/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.vector
import Mathlib.data.list.nodup
import Mathlib.data.list.of_fn
import Mathlib.control.applicative
import Mathlib.PostPort

universes u_1 u_2 u u_3

namespace Mathlib

/-!
# Additional theorems about the `vector` type

This file introduces the infix notation `::ᵥ` for `vector.cons`.
-/

namespace vector

infixr:67 "::ᵥ" => Mathlib.vector.cons

protected instance inhabited {n : ℕ} {α : Type u_1} [Inhabited α] : Inhabited (vector α n) :=
  { default := of_fn fun (_x : fin n) => Inhabited.default }

theorem to_list_injective {n : ℕ} {α : Type u_1} : function.injective to_list :=
  subtype.val_injective

/-- Two `v w : vector α n` are equal iff they are equal at every single index. -/
theorem ext {n : ℕ} {α : Type u_1} {v : vector α n} {w : vector α n}
    (h : ∀ (m : fin n), nth v m = nth w m) : v = w :=
  sorry

/-- The empty `vector` is a `subsingleton`. -/
protected instance zero_subsingleton {α : Type u_1} : subsingleton (vector α 0) :=
  subsingleton.intro fun (_x _x_1 : vector α 0) => ext fun (m : fin 0) => fin.elim0 m

@[simp] theorem cons_val {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) :
    subtype.val (a::ᵥv) = a :: subtype.val v :=
  sorry

@[simp] theorem cons_head {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : head (a::ᵥv) = a :=
  sorry

@[simp] theorem cons_tail {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : tail (a::ᵥv) = v :=
  sorry

@[simp] theorem to_list_of_fn {α : Type u_1} {n : ℕ} (f : fin n → α) :
    to_list (of_fn f) = list.of_fn f :=
  sorry

@[simp] theorem mk_to_list {n : ℕ} {α : Type u_1} (v : vector α n)
    (h : list.length (to_list v) = n) : { val := to_list v, property := h } = v :=
  sorry

@[simp] theorem to_list_map {n : ℕ} {α : Type u_1} {β : Type u_2} (v : vector α n) (f : α → β) :
    to_list (map f v) = list.map f (to_list v) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = n) =>
      Eq.refl (to_list (map f { val := v_val, property := v_property }))

theorem nth_eq_nth_le {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) :
    nth v i =
        list.nth_le (to_list v) (subtype.val i)
          (eq.mpr
            (id (Eq._oldrec (Eq.refl (subtype.val i < list.length (to_list v))) (to_list_length v)))
            (subtype.property i)) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = n) =>
      idRhs
        (nth { val := v_val, property := v_property } i =
          nth { val := v_val, property := v_property } i)
        rfl

@[simp] theorem nth_map {n : ℕ} {α : Type u_1} {β : Type u_2} (v : vector α n) (f : α → β)
    (i : fin n) : nth (map f v) i = f (nth v i) :=
  sorry

@[simp] theorem nth_of_fn {α : Type u_1} {n : ℕ} (f : fin n → α) (i : fin n) :
    nth (of_fn f) i = f i :=
  sorry

@[simp] theorem of_fn_nth {n : ℕ} {α : Type u_1} (v : vector α n) : of_fn (nth v) = v := sorry

@[simp] theorem nth_tail {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) (i : fin n) :
    nth (tail v) i = nth v (fin.succ i) :=
  sorry

@[simp] theorem tail_val {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) :
    subtype.val (tail v) = list.tail (subtype.val v) :=
  sorry

/-- The `tail` of a `nil` vector is `nil`. -/
@[simp] theorem tail_nil {α : Type u_1} : tail nil = nil := rfl

/-- The `tail` of a vector made up of one element is `nil`. -/
@[simp] theorem singleton_tail {α : Type u_1} (v : vector α 1) : tail v = nil :=
  eq.mpr (id (propext (eq_iff_true_of_subsingleton (tail v) nil))) trivial

@[simp] theorem tail_of_fn {α : Type u_1} {n : ℕ} (f : fin (Nat.succ n) → α) :
    tail (of_fn f) = of_fn fun (i : fin (Nat.succ n - 1)) => f (fin.succ i) :=
  sorry

/-- The list that makes up a `vector` made up of a single element,
retrieved via `to_list`, is equal to the list of that single element. -/
@[simp] theorem to_list_singleton {α : Type u_1} (v : vector α 1) : to_list v = [head v] := sorry

/-- Mapping under `id` does not change a vector. -/
@[simp] theorem map_id {α : Type u_1} {n : ℕ} (v : vector α n) : map id v = v := sorry

theorem mem_iff_nth {n : ℕ} {α : Type u_1} {a : α} {v : vector α n} :
    a ∈ to_list v ↔ ∃ (i : fin n), nth v i = a :=
  sorry

theorem nodup_iff_nth_inj {n : ℕ} {α : Type u_1} {v : vector α n} :
    list.nodup (to_list v) ↔ function.injective (nth v) :=
  sorry

@[simp] theorem nth_mem {n : ℕ} {α : Type u_1} (i : fin n) (v : vector α n) : nth v i ∈ to_list v :=
  sorry

theorem head'_to_list {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) :
    list.head' (to_list v) = some (head v) :=
  sorry

def reverse {n : ℕ} {α : Type u_1} (v : vector α n) : vector α n :=
  { val := list.reverse (to_list v), property := sorry }

/-- The `list` of a vector after a `reverse`, retrieved by `to_list` is equal
to the `list.reverse` after retrieving a vector's `to_list`. -/
theorem to_list_reverse {n : ℕ} {α : Type u_1} {v : vector α n} :
    to_list (reverse v) = list.reverse (to_list v) :=
  rfl

@[simp] theorem nth_zero {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) : nth v 0 = head v :=
  sorry

@[simp] theorem head_of_fn {α : Type u_1} {n : ℕ} (f : fin (Nat.succ n) → α) :
    head (of_fn f) = f 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (head (of_fn f) = f 0)) (Eq.symm (nth_zero (of_fn f)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth (of_fn f) 0 = f 0)) (nth_of_fn f 0))) (Eq.refl (f 0)))

@[simp] theorem nth_cons_zero {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : nth (a::ᵥv) 0 = a :=
  sorry

/-- Accessing the `nth` element of a vector made up
of one element `x : α` is `x` itself. -/
@[simp] theorem nth_cons_nil {α : Type u_1} {ix : fin 1} (x : α) : nth (x::ᵥnil) ix = x := sorry

@[simp] theorem nth_cons_succ {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) (i : fin n) :
    nth (a::ᵥv) (fin.succ i) = nth v i :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (nth (a::ᵥv) (fin.succ i) = nth v i)) (Eq.symm (nth_tail (a::ᵥv) i))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth (tail (a::ᵥv)) i = nth v i)) (tail_cons a v)))
      (Eq.refl (nth v i)))

/-- The last element of a `vector`, given that the vector is at least one element. -/
def last {n : ℕ} {α : Type u_1} (v : vector α (n + 1)) : α := nth v (fin.last n)

/-- The last element of a `vector`, given that the vector is at least one element. -/
theorem last_def {n : ℕ} {α : Type u_1} {v : vector α (n + 1)} : last v = nth v (fin.last n) := rfl

/-- The `last` element of a vector is the `head` of the `reverse` vector. -/
theorem reverse_nth_zero {n : ℕ} {α : Type u_1} {v : vector α (n + 1)} :
    head (reverse v) = last v :=
  sorry

/--
Construct a `vector β (n + 1)` from a `vector α n` by scanning `f : β → α → β`
from the "left", that is, from 0 to `fin.last n`, using `b : β` as the starting value.
-/
def scanl {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) :
    vector β (n + 1) :=
  { val := list.scanl f b (to_list v), property := sorry }

/-- Providing an empty vector to `scanl` gives the starting value `b : β`. -/
@[simp] theorem scanl_nil {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) :
    scanl f b nil = b::ᵥnil :=
  rfl

/--
The recursive step of `scanl` splits a vector `x ::ᵥ v : vector α (n + 1)`
into the provided starting value `b : β` and the recursed `scanl`
`f b x : β` as the starting value.

This lemma is the `cons` version of `scanl_nth`.
-/
@[simp] theorem scanl_cons {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    (v : vector α n) (x : α) : scanl f b (x::ᵥv) = b::ᵥscanl f (f b x) v :=
  sorry

/--
The underlying `list` of a `vector` after a `scanl` is the `list.scanl`
of the underlying `list` of the original `vector`.
-/
@[simp] theorem scanl_val {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    {v : vector α n} : subtype.val (scanl f b v) = list.scanl f b (subtype.val v) :=
  sorry

/--
The `to_list` of a `vector` after a `scanl` is the `list.scanl`
of the `to_list` of the original `vector`.
-/
@[simp] theorem to_list_scanl {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    (v : vector α n) : to_list (scanl f b v) = list.scanl f b (to_list v) :=
  rfl

/--
The recursive step of `scanl` splits a vector made up of a single element
`x ::ᵥ nil : vector α 1` into a `vector` of the provided starting value `b : β`
and the mapped `f b x : β` as the last value.
-/
@[simp] theorem scanl_singleton {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    (v : vector α 1) : scanl f b v = b::ᵥf b (head v)::ᵥnil :=
  sorry

/--
The first element of `scanl` of a vector `v : vector α n`,
retrieved via `head`, is the starting value `b : β`.
-/
@[simp] theorem scanl_head {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    (v : vector α n) : head (scanl f b v) = b :=
  sorry

/--
For an index `i : fin n`, the `nth` element of `scanl` of a
vector `v : vector α n` at `i.succ`, is equal to the application
function `f : β → α → β` of the `i.cast_succ` element of
`scanl f b v` and `nth v i`.

This lemma is the `nth` version of `scanl_cons`.
-/
@[simp] theorem scanl_nth {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β)
    (v : vector α n) (i : fin n) :
    nth (scanl f b v) (fin.succ i) = f (nth (scanl f b v) (coe_fn fin.cast_succ i)) (nth v i) :=
  sorry

def m_of_fn {m : Type u → Type u_1} [Monad m] {α : Type u} {n : ℕ} :
    (fin n → m α) → m (vector α n) :=
  sorry

theorem m_of_fn_pure {m : Type u_1 → Type u_2} [Monad m] [is_lawful_monad m] {α : Type u_1} {n : ℕ}
    (f : fin n → α) : (m_of_fn fun (i : fin n) => pure (f i)) = pure (of_fn f) :=
  sorry

def mmap {m : Type u → Type u_1} [Monad m] {α : Type u_2} {β : Type u} (f : α → m β) {n : ℕ} :
    vector α n → m (vector β n) :=
  sorry

@[simp] theorem mmap_nil {m : Type u_1 → Type u_2} [Monad m] {α : Type u_3} {β : Type u_1}
    (f : α → m β) : mmap f nil = pure nil :=
  rfl

@[simp] theorem mmap_cons {m : Type u_1 → Type u_2} [Monad m] {α : Type u_3} {β : Type u_1}
    (f : α → m β) (a : α) {n : ℕ} (v : vector α n) :
    mmap f (a::ᵥv) =
        do
          let h' ← f a
          let t' ← mmap f v
          pure (h'::ᵥt') :=
  sorry

/-- Define `C v` by induction on `v : vector α (n + 1)`, a vector of
at least one element.
This function has two arguments: `h0` handles the base case on `C nil`,
and `hs` defines the inductive step using `∀ x : α, C v → C (x ::ᵥ v)`. -/
def induction_on {α : Type u_1} {n : ℕ} {C : {n : ℕ} → vector α n → Sort u_2} (v : vector α (n + 1))
    (h0 : C nil) (hs : {n : ℕ} → {x : α} → {w : vector α n} → C w → C (x::ᵥw)) : C v :=
  Nat.rec (fun (v : vector α (0 + 1)) => eq.mpr sorry (eq.mpr sorry (hs h0)))
    (fun (n : ℕ) (hn : (v : vector α (n + 1)) → C v) (v : vector α (Nat.succ n + 1)) =>
      eq.mpr sorry (hs (hn (tail v))))
    n v

def to_array {n : ℕ} {α : Type u_1} : vector α n → array n α := sorry

def insert_nth {n : ℕ} {α : Type u_1} (a : α) (i : fin (n + 1)) (v : vector α n) :
    vector α (n + 1) :=
  { val := list.insert_nth (↑i) a (subtype.val v), property := sorry }

theorem insert_nth_val {n : ℕ} {α : Type u_1} {a : α} {i : fin (n + 1)} {v : vector α n} :
    subtype.val (insert_nth a i v) = list.insert_nth (subtype.val i) a (subtype.val v) :=
  rfl

@[simp] theorem remove_nth_val {n : ℕ} {α : Type u_1} {i : fin n} {v : vector α n} :
    subtype.val (remove_nth i v) = list.remove_nth (subtype.val v) ↑i :=
  sorry

theorem remove_nth_insert_nth {n : ℕ} {α : Type u_1} {a : α} {v : vector α n} {i : fin (n + 1)} :
    remove_nth i (insert_nth a i v) = v :=
  subtype.eq (list.remove_nth_insert_nth (subtype.val i) (subtype.val v))

theorem remove_nth_insert_nth_ne {n : ℕ} {α : Type u_1} {a : α} {v : vector α (n + 1)}
    {i : fin (n + bit0 1)} {j : fin (n + bit0 1)} (h : i ≠ j) :
    remove_nth i (insert_nth a j v) =
        insert_nth a (fin.pred_above i j (ne.symm h)) (remove_nth (fin.pred_above j i h) v) :=
  sorry

theorem insert_nth_comm {n : ℕ} {α : Type u_1} (a : α) (b : α) (i : fin (n + 1)) (j : fin (n + 1))
    (h : i ≤ j) (v : vector α n) :
    insert_nth b (fin.succ j) (insert_nth a i v) =
        insert_nth a (coe_fn fin.cast_succ i) (insert_nth b j v) :=
  sorry

/-- `update_nth v n a` replaces the `n`th element of `v` with `a` -/
def update_nth {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) (a : α) : vector α n :=
  { val := list.update_nth (subtype.val v) (subtype.val i) a, property := sorry }

@[simp] theorem nth_update_nth_same {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) (a : α) :
    nth (update_nth v i a) i = a :=
  sorry

theorem nth_update_nth_of_ne {n : ℕ} {α : Type u_1} {v : vector α n} {i : fin n} {j : fin n}
    (h : i ≠ j) (a : α) : nth (update_nth v i a) j = nth v j :=
  sorry

theorem nth_update_nth_eq_if {n : ℕ} {α : Type u_1} {v : vector α n} {i : fin n} {j : fin n}
    (a : α) : nth (update_nth v i a) j = ite (i = j) a (nth v j) :=
  sorry

end vector

namespace vector

protected def traverse {n : ℕ} {F : Type u → Type u} [Applicative F] {α : Type u} {β : Type u}
    (f : α → F β) : vector α n → F (vector β n) :=
  sorry

@[simp] protected theorem traverse_def {n : ℕ} {F : Type u → Type u} [Applicative F]
    [is_lawful_applicative F] {α : Type u} {β : Type u} (f : α → F β) (x : α) (xs : vector α n) :
    vector.traverse f (x::ᵥxs) = cons <$> f x <*> vector.traverse f xs :=
  subtype.cases_on xs
    fun (xs : List α) (xs_property : list.length xs = n) =>
      eq.drec
        (Eq.refl (vector.traverse f (x::ᵥ{ val := xs, property := Eq.refl (list.length xs) })))
        xs_property

protected theorem id_traverse {n : ℕ} {α : Type u} (x : vector α n) : vector.traverse id.mk x = x :=
  sorry

protected theorem comp_traverse {n : ℕ} {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u} {β : Type u}
    {γ : Type u} (f : β → F γ) (g : α → G β) (x : vector α n) :
    vector.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (vector.traverse f <$> vector.traverse g x) :=
  sorry

protected theorem traverse_eq_map_id {n : ℕ} {α : Type u_1} {β : Type u_1} (f : α → β)
    (x : vector α n) : vector.traverse (id.mk ∘ f) x = id.mk (map f x) :=
  sorry

protected theorem naturality {n : ℕ} {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} {β : Type u} (f : α → F β) (x : vector α n) :
    coe_fn η (vector β n) (vector.traverse f x) = vector.traverse (coe_fn η β ∘ f) x :=
  sorry

protected instance flip.traversable {n : ℕ} : traversable (flip vector n) :=
  traversable.mk vector.traverse

protected instance flip.is_lawful_traversable {n : ℕ} : is_lawful_traversable (flip vector n) :=
  is_lawful_traversable.mk vector.id_traverse vector.comp_traverse vector.traverse_eq_map_id
    vector.naturality

end Mathlib


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.dynamics.fixed_points.basic
import Mathlib.data.set.lattice
import Mathlib.data.pnat.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Periodic points

A point `x : α` is a periodic point of `f : α → α` of period `n` if `f^[n] x = x`.

## Main definitions

* `is_periodic_pt f n x` : `x` is a periodic point of `f` of period `n`, i.e. `f^[n] x = x`.
  We do not require `n > 0` in the definition.
* `pts_of_period f n` : the set `{x | is_periodic_pt f n x}`. Note that `n` is not required to
  be the minimal period of `x`.
* `periodic_pts f` : the set of all periodic points of `f`.
* `minimal_period f x` : the minimal period of a point `x` under an endomorphism `f` or zero
  if `x` is not a periodic point of `f`.

## Main statements

We provide “dot syntax”-style operations on terms of the form `h : is_periodic_pt f n x` including
arithmetic operations on `n` and `h.map (hg : semiconj_by g f f')`. We also prove that `f`
is bijective on each set `pts_of_period f n` and on `periodic_pts f`. Finally, we prove that `x`
is a periodic point of `f` of period `n` if and only if `minimal_period f x | n`.

## References

* https://en.wikipedia.org/wiki/Periodic_point

-/

namespace function

/-- A point `x` is a periodic point of `f : α → α` of period `n` if `f^[n] x = x`.
Note that we do not require `0 < n` in this definition. Many theorems about periodic points
need this assumption. -/
def is_periodic_pt {α : Type u_1} (f : α → α) (n : ℕ) (x : α) :=
  is_fixed_pt (nat.iterate f n) x

/-- A fixed point of `f` is a periodic point of `f` of any prescribed period. -/
theorem is_fixed_pt.is_periodic_pt {α : Type u_1} {f : α → α} {x : α} (hf : is_fixed_pt f x) (n : ℕ) : is_periodic_pt f n x :=
  is_fixed_pt.iterate hf n

/-- For the identity map, all points are periodic. -/
theorem is_periodic_id {α : Type u_1} (n : ℕ) (x : α) : is_periodic_pt id n x :=
  is_fixed_pt.is_periodic_pt (is_fixed_pt_id x) n

/-- Any point is a periodic point of period `0`. -/
theorem is_periodic_pt_zero {α : Type u_1} (f : α → α) (x : α) : is_periodic_pt f 0 x :=
  is_fixed_pt_id x

namespace is_periodic_pt

protected instance decidable {α : Type u_1} [DecidableEq α] {f : α → α} {n : ℕ} {x : α} : Decidable (is_periodic_pt f n x) :=
  is_fixed_pt.decidable

protected theorem is_fixed_pt {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hf : is_periodic_pt f n x) : is_fixed_pt (nat.iterate f n) x :=
  hf

protected theorem map {α : Type u_1} {β : Type u_2} {fa : α → α} {fb : β → β} {x : α} {n : ℕ} (hx : is_periodic_pt fa n x) {g : α → β} (hg : semiconj g fa fb) : is_periodic_pt fb n (g x) :=
  is_fixed_pt.map hx (semiconj.iterate_right hg n)

theorem apply_iterate {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hx : is_periodic_pt f n x) (m : ℕ) : is_periodic_pt f n (nat.iterate f m x) :=
  is_periodic_pt.map hx (commute.iterate_self f m)

protected theorem apply {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hx : is_periodic_pt f n x) : is_periodic_pt f n (f x) :=
  apply_iterate hx 1

protected theorem add {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hn : is_periodic_pt f n x) (hm : is_periodic_pt f m x) : is_periodic_pt f (n + m) x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_periodic_pt f (n + m) x)) (equations._eqn_1 f (n + m) x)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (is_fixed_pt (nat.iterate f (n + m)) x)) (iterate_add f n m)))
      (is_fixed_pt.comp hn hm))

