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

/-!
# A computable model of ZFA without infinity

In this file we define finite hereditary lists. This is useful for calculations in naive set theory.

We distinguish two kinds of ZFA lists:
* Atoms. Directly correspond to an element of the original type.
* Proper ZFA lists. Can thought of (but aren't implemented) as a list of ZFA lists (not necessarily
  proper).

For example, `lists ℕ` contains stuff like `23`, `[]`, `[37]`, `[1, [[2], 3], 4]`.

## Implementation note

As we want to be able to append both atoms and proper ZFA lists to proper ZFA lists, it's handy that
atoms and proper ZFA lists belong to the same type, even though atoms of `α` could be modelled as
`α` directly. But we don't want to be able to append anything to atoms.

This calls for a two-steps definition of ZFA lists:
* First, define ZFA prelists as atoms and proper ZFA prelists. Those proper ZFA prelists are defined
  by inductive appending of (not necessarily proper) ZFA lists.
* Second, define ZFA lists by rubbing out the distinction between atoms and proper lists.

## Main declarations

* `lists' α ff`: Atoms as ZFA prelists. Basically a copy of `α`.
* `lists' α tt`: Proper ZFA prelists. Defined inductively from the empty ZFA prelist (`lists'.nil`)
  and from appending a ZFA prelist to a proper ZFA prelist (`lists'.cons a l`).
* `lists α`: ZFA lists. Sum of the atoms and proper ZFA prelists.

## TODO

