/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Simon Hudon
-/
import data.pfunctor.multivariate.basic

/-!
# The W construction as a multivariate polynomial functor.

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

W types are well-founded tree-like structures. They are defined
as the least fixpoint of a polynomial functor.

## Main definitions

 * `W_mk`     - constructor
 * `W_dest    - destructor
 * `W_rec`    - recursor: basis for defining functions by structural recursion on `P.W α`
 * `W_rec_eq` - defining equation for `W_rec`
 * `W_ind`    - induction principle for `P.W α`

## Implementation notes

Three views of M-types:

 * `Wp`: polynomial functor
 * `W`: data type inductively defined by a triple:
     shape of the root, data in the root and children of the root
 * `W`: least fixed point of a polynomial functor

Specifically, we define the polynomial functor `Wp` as:

 * A := a tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   (specified inductively by `W_path`) from the root of `t` to any given node.

As a result `Wp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

## Reference

 * Jeremy Avigad, Mario M. Carneiro and Simon Hudon.
   [*Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universes u v

namespace mvpfunctor
open typevec
open_locale mvfunctor

variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- A path from the root of a tree to one of its node -/
inductive W_path : P.last.W → fin2 n → Type u
| root (a : P.A) (f : P.last.B a → P.last.W) (i : fin2 n) (c : P.drop.B a i) :
    W_path ⟨a, f⟩ i
| child (a : P.A) (f : P.last.B a → P.last.W) (i : fin2 n) (j : P.last.B a) (c : W_path (f j) i) :
    W_path ⟨a, f⟩ i

instance W_path.inhabited (x : P.last.W) {i} [I : inhabited (P.drop.B x.head i)] :
  inhabited (W_path P x i) :=
⟨ match x, I with
  | ⟨a, f ⟩, I := W_path.root a f i (@default _ I)
  end ⟩

/-- Specialized destructor on `W_path` -/
def W_path_cases_on {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path ⟨a, f⟩ ⟹ α :=
begin
  intros i x, cases x,
  case W_path.root : _ _ i c { exact g' i c },
  case W_path.child : _ _ i j c { exact g j i c}
end

/-- Specialized destructor on `W_path` -/
def W_path_dest_left {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.drop.B a ⟹ α :=
λ i c, h i (W_path.root a f i c)

/-- Specialized destructor on `W_path` -/
def W_path_dest_right {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  Π j : P.last.B a, P.W_path (f j) ⟹ α :=
λ j i c, h i (W_path.child a f i j c)

theorem W_path_dest_left_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_left (P.W_path_cases_on g' g) = g' := rfl

theorem W_path_dest_right_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_right (P.W_path_cases_on g' g) = g := rfl

theorem W_path_cases_on_eta {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W_path_cases_on (P.W_path_dest_left h) (P.W_path_dest_right h) = h :=
by ext i x; cases x; reflexivity

theorem comp_W_path_cases_on {α β : typevec n} (h : α ⟹ β) {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  h ⊚ P.W_path_cases_on g' g = P.W_path_cases_on (h ⊚ g') (λ i, h ⊚ g i) :=
by ext i x; cases x; reflexivity

/-- Polynomial functor for the W-type of `P`. `A` is a data-less well-founded
tree whereas, for a given `a : A`, `B a` is a valid path in tree `a` so
that `Wp.obj α` is made of a tree and a function from its valid paths to
the values it contains  -/
def Wp : mvpfunctor n :=
{ A := P.last.W, B := P.W_path }

/-- W-type of `P` -/
@[nolint has_nonempty_instance]
def W (α : typevec n) : Type* := P.Wp.obj α

instance mvfunctor_W : mvfunctor P.W := by delta mvpfunctor.W; apply_instance

/-!
First, describe operations on `W` as a polynomial functor.
-/

/-- Constructor for `Wp` -/
def Wp_mk {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W α :=
⟨⟨a, f⟩, f'⟩

/-- Recursor for `Wp` -/
def Wp_rec {α : typevec n} {C : Type*}
  (g : Π (a : P.A) (f : P.last.B a → P.last.W),
    (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C) :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C
| ⟨a, f⟩ f' := g a f f' (λ i, Wp_rec (f i) (P.W_path_dest_right f' i))

theorem Wp_rec_eq {α : typevec n} {C : Type*}
    (g : Π (a : P.A) (f : P.last.B a → P.last.W),
      (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C)
    (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.Wp_rec g ⟨a, f⟩ f' = g a f f' (λ i, P.Wp_rec g (f i) (P.W_path_dest_right f' i)) :=
rfl

-- Note: we could replace Prop by Type* and obtain a dependent recursor

theorem Wp_ind {α : typevec n} {C : Π x : P.last.W, P.W_path x ⟹ α → Prop}
  (ih : ∀ (a : P.A) (f : P.last.B a → P.last.W)
    (f' : P.W_path ⟨a, f⟩ ⟹ α),
      (∀ i : P.last.B a, C (f i) (P.W_path_dest_right f' i)) → C ⟨a, f⟩ f') :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C x f'
| ⟨a, f⟩ f' := ih a f f' (λ i, Wp_ind _ _)

/-!
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

/-- Constructor for `W` -/
def W_mk {α : typevec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W α :=
let g  : P.last.B a → P.last.W  := λ i, (f i).fst,
    g' : P.W_path ⟨a, g⟩ ⟹ α := P.W_path_cases_on f' (λ i, (f i).snd) in
⟨⟨a, g⟩, g'⟩

/-- Recursor for `W` -/
def W_rec {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C) :
  P.W α → C
| ⟨a, f'⟩ :=
  let g' (a : P.A) (f : P.last.B a → P.last.W) (h : P.W_path ⟨a, f⟩ ⟹ α)
        (h' : P.last.B a → C) : C :=
      g a (P.W_path_dest_left h) (λ i, ⟨f i, P.W_path_dest_right h i⟩) h' in
  P.Wp_rec g' a f'

/-- Defining equation for the recursor of `W` -/
theorem W_rec_eq {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_rec g (P.W_mk a f' f) = g a f' f (λ i, P.W_rec g (f i)) :=
begin
  rw [W_mk, W_rec], dsimp, rw [Wp_rec_eq],
  dsimp only [W_path_dest_left_W_path_cases_on, W_path_dest_right_W_path_cases_on],
  congr; ext1 i; cases (f i); refl
end

/-- Induction principle for `W` -/
theorem W_ind {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α),
      (∀ i, C (f i)) → C (P.W_mk a f' f)) :
  ∀ x, C x :=
begin
  intro x, cases x with a f,
  apply @Wp_ind n P α (λ a f, C ⟨a, f⟩), dsimp,
  intros a f f' ih',
  dsimp [W_mk] at ih,
  let ih'' := ih a (P.W_path_dest_left f') (λ i, ⟨f i, P.W_path_dest_right f' i⟩),
  dsimp at ih'', rw W_path_cases_on_eta at ih'',
  apply ih'',
  apply ih'
end

theorem W_cases {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α), C (P.W_mk a f' f)) :
  ∀ x, C x :=
P.W_ind (λ a f' f ih', ih a f' f)

/-- W-types are functorial -/
def W_map {α β : typevec n} (g : α ⟹ β) : P.W α → P.W β :=
λ x, g <$$> x

theorem W_mk_eq {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W)
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_mk a g' (λ i, ⟨f i, g i⟩) =
    ⟨⟨a, f⟩, P.W_path_cases_on g' g⟩ := rfl

theorem W_map_W_mk {α β : typevec n} (g : α ⟹ β)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  g <$$> P.W_mk a f' f = P.W_mk a (g ⊚ f') (λ i, g <$$> f i) :=
begin
  show _ = P.W_mk a (g ⊚ f') (mvfunctor.map g ∘ f),
  have : mvfunctor.map g ∘ f = λ i, ⟨(f i).fst, g ⊚ ((f i).snd)⟩,
  { ext i : 1, dsimp [function.comp], cases (f i), refl },
  rw this,
  have : f = λ i, ⟨(f i).fst, (f i).snd⟩,
  { ext1, cases (f x), refl },
  rw this, dsimp,
  rw [W_mk_eq, W_mk_eq],
  have h := mvpfunctor.map_eq P.Wp g,
  rw [h, comp_W_path_cases_on]
end

-- TODO: this technical theorem is used in one place in constructing the initial algebra.
-- Can it be avoided?

/-- Constructor of a value of `P.obj (α ::: β)` from components.
Useful to avoid complicated type annotation -/
@[reducible] def obj_append1 {α : typevec n} {β : Type*}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.obj (α ::: β) :=
⟨a, split_fun f' f⟩

theorem map_obj_append1 {α γ : typevec n} (g : α ⟹ γ)
  (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
append_fun g (P.W_map g) <$$> P.obj_append1 a f' f =
  P.obj_append1 a (g ⊚ f') (λ x, P.W_map g (f x)) :=
by rw [obj_append1, obj_append1, map_eq, append_fun, ← split_fun_comp]; refl

/-!
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

/-- Constructor for the W-type of `P` -/
def W_mk' {α : typevec n} : P.obj (α ::: P.W α) → P.W α
| ⟨a, f⟩ := P.W_mk a (drop_fun f) (last_fun f)

/-- Destructor for the W-type of `P` -/
def W_dest' {α : typevec.{u} n} : P.W α → P.obj (α.append1 (P.W α)) :=
P.W_rec (λ a f' f _, ⟨a, split_fun f' f⟩)

theorem W_dest'_W_mk {α : typevec n}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_dest' (P.W_mk a f' f) = ⟨a, split_fun f' f⟩ :=
by rw [W_dest', W_rec_eq]

theorem W_dest'_W_mk' {α : typevec n} (x : P.obj (α.append1 (P.W α))) :
  P.W_dest' (P.W_mk' x) = x :=
by cases x with a f; rw [W_mk', W_dest'_W_mk, split_drop_fun_last_fun]

end mvpfunctor


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

Basic properties of holors.

Holors are indexed collections of tensor coefficients. Confusingly,
they are often called tensors in physics and in the neural network
community.

Based on the tensor library found in https://www.isa-afp.org/entries/Deep_Learning.html.
-/
import data.list.basic
import algebra.module
import algebra.pi_instances
import tactic.interactive
import tactic.tidy
import tactic.pi_instances

universes u

open list

/-- `holor_index ds` is the type of valid index tuples to identify an entry of a holor of dimenstions `ds` -/
def holor_index (ds : list ℕ) : Type := { is : list ℕ // forall₂ (<) is ds}

namespace holor_index
variables {ds₁ ds₂ ds₃ : list ℕ}

def take : Π {ds₁ : list ℕ}, holor_index (ds₁ ++ ds₂) → holor_index ds₁
| ds is := ⟨ list.take (length ds) is.1, forall₂_take_append is.1 ds ds₂ is.2 ⟩

def drop : Π {ds₁ : list ℕ}, holor_index (ds₁ ++ ds₂) → holor_index ds₂
| ds is := ⟨ list.drop (length ds) is.1, forall₂_drop_append is.1 ds ds₂ is.2 ⟩

lemma cast_type (is : list ℕ) (eq : ds₁ = ds₂) (h : forall₂ (<) is ds₁) :
  (cast (congr_arg holor_index eq) ⟨is, h⟩).val = is :=
by subst eq; refl

def assoc_right :
  holor_index (ds₁ ++ ds₂ ++ ds₃) → holor_index (ds₁ ++ (ds₂ ++ ds₃)) :=
cast (congr_arg holor_index (append_assoc ds₁ ds₂ ds₃))

def assoc_left :
  holor_index (ds₁ ++ (ds₂ ++ ds₃)) → holor_index (ds₁ ++ ds₂ ++ ds₃) :=
cast (congr_arg holor_index (append_assoc ds₁ ds₂ ds₃).symm)

lemma take_take :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.take = t.take.take
| ⟨ is , h ⟩ := subtype.eq (by simp [assoc_right,take, cast_type, list.take_take, nat.le_add_right, min_eq_left])

lemma drop_take :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.drop.take = t.take.drop
| ⟨ is , h ⟩ := subtype.eq (by simp [assoc_right, take, drop, cast_type, list.drop_take])

lemma drop_drop :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.drop.drop = t.drop
| ⟨ is , h ⟩ := subtype.eq (by simp [assoc_right,drop, cast_type, list.drop_drop])

end holor_index

/-- Holor (indexed collections of tensor coefficients) -/
def holor (α : Type u) (ds:list ℕ) := holor_index ds → α

namespace holor

variables {α : Type} {d : ℕ} {ds : list ℕ} {ds₁ : list ℕ} {ds₂ : list ℕ} {ds₃ : list ℕ}

instance [inhabited α] : inhabited (holor α ds) := ⟨λ t, default α⟩
instance [has_zero α] : has_zero (holor α ds) := ⟨λ t, 0⟩
instance [has_add α] : has_add (holor α ds) := ⟨λ x y t, x t + y t⟩
instance [has_neg α] : has_neg (holor α ds) :=  ⟨λ a t, - a t⟩

instance [add_semigroup α] : add_semigroup (holor α ds) := by pi_instance

instance [add_comm_semigroup α] : add_comm_semigroup (holor α ds) := by pi_instance

instance [add_monoid α] : add_monoid (holor α ds) := by pi_instance

instance [add_comm_monoid α] : add_comm_monoid (holor α ds) := by pi_instance

instance [add_group α] : add_group (holor α ds) := by pi_instance

instance [add_comm_group α] : add_comm_group (holor α ds) := by pi_instance

/- scalar product -/

instance [has_mul α] : has_scalar α (holor α ds) :=
  ⟨λ a x, λ t, a * x t⟩

instance [ring α] : module α (holor α ds) := pi.module α

instance [discrete_field α] : vector_space α (holor α ds) := ⟨α, holor α ds⟩

/- tensor product -/

def mul [s : has_mul α] (x : holor α ds₁) (y : holor α ds₂) : holor α (ds₁ ++ ds₂) :=
  λ t, x (t.take) * y (t.drop)

local infix ` ⊗ ` : 70 := mul

lemma cast_type (eq : ds₁ = ds₂) (a : holor α ds₁) :
  cast (congr_arg (holor α) eq) a = (λ t, a (cast (congr_arg holor_index eq.symm) t)) :=
by subst eq; refl

def assoc_right :
  holor α (ds₁ ++ ds₂ ++ ds₃) → holor α (ds₁ ++ (ds₂ ++ ds₃)) :=
cast (congr_arg (holor α) (append_assoc ds₁ ds₂ ds₃))

def assoc_left :
  holor α (ds₁ ++ (ds₂ ++ ds₃)) → holor α (ds₁ ++ ds₂ ++ ds₃) :=
cast (congr_arg (holor α) (append_assoc ds₁ ds₂ ds₃).symm)

lemma mul_assoc0 [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) :
  x ⊗ y ⊗ z = (x ⊗ (y ⊗ z)).assoc_left :=
funext (assume t : holor_index (ds₁ ++ ds₂ ++ ds₃),
begin
  rw assoc_left,
  unfold mul,
  rw mul_assoc,
  rw [←holor_index.take_take, ←holor_index.drop_take, ←holor_index.drop_drop],
  rw cast_type,
  refl,
  rw append_assoc
end)

lemma mul_assoc [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃):
  mul (mul x y) z == (mul x (mul y z)) :=
by simp [cast_heq, mul_assoc0, assoc_left].

lemma mul_left_distrib [distrib α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₂) :
  x ⊗ (y + z) = x ⊗ y + x ⊗ z :=
funext (λt, left_distrib (x (holor_index.take t)) (y (holor_index.drop t)) (z (holor_index.drop t)))

lemma mul_right_distrib [distrib α] (x : holor α ds₁) (y : holor α ds₁) (z : holor α ds₂) :
  (x + y) ⊗ z = x ⊗ z + y ⊗ z :=
funext (λt, right_distrib (x (holor_index.take t)) (y (holor_index.take t)) (z (holor_index.drop t)))

@[simp] lemma zero_mul {α : Type} [ring α] (x : holor α ds₂) :
  (0 : holor α ds₁) ⊗ x = 0 :=
funext (λ t, zero_mul (x (holor_index.drop t)))

@[simp] lemma mul_zero {α : Type} [ring α] (x : holor α ds₁) :
  x ⊗ (0 :holor α ds₂) = 0 :=
funext (λ t, mul_zero (x (holor_index.take t)))

lemma mul_scalar_mul [monoid α] (x : holor α []) (y : holor α ds) :
  x ⊗ y = x ⟨[], forall₂.nil⟩ • y :=
by simp [mul, has_scalar.smul, holor_index.take, holor_index.drop]

/- holor slices -/

/-- A slice is a subholor consisting of all entries with initial index i. -/
def slice (x : holor α (d :: ds)) (i : ℕ) (h : i < d) : holor α ds :=
  (λ is : holor_index ds, x ⟨ i :: is.1, forall₂.cons h is.2⟩)

def unit_vec [monoid α] [add_monoid α] (d : ℕ) (j : ℕ) : holor α [d] :=
  λ ti, if ti.1 = [j] then 1 else 0

lemma holor_index_cons_decomp (p: holor_index (d :: ds) → Prop):
  Π (t : holor_index (d :: ds)),
    (∀ i is, Π h : t.1 = i :: is, p ⟨ i :: is, begin rw [←h], exact t.2 end ⟩ ) → p t
| ⟨[], hforall₂⟩        hp := absurd (forall₂_nil_left_iff.1 hforall₂) (cons_ne_nil d ds)
| ⟨(i :: is), hforall₂⟩ hp := hp i is rfl

/-- Two holors are equal if all their slices are equal. -/
lemma slice_eq (x : holor α (d :: ds)) (y : holor α (d :: ds))
  (h : slice x = slice y) : x = y :=
funext $ λ t : holor_index (d :: ds), holor_index_cons_decomp (λ t, x t = y t) t $ λ i is hiis,
have hiisdds: forall₂ (<) (i :: is) (d :: ds), begin rw [←hiis], exact t.2 end,
have hid:     i<d,                             from (forall₂_cons.1 hiisdds).1,
have hisds:   forall₂ (<) is ds,               from (forall₂_cons.1 hiisdds).2,
calc
  x ⟨i :: is, _⟩ = slice x i hid ⟨is, hisds⟩  : congr_arg (λ t, x t) (subtype.eq rfl)
              ... = slice y i hid ⟨is, hisds⟩  : by rw h
              ... = y ⟨i :: is, _⟩             : congr_arg (λ t, y t) (subtype.eq rfl)

lemma slice_unit_vec_mul [ring α] {i : ℕ} {j : ℕ}
  (hid : i < d) (x : holor α ds) :
  slice (unit_vec d j ⊗ x) i hid = if i=j then x else 0 :=
funext $ λ t : holor_index ds, if h : i = j
  then by simp [slice, mul, holor_index.take, unit_vec, holor_index.drop, h]
  else by simp [slice, mul, holor_index.take, unit_vec, holor_index.drop, h]; refl

lemma slice_add [has_add α] (i : ℕ) (hid : i < d)  (x : holor α (d :: ds)) (y : holor α (d :: ds)):
  slice x i hid + slice y i hid = slice (x + y) i hid := funext (λ t, by simp [slice,(+)])

lemma slice_zero [has_zero α] (i : ℕ) (hid : i < d)  :
  slice (0 : holor α (d :: ds)) i hid = 0 := funext (λ t, by simp [slice]; refl)

lemma slice_sum [add_comm_monoid α] {β : Type}
  (i : ℕ) (hid : i < d) (s : finset β) (f : β → holor α (d :: ds)):
  finset.sum s (λ x, slice (f x) i hid) = slice (finset.sum s f) i hid :=
begin
  letI := classical.dec_eq β,
  refine finset.induction_on s _ _,
  { simp [slice_zero] },
  { intros _ _ h_not_in ih,
    rw [finset.sum_insert h_not_in, ih, slice_add, finset.sum_insert h_not_in] }
end

/-- The original holor can be recovered from its slices by multiplying with unit vectors and summing up. -/
@[simp] lemma sum_unit_vec_mul_slice [ring α] (x : holor α (d :: ds)) :
  (finset.range d).attach.sum
    (λ i, unit_vec d i.1 ⊗ slice x i.1 (nat.succ_le_of_lt (finset.mem_range.1 i.2))) = x :=
begin
  apply slice_eq _ _ _,
  ext i hid,
  rw [←slice_sum],
  simp only [slice_unit_vec_mul hid],
  rw finset.sum_eq_single (subtype.mk i _),
  { simp, refl },
  { assume (b : {x // x ∈ finset.range d}) (hb : b ∈ (finset.range d).attach) (hbi : b ≠ ⟨i, _⟩),
    have hbi' : i ≠ b.val,
    { apply not.imp hbi,
      { assume h0 : i = b.val,
        apply subtype.eq,
        simp only [h0] },
      { exact finset.mem_range.2 hid } },
    simp [hbi']},
  { assume hid' : subtype.mk i _ ∉ finset.attach (finset.range d),
    exfalso,
    exact absurd (finset.mem_attach _ _) hid'
  }
end

/- CP rank -/

inductive cprank_max1 [has_mul α]: Π {ds}, holor α ds → Prop
| nil (x : holor α []) :
    cprank_max1 x
| cons {d} {ds} (x : holor α [d]) (y : holor α ds) :
    cprank_max1 y → cprank_max1 (x ⊗ y)

inductive cprank_max [has_mul α] [add_monoid α] : ℕ → Π {ds}, holor α ds → Prop
| zero {ds} :
    cprank_max 0 (0 : holor α ds)
| succ n {ds} (x : holor α ds) (y : holor α ds) :
    cprank_max1 x → cprank_max n y →  cprank_max (n+1) (x + y)

lemma cprank_max_nil [monoid α] [add_monoid α] (x : holor α nil) : cprank_max 1 x :=
  have h : _, from cprank_max.succ 0 x 0 (cprank_max1.nil x) (cprank_max.zero),
  by rwa [add_zero x, zero_add] at h

lemma cprank_max_1 [monoid α] [add_monoid α] {x : holor α ds}
  (h : cprank_max1 x) : cprank_max 1 x :=
have h' : _, from cprank_max.succ 0 x 0 h cprank_max.zero,
by rwa [zero_add, add_zero] at h'

lemma cprank_max_add [monoid α] [add_monoid α]:
  ∀ {m : ℕ} {n : ℕ} {x : holor α ds} {y : holor α ds},
  cprank_max m x → cprank_max n y → cprank_max (m + n) (x + y)
| 0     n x y (cprank_max.zero) hy := by simp [hy]
| (m+1) n _ y (cprank_max.succ k x₁ x₂ hx₁ hx₂) hy :=
begin
  simp only [add_comm, add_assoc],
  apply cprank_max.succ,
  { assumption },
  { exact cprank_max_add hx₂ hy }
end

lemma cprank_max_mul [ring α] :
  ∀ (n : ℕ) (x : holor α [d]) (y : holor α ds), cprank_max n y → cprank_max n (x ⊗ y)
| 0 x _ (cprank_max.zero) := by simp [mul_zero x, cprank_max.zero]
| (n+1) x _ (cprank_max.succ k y₁ y₂ hy₁ hy₂) :=
begin
  rw mul_left_distrib,
  rw nat.add_comm,
  apply cprank_max_add,
  { exact cprank_max_1 (cprank_max1.cons _ _ hy₁) },
  { exact cprank_max_mul k x y₂ hy₂ }
end

lemma cprank_max_sum [ring α] {β} {n : ℕ} (s : finset β) (f : β → holor α ds) :
  (∀ x ∈ s, cprank_max n (f x)) → cprank_max (s.card * n) (finset.sum s f) :=
by letI := classical.dec_eq β;
exact finset.induction_on s
  (by simp [cprank_max.zero])
  (begin
    assume x s (h_x_notin_s : x ∉ s) ih h_cprank,
    simp only [finset.sum_insert h_x_notin_s,finset.card_insert_of_not_mem h_x_notin_s],
    rw nat.right_distrib,
    simp only [nat.one_mul, nat.add_comm],
    have ih' : cprank_max (finset.card s * n) (finset.sum s f),
    {
      apply ih,
      assume (x : β) (h_x_in_s: x ∈ s),
      simp only [h_cprank, finset.mem_insert_of_mem, h_x_in_s]
    },
    exact (cprank_max_add (h_cprank x (finset.mem_insert_self x s)) ih')
  end)

lemma cprank_max_upper_bound [ring α] : Π {ds}, ∀ x : holor α ds, cprank_max ds.prod x
| [] x := cprank_max_nil x
| (d :: ds) x :=
have h_summands : Π (i : {x // x ∈ finset.range d}),
  cprank_max ds.prod (unit_vec d i.1 ⊗ slice x i.1 (mem_range.1 i.2)),
  from λ i, cprank_max_mul _ _ _ (cprank_max_upper_bound (slice x i.1 (mem_range.1 i.2))),
have h_dds_prod : (list.cons d ds).prod = finset.card (finset.range d) * prod ds,
  by simp [finset.card_range],
have cprank_max (finset.card (finset.attach (finset.range d)) * prod ds)
  (finset.sum (finset.attach (finset.range d))
  (λ (i : {x // x ∈ finset.range d}), unit_vec d (i.val)⊗slice x (i.val) (mem_range.1 i.2))),
  from cprank_max_sum (finset.range d).attach _ (λ i _, h_summands i),
have h_cprank_max_sum : cprank_max (finset.card (finset.range d) * prod ds)
  (finset.sum (finset.attach (finset.range d))
  (λ (i : {x // x ∈ finset.range d}), unit_vec d (i.val)⊗slice x (i.val) (mem_range.1 i.2))),
  by rwa [finset.card_attach] at this,
begin
  rw [←sum_unit_vec_mul_slice x],
  rw [h_dds_prod],
  exact h_cprank_max_sum,
end

noncomputable def cprank [ring α] (x : holor α ds) : nat :=
@nat.find (λ n, cprank_max n x) (classical.dec_pred _) ⟨ds.prod, cprank_max_upper_bound x⟩

lemma cprank_upper_bound [ring α] :
  Π {ds}, ∀ x : holor α ds, cprank x ≤ ds.prod :=
λ ds (x : holor α ds),
  by letI := classical.dec_pred (λ (n : ℕ), cprank_max n x);
  exact nat.find_min'
    ⟨ds.prod, show (λ n, cprank_max n x) ds.prod, from cprank_max_upper_bound x⟩
    (cprank_max_upper_bound x)

end holor


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

universe u v

/- Classical reasoning support -/

namespace Classical

axiom choice {α : Sort u} : Nonempty α → α

noncomputable def indefiniteDescription {α : Sort u} (p : α → Prop) (h : ∃ x, p x) : {x // p x} :=
  choice <| let ⟨x, px⟩ := h; ⟨⟨x, px⟩⟩

noncomputable def choose {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : α :=
  (indefiniteDescription p h).val

theorem chooseSpec {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : p (choose h) :=
  (indefiniteDescription p h).property

/- Diaconescu's theorem: excluded middle from choice, Function extensionality and propositional extensionality. -/
theorem em (p : Prop) : p ∨ ¬p :=
  let U (x : Prop) : Prop := x = True ∨ p;
  let V (x : Prop) : Prop := x = False ∨ p;
  have exU : ∃ x, U x := ⟨True, Or.inl rfl⟩;
  have exV : ∃ x, V x := ⟨False, Or.inl rfl⟩;
  let u : Prop := choose exU;
  let v : Prop := choose exV;
  have uDef : U u := chooseSpec exU;
  have vDef : V v := chooseSpec exV;
  have notUvOrP : u ≠ v ∨ p :=
    match uDef, vDef with
    | Or.inr h, _ => Or.inr h
    | _, Or.inr h => Or.inr h
    | Or.inl hut, Or.inl hvf =>
      have hne : u ≠ v := hvf.symm ▸ hut.symm ▸ trueNeFalse
      Or.inl hne
  have pImpliesUv : p → u = v :=
    fun hp =>
    have hpred : U = V :=
      funext fun x =>
        have hl : (x = True ∨ p) → (x = False ∨ p) :=
          fun a => Or.inr hp;
        have hr : (x = False ∨ p) → (x = True ∨ p) :=
          fun a => Or.inr hp;
        show (x = True ∨ p) = (x = False ∨ p) from
          propext (Iff.intro hl hr);
    have h₀ : ∀ exU exV, @choose _ U exU = @choose _ V exV :=
      hpred ▸ fun exU exV => rfl;
    show u = v from h₀ ..;
  match notUvOrP with
  | Or.inl hne => Or.inr (mt pImpliesUv hne)
  | Or.inr h   => Or.inl h

theorem existsTrueOfNonempty {α : Sort u} : Nonempty α → ∃ x : α, True
  | ⟨x⟩ => ⟨x, trivial⟩

noncomputable def inhabitedOfNonempty {α : Sort u} (h : Nonempty α) : Inhabited α :=
  ⟨choice h⟩

noncomputable def inhabitedOfExists {α : Sort u} {p : α → Prop} (h : ∃ x, p x) : Inhabited α :=
  inhabitedOfNonempty (Exists.elim h (fun w hw => ⟨w⟩))

/- all propositions are Decidable -/
noncomputable scoped instance (priority := low) propDecidable (a : Prop) : Decidable a :=
  choice <| match em a with
    | Or.inl h => ⟨isTrue h⟩
    | Or.inr h => ⟨isFalse h⟩

noncomputable def decidableInhabited (a : Prop) : Inhabited (Decidable a) where
  default := inferInstance

noncomputable def typeDecidableEq (α : Sort u) : DecidableEq α :=
  fun x y => inferInstance

noncomputable def typeDecidable (α : Sort u) : PSum α (α → False) :=
  match (propDecidable (Nonempty α)) with
  | (isTrue hp)  => PSum.inl (@arbitrary _ (inhabitedOfNonempty hp))
  | (isFalse hn) => PSum.inr (fun a => absurd (Nonempty.intro a) hn)

noncomputable def strongIndefiniteDescription {α : Sort u} (p : α → Prop) (h : Nonempty α) : {x : α // (∃ y : α, p y) → p x} :=
  @dite _ (∃ x : α, p x) (propDecidable _)
    (fun (hp : ∃ x : α, p x) =>
      show {x : α // (∃ y : α, p y) → p x} from
      let xp := indefiniteDescription _ hp;
      ⟨xp.val, fun h' => xp.property⟩)
    (fun hp => ⟨choice h, fun h => absurd h hp⟩)

/- the Hilbert epsilon Function -/

noncomputable def epsilon {α : Sort u} [h : Nonempty α] (p : α → Prop) : α :=
  (strongIndefiniteDescription p h).val

theorem epsilonSpecAux {α : Sort u} (h : Nonempty α) (p : α → Prop) : (∃ y, p y) → p (@epsilon α h p) :=
  (strongIndefiniteDescription p h).property

theorem epsilonSpec {α : Sort u} {p : α → Prop} (hex : ∃ y, p y) : p (@epsilon α (nonemptyOfExists hex) p) :=
  epsilonSpecAux (nonemptyOfExists hex) p hex

theorem epsilonSingleton {α : Sort u} (x : α) : @epsilon α ⟨x⟩ (fun y => y = x) = x :=
  @epsilonSpec α (fun y => y = x) ⟨x, rfl⟩

/- the axiom of choice -/

theorem axiomOfChoice {α : Sort u} {β : α → Sort v} {r : ∀ x, β x → Prop} (h : ∀ x, ∃ y, r x y) : ∃ (f : ∀ x, β x), ∀ x, r x (f x) :=
  ⟨_, fun x => chooseSpec (h x)⟩

theorem skolem {α : Sort u} {b : α → Sort v} {p : ∀ x, b x → Prop} : (∀ x, ∃ y, p x y) ↔ ∃ (f : ∀ x, b x), ∀ x, p x (f x) :=
  ⟨axiomOfChoice, fun ⟨f, hw⟩ (x) => ⟨f x, hw x⟩⟩

theorem propComplete (a : Prop) : a = True ∨ a = False := by
  cases em a with
  | inl _  => apply Or.inl; apply propext; apply Iff.intro; { intros; apply True.intro }; { intro; assumption }
  | inr hn => apply Or.inr; apply propext; apply Iff.intro; { intro h; exact hn h }; { intro h; apply False.elim h }

-- this supercedes byCases in Decidable
theorem byCases {p q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q :=
  Decidable.byCases (dec := propDecidable _) hpq hnpq

-- this supercedes byContradiction in Decidable
theorem byContradiction {p : Prop} (h : ¬p → False) : p :=
  Decidable.byContradiction (dec := propDecidable _) h

macro "byCases" h:ident ":" e:term : tactic =>
  `(cases em $e:term with
    | inl $h:ident => _
    | inr $h:ident => _)

end Classical


import algebra.category.Module.basic
import linear_algebra.finite_dimensional

/-!
Every monomorphism in fdVec splits.

This is not-so-secretly an exercise in using the linear algebra library
-/

variables (𝕜 : Type) [field 𝕜]

open category_theory

abbreviation Vec := Module 𝕜

@[derive category]
def fdVec := full_subcategory (λ V : Vec 𝕜, finite_dimensional 𝕜 V)

/--
We set up a `has_coe_to_sort` for `fdVec 𝕜`, sending an object directly to the underlying type.
-/
instance : has_coe_to_sort (fdVec 𝕜) (Type*) :=
{ coe := λ V, V.obj }

/--
Lean can already work out that this underlying type has the `module 𝕜` typeclass.
-/
example (V : fdVec 𝕜) : module 𝕜 V := by apply_instance

/--
But we need to tell it about the availability of the `finite_dimensional 𝕜` typeclass.
-/
instance fdVec_finite_dimensional (V : fdVec 𝕜) : finite_dimensional 𝕜 V := V.property

def exercise {X Y : fdVec 𝕜} (f : X ⟶ Y) [mono f] : split_mono f :=
-- We want to
-- * pick a basis of `X`, using `exists_is_basis`
-- * see that its image under `f` is linearly independent in `Y`, using `linear_independent.image_subtype`
-- * extend that set to a basis of `Y` using `exists_subset_is_basis`
-- * define a map back using `is_basis.constr`
-- * check it has the right property, using `is_basis.ext`
sorry

/-!
In practice, one should just prove this theorem directly in the linear algebra library,
without reference to `fdVec`. The statement will be more verbose!
The proof of the "categorical" statement should just be one line.
-/


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

! This file was ported from Lean 3 source module set_theory.cardinal.continuum
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.SetTheory.Cardinal.Ordinal

/-!
# Cardinality of continuum

In this file we define `Cardinal.continuum` (notation: `𝔠`, localized in `Cardinal`) to be `2 ^ ℵ₀`.
We also prove some `simp` lemmas about cardinal arithmetic involving `𝔠`.

## Notation

- `𝔠` : notation for `Cardinal.continuum` in locale `Cardinal`.
-/

namespace Cardinal

universe u v

open Cardinal

/-- Cardinality of continuum. -/
def continuum : Cardinal.{u} :=
  2 ^ aleph0.{u}
#align cardinal.continuum Cardinal.continuum

-- mathport name: Cardinal.continuum
scoped notation "𝔠" => Cardinal.continuum

@[simp]
theorem two_power_aleph0 : 2 ^ aleph0.{u} = continuum.{u} :=
  rfl
#align cardinal.two_power_aleph_0 Cardinal.two_power_aleph0

@[simp]
theorem lift_continuum : lift.{v} 𝔠 = 𝔠 := by
  rw [← two_power_aleph0, lift_two_power, lift_aleph0, two_power_aleph0]
#align cardinal.lift_continuum Cardinal.lift_continuum

/-!
### Inequalities
-/

theorem aleph0_lt_continuum : ℵ₀ < 𝔠 :=
  cantor ℵ₀
#align cardinal.aleph_0_lt_continuum Cardinal.aleph0_lt_continuum

theorem aleph0_le_continuum : ℵ₀ ≤ 𝔠 :=
  aleph0_lt_continuum.le
#align cardinal.aleph_0_le_continuum Cardinal.aleph0_le_continuum

@[simp]
theorem beth_one : beth 1 = 𝔠 := by simpa using beth_succ 0
#align cardinal.beth_one Cardinal.beth_one

theorem nat_lt_continuum (n : ℕ) : ↑n < 𝔠 :=
  (nat_lt_aleph0 n).trans aleph0_lt_continuum
#align cardinal.nat_lt_continuum Cardinal.nat_lt_continuum

theorem mk_set_nat : (#Set ℕ) = 𝔠 := by simp
#align cardinal.mk_set_nat Cardinal.mk_set_nat

theorem continuum_pos : 0 < 𝔠 :=
  nat_lt_continuum 0
#align cardinal.continuum_pos Cardinal.continuum_pos

theorem continuum_ne_zero : 𝔠 ≠ 0 :=
  continuum_pos.ne'
#align cardinal.continuum_ne_zero Cardinal.continuum_ne_zero

theorem aleph_one_le_continuum : aleph 1 ≤ 𝔠 := by
  rw [← succ_aleph0]
  exact Order.succ_le_of_lt aleph0_lt_continuum
#align cardinal.aleph_one_le_continuum Cardinal.aleph_one_le_continuum

@[simp]
theorem continuum_toNat : toNat continuum = 0 :=
  toNat_apply_of_aleph0_le aleph0_le_continuum
#align cardinal.continuum_to_nat Cardinal.continuum_toNat

@[simp]
theorem continuum_toPartENat : toPartENat continuum = ⊤ :=
  toPartENat_apply_of_aleph0_le aleph0_le_continuum
#align cardinal.continuum_to_part_enat Cardinal.continuum_toPartENat

/-!
### Addition
-/

@[simp]
theorem aleph0_add_continuum : ℵ₀ + 𝔠 = 𝔠 :=
  add_eq_right aleph0_le_continuum aleph0_le_continuum
#align cardinal.aleph_0_add_continuum Cardinal.aleph0_add_continuum

@[simp]
theorem continuum_add_aleph0 : 𝔠 + ℵ₀ = 𝔠 :=
  (add_comm _ _).trans aleph0_add_continuum
#align cardinal.continuum_add_aleph_0 Cardinal.continuum_add_aleph0

@[simp]
theorem continuum_add_self : 𝔠 + 𝔠 = 𝔠 :=
  add_eq_right aleph0_le_continuum le_rfl
#align cardinal.continuum_add_self Cardinal.continuum_add_self

@[simp]
theorem nat_add_continuum (n : ℕ) : ↑n + 𝔠 = 𝔠 :=
  add_eq_right aleph0_le_continuum (nat_lt_continuum n).le
#align cardinal.nat_add_continuum Cardinal.nat_add_continuum

@[simp]

/-!
### Multiplication
-/

@[simp]
theorem continuum_mul_self : 𝔠 * 𝔠 = 𝔠 :=
  mul_eq_left aleph0_le_continuum le_rfl continuum_ne_zero
#align cardinal.continuum_mul_self Cardinal.continuum_mul_self

@[simp]
theorem continuum_mul_aleph0 : 𝔠 * ℵ₀ = 𝔠 :=
  mul_eq_left aleph0_le_continuum aleph0_le_continuum aleph0_ne_zero
#align cardinal.continuum_mul_aleph_0 Cardinal.continuum_mul_aleph0

@[simp]
theorem aleph0_mul_continuum : ℵ₀ * 𝔠 = 𝔠 :=
  (mul_comm _ _).trans continuum_mul_aleph0
#align cardinal.aleph_0_mul_continuum Cardinal.aleph0_mul_continuum

@[simp]
theorem nat_mul_continuum {n : ℕ} (hn : n ≠ 0) : ↑n * 𝔠 = 𝔠 :=
  mul_eq_right aleph0_le_continuum (nat_lt_continuum n).le (Nat.cast_ne_zero.2 hn)
#align cardinal.nat_mul_continuum Cardinal.nat_mul_continuum

@[simp]
theorem continuum_mul_nat {n : ℕ} (hn : n ≠ 0) : 𝔠 * n = 𝔠 :=
  (mul_comm _ _).trans (nat_mul_continuum hn)
#align cardinal.continuum_mul_nat Cardinal.continuum_mul_nat

/-!
### Power
-/

@[simp]
theorem aleph0_power_aleph0 : aleph0.{u} ^ aleph0.{u} = 𝔠 :=
  power_self_eq le_rfl
#align cardinal.aleph_0_power_aleph_0 Cardinal.aleph0_power_aleph0

@[simp]
theorem nat_power_aleph0 {n : ℕ} (hn : 2 ≤ n) : (n ^ aleph0.{u} : Cardinal.{u}) = 𝔠 :=
  nat_power_eq le_rfl hn
#align cardinal.nat_power_aleph_0 Cardinal.nat_power_aleph0

@[simp]
theorem continuum_power_aleph0 : continuum.{u} ^ aleph0.{u} = 𝔠 := by
  rw [← two_power_aleph0, ← power_mul, mul_eq_left le_rfl le_rfl aleph0_ne_zero]
#align cardinal.continuum_power_aleph_0 Cardinal.continuum_power_aleph0

end Cardinal


import cautomaton utils data.nat.basic

open utils

namespace gol

section gol

open list function

inductive cellT | A | D

open cellT

def cellT_str : cellT → string
  | A := "X"
  | D := " "

instance cellT_to_str : has_to_string cellT := ⟨cellT_str⟩

instance cellT_repr : has_repr cellT := ⟨cellT_str⟩

instance cellT_deceq : decidable_eq cellT :=
	λl r,
		begin
			cases l; cases r; try {exact is_true rfl}; apply is_false; trivial
		end

instance : has_coe cellT bool := ⟨λx, x = A⟩

instance coe_back : has_coe bool cellT := ⟨λx, if x then A else D⟩

def step (cell : cellT) (alive_neighbours : ℕ) : cellT :=
  if cell then
    if alive_neighbours < 2 then D else
    if bor (alive_neighbours = 2) (alive_neighbours = 3) then A
    else D
  else
    if alive_neighbours = 3 then A
    else D

def gol_step (cell : cellT) (neigh : list cellT) :=
  step cell (count_at_single neigh A)

end gol

open cellT

attribute [reducible]
def gol := cautomaton cellT

def mk_gol (g : vec_grid₀ cellT) : gol :=
  ⟨g, D, cautomatons.moore, sum.inl cautomatons.ext_one, gol_step⟩

def empty := fgrid₀.mk 2 2 dec_trivial ⟨0, 1⟩ (λx y, D)

def empty_g :=
  vec_grid₀.mk ⟨2, 2, dec_trivial, ⟨[D, D, D, D], rfl⟩⟩ ⟨0, 1⟩

def empty_aut : gol := mk_gol empty

def empty_aut_g : gol := mk_gol empty_g

def row := fgrid₀.mk 1 3 dec_trivial ⟨0, 0⟩ (λx y, A)

def row_gol : gol := mk_gol row

def col := vec_grid₀.mk ⟨3, 1, dec_trivial, ⟨[A, A, A], rfl⟩⟩ ⟨1, -1⟩

def col_gol : gol := mk_gol col

def box := fgrid₀.mk 2 2 dec_trivial ⟨0, 1⟩ (λx y, A)

def box_gol : gol := mk_gol box

def dies := vec_grid₀.mk ⟨3, 2, dec_trivial, ⟨[A, D, A, D, D, A], rfl⟩⟩ ⟨0, 1⟩

def dies_gol : gol := mk_gol dies

private lemma col_even {n} (h : n % 2 = 0) {a} {g}
  (h₂ : a = mk_gol g)
  (h₃ : a = col_gol) : step_n a n = a :=
begin
  unfold step_n,
  rw @periode_cycle _ _ _ _ 2,
    {rw [h, iterate_zero]},
    {rw h₂, subst h₃, rw ← h₂, refl}
end

lemma col_gol_even {n} (h : n % 2 = 0) : step_n col_gol n = col_gol :=
  col_even h rfl rfl

private lemma col_row {n} (h : n % 2 = 1) {a} {g}
  (h₂ : a = mk_gol g)
  (h₃ : a = col_gol) : step_n a n = row_gol :=
begin
  unfold step_n,
  rw @periode_cycle _ _ _ _ 2,
    {
      rw [
        h, iterate_one, iterate_zero, h₃
      ]; try { by simp [col_gol, row_gol, mk_gol] },
      refl
    },
    {rw h₃, refl}
end

lemma col_row_odd {n} (h : n % 2 = 1) : step_n col_gol n = row_gol :=
  col_row h rfl rfl

open list prod

def find_period (max : ℕ) (a : gol) : option ℕ :=
  let incr_iota := list.reverse $ list.iota max in
  prod.snd <$> list.find ((=tt) ∘ prod.fst) (
    list.zip (list.map ((=a.g) ∘ cautomaton.g ∘ (step_n a)) incr_iota) incr_iota
  )

meta def solve_periodic_gol_n (n : ℕ) : tactic unit :=
  do {
    `(periodic %%a) ← tactic.target,
    t ← tactic.infer_type a,
    aut ← tactic.eval_expr (cautomaton _) a,
    let val := find_period n aut in do
      v ← val,
      tactic.existsi `(v),
      tactic.split,
      tactic.exact_dec_trivial,
      tactic.reflexivity
  } <|> tactic.fail
        "Unable to discover periodicity. Try to increase the depth of search."

meta def periodic_aut : tactic unit := solve_periodic_gol_n 16

example : periodic col_gol := ⟨2, ⟨dec_trivial, rfl⟩⟩

example : periodic col_gol := by periodic_aut

end gol


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.finite_products_of_binary_products
! leanprover-community/mathlib commit ac3ae212f394f508df43e37aa093722fa9b65d31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.Products
import Mathlib.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathlib.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathlib.Logic.Equiv.Fin

/-!
# Constructing finite products from binary products and terminal.

If a category has binary products and a terminal object then it has finite products.
If a functor preserves binary products and the terminal object then it preserves finite products.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

universe v v' u u'

noncomputable section

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

namespace CategoryTheory

variable {J : Type v} [SmallCategory J]

variable {C : Type u} [Category.{v} C]

variable {D : Type u'} [Category.{v'} D]

/--
Given `n+1` objects of `C`, a fan for the last `n` with point `c₁.pt` and
a binary fan on `c₁.pt` and `f 0`, we can build a fan for all `n+1`.

In `extendFanIsLimit` we show that if the two given fans are limits, then this fan is also a
limit.
-/
@[simps!] -- Porting note: removed semi-reducible config
def extendFan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Fan fun i : Fin n => f i.succ)
    (c₂ : BinaryFan (f 0) c₁.pt) : Fan f :=
  Fan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.fst
      · intro i
        apply c₂.snd ≫ c₁.π.app ⟨i⟩)
#align category_theory.extend_fan CategoryTheory.extendFan

/-- Show that if the two given fans in `extendFan` are limits, then the constructed fan is also a
limit.
-/
def extendFanIsLimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Fan fun i : Fin n => f i.succ}
    {c₂ : BinaryFan (f 0) c₁.pt} (t₁ : IsLimit c₁) (t₂ : IsLimit c₂) : IsLimit (extendFan c₁ c₂)
    where
  lift s := by
    apply (BinaryFan.IsLimit.lift' t₂ (s.π.app ⟨0⟩) _).1
    apply t₁.lift ⟨_, Discrete.natTrans fun ⟨i⟩ => s.π.app ⟨i.succ⟩⟩
  fac := fun s ⟨j⟩ => by
    refine' Fin.inductionOn j ?_ ?_
    · apply (BinaryFan.IsLimit.lift' t₂ _ _).2.1
    · rintro i -
      dsimp only [extendFan_π_app]
      rw [Fin.cases_succ, ← assoc, (BinaryFan.IsLimit.lift' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply BinaryFan.IsLimit.hom_ext t₂
    · rw [(BinaryFan.IsLimit.lift' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(BinaryFan.IsLimit.lift' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      rw [assoc]
      dsimp only [Discrete.natTrans_app]
      rw [← w ⟨j.succ⟩]
      dsimp only [extendFan_π_app]
      rw [Fin.cases_succ]
#align category_theory.extend_fan_is_limit CategoryTheory.extendFanIsLimit

section

variable [HasBinaryProducts C] [HasTerminal C]

/-- If `C` has a terminal object and binary products, then it has a product for objects indexed by
`Fin n`.
This is a helper lemma for `hasFiniteProductsOfHasBinaryAndTerminal`, which is more general
than this.
-/
private theorem hasProduct_fin : ∀ (n : ℕ) (f : Fin n → C), HasProduct f
  | 0 => fun f => by
    letI : HasLimitsOfShape (Discrete (Fin 0)) C :=
      hasLimitsOfShape_of_equivalence (Discrete.equivalence.{0} finZeroEquiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := hasProduct_fin n
    apply HasLimit.mk ⟨_, extendFanIsLimit f (limit.isLimit _) (limit.isLimit _)⟩

/-- If `C` has a terminal object and binary products, then it has finite products. -/
theorem hasFiniteProducts_of_has_binary_and_terminal : HasFiniteProducts C := by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := hasProduct_fin n fun n => K.obj ⟨n⟩
  let that : (Discrete.functor fun n => K.obj ⟨n⟩) ≅ K := Discrete.natIso fun ⟨i⟩ => Iso.refl _
  apply @hasLimitOfIso  _ _ _ _ _ _ this that
#align category_theory.has_finite_products_of_has_binary_and_terminal CategoryTheory.hasFiniteProducts_of_has_binary_and_terminal

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesLimitsOfShape (Discrete WalkingPair) F]

variable [PreservesLimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteProducts.{v} C]

/-- If `F` preserves the terminal object and binary products, then it preserves products indexed by
`Fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndTerminal :
    ∀ (n : ℕ) (f : Fin n → C), PreservesLimit (Discrete.functor f) F
  | 0 => fun f => by
    letI : PreservesLimitsOfShape (Discrete (Fin 0)) F :=
      preservesLimitsOfShapeOfEquiv.{0, 0} (Discrete.equivalence finZeroEquiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preservesFinOfPreservesBinaryAndTerminal n
    intro f
    refine'
      preservesLimitOfPreservesLimitCone
        (extendFanIsLimit f (limit.isLimit _) (limit.isLimit _)) _
    apply (isLimitMapConeFanMkEquiv _ _ _).symm _
    let this :=
      extendFanIsLimit (fun i => F.obj (f i)) (isLimitOfHasProductOfPreservesLimit F _)
        (isLimitOfHasBinaryProductOfPreservesLimit F _ _)
    refine' IsLimit.ofIsoLimit this _
    apply Cones.ext _ _
    apply Iso.refl _
    rintro ⟨j⟩
    refine' Fin.inductionOn j ?_ ?_
    · apply (Category.id_comp _).symm
    · rintro i _
      dsimp [extendFan_π_app, Iso.refl_hom, Fan.mk_π]
      rw [Fin.cases_succ, Fin.cases_succ]
      change F.map _ ≫ _ = 𝟙 _ ≫ _
      simp only [id_comp, ← F.map_comp]
      rfl
#align category_theory.preserves_fin_of_preserves_binary_and_terminal CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓ -- Porting note: order of universes changed

/-- If `F` preserves the terminal object and binary products, then it preserves limits of shape
`Discrete (Fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndTerminal (n : ℕ) :
    PreservesLimitsOfShape (Discrete (Fin n)) F where
  preservesLimit {K} := by
    let that : (Discrete.functor fun n => K.obj ⟨n⟩) ≅ K := Discrete.natIso fun ⟨i⟩ => Iso.refl _
    haveI := preservesFinOfPreservesBinaryAndTerminal F n fun n => K.obj ⟨n⟩
    apply preservesLimitOfIsoDiagram F that
#align category_theory.preserves_shape_fin_of_preserves_binary_and_terminal CategoryTheory.preservesShapeFinOfPreservesBinaryAndTerminal

/-- If `F` preserves the terminal object and binary products then it preserves finite products. -/
def preservesFiniteProductsOfPreservesBinaryAndTerminal (J : Type) [Fintype J] :
    PreservesLimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preservesShapeFinOfPreservesBinaryAndTerminal F (Fintype.card J)
    apply preservesLimitsOfShapeOfEquiv.{0, 0} (Discrete.equivalence e).symm
#align category_theory.preserves_finite_products_of_preserves_binary_and_terminal CategoryTheory.preservesFiniteProductsOfPreservesBinaryAndTerminal

end Preserves

/-- Given `n+1` objects of `C`, a cofan for the last `n` with point `c₁.pt`
and a binary cofan on `c₁.X` and `f 0`, we can build a cofan for all `n+1`.

In `extendCofanIsColimit` we show that if the two given cofans are colimits,
then this cofan is also a colimit.
-/

@[simps!] -- Porting note: removed semireducible config
def extendCofan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Cofan fun i : Fin n => f i.succ)
    (c₂ : BinaryCofan (f 0) c₁.pt) : Cofan f :=
  Cofan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.inl
      · intro i
        apply c₁.ι.app ⟨i⟩ ≫ c₂.inr)
#align category_theory.extend_cofan CategoryTheory.extendCofan

/-- Show that if the two given cofans in `extendCofan` are colimits,
then the constructed cofan is also a colimit.
-/
def extendCofanIsColimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Cofan fun i : Fin n => f i.succ}
    {c₂ : BinaryCofan (f 0) c₁.pt} (t₁ : IsColimit c₁) (t₂ : IsColimit c₂) :
    IsColimit (extendCofan c₁ c₂) where
  desc s := by
    apply (BinaryCofan.IsColimit.desc' t₂ (s.ι.app ⟨0⟩) _).1
    apply t₁.desc ⟨_, Discrete.natTrans fun i => s.ι.app ⟨i.as.succ⟩⟩
  fac s := by
    rintro ⟨j⟩
    refine' Fin.inductionOn j ?_ ?_
    · apply (BinaryCofan.IsColimit.desc' t₂ _ _).2.1
    · rintro i -
      dsimp only [extendCofan_ι_app]
      rw [Fin.cases_succ, assoc, (BinaryCofan.IsColimit.desc' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply BinaryCofan.IsColimit.hom_ext t₂
    · rw [(BinaryCofan.IsColimit.desc' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(BinaryCofan.IsColimit.desc' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      dsimp only [Discrete.natTrans_app]
      rw [← w ⟨j.succ⟩]
      dsimp only [extendCofan_ι_app]
      rw [Fin.cases_succ, assoc]
#align category_theory.extend_cofan_is_colimit CategoryTheory.extendCofanIsColimit

section

variable [HasBinaryCoproducts C] [HasInitial C]

/--
If `C` has an initial object and binary coproducts, then it has a coproduct for objects indexed by
`Fin n`.
This is a helper lemma for `hasCofiniteProductsOfHasBinaryAndTerminal`, which is more general
than this.
-/
private theorem has_coproduct_fin : ∀ (n : ℕ) (f : Fin n → C), HasCoproduct f
  | 0 => fun f =>
    by
    letI : HasColimitsOfShape (Discrete (Fin 0)) C :=
      hasColimitsOfShape_of_equivalence (Discrete.equivalence.{0} finZeroEquiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := has_coproduct_fin n
    apply
      HasColimit.mk ⟨_, extendCofanIsColimit f (colimit.isColimit _) (colimit.isColimit _)⟩

/-- If `C` has an initial object and binary coproducts, then it has finite coproducts. -/
theorem hasFiniteCoproducts_of_has_binary_and_initial : HasFiniteCoproducts C := by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := has_coproduct_fin n fun n => K.obj ⟨n⟩
  let that : K ≅ Discrete.functor fun n => K.obj ⟨n⟩ := Discrete.natIso fun ⟨i⟩ => Iso.refl _
  apply @hasColimitOfIso _ _ _ _ _ _ this that
#align category_theory.has_finite_coproducts_of_has_binary_and_initial CategoryTheory.hasFiniteCoproducts_of_has_binary_and_initial

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesColimitsOfShape (Discrete WalkingPair) F]

variable [PreservesColimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteCoproducts.{v} C]

/-- If `F` preserves the initial object and binary coproducts, then it preserves products indexed by
`Fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndInitial :
    ∀ (n : ℕ) (f : Fin n → C), PreservesColimit (Discrete.functor f) F
  | 0 => fun f => by
    letI : PreservesColimitsOfShape (Discrete (Fin 0)) F :=
      preservesColimitsOfShapeOfEquiv.{0, 0} (Discrete.equivalence finZeroEquiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preservesFinOfPreservesBinaryAndInitial n
    intro f
    refine'
      preservesColimitOfPreservesColimitCocone
        (extendCofanIsColimit f (colimit.isColimit _) (colimit.isColimit _)) _
    apply (isColimitMapCoconeCofanMkEquiv _ _ _).symm _
    let this :=
      extendCofanIsColimit (fun i => F.obj (f i))
        (isColimitOfHasCoproductOfPreservesColimit F _)
        (isColimitOfHasBinaryCoproductOfPreservesColimit F _ _)
    refine' IsColimit.ofIsoColimit this _
    apply Cocones.ext _ _
    apply Iso.refl _
    rintro ⟨j⟩
    refine' Fin.inductionOn j ?_ ?_
    · apply Category.comp_id
    · rintro i _
      dsimp [extendCofan_ι_app, Iso.refl_hom, Cofan.mk_ι]
      rw [Fin.cases_succ, Fin.cases_succ, comp_id, ← F.map_comp]
#align category_theory.preserves_fin_of_preserves_binary_and_initial CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓ  -- Porting note: order of universes changed

/-- If `F` preserves the initial object and binary coproducts, then it preserves colimits of shape
`Discrete (Fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndInitial (n : ℕ) :
    PreservesColimitsOfShape (Discrete (Fin n)) F where
  preservesColimit {K} := by
    let that : (Discrete.functor fun n => K.obj ⟨n⟩) ≅ K := Discrete.natIso fun ⟨i⟩ => Iso.refl _
    haveI := preservesFinOfPreservesBinaryAndInitial F n fun n => K.obj ⟨n⟩
    apply preservesColimitOfIsoDiagram F that
#align category_theory.preserves_shape_fin_of_preserves_binary_and_initial CategoryTheory.preservesShapeFinOfPreservesBinaryAndInitial

/-- If `F` preserves the initial object and binary coproducts then it preserves finite products. -/
def preservesFiniteCoproductsOfPreservesBinaryAndInitial (J : Type) [Fintype J] :
    PreservesColimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preservesShapeFinOfPreservesBinaryAndInitial F (Fintype.card J)
    apply preservesColimitsOfShapeOfEquiv.{0, 0} (Discrete.equivalence e).symm
#align category_theory.preserves_finite_coproducts_of_preserves_binary_and_initial CategoryTheory.preservesFiniteCoproductsOfPreservesBinaryAndInitial

end Preserves

end CategoryTheory


import algebra.invertible
import tactic.linarith
import order.filter.at_top_bot
import algebra.cubic_solution

section field
variables {F : Type*}

def quartic_expression [field F] (x a b c d e : F) : F :=
  ((x * x * x * x * a) + (x * x * x * b) + (x * x * c) + (x * d) + e)

def depressed_quartic_squ_coefficient [field F] (b c : F) : F :=
  (c - (3 * b * b)/8)

def depressed_quartic_linear_coefficient [field F] (b c d : F) : F :=
  (b * b * b) / 8 - (b * c) / 2 + d

def depressed_quartic_constant [field F] (b c d e : F) : F :=
  -(3 * b * b * b * b) / 256 + (c * b * b) / 16 - (b * d) / 4 + e

lemma convert_quartic_to_depressed [field F] (b c d e x : F) (two_ne_zero : (2 : F) ≠ 0) :
  (quartic_expression x 1 b c d e) =
  (quartic_expression (x + (b / 4)) 1 0
                      (depressed_quartic_squ_coefficient b c)
                      (depressed_quartic_linear_coefficient b c d)
                      (depressed_quartic_constant b c d e)) :=
begin
  unfold quartic_expression, unfold depressed_quartic_squ_coefficient,
  unfold depressed_quartic_linear_coefficient, unfold depressed_quartic_constant,
  have h256 : (256 : F) = (16 : F) * (16 : F), ring, rw h256, clear h256,
  have h16 : (16 : F) = (4 : F) * (4 : F), ring, rw h16, clear h16,
  have h8 : (8 : F) = (4 : F) * (2 : F), ring, rw h8, clear h8,
  have h4 : (4 : F) = (2 : F) * (2 : F), ring, rw h4, clear h4,
  field_simp, ring,
end

lemma factorise_depressed_quartic_simultaneous [field F] (c d e x p q s : F)
  (two_ne_zero : (2 : F) ≠ 0) (p_ne_zero : p ≠ 0) :
  (c + p * p = s + q) ->
  (d / p = s - q) ->
  (e = s * q) ->
  (quartic_expression x 1 0 c d e) = (x * x + p * x + q) * (x * x - p * x + s) :=
begin
  intros h1 h2 h3, unfold quartic_expression,
  have mul_quad : (x * x + p * x + q) * (x * x - p * x + s) =
                  (x * x * x * x) + (s + q - p * p) * x * x + (p * s - p * q) * x + s * q,
    ring,
  rw mul_quad, clear mul_quad,
  rw <- h1, rw <- h3, rw sub_eq_add_neg (p * s) (p * q),
  rw neg_mul_eq_mul_neg, rw <- left_distrib, rw <- sub_eq_add_neg,
  rw <- h2,
  field_simp, ring,
end

lemma depressed_quartic_simultaneous_solution [field F] (c d e p q s cubrt sqrt : F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (p_ne_zero : p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * c) (c * c - 4 * e) ≠ 0) :
    (sqrt * sqrt = (cubic_formula_sqrt 1 (2 * c) (c * c - 4 * e) (- d * d))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * c) (c * c - 4 * e) (- d * d)) sqrt) ->
    (p * p) = (cubic_formula 1 (2 * c) (c * c - 4 * e) cubrt) ->
    (s = (c + (p * p) + (d / p)) / 2) ->
    (q = (c + (p * p) - (d / p)) / 2) ->
    ((c + p * p = s + q) /\ (d / p = s - q) /\ (e = s * q)) :=
begin
  intros h_sqrt h_cubrt h_p h_s h_q, split,
  rw h_s, rw h_q, field_simp, ring, split,
  rw h_s, rw h_q, field_simp, ring,

  rw h_s, rw h_q, field_simp,
  have h_cubic : 1 * (p * p) * (p * p) * (p * p) + ((2 * c) * (p * p) * (p * p)) + (c * c - 4 * e) * (p * p) + (-d * d) = 0,
    apply cubic_solution, repeat {assumption},
  rw <- neg_inj, rw <- add_eq_zero_iff_neg_eq,
  simp only [sub_eq_add_neg, left_distrib, right_distrib,
                <- neg_mul_eq_mul_neg, <- neg_mul_eq_neg_mul],
  simp only [sub_eq_add_neg, left_distrib, right_distrib,
                <- neg_mul_eq_mul_neg, <- neg_mul_eq_neg_mul] at h_cubic,
  ring_nf, ring_nf at h_cubic, rw <- neg_inj, rw neg_zero, rw <- h_cubic, ring,
end

lemma depressed_quartic_to_quadratic_product [field F] (x c d e sqrt_p sqrt_cubic cubrt: F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (sqrt_p_ne_zero : sqrt_p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * c) (c * c - 4 * e) ≠ 0)
    :
    (sqrt_cubic * sqrt_cubic = (cubic_formula_sqrt 1 (2 * c) (c * c - 4 * e) (- d * d))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * c) (c * c - 4 * e) (- d * d)) sqrt_cubic) ->
    (sqrt_p * sqrt_p = (cubic_formula 1 (2 * c) (c * c - 4 * e) cubrt)) ->
  (quartic_expression x 1 0 c d e) =
        (x * x + sqrt_p * x + ((c + (sqrt_p * sqrt_p) - (d / sqrt_p)) / 2)) *
        (x * x - sqrt_p * x + ((c + (sqrt_p * sqrt_p) + (d / sqrt_p)) / 2)) :=
begin
  intros h_sqrt_cubic, intros h_cubrt, intros h_sqrt_p,
  apply factorise_depressed_quartic_simultaneous, repeat {assumption},
  field_simp, ring,
  field_simp, ring,
  rw <- neg_inj, rw <- add_eq_zero_iff_neg_eq, field_simp,
  rw [mul_comm sqrt_p 2] {occs := occurrences.pos [1]}, rw mul_assoc 2 sqrt_p _,
  rw <- mul_assoc sqrt_p sqrt_p _,
  simp only [left_distrib, right_distrib, <- neg_mul_eq_mul_neg, <- neg_mul_eq_neg_mul, sub_eq_add_neg],
  repeat {rw mul_assoc}, rw mul_comm c sqrt_p,
  repeat {rw <- mul_assoc sqrt_p sqrt_p _, rw h_sqrt_p},
  set p := cubic_formula 1 (2 * c) (c * c - 4 * e) cubrt with hp,
  rw add_comm _ (d * (sqrt_p * p)),
  have swap : ∀ (x1 x2 x3 : F), x1 * (x2 * x3) = x3 * (x2 * x1), intros, ring,
  rw swap d sqrt_p p, rw swap d sqrt_p c, clear swap, repeat {rw add_assoc},
  rw <- add_assoc (-(p * (sqrt_p * d))) (p * (sqrt_p * d)),
  have tmp : -(p * (sqrt_p * d)) + p * (sqrt_p * d) = 0, ring, rw tmp, clear tmp,
  rw zero_add,
  rw add_comm (c * (sqrt_p * d)) _, repeat {rw add_assoc}, rw add_comm (-(c * (sqrt_p * d))) _,
  repeat {rw add_assoc},
  have tmp : (c * (sqrt_p * d)) + -(c * (sqrt_p * d)) = 0, ring, rw tmp, clear tmp,
  rw add_zero,
  rw <- neg_inj, rw neg_zero,
  have finale : -(e * (2 * (p * 2)) + -(c * (p * c) + (c * (p * p) + (p * (p * c) + (p * (p * p) + -(d * d))))))
                = (1 * p * p * p) + (2 * c * p * p) + ((c * c - 4 * e) * p) + (-d * d),
    ring,
  rw finale, apply cubic_solution, repeat {assumption},
end

/- In a submission to the standard library, I'd use the work in the existing
    quadratic_discriminant.lean.  However, I need some things that aren't
    already in there, and I don't want to mix my work with the existing
    work in the same file, as that would leave it ambiguous what I'd done
    when it comes to mark the project.  Hence, I move all the work that
    I need out to here.-/
def quadratic_formula [field F] (b sqrt : F) : F := (sqrt - b) / 2
def quadratic_discriminant [field F] (b c : F) : F := (b * b) - (4 * c)

lemma quadratic_formula_correct [field F] (b c sqrt x : F) (two_ne_zero : (2 : F) ≠ 0)
              (h_sqrt : sqrt * sqrt = quadratic_discriminant b c) :
              (x = quadratic_formula b sqrt) -> ((x * x) + (b * x) + c = 0) :=
begin
  have tmp : sqrt * sqrt = sqrt ^ 2, ring, rw tmp at h_sqrt, clear tmp,
  unfold quadratic_formula, intros hx, rw hx, field_simp, ring_nf,
  rw h_sqrt, unfold quadratic_discriminant, ring,
end

lemma quadratic_formula_factorise [field F] (b c sqrt x : F) (two_ne_zero : (2 : F) ≠ 0)
              (h_sqrt : sqrt * sqrt = quadratic_discriminant b c) :
              ((x * x) + (b * x) + c) =
              (x - (quadratic_formula b sqrt)) * (x - (quadratic_formula b (- sqrt))) :=
begin
  have tmp : sqrt * sqrt = sqrt ^ 2, ring, rw tmp at h_sqrt, clear tmp,
  unfold quadratic_formula, field_simp, ring_nf, rw h_sqrt, unfold quadratic_discriminant,
  ring,
end

lemma depressed_quartic_solution [field F] (x c d e sqrt_p sqrt_cubic sqrt_quadratic cubrt: F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (sqrt_p_ne_zero : sqrt_p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * c) (c * c - 4 * e) ≠ 0) :
    (sqrt_cubic * sqrt_cubic = (cubic_formula_sqrt 1 (2 * c) (c * c - 4 * e) (- d * d))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * c) (c * c - 4 * e) (- d * d)) sqrt_cubic) ->
    (sqrt_p * sqrt_p = (cubic_formula 1 (2 * c) (c * c - 4 * e) cubrt)) ->
    (sqrt_quadratic * sqrt_quadratic = (quadratic_discriminant sqrt_p ((c + (sqrt_p * sqrt_p) - (d / sqrt_p)) / 2))) ->
    (x = quadratic_formula sqrt_p sqrt_quadratic) -> (quartic_expression x 1 0 c d e = 0) :=
begin
  intros h_sqrt_cubic h_cubrt_cubic h_sqrt_p h_sqrt_quadratic h_x,
  rw depressed_quartic_to_quadratic_product x c d e sqrt_p sqrt_cubic cubrt
            one_ne_zero two_ne_zero three_ne_zero sqrt_p_ne_zero int_quantity_ne_zero
            h_sqrt_cubic h_cubrt_cubic h_sqrt_p,
  rw quadratic_formula_correct sqrt_p ((c + (sqrt_p * sqrt_p) - (d / sqrt_p)) / 2) sqrt_quadratic x two_ne_zero h_sqrt_quadratic h_x,
  rw zero_mul,
end

lemma quartic_solution [field F] (x b c d e sqrt_p sqrt_cubic sqrt_quadratic cubrt: F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (sqrt_p_ne_zero : sqrt_p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) ≠ 0) :
    (sqrt_cubic * sqrt_cubic = (cubic_formula_sqrt 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) (- (depressed_quartic_linear_coefficient b c d) * (depressed_quartic_linear_coefficient b c d)))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) (- (depressed_quartic_linear_coefficient b c d) * (depressed_quartic_linear_coefficient b c d))) sqrt_cubic) ->
    (sqrt_p * sqrt_p = (cubic_formula 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) cubrt)) ->
    (sqrt_quadratic * sqrt_quadratic = (quadratic_discriminant sqrt_p (((depressed_quartic_squ_coefficient b c) + (sqrt_p * sqrt_p) - ((depressed_quartic_linear_coefficient b c d) / sqrt_p)) / 2))) ->
    (x = (quadratic_formula sqrt_p sqrt_quadratic) - (b / 4)) -> (quartic_expression x 1 b c d e = 0) :=
begin
  intros h_sqrt_cubic h_cubrt_cubic h_sqrt_p h_sqrt_quadratic h_x,
  rw convert_quartic_to_depressed,
  apply depressed_quartic_solution (x + b / 4) (depressed_quartic_squ_coefficient b c) (depressed_quartic_linear_coefficient b c d) (depressed_quartic_constant b c d e)
                                    sqrt_p sqrt_cubic sqrt_quadratic cubrt,
  any_goals {assumption},
    rw h_x, simp,
end

lemma depressed_quartic_to_linear_product [field F] (x c d e sqrt_p sqrt_cubic sqrt_discrim_a sqrt_discrim_b cubrt: F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (sqrt_p_ne_zero : sqrt_p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * c) (c * c - 4 * e) ≠ 0)
    :
    (sqrt_cubic * sqrt_cubic = (cubic_formula_sqrt 1 (2 * c) (c * c - 4 * e) (- d * d))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * c) (c * c - 4 * e) (- d * d)) sqrt_cubic) ->
    (sqrt_p * sqrt_p = (cubic_formula 1 (2 * c) (c * c - 4 * e) cubrt)) ->
    (sqrt_discrim_a * sqrt_discrim_a = (quadratic_discriminant sqrt_p ((c + (sqrt_p * sqrt_p) - (d / sqrt_p)) / 2))) ->
    (sqrt_discrim_b * sqrt_discrim_b = (quadratic_discriminant (- sqrt_p) ((c + (sqrt_p * sqrt_p) + (d / sqrt_p)) / 2))) ->
  (quartic_expression x 1 0 c d e) =
        (x - (quadratic_formula sqrt_p sqrt_discrim_a)) *
        (x - (quadratic_formula sqrt_p (- sqrt_discrim_a))) *
        (x - (quadratic_formula (- sqrt_p) sqrt_discrim_b)) *
        (x - (quadratic_formula (- sqrt_p) (- sqrt_discrim_b))) :=
begin
  intros h_sqrt_cubic h_cubrt h_sqrt_p h_discrim_a h_discrim_b,
  rw depressed_quartic_to_quadratic_product x c d e sqrt_p sqrt_cubic cubrt
                one_ne_zero two_ne_zero three_ne_zero sqrt_p_ne_zero int_quantity_ne_zero
                h_sqrt_cubic h_cubrt h_sqrt_p,
  rw quadratic_formula_factorise
        sqrt_p ((c + sqrt_p * sqrt_p - d / sqrt_p) / 2) sqrt_discrim_a x,
  have tmp : (x * x - sqrt_p * x) = (x * x + (- sqrt_p) * x), ring, rw tmp, clear tmp,
  rw quadratic_formula_factorise
        (- sqrt_p) ((c + sqrt_p * sqrt_p + d / sqrt_p) / 2) sqrt_discrim_b x,
  ring, repeat {assumption},
end

lemma quartic_to_linear_product [field F] (x b c d e sqrt_p sqrt_cubic sqrt_discrim_a sqrt_discrim_b cubrt: F)
    (one_ne_zero : (1 : F) ≠ 0) (two_ne_zero : (2 : F) ≠ 0) (three_ne_zero : (3 : F) ≠ 0)
    (sqrt_p_ne_zero : sqrt_p ≠ 0) (int_quantity_ne_zero : depressed_cubic_x_term 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) ≠ 0)
    :
    (sqrt_cubic * sqrt_cubic = (cubic_formula_sqrt 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) (- (depressed_quartic_linear_coefficient b c d) * (depressed_quartic_linear_coefficient b c d)))) ->
    (cubrt * cubrt * cubrt = (cubic_formula_cubrt 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) (- (depressed_quartic_linear_coefficient b c d) * (depressed_quartic_linear_coefficient b c d))) sqrt_cubic) ->
    (sqrt_p * sqrt_p = (cubic_formula 1 (2 * (depressed_quartic_squ_coefficient b c)) ((depressed_quartic_squ_coefficient b c) * (depressed_quartic_squ_coefficient b c) - 4 * (depressed_quartic_constant b c d e)) cubrt)) ->
    (sqrt_discrim_a * sqrt_discrim_a = (quadratic_discriminant sqrt_p (((depressed_quartic_squ_coefficient b c) + (sqrt_p * sqrt_p) - ((depressed_quartic_linear_coefficient b c d) / sqrt_p)) / 2))) ->
    (sqrt_discrim_b * sqrt_discrim_b = (quadratic_discriminant (- sqrt_p) (((depressed_quartic_squ_coefficient b c) + (sqrt_p * sqrt_p) + ((depressed_quartic_linear_coefficient b c d) / sqrt_p)) / 2))) ->
  (quartic_expression x 1 b c d e) =
        ((x + b/4) - (quadratic_formula sqrt_p sqrt_discrim_a)) *
        ((x + b/4) - (quadratic_formula sqrt_p (- sqrt_discrim_a))) *
        ((x + b/4) - (quadratic_formula (- sqrt_p) sqrt_discrim_b)) *
        ((x + b/4) - (quadratic_formula (- sqrt_p) (- sqrt_discrim_b))) :=
begin
  intros h_sqrt_cubic h_cubrt h_sqrt_p h_discrim_a h_discrim_b,
  rw convert_quartic_to_depressed, apply depressed_quartic_to_linear_product,
  repeat {assumption},
end

end field


import .love08_operational_semantics_demo

/-! # LoVe Demo 10: Denotational Semantics

We review a third way to specify the semantics of a programming language:
denotational semantics. Denotational semantics attempt to directly specify the
meaning of programs.

If operational semantics is an idealized interpreter and Hoare logic is an
idealized verifier, then denotational semantics is an idealized compiler. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Compositionality

A __denotational semantics__ defines the meaning of each program as a
mathematical object:

    `⟦ ⟧ : syntax → semantics`

A key property of denotational semantics is __compositionality__: The meaning of
a compound statement should be defined in terms of the meaning of its
components. This disqualifies

    `⟦S⟧ = {st | (S, prod.fst st) ⟹ prod.snd st}`

i.e.

    `⟦S⟧ = {(s, t) | (S, s) ⟹ t}`

because operational semantics are not compositional.

In short, we want

    `⟦S ; T⟧              = … ⟦S⟧ … ⟦T⟧ …`
    `⟦if b then S else T⟧ = … ⟦S⟧ … ⟦T⟧ …`
    `⟦while b do S⟧       = … ⟦S⟧ …`

An evaluation function on arithmetic expressions

    `eval : aexp → ((string → ℤ) → ℤ)`

is a denotational semantics. We want the same for imperative programs.

## A Relational Denotational Semantics

We can represent the semantics of an imperative program as a function from
initial state to final state or more generally as a relation between initial
state and final state: `set (state × state)`.

For `skip`, `:=`, `;`, and `if then else`, the denotational semantics is
easy: -/

namespace sorry_defs

def denote : stmt → set (state × state)
| stmt.skip         := Id
| (stmt.assign n a) :=
  {st | prod.snd st = (prod.fst st){n ↦ a (prod.fst st)}}
| (stmt.seq S T)    := denote S ◯ denote T
| (stmt.ite b S T)  :=
  (denote S ⇃ b) ∪ (denote T ⇃ (λs, ¬ b s))
| (stmt.while b S)  := sorry

end sorry_defs

/-! We write `⟦S⟧` for `denote S`. For `while`, we would like to write

    `((denote S ◯ denote (stmt.while b S)) ⇃ b) ∪ (Id ⇃ (λs, ¬ b s))`

but this is ill-founded due to the recursive call on `stmt.while b S`.

What we are looking for is an `X` such that

    `X = ((denote S ◯ X) ⇃ b) ∪ (Id ⇃ (λs, ¬ b s))`

In other words, we are looking for a fixpoint.

Most of this lecture is concerned with building a least fixpoint operator
`lfp` that will allow us to define the `while` case as well:

    `lfp (λX, ((denote S ◯ X) ⇃ b) ∪ (Id ⇃ (λs, ¬ b s)))`

## Fixpoints

A __fixpoint__ (or fixed point) of `f` is a solution for `X` in the equation

    `X = f X`

In general, fixpoints may not exist at all (e.g., `f := nat.succ`), or there may
be several fixpoints (e.g., `f := id`). But under some conditions on `f`, a
unique __least fixpoint__ and a unique __greatest fixpoint__ are guaranteed to
exist.

Consider this __fixpoint equation__:

    `X = (λ(p : ℕ → Prop) (n : ℕ), n = 0 ∨ ∃m : ℕ, n = m + 2 ∧ p m) X`
      `= (λn : ℕ, n = 0 ∨ ∃m : ℕ, n = m + 2 ∧ X m)`

where `X : ℕ → Prop` and
`f := (λ(p : ℕ → Prop) (n : ℕ), n = 0 ∨ ∃m : ℕ, n = m + 2 ∧ p m)`.

The above example admits only one fixpoint. The fixpoint equation uniquely
specifies `X` as the set of even numbers.

In general, the least and greatest fixpoint may be different:

    `X = X`

Here, the least fixpoint is `(λ_, False)` and the greatest fixpoint is
`(λ_, True)`. Conventionally, `False < True`, and thus
`(λ_, False) < (λ_, True)`. Similarly, `∅ < @set.univ α` (assuming `α` is
inhabited).

For the semantics of programming languages:

* `X` will have type `set (state × state)` (which is isomorphic to
  `state → state → Prop`), representing relations between states;

* `f` will correspond to either taking one extra iteration of the loop (if the
  condition `b` is true) or the identity (if `b` is false).

Kleene's fixpoint theorem:

    `f^0(∅) ∪ f^1(∅) ∪ f^2(∅) ∪ ⋯ = lfp f`

The least fixpoint corresponds to finite executions of a program, which is all
we care about.

**Key observation**:

    Inductive predicates correspond to least fixpoints, but they are built into
    Lean's logic (the calculus of inductive constructions).

## Monotone Functions

Let `α` and `β` be types with partial order `≤`. A function `f : α → β` is
__monotone__ if

    `a ≤ b → f a ≤ f b`   for all `a`, `b`

Many operations on sets (e.g., `∪`), relations (e.g., `◯`), and functions
(e.g., `λx, x`, `λ_, k`, `∘`) are monotone or preserve monotonicity.

All monotone functions `f : set α → set α` admit least and greatest fixpoints.

**Example of a nonmonotone function**:

    `f A = (if A = ∅ then set.univ else ∅)`

Assuming `α` is inhabited, we have `∅ ⊆ set.univ`, but
`f ∅ = set.univ ⊈ ∅ = f set.univ`. -/

def monotone {α β : Type} [partial_order α] [partial_order β]
  (f : α → β) : Prop :=
∀a₁ a₂, a₁ ≤ a₂ → f a₁ ≤ f a₂

lemma monotone_id {α : Type} [partial_order α] :
  monotone (λa : α, a) :=
begin
  intros a₁ a₂ ha,
  exact ha
end

lemma monotone_const {α β : Type} [partial_order α]
    [partial_order β] (b : β) :
  monotone (λ_ : α, b) :=
begin
  intros a₁ a₂ ha,
  exact le_refl b
end

lemma monotone_union {α β : Type} [partial_order α]
    (f g : α → set β) (hf : monotone f) (hg : monotone g) :
  monotone (λa, f a ∪ g a) :=
begin
  intros a₁ a₂ ha b hb,
  cases' hb,
  { exact or.intro_left _ (hf a₁ a₂ ha h) },
  { exact or.intro_right _ (hg a₁ a₂ ha h) }
end

/-! We will prove the following two lemmas in the exercise. -/

namespace sorry_lemmas

lemma monotone_comp {α β : Type} [partial_order α]
    (f g : α → set (β × β)) (hf : monotone f)
    (hg : monotone g) :
  monotone (λa, f a ◯ g a) :=
sorry

lemma monotone_restrict {α β : Type} [partial_order α]
    (f : α → set (β × β)) (p : β → Prop) (hf : monotone f) :
  monotone (λa, f a ⇃ p) :=
sorry

end sorry_lemmas

/-! ## Complete Lattices

To define the least fixpoint on sets, we need `⊆` and `⋂`. Complete lattices
capture this concept abstractly. A __complete lattice__ is an ordered type `α`
for which each set of type `set α` has an infimum.

More precisely, A complete lattice consists of

* a partial order `≤ : α → α → Prop` (i.e., a reflexive, transitive, and
  antisymmetric binary predicate);

* an operator `Inf : set α → α`, called __infimum__.

Moreover, `Inf A` must satisfy these two properties:

* `Inf A` is a lower bound of `A`: `Inf A ≤ b` for all `b ∈ A`;

* `Inf A` is a greatest lower bound: `b ≤ Inf A` for all `b` such that
  `∀a, a ∈ A → b ≤ a`.

**Warning:** `Inf A` is not necessarily an element of `A`.

Examples:

* `set α` is an instance w.r.t. `⊆` and `⋂` for all `α`;
* `Prop` is an instance w.r.t. `→` and `∀` (`Inf A := ∀a ∈ A, a`);
* `enat := ℕ ∪ {∞}`;
* `ereal := ℝ ∪ {- ∞, ∞}`;
* `β → α` if `α` is a complete lattice;
* `α × β` if `α`, `β` are complete lattices.

Finite example (with apologies for the ASCII art):

                Z            Inf {}           = ?
              /   \          Inf {Z}          = ?
             A     B         Inf {A, B}       = ?
              \   /          Inf {Z, A}       = ?
                Y            Inf {Z, A, B, Y} = ?

Nonexamples:

* `ℕ`, `ℤ`, `ℚ`, `ℝ`: no infimum for `∅`, `Inf ℕ`, etc.
* `erat := ℚ ∪ {- ∞, ∞}`: `Inf {q | 2 < q * q} = sqrt 2` is not in `erat`. -/

@[class] structure complete_lattice (α : Type)
  extends partial_order α : Type :=
(Inf    : set α → α)
(Inf_le : ∀A b, b ∈ A → Inf A ≤ b)
(le_Inf : ∀A b, (∀a, a ∈ A → b ≤ a) → b ≤ Inf A)

/-! For sets: -/

@[instance] def set.complete_lattice {α : Type} :
  complete_lattice (set α) :=
{ le          := (⊆),
  le_refl     := by tautology,
  le_trans    := by tautology,
  le_antisymm :=
    begin
      intros A B hAB hBA,
      apply set.ext,
      tautology
    end,
  Inf         := λX, {a | ∀A, A ∈ X → a ∈ A},
  Inf_le      := by tautology,
  le_Inf      := by tautology }

/-! ## Least Fixpoint -/

def lfp {α : Type} [complete_lattice α] (f : α → α) : α :=
complete_lattice.Inf ({a | f a ≤ a})

lemma lfp_le {α : Type} [complete_lattice α] (f : α → α)
    (a : α) (h : f a ≤ a) :
  lfp f ≤ a :=
complete_lattice.Inf_le _ _ h

lemma le_lfp {α : Type} [complete_lattice α] (f : α → α)
    (a : α) (h : ∀a', f a' ≤ a' → a ≤ a') :
  a ≤ lfp f :=
complete_lattice.le_Inf _ _ h

/-! **Knaster-Tarski theorem:** For any monotone function `f`:

* `lfp f` is a fixpoint: `lfp f = f (lfp f)` (lemma `lfp_eq`);
* `lfp f` is smaller than any other fixpoint: `X = f X → lfp f ≤ X`. -/

lemma lfp_eq {α : Type} [complete_lattice α] (f : α → α)
    (hf : monotone f) :
  lfp f = f (lfp f) :=
begin
  have h : f (lfp f) ≤ lfp f :=
    begin
      apply le_lfp,
      intros a' ha',
      apply @le_trans _ _ _ (f a'),
      { apply hf,
        apply lfp_le,
        assumption },
      { assumption }
    end,
  apply le_antisymm,
  { apply lfp_le,
    apply hf,
    assumption },
  { assumption }
end

/-! ## A Relational Denotational Semantics, Continued -/

def denote : stmt → set (state × state)
| stmt.skip         := Id
| (stmt.assign x a) :=
  {st | prod.snd st = (prod.fst st){x ↦ a (prod.fst st)}}
| (stmt.seq S T)    := denote S ◯ denote T
| (stmt.ite b S T)  :=
  (denote S ⇃ b) ∪ (denote T ⇃ (λs, ¬ b s))
| (stmt.while b S)  :=
  lfp (λX, ((denote S ◯ X) ⇃ b) ∪ (Id ⇃ (λs, ¬ b s)))

notation `⟦` S `⟧`:= denote S

/-! ## Application to Program Equivalence

Based on the denotational semantics, we introduce the notion of program
equivalence: `S₁ ~ S₂`. (Compare with exercise 8.) -/

def denote_equiv (S₁ S₂ : stmt) : Prop :=
⟦S₁⟧ = ⟦S₂⟧

infix ` ~ ` := denote_equiv

/-! It is obvious from the definition that `~` is an equivalence relation.

Program equivalence can be used to replace subprograms by other subprograms with
the same semantics. This is achieved by the following congruence rules: -/

lemma denote_equiv.seq_congr {S₁ S₂ T₁ T₂ : stmt}
    (hS : S₁ ~ S₂) (hT : T₁ ~ T₂) :
  S₁ ;; T₁ ~ S₂ ;; T₂ :=
by simp [denote_equiv, denote, *] at *

lemma denote_equiv.ite_congr {b} {S₁ S₂ T₁ T₂ : stmt}
    (hS : S₁ ~ S₂) (hT : T₁ ~ T₂) :
  stmt.ite b S₁ T₁ ~ stmt.ite b S₂ T₂ :=
by simp [denote_equiv, denote, *] at *

lemma denote_equiv.while_congr {b} {S₁ S₂ : stmt}
    (hS : S₁ ~ S₂) :
  stmt.while b S₁ ~ stmt.while b S₂ :=
by simp [denote_equiv, denote, *] at *

/-! Compare the simplicity of these proofs with the corresponding proofs for a
big-step semantics (exercise 8).

Let us prove some program equivalences. -/

lemma denote_equiv.skip_assign_id {x} :
  stmt.assign x (λs, s x) ~ stmt.skip :=
by simp [denote_equiv, denote, Id]

lemma denote_equiv.seq_skip_left {S : stmt} :
  stmt.skip ;; S ~ S :=
by simp [denote_equiv, denote, Id, comp]

lemma denote_equiv.seq_skip_right {S : stmt} :
  S ;; stmt.skip ~ S :=
by simp [denote_equiv, denote, Id, comp]

lemma denote_equiv.ite_seq_while {b} {S : stmt} :
  stmt.ite b (S ;; stmt.while b S) stmt.skip ~ stmt.while b S :=
begin
  simp [denote_equiv, denote],
  apply eq.symm,
  apply lfp_eq,
  apply monotone_union,
  { apply sorry_lemmas.monotone_restrict,
    apply sorry_lemmas.monotone_comp,
    { exact monotone_const _ },
    { exact monotone_id } },
  { apply sorry_lemmas.monotone_restrict,
    exact monotone_const _ }
end

/-! ## Equivalence of the Denotational and the Big-Step Semantics
## (**optional**) -/

lemma denote_of_big_step (S : stmt) (s t : state) (h : (S, s) ⟹ t) :
  (s, t) ∈ ⟦S⟧ :=
begin
  induction' h; try { solve1 { simp [denote, *] } },
  case seq {
    apply exists.intro t,
    exact and.intro ih_h ih_h_1 },
  case while_true {
    rw eq.symm denote_equiv.ite_seq_while,
    simp [denote, *],
    apply exists.intro t,
    apply and.intro; assumption },
  case while_false {
    rw eq.symm denote_equiv.ite_seq_while,
    simp [denote, *] }
end

lemma big_step_of_denote :
  ∀(S : stmt) (s t : state), (s, t) ∈ ⟦S⟧ → (S, s) ⟹ t
| stmt.skip         s t := by simp [denote]
| (stmt.assign n a) s t := by simp [denote]
| (stmt.seq S T)    s t :=
  begin
    intro h,
    cases' h with u hu,
    exact big_step.seq
      (big_step_of_denote S _ _ (and.elim_left hu))
      (big_step_of_denote T _ _ (and.elim_right hu))
  end
| (stmt.ite b S T)  s t :=
  begin
    intro h,
    cases' h,
    case inl {
      cases' h,
      apply big_step.ite_true right,
      exact big_step_of_denote _ _ _ left },
    case inr {
      cases' h,
      apply big_step.ite_false right,
      exact big_step_of_denote _ _ _ left }
  end
| (stmt.while b S)  s t :=
  begin
    have hw : ⟦stmt.while b S⟧
        ≤ {st | (stmt.while b S, prod.fst st) ⟹ prod.snd st} :=
      begin
        apply lfp_le _ _ _,
        intros x hx,
        cases' x with s' t',
        simp at hx,
        cases' hx,
        case inl {
          cases' h with hst hs,
          cases' hst with u hu,
          apply big_step.while_true hs,
          { exact big_step_of_denote S _ _ (and.elim_left hu) },
          { exact and.elim_right hu } },
        case inr {
          cases' h,
          cases' left,
          apply big_step.while_false right }
      end,
    apply hw
  end

lemma denote_iff_big_step (S : stmt) (s t : state) :
  (s, t) ∈ ⟦S⟧ ↔ (S, s) ⟹ t :=
iff.intro (big_step_of_denote S s t) (denote_of_big_step S s t)

/-! ## A Simpler Approach Based on an Inductive Predicate (**optional**) -/

inductive awhile (b : state → Prop)
    (r : set (state × state)) :
  state → state → Prop
| true {s t u} (hcond : b s) (hbody : (s, t) ∈ r)
    (hrest : awhile t u) :
  awhile s u
| false {s} (hcond : ¬ b s) :
  awhile s s

def denote_ind : stmt → set (state × state)
| stmt.skip         := Id
| (stmt.assign x a) :=
  {st | prod.snd st = (prod.fst st){x ↦ a (prod.fst st)}}
| (stmt.seq S T)    := denote_ind S ◯ denote_ind T
| (stmt.ite b S T)  :=
  (denote_ind S ⇃ b) ∪ (denote_ind T ⇃ (λs, ¬ b s))
| (stmt.while b S)  :=
  {st | awhile b (denote_ind S) (prod.fst st) (prod.snd st)}

end LoVe