theorem left_of_add {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hn : is_periodic_pt f (n + m) x) (hm : is_periodic_pt f m x) : is_periodic_pt f n x := sorry

theorem right_of_add {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hn : is_periodic_pt f (n + m) x) (hm : is_periodic_pt f n x) : is_periodic_pt f m x :=
  left_of_add (eq.mp (Eq._oldrec (Eq.refl (is_periodic_pt f (n + m) x)) (add_comm n m)) hn) hm

protected theorem sub {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) : is_periodic_pt f (m - n) x := sorry

protected theorem mul_const {α : Type u_1} {f : α → α} {x : α} {m : ℕ} (hm : is_periodic_pt f m x) (n : ℕ) : is_periodic_pt f (m * n) x := sorry

protected theorem const_mul {α : Type u_1} {f : α → α} {x : α} {m : ℕ} (hm : is_periodic_pt f m x) (n : ℕ) : is_periodic_pt f (n * m) x := sorry

theorem trans_dvd {α : Type u_1} {f : α → α} {x : α} {m : ℕ} (hm : is_periodic_pt f m x) {n : ℕ} (hn : m ∣ n) : is_periodic_pt f n x := sorry

protected theorem iterate {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hf : is_periodic_pt f n x) (m : ℕ) : is_periodic_pt (nat.iterate f m) n x := sorry

protected theorem mod {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) : is_periodic_pt f (m % n) x :=
  left_of_add (eq.mp (Eq._oldrec (Eq.refl (is_periodic_pt f m x)) (Eq.symm (nat.mod_add_div m n))) hm)
    (is_periodic_pt.mul_const hn (m / n))

protected theorem gcd {α : Type u_1} {f : α → α} {x : α} {m : ℕ} {n : ℕ} (hm : is_periodic_pt f m x) (hn : is_periodic_pt f n x) : is_periodic_pt f (nat.gcd m n) x := sorry

/-- If `f` sends two periodic points `x` and `y` of the same positive period to the same point,
then `x = y`. For a similar statement about points of different periods see `eq_of_apply_eq`. -/
theorem eq_of_apply_eq_same {α : Type u_1} {f : α → α} {x : α} {y : α} {n : ℕ} (hx : is_periodic_pt f n x) (hy : is_periodic_pt f n y) (hn : 0 < n) (h : f x = f y) : x = y := sorry

/-- If `f` sends two periodic points `x` and `y` of positive periods to the same point,
then `x = y`. -/
theorem eq_of_apply_eq {α : Type u_1} {f : α → α} {x : α} {y : α} {m : ℕ} {n : ℕ} (hx : is_periodic_pt f m x) (hy : is_periodic_pt f n y) (hm : 0 < m) (hn : 0 < n) (h : f x = f y) : x = y :=
  eq_of_apply_eq_same (is_periodic_pt.mul_const hx n) (is_periodic_pt.const_mul hy m) (mul_pos hm hn) h

end is_periodic_pt

/-- The set of periodic points of a given (possibly non-minimal) period. -/
def pts_of_period {α : Type u_1} (f : α → α) (n : ℕ) : set α :=
  set_of fun (x : α) => is_periodic_pt f n x

@[simp] theorem mem_pts_of_period {α : Type u_1} {f : α → α} {x : α} {n : ℕ} : x ∈ pts_of_period f n ↔ is_periodic_pt f n x :=
  iff.rfl

theorem semiconj.maps_to_pts_of_period {α : Type u_1} {β : Type u_2} {fa : α → α} {fb : β → β} {g : α → β} (h : semiconj g fa fb) (n : ℕ) : set.maps_to g (pts_of_period fa n) (pts_of_period fb n) :=
  semiconj.maps_to_fixed_pts (semiconj.iterate_right h n)

theorem bij_on_pts_of_period {α : Type u_1} (f : α → α) {n : ℕ} (hn : 0 < n) : set.bij_on f (pts_of_period f n) (pts_of_period f n) := sorry

theorem directed_pts_of_period_pnat {α : Type u_1} (f : α → α) : directed has_subset.subset fun (n : ℕ+) => pts_of_period f ↑n := sorry

/-- The set of periodic points of a map `f : α → α`. -/
def periodic_pts {α : Type u_1} (f : α → α) : set α :=
  set_of fun (x : α) => ∃ (n : ℕ), ∃ (H : n > 0), is_periodic_pt f n x

theorem mk_mem_periodic_pts {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hn : 0 < n) (hx : is_periodic_pt f n x) : x ∈ periodic_pts f :=
  Exists.intro n (Exists.intro hn hx)

theorem mem_periodic_pts {α : Type u_1} {f : α → α} {x : α} : x ∈ periodic_pts f ↔ ∃ (n : ℕ), ∃ (H : n > 0), is_periodic_pt f n x :=
  iff.rfl

theorem bUnion_pts_of_period {α : Type u_1} (f : α → α) : (set.Union fun (n : ℕ) => set.Union fun (H : n > 0) => pts_of_period f n) = periodic_pts f := sorry

theorem Union_pnat_pts_of_period {α : Type u_1} (f : α → α) : (set.Union fun (n : ℕ+) => pts_of_period f ↑n) = periodic_pts f :=
  Eq.trans supr_subtype (bUnion_pts_of_period f)

theorem bij_on_periodic_pts {α : Type u_1} (f : α → α) : set.bij_on f (periodic_pts f) (periodic_pts f) :=
  Union_pnat_pts_of_period f ▸
    set.bij_on_Union_of_directed (directed_pts_of_period_pnat f) fun (i : ℕ+) => bij_on_pts_of_period f (pnat.pos i)

theorem semiconj.maps_to_periodic_pts {α : Type u_1} {β : Type u_2} {fa : α → α} {fb : β → β} {g : α → β} (h : semiconj g fa fb) : set.maps_to g (periodic_pts fa) (periodic_pts fb) := sorry

/-- Minimal period of a point `x` under an endomorphism `f`. If `x` is not a periodic point of `f`,
then `minimal_period f x = 0`. -/
def minimal_period {α : Type u_1} (f : α → α) (x : α) : ℕ :=
  dite (x ∈ periodic_pts f) (fun (h : x ∈ periodic_pts f) => nat.find h) fun (h : ¬x ∈ periodic_pts f) => 0

theorem is_periodic_pt_minimal_period {α : Type u_1} (f : α → α) (x : α) : is_periodic_pt f (minimal_period f x) x := sorry

theorem minimal_period_pos_of_mem_periodic_pts {α : Type u_1} {f : α → α} {x : α} (hx : x ∈ periodic_pts f) : 0 < minimal_period f x := sorry

theorem is_periodic_pt.minimal_period_pos {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hn : 0 < n) (hx : is_periodic_pt f n x) : 0 < minimal_period f x :=
  minimal_period_pos_of_mem_periodic_pts (mk_mem_periodic_pts hn hx)

theorem minimal_period_pos_iff_mem_periodic_pts {α : Type u_1} {f : α → α} {x : α} : 0 < minimal_period f x ↔ x ∈ periodic_pts f := sorry

theorem is_periodic_pt.minimal_period_le {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hn : 0 < n) (hx : is_periodic_pt f n x) : minimal_period f x ≤ n := sorry

theorem is_periodic_pt.eq_zero_of_lt_minimal_period {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hx : is_periodic_pt f n x) (hn : n < minimal_period f x) : n = 0 :=
  Eq.symm
    (or.resolve_right (eq_or_lt_of_le (nat.zero_le n))
      fun (hn0 : 0 < n) => iff.mpr not_lt (is_periodic_pt.minimal_period_le hn0 hx) hn)

theorem is_periodic_pt.minimal_period_dvd {α : Type u_1} {f : α → α} {x : α} {n : ℕ} (hx : is_periodic_pt f n x) : minimal_period f x ∣ n := sorry

theorem is_periodic_pt_iff_minimal_period_dvd {α : Type u_1} {f : α → α} {x : α} {n : ℕ} : is_periodic_pt f n x ↔ minimal_period f x ∣ n :=
  { mp := is_periodic_pt.minimal_period_dvd,
    mpr := fun (h : minimal_period f x ∣ n) => is_periodic_pt.trans_dvd (is_periodic_pt_minimal_period f x) h }


import tactic
import init.meta.expr
import init.meta.lean.parser

open tactic expr

-- Like expr.get_pis, but uses mvars instead of local variables.
meta def get_pi_mvars : expr → tactic (list expr × expr)
| (pi n bi d b)  :=
do mv ← mk_meta_var d,
   (mvs, b) ← get_pi_mvars (b.instantiate_var mv),
   pure (mv::mvs, b)
| e              := pure ([], e)

