/-
Copyright (c) 2021 Aaron Anderson, Jesse Michael Han, Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Jesse Michael Han, Floris van Doorn
-/
import data.list.prod_sigma
import data.set.prod
import logic.equiv.fin
import model_theory.language_map

/-!
# Basics on First-Order Syntax
This file defines first-order terms, formulas, sentences, and theories in a style inspired by the
[Flypitch project](https://flypitch.github.io/).

## Main Definitions
* A `first_order.language.term` is defined so that `L.term α` is the type of `L`-terms with free
  variables indexed by `α`.
* A `first_order.language.formula` is defined so that `L.formula α` is the type of `L`-formulas with
  free variables indexed by `α`.
* A `first_order.language.sentence` is a formula with no free variables.
* A `first_order.language.Theory` is a set of sentences.
* The variables of terms and formulas can be relabelled with `first_order.language.term.relabel`,
`first_order.language.bounded_formula.relabel`, and `first_order.language.formula.relabel`.
* Given an operation on terms and an operation on relations,
  `first_order.language.bounded_formula.map_term_rel` gives an operation on formulas.
* `first_order.language.bounded_formula.cast_le` adds more `fin`-indexed variables.
* `first_order.language.bounded_formula.lift_at` raises the indexes of the `fin`-indexed variables
above a particular index.
* `first_order.language.term.subst` and `first_order.language.bounded_formula.subst` substitute
variables with given terms.
* Language maps can act on syntactic objects with functions such as
`first_order.language.Lhom.on_formula`.
* `first_order.language.term.constants_vars_equiv` and
`first_order.language.bounded_formula.constants_vars_equiv` switch terms and formulas between having
constants in the language and having extra variables indexed by the same type.

## Implementation Notes
* Formulas use a modified version of de Bruijn variables. Specifically, a `L.bounded_formula α n`
is a formula with some variables indexed by a type `α`, which cannot be quantified over, and some
indexed by `fin n`, which can. For any `φ : L.bounded_formula α (n + 1)`, we define the formula
`∀' φ : L.bounded_formula α n` by universally quantifying over the variable indexed by
`n : fin (n + 1)`.

## References
For the Flypitch project:
- [J. Han, F. van Doorn, *A formal proof of the independence of the continuum hypothesis*]
[flypitch_cpp]
- [J. Han, F. van Doorn, *A formalization of forcing and the unprovability of
the continuum hypothesis*][flypitch_itp]

-/

universes u v w u' v'

namespace first_order
namespace language

variables (L : language.{u v}) {L' : language}
variables {M : Type w} {N P : Type*} [L.Structure M] [L.Structure N] [L.Structure P]
variables {α : Type u'} {β : Type v'} {γ : Type*}
open_locale first_order
open Structure fin

/-- A term on `α` is either a variable indexed by an element of `α`
  or a function symbol applied to simpler terms. -/
inductive term (α : Type u') : Type (max u u')
| var {} : ∀ (a : α), term
| func {} : ∀ {l : ℕ} (f : L.functions l) (ts : fin l → term), term
export term

variable {L}

namespace term

open finset

/-- The `finset` of variables used in a given term. -/
@[simp] def var_finset [decidable_eq α] : L.term α → finset α
| (var i) := {i}
| (func f ts) := univ.bUnion (λ i, (ts i).var_finset)

/-- The `finset` of variables from the left side of a sum used in a given term. -/
@[simp] def var_finset_left [decidable_eq α] : L.term (α ⊕ β) → finset α
| (var (sum.inl i)) := {i}
| (var (sum.inr i)) := ∅
| (func f ts) := univ.bUnion (λ i, (ts i).var_finset_left)

/-- Relabels a term's variables along a particular function. -/
@[simp] def relabel (g : α → β) : L.term α → L.term β
| (var i) := var (g i)
| (func f ts) := func f (λ i, (ts i).relabel)

lemma relabel_id (t : L.term α) :
  t.relabel id = t :=
begin
  induction t with _ _ _ _ ih,
  { refl, },
  { simp [ih] },
end

@[simp] lemma relabel_id_eq_id :
  (term.relabel id : L.term α → L.term α) = id :=
funext relabel_id

@[simp] lemma relabel_relabel (f : α → β) (g : β → γ) (t : L.term α) :
  (t.relabel f).relabel g = t.relabel (g ∘ f) :=
begin
  induction t with _ _ _ _ ih,
  { refl, },
  { simp [ih] },
end

@[simp] lemma relabel_comp_relabel (f : α → β) (g : β → γ) :
  (term.relabel g ∘ term.relabel f : L.term α → L.term γ) = term.relabel (g ∘ f) :=
funext (relabel_relabel f g)

/-- Relabels a term's variables along a bijection. -/
@[simps] def relabel_equiv (g : α ≃ β) : L.term α ≃ L.term β :=
⟨relabel g, relabel g.symm, λ t, by simp, λ t, by simp⟩

/-- Restricts a term to use only a set of the given variables. -/
def restrict_var [decidable_eq α] : Π (t : L.term α) (f : t.var_finset → β), L.term β
| (var a) f := var (f ⟨a, mem_singleton_self a⟩)
| (func F ts) f := func F (λ i, (ts i).restrict_var
  (f ∘ set.inclusion (subset_bUnion_of_mem _ (mem_univ i))))

/-- Restricts a term to use only a set of the given variables on the left side of a sum. -/
def restrict_var_left [decidable_eq α] {γ : Type*} :
  Π (t : L.term (α ⊕ γ)) (f : t.var_finset_left → β), L.term (β ⊕ γ)
| (var (sum.inl a)) f := var (sum.inl (f ⟨a, mem_singleton_self a⟩))
| (var (sum.inr a)) f := var (sum.inr a)
| (func F ts) f := func F (λ i, (ts i).restrict_var_left
  (f ∘ set.inclusion (subset_bUnion_of_mem _ (mem_univ i))))

end term

/-- The representation of a constant symbol as a term. -/
def constants.term (c : L.constants) : (L.term α) :=
func c default

/-- Applies a unary function to a term. -/
def functions.apply₁ (f : L.functions 1) (t : L.term α) : L.term α := func f ![t]

/-- Applies a binary function to two terms. -/
def functions.apply₂ (f : L.functions 2) (t₁ t₂ : L.term α) : L.term α := func f ![t₁, t₂]

namespace term

/-- Sends a term with constants to a term with extra variables. -/
@[simp] def constants_to_vars : L[[γ]].term α → L.term (γ ⊕ α)
| (var a) := var (sum.inr a)
| (@func _ _ 0 f ts) := sum.cases_on f (λ f, func f (λ i, (ts i).constants_to_vars))
    (λ c, var (sum.inl c))
| (@func _ _ (n + 1) f ts) := sum.cases_on f (λ f, func f (λ i, (ts i).constants_to_vars))
    (λ c, is_empty_elim c)

/-- Sends a term with extra variables to a term with constants. -/
@[simp] def vars_to_constants : L.term (γ ⊕ α) → L[[γ]].term α
| (var (sum.inr a)) := var a
| (var (sum.inl c)) := constants.term (sum.inr c)
| (func f ts) := func (sum.inl f) (λ i, (ts i).vars_to_constants)

/-- A bijection between terms with constants and terms with extra variables. -/
@[simps] def constants_vars_equiv : L[[γ]].term α ≃ L.term (γ ⊕ α) :=
⟨constants_to_vars, vars_to_constants, begin
  intro t,
  induction t with _ n f _ ih,
  { refl },
  { cases n,
    { cases f,
      { simp [constants_to_vars, vars_to_constants, ih] },
      { simp [constants_to_vars, vars_to_constants, constants.term] } },
    { cases f,
      { simp [constants_to_vars, vars_to_constants, ih] },
      { exact is_empty_elim f } } }
end, begin
  intro t,
  induction t with x n f _ ih,
  { cases x;
    refl },
  { cases n;
    { simp [vars_to_constants, constants_to_vars, ih] } }
end⟩

/-- A bijection between terms with constants and terms with extra variables. -/
def constants_vars_equiv_left : L[[γ]].term (α ⊕ β) ≃ L.term ((γ ⊕ α) ⊕ β) :=
constants_vars_equiv.trans (relabel_equiv (equiv.sum_assoc _ _ _)).symm

@[simp] lemma constants_vars_equiv_left_apply (t : L[[γ]].term (α ⊕ β)) :
  constants_vars_equiv_left t = (constants_to_vars t).relabel (equiv.sum_assoc _ _ _).symm :=
rfl

@[simp] lemma constants_vars_equiv_left_symm_apply (t : L.term ((γ ⊕ α) ⊕ β)) :
  constants_vars_equiv_left.symm t = vars_to_constants (t.relabel (equiv.sum_assoc _ _ _)) :=
rfl

instance inhabited_of_var [inhabited α] : inhabited (L.term α) :=
⟨var default⟩

instance inhabited_of_constant [inhabited L.constants] : inhabited (L.term α) :=
⟨(default : L.constants).term⟩

/-- Raises all of the `fin`-indexed variables of a term greater than or equal to `m` by `n'`. -/
def lift_at {n : ℕ} (n' m : ℕ) : L.term (α ⊕ fin n) → L.term (α ⊕ fin (n + n')) :=
relabel (sum.map id (λ i, if ↑i < m then fin.cast_add n' i else fin.add_nat n' i))

/-- Substitutes the variables in a given term with terms. -/
@[simp] def subst : L.term α → (α → L.term β) → L.term β
| (var a) tf := tf a
| (func f ts) tf := (func f (λ i, (ts i).subst tf))

end term

localized "prefix (name := language.term.var) `&`:max :=
  first_order.language.term.var ∘ sum.inr" in first_order

namespace Lhom

/-- Maps a term's symbols along a language map. -/
@[simp] def on_term (φ : L →ᴸ L') : L.term α → L'.term α
| (var i) := var i
| (func f ts) := func (φ.on_function f) (λ i, on_term (ts i))

@[simp] lemma id_on_term :
  ((Lhom.id L).on_term : L.term α → L.term α) = id :=
begin
  ext t,
  induction t with _ _ _ _ ih,
  { refl },
  { simp_rw [on_term, ih],
    refl, },
end

@[simp] lemma comp_on_term {L'' : language} (φ : L' →ᴸ L'') (ψ : L →ᴸ L') :
  ((φ.comp ψ).on_term : L.term α → L''.term α) = φ.on_term ∘ ψ.on_term :=
begin
  ext t,
  induction t with _ _ _ _ ih,
  { refl },
  { simp_rw [on_term, ih],
    refl, },
end

end Lhom

/-- Maps a term's symbols along a language equivalence. -/
@[simps] def Lequiv.on_term (φ : L ≃ᴸ L') : L.term α ≃ L'.term α :=
{ to_fun := φ.to_Lhom.on_term,
  inv_fun := φ.inv_Lhom.on_term,
  left_inv := by rw [function.left_inverse_iff_comp, ← Lhom.comp_on_term, φ.left_inv,
    Lhom.id_on_term],
  right_inv := by rw [function.right_inverse_iff_comp, ← Lhom.comp_on_term, φ.right_inv,
    Lhom.id_on_term] }

variables (L) (α)
/-- `bounded_formula α n` is the type of formulas with free variables indexed by `α` and up to `n`
  additional free variables. -/
inductive bounded_formula : ℕ → Type (max u v u')
| falsum {} {n} : bounded_formula n
| equal {n} (t₁ t₂ : L.term (α ⊕ fin n)) : bounded_formula n
| rel {n l : ℕ} (R : L.relations l) (ts : fin l → L.term (α ⊕ fin n)) : bounded_formula n
| imp {n} (f₁ f₂ : bounded_formula n) : bounded_formula n
| all {n} (f : bounded_formula (n+1)) : bounded_formula n

/-- `formula α` is the type of formulas with all free variables indexed by `α`. -/
@[reducible] def formula := L.bounded_formula α 0

/-- A sentence is a formula with no free variables. -/
@[reducible] def sentence := L.formula empty

/-- A theory is a set of sentences. -/
@[reducible] def Theory := set L.sentence

variables {L} {α} {n : ℕ}

/-- Applies a relation to terms as a bounded formula. -/
def relations.bounded_formula {l : ℕ} (R : L.relations n) (ts : fin n → L.term (α ⊕ fin l)) :
  L.bounded_formula α l := bounded_formula.rel R ts

/-- Applies a unary relation to a term as a bounded formula. -/
def relations.bounded_formula₁ (r : L.relations 1) (t : L.term (α ⊕ fin n)) :
  L.bounded_formula α n :=
r.bounded_formula ![t]

/-- Applies a binary relation to two terms as a bounded formula. -/
def relations.bounded_formula₂ (r : L.relations 2) (t₁ t₂ : L.term (α ⊕ fin n)) :
  L.bounded_formula α n :=
r.bounded_formula ![t₁, t₂]

/-- The equality of two terms as a bounded formula. -/
def term.bd_equal (t₁ t₂ : L.term (α ⊕ fin n)) : (L.bounded_formula α n) :=
bounded_formula.equal t₁ t₂

/-- Applies a relation to terms as a bounded formula. -/
def relations.formula (R : L.relations n) (ts : fin n → L.term α) :
  L.formula α := R.bounded_formula (λ i, (ts i).relabel sum.inl)

/-- Applies a unary relation to a term as a formula. -/
def relations.formula₁ (r : L.relations 1) (t : L.term α) :
  L.formula α :=
r.formula ![t]

/-- Applies a binary relation to two terms as a formula. -/
def relations.formula₂ (r : L.relations 2) (t₁ t₂ : L.term α) :
  L.formula α :=
r.formula ![t₁, t₂]

/-- The equality of two terms as a first-order formula. -/
def term.equal (t₁ t₂ : L.term α) : (L.formula α) :=
(t₁.relabel sum.inl).bd_equal (t₂.relabel sum.inl)

namespace bounded_formula

instance : inhabited (L.bounded_formula α n) :=
⟨falsum⟩

instance : has_bot (L.bounded_formula α n) := ⟨falsum⟩

/-- The negation of a bounded formula is also a bounded formula. -/
@[pattern] protected def not (φ : L.bounded_formula α n) : L.bounded_formula α n := φ.imp ⊥

/-- Puts an `∃` quantifier on a bounded formula. -/
@[pattern] protected def ex (φ : L.bounded_formula α (n + 1)) : L.bounded_formula α n :=
  φ.not.all.not

instance : has_top (L.bounded_formula α n) := ⟨bounded_formula.not ⊥⟩

instance : has_inf (L.bounded_formula α n) := ⟨λ f g, (f.imp g.not).not⟩

instance : has_sup (L.bounded_formula α n) := ⟨λ f g, f.not.imp g⟩

/-- The biimplication between two bounded formulas. -/
protected def iff (φ ψ : L.bounded_formula α n) := φ.imp ψ ⊓ ψ.imp φ

open finset

/-- The `finset` of variables used in a given formula. -/
@[simp] def free_var_finset [decidable_eq α] :
  ∀ {n}, L.bounded_formula α n → finset α
| n falsum := ∅
| n (equal t₁ t₂) := t₁.var_finset_left ∪ t₂.var_finset_left
| n (rel R ts) := univ.bUnion (λ i, (ts i).var_finset_left)
| n (imp f₁ f₂) := f₁.free_var_finset ∪ f₂.free_var_finset
| n (all f) := f.free_var_finset

/-- Casts `L.bounded_formula α m` as `L.bounded_formula α n`, where `m ≤ n`. -/
@[simp] def cast_le : ∀ {m n : ℕ} (h : m ≤ n), L.bounded_formula α m → L.bounded_formula α n
| m n h falsum := falsum
| m n h (equal t₁ t₂) := equal (t₁.relabel (sum.map id (fin.cast_le h)))
    (t₂.relabel (sum.map id (fin.cast_le h)))
| m n h (rel R ts) := rel R (term.relabel (sum.map id (fin.cast_le h)) ∘ ts)
| m n h (imp f₁ f₂) := (f₁.cast_le h).imp (f₂.cast_le h)
| m n h (all f) := (f.cast_le (add_le_add_right h 1)).all

@[simp] lemma cast_le_rfl {n} (h : n ≤ n) (φ : L.bounded_formula α n) :
  φ.cast_le h = φ :=
begin
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp [fin.cast_le_of_eq], },
  { simp [fin.cast_le_of_eq], },
  { simp [fin.cast_le_of_eq, ih1, ih2], },
  { simp [fin.cast_le_of_eq, ih3], },
end

@[simp] lemma cast_le_cast_le {k m n} (km : k ≤ m) (mn : m ≤ n) (φ : L.bounded_formula α k) :
  (φ.cast_le km).cast_le mn = φ.cast_le (km.trans mn) :=
begin
  revert m n,
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3;
  intros m n km mn,
  { refl },
  { simp },
  { simp only [cast_le, eq_self_iff_true, heq_iff_eq, true_and],
    rw [← function.comp.assoc, relabel_comp_relabel],
    simp },
  { simp [ih1, ih2] },
  { simp only [cast_le, ih3] }
end

@[simp] lemma cast_le_comp_cast_le {k m n} (km : k ≤ m) (mn : m ≤ n) :
  (bounded_formula.cast_le mn ∘ bounded_formula.cast_le km :
    L.bounded_formula α k → L.bounded_formula α n) =
    bounded_formula.cast_le (km.trans mn) :=
funext (cast_le_cast_le km mn)

/-- Restricts a bounded formula to only use a particular set of free variables. -/
def restrict_free_var [decidable_eq α] : Π {n : ℕ} (φ : L.bounded_formula α n)
  (f : φ.free_var_finset → β), L.bounded_formula β n
| n falsum f := falsum
| n (equal t₁ t₂) f := equal
  (t₁.restrict_var_left (f ∘ set.inclusion (subset_union_left _ _)))
  (t₂.restrict_var_left (f ∘ set.inclusion (subset_union_right _ _)))
| n (rel R ts) f := rel R (λ i, (ts i).restrict_var_left
  (f ∘ set.inclusion (subset_bUnion_of_mem _ (mem_univ i))))
| n (imp φ₁ φ₂) f :=
  (φ₁.restrict_free_var (f ∘ set.inclusion (subset_union_left _ _))).imp
  (φ₂.restrict_free_var (f ∘ set.inclusion (subset_union_right _ _)))
| n (all φ) f := (φ.restrict_free_var f).all

/-- Places universal quantifiers on all extra variables of a bounded formula. -/
def alls : ∀ {n}, L.bounded_formula α n → L.formula α
| 0 φ := φ
| (n + 1) φ := φ.all.alls

/-- Places existential quantifiers on all extra variables of a bounded formula. -/
def exs : ∀ {n}, L.bounded_formula α n → L.formula α
| 0 φ := φ
| (n + 1) φ := φ.ex.exs

/-- Maps bounded formulas along a map of terms and a map of relations. -/
def map_term_rel {g : ℕ → ℕ}
  (ft : ∀ n, L.term (α ⊕ fin n) → L'.term (β ⊕ fin (g n)))
  (fr : ∀ n, L.relations n → L'.relations n)
  (h : ∀ n, L'.bounded_formula β (g (n + 1)) → L'.bounded_formula β (g n + 1)) :
  ∀ {n}, L.bounded_formula α n → L'.bounded_formula β (g n)
| n falsum := falsum
| n (equal t₁ t₂) := equal (ft _ t₁) (ft _ t₂)
| n (rel R ts) := rel (fr _ R) (λ i, ft _ (ts i))
| n (imp φ₁ φ₂) := φ₁.map_term_rel.imp φ₂.map_term_rel
| n (all φ) := (h n φ.map_term_rel).all

/-- Raises all of the `fin`-indexed variables of a formula greater than or equal to `m` by `n'`. -/
def lift_at : ∀ {n : ℕ} (n' m : ℕ), L.bounded_formula α n → L.bounded_formula α (n + n') :=
λ n n' m φ, φ.map_term_rel (λ k t, t.lift_at n' m) (λ _, id)
  (λ _, cast_le (by rw [add_assoc, add_comm 1, add_assoc]))

@[simp] lemma map_term_rel_map_term_rel {L'' : language}
  (ft : ∀ n, L.term (α ⊕ fin n) → L'.term (β ⊕ fin n))
  (fr : ∀ n, L.relations n → L'.relations n)
  (ft' : ∀ n, L'.term (β ⊕ fin n) → L''.term (γ ⊕ fin n))
  (fr' : ∀ n, L'.relations n → L''.relations n)
  {n} (φ : L.bounded_formula α n) :
  (φ.map_term_rel ft fr (λ _, id)).map_term_rel ft' fr' (λ _, id) =
    φ.map_term_rel (λ _, (ft' _) ∘ (ft _)) (λ _, (fr' _) ∘ (fr _)) (λ _, id) :=
begin
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp [map_term_rel] },
  { simp [map_term_rel] },
  { simp [map_term_rel, ih1, ih2] },
  { simp [map_term_rel, ih3], }
end

@[simp] lemma map_term_rel_id_id_id {n} (φ : L.bounded_formula α n) :
  φ.map_term_rel (λ _, id) (λ _, id) (λ _, id) = φ :=
begin
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp [map_term_rel] },
  { simp [map_term_rel] },
  { simp [map_term_rel, ih1, ih2] },
  { simp [map_term_rel, ih3], }
end

/-- An equivalence of bounded formulas given by an equivalence of terms and an equivalence of
relations. -/
@[simps] def map_term_rel_equiv (ft : ∀ n, L.term (α ⊕ fin n) ≃ L'.term (β ⊕ fin n))
  (fr : ∀ n, L.relations n ≃ L'.relations n) {n} :
  L.bounded_formula α n ≃ L'.bounded_formula β n :=
⟨map_term_rel (λ n, ft n) (λ n, fr n) (λ _, id),
  map_term_rel (λ n, (ft n).symm) (λ n, (fr n).symm) (λ _, id),
  λ φ, by simp, λ φ, by simp⟩

/-- A function to help relabel the variables in bounded formulas. -/
def relabel_aux (g : α → β ⊕ fin n) (k : ℕ) :
  α ⊕ fin k → β ⊕ fin (n + k) :=
sum.map id fin_sum_fin_equiv ∘ equiv.sum_assoc _ _ _ ∘ sum.map g id

@[simp] lemma sum_elim_comp_relabel_aux {m : ℕ} {g : α → (β ⊕ fin n)}
  {v : β → M} {xs : fin (n + m) → M} :
  sum.elim v xs ∘ relabel_aux g m =
    sum.elim (sum.elim v (xs ∘ cast_add m) ∘ g) (xs ∘ nat_add n) :=
begin
  ext x,
  cases x,
  { simp only [bounded_formula.relabel_aux, function.comp_app, sum.map_inl, sum.elim_inl],
    cases g x with l r;
    simp },
  { simp [bounded_formula.relabel_aux] }
end

@[simp] lemma relabel_aux_sum_inl (k : ℕ) :
  relabel_aux (sum.inl : α → α ⊕ fin n) k =
  sum.map id (nat_add n) :=
begin
  ext x,
  cases x;
  { simp [relabel_aux] },
end

/-- Relabels a bounded formula's variables along a particular function. -/
def relabel (g : α → (β ⊕ fin n)) {k} (φ : L.bounded_formula α k) :
  L.bounded_formula β (n + k) :=
φ.map_term_rel (λ _ t, t.relabel (relabel_aux g _)) (λ _, id)
  (λ _, cast_le (ge_of_eq (add_assoc _ _ _)))

/-- Relabels a bounded formula's free variables along a bijection. -/
def relabel_equiv (g : α ≃ β) {k} :
  L.bounded_formula α k ≃ L.bounded_formula β k :=
map_term_rel_equiv (λ n, term.relabel_equiv (g.sum_congr (_root_.equiv.refl _)))
  (λ n, _root_.equiv.refl _)

@[simp] lemma relabel_falsum (g : α → (β ⊕ fin n)) {k} :
  (falsum : L.bounded_formula α k).relabel g = falsum :=
rfl

@[simp] lemma relabel_bot (g : α → (β ⊕ fin n)) {k} :
  (⊥ : L.bounded_formula α k).relabel g = ⊥ :=
rfl

@[simp] lemma relabel_imp (g : α → (β ⊕ fin n)) {k} (φ ψ : L.bounded_formula α k) :
  (φ.imp ψ).relabel g = (φ.relabel g).imp (ψ.relabel g) :=
rfl

@[simp] lemma relabel_not (g : α → (β ⊕ fin n)) {k} (φ : L.bounded_formula α k) :
  φ.not.relabel g = (φ.relabel g).not :=
by simp [bounded_formula.not]

@[simp] lemma relabel_all (g : α → (β ⊕ fin n)) {k} (φ : L.bounded_formula α (k + 1)) :
  φ.all.relabel g = (φ.relabel g).all :=
begin
  rw [relabel, map_term_rel, relabel],
  simp,
end

@[simp] lemma relabel_ex (g : α → (β ⊕ fin n)) {k} (φ : L.bounded_formula α (k + 1)) :
  φ.ex.relabel g = (φ.relabel g).ex :=
by simp [bounded_formula.ex]

@[simp] lemma relabel_sum_inl (φ : L.bounded_formula α n) :
  (φ.relabel sum.inl : L.bounded_formula α (0 + n)) =
  φ.cast_le (ge_of_eq (zero_add n)) :=
begin
  simp only [relabel, relabel_aux_sum_inl],
  induction φ with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp [fin.nat_add_zero, cast_le_of_eq, map_term_rel] },
  { simp [fin.nat_add_zero, cast_le_of_eq, map_term_rel] },
  { simp [map_term_rel, ih1, ih2], },
  { simp [map_term_rel, ih3, cast_le], },
end

/-- Substitutes the variables in a given formula with terms. -/
@[simp] def subst {n : ℕ} (φ : L.bounded_formula α n) (f : α → L.term β) : L.bounded_formula β n :=
φ.map_term_rel (λ _ t, t.subst (sum.elim (term.relabel sum.inl ∘ f) (var ∘ sum.inr)))
  (λ _, id) (λ _, id)

/-- A bijection sending formulas with constants to formulas with extra variables. -/
def constants_vars_equiv : L[[γ]].bounded_formula α n ≃ L.bounded_formula (γ ⊕ α) n :=
map_term_rel_equiv (λ _, term.constants_vars_equiv_left) (λ _, equiv.sum_empty _ _)

/-- Turns the extra variables of a bounded formula into free variables. -/
@[simp] def to_formula : ∀ {n : ℕ}, L.bounded_formula α n → L.formula (α ⊕ fin n)
| n falsum := falsum
| n (equal t₁ t₂) := t₁.equal t₂
| n (rel R ts) := R.formula ts
| n (imp φ₁ φ₂) := φ₁.to_formula.imp φ₂.to_formula
| n (all φ) := (φ.to_formula.relabel
  (sum.elim (sum.inl ∘ sum.inl) (sum.map sum.inr id ∘ fin_sum_fin_equiv.symm))).all

variables {l : ℕ} {φ ψ : L.bounded_formula α l} {θ : L.bounded_formula α l.succ}
variables {v : α → M} {xs : fin l → M}

/-- An atomic formula is either equality or a relation symbol applied to terms.
  Note that `⊥` and `⊤` are not considered atomic in this convention. -/
inductive is_atomic : L.bounded_formula α n → Prop
| equal (t₁ t₂ : L.term (α ⊕ fin n)) : is_atomic (bd_equal t₁ t₂)
| rel {l : ℕ} (R : L.relations l) (ts : fin l → L.term (α ⊕ fin n)) :
    is_atomic (R.bounded_formula ts)

lemma not_all_is_atomic (φ : L.bounded_formula α (n + 1)) :
  ¬ φ.all.is_atomic :=
λ con, by cases con

lemma not_ex_is_atomic (φ : L.bounded_formula α (n + 1)) :
  ¬ φ.ex.is_atomic :=
λ con, by cases con

lemma is_atomic.relabel {m : ℕ} {φ : L.bounded_formula α m} (h : φ.is_atomic)
  (f : α → β ⊕ (fin n)) :
  (φ.relabel f).is_atomic :=
is_atomic.rec_on h (λ _ _, is_atomic.equal _ _) (λ _ _ _, is_atomic.rel _ _)

lemma is_atomic.lift_at {k m : ℕ} (h : is_atomic φ) : (φ.lift_at k m).is_atomic :=
is_atomic.rec_on h (λ _ _, is_atomic.equal _ _) (λ _ _ _, is_atomic.rel _ _)

lemma is_atomic.cast_le {h : l ≤ n} (hφ : is_atomic φ) :
  (φ.cast_le h).is_atomic :=
is_atomic.rec_on hφ (λ _ _, is_atomic.equal _ _) (λ _ _ _, is_atomic.rel _ _)

/-- A quantifier-free formula is a formula defined without quantifiers. These are all equivalent
to boolean combinations of atomic formulas. -/
inductive is_qf : L.bounded_formula α n → Prop
| falsum : is_qf falsum
| of_is_atomic {φ} (h : is_atomic φ) : is_qf φ
| imp {φ₁ φ₂} (h₁ : is_qf φ₁) (h₂ : is_qf φ₂) : is_qf (φ₁.imp φ₂)

lemma is_atomic.is_qf {φ : L.bounded_formula α n} : is_atomic φ → is_qf φ :=
is_qf.of_is_atomic

lemma is_qf_bot : is_qf (⊥ : L.bounded_formula α n) :=
is_qf.falsum

lemma is_qf.not {φ : L.bounded_formula α n} (h : is_qf φ) :
  is_qf φ.not :=
h.imp is_qf_bot

lemma is_qf.relabel {m : ℕ} {φ : L.bounded_formula α m} (h : φ.is_qf)
  (f : α → β ⊕ (fin n)) :
  (φ.relabel f).is_qf :=
is_qf.rec_on h is_qf_bot (λ _ h, (h.relabel f).is_qf) (λ _ _ _ _ h1 h2, h1.imp h2)

lemma is_qf.lift_at {k m : ℕ} (h : is_qf φ) : (φ.lift_at k m).is_qf :=
is_qf.rec_on h is_qf_bot (λ _ ih, ih.lift_at.is_qf) (λ _ _ _ _ ih1 ih2, ih1.imp ih2)

lemma is_qf.cast_le {h : l ≤ n} (hφ : is_qf φ) :
  (φ.cast_le h).is_qf :=
is_qf.rec_on hφ is_qf_bot (λ _ ih, ih.cast_le.is_qf) (λ _ _ _ _ ih1 ih2, ih1.imp ih2)

lemma not_all_is_qf (φ : L.bounded_formula α (n + 1)) :
  ¬ φ.all.is_qf :=
λ con, begin
  cases con with _ con,
  exact (φ.not_all_is_atomic con),
end

lemma not_ex_is_qf (φ : L.bounded_formula α (n + 1)) :
  ¬ φ.ex.is_qf :=
λ con, begin
  cases con with _ con _ _ con,
  { exact (φ.not_ex_is_atomic con) },
  { exact not_all_is_qf _ con }
end

/-- Indicates that a bounded formula is in prenex normal form - that is, it consists of quantifiers
  applied to a quantifier-free formula. -/
inductive is_prenex : ∀ {n}, L.bounded_formula α n → Prop
| of_is_qf {n} {φ : L.bounded_formula α n} (h : is_qf φ) : is_prenex φ
| all {n} {φ : L.bounded_formula α (n + 1)} (h : is_prenex φ) : is_prenex φ.all
| ex {n} {φ : L.bounded_formula α (n + 1)} (h : is_prenex φ) : is_prenex φ.ex

lemma is_qf.is_prenex {φ : L.bounded_formula α n} : is_qf φ → is_prenex φ :=
is_prenex.of_is_qf

lemma is_atomic.is_prenex {φ : L.bounded_formula α n} (h : is_atomic φ) : is_prenex φ :=
h.is_qf.is_prenex

lemma is_prenex.induction_on_all_not {P : ∀ {n}, L.bounded_formula α n → Prop}
  {φ : L.bounded_formula α n}
  (h : is_prenex φ)
  (hq : ∀ {m} {ψ : L.bounded_formula α m}, ψ.is_qf → P ψ)
  (ha : ∀ {m} {ψ : L.bounded_formula α (m + 1)}, P ψ → P ψ.all)
  (hn : ∀ {m} {ψ : L.bounded_formula α m}, P ψ → P ψ.not) :
  P φ :=
is_prenex.rec_on h (λ _ _, hq) (λ _ _ _, ha) (λ _ _ _ ih, hn (ha (hn ih)))

lemma is_prenex.relabel {m : ℕ} {φ : L.bounded_formula α m} (h : φ.is_prenex)
  (f : α → β ⊕ (fin n)) :
  (φ.relabel f).is_prenex :=
is_prenex.rec_on h
  (λ _ _ h, (h.relabel f).is_prenex)
  (λ _ _ _ h, by simp [h.all])
  (λ _ _ _ h, by simp [h.ex])

lemma is_prenex.cast_le (hφ : is_prenex φ) :
  ∀ {n} {h : l ≤ n}, (φ.cast_le h).is_prenex :=
is_prenex.rec_on hφ
  (λ _ _ ih _ _, ih.cast_le.is_prenex)
  (λ _ _ _ ih _ _, ih.all)
  (λ _ _ _ ih _ _, ih.ex)

lemma is_prenex.lift_at {k m : ℕ} (h : is_prenex φ) : (φ.lift_at k m).is_prenex :=
is_prenex.rec_on h
  (λ _ _ ih, ih.lift_at.is_prenex)
  (λ _ _ _ ih, ih.cast_le.all)
  (λ _ _ _ ih, ih.cast_le.ex)

/-- An auxiliary operation to `first_order.language.bounded_formula.to_prenex`.
  If `φ` is quantifier-free and `ψ` is in prenex normal form, then `φ.to_prenex_imp_right ψ`
  is a prenex normal form for `φ.imp ψ`. -/
def to_prenex_imp_right :
  ∀ {n}, L.bounded_formula α n → L.bounded_formula α n → L.bounded_formula α n
| n φ (bounded_formula.ex ψ) := ((φ.lift_at 1 n).to_prenex_imp_right ψ).ex
| n φ (all ψ) := ((φ.lift_at 1 n).to_prenex_imp_right ψ).all
| n φ ψ := φ.imp ψ

lemma is_qf.to_prenex_imp_right {φ : L.bounded_formula α n} :
  Π {ψ : L.bounded_formula α n}, is_qf ψ → (φ.to_prenex_imp_right ψ = φ.imp ψ)
| _ is_qf.falsum := rfl
| _ (is_qf.of_is_atomic (is_atomic.equal _ _)) := rfl
| _ (is_qf.of_is_atomic (is_atomic.rel _ _)) := rfl
| _ (is_qf.imp is_qf.falsum _) := rfl
| _ (is_qf.imp (is_qf.of_is_atomic (is_atomic.equal _ _)) _) := rfl
| _ (is_qf.imp (is_qf.of_is_atomic (is_atomic.rel _ _)) _) := rfl
| _ (is_qf.imp (is_qf.imp _ _) _) := rfl

lemma is_prenex_to_prenex_imp_right {φ ψ : L.bounded_formula α n}
  (hφ : is_qf φ) (hψ : is_prenex ψ) :
  is_prenex (φ.to_prenex_imp_right ψ) :=
begin
  induction hψ with _ _ hψ _ _ _ ih1 _ _ _ ih2,
  { rw hψ.to_prenex_imp_right,
    exact (hφ.imp hψ).is_prenex },
  { exact (ih1 hφ.lift_at).all },
  { exact (ih2 hφ.lift_at).ex }
end

/-- An auxiliary operation to `first_order.language.bounded_formula.to_prenex`.
  If `φ` and `ψ` are in prenex normal form, then `φ.to_prenex_imp ψ`
  is a prenex normal form for `φ.imp ψ`. -/
def to_prenex_imp :
  ∀ {n}, L.bounded_formula α n → L.bounded_formula α n → L.bounded_formula α n
| n (bounded_formula.ex φ) ψ := (φ.to_prenex_imp (ψ.lift_at 1 n)).all
| n (all φ) ψ := (φ.to_prenex_imp (ψ.lift_at 1 n)).ex
| _ φ ψ := φ.to_prenex_imp_right ψ

lemma is_qf.to_prenex_imp : Π {φ ψ : L.bounded_formula α n}, φ.is_qf →
  φ.to_prenex_imp ψ = φ.to_prenex_imp_right ψ
| _ _ is_qf.falsum := rfl
| _ _ (is_qf.of_is_atomic (is_atomic.equal _ _)) := rfl
| _ _ (is_qf.of_is_atomic (is_atomic.rel _ _)) := rfl
| _ _ (is_qf.imp is_qf.falsum _) := rfl
| _ _ (is_qf.imp (is_qf.of_is_atomic (is_atomic.equal _ _)) _) := rfl
| _ _ (is_qf.imp (is_qf.of_is_atomic (is_atomic.rel _ _)) _) := rfl
| _ _ (is_qf.imp (is_qf.imp _ _) _) := rfl

lemma is_prenex_to_prenex_imp {φ ψ : L.bounded_formula α n}
  (hφ : is_prenex φ) (hψ : is_prenex ψ) :
  is_prenex (φ.to_prenex_imp ψ) :=
begin
  induction hφ with _ _ hφ _ _ _ ih1 _ _ _ ih2,
  { rw hφ.to_prenex_imp,
    exact is_prenex_to_prenex_imp_right hφ hψ },
  { exact (ih1 hψ.lift_at).ex },
  { exact (ih2 hψ.lift_at).all }
end

/-- For any bounded formula `φ`, `φ.to_prenex` is a semantically-equivalent formula in prenex normal
  form. -/
def to_prenex : ∀ {n}, L.bounded_formula α n → L.bounded_formula α n
| _ falsum        := ⊥
| _ (equal t₁ t₂) := t₁.bd_equal t₂
| _ (rel R ts)    := rel R ts
| _ (imp f₁ f₂)   := f₁.to_prenex.to_prenex_imp f₂.to_prenex
| _ (all f)       := f.to_prenex.all

lemma to_prenex_is_prenex (φ : L.bounded_formula α n) :
  φ.to_prenex.is_prenex :=
bounded_formula.rec_on φ
  (λ _, is_qf_bot.is_prenex)
  (λ _ _ _, (is_atomic.equal _ _).is_prenex)
  (λ _ _ _ _, (is_atomic.rel _ _).is_prenex)
  (λ _ _ _ h1 h2, is_prenex_to_prenex_imp h1 h2)
  (λ _ _, is_prenex.all)

end bounded_formula

namespace Lhom
open bounded_formula

/-- Maps a bounded formula's symbols along a language map. -/
@[simp] def on_bounded_formula (g : L →ᴸ L') :
  ∀ {k : ℕ}, L.bounded_formula α k → L'.bounded_formula α k
| k falsum := falsum
| k (equal t₁ t₂) := (g.on_term t₁).bd_equal (g.on_term t₂)
| k (rel R ts) := (g.on_relation R).bounded_formula (g.on_term ∘ ts)
| k (imp f₁ f₂) := (on_bounded_formula f₁).imp (on_bounded_formula f₂)
| k (all f) := (on_bounded_formula f).all

@[simp] lemma id_on_bounded_formula :
  ((Lhom.id L).on_bounded_formula : L.bounded_formula α n → L.bounded_formula α n) = id :=
begin
  ext f,
  induction f with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { rw [on_bounded_formula, Lhom.id_on_term, id.def, id.def, id.def, bd_equal] },
  { rw [on_bounded_formula, Lhom.id_on_term],
    refl, },
  { rw [on_bounded_formula, ih1, ih2, id.def, id.def, id.def] },
  { rw [on_bounded_formula, ih3, id.def, id.def] }
end

@[simp] lemma comp_on_bounded_formula {L'' : language} (φ : L' →ᴸ L'') (ψ : L →ᴸ L') :
  ((φ.comp ψ).on_bounded_formula : L.bounded_formula α n → L''.bounded_formula α n) =
    φ.on_bounded_formula ∘ ψ.on_bounded_formula :=
begin
  ext f,
  induction f with _ _ _ _ _ _ _ _ _ _ _ ih1 ih2 _ _ ih3,
  { refl },
  { simp only [on_bounded_formula, comp_on_term, function.comp_app],
    refl, },
  { simp only [on_bounded_formula, comp_on_relation, comp_on_term, function.comp_app],
    refl },
  { simp only [on_bounded_formula, function.comp_app, ih1, ih2, eq_self_iff_true, and_self], },
  { simp only [ih3, on_bounded_formula, function.comp_app] }
end

/-- Maps a formula's symbols along a language map. -/
def on_formula (g : L →ᴸ L') : L.formula α → L'.formula α :=
g.on_bounded_formula

/-- Maps a sentence's symbols along a language map. -/
def on_sentence (g : L →ᴸ L') : L.sentence → L'.sentence :=
g.on_formula

/-- Maps a theory's symbols along a language map. -/
def on_Theory (g : L →ᴸ L') (T : L.Theory) : L'.Theory :=
g.on_sentence '' T

@[simp]

end Lhom

namespace Lequiv

/-- Maps a bounded formula's symbols along a language equivalence. -/
@[simps] def on_bounded_formula (φ : L ≃ᴸ L') :
  L.bounded_formula α n ≃ L'.bounded_formula α n :=
{ to_fun := φ.to_Lhom.on_bounded_formula,
  inv_fun := φ.inv_Lhom.on_bounded_formula,
  left_inv := by rw [function.left_inverse_iff_comp, ← Lhom.comp_on_bounded_formula, φ.left_inv,
    Lhom.id_on_bounded_formula],
  right_inv := by rw [function.right_inverse_iff_comp, ← Lhom.comp_on_bounded_formula, φ.right_inv,
    Lhom.id_on_bounded_formula] }

lemma on_bounded_formula_symm (φ : L ≃ᴸ L') :
  (φ.on_bounded_formula.symm : L'.bounded_formula α n ≃ L.bounded_formula α n) =
    φ.symm.on_bounded_formula :=
rfl

/-- Maps a formula's symbols along a language equivalence. -/
def on_formula (φ : L ≃ᴸ L') :
  L.formula α ≃ L'.formula α :=
φ.on_bounded_formula

@[simp] lemma on_formula_apply (φ : L ≃ᴸ L') :
  (φ.on_formula : L.formula α → L'.formula α) = φ.to_Lhom.on_formula :=
rfl

@[simp] lemma on_formula_symm (φ : L ≃ᴸ L') :
  (φ.on_formula.symm : L'.formula α ≃ L.formula α) = φ.symm.on_formula :=
rfl

/-- Maps a sentence's symbols along a language equivalence. -/
@[simps] def on_sentence (φ : L ≃ᴸ L') :
  L.sentence ≃ L'.sentence :=
φ.on_formula

end Lequiv

localized "infix (name := term.bd_equal)
  ` =' `:88 := first_order.language.term.bd_equal" in first_order
  -- input \~- or \simeq
localized "infixr (name := bounded_formula.imp)
  ` ⟹ `:62 := first_order.language.bounded_formula.imp" in first_order
  -- input \==>
localized "prefix (name := bounded_formula.all)
  `∀'`:110 := first_order.language.bounded_formula.all" in first_order
localized "prefix (name := bounded_formula.not)
  `∼`:max := first_order.language.bounded_formula.not" in first_order
  -- input \~, the ASCII character ~ has too low precedence
localized "infix (name := bounded_formula.iff)
  ` ⇔ `:61 := first_order.language.bounded_formula.iff" in first_order -- input \<=>
localized "prefix (name := bounded_formula.ex)
  `∃'`:110 := first_order.language.bounded_formula.ex" in first_order -- input \ex

namespace formula

/-- Relabels a formula's variables along a particular function. -/
def relabel (g : α → β) : L.formula α → L.formula β :=
@bounded_formula.relabel _ _ _ 0 (sum.inl ∘ g) 0

/-- The graph of a function as a first-order formula. -/
def graph (f : L.functions n) : L.formula (fin (n + 1)) :=
equal (var 0) (func f (λ i, var i.succ))

/-- The negation of a formula. -/
protected def not (φ : L.formula α) : L.formula α := φ.not

/-- The implication between formulas, as a formula. -/
protected def imp : L.formula α → L.formula α → L.formula α := bounded_formula.imp

/-- The biimplication between formulas, as a formula. -/
protected def iff (φ ψ : L.formula α) : L.formula α := φ.iff ψ

lemma is_atomic_graph (f : L.functions n) : (graph f).is_atomic :=
bounded_formula.is_atomic.equal _ _

/-- A bijection sending formulas to sentences with constants. -/
def equiv_sentence : L.formula α ≃ L[[α]].sentence :=
(bounded_formula.constants_vars_equiv.trans
  (bounded_formula.relabel_equiv (equiv.sum_empty _ _))).symm

lemma equiv_sentence_not (φ : L.formula α) :
  equiv_sentence φ.not = (equiv_sentence φ).not :=
rfl

lemma equiv_sentence_inf (φ ψ : L.formula α) :
  equiv_sentence (φ ⊓ ψ) = equiv_sentence φ ⊓ equiv_sentence ψ :=
rfl

end formula

namespace relations

variable (r : L.relations 2)

/-- The sentence indicating that a basic relation symbol is reflexive. -/
protected def reflexive : L.sentence := ∀' r.bounded_formula₂ &0 &0

/-- The sentence indicating that a basic relation symbol is irreflexive. -/
protected def irreflexive : L.sentence := ∀' ∼ (r.bounded_formula₂ &0 &0)

/-- The sentence indicating that a basic relation symbol is symmetric. -/
protected def symmetric : L.sentence := ∀' ∀' (r.bounded_formula₂ &0 &1 ⟹ r.bounded_formula₂ &1 &0)

/-- The sentence indicating that a basic relation symbol is antisymmetric. -/
protected def antisymmetric : L.sentence :=
  ∀' ∀' (r.bounded_formula₂ &0 &1 ⟹ (r.bounded_formula₂ &1 &0 ⟹ term.bd_equal &0 &1))

/-- The sentence indicating that a basic relation symbol is transitive. -/
protected def transitive : L.sentence :=
  ∀' ∀' ∀' (r.bounded_formula₂ &0 &1 ⟹ r.bounded_formula₂ &1 &2 ⟹ r.bounded_formula₂ &0 &2)

/-- The sentence indicating that a basic relation symbol is total. -/
protected def total : L.sentence :=
  ∀' ∀' (r.bounded_formula₂ &0 &1 ⊔ r.bounded_formula₂ &1 &0)

end relations

section cardinality

variable (L)

/-- A sentence indicating that a structure has `n` distinct elements. -/
protected def sentence.card_ge (n) : L.sentence :=
(((((list.fin_range n).product (list.fin_range n)).filter (λ ij : _ × _, ij.1 ≠ ij.2)).map
  (λ (ij : _ × _), ∼ ((& ij.1).bd_equal (& ij.2)))).foldr (⊓) ⊤).exs

/-- A theory indicating that a structure is infinite. -/
def infinite_theory : L.Theory := set.range (sentence.card_ge L)

/-- A theory that indicates a structure is nonempty. -/
def nonempty_theory : L.Theory := {sentence.card_ge L 1}

/-- A theory indicating that each of a set of constants is distinct. -/
def distinct_constants_theory (s : set α) : L[[α]].Theory :=
(λ ab : α × α, (((L.con ab.1).term.equal (L.con ab.2).term).not)) '' (s ×ˢ s ∩ (set.diagonal α)ᶜ)

variables {L} {α}

open set

lemma monotone_distinct_constants_theory :
  monotone (L.distinct_constants_theory : set α → L[[α]].Theory) :=
λ s t st, (image_subset _ (inter_subset_inter_left _ (prod_mono st st)))

lemma directed_distinct_constants_theory :
  directed (⊆) (L.distinct_constants_theory : set α → L[[α]].Theory) :=
monotone.directed_le monotone_distinct_constants_theory

lemma distinct_constants_theory_eq_Union (s : set α) :
  L.distinct_constants_theory s = ⋃ (t : finset s), L.distinct_constants_theory
    (t.map (function.embedding.subtype (λ x, x ∈ s))) :=
begin
  classical,
  simp only [distinct_constants_theory],
  rw [← image_Union, ← Union_inter],
  refine congr rfl (congr (congr rfl _) rfl),
  ext ⟨i, j⟩,
  simp only [prod_mk_mem_set_prod_eq, finset.coe_map, function.embedding.coe_subtype, mem_Union,
    mem_image, finset.mem_coe, subtype.exists, subtype.coe_mk, exists_and_distrib_right,
    exists_eq_right],
  refine ⟨λ h, ⟨{⟨i, h.1⟩, ⟨j, h.2⟩}, ⟨h.1, _⟩, ⟨h.2, _⟩⟩, _⟩,
  { simp },
  { simp },
  { rintros ⟨t, ⟨is, _⟩, ⟨js, _⟩⟩,
    exact ⟨is, js⟩ }
end

end cardinality

end language
end first_order


import data.nat.basic
import tactic.basic
import .ch01_basics

open basics (oddb eqb leb)
open nat (pred zero succ)

namespace lists

/-
  nb. i skipped from induction to tactics
  the bits using lists and polymorphism there annoyed me
  whoops

  let's see how well i can ignore those tactics in the
  next two chapters that should precede them
-/

/-
Inductive natprod : Type :=
| pair (n1 n2 : nat).
-/

/- in lean, prod is actually a structure -/
inductive natprod : Type
| pair (n1 n2 : ℕ)

open natprod

/-
Check (pair 3 5).
-/

#check pair 3 5

/-
Definition fst (p : natprod) : nat :=
  match p with
  | pair x y ⇒ x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair x y ⇒ y
  end.
Compute (fst (pair 3 5)).
(* ===> 3 *)
-/

definition fst : natprod → ℕ
| (pair x _) := x

definition snd : natprod → ℕ
| (pair _ y) := y

#reduce fst (pair 3 5)

/-
Notation "( x , y )" := (pair x y).
-/

/-
using parentheses breaks things in surprising ways
definition of minus below fails to compile at first closing paren

update : using braces breaks typeclass instance definitions
should be okay if local
-/
local notation {x, y} := pair x y

/-
Compute (fst (3,5)).

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) ⇒ x
  end.

Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) ⇒ y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) ⇒ (y,x)
  end.
-/

#reduce fst {3, 5}

def fst' : natprod → ℕ
| {x, _} := x

def snd' : natprod → ℕ
| {_, y} := y

def swap_pair : natprod → natprod
| {x, y} := {y, x}

/-
Fixpoint minus (n m : nat) : nat :=
  match n, m with
  | O   , _    ⇒ O
  | S _ , O    ⇒ n
  | S n', S m' ⇒ minus n' m'
  end.
-/

/-
stated before, but lean doesn't allow recursion
with the match notation.
the point is to show comma fun, so i think it's ok
to use the built in subtraction
-/
def minus : ℕ → ℕ → ℕ
| 0 _ := 0
| _ 0 := 0
| (n + 1) (m + 1) := minus n m

/-
(* Can't match on a pair with multiple patterns: *)
Definition bad_fst (p : natprod) : nat :=
  match p with
  | x, y ⇒ x
  end.

(* Can't match on multiple values with pair patterns: *)
Definition bad_minus (n m : nat) : nat :=
  match n, m with
  | (O   , _   ) ⇒ O
  | (S _ , O   ) ⇒ n
  | (S n', S m') ⇒ bad_minus n' m'
  end.
-/

/-
def bad_fst : natprod → ℕ
| x y := x

def bad_minus : ℕ → ℕ → ℕ
| {0, _} := 0
| {_, 0} := n
| {n + 1, m + 1} := n - m
-/

/-
Theorem surjective_pairing' : ∀(n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity. Qed.
-/

theorem surjective_pairing' (n m : ℕ)
  : {n, m} = {fst {n, m}, snd {n, m}} := rfl

/-
Theorem surjective_pairing_stuck : ∀(p : natprod),
  p = (fst p, snd p).
Proof.
  simpl. (* Doesn't reduce anything! *)
Abort.
-/

/-
theorem surjective_pairing_stuck (p : natprod)
  : p = {fst p, snd p} :=
begin
  simp [fst, snd],
  /- abort -/
end
-/

/-
Theorem surjective_pairing : ∀(p : natprod),
  p = (fst p, snd p).
Proof.
  intros p. destruct p as [n m]. simpl. reflexivity. Qed.
-/

theorem surjective_pairing (p : natprod) : p = {fst p, snd p} :=
begin
  cases p with n m,
  refl,
end

/-
Theorem snd_fst_is_swap : ∀(p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem snd_fst_is_swap (p : natprod) : {snd p, fst p} = swap_pair p :=
begin
  cases p with n m,
  refl,
end

/-
Theorem fst_swap_is_snd : ∀(p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem fst_swap_is_snd (p : natprod) : fst (swap_pair p) = snd p :=
begin
  cases p with n m,
  refl,
end

/-
Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).
-/

inductive natlist : Type
| nil
| cons (n : ℕ) (l : natlist)

open natlist

/-
Definition mylist := cons 1 (cons 2 (cons 3 nil)).
-/

def mylist := cons 1 (cons 2 (cons 3 nil))

/-
Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
-/

/-
same as above. there are conflicts with core using brackets
not sure how the foldr notation works
-/
local infixr :: := cons
local notation `[` l:(foldr `, ` (h t, cons h t) nil `]`) := l

/-
Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].
-/

def mylist1 := 1 :: (2 :: (3 :: nil))
def mylist2 := 1 :: 2 :: 3 :: nil
def mylist3 := [1, 2, 3]

/-
Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O ⇒ nil
  | S count' ⇒ n :: (repeat n count')
  end.
-/

def repeat (n : ℕ) : ℕ → natlist
| 0 := nil
| (m + 1) := n :: repeat m

/-
Fixpoint length (l:natlist) : nat :=
  match l with
  | nil ⇒ O
  | h :: t ⇒ S (length t)
  end.
-/

def length : natlist → ℕ
| nil := 0
| (_ :: t) := length t + 1

/-
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil ⇒ l2
  | h :: t ⇒ h :: (app t l2)
  end.
-/

def append : natlist → natlist → natlist
| nil l2 := l2
| (h::t) l2 := h :: append t l2

/-
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.

Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.

Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.
-/

infix ++ := append

example : [1, 2, 3] ++ [4, 5] = [1, 2, 3, 4, 5] := rfl
example : nil ++ [4, 5] = [4, 5] := rfl
example : [1, 2, 3] ++ nil = [1, 2, 3] := rfl

/-
Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil ⇒ default
  | h :: t ⇒ h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil ⇒ nil
  | h :: t ⇒ t
  end.

Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.

Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.

Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.
-/

def head (default : ℕ) : natlist → ℕ
| nil := default
| (h::_) := h

def tail : natlist → natlist
| nil := nil
| (_::t) := t

example : head 0 [1, 2, 3] = 1 := rfl
example : head 0 [] = 0 := rfl
example : tail [1, 2, 3] = [2, 3] := rfl

/-
Fixpoint nonzeros (l:natlist) : natlist
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
  (* FILL IN HERE *) Admitted.

Fixpoint oddmembers (l:natlist) : natlist
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
  (* FILL IN HERE *) Admitted.

Definition countoddmembers (l:natlist) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
  (* FILL IN HERE *) Admitted.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
  (* FILL IN HERE *) Admitted.

Example test_countoddmembers3:
  countoddmembers nil = 0.
  (* FILL IN HERE *) Admitted.
-/

def nonzeros : natlist → natlist
| ((n + 1)::t) := (n + 1)::nonzeros t
| (_::t) := nonzeros t
| _ := nil

example : nonzeros [0, 1, 0, 2, 3, 0, 0] = [1, 2, 3] := rfl

def filter (p : ℕ → bool) : natlist → natlist
| (h::t) := if p h then h::filter t else filter t
| _ := nil

def oddmembers := filter oddb

example : oddmembers [0, 1, 0, 2, 3, 0, 0] = [1, 3] := rfl

def countoddmembers := length ∘ oddmembers

example : countoddmembers [1, 0, 3, 1, 4, 5] = 4 := rfl

example : countoddmembers [0, 2, 4] = 0 := rfl

example : countoddmembers nil = 0 := rfl

/-
Fixpoint alternate (l1 l2 : natlist) : natlist
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
  (* FILL IN HERE *) Admitted.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
  (* FILL IN HERE *) Admitted.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
  (* FILL IN HERE *) Admitted.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
  (* FILL IN HERE *) Admitted.
-/

def alternate : natlist → natlist → natlist
| nil r := r
| l nil := l
| (lh::lt) (rh::rt) := lh::rh::alternate lt rt

example : alternate [1, 2, 3] [4, 5, 6] = [1, 4, 2, 5, 3, 6] := rfl

example : alternate [1] [4, 5, 6] = [1, 4, 5, 6] := rfl

example : alternate [1, 2, 3] [4] = [1, 4, 2, 3] := rfl

example : alternate [] [20, 30] = [20, 30] := rfl

/-
Definition bag := natlist.
-/

def bag := natlist

/-
Fixpoint count (v:nat) (s:bag) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
-/

/- i really feel like i'm starting to miss the point -/
def count (v : ℕ) : bag → ℕ :=
  length ∘ filter (eqb v)

/-
Example test_count1: count 1 [1;2;3;1;4;1] = 3.
 (* FILL IN HERE *) Admitted.

Example test_count2: count 6 [1;2;3;1;4;1] = 0.
 (* FILL IN HERE *) Admitted.
-/

example : count 1 [1, 2, 3, 1, 4, 1] = 3 := rfl

example : count 6 [1, 2, 3, 1, 4, 1] = 0 := rfl

/-
Definition sum : bag → bag → bag
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
 (* FILL IN HERE *) Admitted.

Definition add (v:nat) (s:bag) : bag
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
 (* FILL IN HERE *) Admitted.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
 (* FILL IN HERE *) Admitted.

Definition member (v:nat) (s:bag) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_member1: member 1 [1;4;1] = true.
 (* FILL IN HERE *) Admitted.

Example test_member2: member 2 [1;4;1] = false.
(* FILL IN HERE *) Admitted.
-/

def sum := append

example : count 1 (sum [1, 2, 3] [1, 4, 1]) = 3 := rfl

def add := cons

example : count 1 (add 1 [1, 4, 1]) = 3 := rfl

example : count 5 (add 1 [1, 4, 1]) = 0 := rfl

def member (v : ℕ) : bag → bool
| (h::t) := if eqb v h then tt else member t
| _ := ff

example : member 1 [1, 4, 1] = tt := rfl

example : member 2 [1, 4, 1] = ff := rfl

/-
Fixpoint remove_one (v:nat) (s:bag) : bag
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
  (* FILL IN HERE *) Admitted.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
  (* FILL IN HERE *) Admitted.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
  (* FILL IN HERE *) Admitted.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
  (* FILL IN HERE *) Admitted.

Fixpoint remove_all (v:nat) (s:bag) : bag
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
 (* FILL IN HERE *) Admitted.

Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
 (* FILL IN HERE *) Admitted.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
 (* FILL IN HERE *) Admitted.

Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
 (* FILL IN HERE *) Admitted.

Fixpoint subset (s1:bag) (s2:bag) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
 (* FILL IN HERE *) Admitted.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
 (* FILL IN HERE *) Admitted.
-/

def remove_one (v : ℕ) : bag → bag
| (h::t) := if eqb v h then t else h::remove_one t
| _ := nil

example : count 5 (remove_one 5 [2, 1, 5, 4, 1]) = 0 := rfl

example : count 5 (remove_one 5 [2, 1, 4, 1]) = 0 := rfl

example : count 4 (remove_one 5 [2, 1, 4, 5, 1, 4]) = 2 := rfl

example : count 5 (remove_one 5 [2, 1, 5, 4, 5, 1, 4]) = 1 := rfl

def remove_all (v : ℕ) : bag → bag
| (h::t) := if eqb v h then remove_all t else h::remove_all t
| _ := nil

example : count 5 (remove_all 5 [2, 1, 5, 4, 1]) = 0 := rfl

example : count 5 (remove_all 5 [2, 1, 4, 1]) = 0 := rfl

example : count 4 (remove_all 5 [2, 1, 4, 5, 1, 4]) = 2 := rfl

example : count 5 (remove_all 5 [2, 1, 5, 4, 5, 1, 4, 5, 1, 4]) = 0 := rfl

/- this is about the dumbest way i can think of -/
def subset : bag → bag → bool
| (h::t) b := if leb (count h (h::t)) (count h b)
              then subset t b
              else ff
| _ _ := tt

example : subset [1, 2] [2, 1, 4, 1] = tt := rfl

example : subset [1, 2, 2] [2, 1, 4, 1] = ff := rfl

/-
Theorem nil_app : ∀l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.
-/

theorem nil_append (l : natlist) : [] ++ l = l := rfl

/-
Theorem tl_length_pred : ∀l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    reflexivity. Qed.
-/

/- TODO: be consistent about core vs defined usage -/

theorem length_tail (l : natlist)
  : length (tail l) = pred (length l) :=
begin
  cases l with n l,
    refl,
  refl,
end

/-
Theorem app_assoc : ∀l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite → IHl1'. reflexivity. Qed.
-/

theorem cons_append (n : ℕ) (l₁ l₂ : natlist)
  : (n::l₁) ++ l₂ = n::(l₁ ++ l₂) := rfl

theorem append_assoc (l₁ l₂ l₃ : natlist)
  : (l₁ ++ l₂) ++ l₃ = l₁ ++ (l₂ ++ l₃) :=
begin
  induction l₁ with n l ih,
    refl,
  rw [cons_append, cons_append, cons_append],
  rw ih,
end

/-
Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil ⇒ nil
  | h :: t ⇒ rev t ++ [h]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.

Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.
-/

def reverse : natlist → natlist
| (h::t) := reverse t ++ [h]
| _ := []

example : reverse [1, 2, 3] = [3, 2, 1] := rfl

example : reverse nil = nil := rfl

/-
Theorem rev_length_firsttry : ∀l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l =  *)
    reflexivity.
  - (* l = n :: l' *)
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving ++, but we don't have any useful equations
       in either the immediate context or in the global
       environment!  We can make a little progress by using
       the IH to rewrite the goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.
-/

/-
theorem length_reverse_firsttry (l : natlist) :
  length (reverse l) = length l :=
begin
  induction l with n l ih,
    refl,
  simp,
  rw ←ih,
  /- abort -/
end
-/

/-
Theorem app_length : ∀l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite → IHl1'. reflexivity. Qed.
-/

theorem length_nil : length nil = 0 := rfl

theorem length_cons (n : ℕ) (l : natlist) : length (n::l) = length l + 1
  := rfl

theorem length_append (l₁ l₂ : natlist)
  : length (l₁ ++ l₂) = (length l₁) + (length l₂) :=
begin
  induction l₁ with n l ih,
    rw nil_append,
    rw length_nil,
    rw zero_add,
  rw cons_append,
  rw [length_cons, length_cons],
  rw ih,
  rw [add_assoc _ 1, add_comm 1, add_assoc],
end

/-
Theorem rev_length : ∀l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite → app_length, plus_comm.
    simpl. rewrite → IHl'. reflexivity. Qed.
-/

theorem length_reverse (l: natlist) : length (reverse l) = length l :=
begin
  induction l with n l ih,
    refl,
  rw reverse,
  rw length_append,
  rw [length_cons, length_cons],
  rw length_nil,
  rw ih,
end

/-
(*  Search rev. *)
-/

/-
  not great, but
  ctrl+p #
-/

#print prefix lists

/-
Theorem app_nil_r : ∀l : natlist,
  l ++ [] = l.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_app_distr: ∀l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.

Proof.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : ∀l : natlist,
  rev (rev l) = l.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem append_nil (l : natlist) : l ++ [] = l :=
begin
  induction l with n l ih,
    refl,
  rw cons_append,
  rw ih,
end

#print prefix list

theorem reverse_append (l₁ l₂ : natlist)
  : reverse (l₁ ++ l₂) = reverse l₂ ++ reverse l₁ :=
begin
  induction l₁ with n l₁ ih,
    rw nil_append,
    rw reverse,
    rw append_nil,
  rw cons_append,
  rw [reverse, reverse],
  rw ih,
  rw append_assoc,
end

theorem reverse_involutive (l : natlist) : reverse (reverse l) = l :=
begin
  induction l with n l ih,
    refl,
  rw reverse,
  rw reverse_append,
  rw ih,
  refl,
end

/-
Theorem app_assoc4 : ∀l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem append_assoc4 (l₁ l₂ l₃ l₄ : natlist)
  : l₁ ++ (l₂ ++ (l₃ ++ l₄)) = ((l₁ ++ l₂) ++ l₃) ++ l₄ :=
by rw [append_assoc, append_assoc]

/-
Lemma nonzeros_app : ∀l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  (* FILL IN HERE *) Admitted.
-/

/-
TODO: explain rwa
-/

lemma nonzeros_append (l₁ l₂ : natlist) :
  nonzeros (l₁ ++ l₂) = (nonzeros l₁) ++ (nonzeros l₂) :=
begin
  induction l₁ with n l₁ ih,
    refl,
  cases n,
    rw cons_append,
    rwa [nonzeros, nonzeros],
  rw cons_append,
  rw [nonzeros, nonzeros],
  rw ih,
  rw cons_append,
end

/-
Fixpoint eqblist (l1 l2 : natlist) : bool
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_eqblist1 :
  (eqblist nil nil = true).
 (* FILL IN HERE *) Admitted.

Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
(* FILL IN HERE *) Admitted.

Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
 (* FILL IN HERE *) Admitted.

Theorem eqblist_refl : ∀l:natlist,
  true = eqblist l l.
Proof.
  (* FILL IN HERE *) Admitted.
-/

def eqblist : natlist → natlist → bool
| nil nil := tt
| (h₁::t₁) (h₂::t₂) := if eqb h₁ h₂
                       then eqblist t₁ t₂
                       else ff
| _ _ := ff

example : eqblist nil nil := rfl

example : eqblist [1, 2, 3] [1, 2, 3] := rfl

example : eqblist [1, 2, 3] [1, 2, 4] = ff := rfl

lemma eqb_refl (l : ℕ) : eqb l l = tt :=
begin
  induction l with h l ih,
    refl,
  rwa eqb,
end

theorem eqblist_refl (l : natlist) : eqblist l l = tt :=
begin
  induction l with n l ih,
    refl,
  rw eqblist,
  rw eqb_refl,
  rw ih,
  refl,
end

/-
Theorem count_member_nonzero : ∀(s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem count_member_nonzero (s : bag) : 1 ≤? (count 1 (1 :: s)) = tt :=
begin
  induction s with n s ih,
    refl,
  refl,
end

/-
Theorem leb_n_Sn : ∀n,
  n <=? (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity. Qed.
-/

theorem leb_succ (n : ℕ) : n ≤? succ n = tt :=
begin
  induction n with n ih,
    refl,
  rwa leb,
end

/-
Theorem remove_does_not_increase_count: ∀(s : bag),
  (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem count_remove_leb_count (s : bag)
  : count 0 (remove_one 0 s) ≤? count 0 s = tt :=
begin
  induction s with h t ih,
    refl,
  cases h,
    rw remove_one,
    rw count,
    rw [function.comp_app, function.comp_app],
    rw filter,
    rw eqb,
    rw [if_pos rfl, if_pos rfl],
    rw length,
    rw leb_succ,
  /- not really sure why this works -/
  exact ih,
end

/-
∀(l1 l2 : natlist), rev l1 = rev l2 → l1 = l2.
-/

/-
TODO: revisit hard way as these tactics shouldn't be known yet
-/

lemma eq_append_nil_false
  (h : ℕ) (t : natlist) (c : t ++ [h] = nil) : false :=
begin
  have : length (t ++ [h]) = length (nil),
    exact congr_arg length c,
  rw length_append at this,
  rw length at this,
  rw length_nil at this,
  contradiction,
end

lemma eq_nil_append_false
  (h : ℕ) (t : natlist) (c : nil = t ++ [h]) : false :=
eq_append_nil_false h t (eq.symm c)

theorem snoc_injective' {h₁ h₂ : ℕ} : ∀ t₁ t₂ : natlist,
  t₁ ++ [h₁] = t₂ ++ [h₂] → h₁ = h₂ ∧ t₁ = t₂
| nil nil :=
begin
  intro h,
  injection h with hl hr,
  exact ⟨hl, hr⟩,
end
| (h₁'::t₁) nil :=
begin
  intro h,
  injection h with hl hr,
  exfalso,
  exact eq_append_nil_false _ _ hr,
end
| nil (h₂'::t₂) :=
begin
  intro h,
  injection h with hl hr,
  exfalso,
  exact eq_nil_append_false _ _ hr,
end
| (h₁'::t₁) (h₂'::t₂) :=
begin
  intro h,
  injection h with hl hr,
  have : h₁ = h₂ ∧ t₁ = t₂,
    exact snoc_injective' t₁ t₂ hr,
  split,
    rw this.left,
  rw [hl, this.right],
end

theorem reverse_injective_hard' :
  ∀ l₁ l₂ : natlist, reverse l₁ = reverse l₂ → l₁ = l₂
| nil nil :=
begin
  intro h,
  refl,
end
| nil (h₂::t₂) :=
begin
  intro h,
  rw [reverse, reverse] at h,
  exfalso,
  exact eq_nil_append_false _ _ h,
end
| (h₁::t₁) nil :=
begin
  intro h,
  rw [reverse, reverse] at h,
  exfalso,
  exact eq_append_nil_false _ _ h,
end
| (h₁::t₁) (h₂::t₂) :=
begin
  simp,
  intro h,
  have : h₁ = h₂ ∧ reverse t₁ = reverse t₂,
    exact snoc_injective' (reverse t₁) (reverse t₂) h,
  exact ⟨this.left, reverse_injective_hard' t₁ t₂ this.right⟩,
end

/-
without computation engine
-/
theorem snoc_injective {h₁ h₂ : ℕ} : ∀ t₁ t₂ : natlist,
  t₁ ++ [h₁] = t₂ ++ [h₂] → h₁ = h₂ ∧ t₁ = t₂ :=
begin
  intro t₁,
  induction t₁ with h₁' t₁ ih,
    rintro (_ | ⟨h₂', t₂⟩) h,
      injection h with hl hr,
      exact ⟨hl, hr⟩,
    injection h with hl hr,
    exfalso,
    exact eq_nil_append_false _ _ hr,
  rintro (_ | ⟨h₂', t₂⟩) h,
    injection h with hl hr,
    exfalso,
    exact eq_append_nil_false _ _ hr,
  injection h with hl hr,
  have : h₁ = h₂ ∧ t₁ = t₂,
    exact ih t₂ hr,
  split,
    exact this.left,
  rw [hl, this.right],
end

theorem reverse_injective_hard :
  ∀ l₁ l₂ : natlist, reverse l₁ = reverse l₂ → l₁ = l₂ :=
begin
  intro l₁,
  induction l₁ with h₁ t₁ ih,
    rintro (_ | ⟨h₂, t₂⟩) h,
      refl,
    rw [reverse, reverse] at h,
    exfalso,
    exact eq_nil_append_false _ _ h,
  rintro (_ | ⟨h₂, t₂⟩) h,
    rw [reverse, reverse] at h,
    exfalso,
    exact eq_append_nil_false _ _ h,
  rw [reverse, reverse] at h,
  have : h₁ = h₂ ∧ reverse t₁ = reverse t₂,
    exact snoc_injective (reverse t₁) (reverse t₂) h,
  rw this.left,
  have, exact ih _ this.right,
  rw this,
end

/-
now, for the easy way
-/

theorem reverse_injective
  (l₁ l₂ : natlist) (h : reverse l₁ = reverse l₂) : l₁ = l₂ :=
begin
  rw ←reverse_involutive l₁,
  rw ←reverse_involutive l₂,
  rw h,
end

/-
Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil ⇒ 42 (* arbitrary! *)
  | a :: l' ⇒ match n =? O with
               | true ⇒ a
               | false ⇒ nth_bad l' (pred n)
               end
  end.
-/

def nth_bad : natlist → ℕ → ℕ
| nil _ := 42
| (h::_) 0 := h
| (_::t) (n + 1) := nth_bad t n

/-
Inductive natoption : Type :=
  | Some (n : nat)
  | None.
-/

inductive natoption : Type
| some (n : ℕ)
| none

open natoption

/-
Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil ⇒ None
  | a :: l' ⇒ match n =? O with
               | true ⇒ Some a
               | false ⇒ nth_error l' (pred n)
               end
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.

Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.

Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
-/

@[simp]
def nth_error : natlist → ℕ → natoption
| nil _ := none
| (h::_) 0 := some h
| (_::t) (n + 1) := nth_error t n

example : nth_error [4, 5, 6, 7] 0 = some 4 := rfl

example : nth_error [4, 5, 6, 7] 3 = some 7 := rfl

example : nth_error [4, 5, 6, 7] 9 = none := rfl

/-
Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil ⇒ None
  | a :: l' ⇒ if n =? O then Some a
               else nth_error' l' (pred n)
  end.
-/

/-
yeah, we've been using ite already...
-/
def nth_error' : natlist → ℕ → natoption
| nil := λ _, none
| (h::t) := λ n, if n =? 0 then some h
                 else nth_error' t (pred n)

/-
Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' ⇒ n'
  | None ⇒ d
  end.
-/

def option_elim (d : ℕ) : natoption → ℕ
| (some n) := n
| _ := d

/-
Definition hd_error (l : natlist) : natoption
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_hd_error1 : hd_error [] = None.
 (* FILL IN HERE *) Admitted.

Example test_hd_error2 : hd_error [1] = Some 1.
 (* FILL IN HERE *) Admitted.

Example test_hd_error3 : hd_error [5;6] = Some 5.
 (* FILL IN HERE *) Admitted.
-/

def head_error : natlist → natoption
| nil := none
| (h::_) := some h

example : head_error [] = none := rfl

example : head_error [1] = some 1 := rfl

example : head_error [5, 6] = some 5 := rfl

/-
Theorem option_elim_hd : ∀(l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem option_elim_head (l : natlist) (default : ℕ)
  : head default l = option_elim default (head_error l) :=
begin
  cases l with n l,
    refl,
  refl,
end

/-
Inductive id : Type :=
  | Id (n : nat).
-/

/-
TODO: investigate error with using sf casing
-/
inductive Id : Type
| id (n : ℕ)

open Id

/-
Definition eqb_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 ⇒ n1 =? n2
  end.
-/

def eqb_id : Id → Id → bool
| (id n₁) (id n₂) := n₁ =? n₂

/-
Theorem eqb_id_refl : ∀x, true = eqb_id x x.
Proof.
  (* FILL IN HERE *) Admitted.
-/

theorem eqb_id_refl (x : Id) : eqb_id x x = tt :=
begin
  cases x,
  rw eqb_id,
  rw eqb_refl,
end

/-
Inductive partial_map : Type :=
  | empty
  | record (i : id) (v : nat) (m : partial_map).
-/

inductive partial_map : Type
| empty
| record (i : Id) (v : ℕ) (m : partial_map)

open partial_map

/-
Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.
-/

def update (d : partial_map) (x : Id) (value : ℕ)
  : partial_map := record x value d

/-
Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty ⇒ None
  | record y v d' ⇒ if eqb_id x y
                     then Some v
                     else find x d'
  end.
-/

def find (x : Id) : partial_map → natoption
| empty := none
| (record y v d) := if eqb_id x y
                    then some v
                    else find d

/-
Theorem update_eq :
  ∀(d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
 (* FILL IN HERE *) Admitted.
-/

theorem update_eq (d : partial_map) (x : Id) (v : ℕ) :
  find x (update d x v) = some v :=
begin
  rw update,
  rw find,
  rw eqb_id_refl,
  refl,
end

/-
Theorem update_neq :
  ∀(d : partial_map) (x y : id) (o: nat),
    eqb_id x y = false → find x (update d y o) = find x d.
Proof.
 (* FILL IN HERE *) Admitted.
-/

theorem update_neq
  (d : partial_map) (x y : Id) (o : ℕ) (h : eqb_id x y = ff) :
  find x (update d y o) = find x d :=
begin
  rw update,
  rw find,
  rw h,
  refl,
end

/-
Inductive baz : Type :=
  | Baz1 (x : baz)
  | Baz2 (y : baz) (b : bool).
-/

/- you can write it, but can't make any -/
inductive baz : Type
| Baz1 (x : baz)
| Baz2 (y : baz) (b : bool)

end lists


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

import tactic
import data.set.basic

/-!
# Young diagrams

A Young diagram is a finite set of up-left justified boxes:

[5, 3, 3, 1]
□□□□□
□□□
□□□
□

Equivalently, a lower set in ℕ × ℕ in the product partial order.

## Main functions:

  - basic properties and definitions involving shape, size, row and column
    lengths, and corners of a Young diagram

  - various constructors:
      [young_diagram.has_empty]
      [young_diagram.of_row_lens]
      [young_diagram.outer_corner.add]
      [young_diagram.inner_corner.del]

  - TODO: young_diagram ≃ { l : list ℕ // l.sorted (≤) }

## Tags

Young diagram

## References

<https://en.wikipedia.org/wiki/Young_tableau>

-/

section young_diagram

@[ext]
structure young_diagram :=
  (cells : finset (ℕ × ℕ))
  (nw_of' : ∀ {i1 i2 j1 j2 : ℕ},
    i1 ≤ i2 → j1 ≤ j2 → (i2, j2) ∈ cells → (i1, j1) ∈ cells)

instance young_diagram.has_mem : has_mem (ℕ × ℕ) young_diagram :=
{ mem := λ c μ, c ∈ μ.cells, }

@[simp]
lemma young_diagram.mem_cells (μ : young_diagram) (c : ℕ × ℕ) :
  c ∈ μ.cells ↔ c ∈ μ := iff.rfl

def young_diagram.nw_of (μ : young_diagram)
  {i1 i2 j1 j2 : ℕ} (hi : i1 ≤ i2) (hj : j1 ≤ j2) (hcell : (i2, j2) ∈ μ) :
  (i1, j1) ∈ μ := μ.nw_of' hi hj hcell

instance young_diagram.has_subset : has_subset young_diagram :=
{ subset := λ μ ν, μ.cells ⊆ ν.cells }

def young_diagram.size (μ : young_diagram) := μ.cells.card
def young_diagram.row (μ : young_diagram) (i : ℕ) := μ.cells.filter (λ c, c.fst = i)
def young_diagram.col (μ : young_diagram) (j : ℕ) := μ.cells.filter (λ c, c.snd = j)

lemma young_diagram.row_def (μ : young_diagram) {i : ℕ} :
  μ.row i = μ.cells.filter (λ c, c.fst = i) := rfl
lemma young_diagram.col_def (μ : young_diagram) {j : ℕ} :
  μ.col j = μ.cells.filter (λ c, c.snd = j) := rfl

lemma young_diagram.mem_row_iff (μ : young_diagram) {i : ℕ} (c : ℕ × ℕ) :
  c ∈ μ.row i ↔ c ∈ μ ∧ c.fst = i :=
by {rw [young_diagram.row_def, finset.mem_filter], refl}
lemma young_diagram.mem_col_iff (μ : young_diagram) {j : ℕ} (c : ℕ × ℕ) :
  c ∈ μ.col j ↔ c ∈ μ ∧ c.snd = j :=
by {rw [young_diagram.col_def, finset.mem_filter], refl}

lemma young_diagram.mem_iff_mem_row (μ : young_diagram) {i j : ℕ} :
  (i, j) ∈ μ ↔ (i, j) ∈ μ.row i :=
by rw [young_diagram.mem_row_iff, and_iff_left rfl]
lemma young_diagram.mem_iff_mem_col (μ : young_diagram) {i j : ℕ} :
  (i, j) ∈ μ ↔ (i, j) ∈ μ.col j :=
by rw [young_diagram.mem_col_iff, and_iff_left rfl]

lemma young_diagram.row_len_aux (μ : young_diagram) (i : ℕ) : ∃ j, (i, j) ∉ μ :=
begin
  obtain ⟨j, hj⟩ := infinite.exists_not_mem_finset ((μ.row i).image prod.snd),
  use j, intro hij, apply hj,
  rw finset.mem_image, rw μ.mem_iff_mem_row at hij,
  exact ⟨_, hij, rfl⟩,
end
lemma young_diagram.col_len_aux (μ : young_diagram) (j : ℕ) : ∃ i, (i, j) ∉ μ :=
begin
  obtain ⟨i, hi⟩ := infinite.exists_not_mem_finset ((μ.col j).image prod.fst),
  use i, intro hij, apply hi,
  rw finset.mem_image, rw μ.mem_iff_mem_col at hij,
  exact ⟨_, hij, rfl⟩,
end

def young_diagram.row_len (μ : young_diagram) (i : ℕ) : ℕ :=
  nat.find $ μ.row_len_aux i
def young_diagram.col_len (μ : young_diagram) (j : ℕ) : ℕ :=
  nat.find $ μ.col_len_aux j
def young_diagram.row_lens (μ : young_diagram) : list ℕ :=
  list.map μ.row_len (list.range $ μ.col_len 0)
def young_diagram.col_lens (μ : young_diagram) : list ℕ :=
  list.map μ.col_len (list.range $ μ.row_len 0)

lemma young_diagram.row_len_def (μ : young_diagram) {i : ℕ} :
  μ.row_len i = nat.find (μ.row_len_aux i) := rfl
lemma young_diagram.col_len_def (μ : young_diagram) {j : ℕ} :
  μ.col_len j = nat.find (μ.col_len_aux j) := rfl

lemma young_diagram.mem_row_iff' (μ : young_diagram) {i j : ℕ} :
  (i, j) ∈ μ ↔ j < μ.row_len i :=
begin
  rw [μ.row_len_def, nat.lt_find_iff], push_neg,
  split; intro h,
  exact λ m hmj, μ.nw_of (le_refl i) hmj h,
  exact h _ (le_refl _),
end
lemma young_diagram.mem_col_iff' (μ : young_diagram) {i j : ℕ} :
  (i, j) ∈ μ ↔ i < μ.col_len j :=
begin
  rw [μ.col_len_def, nat.lt_find_iff], push_neg,
  split; intro h,
  exact λ m hmj, μ.nw_of hmj (le_refl j) h,
  exact h _ (le_refl _),
end

lemma young_diagram.row_eq_prod_range (μ : young_diagram) {i : ℕ} :
  μ.row i = finset.product {i} (finset.range $ μ.row_len i) :=
begin
  ext ⟨a, b⟩,
  rw [finset.mem_product, finset.mem_singleton, finset.mem_range,
      μ.mem_row_iff, μ.mem_row_iff',
      and_comm, and.congr_right_iff],
  rintro rfl, refl,
end
lemma young_diagram.col_eq_prod_range (μ : young_diagram) {j : ℕ} :
  μ.col j = finset.product (finset.range $ μ.col_len j) {j} :=
begin
  ext ⟨a, b⟩,
  rw [finset.mem_product, finset.mem_singleton, finset.mem_range,
      μ.mem_col_iff, μ.mem_col_iff', and.congr_left_iff],
  rintro rfl, refl,
end

lemma young_diagram.row_len_eq_card (μ : young_diagram) {i : ℕ} :
  μ.row_len i = (μ.row i).card :=
begin
  rw μ.row_eq_prod_range,
  rw [finset.card_product, finset.card_singleton, finset.card_range, one_mul],
end
lemma young_diagram.col_len_eq_card (μ : young_diagram) {j: ℕ} :
  μ.col_len j = (μ.col j).card :=
begin
  rw μ.col_eq_prod_range,
  rw [finset.card_product, finset.card_singleton, finset.card_range, mul_one],
end

lemma young_diagram.row_len_decr (μ : young_diagram) {i1 i2 : ℕ} (hi : i1 ≤ i2) :
  μ.row_len i2 ≤ μ.row_len i1 :=
begin
  by_contra h_lt, push_neg at h_lt,
  have := μ.nw_of hi (le_refl _),
  rw [μ.mem_row_iff', μ.mem_row_iff'] at this,
  exact (lt_self_iff_false _).mp (this h_lt),
end

lemma young_diagram.col_len_decr (μ : young_diagram) {j1 j2 : ℕ} (hj : j1 ≤ j2) :
  μ.col_len j2 ≤ μ.col_len j1 :=
begin
  by_contra h_lt, push_neg at h_lt,
  have := μ.nw_of (le_refl _) hj,
  rw [μ.mem_col_iff', μ.mem_col_iff'] at this,
  exact (lt_self_iff_false _).mp (this h_lt),
end

section μ_empty

instance young_diagram.has_emptyc : has_emptyc young_diagram :=
{ emptyc := { cells := finset.empty, nw_of' := λ _ _ _ _ _ _ h, h, } }

@[simp] lemma μ_empty_size : (∅ : young_diagram).size = 0 := rfl

end μ_empty

section of_row_lens

def list_decr : list ℕ → Prop
| [] := true
| [x] := true
| (x :: y :: xs) := y ≤ x ∧ list_decr (y :: xs)

lemma list_decr_iff :
  Π {w : list ℕ},
  list_decr w ↔ ∀ n n', n ≤ n' → w.inth n' ≤ w.inth n
| [] := begin  apply (true_iff _).mpr, exact λ _ _ _, le_refl 0, end
| [x] := begin apply (true_iff _).mpr, intros n n' h,
               cases n', rw nat.le_zero_iff.mp h, exact nat.zero_le _, end
| (x :: y :: xs) := begin
  unfold list_decr, rw list_decr_iff, dsimp only [list.inth],
  split,
  { rintros ⟨h, h'⟩ n n' hn,
    cases n', rw nat.le_zero_iff at hn, subst n,
    cases n, --change ((y :: xs).nth _).iget ≤ x,
    exact (h' 0 n' (nat.zero_le _)).trans h,
    apply h', exact nat.succ_le_succ_iff.mp hn, },
  { intro h', split,
    exact h' 0 1 (nat.zero_le _),
    intros n n' hn,
    exact h' n.succ n'.succ (nat.succ_le_succ hn), },
end

def young_diagram.cells_of_row_lens (w : list ℕ) : finset (ℕ × ℕ) :=
  finset.bUnion
    (finset.range w.length)
    (λ i, ({i} : finset ℕ).product (finset.range $ w.inth i))

lemma young_diagram.mem_of_row_lens (w : list ℕ) (c : ℕ × ℕ):
  c ∈ young_diagram.cells_of_row_lens w ↔ c.snd < w.inth c.fst :=
begin
  unfold young_diagram.cells_of_row_lens,
  rw finset.mem_bUnion, dsimp only [list.inth],
  split; intro h,
  { obtain ⟨a, h, h'⟩ := h,
    rw finset.mem_product at h',
    obtain ⟨hc1, hc2⟩ := h',
    rw ← finset.eq_of_mem_singleton hc1 at hc2,
    exact finset.mem_range.mp hc2, },
  { use c.fst,
    have : c.fst < w.length,
    { by_contra h', push_neg at h',
      apply nat.not_lt_zero c.snd, convert h,
      rw list.nth_eq_none_iff.mpr h', refl, },
    exact ⟨finset.mem_range.mpr this,
           finset.mem_product.mpr
             ⟨finset.mem_singleton_self _, finset.mem_range.mpr h⟩⟩, },
end

def young_diagram.of_row_lens (r : list ℕ) (h : list_decr r) : young_diagram :=
{ cells := young_diagram.cells_of_row_lens r,
  nw_of' := λ i1 i2 j1 j2 hi hj hcell, begin
    rw young_diagram.mem_of_row_lens at *,
    change j1 < r.inth i1, change j2 < r.inth i2 at hcell,
    apply lt_of_le_of_lt hj,
    apply lt_of_lt_of_le hcell,
    apply list_decr_iff.mp h, exact hi,
  end,}

@[simp] lemma young_diagram.of_row_lens.mem (w : list ℕ) (h : list_decr w)
  {c : ℕ × ℕ} :
  c ∈ young_diagram.of_row_lens w h ↔ c.snd < w.inth c.fst :=
young_diagram.mem_of_row_lens w c

lemma young_diagram.list_decr_of_row_lens (μ : young_diagram) :
  list_decr μ.row_lens :=
begin
  rw list_decr_iff,
  intros n n' hn,
  rw young_diagram.row_lens, simp only [list.inth, list.nth_map],
  by_cases n' < μ.col_len 0,
  { rw list.nth_range h, rw list.nth_range (lt_of_le_of_lt hn h),
    simp only [option.map_some', option.iget_some],
    apply μ.row_len_decr hn },
  { push_neg at h,
    rw [list.nth_eq_none_iff.mpr, option.map_none'],
    apply nat.zero_le,
    rwa list.length_range }
end

end of_row_lens

section repr

def young_diagram.repr (μ : young_diagram) : string := μ.row_lens.to_string
def young_diagram.repr' (μ : young_diagram) : string :=
  string.intercalate "\n" $
    μ.repr :: (list.map (λ i, string.join $ list.repeat "□" i) μ.row_lens)
instance young_diagram.has_repr : has_repr young_diagram :=
{ repr := young_diagram.repr' }

end repr

section corners

structure young_diagram.inner_corner (μ : young_diagram) :=
  (i j : ℕ)
  (cell : (i, j) ∈ μ)
  (cell_right : ∀ {j'}, j < j' → (i, j') ∉ μ)
  (cell_down : ∀ {i'}, i < i' → (i', j) ∉ μ)

structure young_diagram.outer_corner (μ : young_diagram) :=
  (i j : ℕ)
  (not_cell : (i, j) ∉ μ)
  (cell_left : ∀ {j'}, j' < j → (i, j') ∈ μ)
  (cell_up : ∀ {i'}, i' < i → (i', j) ∈ μ)

instance young_diagram.dec_cell_right (μ : young_diagram)
  (i j : ℕ) : decidable (∀ {j'}, j < j' → (i, j') ∉ μ) :=
if hj : j.succ < μ.row_len i
then is_false $ λ h', h' (lt_add_one j) (μ.mem_row_iff'.mpr hj)
else is_true $ λ j' h' hcell, hj (μ.mem_row_iff'.mp $ μ.nw_of (le_refl _) h' hcell)

instance young_diagram.dec_cell_down (μ : young_diagram)
  (i j : ℕ) : decidable (∀ {i'}, i < i' → (i', j) ∉ μ) :=
if hi : i.succ < μ.col_len j
then is_false $ λ h', h' (lt_add_one i) (μ.mem_col_iff'.mpr hi)
else is_true $ λ j' h' hcell, hi (μ.mem_col_iff'.mp $ μ.nw_of h' (le_refl _) hcell)

-- presumably easier because they only involve finitely-many values of j'
instance young_diagram.dec_cell_left (μ : young_diagram)
  (i j : ℕ) : decidable (∀ {j'}, j' < j → (i, j') ∈ μ) := by apply_instance
instance young_diagram.dec_cell_up (μ : young_diagram)
  (i j : ℕ) : decidable (∀ {i'}, i' < i → (i', j) ∈ μ) := by apply_instance

def young_diagram.inner_corner.del {μ : young_diagram} (c : μ.inner_corner) :
young_diagram :=
{ cells := μ.cells.erase (c.i, c.j),
  nw_of' := λ i1 i2 j1 j2 hi hj hcell, begin
    rw finset.mem_erase at *,
    split,
    intro h, cases h, clear h,
    cases lt_or_eq_of_le hi,
      exact c.cell_down h (μ.nw_of (le_refl _) hj hcell.2),
    cases lt_or_eq_of_le hj,
      exact c.cell_right h_1 (μ.nw_of hi (le_refl _) hcell.2),
    apply hcell.1, subst i2, subst j2,
    exact μ.nw_of hi hj hcell.2,
  end
}

lemma young_diagram.inner_corner.del_def
  {μ : young_diagram} (c : μ.inner_corner) :
c.del.cells = μ.cells.erase (c.i, c.j) := rfl

@[simp] lemma young_diagram.inner_corner.mem_del
  {μ : young_diagram} (c : μ.inner_corner) {i j : ℕ} :
(i, j) ∈ c.del ↔ (i, j) ≠ (c.i, c.j) ∧ (i, j) ∈ μ := finset.mem_erase

lemma young_diagram.inner_corner.del_size
  {μ : young_diagram} (c : μ.inner_corner) :
  c.del.size + 1 = μ.size := finset.card_erase_add_one c.cell

def young_diagram.outer_corner.add {μ : young_diagram} (c : μ.outer_corner) :
young_diagram :=
{ cells := insert (c.i, c.j) μ.cells,
  nw_of' := λ i1 i2 j1 j2 hi hj hcell, begin
    rw finset.mem_insert at *,
    cases hcell,
    cases hcell,
    cases lt_or_eq_of_le hi,
      right, exact μ.nw_of (le_refl _) hj (c.cell_up h),
    cases lt_or_eq_of_le hj,
      right, exact μ.nw_of hi (le_refl _) (c.cell_left h_1),
    left, subst i1, subst j1,
    exact or.inr (μ.nw_of hi hj hcell),
  end
}

lemma young_diagram.outer_corner.add_def
  {μ : young_diagram} (c : μ.outer_corner) :
c.add.cells = insert (c.i, c.j) μ.cells := rfl

@[simp] lemma young_diagram.outer_corner.mem_add
  {μ : young_diagram} (c : μ.outer_corner) {i j : ℕ} :
(i, j) ∈ c.add ↔ (i, j) = (c.i, c.j) ∨ (i, j) ∈ μ := finset.mem_insert

lemma young_diagram.outer_corner.add_size
  {μ : young_diagram} (c : μ.outer_corner) :
  c.add.size = μ.size + 1 := finset.card_insert_of_not_mem c.not_cell

def young_diagram.inner_corner.to_outer
  {μ : young_diagram} (c : μ.inner_corner) : c.del.outer_corner :=
{ i := c.i,
  j := c.j,
  not_cell := begin
    rw young_diagram.inner_corner.mem_del,
    rw not_and', push_neg, exact λ _, rfl,
  end,
  cell_left := λ j' hj, begin
    rw young_diagram.inner_corner.mem_del,
    split, exact λ h, ne_of_lt hj (prod.ext_iff.mp h).2,
    exact μ.nw_of (le_refl _) (le_of_lt hj) c.cell,
  end,
  cell_up := λ i' hi, begin
    rw young_diagram.inner_corner.mem_del,
    split, exact λ h, ne_of_lt hi (prod.ext_iff.mp h).1,
    exact μ.nw_of (le_of_lt hi) (le_refl _) c.cell,
  end,
}

def young_diagram.outer_corner.to_inner
  {μ : young_diagram} (c : μ.outer_corner) : c.add.inner_corner :=
{ i := c.i,
  j := c.j,
  cell := begin
    rw young_diagram.outer_corner.mem_add,
    left, refl,
  end,
  cell_right := λ j' hj, begin
    rw young_diagram.outer_corner.mem_add, intro h,
    cases h, exact (ne_of_lt hj).symm (prod.ext_iff.mp h).2,
    exact c.not_cell (μ.nw_of (le_refl _) (le_of_lt hj) h),
  end,
  cell_down := λ i' hi, begin
    rw young_diagram.outer_corner.mem_add, intro h,
    cases h, exact (ne_of_lt hi).symm (prod.ext_iff.mp h).1,
    exact c.not_cell (μ.nw_of (le_of_lt hi) (le_refl _) h),
  end,
}

@[simp] lemma young_diagram.outer_inner {μ : young_diagram} (c : μ.inner_corner) :
  c.to_outer.add = μ :=
begin
  ext ⟨i, j⟩,
  rw [c.to_outer.add.mem_cells, μ.mem_cells, c.to_outer.mem_add, c.mem_del],
  change (i, j) = (c.i, c.j) ∨ _ ↔ _,
  by_cases (i, j) = (c.i, c.j),
    rw [h, eq_self_iff_true, true_or, true_iff],
    exact c.cell,
  rw [or_iff_right h, and_iff_right h],
end

@[simp] lemma young_diagram.inner_outer {μ : young_diagram} (c : μ.outer_corner) :
  c.to_inner.del = μ :=
begin
  ext ⟨i, j⟩,
  rw [c.to_inner.del.mem_cells, μ.mem_cells, c.to_inner.mem_del, c.mem_add],
  change (i, j) ≠ (c.i, c.j) ∧ _ ↔ _,
  by_cases (i, j) = (c.i, c.j),
    rw [h, ← (false_iff _).mpr c.not_cell, iff_false],
    push_neg, exact λ h, false.rec _ (h rfl),
  rw [and_iff_right h, or_iff_right h],
end

end corners

section examples

@[simp]
def μ5331 : young_diagram :=
  young_diagram.of_row_lens [5, 3, 3, 1] (by {unfold list_decr, dec_trivial})

def μ5331.corner2 : μ5331.inner_corner :=
{ i := 2,
  j := 2,
  cell := dec_trivial,
  cell_right :=
  -- begin
  --   have : (2 : ℕ).succ < μ5331.row_len 2,
  --     rw young_diagram.row_len_eq_card,
  --     -- dec_trivial,
  --     sorry,
  --   sorry,
  -- end,
  λ j', begin
    contrapose!, dsimp only [μ5331], rw young_diagram.of_row_lens.mem,
    exact λ h, nat.lt_succ_iff.mp h,
  end,
  cell_down := λ i', begin
    dsimp only [μ5331], rw [young_diagram.of_row_lens.mem, list.inth],
    contrapose!, intro h,

    -- beginning of μ
    repeat { cases i', dec_trivial, simp only [list.nth] at h, },
    -- rest of μ
    exfalso, apply not_le_of_lt h, clear h,
    repeat { cases i', dec_trivial, simp only [list.nth], },
    -- empty list
    exact nat.zero_le _,
  end, }

def μ5331.corner3 : μ5331.outer_corner :=
{ i := 1,
  j := 3,
  not_cell := dec_trivial,
  cell_left := dec_trivial,
  -- λ j', begin
  --   contrapose!, dsimp, rw young_diagram.of_row_lens.mem,
  --   push_neg, exact id,
  -- end,
  cell_up := dec_trivial,
  -- λ i', begin
  --   dsimp, rw [young_diagram.of_row_lens.mem, list.inth],
  --   intro h, rw nat.lt_succ_iff at h,
  --   -- beginning of μ
  --   repeat { cases i', dec_trivial,
  --            simp only [list.nth],
  --            repeat { rw nat.succ_le_succ_iff at h },},
  --   -- empty list
  --   exfalso, apply nat.not_succ_le_zero _ h,
  -- end,
}

#eval μ5331

#eval μ5331.corner2.del

#eval μ5331.corner3.add

-- lemma list.inth_of_repeat {α : Type} [inhabited α]
--   (a : α) {n i : ℕ} (h : i < n) :
--   (list.repeat a n).inth i = a :=
-- begin
--   induction n with n ih_n generalizing i,
--   exfalso, exact not_le_of_lt h (zero_le _),
--   cases i, refl,
--   exact ih_n (nat.succ_lt_succ_iff.mp h),
-- end

-- lemma list.inth_of_repeat_ge_length {α : Type} [inhabited α]
--   (a : α) {n i : ℕ} (h : n ≤ i) :
--   (list.repeat a n).inth i = default :=
-- begin
--   induction n with n ih_n generalizing i,
--   refl, cases i,
--   exfalso, exact not_lt_of_le h (nat.succ_pos _),
--   exact ih_n (nat.succ_le_succ_iff.mp h),
-- end

-- def rectangle_shape (m n : ℕ) : young_diagram :=
--   young_diagram.of_row_lens (list.repeat m n)
-- begin
--   rw list_decr_iff,
--   intros i j hij,
--   cases lt_or_ge j n,
--   rw [list.inth_of_repeat _ h,
--       list.inth_of_repeat _ (hij.trans_lt h)],
--   rw list.inth_of_repeat_ge_length _ h,
--   exact nat.zero_le _,
-- end

def rectangle_shape (m n : ℕ) : young_diagram :=
{ cells := (finset.range m).product (finset.range n),
  nw_of' := λ i1 i2 j1 j2 hi hj h_cell,
  begin
    simp only [finset.mem_range, finset.mem_product] at ⊢ h_cell,
    exact ⟨hi.trans_lt h_cell.1, hj.trans_lt h_cell.2⟩,
  end, }

lemma rectangle_shape.cells_def {m n : ℕ} :
  (rectangle_shape m n).cells =
  (finset.range m).product (finset.range n) := rfl

lemma rectangle_shape.mem_iff {m n : ℕ} (i j : ℕ) :
  (i, j) ∈ rectangle_shape m n ↔ i < m ∧ j < n :=
begin
  change (i, j) ∈ finset.product _ _ ↔ _, simp,
end

lemma rectangle_shape.row_len {m n : ℕ} {r : ℕ} :
  (rectangle_shape m n).row_len r = ite (r < m) n 0 :=
begin
  simp_rw [young_diagram.row_len_def, nat.find_eq_iff,
           rectangle_shape.mem_iff],
  split; push_neg,
  { intro h, rw if_pos h, },
  { intros i hi,
    split_ifs at hi,
    exact ⟨h, hi⟩, exact false.rec _ (i.not_lt_zero hi), },
end

lemma rectangle_shape.col_len {m n : ℕ} (c : ℕ) :
  (rectangle_shape m n).col_len c = ite (c < n) m 0 :=
begin
  simp_rw [young_diagram.col_len_def, nat.find_eq_iff,
           rectangle_shape.mem_iff],
  split,
  { rw not_and', intro h, rw if_pos h, simp, },
  { intros i hi, push_neg,
    split_ifs at hi,
    exact ⟨hi, h⟩, exact false.rec _ (i.not_lt_zero hi), },
end

lemma rectangle_shape.row_lens {m n : ℕ} (hn : 0 < n) :
  (rectangle_shape m n).row_lens = list.repeat n m :=
begin
  change list.map _ _ = _,
  rw [rectangle_shape.col_len, if_pos hn],
  apply list.ext, intro r,
  cases le_or_gt m r,
  { repeat {rw list.nth_eq_none_iff.mpr},
    rw list.length_repeat, exact h,
    rw [list.length_map, list.length_range], exact h, },
  rw [list.nth_map, list.nth_range h, option.map_some',
      rectangle_shape.row_len, if_pos h, list.nth_eq_some.mpr],
  simp_rw list.length_repeat, use h,
  rw list.nth_le_repeat,
end

end examples

end young_diagram


/-
Copyright (c) 2020 Utensil Song. All rights reserved.
Released under MIT license as described in the file LICENSE.
Authors: Utensil Song, Eric Wieser

This file is based on https://arxiv.org/abs/1205.5935
-/
import algebra.hom.group
import algebra.algebra.basic
import data.real.basic
import data.complex.basic

import tactic.apply_fun
import tactic

universes u u₀ u₁

/- Needed for zero_pairwise_ortho_vector -/
-- lemma pairwise_of_repeat {X : Type*} {x : X} {n : ℕ} {r : X → X → Prop} (hr : r x x) :
--   list.pairwise r (list.repeat x n) :=
-- begin
--   induction n with d hd,
--   { exact list.pairwise.nil},
--   { apply list.pairwise.cons _ hd,
--     intros a ha,
--     convert hr,
--     exact list.eq_of_mem_repeat ha,
--   }
-- end

class geometric_algebra
-- Axiom 2: G contains a field G0 of characteristic zero which includes 0 and 1.
(G₀ : Type*) [field G₀]
-- Axiom 3: G contains a subset G1 closed under addition,
-- and λ ∈ G0, v ∈ G1 implies λv = vλ ∈ G1.
(G₁ : Type*) [add_comm_group G₁] [module G₀ G₁]
-- Axiom 1: G is a ring with unit.
-- The additive identity is called 0 and the multiplicative identity is called 1.
(G : Type*) [ring G]
[algebra G₀ G]
:=
(f₁ : G₁ →+ G)
-- Axiom 4: The square of every vector is a scalar.
-- TODO clearly this should be nameed following "contraction rule", I'm thinking maybe `contract`?
(vec_sq_scalar : ∀ v : G₁, ∃ k : G₀, f₁ v * f₁ v = algebra_map _ _ k )

namespace geometric_algebra

section basic

parameters
{G₀ : Type u} [field G₀]
{G₁ : Type u} [add_comm_group G₁] [module G₀ G₁]
{G : Type u} [ring G] [algebra G₀ G] [geometric_algebra G₀ G₁ G]

-- define a blade representation
-- TODO: how to describe the fact that the vector argument to `graded` must be orthogonal?
inductive blade : nat → Type u
| scalar : G₀ → blade 0
| vector : G₁ → blade 1
| graded {n : ℕ} : G₁ → blade (n + 1) → blade (n + 2)
namespace blade
  instance g0_coe : has_coe_t G₀ (blade 0) := { coe := blade.scalar }
  instance g1_coe : has_coe_t G₁ (blade 1) := { coe := blade.vector }

  -- define zero and one on the blades
  def zero : Π (n : ℕ), blade n
  | 0 := blade.scalar (0 : G₀)
  | 1 := blade.vector (0 : G₁)
  | (nat.succ $ nat.succ n) := blade.graded (0 : G₁) (zero $ nat.succ n)
  instance has_zero {n : ℕ} : has_zero (blade n) := { zero := zero n }
  instance r0_has_one : has_one (blade 0) := { one := (1 : G₀) }

  -- define add on the blades
  def r0_add (a : blade 0) (b : blade 0) : blade 0 := begin
    cases a with a',
    cases b with b',
    exact blade.scalar (a' + b')
  end
  instance r0_has_add : has_add (blade 0) := { add := r0_add }
  def r1_add (a : blade 1) (b : blade 1) : blade 1 := begin
    cases a,
    cases b,
    exact blade.vector (a_1 + b_1)
  end
  instance r1_has_add : has_add (blade 1) := { add := r1_add }
end blade

-- define a sum-of-blades representation
inductive hom_mv : nat → Type u
| scalar : blade 0 -> hom_mv 0
| vector : blade 1 -> hom_mv 1
| graded {n : ℕ} : list (blade $ nat.succ $ nat.succ n) → (hom_mv $ nat.succ $ nat.succ n)

namespace hom_mv
  def coe : Π {n : ℕ}, (blade n) → hom_mv n
  | 0 := hom_mv.scalar
  | 1 := hom_mv.vector
  | (r + 2) := λ b, hom_mv.graded [b]
  instance has_blade_coe {r : ℕ} : has_coe (blade r) (hom_mv r) := { coe := coe }
  instance has_g0_coe : has_coe_t G₀ (hom_mv 0) := { coe := λ s, coe s }
  instance has_g1_coe : has_coe_t G₁ (hom_mv 1) := { coe := λ s, coe s }

  -- define zero and one on the hom_mvs
  instance has_zero {n : ℕ} : has_zero (hom_mv n) := { zero := (0 : blade n) }
  instance r0_has_one : has_one (hom_mv 0) := { one := (1 : blade 0) }

  def add : Π {n : ℕ}, hom_mv n → hom_mv n → hom_mv n
  | 0 (scalar a) (scalar b) := hom_mv.scalar (a + b)
  | 1 (vector a) (vector b) := hom_mv.vector (a + b)
  | (n + 2) (graded a) (graded b) := hom_mv.graded (a ++ b)

  instance has_add {n : ℕ} : has_add (hom_mv n) := { add := add }
end hom_mv

inductive multivector : nat → Type u
| scalar : hom_mv 0 → multivector 0
| augment {n : ℕ} : multivector n → hom_mv (nat.succ n) → multivector (nat.succ n)

namespace mv
  -- define zero and one on the multivectors
  def mv_zero : Π (n : ℕ), multivector n
  | 0 := multivector.scalar (0 : G₀)
  | 1 := multivector.augment (mv_zero 0) 0
  | (nat.succ $ nat.succ n) := multivector.augment (mv_zero $ nat.succ n) (hom_mv.graded [])
  def mv_one : Π (n : ℕ), multivector n
  | 0 := multivector.scalar (1 : G₀)
  | 1 := multivector.augment (mv_one 0) 0
  | (nat.succ $ nat.succ n) := multivector.augment (mv_one $ nat.succ n) (hom_mv.graded [])
  instance mv_has_zero {n : ℕ} : has_zero (multivector n) := { zero := mv_zero n }
  instance mv_has_one {n : ℕ} : has_one (multivector n) := { one := mv_one n }

  -- blades are coercible to multivectors
  def hom_mv_coe : Π {n : ℕ}, (hom_mv n) -> (multivector n)
  | nat.zero := λ b, multivector.scalar b
  | (nat.succ n) := λ b, multivector.augment (mv_zero n) b
  instance has_hom_mv_coe {n : ℕ} : has_coe (hom_mv n) (multivector n) := { coe := hom_mv_coe }
  instance has_g0_coe_t : has_coe_t G₀ (multivector 0) := { coe := λ s, hom_mv_coe $ hom_mv.scalar $ blade.scalar s }
  instance has_g1_coe_t : has_coe_t G₁ (multivector 1) := { coe := λ v, hom_mv_coe $ hom_mv.vector $ blade.vector v }

  -- multivectors are up-coercible
  def augment_coe {n : ℕ} (mv : multivector n) : multivector (nat.succ n) := multivector.augment mv 0
  instance has_augment_coe {n : ℕ} : has_coe (multivector n) (multivector (nat.succ n)) := { coe := augment_coe }
  instance has_g0_coe_n {n : ℕ} : has_coe_t G₀ (multivector n) := {
    coe := nat.rec_on n coe $ λ n s k, s k }
  instance has_g1_coe_n {n : ℕ} : has_coe_t G₁ (multivector n.succ) := {
    coe := nat.rec_on n coe $ λ n s k, s k }

  def mv_add : Π {n : ℕ}, multivector n → multivector n → multivector n
  | 0 (multivector.scalar a) (multivector.scalar b) := multivector.scalar (a + b)
  | (nat.succ n) (multivector.augment a ar) (multivector.augment b br) :=
    multivector.augment (mv_add a b) (ar + br)

  instance has_add {n: ℕ} : has_add (multivector n) := { add := mv_add }
end mv

parameter v : G₁

--  Addition!
#check ((2 + v) : multivector 1)
#check ((2 + v) : multivector 2)

def fᵥ : G₁ →+ G := f₁ G₀

abbreviation fₛ : G₀ →+* G := algebra_map G₀ G

def prod_vec (a b : G₁) : G := fᵥ a * fᵥ b

local infix `*ᵥ`:75 := prod_vec

def square_vec (a : G₁) := a *ᵥ a

local postfix `²ᵥ`:80 := square_vec

def sym_prod_vec (a b : G₁) := a *ᵥ b + b *ᵥ a

local infix `*₊ᵥ`:75 := sym_prod_vec

def is_orthogonal (a : G₁) (b : G₁) : Prop := sym_prod_vec a b = 0

theorem zero_is_orthogonal (a : G₁) : is_orthogonal 0 a := begin
  unfold is_orthogonal,
  unfold sym_prod_vec,
  unfold prod_vec,
  simp
end

/-- a list of `r` orthogonal vectors, which may be non-unique -/
abbreviation pairwise_ortho_vector (r : ℕ) := {l : vector G₁ r // l.to_list.pairwise is_orthogonal}

/- need this for later, can't seem to get the type inference to work if I inline it-/
-- def zero_pairwise_ortho_vector (r : ℕ) : pairwise_ortho_vector r := ⟨
--   vector.repeat (0 : G₁) r, begin
--   unfold vector.repeat subtype.val,
--   apply pairwise_of_repeat,
--   apply zero_is_orthogonal,
-- end⟩

/-- r-blades -/
def is_rblade (r : ℕ) (b : G) : Prop :=
  -- a product of orthogonal vectors an a scalar
∃ (k : G₀) (v : pairwise_ortho_vector r),
  b = k • ((v : vector G₁ r).map fᵥ).to_list.prod

def Bᵣ (r : ℕ) := set_of (is_rblade r)

namespace Bᵣ
  variables {r : ℕ}

  lemma all_G₀_is_rblade0 (k : G₀) : is_rblade 0 (fₛ k) := begin
    use [k, list.pairwise.nil],
    simp [algebra.smul_def],
  end
  lemma all_G₁_is_rblade1 (a : G₁) : is_rblade 1 (fᵥ a) := begin
    use [1, ⟨vector.cons a vector.nil, list.pairwise_singleton _ a⟩],
    rw vector.to_list_map,
    simp,
  end

  instance has_coe_from_G₀ : has_coe G₀ (Bᵣ 0) := { coe := λ k, ⟨fₛ k, all_G₀_is_rblade0 k⟩}
  instance has_coe_from_G₁ : has_coe G₁ (Bᵣ 1) := { coe := λ a, ⟨fᵥ a, all_G₁_is_rblade1 a⟩}

  -- this is trivial, but maybe still needed
  @[simp]
  lemma coe_is_rblade (b : Bᵣ r) : is_rblade r b := b.prop

  /- todo: do we want this? -/
  -- instance has_zero : has_zero (Bᵣ r) := {
  --   zero := ⟨(0 : G), begin
  --     use [0, zero_pairwise_ortho_vector r],
  --     simp,
  --   end⟩
  -- }

  /- scalar multiple of an element of Bᵣ is also in Bᵣ -/
  lemma smul_mem {b : G} {k : G₀} (hb : is_rblade r b) : is_rblade r (k • b) := begin
    obtain ⟨a, factors, ha_1⟩ := hb,
    refine ⟨k * a, factors, _⟩,
    rw [ha_1, mul_smul],
  end

  /- now show via trivial proofs that Bᵣ is a mul_action and has_neg -/
  instance mul_action (r : ℕ) : mul_action G₀ (Bᵣ r) :=
  { smul := λ k b, ⟨k • (b : G), smul_mem b.prop⟩,
    one_smul := λ b, subtype.eq $ one_smul _ b,
    mul_smul := λ k₁ k₂ b, subtype.eq $ mul_smul k₁ k₂ b }

  instance has_neg (r : ℕ) : has_neg (Bᵣ r) := { neg := λ b, (-1 : G₀) • b }

end Bᵣ

/-- `r`-vectors -/
def Gᵣ (r : ℕ) := add_subgroup.closure (Bᵣ r)

example (r : ℕ) : add_comm_group (Gᵣ r) := by apply_instance
namespace Gᵣ
  variables {r : ℕ}

  -- this is trivial, but maybe needed
  -- instance has_coe_from_Bᵣ : has_coe (Bᵣ r) (Gᵣ r) := { coe := λ b, ⟨b.val, add_subgroup.subset_closure b.property⟩ }

  -- scalar multiple of an element of Gᵣ is also in Gᵣ
  lemma smul_mem {v : G} {k : G₀} (hv : v ∈ Gᵣ r) : (k • v) ∈ Gᵣ r :=
  add_subgroup.closure_induction hv
    (λ x hx, add_subgroup.subset_closure $ by exact Bᵣ.smul_mem hx)
    (by {
      rw smul_zero, exact (Gᵣ r).zero_mem, })
    (λ a b, by {
      rw smul_add, exact (Gᵣ r).add_mem, })
    (λ a, by {
      rw smul_neg, exact (Gᵣ r).neg_mem, })

  -- now show via trivial proofs that Gᵣ is a module (basically a vector space)
  instance has_scalar (r : ℕ) : module G₀ (Gᵣ r) :=
  { smul := λ k v, ⟨k • v, smul_mem v.prop⟩,
    one_smul := λ v, subtype.eq $ one_smul _ v,
    mul_smul := λ k₁ k₂ v, subtype.eq $ mul_smul k₁ k₂ v,
    smul_zero := λ v, subtype.eq $ smul_zero v,
    zero_smul := λ v, subtype.eq $ zero_smul _ v,
    add_smul := λ k₁ k₂ v, subtype.eq $ add_smul k₁ k₂ v,
    smul_add := λ k v₁ v₂, subtype.eq $ smul_add k v₁ v₂,
    zero_smul := λ v, subtype.eq $ zero_smul _ v }

end Gᵣ

/-- multi-vectors of at most grade `r` -/
def Mᵣ (r : ℕ) := add_subgroup.closure (⋃ (r' : fin r), (Gᵣ r').carrier)
example (r : ℕ) : add_comm_group (Mᵣ r) := infer_instance

abbreviation is_scalar : G → Prop := is_rblade 0

/--
  Symmetrised product of two vectors must be a scalar
-/
lemma vec_sym_prod_scalar (a b : G₁) : is_scalar (a *₊ᵥ b) :=
have h1 : (a + b)²ᵥ = a²ᵥ + b²ᵥ + a *₊ᵥ b, from begin
  unfold square_vec sym_prod_vec prod_vec,
  rw fᵥ.map_add a b,
  rw left_distrib,
  repeat {rw right_distrib},
  abel,
end,
have vec_sq_scalar : ∀ v : G₁, ∃ k : G₀, v²ᵥ = fₛ k, from
  λ v, geometric_algebra.vec_sq_scalar(v),
begin
  obtain ⟨kab, hab⟩ := vec_sq_scalar (a + b),
  obtain ⟨ka, ha⟩ := vec_sq_scalar a,
  obtain ⟨kb, hb⟩ := vec_sq_scalar b,
  rw [hb, ha, hab] at h1,
  have h2 : (fₛ (kab - ka - kb : G₀) : G) = sym_prod_vec a b, by {
    repeat {rw ring_hom.map_sub},
    rw h1,
    abel,
  },
  rw ← h2,
  exact Bᵣ.all_G₀_is_rblade0 _, -- this feels clumsy, can I make this automatic?
end

end basic

end geometric_algebra