The next step is to define ZFA sets as lists quotiented by `lists.equiv`.
(-/

variables {α : Type*}

/-- Prelists, helper type to define `lists`. `lists' α ff` are the "atoms", a copy of `α`.
`lists' α tt` are the "proper" ZFA prelists, inductively defined from the empty ZFA prelist and from
appending a ZFA prelist to a proper ZFA prelist. It is made so that you can't append anything to an
atom while having only one appending function for appending both atoms and proper ZFC prelists to a
proper ZFA prelist. -/
@[derive decidable_eq]
inductive {u} lists' (α : Type u) : bool → Type u
| atom : α → lists' ff
| nil : lists' tt
| cons' {b} : lists' b → lists' tt → lists' tt

/-- Hereditarily finite list, aka ZFA list. A ZFA list is either an "atom" (`b = ff`), corresponding
to an element of `α`, or a "proper" ZFA list, inductively defined from the empty ZFA list and from
appending a ZFA list to a proper ZFA list. -/
def lists (α : Type*) := Σ b, lists' α b

namespace lists'

instance [inhabited α] : ∀ b, inhabited (lists' α b)
| tt := ⟨nil⟩
| ff := ⟨atom (default _)⟩

/-- Appending a ZFA list to a proper ZFA prelist. -/
def cons : lists α → lists' α tt → lists' α tt
| ⟨b, a⟩ l := cons' a l

/-- Converts a ZFA prelist to a `list` of ZFA lists. Atoms are sent to `[]`. -/
@[simp] def to_list : ∀ {b}, lists' α b → list (lists α)
| _ (atom a)    := []
| _ nil         := []
| _ (cons' a l) := ⟨_, a⟩ :: l.to_list

@[simp] theorem to_list_cons (a : lists α) (l) :
  to_list (cons a l) = a :: l.to_list :=
by cases a; simp [cons]

/-- Converts a `list` of ZFA lists to a proper ZFA prelist. -/
@[simp] def of_list : list (lists α) → lists' α tt
| []       := nil
| (a :: l) := cons a (of_list l)

@[simp] theorem to_of_list (l : list (lists α)) : to_list (of_list l) = l :=
by induction l; simp *

@[simp] theorem of_to_list : ∀ (l : lists' α tt), of_list (to_list l) = l :=
suffices ∀ b (h : tt = b) (l : lists' α b),
  let l' : lists' α tt := by rw h; exact l in
  of_list (to_list l') = l', from this _ rfl,
λ b h l, begin
  induction l, {cases h}, {exact rfl},
  case lists'.cons' : b a l IH₁ IH₂
  { intro, change l' with cons' a l,
    simpa [cons] using IH₂ rfl }
end

end lists'

mutual inductive lists.equiv, lists'.subset
with lists.equiv : lists α → lists α → Prop
| refl (l) : lists.equiv l l
| antisymm {l₁ l₂ : lists' α tt} :
  lists'.subset l₁ l₂ → lists'.subset l₂ l₁ → lists.equiv ⟨_, l₁⟩ ⟨_, l₂⟩
with lists'.subset : lists' α tt → lists' α tt → Prop
| nil {l} : lists'.subset lists'.nil l
| cons {a a' l l'} : lists.equiv a a' → a' ∈ lists'.to_list l' →
  lists'.subset l l' → lists'.subset (lists'.cons a l) l'
local infix ` ~ `:50 := lists.equiv

/-- Equivalence of ZFA lists. Defined inductively. -/
add_decl_doc lists.equiv

/-- Subset relation for ZFA lists. Defined inductively. -/
add_decl_doc lists'.subset

namespace lists'

instance : has_subset (lists' α tt) := ⟨lists'.subset⟩

/-- ZFA prelist membership. A ZFA list is in a ZFA prelist if some element of this ZFA prelist is
equivalent as a ZFA list to this ZFA list. -/
instance {b} : has_mem (lists α) (lists' α b) :=
⟨λ a l, ∃ a' ∈ l.to_list, a ~ a'⟩

theorem mem_def {b a} {l : lists' α b} :
  a ∈ l ↔ ∃ a' ∈ l.to_list, a ~ a' := iff.rfl

@[simp] theorem mem_cons {a y l} : a ∈ @cons α y l ↔ a ~ y ∨ a ∈ l :=
by simp [mem_def, or_and_distrib_right, exists_or_distrib]

theorem cons_subset {a} {l₁ l₂ : lists' α tt} :
  lists'.cons a l₁ ⊆ l₂ ↔ a ∈ l₂ ∧ l₁ ⊆ l₂ :=
begin
  refine ⟨λ h, _, λ ⟨⟨a', m, e⟩, s⟩, subset.cons e m s⟩,
  generalize_hyp h' : lists'.cons a l₁ = l₁' at h,
  cases h with l a' a'' l l' e m s, {cases a, cases h'},
  cases a, cases a', cases h', exact ⟨⟨_, m, e⟩, s⟩
end

theorem of_list_subset {l₁ l₂ : list (lists α)} (h : l₁ ⊆ l₂) :
  lists'.of_list l₁ ⊆ lists'.of_list l₂ :=
begin
  induction l₁, {exact subset.nil},
  refine subset.cons (lists.equiv.refl _) _ (l₁_ih (list.subset_of_cons_subset h)),
  simp at h, simp [h]
end

@[refl] theorem subset.refl {l : lists' α tt} : l ⊆ l :=
by rw ← lists'.of_to_list l; exact
   of_list_subset (list.subset.refl _)

theorem subset_nil {l : lists' α tt} :
  l ⊆ lists'.nil → l = lists'.nil :=
begin
  rw ← of_to_list l,
  induction to_list l; intro h, {refl},
  rcases cons_subset.1 h with ⟨⟨_, ⟨⟩, _⟩, _⟩
end

theorem mem_of_subset' {a} {l₁ l₂ : lists' α tt}
  (s : l₁ ⊆ l₂) (h : a ∈ l₁.to_list) : a ∈ l₂ :=
begin
  induction s with _ a a' l l' e m s IH, {cases h},
  simp at h, rcases h with rfl|h,
  exacts [⟨_, m, e⟩, IH h]
end

theorem subset_def {l₁ l₂ : lists' α tt} :
  l₁ ⊆ l₂ ↔ ∀ a ∈ l₁.to_list, a ∈ l₂ :=
⟨λ H a, mem_of_subset' H, λ H, begin
  rw ← of_to_list l₁,
  revert H, induction to_list l₁; intro,
  { exact subset.nil },
  { simp at H, exact cons_subset.2 ⟨H.1, ih H.2⟩ }
end⟩

end lists'

namespace lists

/-- Sends `a : α` to the corresponding atom in `lists α`. -/
@[pattern] def atom (a : α) : lists α := ⟨_, lists'.atom a⟩

/-- Converts a proper ZFA prelist to a ZFA list. -/
@[pattern] def of' (l : lists' α tt) : lists α := ⟨_, l⟩

/-- Converts a ZFA list to a `list` of ZFA lists. Atoms are sent to `[]`. -/
@[simp] def to_list : lists α → list (lists α)
| ⟨b, l⟩ := l.to_list

/-- Predicate stating that a ZFA list is proper. -/
def is_list (l : lists α) : Prop := l.1

/-- Converts a `list` of ZFA lists to a ZFA list. -/
def of_list (l : list (lists α)) : lists α := of' (lists'.of_list l)

theorem is_list_to_list (l : list (lists α)) : is_list (of_list l) :=
eq.refl _

theorem to_of_list (l : list (lists α)) : to_list (of_list l) = l :=
by simp [of_list, of']

theorem of_to_list : ∀ {l : lists α}, is_list l → of_list (to_list l) = l
| ⟨tt, l⟩ _ := by simp [of_list, of']

instance : inhabited (lists α) :=
⟨of' lists'.nil⟩

instance [decidable_eq α] : decidable_eq (lists α) :=
by unfold lists; apply_instance

instance [has_sizeof α] : has_sizeof (lists α) :=
by unfold lists; apply_instance

/-- A recursion principle for pairs of ZFA lists and proper ZFA prelists. -/
def induction_mut (C : lists α → Sort*) (D : lists' α tt → Sort*)
  (C0 : ∀ a, C (atom a)) (C1 : ∀ l, D l → C (of' l))
  (D0 : D lists'.nil) (D1 : ∀ a l, C a → D l → D (lists'.cons a l)) :
  pprod (∀ l, C l) (∀ l, D l) :=
begin
  suffices : ∀ {b} (l : lists' α b),
    pprod (C ⟨_, l⟩) (match b, l with
    | tt, l := D l
    | ff, l := punit
    end),
  { exact ⟨λ ⟨b, l⟩, (this _).1, λ l, (this l).2⟩ },
  intros, induction l with a b a l IH₁ IH₂,
  { exact ⟨C0 _, ⟨⟩⟩ },
  { exact ⟨C1 _ D0, D0⟩ },
  { suffices, {exact ⟨C1 _ this, this⟩},
    exact D1 ⟨_, _⟩ _ IH₁.1 IH₂.2 }
end

/-- Membership of ZFA list. A ZFA list belongs to a proper ZFA list if it belongs to the latter as a
proper ZFA prelist. An atom has no members. -/
def mem (a : lists α) : lists α → Prop
| ⟨ff, l⟩ := false
| ⟨tt, l⟩ := a ∈ l

instance : has_mem (lists α) (lists α) := ⟨mem⟩

theorem is_list_of_mem {a : lists α} : ∀ {l : lists α}, a ∈ l → is_list l
| ⟨_, lists'.nil⟩       _ := rfl
| ⟨_, lists'.cons' _ _⟩ _ := rfl

theorem equiv.antisymm_iff {l₁ l₂ : lists' α tt} :
  of' l₁ ~ of' l₂ ↔ l₁ ⊆ l₂ ∧ l₂ ⊆ l₁ :=
begin
  refine ⟨λ h, _, λ ⟨h₁, h₂⟩, equiv.antisymm h₁ h₂⟩,
  cases h with _ _ _ h₁ h₂,
  { simp [lists'.subset.refl] }, { exact ⟨h₁, h₂⟩ }
end

attribute [refl] equiv.refl

theorem equiv_atom {a} {l : lists α} : atom a ~ l ↔ atom a = l :=
⟨λ h, by cases h; refl, λ h, h ▸ equiv.refl _⟩

theorem equiv.symm {l₁ l₂ : lists α} (h : l₁ ~ l₂) : l₂ ~ l₁ :=
by cases h with _ _ _ h₁ h₂; [refl, exact equiv.antisymm h₂ h₁]

theorem equiv.trans : ∀ {l₁ l₂ l₃ : lists α}, l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃ :=
begin
  let trans := λ (l₁ : lists α), ∀ ⦃l₂ l₃⦄, l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃,
  suffices : pprod (∀ l₁, trans l₁)
    (∀ (l : lists' α tt) (l' ∈ l.to_list), trans l'), {exact this.1},
  apply induction_mut,
  { intros a l₂ l₃ h₁ h₂,
    rwa ← equiv_atom.1 h₁ at h₂ },
  { intros l₁ IH l₂ l₃ h₁ h₂,
    cases h₁ with _ _ l₂, {exact h₂},
    cases h₂ with _ _ l₃, {exact h₁},
    cases equiv.antisymm_iff.1 h₁ with hl₁ hr₁,
    cases equiv.antisymm_iff.1 h₂ with hl₂ hr₂,
    apply equiv.antisymm_iff.2; split; apply lists'.subset_def.2,
    { intros a₁ m₁,
      rcases lists'.mem_of_subset' hl₁ m₁ with ⟨a₂, m₂, e₁₂⟩,
      rcases lists'.mem_of_subset' hl₂ m₂ with ⟨a₃, m₃, e₂₃⟩,
      exact ⟨a₃, m₃, IH _ m₁ e₁₂ e₂₃⟩ },
    { intros a₃ m₃,
      rcases lists'.mem_of_subset' hr₂ m₃ with ⟨a₂, m₂, e₃₂⟩,
      rcases lists'.mem_of_subset' hr₁ m₂ with ⟨a₁, m₁, e₂₁⟩,
      exact ⟨a₁, m₁, (IH _ m₁ e₂₁.symm e₃₂.symm).symm⟩ } },
  { rintro _ ⟨⟩ },
  { intros a l IH₁ IH₂, simpa [IH₁] using IH₂ }
end

instance : setoid (lists α) :=
⟨(~), equiv.refl, @equiv.symm _, @equiv.trans _⟩

section decidable

@[simp] def equiv.decidable_meas :
  (psum (Σ' (l₁ : lists α), lists α) $
   psum (Σ' (l₁ : lists' α tt), lists' α tt)
   Σ' (a : lists α), lists' α tt) → ℕ
| (psum.inl ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂
| (psum.inr $ psum.inl ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂
| (psum.inr $ psum.inr ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂

open well_founded_tactics

theorem sizeof_pos {b} (l : lists' α b) : 0 < sizeof l :=
by cases l; unfold_sizeof; trivial_nat_lt

theorem lt_sizeof_cons' {b} (a : lists' α b) (l) :
  sizeof (⟨b, a⟩ : lists α) < sizeof (lists'.cons' a l) :=
by {unfold_sizeof, apply sizeof_pos}

@[instance] mutual def equiv.decidable, subset.decidable, mem.decidable [decidable_eq α]
with equiv.decidable : ∀ l₁ l₂ : lists α, decidable (l₁ ~ l₂)
| ⟨ff, l₁⟩ ⟨ff, l₂⟩ := decidable_of_iff' (l₁ = l₂) $
  by cases l₁; refine equiv_atom.trans (by simp [atom])
| ⟨ff, l₁⟩ ⟨tt, l₂⟩ := is_false $ by rintro ⟨⟩
| ⟨tt, l₁⟩ ⟨ff, l₂⟩ := is_false $ by rintro ⟨⟩
| ⟨tt, l₁⟩ ⟨tt, l₂⟩ := begin
  haveI :=
    have sizeof l₁ + sizeof l₂ <
         sizeof (⟨tt, l₁⟩ : lists α) + sizeof (⟨tt, l₂⟩ : lists α),
    by default_dec_tac,
    subset.decidable l₁ l₂,
  haveI :=
    have sizeof l₂ + sizeof l₁ <
         sizeof (⟨tt, l₁⟩ : lists α) + sizeof (⟨tt, l₂⟩ : lists α),
    by default_dec_tac,
    subset.decidable l₂ l₁,
  exact decidable_of_iff' _ equiv.antisymm_iff,
end
with subset.decidable : ∀ l₁ l₂ : lists' α tt, decidable (l₁ ⊆ l₂)
| lists'.nil l₂ := is_true subset.nil
| (@lists'.cons' _ b a l₁) l₂ := begin
  haveI :=
    have sizeof (⟨b, a⟩ : lists α) + sizeof l₂ <
         sizeof (lists'.cons' a l₁) + sizeof l₂,
    from add_lt_add_right (lt_sizeof_cons' _ _) _,
    mem.decidable ⟨b, a⟩ l₂,
  haveI :=
    have sizeof l₁ + sizeof l₂ <
         sizeof (lists'.cons' a l₁) + sizeof l₂,
    by default_dec_tac,
    subset.decidable l₁ l₂,
  exact decidable_of_iff' _ (@lists'.cons_subset _ ⟨_, _⟩ _ _)
end
with mem.decidable : ∀ (a : lists α) (l : lists' α tt), decidable (a ∈ l)
| a lists'.nil := is_false $ by rintro ⟨_, ⟨⟩, _⟩
| a (lists'.cons' b l₂) := begin
  haveI :=
    have sizeof a + sizeof (⟨_, b⟩ : lists α) <
         sizeof a + sizeof (lists'.cons' b l₂),
    from add_lt_add_left (lt_sizeof_cons' _ _) _,
    equiv.decidable a ⟨_, b⟩,
  haveI :=
    have sizeof a + sizeof l₂ <
         sizeof a + sizeof (lists'.cons' b l₂),
    by default_dec_tac,
    mem.decidable a l₂,
  refine decidable_of_iff' (a ~ ⟨_, b⟩ ∨ a ∈ l₂) _,
  rw ← lists'.mem_cons, refl
end
using_well_founded
{ rel_tac := λ _ _, `[exact ⟨_, measure_wf equiv.decidable_meas⟩],
  dec_tac := `[assumption] }

end decidable

end lists

namespace lists'

theorem mem_equiv_left {l : lists' α tt} :
  ∀ {a a'}, a ~ a' → (a ∈ l ↔ a' ∈ l) :=
suffices ∀ {a a'}, a ~ a' → a ∈ l → a' ∈ l,
  from λ a a' e, ⟨this e, this e.symm⟩,
λ a₁ a₂ e₁ ⟨a₃, m₃, e₂⟩, ⟨_, m₃, e₁.symm.trans e₂⟩

theorem mem_of_subset {a} {l₁ l₂ : lists' α tt}
  (s : l₁ ⊆ l₂) : a ∈ l₁ → a ∈ l₂ | ⟨a', m, e⟩ :=
(mem_equiv_left e).2 (mem_of_subset' s m)

theorem subset.trans {l₁ l₂ l₃ : lists' α tt}
  (h₁ : l₁ ⊆ l₂) (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
subset_def.2 $ λ a₁ m₁, mem_of_subset h₂ $ mem_of_subset' h₁ m₁

end lists'

def finsets (α : Type*) := quotient (@lists.setoid α)

namespace finsets

instance : has_emptyc (finsets α) := ⟨⟦lists.of' lists'.nil⟧⟩

instance : inhabited (finsets α) := ⟨∅⟩

instance [decidable_eq α] : decidable_eq (finsets α) :=
by unfold finsets; apply_instance

end finsets


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (hα : ¬ is_rat α) : ∀ y ∈ Icc 0 1, ∃ x ∈ Icc 0 1, x ≠ y ∧ x ∈ {i • α | i ∈ ℤ} :=
begin
  assume y h,
  have h1 : ∀ i j : ℤ, i ≠ j → {i • α} ≠ {j • α}, from by {
    assume i j h2,
    assume h3 : {i • α} = {j • α},
    have h4 : i • α - (i • α).floor = {i • α}, from by {rw h3},
    have h5 : j • α - (j • α).floor = {j • α}, from by {rw h3},
    have h6 : α = (i • α).floor - (j • α).floor / (i - j), from by {rw [h4,h5], ring},
    have h7 : α ∈ ℚ, from by {apply quotient.exact h6},
    exact hα h7,
  },
  have h2 : ∀ i j : ℤ, i ≠ j → i • α ≠ j • α, from by {
    assume i j h3,
    assume h4 : i • α = j • α,
    have h5 : i = j, from by {rw [h4,mul_eq_mul_iff_left hα]},
    exact h3 h5,
  },
  have h3 : ∀ i j : ℤ, i ≠ j → i • α - (i • α).floor ≠ j • α - (j • α).floor, from by {
    assume i j h4,
    assume h5 : i • α - (i • α).floor = j • α - (j • α).floor,
    have h6 : i • α = j • α, from by {rw h5, ring},
    exact h2 i j h4 h6,
  },
  have h4 : ∀ i j : ℤ, i ≠ j → {i • α} ≠ {j • α}, from by {
    assume i j h5,
    assume h6 : {i • α} = {j • α},
    have h7 : i • α - (i • α).floor = {i • α}, from by {rw h6},
    have h8 : j • α - (j • α).floor = {j • α}, from by {rw h6},
    have h9 : i • α - (i • α).floor = j • α - (j • α).floor, from by {rw [h7,h8]},
    exact h3 i j h5 h9,
  },
  have h5 : ∀ i j : ℤ, i ≠ j → i • α ≠ j • α, from by {
    assume i j h6,
    assume h7 : i • α = j • α,
    have h8 : i = j, from by {rw [h7,mul_eq_mul_iff_left hα]},
    exact h6 h8,
  },
  have h6 : ∀ i j : ℤ, i ≠ j → i • α - (i • α).floor ≠ j • α - (j • α).floor, from by {
    assume i j h7,
    assume h8 : i • α - (i • α).floor = j • α - (j • α).floor,
    have h9 : i • α = j • α, from by {rw h8, ring},
    exact h5 i j h7 h9,
  },
  have h7 : ∀ i j : ℤ, i ≠ j → {i • α} ≠ {j • α}, from by {
    assume i j h8,
    assume h9 : {i • α} = {j • α},
    have h10 : i • α - (i • α).floor = {i • α}, from by {rw h9},
    have h11 : j • α - (j • α).floor = {j • α}, from by {rw h9},
    have h12 : i • α - (i • α).floor = j • α - (j • α).floor, from by {rw [h10,h11]},
    exact h6 i j h8 h12,
  },
  have h8 : ∀ i j : ℤ, i ≠ j → i • α ≠ j • α, from by {
    assume i j h9,
    assume h10 : i • α = j • α,
    have h11 : i = j, from by {rw [h10,mul_eq_mul_iff_left hα]},
    exact h9 h11,
  },
  have h9 : ∀ i j : ℤ, i ≠ j → i • α - (i • α).floor ≠ j • α - (j • α).floor, from by {
    assume i j h10,
    assume h11 : i • α - (i • α).floor = j • α - (j • α).floor,
    have h12 : i • α = j • α, from by {rw h11, ring},
    exact h8 i j h10 h12,
  },
  have h10 : ∀ i j : ℤ, i ≠ j → {i • α} ≠ {j • α}, from by {
    assume i j h11,
    assume h12 : {i • α} = {j • α},
    have h13 : i • α - (i • α).floor = {i • α}, from by {rw h12},
    have h14 : j • α - (j • α).floor = {j • α}, from by {rw h12},
    have h15 : i • α - (i • α).floor = j • α - (j • α).floor, from by {rw [h13,h14]},
    exact h9 i j h11 h15,
  },
  have h11 : ∀ i j : ℤ, i ≠ j → i • α ≠ j • α, from by {
    assume i j h12,
    assume h13 : i • α = j • α,
    have h14 : i = j, from by {rw [h13,mul_eq_mul_iff_left hα]},
    exact h12 h14,
  },
  have h12 : ∀ i j : ℤ, i ≠ j → i • α - (i • α).floor ≠ j • α - (j • α).floor, from by {
    assume i j h13,
    assume h14 : i • α - (i • α).floor = j • α - (j • α).floor,
    have h15 : i • α = j • α, from by {rw h14, ring},
    exact h11 i j h13 h15,
  },
  have h13 : ∀ i j : ℤ, i ≠ j → {i • α} ≠ {j • α}, from by {
    assume i j h14,
    assume h15 : {i • α} = {j • α},
    have h16 : i • α - (i • α).floor = {i • α}, from by {rw h15},
    have h17 : j • α - (j • α).floor = {j • α}, from by {rw h15},
    have h18 : i • α - (i • α).floor = j • α - (j • α).floor, from by {rw [h16,h17]},
    exact h12 i j h14 h18,
  },
  have h14 : ∀ i j : ℤ, i ≠ j → i • α ≠ j • α, from by {
    assume i j h15,
    assume h16 : i • α = j • α,
    have h17 : i = j, from by {rw [h16,mul_eq_mul_iff_left hα]},
    exact h15 h17,
  },
  have h15 : ∀ i j : ℤ, i ≠ j → i • α - (i • α).floor ≠ j • α - (j • α).floor, from by {
    assume i j h16,
    assume h17 : i • α - (i •
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  --From Negative of Absolute Value: $\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$
  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by
  {
    intro x0,
    have h6 : |x0 - l| < ε ↔ ((x0 - l) < ε) ∧ ((l - x0) < ε),
    from abs_sub_lt_iff, rw h6,
    split,
    rintro ⟨ S_1, S_2 ⟩,
    split; linarith,
    rintro ⟨ S_3, S_4 ⟩,
    split; linarith,
    },

  --Let $\epsilon > 0$.
  assume (h7 : ε > 0),

  --As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that $\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$
  cases h2 ε h7 with N1 h8,

  --As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that $\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$
  cases h3 ε h7 with N2 h9,

  --Let $N = \max \set {N_1, N_2}$.
  let N := max N1 N2,
  use N,

  --Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.
  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by {
    assume n h,
    split,
    exact lt_of_le_of_lt (le_max_left N1 N2) h,
    exact lt_of_le_of_lt (le_max_right N1 N2) h,
  },

  --$\forall n > N: l - \epsilon < y_n < l + \epsilon$
  --$\forall n > N: l - \epsilon < z_n < l + \epsilon$
  --$\forall n \in \N: y_n \le x_n \le z_n$
  --So $\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by {
    intros n h12,
    split,
    {

      have h13 := (h8 n (h10 n h12).left), rw h5 (y n) at h13,
      split,
      exact h13.left,
      exact (h4 n).left,
    },
    {
      have h14 := (h9 n (h10 n h12).right),rw h5 (z n) at h14,
      split,
      exact (h4 n).right,
      exact h14.right,
    },

  },

  --$\forall n > N: l - \epsilon < x_n < l + \epsilon$
  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by {
    intros n1 h16, cases (h11 n1 h16);
    split; linarith,
  },

  --So $\forall n > N: \size {x_n - l} < \epsilon$
  --Hence the result
  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by {
    intros n h17,
    cases h5 (x n) with h18 h19,
    apply h19, exact h15 n h17,
  },
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.pi
import algebra.category.Group.preadditive
import category_theory.limits.shapes.biproducts
import algebra.category.Group.limits

/-!
# The category of abelian groups has finite biproducts
-/

open category_theory
open category_theory.limits

open_locale big_operators

universe u

namespace AddCommGroup

/--
Construct limit data for a binary product in `AddCommGroup`, using `AddCommGroup.of (G × H)`.
-/
def binary_product_limit_cone (G H : AddCommGroup.{u}) : limits.limit_cone (pair G H) :=
{ cone :=
  { X := AddCommGroup.of (G × H),
    π := { app := λ j, walking_pair.cases_on j (add_monoid_hom.fst G H) (add_monoid_hom.snd G H) }},
  is_limit :=
  { lift := λ s, add_monoid_hom.prod (s.π.app walking_pair.left) (s.π.app walking_pair.right),
    fac' := begin rintros s (⟨⟩|⟨⟩); { ext x, simp, }, end,
    uniq' := λ s m w,
    begin
      ext; [rw ← w walking_pair.left, rw ← w walking_pair.right]; refl,
    end, } }

instance has_binary_product (G H : AddCommGroup.{u}) : has_binary_product G H :=
has_limit.mk (binary_product_limit_cone G H)

instance (G H : AddCommGroup.{u}) : has_binary_biproduct G H :=
has_binary_biproduct.of_has_binary_product _ _

/--
We verify that the biproduct in AddCommGroup is isomorphic to
the cartesian product of the underlying types:
-/
noncomputable
def biprod_iso_prod (G H : AddCommGroup.{u}) : (G ⊞ H : AddCommGroup) ≅ AddCommGroup.of (G × H) :=
is_limit.cone_point_unique_up_to_iso
  (binary_biproduct.is_limit G H)
  (binary_product_limit_cone G H).is_limit

-- Furthermore, our biproduct will automatically function as a coproduct.
example (G H : AddCommGroup.{u}) : has_colimit (pair G H) := by apply_instance

variables {J : Type u} (F : (discrete J) ⥤ AddCommGroup.{u})

namespace has_limit

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
def lift (s : cone F) :
  s.X ⟶ AddCommGroup.of (Π j, F.obj j) :=
{ to_fun := λ x j, s.π.app j x,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp }, }

@[simp] lemma lift_apply (s : cone F) (x : s.X) (j : J) : (lift F s) x j = s.π.app j x := rfl

/--
Construct limit data for a product in `AddCommGroup`, using `AddCommGroup.of (Π j, F.obj j)`.
-/
def product_limit_cone : limits.limit_cone F :=
{ cone :=
  { X := AddCommGroup.of (Π j, F.obj j),
    π := discrete.nat_trans (λ j, pi.eval_add_monoid_hom (λ j, F.obj j) j), },
  is_limit :=
  { lift := lift F,
    fac' := λ s j, by { ext, simp, },
    uniq' := λ s m w,
    begin
      ext x j,
      dsimp only [has_limit.lift],
      simp only [add_monoid_hom.coe_mk],
      exact congr_arg (λ f : s.X ⟶ F.obj j, (f : s.X → F.obj j) x) (w j),
    end, }, }

end has_limit

section

open has_limit

variables [decidable_eq J] [fintype J]

instance (f : J → AddCommGroup.{u}) : has_biproduct f :=
has_biproduct.of_has_product _

/--
We verify that the biproduct we've just defined is isomorphic to the AddCommGroup structure
on the dependent function type
-/
noncomputable
def biproduct_iso_pi (f : J → AddCommGroup.{u}) :
  (⨁ f : AddCommGroup) ≅ AddCommGroup.of (Π j, f j) :=
is_limit.cone_point_unique_up_to_iso
  (biproduct.is_limit f)
  (product_limit_cone (discrete.functor f)).is_limit

end

instance : has_finite_biproducts AddCommGroup :=
⟨λ J _ _, by exactI { has_biproduct := λ f, by apply_instance }⟩

end AddCommGroup


def x := 1

#check x

variable {α : Type}

def f (a : α) : α :=
a

def tst (xs : List Nat) : Nat :=
xs.foldl (init := 10) (· + ·)

#check tst [1, 2, 3]

#check fun x y : Nat => x + y

#check tst

#check (fun stx => if True then let e := stx; Pure.pure e else Pure.pure stx : Nat → Id Nat)

#check let x : Nat := 1; x

def foo (a : Nat) (b : Nat := 10) (c : Bool := Bool.true) : Nat :=
a + b

set_option pp.all true

#check foo 1

#check foo 3 (c := false)

def Nat.boo (a : Nat) :=
succ a -- succ here is resolved as `Nat.succ`.

#check Nat.boo

#check true

-- apply is still a valid identifier name
def apply := "hello"

#check apply

theorem simple1 (x y : Nat) (h : x = y) : x = y :=
by {
  assumption
}

theorem simple2 (x y : Nat) : x = y → x = y :=
by {
  intro h;
  assumption
}

syntax "intro2" : tactic

macro_rules
| `(tactic| intro2) => `(tactic| intro; intro )

theorem simple3 (x y : Nat) : x = x → x = y → x = y :=
by {
  intro2;
  assumption
}

macro "intro3" : tactic => `(tactic| (intro; intro; intro))
macro "check2" x:term : command => `(#check $x #check $x)
macro "foo" x:term "," y:term : term => `($x + $y + $x)

set_option pp.all false

check2 0+1
check2 foo 0,1

theorem simple4 (x y : Nat) : y = y → x = x → x = y → x = y :=
by {
  intro3;
  assumption
}

theorem simple5 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro _; intro h3;
  exact Eq.trans h3 h1
}

theorem simple6 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro _; intro h3;
  refine Eq.trans ?_ h1;
  assumption
}

theorem simple7 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro _; intro h3;
  refine' Eq.trans ?pre ?post;
  exact y;
  { exact h3 }
  { exact h1 }
}

theorem simple8 (x y z : Nat) : y = z → x = x → x = y → x = z := by
intro h1; intro _; intro h3
refine' Eq.trans ?pre ?post
case post => exact h1
case pre => exact h3

theorem simple9 (x y z : Nat) : y = z → x = x → x = y → x = z := by
intros h1 _ h3
trace_state
focus
  refine' Eq.trans ?pre ?post
  first
    | exact h1
      assumption
    | exact y
      exact h3
      assumption

theorem simple9b (x y z : Nat) : y = z → x = x → x = y → x = z := by
intros h1 _ h3
trace_state
focus
  refine' Eq.trans ?pre ?post
  first
    | exact h1
    | exact y; exact h3
  assumption

theorem simple9c (x y z : Nat) : y = z → x = x → x = y → x = z := by
  intros h1 _ h3
  solve
    | exact h1
    | refine' Eq.trans ?pre ?post; exact y; exact h3; assumption
    | exact h3

theorem simple9d (x y z : Nat) : y = z → x = x → x = y → x = z := by
  intros h1 _ h3
  refine' Eq.trans ?pre ?post
  solve
    | exact h1
    | exact y
    | exact h3
  solve
    | exact h1
    | exact h3
  solve
    | exact h1
    | assumption

namespace Foo
  def Prod.mk := 1
  #check (⟨2, 3⟩ : Prod _ _)
end Foo

theorem simple10 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro h2; intro h3;
  skip;
  apply Eq.trans;
  exact h3;
  assumption
}

theorem simple11 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro h2; intro h3;
  apply @Eq.trans;
  trace_state;
  exact h3;
  assumption
}

theorem simple12 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intro h1; intro h2; intro h3;
  apply @Eq.trans;
  try exact h1; -- `exact h1` fails
  trace_state;
  try exact h3;
  trace_state;
  try exact h1;
}

theorem simple13 (x y z : Nat) : y = z → x = x → x = y → x = z := by
intros h1 h2 h3
trace_state
apply @Eq.trans
case b => exact y
trace_state
repeat assumption

theorem simple13b (x y z : Nat) : y = z → x = x → x = y → x = z := by {
intros h1 h2 h3;
trace_state;
apply @Eq.trans;
case b => exact y;
trace_state;
repeat assumption
}

theorem simple14 (x y z : Nat) : y = z → x = x → x = y → x = z := by
intros
apply @Eq.trans
case b => exact y
repeat assumption

theorem simple15 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intros h1 h2 h3;
  revert y;
  intros y h1 h3;
  apply Eq.trans;
  exact h3;
  exact h1
}

theorem simple16 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by {
  intros h1 h2 h3;
  try clear x; -- should fail
  clear h2;
  trace_state;
  apply Eq.trans;
  exact h3;
  exact h1
}

macro "blabla" : tactic => `(tactic| assumption)

-- Tactic head symbols do not become reserved words
def blabla := 100

#check blabla

theorem simple17 (x : Nat) (h : x = 0) : x = 0 :=
by blabla

theorem simple18 (x : Nat) (h : x = 0) : x = 0 :=
by blabla

theorem simple19 (x y : Nat) (h₁ : x = 0) (h₂ : x = y) : y = 0 :=
by subst x; subst y; exact rfl

theorem tstprec1 (x y z : Nat) : x + y * z = x + (y * z) :=
rfl

theorem tstprec2 (x y z : Nat) : y * z + x = (y * z) + x :=
rfl

set_option pp.all true

#check fun {α} (a : α) => a
#check @(fun α (a : α) => a)

#check
  let myid := fun {α} (a : α) => a;
  myid [myid 1]

-- In the following example, we need `@` otherwise we will try to insert mvars for α and [Add α],
-- and will fail to generate instance for [Add α]
#check @(fun α (s : Add α) (a : α) => a + a)

def g1 {α} (a₁ a₂ : α) {β} (b : β) : α × α × β :=
(a₁, a₂, b)

def id1 : {α : Type} → α → α :=
fun x => x

def listId : List ({α : Type} → α → α) :=
(fun x => x) :: []

def id2 : {α : Type} → α → α :=
@(fun α (x : α) => id1 x)

def id3 : {α : Type} → α → α :=
@(fun α x => id1 x)

def id4 : {α : Type} → α → α :=
fun x => id1 x

def id5 : {α : Type} → α → α :=
fun {α} x => id1 x

def id6 : {α : Type} → α → α :=
@(fun {α} x => id1 x)

def id7 : {α : Type} → α → α :=
fun {α} x => @id α x

def id8 : {α : Type} → α → α :=
fun {α} x => id (@id α x)

def altTst1 {m σ} [Alternative m] [Monad m] : Alternative (StateT σ m) :=
⟨StateT.failure, StateT.orElse⟩

def altTst2 {m σ} [Alternative m] [Monad m] : Alternative (StateT σ m) :=
⟨@(fun α => StateT.failure), @(fun α => StateT.orElse)⟩

def altTst3 {m σ} [Alternative m] [Monad m] : Alternative (StateT σ m) :=
⟨fun {α} => StateT.failure, fun {α} => StateT.orElse⟩

#check_failure 1 + true

/-
universe u v

/-
  MonadFunctorT.{u ?M_1 v} (λ (β : Type u), m α) (λ (β : Type u), m' α) n n'
-/
set_option pp.raw.maxDepth 100
set_option trace.Elab true

def adapt {m m' σ σ'} {n n' : Type → Type} [MonadFunctor m m' n n'] [MonadStateAdapter σ σ' m m'] : MonadStateAdapter σ σ' n n' :=
⟨fun split join => monadMap (adaptState split join : m α → m' α)⟩

-/

syntax "fn" (term:max)+ "=>" term : term

macro_rules
| `(fn $xs* => $b) => `(fun $xs* => $b)

set_option pp.all false

#check fn x => x+1

#check fn α (a : α) => a

def tst1 : {α : Type} → α → α :=
@(fn α a => a)

#check @tst1

syntax ident "==>" term : term

syntax "{" ident "}" "==>" term : term

macro_rules
| `($x:ident ==> $b)   => `(fn $x => $b)
| `({$x:ident} ==> $b) => `(fun {$x:ident} => $b)

#check x ==> x+1

def tst2a : {α : Type} → α → α :=
@(α ==> a ==> a)

def tst2b : {α : Type} → α → α :=
{α} ==> a ==> a

#check @tst2a
#check @tst2b

def tst3a : {α : Type} → {β : Type} → α → β → α × β :=
@(α ==> @(β ==> a ==> b ==> (a, b)))

def tst3b : {α : Type} → {β : Type} → α → β → α × β :=
{α} ==> {β} ==> a ==> b ==> (a, b)

syntax "function" (term:max)+ "=>" term : term

macro_rules
| `(function $xs* => $b) => `(@(fun $xs* => $b))

def tst4 : {α : Type} → {β : Type} → α → β → α × β :=
function α β a b => (a, b)

theorem simple20 (x y z : Nat) : y = z → x = x → x = y → x = z :=
by intros h1 h2 h3;
   try clear x; -- should fail
   clear h2;
   trace_state;
   apply Eq.trans;
   exact h3;
   exact h1

theorem simple21 (x y z : Nat) : y = z → x = x → y = x → x = z :=
fun h1 _ h3 =>
  have : x = y := by { apply Eq.symm; assumption };
  Eq.trans this (by assumption)

theorem simple22 (x y z : Nat) : y = z → y = x → id (x = z + 0) :=
fun h1 h2 => show x = z + 0 by
  apply Eq.trans
  exact h2.symm
  assumption
  skip

theorem simple23 (x y z : Nat) : y = z → x = x → y = x → x = z :=
fun h1 _ h3 =>
  have : x = y := by apply Eq.symm; assumption
  Eq.trans this (by assumption)

theorem simple24 (x y z : Nat) : y = z → x = x → y = x → x = z :=
fun h1 _ h3 =>
  have h : x = y := by apply Eq.symm; assumption
  Eq.trans h (by assumption)

def f1 (x : Nat) : Nat :=
  let double x := x + x
  let rec loop x :=
    match x with
    | 0   => 0
    | x+1 => loop x + double x
  loop x

#eval f1 5

def f2 (x : Nat) : String :=
  let bad x : String := toString x
  bad x

def f3 x y :=
  x + y + 1

theorem f3eq x y : f3 x y = x + y + 1 :=
  rfl

def f4 (x y : Nat) : String :=
  if x > y + 1 then "hello" else "world"


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz, Johan Commelin, Joël Riou
-/
import category_theory.preadditive.additive_functor
import logic.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma unop_zsmul {X Y : Cᵒᵖ} (k : ℤ) (f : X ⟶ Y) : (k • f).unop = k • f.unop := rfl
@[simp] lemma unop_neg {X Y : Cᵒᵖ}(f : X ⟶ Y) : (-f).unop = -(f.unop) := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp]

variable {C}

/-- `unop` induces morphisms of monoids on hom groups of a preadditive category -/
@[simps] def unop_hom (X Y : Cᵒᵖ) : (X ⟶ Y) →+ (opposite.unop Y ⟶ opposite.unop X) :=
add_monoid_hom.mk' (λ f, f.unop) $ λ f g, unop_add _ f g

@[simp] lemma unop_sum (X Y : Cᵒᵖ) {ι : Type*} (s : finset ι) (f : ι → (X ⟶ Y)) :
  (s.sum f).unop = s.sum (λ i, (f i).unop) :=
(unop_hom X Y).map_sum _ _

/-- `op` induces morphisms of monoids on hom groups of a preadditive category -/
@[simps] def op_hom (X Y : C) : (X ⟶ Y) →+ (opposite.op Y ⟶ opposite.op X) :=
add_monoid_hom.mk' (λ f, f.op) $ λ f g, op_add _ f g

@[simp] lemma op_sum (X Y : C) {ι : Type*} (s : finset ι) (f : ι → (X ⟶ Y)) :
  (s.sum f).op = s.sum (λ i, (f i).op) :=
(op_hom X Y).map_sum _ _

variables {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.coercions.instances

/-!
# Appending Simulation Oracles

This file defines an append operation `++ₛ` for simulation oracles,
creating a simulation oracle for a combined set of initial oracles.
In particular, if simulation oracles `so` and `so'` have starting oracles given by
`spec` and `spec'`, then `so ++ₛ so'` will have starting oracles `spec ++ spec'`.

The implementation just maintains a seperate state for each oracle,
using pattern matching on queries to decide which `sim_oracle` to call.
-/

open oracle_comp oracle_spec

variables {spec spec' spec'' spec''' : oracle_spec} {α β γ : Type} {S S' : Type}

namespace sim_oracle

def oracle_append (so : sim_oracle spec spec'' S) (so' : sim_oracle spec' spec'' S') :
  sim_oracle (spec ++ spec') spec'' (S × S') :=
{ default_state := (so.default_state, so'.default_state),
  o := λ i, match i with
  | (sum.inl i) := λ ⟨t, s₁, s₂⟩, do {⟨u, s₁'⟩ ← so i (t, s₁), return (u, s₁', s₂)}
  | (sum.inr i) := λ ⟨t, s₁, s₂⟩, do {⟨u, s₂'⟩ ← so' i (t, s₂), return (u, s₁, s₂')}
  end }

infixl ` ++ₛ `:65 := oracle_append

namespace oracle_append

variables (so : sim_oracle spec spec'' S) (so' : sim_oracle spec' spec'' S')
  (oa : oracle_comp (spec ++ spec') α) (ob : α → oracle_comp (spec ++ spec') β) (a : α)
  (i : spec.ι) (i' : spec'.ι) (t : spec.domain i) (t' : spec'.domain i') (s : S × S')
  (x : spec.domain i × S × S') (x' : spec'.domain i' × S × S')

@[simp]
lemma apply_inl_eq : (so ++ₛ so') (sum.inl i) x =
  do {u_s' ← so i (x.1, x.2.1), return (u_s'.1, u_s'.2, x.2.2)} :=
begin
  cases x with t s, cases s with s₁ s₂,
  refine congr_arg (λ ou, so i (t, s₁) >>= ou) (funext $ λ y, _),
  cases y, refl,
end

@[simp]
lemma apply_inr_eq : (so ++ₛ so') (sum.inr i') x' =
  do {u_s' ← so' i' (x'.1, x'.2.2), return (u_s'.1, x'.2.1, u_s'.2)} :=
begin
  cases x' with t s, cases s with s₁ s₂,
  refine congr_arg (λ ou, so' i' (t, s₂) >>= ou) (funext $ λ y, _),
  cases y, refl,
end

section support

lemma support_apply_inl : ((so ++ₛ so') (sum.inl i) (t, s)).support =
  {x | (x.1, x.2.1) ∈ (so i (t, s.1)).support ∧ x.2.2 = s.2} :=
begin
  ext x,
  simp only [apply_inl_eq, support_bind, support_return, set.mem_Union,
    set.mem_singleton_iff, exists_prop, prod.exists, set.mem_set_of_eq],
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨u, s', hu, hx⟩ := h,
    simpa only [hx, eq_self_iff_true, and_true] using hu },
  { refine ⟨x.1, x.2.1, _⟩,
    simp only [← h.2, h.1, true_and, prod.mk.eta] }
end

lemma support_apply_inr : ((so ++ₛ so') (sum.inr i') (t', s)).support =
  {x | (x.1, x.2.2) ∈ (so' i' (t', s.2)).support ∧ x.2.1 = s.1} :=
begin
  ext x,
  simp only [apply_inr_eq, support_bind, support_return, set.mem_Union,
    set.mem_singleton_iff, exists_prop, prod.exists, set.mem_set_of_eq],
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨u, s', hu, hx⟩ := h,
    simpa only [hx, eq_self_iff_true, and_true] using hu },
  { refine ⟨x.1, x.2.2, _⟩,
    simp only [← h.2, h.1, true_and, prod.mk.eta] }
end

end support

section coe_append_right

/-- Coercing a computation on `spec` to one on `spec ++ spec'`, and then simulating with
two independent oracles `so ++ₛ so'` has the same support as simulating the original with `so`,
modulo the extra oracle state for the right oracle, which remains unchanged during simulation. -/
@[simp] lemma support_simulate_coe_append_right (s : S × S') (oa : oracle_comp spec α) :
  (simulate (so ++ₛ so') ↑oa s).support =
    (λ (x : α × S), (x.1, x.2, s.2)) '' (simulate so oa s.1).support :=
calc (simulate (so ++ₛ so') ↑oa s).support =
    (simulate (so ++ₛ so') ↑oa ((λ s₁, (s₁, s.2)) s.1)).support : by simp only [prod.mk.eta]
    ... = prod.map id (λ s₁, (s₁, s.2)) '' (simulate so oa s.1).support : begin
      refine (support_simulate_coe_sub_spec so (so ++ₛ so') s.1 oa _ (λ i t s, _)),
      simp_rw [is_sub_spec_append_right_apply, simulate_query, apply_inl_eq,
        support_bind_return, prod_map, id.def],
    end
    ... = (λ (x : α × S), (x.1, x.2, s.2)) '' (simulate so oa s.1).support : rfl

/-- Coercing a computation on `spec` to one on `spec ++ spec'`, and then simulating with
two independent oracles `so ++ₛ so'` has the same support as simulating the original with `so`,
if we use `simulate'` to ignore the final oracle state of the two `sim_oracle`s. -/
@[simp] lemma support_simulate'_coe_append_right (so : sim_oracle spec spec'' S)
  (so' : sim_oracle spec' spec'' S') (s : S × S') (oa : oracle_comp spec α) :
  (simulate' (so ++ₛ so') ↑oa s).support = (simulate' so oa s.1).support :=
set.ext (λ x, by simp only [support_simulate', support_simulate_coe_append_right, set.image_image])

end coe_append_right

end oracle_append

end sim_oracle


/-
This is the final correctenss theorem, stated in terms of the autogenerated constraints.

The statements of theorems only depend on the data and constraints specified in
`constraints_autogenerated.lean` and the machine semantics in `cpu.lean`.
-/
import starkware.cairo.lean.semantics.air_encoding.correctness
import starkware.cairo.lean.semantics.air_encoding.glue

noncomputable theory
open_locale classical
open_locale big_operators

variables {F : Type} [field F] [fintype F]

/-
These are the constraints that the verifier has to check against the public data.
-/

structure public_constraints (inp : input_data F) (pd : public_data F) : Prop :=
(h_mem_star :
  let z     := pd.memory__multi_column_perm__perm__interaction_elm,
      alpha := pd.memory__multi_column_perm__hash_interaction_elm0,
      p     := pd.memory__multi_column_perm__perm__public_memory_prod,
      dom_m_star := { x // option.is_some (inp.m_star x) } in
    p * ∏ a : dom_m_star, (z - (a.val + alpha * mem_val a)) = z^(fintype.card dom_m_star))
(h_card_dom : 8 * fintype.card { x // option.is_some (inp.m_star x) } + 2 ≤ inp.trace_length)
(public_memory_prod_eq_one : pd.rc16__perm__public_memory_prod = 1)
(rc_max_lt : pd.rc_max < 2^16)
(rc_min_le : pd.rc_min ≤ pd.rc_max)
(trace_length_le_char : inp.trace_length ≤ ring_char F)

/-
The main correctness theorem.
-/

theorem final_correctness
    (char_ge : ring_char F ≥ 2^63)
    /- public data -/
    (inp     : input_data F)
    (pd      : public_data F)
    (pc      : public_constraints inp pd)
    (c       : columns F) :
    /- sets to avoid -/
  ∃ bad1
    bad2
    bad3     : finset F,
    bad1.card ≤ (inp.trace_length / 2)^2 ∧
    bad2.card ≤ inp.trace_length / 2 ∧
    bad3.card ≤ inp.trace_length ∧
  ∀ ci       : columns_inter F,
      /- autogenerated constraints-/
      cpu__decode c ∧
      cpu__operands c ∧
      cpu__update_registers inp c ∧
      cpu__opcodes c ∧
      memory inp pd c ci ∧
      rc16 inp pd c ci ∧
      public_memory c ∧
      rc_builtin inp pd c ∧
      toplevel_constraints inp c ∧
      /- probabilistic constraints -/
      pd.memory__multi_column_perm__hash_interaction_elm0 ∉ bad1 ∧
      pd.memory__multi_column_perm__perm__interaction_elm ∉ bad2 ∧
      pd.memory__multi_column_perm__perm__interaction_elm ≠ 0 ∧
      pd.rc16__perm__interaction_elm ∉ bad3 →
      let -- number of execution steps
          T := inp.trace_length / 16 - 1,
          -- memory elements checked by range check builtin
          rc_len := inp.trace_length / 128 in
      /- the conclusion -/
      ∃ mem : F → F,
        option.fn_extends mem inp.m_star ∧
        (∀ i < rc_len, ∃ n < 2^128, mem (pd.initial_rc_addr + i) = ↑n) ∧
        ∃ exec : fin (T + 1) → register_state F,
          (exec 0).pc = inp.initial_pc ∧
          (exec 0).ap = inp.initial_ap ∧
          (exec 0).fp = inp.initial_ap ∧
          (exec (fin.last T)).pc = inp.final_pc ∧
          (exec (fin.last T)).ap = inp.final_ap ∧
          ∀ i : fin T, next_state mem (exec i.cast_succ) (exec i.succ) :=
begin
  use bad1 pc.h_card_dom c.column19 c.column20,
  use bad2 pd pc.h_card_dom c.column19 c.column20,
  use bad3 inp c.column0 c.column2,
  use bad1_bound pc.h_card_dom _ _,
  use bad2_bound pd pc.h_card_dom _ _,
  use bad3_bound pc.h_card_dom _ _,
  intro ci,
  rintros ⟨cd, ops, upd, opcodes, m, rc, pm, rcb, iandf, prob1, prob2, prob3, prob4⟩,
  dsimp,
  exact execution_exists char_ge
    (inp.to_input_data_aux pd pc.rc_max_lt pc.rc_min_le)
    (to_constraints cd ops upd opcodes m rc pm rcb iandf pc.h_mem_star pc.h_card_dom
      pc.public_memory_prod_eq_one pc.rc_max_lt pc.rc_min_le pc.trace_length_le_char)
    { hprob₁ := prob1,
      hprob₂ := prob2,
      hprob₃ := prob3,
      hprob₄ := prob4 }
end


example (A B C D E F G H I J K L : Prop)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L :=
begin
cc,
end


import mathlib.prod
import group_theory.group_action.sigma
import phase1.code_equiv

/-!
# Allowable permutations
-/

-- Note to whoever fixes this file: We may want to use `type_index` instead of `Λ` in some places
-- now that supports are defined in these cases.

open function set with_bot
open_locale pointwise

noncomputable theory

universe u

namespace con_nf
variables [params.{u}] (α : Λ) [core_tangle_cumul α] (β : Iio_index α) (γ : Iio α)

open code

/-- A semi-allowable permutation is a `-1`-allowable permutation of atoms (a near-litter
permutation) together with allowable permutations on all `γ < β`. This forms a group structure
automatically. -/
@[derive group] def semiallowable_perm : Type u := Π β : Iio_index α, allowable β

namespace semiallowable_perm
variables {α} (π : semiallowable_perm α) (c : code α)

/-- The allowable permutation at a lower level corresponding to a semi-allowable permutation. -/
noncomputable! def to_allowable : semiallowable_perm α →* allowable β :=
⟨λ f, f β, rfl, λ _ _, rfl⟩

/-- Reinterpret a semi-allowable permutation as a structural permutation. -/
noncomputable! def to_struct_perm : semiallowable_perm α →* struct_perm α :=
{ to_fun := λ f, struct_perm.to_coe $ λ β hβ, (f ⟨β, hβ⟩).to_struct_perm,
  map_one' := struct_perm.of_coe.injective $ funext $ λ β, funext $ λ hβ, match β, hβ with
    | ⊥, _ := by { simp only [struct_perm.of_coe_to_coe, struct_perm.of_coe_one, pi.one_apply],
      exact struct_perm.to_bot_one }
    | (β : Λ), (hβ : ↑β < ↑α) := by { simp only [struct_perm.of_coe_to_coe, struct_perm.of_coe_one,
      pi.one_apply], exact allowable.to_struct_perm.map_one }
  end,
  map_mul' := λ f g, struct_perm.of_coe.injective $ funext $ λ β, funext $ λ hβ, match β, hβ with
    | ⊥, _ := by { simp only [struct_perm.of_coe_to_coe, struct_perm.of_coe_mul, pi.mul_apply],
      exact struct_perm.to_bot_mul _ _ }
    | (β : Λ), (hβ : ↑β < ↑α) := by { simp only [struct_perm.of_coe_to_coe, struct_perm.of_coe_mul,
      pi.mul_apply], exact allowable.to_struct_perm.map_mul _ _ }
  end }

section
variables {X : Type*} [mul_action (struct_perm α) X]

instance mul_action_of_struct_perm : mul_action (semiallowable_perm α) X :=
mul_action.comp_hom _ to_struct_perm

@[simp] lemma to_struct_perm_smul (f : semiallowable_perm α) (x : X) :
  f.to_struct_perm • x = f • x := rfl

end

instance mul_action_tangle : mul_action (semiallowable_perm α) (tangle β) :=
mul_action.comp_hom _ $ to_allowable β

instance mul_action_tangle' {β : Iio α} : mul_action (semiallowable_perm α) (tangle β) :=
show mul_action (semiallowable_perm α) (tangle $ Iio_coe β), from infer_instance

instance mul_action_tangle'' : mul_action (semiallowable_perm α) (tangle (γ : Λ)) :=
show mul_action (semiallowable_perm α) (tangle $ Iio_coe γ), from infer_instance

@[simp] lemma to_allowable_smul (f : semiallowable_perm α) (t : tangle β) :
  to_allowable β f • t = f • t := rfl

attribute [derive mul_action (semiallowable_perm α)] code

@[simp] lemma fst_smul : (π • c).1 = c.1 := rfl
@[simp] lemma snd_smul : (π • c).2 = π • c.2 := rfl
@[simp] lemma smul_mk (f : semiallowable_perm α) (γ s) : f • (mk γ s : code α) = mk γ (f • s) := rfl

instance has_smul_nonempty_code : has_smul (semiallowable_perm α) (nonempty_code α) :=
⟨λ π c, ⟨π • c, c.2.image _⟩⟩

@[simp, norm_cast] lemma coe_smul (c : nonempty_code α) : (↑(π • c) : code α) = π • c := rfl

instance mul_action_nonempty_code : mul_action (semiallowable_perm α) (nonempty_code α) :=
subtype.coe_injective.mul_action _ coe_smul

end semiallowable_perm

variables [position_data.{}] [positioned_tangle_cumul α] [almost_tangle_cumul α]
  [core_tangle_data α]

/-- An allowable permutation is a semi-allowable permutation whose action on codes preserves
equivalence. -/
def allowable_perm := {π : semiallowable_perm α // ∀ X Y : code α, π • X ≡ π • Y ↔ X ≡ Y}

variables {α} {f : allowable_perm α} {c d : code α}

namespace allowable_perm

instance : has_coe_t (allowable_perm α) (semiallowable_perm α) := @coe_base _ _ coe_subtype

lemma coe_injective : injective (coe : allowable_perm α → semiallowable_perm α) :=
subtype.coe_injective

instance : has_one (allowable_perm α) := ⟨⟨1, λ _ _, by simp_rw one_smul⟩⟩
instance : has_inv (allowable_perm α) :=
⟨λ f, ⟨f⁻¹, λ c d, by rw [←f.prop, smul_inv_smul, smul_inv_smul]⟩⟩
instance : has_mul (allowable_perm α) :=
⟨λ f g, ⟨f * g, λ c d, by simp_rw [mul_smul, f.prop, g.prop]⟩⟩
instance : has_div (allowable_perm α) :=
⟨λ f g, ⟨f / g, by { simp_rw [div_eq_mul_inv], exact (f * g⁻¹).2 }⟩⟩
instance : has_pow (allowable_perm α) ℕ :=
⟨λ f n, ⟨f ^ n, begin
  induction n with d hd,
  { simp_rw pow_zero,
    exact (1 : allowable_perm α).2 },
  { simp_rw pow_succ,
    exact (f * ⟨f ^ d, hd⟩).2 }
end⟩⟩

instance : has_pow (allowable_perm α) ℤ :=
⟨λ f n, ⟨f ^ n, begin
  cases n,
  { simp_rw zpow_of_nat,
    exact (f ^ n).2 },
  { simp_rw zpow_neg_succ_of_nat,
    exact (f ^ (n + 1))⁻¹.2 }
end⟩⟩

@[simp] lemma coe_one : ((1 : allowable_perm α) : semiallowable_perm α) = 1 := rfl
@[simp] lemma coe_inv (f : allowable_perm α) : (↑(f⁻¹) : semiallowable_perm α) = f⁻¹ := rfl
@[simp] lemma coe_mul (f g : allowable_perm α) : (↑(f * g) : semiallowable_perm α) = f * g := rfl
@[simp] lemma coe_div (f g : allowable_perm α) : (↑(f / g) : semiallowable_perm α) = f / g := rfl
@[simp] lemma coe_pow (f : allowable_perm α) (n : ℕ) :
  (↑(f ^ n) : semiallowable_perm α) = f ^ n := rfl
@[simp] lemma coe_zpow (f : allowable_perm α) (n : ℤ) :
  (↑(f ^ n) : semiallowable_perm α) = f ^ n := rfl

instance : group (allowable_perm α) :=
coe_injective.group _ coe_one coe_mul coe_inv coe_div coe_pow coe_zpow

/-- The coercion from allowable to semi-allowable permutation as a monoid homomorphism. -/
@[simps] noncomputable! def coe_hom : allowable_perm α →* semiallowable_perm α :=
⟨coe, coe_one, coe_mul⟩

/-- Turn an allowable permutation into a structural permutation. -/
def to_struct_perm : allowable_perm α →* struct_perm α :=
semiallowable_perm.to_struct_perm.comp coe_hom

section
variables {X : Type*} [mul_action (semiallowable_perm α) X]

instance mul_action_of_semiallowable_perm : mul_action (allowable_perm α) X :=
mul_action.comp_hom _ coe_hom

@[simp] lemma coe_smul (f : allowable_perm α) (x : X) : (f : semiallowable_perm α) • x = f • x :=
rfl

end

@[simp] lemma fst_smul_near_litter (f : allowable_perm α) (N : near_litter) : (f • N).1 = f • N.1 :=
rfl
@[simp] lemma snd_smul_near_litter (f : allowable_perm α) (N : near_litter) :
  ((f • N).2 : set atom) = f • ↑N.2 := rfl

@[simp] lemma smul_typed_near_litter (f : allowable_perm α) (N : near_litter) :
  f • (typed_near_litter N : tangle (γ : Λ)) =
    typed_near_litter ((f : semiallowable_perm α) γ • N) :=
allowable.smul_typed_near_litter _ _

@[simp] lemma fst_smul (f : allowable_perm α) (c : code α) : (f • c).1 = c.1 := rfl
@[simp] lemma snd_smul (f : allowable_perm α) (c : code α) : (f • c).2 = f • c.2 := rfl
@[simp] lemma smul_mk (f : allowable_perm α) (γ s) : f • (mk γ s : code α) = mk γ (f • s) := rfl

lemma _root_.con_nf.code.equiv.smul : c ≡ d → f • c ≡ f • d := (f.2 _ _).2

end allowable_perm

namespace allowable_perm
variables {β γ}

lemma smul_f_map (hβγ : β ≠ γ) (π : allowable_perm α) (t : tangle β) :
  ((π : semiallowable_perm α) γ) • f_map (coe_ne hβγ) t = f_map (coe_ne hβγ) (π • t) :=
begin
  classical,
  have equiv := code.equiv.singleton hβγ t,
  rw ← π.prop at equiv,
  simp only [subtype.val_eq_coe, rec_bot_coe_coe, image_smul, smul_set_singleton] at equiv,
  simp only [code.equiv_iff] at equiv,
  obtain a | ⟨heven, ε, hε, hA⟩ | ⟨heven, ε, hε, hA⟩ | ⟨c, heven, ε, hε, ζ, hζ, h₁, h₂⟩ := equiv,
  { cases hβγ.symm (congr_arg sigma.fst a) },
  { simp_rw [semiallowable_perm.smul_mk, smul_set_singleton] at hA,
    cases A_map_code_ne_singleton _ hA.symm,
    exact hβγ.symm },
  { have := congr_arg sigma.fst hA,
    simp only [semiallowable_perm.smul_mk, fst_A_map_code, fst_mk, Iio.coe_inj] at this,
    subst this,
    simp only [semiallowable_perm.smul_mk, A_map_code_ne _ (mk β _) hβγ, mk_inj] at hA,
    simp only [coe_smul, snd_mk, smul_set_singleton, A_map_singleton] at hA,
    simp only [← image_smul, image_image, smul_typed_near_litter] at hA,
    rw ← image_image at hA,
    rw image_eq_image typed_near_litter.injective at hA,
    have := litter.to_near_litter_mem_local_cardinal (f_map (coe_ne hβγ) (π • t)),
    rw ← hA at this,
    obtain ⟨N, hN₁, hN₂⟩ := this,
    have := congr_arg sigma.fst hN₂,
    simp only [litter.to_near_litter_fst] at this,
    rw [← allowable.to_struct_perm_smul, struct_perm.smul_near_litter_fst,
      allowable.to_struct_perm_smul] at this,
    rw mem_local_cardinal at hN₁,
    rw hN₁ at this,
    exact this },
  { have := congr_arg sigma.fst h₁,
    simp only [coe_smul, smul_mk, fst_mk, fst_A_map_code] at this,
    subst this,
    simp only [coe_smul, smul_mk, smul_set_singleton] at h₁,
    cases A_map_code_ne_singleton hε h₁.symm }
end

lemma smul_A_map (π : allowable_perm α) (s : set (tangle β)) (hβγ : β ≠ γ) :
  π • A_map hβγ s = A_map hβγ (π • s) :=
begin
  ext,
  simp only [A_map, mem_image, mem_Union, mem_local_cardinal, exists_prop, ← image_smul],
  simp only [exists_exists_and_eq_and, smul_typed_near_litter, ← smul_f_map hβγ],
  split,
  { rintro ⟨N, ⟨y, y_mem, y_fmap⟩, rfl⟩,
    refine ⟨(π : semiallowable_perm α) γ • N, ⟨y, y_mem, _⟩, rfl⟩,
    rw ← y_fmap,
    refl },
  { rintro ⟨N, ⟨y, y_mem, y_fmap⟩, rfl⟩,
    refine ⟨((π : semiallowable_perm α) γ)⁻¹ • N, ⟨y, y_mem, _⟩, _⟩,
    { change _ • N.fst = _,
      simp only [y_fmap, map_inv, inv_smul_eq_iff],
      refl },
    { simp only [smul_inv_smul] } },
end

lemma smul_A_map_code (π : allowable_perm α) (hc : c.1 ≠ γ) :
  π • A_map_code γ c = A_map_code γ (π • c) :=
by simp only [A_map_code_ne γ c hc, A_map_code_ne γ (π • c) hc, smul_A_map, snd_smul, smul_mk]

end allowable_perm

lemma A_map_rel.smul : c ↝ d → f • c ↝ f • d :=
by { rintro ⟨γ, hγ⟩, exact (A_map_rel_iff _ _).2 ⟨_, hγ, f.smul_A_map_code hγ⟩ }

@[simp] lemma smul_A_map_rel : f • c ↝ f • d ↔ c ↝ d :=
by { refine ⟨λ h, _, A_map_rel.smul⟩, rw [←inv_smul_smul f c, ←inv_smul_smul f d], exact h.smul }

namespace code

lemma is_even_smul_nonempty : ∀ (c : nonempty_code α), (f • c.val).is_even ↔ c.val.is_even
| ⟨c, hc⟩ := begin
  simp_rw code.is_even_iff,
  split; intros h d hd,
  { have := hd.nonempty_iff.2 hc,
    let rec : A_map_rel' ⟨d, this⟩ ⟨c, hc⟩ := A_map_rel_coe_coe.1 hd,
    exact code.not_is_even.1 (λ H, (h _ hd.smul).not_is_even $
      (is_even_smul_nonempty ⟨d, this⟩).2 H) },
  { rw ←smul_inv_smul f d at hd ⊢,
    rw smul_A_map_rel at hd,
    have := hd.nonempty_iff.2 hc,
    let rec : A_map_rel' ⟨_, this⟩ ⟨c, hc⟩ := A_map_rel_coe_coe.1 hd,
    exact code.not_is_even.1 (λ H, (h _ hd).not_is_even $ (is_even_smul_nonempty ⟨_, this⟩).1 H) }
end
using_well_founded { dec_tac := `[assumption] }

@[simp] lemma is_even_smul : (f • c).is_even ↔ c.is_even :=
begin
  cases c.2.eq_empty_or_nonempty,
  { rw [is_empty.is_even_iff h, is_empty.is_even_iff],
    { refl },
    simpa [code.is_empty] },
  { exact is_even_smul_nonempty ⟨c, h⟩ }
end

@[simp] lemma is_odd_smul : (f • c).is_odd ↔ c.is_odd :=
by simp_rw [←code.not_is_even, is_even_smul]

alias is_even_smul ↔ _ is_even.smul
alias is_odd_smul ↔ _ is_odd.smul

end code
end con_nf


import language_extension

namespace fol
namespace Lhom

universe u

variables {L L' : Language.{u}} {ϕ : L →ᴸ L'}

/-- restatement of `Lhom.reduct_all_ssatisfied` -/
def reduct_Theory_induced {S : Structure L'} {T : Theory L} (hϕ : ϕ.is_injective)
  (h : S ⊨ Theory_induced ϕ T) : S[[ϕ]] ⊨ T :=
reduct_all_ssatisfied hϕ h

namespace sum

lemma is_injective_inl : (@Lhom.sum_inl L L').is_injective :=
{ on_function := λ n x y hxy, sum.inl.inj hxy,
  on_relation := λ n x y hxy, sum.inl.inj hxy, }

lemma is_injective_inr : (@Lhom.sum_inr L L').is_injective :=
{ on_function := λ n x y hxy, sum.inr.inj hxy,
  on_relation := λ n x y hxy, sum.inr.inj hxy, }

end sum
end Lhom
end fol


import GMLInit.Data.Set.Basic
import GMLInit.Data.Set.Insert

set_option checkBinderAnnotations false in
class inductive Set.IsSubfinite : Set α → Prop
| protected empty : IsSubfinite Set.empty
| protected insertIf (s : Set α) [inst : IsSubfinite s] (a : α) (p : Prop := True) : IsSubfinite (s.insertIf a p)
attribute [instance] Set.IsSubfinite.empty Set.IsSubfinite.insertIf

namespace Set.IsSubfinite
open Set Set.Notation

protected instance pure (x : α) : IsSubfinite (Set.pure x) := by
  have : Set.pure x = Set.empty.insertIf x True := by
    apply Set.ext
    intro x
    constr
    · intro h
      cases h
      left
      constr
      · rfl
      · trivial
    · intro
      | Or.inl ⟨h,_⟩ => cases h; rfl
      | Or.inr h => contradiction
  rw [this]
  infer_instance

protected instance union (s t : Set α) [hs : IsSubfinite s] [ht : IsSubfinite t] : IsSubfinite (Set.union s t) := by
  induction hs with
  | empty =>
    rw [empty_union]
    exact ht
  | insertIf s a p H =>
    rw [insertIf_union_left]
    exact IsSubfinite.insertIf (inst:=H) (p := p) ..

protected instance inter_left (s t : Set α) [hs : IsSubfinite s] : IsSubfinite (Set.inter s t) := by
  induction hs with
  | empty =>
    rw [empty_inter]
    exact IsSubfinite.empty
  | insertIf s a p H =>
    rw [insertIf_inter_left]
    exact IsSubfinite.insertIf (inst:=H) (p := p ∧ a ∈ t) ..

protected instance inter_right (s t : Set α) [ht : IsSubfinite t] : IsSubfinite (Set.inter s t) := by
  induction ht with
  | empty =>
    rw [inter_empty]
    exact IsSubfinite.empty
  | insertIf t a p H =>
    rw [insertIf_inter_right]
    exact IsSubfinite.insertIf (inst:=H) (p := p ∧ a ∈ s) ..

protected instance map (f : α → β) (s : Set α) [hs : IsSubfinite s] : IsSubfinite (s.map f) := by
  induction hs with
  | empty =>
    rw [empty_map]
    exact IsSubfinite.empty
  | insertIf s a p H =>
    rw [insertIf_map]
    exact IsSubfinite.insertIf (inst:=H) (p := p) ..

protected instance bind (f : α → Set β) [hf : (x : α) → IsSubfinite (f x)] (s : Set α) [hs : IsSubfinite s] : IsSubfinite (s.bind f) := by
  induction hs with
  | empty =>
    rw [empty_bind]
    exact IsSubfinite.empty
  | insertIf s a p H =>
    rw [insertIf_bind]
    exact IsSubfinite.union (ht:=H) ..

protected instance seq (f : Set (α → β)) [hf : IsSubfinite f] (s : Set α) [hs : IsSubfinite s] : IsSubfinite (Set.seq f s) := by
  induction hs with
  | empty =>
    rw [empty_seq]
    exact IsSubfinite.empty
  | insertIf s a p H =>
    rw [insertIf_seq]
    exact IsSubfinite.union (ht:=H) ..

protected instance seqLeft (s : Set α) [hs : IsSubfinite s] (t : Set β) [ht : IsSubfinite t] : IsSubfinite (Set.seqLeft s t) := by
  clean unfold Set.seqLeft
  infer_instance

protected instance seqRight (s : Set α) [hs : IsSubfinite s] (t : Set β) [ht : IsSubfinite t] : IsSubfinite (Set.seqRight s t) := by
  clean unfold Set.seqRight
  infer_instance

end Set.IsSubfinite

structure Subfinset (α) extends Set α where
  isSubfinite : toSet.IsSubfinite
attribute [instance] Subfinset.isSubfinite

instance (α) : CoeSort (Subfinset α) (Set α) := ⟨Subfinset.toSet⟩

protected theorem Subfinset.eq {α} : {s t : Subfinset α} → s.toSet = t.toSet → s = t
| ⟨_,_⟩, ⟨_,_⟩, rfl => rfl

protected theorem Subfinset.ext {α} {s t : Subfinset α} : (∀ x, s.Mem x ↔ t.Mem x) → s = t :=
  λ h => Subfinset.eq (Set.ext h)

instance : Monad Subfinset where
  pure a := ⟨pure a, Set.IsSubfinite.pure a⟩
  map f s := ⟨f <$> s.toSet, Set.IsSubfinite.map f s.toSet⟩
  bind s f := ⟨s.toSet >>= λ x => (f x).toSet, Set.IsSubfinite.bind (λ x => (f x).toSet) s.toSet⟩
  seq f s := ⟨f.toSet <*> (s ()).toSet, Set.IsSubfinite.seq f.toSet (s ()).toSet⟩
  seqLeft s t := ⟨s.toSet <* (t ()).toSet, Set.IsSubfinite.seqLeft s.toSet (t ()).toSet⟩
  seqRight s t := ⟨s.toSet *> (t ()).toSet, Set.IsSubfinite.seqRight s.toSet (t ()).toSet⟩

instance : LawfulMonad Subfinset where
  id_map := by
    intro _ ⟨_,_⟩
    apply Subfinset.eq
    simp only [Functor.map, Set.id_map]
  comp_map := by
    intro _ _ _ f g ⟨_,_⟩
    apply Subfinset.eq
    simp only [Functor.map, Set.comp_map]
  map_const := by intros; rfl
  map_pure f a := by
    apply Subfinset.eq
    simp only [Functor.map, Pure.pure, Set.map_pure]
  pure_bind := by
    intros
    apply Subfinset.eq
    simp only [Bind.bind, Pure.pure, Set.pure_bind]
  bind_assoc := by
    intros
    apply Subfinset.eq
    simp only [Bind.bind, Set.bind_assoc]
  bind_pure_comp := by
    intros
    apply Subfinset.eq
    simp only [Bind.bind, Pure.pure, Functor.map, Set.bind_pure_comp]
  bind_map := by
    intros
    apply Subfinset.eq
    simp only [Bind.bind, Functor.map, Seq.seq, Set.bind_map]
  pure_seq f s := by
    intros
    apply Subfinset.eq
    simp only [Seq.seq, Pure.pure, Functor.map, Set.pure_seq]
  seq_assoc := by
    intros
    apply Subfinset.eq
    simp only [Seq.seq, Functor.map, Set.seq_assoc]
  seqLeft_eq _ _ := rfl
  seqRight_eq _ _ := rfl