-- returns expr and its local variables
meta def mk_mvar_app_aux : expr → list expr → list expr → tactic (expr × list expr)
| g (m::ms) local_vars := do
  g ← instantiate_mvars g,
  (loc::locs, _) ← infer_type g >>= mk_local_pis,
  assigned ← is_assigned m,
  match assigned with
  | tt := mk_mvar_app_aux (app g m) ms local_vars
  | ff := do
    tm ← infer_type m,
    tm ← instantiate_mvars tm,
    tloc ← infer_type loc,
    unify tm tloc,
    unify m loc,
    mk_mvar_app_aux (app g loc) ms (loc::local_vars)
  end
| g [] local_vars := pure (g, list.reverse local_vars)

-- Given a function-type expression `f`, and a list of mvars `ms`, construct the application of `f` to `ms`
-- where assigned mvars are replaced by their instantiations and unassigned mvars are turned into local variables.
meta def mk_mvar_app : expr → list expr → tactic (expr × list expr) :=
λ e ms, mk_mvar_app_aux e ms []

-- Modus ponens in the `n`th argument of `f` usinf `g`.
meta def mp_nth_arg (f g : expr) (n : ℕ) : tactic expr :=
do tf ← infer_type f,
  tg ← infer_type g,
  (gmvs, gconc) ← get_pi_mvars tg,
  gtys ← mmap infer_type gmvs,
  let replace : list bool := list.map (= n) $ list.range (list.length gtys),
  match list.nth gtys n with
  | some t := do
    (fmvs, fconc) ← get_pi_mvars tf,
    unify fconc t,
    gmvs ← mmap (λ a, match a with
    | (m, tt) := do (app_of_list f <$> (mmap instantiate_mvars fmvs)) >>= unify m, pure m
    | (m, ff) := pure m
    end
    ) (list.zip gmvs replace),
    (res, locs) ← mk_mvar_app g gmvs,
    res ← instantiate_mvars res,
    pure $ expr.lambdas locs res
   | none := failed
   end

/- Apply modus ponens once in each argument in which it is possible, returning a list consisting of the results
   if possible and none otherwise. -/
meta def mp_core (f g : expr) : tactic (list (option expr)) :=
do tg ← infer_type g,
  let n := pi_arity tg,
  mmap (λ k, try_core $ mp_nth_arg f g k) (list.range n)

def option_list_to_list {α : Type*} (l : list (option α)) : list α :=
list.foldl list.append [] (list.map option.to_list l)

/- Apply modus ponens once in each argument in which it is possible, returning the list of results. -/
meta def mp_core' (f g : expr) : tactic (list expr) :=
option_list_to_list <$> mp_core f g

/- Define the interactive `mp` tactic-/

open interactive
open lean.parser (ident tk)

/- Turn numbers in strings to lowercase indices. -/
meta def to_lower_digits (s : string) : string :=
list.foldl (++) "" $
(list.map $ (λ (c : char), match to_string c with
| "0" := "₀"
| "1" := "₁"
| "2" := "₂"
| "3" := "₃"
| "4" := "₄"
| "5" := "₅"
| "6" := "₆"
| "7" := "₇"
| "8" := "₈"
| "9" := "₉"
| x := x
end
)) s.to_list

/- Apply the local hyposthesis `f` to an argument (assumption) of `g`, and add the resulting statements to the
   context, optionally using the name `nm` for the new hypotheses. If there are several possibilities, do it
   for each possibility once and add subscripts to the new hypothesis names. -/
meta def tactic.interactive.mp (f g : parse ident)
(nm : parse (optional (tk "with" *> ident)))
: tactic unit :=
-- Note: switched order w.r.t. to `mp_core`
let nm := nm.get_or_else `this in
do f ← get_local f,
  g ← get_local g,
  hs ← mp_core' g f,
  let num_new_hyps := list.length hs,
  let inds := list.range num_new_hyps,

  mmap ( λ (hi : expr × nat) ,
    match hi with
    | (h, i) := do
      let nm_i :=  mk_simple_name $ (name.to_string nm) ++ (to_lower_digits $ to_string i),
      let nm' := if num_new_hyps = 1 then nm else nm_i,
      interactive.have nm' none ``(%%h)
    end
  ) (list.zip hs inds),
  pure ()

/-- EXAMPLE -/

def P : ℕ → ℕ → Prop := sorry
def Q : ℕ → ℕ → ℕ → Prop := sorry

example (f : ∀ a, P a a) (g : ∀ a b c, P a b → P b c → Q a b c) (g' : ∀ a b, P a b → Q a a b): true :=
begin
  mp g f with H,        -- give the new hypotheses names starting with `H`
  mp g f,               -- use `this` instead
  mp g' f,              -- no indices if there is only one possibility
  mp H₀ f with HH₀,     -- can be applied multiple times
  mp H₁ f with HH₁,
  trivial
end

def PP : Prop := sorry
def QQ : Prop := sorry

/- The argument order was chosen such that `mp g f` is like `g(f)` or `g ∘ f` (but that can be changed). -/
example (f : PP) (g : PP → QQ) : QQ := by mp g f; assumption


import category_theory.limits.shapes.comm_sq

open category_theory.limits

namespace category_theory

variables {C : Type*} [category C]

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}
/-
lemma of_horiz_is_iso [is_iso f] [is_iso inr] (sq : comm_sq f g inl inr) :
  is_pushout f g inl inr := of_is_colimit' sq
begin
  refine pushout_cocone.is_colimit.mk _ (λ s, inv inr ≫ s.inr) (λ s, _) (by tidy) (by tidy),
  simp only [← cancel_epi f, s.condition, sq.w_assoc, is_iso.hom_inv_id_assoc],
end

lemma of_vert_is_iso [is_iso g] [is_iso inl] (sq : comm_sq f g inl inr) :
  is_pushout f g inl inr := (of_horiz_is_iso sq.flip).flip-/

lemma of_coprod_inl_with_id {A B : C} (f : A ⟶ B) (X : C) [has_binary_coproduct A X]
  [has_binary_coproduct B X] :
  is_pushout coprod.inl f (coprod.map f (𝟙 X)) coprod.inl :=
is_pushout.of_is_colimit' (comm_sq.mk (coprod.inl_map _ _))
(pushout_cocone.is_colimit_aux _ (λ s, coprod.desc s.inr (coprod.inr ≫ s.inl))
(λ s, begin
  dsimp [comm_sq.cocone],
  ext,
  { simp only [coprod.map_desc, coprod.inl_desc, s.condition], },
  { simp only [coprod.map_desc, category.id_comp, coprod.inr_desc], },
end)
(λ s, by { dsimp [comm_sq.cocone], simp only [coprod.inl_desc], })
(λ s m hm, begin
  dsimp [comm_sq.cocone],
  ext,
  { simpa only [coprod.inl_desc] using hm walking_span.right, },
  { have h := coprod.inr ≫= hm walking_span.left,
    dsimp [comm_sq.cocone] at h,
    simpa only [coprod.inr_desc, coprod.inr_map_assoc, category.id_comp] using h, },
end))

end is_pushout

end category_theory


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.Init.Logic

/-!
# Unbundled algebra classes

These classes are part of an incomplete refactor described
[here on the github Wiki](https://github.com/leanprover/lean/wiki/Refactoring-structures#encoding-the-algebraic-hierarchy-1).
However a subset of them are widely used in mathlib3,
and it has been tricky to clean this up as this file was in core Lean 3.

By themselves, these classes are not good replacements for the `monoid` / `group` etc structures
provided by mathlib, as they are not discoverable by `simp` unlike the current lemmas due to there
being little to index on.

## Porting notes:
This file is ancient, and it would be good to replace it with a clean version
that provides what mathlib4 actually needs.

I've omitted all the `@[algebra]` attributes, as they are not used elsewhere.

The section `StrictWeakOrder` has been omitted, but I've left the mathport output in place.
Please delete if cleaning up.

I've commented out some classes which we think are completely unused in mathlib.

I've added many of the declarations to `nolints.json`.
If you clean up this file, please add documentation to classes that we are keeping.

Mario made the following analysis of uses in mathlib3:
* `is_symm_op`: unused except for some instances
* `is_commutative`: used a fair amount via some theorems about folds
  (also assuming `is_associative`)
* `is_associative`: ditto, also used in `noncomm_fold`
* `is_left_id`, `is_right_id`: unused except in the mathlib class `is_unital` and in `mono`
  (which looks like it could use `is_unital`)
* `is_left_null`, `is_right_null`: unused
* `is_left_cancel`, `is_right_cancel`: unused except for instances
* `is_idempotent`: this one is actually used to prove things not directly about `is_idempotent`
* `is_left_distrib`, `is_right_distrib`, `is_left_inv`, `is_right_inv`, `is_cond_left_inv`,
  `is_cond_right_inv`: unused
* `is_distinct`: unused (although we reinvented this one as `nontrivial`)
* `is_irrefl`, `is_refl`, `is_symm`, `is_trans`: significant usage
* `is_asymm`, `is_antisymm`, `is_total`, `is_strict_order`: a lot of uses but all in order theory
  and it's unclear how much could not be transferred to another typeclass
* `is_preorder`: unused except for instances
  (except `antisymmetrization`, maybe it could be transferred)
* `is_total_preorder`, `is_partial_order`: unused except for instances
* `is_linear_order`: unused except for instances
* `is_equiv`: unused except for instances (most uses can use `equivalence` instead)
* `is_per`: unused
* `is_incomp_trans`: unused
* `is_strict_weak_order`: significant usage (most of it on `rbmap`, could be transferred)
* `is_trichotomous`: some usage
* `is_strict_total_order`: looks like the only usage is in `rbmap` again
-/

universe u v

class IsSymmOp (α : Type u) (β : Type v) (op : α → α → β) : Prop where
  symm_op : ∀ a b, op a b = op b a

/-- A commutative binary operation. -/
class IsCommutative (α : Type u) (op : α → α → α) : Prop where
  comm : ∀ a b, op a b = op b a

instance [IsCommutative α op] : Lean.IsCommutative op where
  comm := IsCommutative.comm

instance isSymmOp_of_isCommutative (α : Type u) (op : α → α → α)
    [IsCommutative α op] : IsSymmOp α α op where symm_op :=
  IsCommutative.comm

/-- An associative binary operation. -/
class IsAssociative (α : Type u) (op : α → α → α) : Prop where
  assoc : ∀ a b c, op (op a b) c = op a (op b c)

instance [IsAssociative α op] : Lean.IsAssociative op where
  assoc := IsAssociative.assoc

/-- A binary operation with a left identity. -/
class IsLeftId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  left_id : ∀ a, op o a = a

/-- A binary operation with a right identity. -/
class IsRightId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  right_id : ∀ a, op a o = a

instance [IsLeftId α op o] [IsRightId α op o] : Lean.IsNeutral op o where
  left_neutral := IsLeftId.left_id
  right_neutral := IsRightId.right_id

-- -- class IsLeftNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
--   left_null : ∀ a, op o a = o

-- -- class IsRightNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
--   right_null : ∀ a, op a o = o

class IsLeftCancel (α : Type u) (op : α → α → α) : Prop where
  left_cancel : ∀ a b c, op a b = op a c → b = c

class IsRightCancel (α : Type u) (op : α → α → α) : Prop where
  right_cancel : ∀ a b c, op a b = op c b → a = c

class IsIdempotent (α : Type u) (op : α → α → α) : Prop where
  idempotent : ∀ a, op a a = a

instance [IsIdempotent α op] : Lean.IsIdempotent op where
  idempotent := IsIdempotent.idempotent

--class IsLeftDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
--   left_distrib : ∀ a b c, op₁ a (op₂ b c) = op₂ (op₁ a b) (op₁ a c)

-- class IsRightDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
--   right_distrib : ∀ a b c, op₁ (op₂ a b) c = op₂ (op₁ a c) (op₁ b c)

-- class IsLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
--     Prop where
--   left_inv : ∀ a, op (inv a) a = o

-- class IsRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
--     Prop where
--   right_inv : ∀ a, op a (inv a) = o

-- class IsCondLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
--   (p : outParam <| α → Prop) : Prop where
--   left_inv : ∀ a, p a → op (inv a) a = o

-- class IsCondRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
--   (p : outParam <| α → Prop) : Prop where
--   right_inv : ∀ a, p a → op a (inv a) = o

-- class IsDistinct (α : Type u) (a : α) (b : α) : Prop where
--   distinct : a ≠ b

/-
-- The following type class doesn't seem very useful, a regular simp lemma should work for this.
class is_inv (α : Type u) (β : Type v) (f : α → β) (g : out β → α) : Prop :=
(inv : ∀ a, g (f a) = a)

-- The following one can also be handled using a regular simp lemma
class is_idempotent (α : Type u) (f : α → α) : Prop :=
(idempotent : ∀ a, f (f a) = f a)
-/
/-- `IsIrrefl X r` means the binary relation `r` on `X` is irreflexive (that is, `r x x` never
holds). -/
class IsIrrefl (α : Type u) (r : α → α → Prop) : Prop where
  irrefl : ∀ a, ¬r a a

/-- `IsRefl X r` means the binary relation `r` on `X` is reflexive. -/
class IsRefl (α : Type u) (r : α → α → Prop) : Prop where
  refl : ∀ a, r a a

/-- `IsSymm X r` means the binary relation `r` on `X` is symmetric. -/
class IsSymm (α : Type u) (r : α → α → Prop) : Prop where
  symm : ∀ a b, r a b → r b a

/-- The opposite of a symmetric relation is symmetric. -/
instance isSymmOp_of_isSymm (α : Type u) (r : α → α → Prop) [IsSymm α r] :
    IsSymmOp α Prop r where
  symm_op := fun a b ↦ propext <| Iff.intro (IsSymm.symm a b) (IsSymm.symm b a)

/-- `IsAsymm X r` means that the binary relation `r` on `X` is asymmetric, that is,
`r a b → ¬ r b a`. -/
class IsAsymm (α : Type u) (r : α → α → Prop) : Prop where
  asymm : ∀ a b, r a b → ¬r b a

/-- `IsAntisymm X r` means the binary relation `r` on `X` is antisymmetric. -/
class IsAntisymm (α : Type u) (r : α → α → Prop) : Prop where
  antisymm : ∀ a b, r a b → r b a → a = b

/-- `IsTrans X r` means the binary relation `r` on `X` is transitive. -/
class IsTrans (α : Type u) (r : α → α → Prop) : Prop where
  trans : ∀ a b c, r a b → r b c → r a c

instance {α : Type u} {r : α → α → Prop} [IsTrans α r] : Trans r r r :=
  ⟨IsTrans.trans _ _ _⟩

instance {α : Type u} {r : α → α → Prop} [Trans r r r] : IsTrans α r :=
  ⟨fun _ _ _ => Trans.trans⟩

/-- `IsTotal X r` means that the binary relation `r` on `X` is total, that is, that for any
`x y : X` we have `r x y` or `r y x`.-/
class IsTotal (α : Type u) (r : α → α → Prop) : Prop where
  total : ∀ a b, r a b ∨ r b a

/-- `IsPreorder X r` means that the binary relation `r` on `X` is a pre-order, that is, reflexive
and transitive. -/
class IsPreorder (α : Type u) (r : α → α → Prop) extends IsRefl α r, IsTrans α r : Prop

/-- `IsTotalPreorder X r` means that the binary relation `r` on `X` is total and a preorder. -/
class IsTotalPreorder (α : Type u) (r : α → α → Prop) extends IsTrans α r, IsTotal α r : Prop

/-- Every total pre-order is a pre-order. -/
instance isTotalPreorder_isPreorder (α : Type u) (r : α → α → Prop) [s : IsTotalPreorder α r] :
    IsPreorder α r where
  trans := s.trans
  refl := fun a ↦ Or.elim (@IsTotal.total _ r _ a a) id id

/-- `IsPartialOrder X r` means that the binary relation `r` on `X` is a partial order, that is,
`IsPreorder X r` and `IsAntisymm X r`. -/
class IsPartialOrder (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsAntisymm α r : Prop

/-- `IsLinearOrder X r` means that the binary relation `r` on `X` is a linear order, that is,
`IsPartialOrder X r` and `IsTotal X r`. -/
class IsLinearOrder (α : Type u) (r : α → α → Prop) extends IsPartialOrder α r, IsTotal α r : Prop

/-- `IsEquiv X r` means that the binary relation `r` on `X` is an equivalence relation, that
is, `IsPreorder X r` and `IsSymm X r`. -/
class IsEquiv (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsSymm α r : Prop

-- /-- `IsPer X r` means that the binary relation `r` on `X` is a partial equivalence relation, that
-- is, `IsSymm X r` and `IsTrans X r`. -/
-- -- class IsPer (α : Type u) (r : α → α → Prop) extends IsSymm α r, IsTrans α r : Prop

/-- `IsStrictOrder X r` means that the binary relation `r` on `X` is a strict order, that is,
`IsIrrefl X r` and `IsTrans X r`. -/
class IsStrictOrder (α : Type u) (r : α → α → Prop) extends IsIrrefl α r, IsTrans α r : Prop

/-- `IsIncompTrans X lt` means that for `lt` a binary relation on `X`, the incomparable relation
`λ a b, ¬ lt a b ∧ ¬ lt b a` is transitive. -/
class IsIncompTrans (α : Type u) (lt : α → α → Prop) : Prop where
  incomp_trans : ∀ a b c, ¬lt a b ∧ ¬lt b a → ¬lt b c ∧ ¬lt c b → ¬lt a c ∧ ¬lt c a

/-- `IsStrictWeakOrder X lt` means that the binary relation `lt` on `X` is a strict weak order,
that is, `IsStrictOrder X lt` and `IsIncompTrans X lt`. -/
class IsStrictWeakOrder (α : Type u) (lt : α → α → Prop)
  extends IsStrictOrder α lt, IsIncompTrans α lt : Prop

/-- `IsTrichotomous X lt` means that the binary relation `lt` on `X` is trichotomous, that is,
either `lt a b` or `a = b` or `lt b a` for any `a` and `b`. -/
class IsTrichotomous (α : Type u) (lt : α → α → Prop) : Prop where
  trichotomous : ∀ a b, lt a b ∨ a = b ∨ lt b a

/-- `IsStrictTotalOrder X lt` means that the binary relation `lt` on `X` is a strict total order,
that is, `IsTrichotomous X lt` and `IsStrictOrder X lt`. -/
class IsStrictTotalOrder (α : Type u) (lt : α → α → Prop)
  extends IsTrichotomous α lt, IsStrictOrder α lt : Prop

/-- Equality is an equivalence relation. -/
instance eq_isEquiv (α : Type u) : IsEquiv α (· = ·) where
  symm := @Eq.symm _
  trans := @Eq.trans _
  refl := Eq.refl

section

variable {α : Type u} {r : α → α → Prop}

/-- Temporary notation for a relation. -/
local infixl:50 "≺" => r

theorem irrefl [IsIrrefl α r] (a : α) : ¬a ≺ a :=
  IsIrrefl.irrefl a

theorem refl [IsRefl α r] (a : α) : a ≺ a :=
  IsRefl.refl a

theorem trans [IsTrans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c :=
  IsTrans.trans _ _ _

theorem symm [IsSymm α r] {a b : α} : a ≺ b → b ≺ a :=
  IsSymm.symm _ _

theorem antisymm [IsAntisymm α r] {a b : α} : a ≺ b → b ≺ a → a = b :=
  IsAntisymm.antisymm _ _

theorem asymm [IsAsymm α r] {a b : α} : a ≺ b → ¬b ≺ a :=
  IsAsymm.asymm _ _

theorem trichotomous [IsTrichotomous α r] : ∀ a b : α, a ≺ b ∨ a = b ∨ b ≺ a :=
  IsTrichotomous.trichotomous

theorem incomp_trans [IsIncompTrans α r] {a b c : α} :
    ¬a ≺ b ∧ ¬b ≺ a → ¬b ≺ c ∧ ¬c ≺ b → ¬a ≺ c ∧ ¬c ≺ a :=
  IsIncompTrans.incomp_trans _ _ _

instance (priority := 90) isAsymm_of_isTrans_of_isIrrefl [IsTrans α r] [IsIrrefl α r] :
    IsAsymm α r :=
  ⟨fun a _ h₁ h₂ ↦ absurd (_root_.trans h₁ h₂) (irrefl a)⟩

section ExplicitRelationVariants

variable (r)

@[elab_without_expected_type]
theorem irrefl_of [IsIrrefl α r] (a : α) : ¬a ≺ a :=
  irrefl a

@[elab_without_expected_type]
theorem refl_of [IsRefl α r] (a : α) : a ≺ a :=
  refl a

@[elab_without_expected_type]
theorem trans_of [IsTrans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c :=
  _root_.trans

@[elab_without_expected_type]
theorem symm_of [IsSymm α r] {a b : α} : a ≺ b → b ≺ a :=
  symm

@[elab_without_expected_type]
theorem asymm_of [IsAsymm α r] {a b : α} : a ≺ b → ¬b ≺ a :=
  asymm

@[elab_without_expected_type]
theorem total_of [IsTotal α r] (a b : α) : a ≺ b ∨ b ≺ a :=
  IsTotal.total _ _

@[elab_without_expected_type]
theorem trichotomous_of [IsTrichotomous α r] : ∀ a b : α, a ≺ b ∨ a = b ∨ b ≺ a :=
  trichotomous

@[elab_without_expected_type]
theorem incomp_trans_of [IsIncompTrans α r] {a b c : α} :
    ¬a ≺ b ∧ ¬b ≺ a → ¬b ≺ c ∧ ¬c ≺ b → ¬a ≺ c ∧ ¬c ≺ a :=
  incomp_trans

end ExplicitRelationVariants

end

-- Porting note: the `StrictWeakOrder` section has been ommitted.

-- namespace StrictWeakOrder

-- section

-- parameter {α : Type u}{r : α → α → Prop}

-- -- mathport name: «expr ≺ »
-- local infixl:50 "≺" => r

-- def Equiv (a b : α) : Prop :=
--   ¬a ≺ b ∧ ¬b ≺ a

-- parameter [IsStrictWeakOrder α r]

-- -- mathport name: equiv
-- local infixl:50 " ≈ " => equiv

-- theorem erefl (a : α) : a ≈ a :=
--   ⟨irrefl a, irrefl a⟩

-- theorem esymm {a b : α} : a ≈ b → b ≈ a := fun ⟨h₁, h₂⟩ ↦ ⟨h₂, h₁⟩

-- theorem etrans {a b c : α} : a ≈ b → b ≈ c → a ≈ c :=
--   incomp_trans

-- theorem not_lt_of_equiv {a b : α} : a ≈ b → ¬a ≺ b := fun h ↦ h.1

-- theorem not_lt_of_equiv' {a b : α} : a ≈ b → ¬b ≺ a := fun h ↦ h.2

-- instance is_equiv : IsEquiv α equiv where
--   refl := erefl
--   trans := @etrans
--   symm := @esymm

-- end

-- -- mathport name: «expr ≈[ ] »
-- notation:50 -- Notation for the equivalence relation induced by lt
-- a " ≈[" lt "]" b:50 => @Equiv _ lt a b

-- end StrictWeakOrder

theorem isStrictWeakOrder_of_isTotalPreorder {α : Type u} {le : α → α → Prop}
    {lt : α → α → Prop} [DecidableRel le] [IsTotalPreorder α le] (h : ∀ a b, lt a b ↔ ¬le b a) :
    IsStrictWeakOrder α lt :=
  { trans := fun a b c hab hbc ↦
      have nba : ¬le b a := Iff.mp (h _ _) hab
      have ncb : ¬le c b := Iff.mp (h _ _) hbc
      have hab : le a b := Or.resolve_left (total_of le b a) nba
      have nca : ¬le c a := fun hca : le c a ↦
        have hcb : le c b := trans_of le hca hab
        absurd hcb ncb
      Iff.mpr (h _ _) nca,
    irrefl := fun a hlt ↦ absurd (refl_of le a) (Iff.mp (h _ _) hlt),
    incomp_trans := fun a b c ⟨nab, nba⟩ ⟨nbc, ncb⟩ ↦
      have hba : le b a := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nab)
      have hab : le a b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nba)
      have hcb : le c b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nbc)
      have hbc : le b c := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) ncb)
      have hac : le a c := trans_of le hab hbc
      have hca : le c a := trans_of le hcb hba
      And.intro (fun n ↦ absurd hca (Iff.mp (h _ _) n)) fun n ↦ absurd hac (Iff.mp (h _ _) n) }

theorem lt_of_lt_of_incomp {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, lt a b → ¬lt b c ∧ ¬lt c b → lt a c :=
  @fun a b c hab ⟨nbc, ncb⟩ ↦
  have nca : ¬lt c a := fun hca ↦ absurd (trans_of lt hca hab) ncb
  Decidable.by_contradiction fun nac : ¬lt a c ↦
    have : ¬lt a b ∧ ¬lt b a := incomp_trans_of lt ⟨nac, nca⟩ ⟨ncb, nbc⟩
    absurd hab this.1

theorem lt_of_incomp_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, ¬lt a b ∧ ¬lt b a → lt b c → lt a c :=
  @fun a b c ⟨nab, nba⟩ hbc ↦
  have nca : ¬lt c a := fun hca ↦ absurd (trans_of lt hbc hca) nba
  Decidable.by_contradiction fun nac : ¬lt a c ↦
    have : ¬lt b c ∧ ¬lt c b := incomp_trans_of lt ⟨nba, nab⟩ ⟨nac, nca⟩
    absurd hbc this.1

theorem eq_of_incomp {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    ¬lt a b ∧ ¬lt b a → a = b :=
  fun ⟨nab, nba⟩ ↦
  match trichotomous_of lt a b with
  | Or.inl hab => absurd hab nab
  | Or.inr (Or.inl hab) => hab
  | Or.inr (Or.inr hba) => absurd hba nba

theorem eq_of_eqv_lt {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    ¬lt a b ∧ ¬lt b a → a = b :=
  eq_of_incomp

theorem incomp_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    ¬lt a b ∧ ¬lt b a ↔ a = b :=
  Iff.intro eq_of_incomp fun hab ↦ by
    rw [hab]
    exact ⟨irrefl_of lt b, irrefl_of lt b⟩

theorem eqv_lt_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    ¬lt a b ∧ ¬lt b a ↔ a = b :=
  incomp_iff_eq a b

theorem not_lt_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictOrder α lt] {a b} :
    lt a b → ¬lt b a :=
  fun h₁ h₂ ↦ absurd (trans_of lt h₁ h₂) (irrefl_of lt _)


import algebra.category.Group.colimits
import lemmas.ulift
import new.unordered.d

section

open topological_space Top Top.sheaf
open category_theory
open opposite
open nat

open_locale big_operators

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U V : X.oc)
variable (n : ℕ)

section

variables {n U V} (r : U ⟶ V)

def vec.refine (α : fin n → U.ι) : fin n → V.ι :=
r.func ∘ α

lemma vec.refine_apply (α : fin n → U.ι) (m : fin n) :
  vec.refine r α m = r.func (α m) := rfl

lemma vec.refine_comp_apply {U V W : X.oc} (r : U ⟶ V) (r' : V ⟶ W)
  (α : fin n → U.ι) (m : fin n) :
  vec.refine (r ≫ r') α m = vec.refine r' (vec.refine r α) m := rfl

lemma vec.refine_le (α : fin n → U.ι) :
  face α ≤ face (vec.refine r α) :=
begin
  intros p hp,
  rw opens.mem_coe at hp ⊢,
  unfold face at hp ⊢,
  rw opens.fintype_infi at hp ⊢,
  intros i,
  specialize hp i,
  apply r.is_refinement,
  exact hp,
end

lemma vec.refine_ignore (α : fin (n + 1) → U.ι) (k : fin (n + 1)) :
  vec.refine r (ignore α k) = ignore (vec.refine r α) k :=
begin
  ext1 m,
  rw vec.refine_apply,
  rw ignore.apply_ite,
  rw ignore.apply_ite,
  split_ifs,
  rw vec.refine_apply,
  rw vec.refine_apply,
end

variables {𝓕}
def C.refine.to_fun (f : C 𝓕 V n) : C 𝓕 U n :=
λ α, 𝓕.1.map (hom_of_le (vec.refine_le r α)).op (f (vec.refine r α))

lemma C.refine.to_fun_apply (f : C 𝓕 V n) (α : fin n → U.ι) :
  C.refine.to_fun r f α = 𝓕.1.map (hom_of_le (vec.refine_le r α)).op (f (vec.refine r α)) :=
rfl

def C.refine : C 𝓕 V n ⟶ C 𝓕 U n :=
{ to_fun := λ f, C.refine.to_fun r f,
  map_zero' := begin
    ext α,
    rw C.refine.to_fun_apply,
    simp only [C_pre.zero_apply, map_zero],
  end,
  map_add' := λ f g, begin
    ext α,
    rw [C.refine.to_fun_apply, pi.add_apply, map_add],
    refl,
  end }

lemma C.refine_d_eq_d_refine :
  C.refine r ≫ d 𝓕 U n = d 𝓕 V n ≫ C.refine r :=
begin
  ext f α,
  rw [comp_apply, comp_apply],
  rw [dd_aux.d_def],
  rw [C.refine, C.refine, add_monoid_hom.coe_mk, add_monoid_hom.coe_mk, C.refine.to_fun_apply],
  simp_rw [C.refine.to_fun_apply],
  rw [dd_aux.d_def],
  rw add_monoid_hom.map_sum,
  rw finset.sum_congr rfl,
  intros i _,
  split_ifs,
  { rw [id, ← comp_apply, ← 𝓕.1.map_comp, ← comp_apply, ← 𝓕.1.map_comp],
    rw map_congr.vec_eq f (_ : vec.refine r (ignore α i) = ignore (vec.refine r α) i),
    rw [← comp_apply, ← 𝓕.1.map_comp],
    congr,
    rw vec.refine_ignore, },
  { rw [pi.neg_apply, pi.neg_apply],
    simp only [pi.neg_apply, add_monoid_hom.neg_apply, map_neg, neg_inj],
    rw [← comp_apply, ← comp_apply, ← 𝓕.1.map_comp, ← 𝓕.1.map_comp],
    rw map_congr.vec_eq f (_ : vec.refine r (ignore α i) = ignore (vec.refine r α) i),
    rw [← comp_apply, ← 𝓕.1.map_comp],
    congr,
    rw vec.refine_ignore, },
end

lemma C.refine_d_eq_d_refine' (f) :
  C.refine r (d 𝓕 V n f)  = d 𝓕 U n (C.refine r f) :=
begin
  rw ← comp_apply,
  rw ← C.refine_d_eq_d_refine,
  rw comp_apply,
end

lemma C.refine_eq_to_hom {m n : ℕ} (h0 : m + 1 = n) (h1 : C 𝓕 U (m + 1) = C 𝓕 U n) (h2 : C 𝓕 V (m + 1) = C 𝓕 V n) :
  (@C.refine X 𝓕 U V (m+1) r ≫ eq_to_hom h1) = eq_to_hom h2 ≫ @C.refine X 𝓕 U V n r :=
begin
  ext f α,
  rw [comp_apply, comp_apply, C.refine, add_monoid_hom.coe_mk,  C.refine, add_monoid_hom.coe_mk, C.refine.to_fun_apply],

  have : @eq_to_hom Ab _ _ _ h2 f (vec.refine r α) = 𝓕.1.map _ (f (vec.refine r (λ i, α ⟨i.1, h0 ▸ i.2⟩))),
  work_on_goal 3
  { refine quiver.hom.op _,
    refine eq_to_hom _,
    sorry },
  { sorry },
  rw this,
  have : (@eq_to_hom Ab _ _ _ h1 (C.refine.to_fun r f)) α = 𝓕.1.map _ (C.refine.to_fun r f (λ i, α ⟨i.1, h0 ▸ i.2⟩)),
  work_on_goal 3
  { refine quiver.hom.op _,
    refine eq_to_hom _,
    unfold face,
    ext,
    split,

    { intros hp,
      rw opens.mem_coe at hp ⊢,
      rw opens.fintype_infi at hp ⊢,
      intros i,
      specialize hp ⟨i.1, h0 ▸ i.2⟩,
      exact hp },
    { intros hp,
      rw opens.mem_coe at hp ⊢,
      rw opens.fintype_infi at hp ⊢,
      intros i,
      specialize hp ⟨i.1, h0.symm ▸ i.2⟩,
      convert hp,
      rw subtype.ext_iff_val, }, },

  { sorry },
  rw this,
  rw ← comp_apply,
  rw ← 𝓕.1.map_comp,
  rw C.refine.to_fun_apply,
  rw ← comp_apply,
  rw ← 𝓕.1.map_comp,
  congr,
end

def C.refine_functor : X.ocᵒᵖ ⥤ Ab :=
{ obj := λ U, C 𝓕 (unop U) n,
  map := λ U V r, C.refine r.unop,
  map_id' := λ U, begin
    ext f α,
    simp only [unop_id, id_apply],
    change C.refine.to_fun _ f α = _,
    rw C.refine.to_fun_apply,
    rw map_congr.vec_eq f (_ : α = vec.refine (𝟙 _) α),
    congr,
    ext m,
    rw vec.refine_apply,
    refl,
  end,
  map_comp' := λ U V W rUV rVW, begin
    ext f α,
    rw comp_apply,
    change C.refine.to_fun _ f α = _,
    rw C.refine.to_fun_apply,
    rw C.refine,
    simp only [add_monoid_hom.coe_mk],
    rw C.refine,
    simp only [add_monoid_hom.coe_mk],

    rw C.refine.to_fun_apply,
    rw C.refine.to_fun_apply,
    rw ← comp_apply,
    rw ← 𝓕.1.map_comp,
    rw map_congr.vec_eq f (_ : vec.refine (rUV ≫ rVW).unop α = vec.refine rUV.unop (vec.refine rVW.unop α)),
    rw ← comp_apply,
    rw ← 𝓕.1.map_comp,
    congr,
    refl,
  end }

include 𝓕 n
noncomputable example : Ab :=
begin
  have := limits.colim.obj (@C.refine_functor _ 𝓕 n  ⋙ AddCommGroup.ulift_functor.{u u+1}),
  exact this,
end

end

end


import data.cpi.semantics.relation
import data.fin_fn

namespace cpi

/-- Determine if two concretions are equal. Effectively a decision procedure for
    structural congruence. -/
instance concretion_wrap.decidable_eq {ℍ ω Γ} [cpi_equiv ℍ ω] :
  decidable_eq ( prime_species' ℍ ω Γ
               × (Σ (b y : ℕ), concretion' ℍ ω Γ b y) × name Γ)
| a b := by apply_instance

/-- A vector-space representation of processes, mapping prime species into their
    concentrations. -/
@[nolint has_inhabited_instance]
def process_space (ℂ ℍ : Type) (ω Γ : context) [add_monoid ℂ] [cpi_equiv ℍ ω]
  := fin_fn (prime_species' ℍ ω Γ) ℂ

variables {ℂ ℍ : Type} {ω : context} [half_ring ℂ] [cpi_equiv ℍ ω] [decidable_eq ℂ]

instance process_space.add_comm_monoid {Γ} : add_comm_group (process_space ℂ ℍ ω Γ) := fin_fn.add_comm_group _ ℂ
instance process_space.semimodule {Γ} : semimodule ℂ (process_space ℂ ℍ ω Γ) := fin_fn.semimodule _ ℂ
instance process_space.has_repr {ℂ} [add_monoid ℂ] [has_repr ℂ] {Γ} [has_repr (species' ℍ ω Γ)]
  : has_repr (process_space ℂ ℍ ω Γ) := ⟨ fin_fn.to_string "\n" ⟩

/-- Convert a species into a process space with a unit vector for each element
    of the prime decomposition.

    This is defined as ⟨A⟩ within the paper. -/
def to_process_space {Γ} (A : species' ℍ ω Γ) : process_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose' A).sum' (λ A, fin_fn.single A 1)

@[simp]
lemma to_process_space.nil {Γ} : to_process_space ⟦nil⟧ = (0 : process_space ℂ ℍ ω Γ)
  := by simp only [to_process_space, cpi_equiv.prime_decompose_nil', multiset.sum'_zero]

@[simp]
lemma to_process_space.prime {Γ} (A : prime_species' ℍ ω Γ)
  : (to_process_space (prime_species.unwrap A) : process_space ℂ ℍ ω Γ)
  = fin_fn.single A 1
  := by simp only [to_process_space, cpi_equiv.prime_decompose_prime', multiset.sum'_singleton]

@[simp]
lemma to_process_space.parallel {Γ} (A B : species ℍ ω Γ)
  : (to_process_space ⟦ A |ₛ B ⟧ : process_space ℂ ℍ ω Γ)
  = to_process_space ⟦ A ⟧ + to_process_space ⟦ B ⟧
  := by simp only [to_process_space, cpi_equiv.prime_decompose_parallel', multiset.sum'_add]

/-- The vector space (A, E, a)→ℍ relating transitions from A to E with label #a.
  -/
@[nolint has_inhabited_instance]
def interaction_space (ℂ ℍ : Type) (ω Γ : context) [add_monoid ℂ] [cpi_equiv ℍ ω] : Type
  := fin_fn
      ( prime_species' ℍ ω Γ
      × (Σ (b y), concretion' ℍ ω Γ b y)
      × name Γ)
      ℂ

instance interaction_space.add_comm_monoid {Γ} : add_comm_group (interaction_space ℂ ℍ ω Γ) := fin_fn.add_comm_group _ ℂ
instance interaction_space.semimodule {Γ} : semimodule ℂ (interaction_space ℂ ℍ ω Γ) := fin_fn.semimodule _ ℂ

instance interaction_space.has_repr {ℂ} [add_monoid ℂ] [has_repr ℂ] {Γ}
  [has_repr (species' ℍ ω Γ)] [∀ b y, has_repr (concretion' ℍ ω Γ b y)]
  : has_repr (interaction_space ℂ ℍ ω Γ) := ⟨ @fin_fn.to_string
    ( prime_species' ℍ ω Γ
      × (Σ (b y), concretion' ℍ ω Γ b y)
      × name Γ) ℂ _
    ⟨ λ ⟨ A, ⟨ _, _, F ⟩, a ⟩, "[" ++ repr A ++ "], [" ++ repr F ++ "], " ++ repr a ⟩
    _ "\n" ⟩

/-- Convert a process into a process space. -/
def process.to_space {Γ}
  : process ℂ ℍ ω Γ → process_space ℂ ℍ ω Γ
| (c ◯ A) := c • to_process_space ⟦ A ⟧
| (P |ₚ Q) := process.to_space P + process.to_space Q

/-- Convert a process space into a process. -/
def process.from_space {ℂ} [add_comm_monoid ℂ] {Γ} : process_space ℂ ℍ ω Γ → process' ℂ ℍ ω Γ
| Ps := process.from_prime_multiset Ps.space Ps.support.val

/-- Convert a class of equivalent processes into a process space. -/
def process.to_space' {Γ} : process' ℂ ℍ ω Γ → process_space ℂ ℍ ω Γ
| P := quot.lift_on P process.to_space (λ P Q eq, begin
  induction eq,
  case process.equiv.refl { from rfl },
  case process.equiv.trans : P Q R _ _ pq qr { from trans pq qr },
  case process.equiv.symm : P Q _ ih { from symm ih },

  case process.equiv.ξ_species : c A A' eq {
    simp only [process.to_space, quotient.sound eq],
  },
  case process.equiv.ξ_parallel₁ : P P' Q _ ih { simp only [process.to_space, ih] },
  case process.equiv.ξ_parallel₂ : P Q Q' _ ih { simp only [process.to_space, ih] },

  case process.equiv.parallel_nil : P c {
    simp only [process.to_space, cpi.to_process_space.nil, smul_zero, add_zero],
  },
  case process.equiv.parallel_symm { simp only [process.to_space, add_comm] },
  case process.equiv.parallel_assoc { simp only [process.to_space, add_assoc] },
  case cpi.process.equiv.join : A c d { simp only [process.to_space, add_smul] },
  case cpi.process.equiv.split : A B c {
    simp only [process.to_space, to_process_space.parallel, smul_add],
  }
end)

axiom process.from_inverse {Γ} :
  function.left_inverse process.to_space' (@process.from_space ℍ ω _ ℂ _ Γ)

/-- Show that process spaces can be embeeded into equivalence classes of processes. -/
def process.space_embed {Γ} : process_space ℂ ℍ ω Γ ↪ process' ℂ ℍ ω Γ :=
  { to_fun := process.from_space,
    inj := function.injective_of_left_inverse process.from_inverse }

end cpi

#lint-


import data.finset data.multiset.dict data.pfun logic.function

local attribute [-simp] sigma.forall sigma.exists

universes u v

/-- Finite map: a multiset of dependent pairs with no duplicate keys -/
structure finmap (α : Type u) (β : α → Type v) : Type (max u v) :=
(val : multiset (sigma β))
(nodupkeys : val.nodupkeys)

namespace finmap
open multiset

section αβ
variables {α : Type u} {β : α → Type v}

/- equality -/

theorem eq_of_veq : ∀ {f g : finmap α β}, f.val = g.val → f = g
| ⟨s, _⟩ ⟨t, _⟩ h := by congr; exact h

@[simp] theorem val_inj {f g : finmap α β} : f.val = g.val ↔ f = g :=
⟨eq_of_veq, congr_arg _⟩

instance has_decidable_eq [decidable_eq α] [∀ a, decidable_eq (β a)] : decidable_eq (finmap α β)
| f g := decidable_of_iff _ val_inj

/- recursors -/

section rec
open function

/-- Dependent recursor on a finmap for a list -/
protected def lrec_on {γ : Sort*} (f : finmap α β)
  (φ : ∀ {l : list (sigma β)}, l.nodupkeys → γ)
  (c : ∀ {l₁ l₂} (p : l₁ ~ l₂) d₁ d₂, φ d₁ = φ d₂) : γ :=
@quotient.hrec_on _ _ (λ (m : multiset (sigma β)), m.nodupkeys → γ)
  f.val
  (λ l (d : l.nodupkeys), φ d)
  (λ l₁ l₂ p, hfunext (by rw list.perm_nodupkeys p) $ λ d₁ d₂ _, heq_of_eq $ c p d₁ d₂)
  f.nodupkeys

/-- Dependent recursor on two finmaps for lists -/
protected def lrec_on₂ {γ : Sort*} (f g : finmap α β)
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (c : ∀ {l₁ l₂ l₃ l₄} (p₁₃ : l₁ ~ l₃) (p₂₄ : l₂ ~ l₄) d₁ d₂ d₃ d₄, φ d₁ d₂ = φ d₃ d₄) : γ :=
@quotient.hrec_on₂ _ _ _ _
  (λ (m₁ m₂ : multiset (sigma β)), m₁.nodupkeys → m₂.nodupkeys → γ)
  f.val g.val
  (λ l₁ l₂ (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ d₂)
  (λ l₁ l₂ l₃ l₄ p₁₃ p₂₄, hfunext (by rw list.perm_nodupkeys p₁₃) $
    λ d₁ d₃ _, hfunext (by rw list.perm_nodupkeys p₂₄) $
      λ d₂ d₄ _, heq_of_eq $ c p₁₃ p₂₄ d₁ d₂ d₃ d₄)
  f.nodupkeys g.nodupkeys

/-- Lift a function on 2 lists to a function on 2 finmaps  -/
protected def lift_on₂ {γ : Type*} (f g : finmap α β)
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (c : ∀ {l₁ l₂ l₃ l₄} (p₁₃ : l₁ ~ l₃) (p₂₄ : l₂ ~ l₄) d₁ d₂ d₃ d₄, φ d₁ d₂ = φ d₃ d₄) :
  roption γ :=
quotient.lift_on₂ f.val g.val
  (λ l₁ l₂, roption.mk (l₁.nodupkeys ∧ l₂.nodupkeys) (λ ⟨d₁, d₂⟩, φ d₁ d₂))
  (λ l₁ l₂ l₃ l₄ p₁₃ p₂₄, roption.ext'
    (and_congr (list.perm_nodupkeys p₁₃) (list.perm_nodupkeys p₂₄))
    (λ ⟨d₁, d₂⟩ ⟨d₃, d₄⟩, c p₁₃ p₂₄ d₁ d₂ d₃ d₄))

end rec

/- membership -/

section mem
variables {s : sigma β} {m : multiset (sigma β)} {d : m.nodupkeys} {f : finmap α β}

instance : has_mem (sigma β) (finmap α β) :=
⟨λ s f, s ∈ f.val⟩

theorem mem_def : s ∈ f ↔ s ∈ f.val :=
iff.rfl

@[simp] theorem mem_mk : @has_mem.mem _ (finmap α β) _ s (finmap.mk m d) ↔ s ∈ m :=
iff.rfl

instance decidable_mem [decidable_eq α] [∀ a, decidable_eq (β a)] (s : sigma β) (f : finmap α β) :
  decidable (s ∈ f) :=
multiset.decidable_mem _ _

end mem

/- set coercion -/

section set
variables {s : sigma β} {f : finmap α β}

def to_set (f : finmap α β) : set (sigma β) :=
{x | x ∈ f}

instance has_lift_set : has_lift (finmap α β) (set (sigma β)) :=
⟨to_set⟩

@[simp] theorem mem_set_coe : s ∈ (↑f : set (sigma β)) ↔ s ∈ f :=
iff.rfl

end set

/- finset coercion -/

section finset
variables {s : sigma β} {f : finmap α β}

def to_finset (f : finmap α β) : finset (sigma β) :=
⟨f.val, nodup_of_nodupkeys f.nodupkeys⟩

instance has_lift_finset : has_lift (finmap α β) (finset (sigma β)) :=
⟨to_finset⟩

@[simp] theorem mem_finset_coe : s ∈ (↑f : finset (sigma β)) ↔ s ∈ f :=
iff.rfl

end finset

/- extensionality -/

section ext
variables {f g : finmap α β}

theorem ext : f = g ↔ ∀ s, s ∈ f ↔ s ∈ g :=
val_inj.symm.trans $ nodup_ext
  (nodup_of_nodupkeys f.nodupkeys)
  (nodup_of_nodupkeys g.nodupkeys)

@[extensionality]
theorem ext' : (∀ s, s ∈ f ↔ s ∈ g) → f = g :=
ext.mpr

end ext

/- subset -/

section subset
variables {s : sigma β} {f g h : finmap α β}

instance : has_subset (finmap α β) :=
⟨λ f g, ∀ ⦃s : sigma β⦄, s ∈ f → s ∈ g⟩

theorem subset_def : f ⊆ g ↔ f.val ⊆ g.val :=
iff.rfl

@[simp] theorem subset.refl (f : finmap α β) : f ⊆ f :=
subset.refl _

theorem subset.trans : f ⊆ g → g ⊆ h → f ⊆ h :=
subset.trans

theorem mem_of_subset : f ⊆ g → s ∈ f → s ∈ g :=
mem_of_subset

theorem subset.antisymm (H₁ : f ⊆ g) (H₂ : g ⊆ f) : f = g :=
ext' $ λ a, ⟨@H₁ a, @H₂ a⟩

theorem subset_iff : f ⊆ g ↔ ∀ ⦃x⦄, x ∈ f → x ∈ g :=
iff.rfl

@[simp] theorem coe_subset_set : (↑f : set (sigma β)) ⊆ ↑g ↔ f ⊆ g :=
iff.rfl

@[simp] theorem coe_subset_finset : (↑f : finset (sigma β)) ⊆ ↑g ↔ f ⊆ g :=
iff.rfl

@[simp] theorem val_le_iff : f.val ≤ g.val ↔ f ⊆ g :=
le_iff_subset (nodup_of_nodupkeys f.nodupkeys)

instance : has_ssubset (finmap α β) :=
⟨λa b, a ⊆ b ∧ ¬ b ⊆ a⟩

instance : partial_order (finmap α β) :=
{ le := (⊆),
  lt := (⊂),
  le_refl := subset.refl,
  le_trans := @subset.trans _ _,
  le_antisymm := @subset.antisymm _ _ }

@[simp] theorem le_iff_subset : f ≤ g ↔ f ⊆ g := iff.rfl
@[simp] theorem lt_iff_ssubset : f < g ↔ f ⊂ g := iff.rfl

@[simp] theorem val_lt_iff : f.val < g.val ↔ f ⊂ g :=
and_congr val_le_iff $ not_congr val_le_iff

end subset

/- empty -/

section empty
variables {s : sigma β} {f : finmap α β}

instance : has_emptyc (finmap α β) :=
⟨⟨_, nodupkeys_zero⟩⟩

instance : inhabited (finmap α β) :=
⟨∅⟩

@[simp] theorem empty_val : (∅ : finmap α β).val = 0 :=
rfl

@[simp] theorem not_mem_empty (s : sigma β) : s ∉ (∅ : finmap α β) :=
id

@[simp] theorem ne_empty_of_mem (h : s ∈ f) : f ≠ ∅
| e := not_mem_empty s $ e ▸ h

@[simp] theorem empty_subset (f : finmap α β) : ∅ ⊆ f :=
zero_subset _

theorem eq_empty_of_forall_not_mem (H : ∀x, x ∉ f) : f = ∅ :=
eq_of_veq (eq_zero_of_forall_not_mem H)

@[simp] theorem val_eq_zero : f.val = 0 ↔ f = ∅ :=
@val_inj _ _ f ∅

theorem subset_empty : f ⊆ ∅ ↔ f = ∅ :=
subset_zero.trans val_eq_zero

theorem exists_mem_of_ne_empty (h : f ≠ ∅) : ∃ s : sigma β, s ∈ f :=
exists_mem_of_ne_zero (mt val_eq_zero.mp h)

@[simp] theorem coe_empty_set : ↑(∅ : finmap α β) = (∅ : set (sigma β)) :=
by simp [set.ext_iff]

@[simp] theorem coe_empty_finset : ↑(∅ : finmap α β) = (∅ : finset (sigma β)) :=
by simp [finset.ext]

end empty

/- singleton -/

section singleton
variables {s₁ s₂ : sigma β}

/-- `singleton s` is the set `{s}` containing `s` and nothing else. -/
def singleton (s : sigma β) : finmap α β :=
⟨⟦[s]⟧, nodupkeys_singleton s⟩

@[simp] theorem singleton_val (s : sigma β) : (singleton s).val = s :: 0 :=
rfl

@[simp] theorem mem_singleton : s₁ ∈ singleton s₂ ↔ s₁ = s₂ :=
by simp [singleton]

theorem not_mem_singleton : s₁ ∉ singleton s₂ ↔ s₁ ≠ s₂ := by simp

theorem mem_singleton_self (s : sigma β) : s ∈ singleton s := by simp

theorem singleton_inj : singleton s₁ = singleton s₂ ↔ s₁ = s₂ :=
⟨λ h, mem_singleton.mp (h ▸ mem_singleton_self _), congr_arg _⟩

@[simp] theorem singleton_ne_empty (s : sigma β) : singleton s ≠ ∅ :=
ne_empty_of_mem (mem_singleton_self _)

@[simp] theorem coe_singleton_set (s : sigma β) : ↑(singleton s) = ({s} : set (sigma β)) :=
by simp [set.ext_iff]

@[simp] theorem coe_singleton_finset (s : sigma β) : ↑(singleton s) = finset.singleton s :=
by simp [finset.ext]

end singleton

/- keys -/

section keys
variables {a a₁ a₂ : α} {s : sigma β} {f : finmap α β}

def keys (f : finmap α β) : finset α :=
⟨f.val.keys, nodupkeys_iff.mpr f.nodupkeys⟩

@[simp] theorem keys_val (f : finmap α β) : f.keys.val = f.val.keys :=
rfl

@[simp] theorem keys_empty : keys (∅ : finmap α β) = ∅ :=
rfl

@[simp] theorem keys_singleton : keys (singleton s) = finset.singleton s.1 :=
rfl

theorem mem_keys_of_mem : s ∈ f → s.1 ∈ f.keys :=
mem_keys_of_mem

theorem exists_mem_of_mem_keys : a ∈ f.keys → ∃ (b : β a), sigma.mk a b ∈ f :=
exists_mem_of_mem_keys

@[simp] theorem mem_keys_singleton : a ∈ (singleton s).keys ↔ a = s.1 :=
by simp

@[simp] theorem mem_insert_keys [decidable_eq α] :
  a₁ ∈ insert a₂ f.keys ↔ a₁ = a₂ ∨ a₁ ∈ f.keys :=
by simp

end keys

section decidable_eq_α
variables [decidable_eq α]

/- erase -/

section erase
variables {s : sigma β} {a a₁ a₂ : α} {f g : finmap α β}

def erase (f : finmap α β) (a : α) : finmap α β :=
⟨kerase a f.nodupkeys, nodupkeys_kerase a f.nodupkeys⟩

@[simp] theorem erase_val (f : finmap α β) (a : α) : (f.erase a).val = kerase a f.nodupkeys :=
rfl

@[simp] theorem mem_erase : s ∈ f.erase a ↔ s.1 ≠ a ∧ s ∈ f :=
mem_kerase f.nodupkeys

theorem not_mem_erase (a : α) (b : β a) (f : finmap α β) : sigma.mk a b ∉ f.erase a :=
by simp

@[simp] theorem mem_keys_erase : a₁ ∈ (f.erase a₂).keys ↔ a₁ ≠ a₂ ∧ a₁ ∈ f.keys :=
by simp [keys]

@[simp] theorem erase_empty (β : α → Type v) (a) : erase ∅ a = (∅ : finmap α β) :=
rfl

theorem ne_of_mem_erase : s ∈ f.erase a → s.1 ≠ a :=
by simp {contextual := tt}

theorem erase_subset_erase (a : α) (h : f ⊆ g) : f.erase a ⊆ g.erase a :=
val_le_iff.mp $ kerase_le_kerase _ (val_le_iff.mpr h) _ _

theorem erase_subset (a : α) : f.erase a ⊆ f :=
kerase_subset a f.nodupkeys

end erase

/- insert -/

section insert
variables {a : α} {s : sigma β} {f g : finmap α β}

instance : has_insert (sigma β) (finmap α β) :=
⟨λ s f, ⟨kinsert s f.nodupkeys, nodupkeys_kinsert s f.nodupkeys⟩⟩

theorem insert_def (s : sigma β) (f : finmap α β) :
  insert s f = mk (kinsert s f.nodupkeys) (nodupkeys_kinsert s f.nodupkeys) :=
rfl

@[simp] theorem insert_val (s : sigma β) (f : finmap α β) :
  (insert s f).val = kinsert s f.nodupkeys :=
rfl

@[simp] theorem insert_empty (s : sigma β) : insert s (∅ : finmap α β) = {s} :=
rfl

@[simp] theorem mem_insert (s₁ s₂ : sigma β) (f : finmap α β) :
  s₁ ∈ insert s₂ f ↔ s₁ = s₂ ∨ s₁ ∈ f.erase s₂.1 :=
mem_kinsert f.nodupkeys

@[simp] theorem mem_keys_insert : a ∈ (insert s f).keys ↔ a = s.1 ∨ a ∈ f.keys :=
by simp [keys]

@[simp] theorem insert_keys : (insert s f).keys = insert s.1 f.keys :=
finset.ext' $ by simp

@[simp] theorem disjoint_keys_insert_left :
  disjoint (insert s f).keys g.keys ↔ s.1 ∉ g.keys ∧ disjoint f.keys g.keys :=
by simp

@[simp] theorem disjoint_keys_insert_right :
  disjoint f.keys (insert s g).keys ↔ s.1 ∉ f.keys ∧ disjoint f.keys g.keys :=
by simp

end insert

/- lookup -/

section lookup

/-- Look up a key in a finmap to find the value, if it exists -/
def lookup (a : α) (f : finmap α β) : option (β a) :=
klookup a f.nodupkeys

/-- Treat a finmap as the function `∀ a, option (β a)` -/
def to_fun (f : finmap α β) (a : α) : option (β a) :=
f.lookup a

/-- Treat a finmap as the partial function `∀ a, roption (β a)` -/
def to_pfun (f : finmap α β) (a : α) : roption (β a) :=
roption.of_option (f.to_fun a)

theorem lookup_empty (β : α → Type v) (a) : lookup a (∅ : finmap α β) = none :=
rfl

end lookup

/- replace -/

section replace

def replace (s : sigma β) (f : finmap α β) : finmap α β :=
⟨kreplace s f.nodupkeys, nodupkeys_kreplace s f.nodupkeys⟩

@[simp] theorem replace_empty (s : sigma β) : replace s ∅ = ∅ :=
rfl

end replace

/- union -/

section union
variables {a : α} {s : sigma β} {f g h : finmap α β}

protected def union (f : finmap α β) (g : finmap α β) : finmap α β :=
⟨kunion f.nodupkeys g.nodupkeys, nodupkeys_kunion f.nodupkeys g.nodupkeys⟩

instance : has_union (finmap α β) :=
⟨finmap.union⟩

@[simp] theorem union_val : (f ∪ g).val = kunion f.nodupkeys g.nodupkeys :=
rfl

@[simp] theorem empty_union (f : finmap α β) : ∅ ∪ f = f :=
eq_of_veq $ by simp [zero_kunion f.nodupkeys]

@[simp] theorem union_empty (f : finmap α β) : f ∪ ∅ = f :=
eq_of_veq $ kunion_zero f.nodupkeys

@[simp] theorem insert_union : insert s f ∪ g = insert s (f ∪ g) :=
eq_of_veq $ kinsert_kunion f.nodupkeys g.nodupkeys

theorem mem_of_mem_union : s ∈ f ∪ g → s ∈ f ∨ s ∈ g :=
mem_of_mem_kunion f.nodupkeys g.nodupkeys

theorem mem_union_left (g : finmap α β) : s ∈ f → s ∈ f ∪ g :=
mem_kunion_left f.nodupkeys g.nodupkeys

theorem mem_union_right : s.1 ∉ f.keys → s ∈ g → s ∈ f ∪ g :=
mem_kunion_right f.nodupkeys g.nodupkeys

@[simp] theorem mem_union (dk : disjoint f.keys g.keys) : s ∈ f ∪ g ↔ s ∈ f ∨ s ∈ g :=
mem_kunion f.nodupkeys g.nodupkeys (finset.disjoint_val.mp dk)

theorem union_comm (dk : disjoint f.keys g.keys) : f ∪ g = g ∪ f :=
by simp [ext, or_comm, dk, dk.symm]

@[simp] theorem mem_keys_union : a ∈ (f ∪ g).keys ↔ a ∈ f.keys ∨ a ∈ g.keys :=
mem_keys_kunion f.nodupkeys g.nodupkeys

@[simp] theorem union_keys : (f ∪ g).keys = f.keys ∪ g.keys :=
finset.ext' $ by simp

theorem disjoint_keys_union_left :
  disjoint (f ∪ g).keys h.keys ↔ disjoint f.keys h.keys ∧ disjoint g.keys h.keys :=
by simp

theorem disjoint_keys_union_right :
  disjoint f.keys (g ∪ h).keys ↔ disjoint f.keys g.keys ∧ disjoint f.keys h.keys :=
by simp

@[simp] theorem union_assoc (dk_fg : disjoint f.keys g.keys) (dk_gh : disjoint g.keys h.keys)
  (dk_fh : disjoint f.keys h.keys) : (f ∪ g) ∪ h = f ∪ (g ∪ h) :=
have disjoint (f ∪ g).keys h.keys := disjoint_keys_union_left.mpr ⟨dk_fh, dk_gh⟩,
have disjoint f.keys (g ∪ h).keys := disjoint_keys_union_right.mpr ⟨dk_fg, dk_fh⟩,
by simp [ext, or_comm, or.left_comm, *]

theorem mem_union_middle_left (dk_fh : disjoint f.keys h.keys) (dk_gh : disjoint g.keys h.keys)
  (p : s ∈ f ∪ h) : s ∈ f ∪ g ∪ h :=
match mem_of_mem_union p with
| or.inl p := mem_union_left _ (mem_union_left _ p)
| or.inr p := mem_union_right
  (finset.disjoint_right.mp (disjoint_keys_union_left.mpr ⟨dk_fh, dk_gh⟩) (mem_keys_of_mem p)) p
end

theorem mem_union_middle_right (dk_fh : disjoint f.keys h.keys) (dk_gh : disjoint g.keys h.keys)
  (p : s ∈ f ∪ h) : s ∈ f ∪ (g ∪ h) :=
match mem_of_mem_union p with
| or.inl p := mem_union_left _ p
| or.inr p :=
  have s.1 ∈ h.keys := mem_keys_of_mem p,
  mem_union_right
    (finset.disjoint_right.mp dk_fh this)
    (mem_union_right (finset.disjoint_right.mp dk_gh this) p)
end

end union

end decidable_eq_α

end αβ

section α₁α₂α₃β₁β₂β₃
variables {α₁ α₂ α₃ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v} {β₃ : α₃ → Type v}

section map
variables {p : β₁ s↪ β₂} {q : β₂ s↪ β₃} {s₁ : sigma β₁} {s₂ : sigma β₂} {f g : finmap α₁ β₁}

def map (p : β₁ s↪ β₂) (f : finmap α₁ β₁) : finmap α₂ β₂ :=
⟨f.val.map p, nodupkeys_map p.fst_inj f.nodupkeys⟩

@[simp] theorem map_val (p : β₁ s↪ β₂) (f : finmap α₁ β₁) : (f.map p).val = f.val.map p :=
rfl

@[simp] theorem map_mk {m₁ : multiset (sigma β₁)} {m₂ : multiset (sigma β₂)} {p : β₁ s↪ β₂}
  (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys) : (mk m₁ d₁).map p = mk m₂ d₂ ↔ m₁.map p = m₂ :=
by simp [map]

@[simp] theorem map_empty (p : β₁ s↪ β₂) : map p ∅ = ∅ :=
rfl

@[simp] theorem mem_map : s₂ ∈ f.map p ↔ ∃ s₁ ∈ f, p s₁ = s₂ :=
by simp [mem_def]

@[simp] theorem mem_map_of_mem (h : s₁ ∈ f) : p s₁ ∈ f.map p :=
mem_map.mpr ⟨_, h, rfl⟩

theorem map_refl : f.map (sigma.embedding.refl _) = f :=
ext' $ by simp [sigma.embedding.refl]

theorem map_map : (f.map p).map q = f.map (p.trans q) :=
eq_of_veq $ by simp [erase_dup_map_erase_dup_eq]

theorem map_subset_map (h : f ⊆ g) : f.map p ⊆ g.map p :=
by simp [subset_def, map_subset_map h]

theorem mem_keys_map (pf : sigma.fst_functional p) :
  s₁.1 ∈ f.keys → (p s₁).1 ∈ (f.map p).keys :=
mem_keys_map pf

theorem mem_keys_of_mem_keys_map : (p s₁).1 ∈ (f.map p).keys → s₁.1 ∈ f.keys :=
mem_keys_of_mem_keys_map p.fst_inj

theorem mem_keys_map_iff (pf : sigma.fst_functional p) :
  (p s₁).1 ∈ (f.map p).keys ↔ s₁.1 ∈ f.keys :=
⟨mem_keys_of_mem_keys_map, mem_keys_map pf⟩

theorem map_disjoint_keys [decidable_eq α₁] [decidable_eq α₂] (pf : sigma.fst_functional p) :
  disjoint (f.map p).keys (g.map p).keys ↔ disjoint f.keys g.keys :=
by simp only [finset.disjoint_val]; exact multiset.map_disjoint_keys pf p.fst_inj

theorem map_union [decidable_eq α₁] [decidable_eq α₂] (pf : sigma.fst_functional p)
  (dk : disjoint f.keys g.keys) : (f ∪ g).map p = f.map p ∪ g.map p :=
ext' $ by simp [dk, map_disjoint_keys pf, or_and_distrib_right, exists_or_distrib]

section decidable_eq_α₁α₂
variables [decidable_eq α₁] [decidable_eq α₂]

@[simp] theorem map_erase (pf : sigma.fst_functional p) :
  (f.erase s₁.1).map p = (f.map p).erase (p s₁).1 :=
by simp [erase, map_kerase pf p.fst_inj f.nodupkeys]

@[simp] theorem map_insert (pf : sigma.fst_functional p) :
  (insert s₁ f).map p = insert (p s₁) (f.map p) :=
by simp [insert_def, map_kinsert pf p.fst_inj f.nodupkeys]

end decidable_eq_α₁α₂

end map

end α₁α₂α₃β₁β₂β₃

section αβ₁β₂
variables {α : Type u} {β₁ β₂ : α → Type v}

section map_id
variables {s : sigma β₁} {f : finmap α β₁}

@[simp] theorem map_id_val (p : ∀ a, β₁ a → β₂ a) (f : finmap α β₁) :
  (f.map (sigma.embedding.mk₂ p)).val = f.val.map (sigma.map id p) :=
rfl

@[simp] theorem map_id_keys (p : ∀ a, β₁ a → β₂ a) : (f.map (sigma.embedding.mk₂ p)).keys = f.keys :=
finset.val_inj.mp $ by simp

end map_id

end αβ₁β₂

end finmap


import logic.equiv.transfer_instance

lemma ring_hom.is_field {R S : Type*} [semifield R] [semiring S] [nontrivial S] (f : R →+* S)
  (hf : function.surjective f) : is_field S :=
begin
  constructor,
  { exact exists_pair_ne _ },
  { intros x y, obtain ⟨x, rfl⟩ := hf x, obtain ⟨y, rfl⟩ := hf y,
    rw [← map_mul, ← map_mul, mul_comm] },
  { intros a ha, obtain ⟨a, rfl⟩ := hf a, use f (1 / a), rw [← map_mul, mul_div_cancel', map_one],
    rintro rfl, apply ha, rw map_zero }
end

lemma ring_equiv.is_field {R S : Type*} [semifield R] [semiring S] (f : R ≃+* S) : is_field S :=
begin
  haveI := f.to_equiv.symm.nontrivial,
  exact f.to_ring_hom.is_field f.surjective
end

lemma ring_equiv.is_field_of_is_field {R S : Type*} [semiring R] [semiring S] (f : R ≃+* S)
  (h : is_field R) : is_field S :=
begin
  letI := h.to_semifield,
  exact f.is_field
end


import for_mathlib.algebraic_topology.homotopical_algebra.cofibrant_object
import for_mathlib.category_theory.localization.equivalence

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

namespace cofibrant_replacement

def obj (X : C) : cofibrant_object C :=
cofibrant_object.mk (CM5b.obj (initial.to X))

def app (X : C) : (obj X).obj ⟶ X := CM5b.p (initial.to X)

def app' (X : cofibrant_object C) : obj X.obj ⟶ X := app X.obj

instance (X : C) : fibration (app X) := by { dsimp [app], apply_instance, }
instance (X : C) : weak_eq (app X) := by { dsimp [app], apply_instance, }

def map' {X Y : C} (f : X ⟶ Y) : obj X ⟶ obj Y :=
begin
  have sq : comm_sq (initial.to (obj Y).obj) (initial.to (obj X).obj) (app Y) (app X ≫ f) :=
    by tidy,
  exact sq.lift,
end

@[reassoc]
lemma fac {X Y : C} (f : X ⟶ Y) : (cofibrant_object.forget C).map (map' f) ≫ app Y =
  app X ≫ f :=
by apply comm_sq.fac_right

lemma fac' {X Y : cofibrant_object C} (f : X ⟶ Y) :
  map' ((cofibrant_object.forget C).map f) ≫ app' Y = app' X ≫ f :=
by apply fac

def map {X Y : C} (f : X ⟶ Y) : cofibrant_object.homotopy_category.Q.obj (obj X) ⟶
  cofibrant_object.homotopy_category.Q.obj (obj Y) :=
  cofibrant_object.homotopy_category.Q.map (map' f)

lemma map_eq {X Y : C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) ((cofibrant_object.forget C).map f') f (app Y)) :
  map f = cofibrant_object.homotopy_category.Q.map f' :=
begin
  apply category_theory.quotient.sound,
  apply cofibrant_object.right_homotopy.trans_closure.mk,
  let Cyl := cylinder.some (obj X).obj,
  suffices : left_homotopy Cyl.pre (map' f) f',
  { exact cofibrant_object.right_homotopy.mk (path_object.some (obj Y).obj)
      (this.to_right_homotopy _), },
  have sq' : comm_sq (coprod.desc ((cofibrant_object.forget C).map (map' f)) f') Cyl.ι
    (app Y) (Cyl.σ ≫ app X ≫ f),
  { refine comm_sq.mk _,
    ext,
    { simpa only [precylinder.ι, cofibrant_object.forget_map, coprod.desc_comp,
        coprod.inl_desc, coprod.desc_comp_assoc, precylinder.σd₀, id_comp] using fac f, },
    { simpa only [precylinder.ι, coprod.desc_comp, coprod.inr_desc, coprod.desc_comp_assoc,
        precylinder.σd₁, id_comp] using sq.w.symm, }, },
  exact
  { h := sq'.lift,
    h₀' := by simpa using congr_arg (λ f, limits.coprod.inl ≫ f) sq'.fac_left,
    h₁' := by simpa using congr_arg (λ f, limits.coprod.inr ≫ f) sq'.fac_left, },
end

end cofibrant_replacement

variable (C)

@[simps]
def cofibrant_replacement : C ⥤ cofibrant_object.homotopy_category C :=
{ obj := λ X, cofibrant_object.homotopy_category.Q.obj (cofibrant_replacement.obj X),
  map := λ X Y f, cofibrant_replacement.map f,
  map_id' := λ X, begin
    rw [cofibrant_replacement.map_eq _ (𝟙 _), cofibrant_object.homotopy_category.Q.map_id],
    exact comm_sq.mk (by erw [id_comp, comp_id]),
  end,
  map_comp' := λ X Y Z f g, begin
    rw [cofibrant_replacement.map_eq (f ≫ g)
      (cofibrant_replacement.map' f ≫ cofibrant_replacement.map' g), functor.map_comp],
    { refl, },
    { refine comm_sq.mk _,
      rw [functor.map_comp, assoc, cofibrant_replacement.fac g,
        cofibrant_replacement.fac_assoc f], },
  end, }

variables {Hocof : Type*} [category Hocof] (Lcof : cofibrant_object C ⥤ Hocof)
  [Lcof.is_localization cofibrant_object.weq]
  {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq]

namespace cofibrant_replacement

variable {C}

lemma weq_iff {X Y : C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) ((cofibrant_object.forget C).map f') f (app Y)) :
  weq f ↔ cofibrant_object.weq f' :=
begin
  split,
  { intro hf,
    have h : weq (app X ≫ f) := CM2.of_comp (app X) f weak_eq.property hf,
    rw sq.w at h,
    exact CM2.of_comp_right _ _ weak_eq.property h, },
  { intro hf',
    have h : weq (app X ≫ f),
    { rw sq.w,
      exact CM2.of_comp _ _ hf' weak_eq.property, },
    exact CM2.of_comp_left _ _ weak_eq.property h, },
end

lemma weq_eq_inverse_image_homotopy_category_weq :
  model_category.weq =
cofibrant_object.homotopy_category.weq.inverse_image (cofibrant_replacement C) :=
begin
  ext X Y f,
  dsimp only [morphism_property.inverse_image, cofibrant_replacement, map],
  rw cofibrant_object.homotopy_category.weq_Q_map_iff,
  exact weq_iff _ _ (comm_sq.mk (fac f).symm),
end

include Lcof

@[simps]
def π : cofibrant_object.homotopy_category C ⥤ Hocof :=
category_theory.quotient.lift _ Lcof (λ (X Y : cofibrant_object C), begin
  let Y' : cofibrant_object C := cofibrant_object.mk (CM5a.obj (terminal.from Y.obj)),
  let φ : Y ⟶ Y' := CM5a.i (terminal.from Y.obj),
  intros f₁ f₂ h,
  haveI : is_iso (Lcof.map φ) := localization.inverts Lcof cofibrant_object.weq φ
    (by { change weq (CM5a.i (terminal.from Y.obj)), exact weak_eq.property, }),
  simp only [← cancel_mono (Lcof.map φ), ← Lcof.map_comp],
  induction h with g₁ g₂ h g₁ g₂ g₃ H₁₂ H₂₃ h₁₂ h₂₃,
  { rcases h.comp_right φ with ⟨P, H⟩,
    let Cyl := cylinder.some X.obj,
    let I' := cofibrant_object.mk Cyl.I,
    let s : I' ⟶ X := Cyl.σ,
    haveI : is_iso (Lcof.map s) := localization.inverts Lcof cofibrant_object.weq s
      (by { change weq Cyl.σ, exact weak_eq.property, }),
    let h' := H.some.to_left_homotopy Cyl,
    let ψ : I' ⟶ Y' := h'.h,
    let d₀ : X ⟶ I' := Cyl.d₀,
    let d₁ : X ⟶ I' := Cyl.d₁,
    have eq₀ : d₀ ≫ ψ = g₁ ≫ φ := h'.h₀,
    have eq₁ : d₁ ≫ ψ = g₂ ≫ φ := h'.h₁,
    simp only [← eq₀, ← eq₁, Lcof.map_comp],
    congr' 1,
    simp only [← cancel_mono (Lcof.map s), ← Lcof.map_comp],
    congr' 1,
    exact Cyl.σd₀.trans Cyl.σd₁.symm, },
  { exact h₁₂.trans h₂₃, },
end)

lemma π_inverts_weq : cofibrant_object.homotopy_category.weq.is_inverted_by (π Lcof) := λ X Y f hf,
begin
  rcases cofibrant_object.homotopy_category.Q_map_surjective _ _ f with ⟨g, hg⟩,
  subst hg,
  simp only [cofibrant_object.homotopy_category.Q_map, quotient.functor_map,
    π_map, quot.lift_on_mk],
  apply localization.inverts Lcof cofibrant_object.weq g,
  exact (cofibrant_object.homotopy_category.weq_Q_map_iff g).mp hf,
end

omit Lcof

lemma forget_comp_L_inverts_weq :
  cofibrant_object.weq.is_inverted_by (cofibrant_object.forget C ⋙ L) :=
λ X Y f hf, by convert localization.inverts L weq ((cofibrant_object.forget C).map f) hf

def R : C ⥤ Hocof := cofibrant_replacement C ⋙ π Lcof

lemma R_inverts_weq : weq.is_inverted_by (R Lcof) := λ X Y f hf,
begin
  dsimp only [R, functor.comp_map],
  exact (π_inverts_weq Lcof) _
    (by simpa only [weq_eq_inverse_image_homotopy_category_weq] using hf),
end

def forget_comp_R_iso : cofibrant_object.forget C ⋙ R Lcof ≅ Lcof :=
nat_iso.of_components (λ X, localization.iso_of_hom' Lcof cofibrant_object.weq (app' X)
  (by { dsimp [app'], exact weak_eq.property, }))
(λ X Y f, begin
  simp only [functor.comp_map, cofibrant_object.forget_map, localization.iso_of_hom'_hom],
  rw [← Lcof.map_comp, ← fac' f, Lcof.map_comp],
  refl,
end)

def R_comp_I'_iso {I' : Hocof ⥤ Ho} (sq : Comm_sq (cofibrant_object.forget C) Lcof L I') :
  R Lcof ⋙ I' ≅ L :=
nat_iso.of_components (λ X, sq.iso.app _ ≪≫
  localization.iso_of_hom' L model_category.weq (app X) weak_eq.property)
(λ X Y f, begin
  simp only [functor.comp_map, iso.trans_hom, iso.app_hom, localization.iso_of_hom'_hom, assoc,
    ← L.map_comp],
  simp only [← fac, L.map_comp, ← assoc],
  congr' 1,
  apply sq.iso.hom.naturality,
end)

def is_equivalence (I' : Hocof ⥤ Ho)
  (sq : Comm_sq (cofibrant_object.forget C) Lcof L I') : is_equivalence I' :=
localization.lifting_is_equivalence sq cofibrant_object.weq model_category.weq
  (R Lcof) (localization.lift (R Lcof) (R_inverts_weq Lcof) L)
  (R_comp_I'_iso Lcof L sq) (forget_comp_R_iso Lcof)

end cofibrant_replacement

variable {C}

def Hocof_to_Ho : Hocof ⥤ Ho :=
localization.lift ((cofibrant_object.forget C) ⋙ L)
  (cofibrant_replacement.forget_comp_L_inverts_weq L) Lcof

def Lcof_comp_Hocof_to_Ho_iso : Lcof ⋙ Hocof_to_Ho Lcof L ≅ cofibrant_object.forget C ⋙ L :=
localization.fac _ _ _

instance : is_equivalence (Hocof_to_Ho Lcof L) :=
cofibrant_replacement.is_equivalence Lcof L (Hocof_to_Ho Lcof L)
    ⟨Lcof_comp_Hocof_to_Ho_iso Lcof L⟩

lemma is_iso_Lcof_map' {X Y : cofibrant_object C} (f : X ⟶ Y) (hf : cofibrant_object.weq f) :
  is_iso (Lcof.map f) := localization.inverts Lcof cofibrant_object.weq f hf

lemma is_iso_Lcof_map {X Y : cofibrant_object C} (f : X ⟶ Y)
  [weak_eq ((cofibrant_object.forget C).map f)] : is_iso (Lcof.map f) :=
is_iso_Lcof_map' Lcof f weak_eq.property

end model_category

end algebraic_topology


open Lean

def foo : Name := `foo

def isFoo : Name → Bool
  | ``foo => true
  | _     => false

theorem ex1 : isFoo `foo = true  := rfl
theorem ex2 : isFoo `bla = false := rfl

def Bla.boo : Name := `boo

open Bla

def isBoo : Name → Bool
  | ``boo => true
  | _     => false

theorem ex3 : isBoo `Bla.boo = true := rfl
theorem ex4 : isBoo ``boo = true := rfl
theorem ex5 : ``boo = `Bla.boo := rfl


import .admits
import .misc_list

import data.finset

set_option pp.parens true

open formula

inductive is_prop_sub : formula → variable_ → variable_ → formula → Prop
| true_
  (v t : variable_) :
  is_prop_sub true_ v t true_

| pred_
  (name : pred_name_) (args : list variable_)
  (v t : variable_) :
    is_prop_sub (pred_ name args) v t (pred_ name (args.map (fun (x : variable_), if x = v then t else x)))

| eq_
  (x y : variable_)
  (v t : variable_) :
    is_prop_sub (eq_ x y) v t (eq_ (if x = v then t else x) (if y = v then t else y))

| not_
  (P : formula)
  (v t : variable_)
  (P' : formula) :
  is_prop_sub P v t P' →
  is_prop_sub P.not_ v t P'.not_

| imp_
  (P Q : formula)
  (v t : variable_)
  (P' Q' : formula) :
  is_prop_sub P v t P' →
  is_prop_sub Q v t Q' →
  is_prop_sub (P.imp_ Q) v t (P'.imp_ Q')

| forall_same_
  (x : variable_) (P : formula)
  (v t : variable_) :
  v = x →
  is_prop_sub (forall_ x P) v t (forall_ x P)

| forall_diff_nel_
  (x : variable_) (P : formula)
  (v t : variable_)
  (P' : formula) :
  ¬ v = x →
  ¬ is_free_in v (forall_ x P) →
  is_prop_sub P v t P' →
  is_prop_sub (forall_ x P) v t (forall_ x P')

| forall_diff_
  (x : variable_) (P : formula)
  (v t : variable_)
  (P' : formula) :
  ¬ v = x →
  ¬ t = x →
  is_prop_sub P v t P' →
  is_prop_sub (forall_ x P) v t (forall_ x P')

lemma fast_admits_aux_and_fast_replace_free_imp_is_prop_sub
  (P P' : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : fast_admits_aux v u binders P)
  (h2 : fast_replace_free v u P = P') :
  is_prop_sub P v u P' :=
begin
  subst h2,
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.true_,
  },
  case formula.pred_ : name args binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.pred_,
  },
  case formula.eq_ : x y binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.eq_,
  },
  case formula.not_ : P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    apply is_prop_sub.not_,
    exact P_ih binders h1,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1
  {
    unfold fast_admits_aux at h1,
    cases h1,

    apply is_prop_sub.imp_,
    {
      exact P_ih binders h1_left,
    },
    {
      exact Q_ih binders h1_right,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    cases h1,
    {
      unfold fast_replace_free,
      split_ifs,
      apply is_prop_sub.forall_same_ x P v u h1,
    },
    {
      unfold fast_replace_free,
      split_ifs,
      {
        apply is_prop_sub.forall_same_ x P v u h,
      },
      {
        by_cases c1 : is_free_in v (forall_ x P),
        {
          apply is_prop_sub.forall_diff_,
          {
            exact h,
          },
          {
            unfold is_free_in at c1,
            cases c1,
            have s1 : u ∉ binders ∪ {x},
            apply fast_admits_aux_is_free_in P v u,
            {
              exact h1,
            },
            {
              exact c1_right,
            },

            simp only [finset.mem_union, finset.mem_singleton] at s1,
            push_neg at s1,
            cases s1,
            exact s1_right,
          },
          {
            apply P_ih (binders ∪ {x}),
            exact h1,
          }
        },
        {
          apply is_prop_sub.forall_diff_nel_,
          {
            exact h,
          },
          {
            exact c1,
          },
          {
            apply P_ih (binders ∪ {x}) h1,
          },
        }
      }
    }
  },
end

lemma is_prop_sub_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ∃ (P' : formula), is_prop_sub P v u P')
  (h2 : u ∉ binders) :
  fast_admits_aux v u binders P :=
begin
  apply exists.elim h1,
  intros P' h1_1,
  clear h1,

  induction h1_1 generalizing binders,
  case is_prop_sub.true_ : h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
  },
  case is_prop_sub.pred_ : h1_1_name h1_1_args h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
    intros a1,
    exact h2,
  },
  case is_prop_sub.eq_ : h1_1_x h1_1_y h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
    intros a1,
    exact h2,
  },
  case is_prop_sub.not_ : h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_ih binders h2
  {
    unfold fast_admits_aux,
    exact h1_1_ih binders h2,
  },
  case is_prop_sub.imp_ : h1_1_P h1_1_Q h1_1_v h1_1_t h1_1_P' h1_1_Q' h1_1_1 h1_1_2 h1_1_ih_1 h1_1_ih_2 binders h2
  {
    unfold fast_admits_aux,
    split,
    {
      exact h1_1_ih_1 binders h2,
    },
    {
      exact h1_1_ih_2 binders h2,
    }
  },
  case is_prop_sub.forall_same_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_1 binders h2
  {
    unfold fast_admits_aux,
    apply or.intro_left,
    exact h1_1_1,
  },
  case is_prop_sub.forall_diff_nel_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_2 h1_1_3 h1_1_ih binders h2
  {
    unfold is_free_in at h1_1_2,
    push_neg at h1_1_2,

    unfold fast_admits_aux,

    apply or.intro_right,
    apply not_is_free_in_imp_fast_admits_aux,
    apply h1_1_2,
    exact h1_1_1,
  },
  case is_prop_sub.forall_diff_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_2 h1_1_3 h1_1_ih binders h2
  {
    unfold fast_admits_aux,
    apply or.intro_right,
    apply h1_1_ih,
    simp only [finset.mem_union, finset.mem_singleton],
    push_neg,
    split,
    {
      exact h2,
    },
    {
      exact h1_1_2,
    }
  },
end

lemma is_prop_sub_imp_fast_replace_free
  (P P' : formula)
  (v u : variable_)
  (h1 : is_prop_sub P v u P') :
  fast_replace_free v u P = P' :=
begin
  induction h1,
  case is_prop_sub.true_ : h1_v h1_t
  {
    refl,
  },
  case is_prop_sub.pred_ : h1_name h1_args h1_v h1_t
  {
    unfold fast_replace_free,
  },
  case is_prop_sub.eq_ : h1_x h1_y h1_v h1_t
  {
    unfold fast_replace_free,
  },
  case is_prop_sub.not_ : h1_P h1_v h1_t h1_P' h1_1 h1_ih
  {
    unfold fast_replace_free,
    congr,
    exact h1_ih,
  },
  case is_prop_sub.imp_ : h1_P h1_Q h1_v h1_t h1_P' h1_Q' h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    unfold fast_replace_free,
    congr,
    {
      exact h1_ih_1,
    },
    {
      exact h1_ih_2,
    }
  },
  case is_prop_sub.forall_same_ : h1_x h1_P h1_v h1_t h1_1
  {
    apply not_free_in_fast_replace_free_id,
    unfold is_free_in,
    simp only [finset.mem_sdiff, finset.mem_singleton, not_and, not_not],
    intros a1,
    contradiction,
  },
  case is_prop_sub.forall_diff_nel_ : h1_x h1_P h1_v h1_t h1_P' h1_1 h1_2 h1_3 h1_ih
  {
    unfold fast_replace_free,
    split_ifs,
    simp only [eq_self_iff_true, true_and],
    apply h1_ih,
  },
  case is_prop_sub.forall_diff_ : h1_x h1_P h1_v h1_t h1_P' h1_1 h1_2 h1_3 h1_ih
  {
    unfold fast_replace_free,
    split_ifs,
    simp only [eq_self_iff_true, true_and],
    apply h1_ih,
  },
end

example
  (P P' : formula)
  (v u : variable_) :
  is_prop_sub P v u P' ↔
    (fast_admits v u P ∧ fast_replace_free v u P = P') :=
begin
  unfold fast_admits,
  split,
  {
    intros a1,
    split,
    {
      apply is_prop_sub_imp_fast_admits_aux,
      {
        apply exists.intro P',
        exact a1,
      },
      {
        simp only [finset.not_mem_empty, not_false_iff],
      }
    },
    {
      apply is_prop_sub_imp_fast_replace_free,
      exact a1,
    }
  },
  {
    intros a1,
    cases a1,
    exact fast_admits_aux_and_fast_replace_free_imp_is_prop_sub P P' v u ∅ a1_left a1_right,
  }
end


open classical
variables (α : Type) (p q : α -> Prop)
variable a : α
variable r : Prop
example : r → (∃ x : α, r) :=
assume (h1 : r),
show ∃ x : α, r, from exists.intro a h1