/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin, Andrew Yang
-/
import category_theory.limits.preserves.shapes.zero
import category_theory.monoidal.End
import category_theory.monoidal.discrete

/-!
# Shift

A `shift` on a category `C` indexed by a monoid `A` is is nothing more than a monoidal functor
from `A` to `C ⥤ C`. A typical example to keep in mind might be the category of
complexes `⋯ → C_{n-1} → C_n → C_{n+1} → ⋯`. It has a shift indexed by `ℤ`, where we assign to
each `n : ℤ` the functor `C ⥤ C` that re-indexing the terms, so the degree `i` term of `shift n C`
would be the degree `i+n`-th term of `C`.

## Main definitions
* `has_shift`: A typeclass asserting the existence of a shift functor.
* `shift_equiv`: When the indexing monoid is a group, then the functor indexed by `n` and `-n` forms
  an self-equivalence of `C`.
* `shift_comm`: When the indexing monoid is commutative, then shifts commute as well.

## Implementation Notes

Most of the definitions in this file is marked as an `abbreviation` so that the simp lemmas in
`category_theory/monoidal/End` could apply.

-/
namespace category_theory

noncomputable theory

universes v u

variables (C : Type u) (A : Type*) [category.{v} C]

local attribute [instance] endofunctor_monoidal_category
local attribute [reducible] endofunctor_monoidal_category discrete.add_monoidal

section eq_to_hom

variables {A C}

variables [add_monoid A] (F : monoidal_functor (discrete A) (C ⥤ C))

 @[simp, reassoc] lemma eq_to_hom_μ_app {i j i' j' : A} (h₁ : i = i') (h₂ : j = j') (X : C) :
   eq_to_hom (by rw [h₁, h₂]) ≫ (F.μ i' j').app X =
     (F.μ i j).app X ≫ eq_to_hom (by rw [h₁, h₂]) :=
 by { cases h₁, cases h₂, rw [eq_to_hom_refl, eq_to_hom_refl, category.id_comp, category.comp_id] }

 @[simp, reassoc] lemma μ_inv_app_eq_to_hom {i j i' j' : A} (h₁ : i = i') (h₂ : j = j') (X : C) :
   (F.μ_iso i j).inv.app X ≫ eq_to_hom (by rw [h₁, h₂]) =
     eq_to_hom (by rw [h₁, h₂]) ≫ (F.μ_iso i' j').inv.app X :=
 by { cases h₁, cases h₂, rw [eq_to_hom_refl, eq_to_hom_refl, category.id_comp, category.comp_id] }

end eq_to_hom

variables {A C}

/-- A monoidal functor from a group `A` into `C ⥤ C` induces
a self-equivalence of `C` for each `n : A`. -/
@[simps functor inverse unit_iso_hom unit_iso_inv counit_iso_hom counit_iso_inv]
def add_neg_equiv [add_group A] (F : monoidal_functor (discrete A) (C ⥤ C)) (n : A) : C ≌ C :=
equiv_of_tensor_iso_unit F n (-n : A)
  (eq_to_iso (add_neg_self n)) (eq_to_iso (neg_add_self n)) (subsingleton.elim _ _)

section defs

variables (A C) [add_monoid A]

/-- A category has a shift indexed by an additive monoid `A`
if there is a monoidal functor from `A` to `C ⥤ C`. -/
class has_shift (C : Type u) (A : Type*) [category.{v} C] [add_monoid A] :=
(shift : monoidal_functor (discrete A) (C ⥤ C))

/-- A helper structure to construct the shift functor `(discrete A) ⥤ (C ⥤ C)`. -/
@[nolint has_inhabited_instance]
structure shift_mk_core :=
(F : A → (C ⥤ C))
(ε : 𝟭 C ≅ F 0)
(μ : Π n m : A, F n ⋙ F m ≅ F (n + m))
(associativity : ∀ (m₁ m₂ m₃ : A) (X : C),
  (F m₃).map ((μ m₁ m₂).hom.app X) ≫ (μ (m₁ + m₂) m₃).hom.app X ≫
    eq_to_hom (by { congr' 2, exact add_assoc _ _ _ }) =
    (μ m₂ m₃).hom.app ((F m₁).obj X) ≫ (μ m₁ (m₂ + m₃)).hom.app X . obviously)
(left_unitality : ∀ (n : A) (X : C),
  (F n).map (ε.hom.app X) ≫ (μ 0 n).hom.app X =
    eq_to_hom (by { dsimp, rw zero_add }) . obviously)
(right_unitality : ∀ (n : A) (X : C),
  ε.hom.app ((F n).obj X) ≫ (μ n 0).hom.app X =
    eq_to_hom (by { dsimp, rw add_zero }) . obviously)

/-- Constructs a `has_shift C A` instance from `shift_mk_core`. -/
@[simps]
def has_shift_mk (h : shift_mk_core C A) : has_shift C A :=
⟨{ ε := h.ε.hom,
   μ := λ m n, (h.μ m n).hom,
   μ_natural' := by { rintros _ _ _ _ ⟨⟨rfl⟩⟩ ⟨⟨rfl⟩⟩, ext, dsimp, simp, dsimp, simp },
   associativity' := by { introv, ext, dsimp, simpa using h.associativity _ _ _ _, },
   left_unitality' :=
    by { introv, ext, dsimp, rw [category.id_comp, ← category.assoc, h.left_unitality], simp },
   right_unitality' :=
    by { introv, ext, dsimp, rw [functor.map_id, category.comp_id,
      ← category.assoc, h.right_unitality], simp },
 ..(discrete.functor h.F) }⟩

variables [has_shift C A]

/-- The monoidal functor from `A` to `C ⥤ C` given a `has_shift` instance. -/
def shift_monoidal_functor : monoidal_functor (discrete A) (C ⥤ C) := has_shift.shift

variable {A}

/-- The shift autoequivalence, moving objects and morphisms 'up'. -/
abbreviation shift_functor (i : A) : C ⥤ C := (shift_monoidal_functor C A).obj i

/-- Shifting by `i + j` is the same as shifting by `i` and then shifting by `j`. -/
abbreviation shift_functor_add (i j : A) :
  shift_functor C (i + j) ≅ shift_functor C i ⋙ shift_functor C j :=
((shift_monoidal_functor C A).μ_iso i j).symm

variables (A)

/-- Shifting by zero is the identity functor. -/
abbreviation shift_functor_zero : shift_functor C (0 : A) ≅ 𝟭 C :=
(shift_monoidal_functor C A).ε_iso.symm

-- Any better notational suggestions?
notation X`⟦`n`⟧`:20 := (shift_functor _ n).obj X
notation f`⟦`n`⟧'`:80 := (shift_functor _ n).map f

end defs

section examples
variables [has_shift C ℤ]

example {X Y : C} (f : X ⟶ Y) : X⟦(1 : ℤ)⟧ ⟶ Y⟦1⟧ := f⟦1⟧'
example {X Y : C} (f : X ⟶ Y) : X⟦(-2 : ℤ)⟧ ⟶ Y⟦-2⟧ := f⟦-2⟧'

end examples

section add_monoid

variables {C A} [add_monoid A] [has_shift C A] (X Y : C) (f : X ⟶ Y)

@[simp] lemma has_shift.shift_obj_obj (n : A) (X : C) : (has_shift.shift.obj n).obj X = X⟦n⟧ := rfl

/-- Shifting by `i + j` is the same as shifting by `i` and then shifting by `j`. -/
abbreviation shift_add (i j : A) : X⟦i + j⟧ ≅ X⟦i⟧⟦j⟧ := (shift_functor_add C i j).app _

@[reassoc] lemma shift_add_hom_comp_eq_to_hom₁ (i i' j : A) (h : i = i') :
  (shift_add X i j).hom ≫ eq_to_hom (by rw h) = eq_to_hom (by rw h) ≫ (shift_add X i' j).hom :=
by { cases h, rw [eq_to_hom_refl, eq_to_hom_refl, category.id_comp, category.comp_id] }

@[reassoc] lemma shift_add_hom_comp_eq_to_hom₂ (i j j' : A) (h : j = j') :
  (shift_add X i j).hom ≫ eq_to_hom (by rw h) = eq_to_hom (by rw h) ≫ (shift_add X i j').hom :=
by { cases h, rw [eq_to_hom_refl, eq_to_hom_refl, category.id_comp, category.comp_id] }

@[reassoc] lemma shift_add_hom_comp_eq_to_hom₁₂ (i j i' j' : A) (h₁ : i = i') (h₂ : j = j') :
  (shift_add X i j).hom ≫ eq_to_hom (by rw [h₁, h₂]) =
    eq_to_hom (by rw [h₁, h₂]) ≫ (shift_add X i' j').hom :=
by { cases h₁, cases h₂, rw [eq_to_hom_refl, eq_to_hom_refl, category.id_comp, category.comp_id] }

@[reassoc] lemma eq_to_hom_comp_shift_add_inv₁ (i i' j : A) (h : i = i') :
  eq_to_hom (by rw h) ≫ (shift_add X i' j).inv = (shift_add X i j).inv ≫ eq_to_hom (by rw h) :=
by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, shift_add_hom_comp_eq_to_hom₁]

@[reassoc] lemma eq_to_hom_comp_shift_add_inv₂ (i j j' : A) (h : j = j') :
  eq_to_hom (by rw h) ≫ (shift_add X i j').inv = (shift_add X i j).inv ≫ eq_to_hom (by rw h) :=
by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, shift_add_hom_comp_eq_to_hom₂]

@[reassoc] lemma eq_to_hom_comp_shift_add_inv₁₂ (i j i' j' : A) (h₁ : i = i') (h₂ : j = j') :
  eq_to_hom (by rw [h₁, h₂]) ≫ (shift_add X i' j').inv =
    (shift_add X i j).inv ≫ eq_to_hom (by rw [h₁, h₂]) :=
by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, shift_add_hom_comp_eq_to_hom₁₂]

lemma shift_shift' (i j : A) :
  f⟦i⟧'⟦j⟧' = (shift_add X i j).inv ≫ f⟦i + j⟧' ≫ (shift_add Y i j).hom :=
by { symmetry, apply nat_iso.naturality_1 }

variables (A)

/-- Shifting by zero is the identity functor. -/
abbreviation shift_zero  :
  X⟦0⟧ ≅ X := (shift_functor_zero C A).app _

lemma shift_zero' :
  f⟦(0 : A)⟧' = (shift_zero A X).hom ≫ f ≫ (shift_zero A Y).inv :=
by { symmetry, apply nat_iso.naturality_2 }

end add_monoid

section opaque_eq_to_iso

variables {ι : Type*} {i j k : ι}

/-- This definition is used instead of `eq_to_iso` so that the proof of `i = j` is visible
to the simplifier -/
def opaque_eq_to_iso (h : i = j) : @iso (discrete ι) _ i j := eq_to_iso h

@[simp]
lemma opaque_eq_to_iso_symm (h : i = j) :
  (opaque_eq_to_iso h).symm = opaque_eq_to_iso h.symm := rfl

@[simp]
lemma opaque_eq_to_iso_inv (h : i = j) :
  (opaque_eq_to_iso h).inv = (opaque_eq_to_iso h.symm).hom := rfl

@[simp, reassoc]
lemma map_opaque_eq_to_iso_comp_app (F : discrete ι ⥤ C ⥤ C) (h : i = j) (h' : j = k) (X : C) :
  (F.map (opaque_eq_to_iso h).hom).app X ≫ (F.map (opaque_eq_to_iso h').hom).app X =
    (F.map (opaque_eq_to_iso $ h.trans h').hom).app X := by { delta opaque_eq_to_iso, simp }

end opaque_eq_to_iso

section add_group

variables (C) {A} [add_group A] [has_shift C A]
variables (X Y : C) (f : X ⟶ Y)

/-- Shifting by `i` and then shifting by `-i` is the identity. -/
abbreviation shift_functor_comp_shift_functor_neg (i : A) :
  shift_functor C i ⋙ shift_functor C (-i) ≅ 𝟭 C :=
unit_of_tensor_iso_unit (shift_monoidal_functor C A) i (-i : A) (opaque_eq_to_iso (add_neg_self i))

/-- Shifting by `-i` and then shifting by `i` is the identity. -/
abbreviation shift_functor_neg_comp_shift_functor (i : A) :
  shift_functor C (-i) ⋙ shift_functor C i ≅ 𝟭 C :=
unit_of_tensor_iso_unit (shift_monoidal_functor C A) (-i : A) i (opaque_eq_to_iso (neg_add_self i))

section

variables (C)

/-- Shifting by `n` is a faithful functor. -/
instance shift_functor_faithful (i : A) : faithful (shift_functor C i) :=
faithful.of_comp_iso (shift_functor_comp_shift_functor_neg C i)

/-- Shifting by `n` is a full functor. -/
instance shift_functor_full (i : A) : full (shift_functor C i) :=
begin
  haveI : full (shift_functor C i ⋙ shift_functor C (-i)) :=
    full.of_iso (shift_functor_comp_shift_functor_neg C i).symm,
  exact full.of_comp_faithful _ (shift_functor C (-i))
end

/-- Shifting by `n` is an essentially surjective functor. -/
instance shift_functor_ess_surj (i : A) : ess_surj (shift_functor C i) :=
{ mem_ess_image := λ Y, ⟨Y⟦-i⟧, ⟨(shift_functor_neg_comp_shift_functor C i).app Y⟩⟩ }

/-- Shifting by `n` is an equivalence. -/
noncomputable instance shift_functor_is_equivalence (n : A) : is_equivalence (shift_functor C n) :=
equivalence.of_fully_faithfully_ess_surj _

end

variables {C}

/-- Shifting by `i` and then shifting by `-i` is the identity. -/
abbreviation shift_shift_neg (i : A) : X⟦i⟧⟦-i⟧ ≅ X :=
(shift_functor_comp_shift_functor_neg C i).app _

/-- Shifting by `-i` and then shifting by `i` is the identity. -/
abbreviation shift_neg_shift (i : A) : X⟦-i⟧⟦i⟧ ≅ X :=
(shift_functor_neg_comp_shift_functor C i).app _

variables {X Y}

lemma shift_shift_neg' (i : A) :
  f⟦i⟧'⟦-i⟧' = (shift_shift_neg X i).hom ≫ f ≫ (shift_shift_neg Y i).inv :=
by { symmetry, apply nat_iso.naturality_2 }

lemma shift_neg_shift' (i : A) :
  f⟦-i⟧'⟦i⟧' = (shift_neg_shift X i).hom ≫ f ≫ (shift_neg_shift Y i).inv :=
by { symmetry, apply nat_iso.naturality_2 }

lemma shift_equiv_triangle (n : A) (X : C) :
  (shift_shift_neg X n).inv⟦n⟧' ≫ (shift_neg_shift (X⟦n⟧) n).hom = 𝟙 (X⟦n⟧) :=
(add_neg_equiv (shift_monoidal_functor C A) n).functor_unit_iso_comp X

lemma shift_shift_neg_hom_shift (n : A) (X : C) :
  (shift_shift_neg X n).hom ⟦n⟧' = (shift_neg_shift (X⟦n⟧) n).hom :=
by simp

lemma shift_shift_neg_inv_shift (n : A) (X : C) :
  (shift_shift_neg X n).inv ⟦n⟧' = (shift_neg_shift (X⟦n⟧) n).inv :=
by { ext, rw [← shift_shift_neg_hom_shift, ← functor.map_comp, iso.hom_inv_id, functor.map_id] }

@[simp]
lemma shift_shift_neg_shift_eq (n : A) (X : C) :
  (shift_functor C n).map_iso (shift_shift_neg X n) = shift_neg_shift (X⟦n⟧) n :=
category_theory.iso.ext $ shift_shift_neg_hom_shift _ _

variables (C)

/-- Shifting by `n` and shifting by `-n` forms an equivalence. -/
@[simps]
def shift_equiv (n : A) : C ≌ C :=
{ functor := shift_functor C n,
  inverse := shift_functor C (-n),
  ..(add_neg_equiv (shift_monoidal_functor C A) n) }

variable {C}

open category_theory.limits

variables [has_zero_morphisms C]

lemma shift_zero_eq_zero (X Y : C) (n : A) : (0 : X ⟶ Y)⟦n⟧' = (0 : X⟦n⟧ ⟶ Y⟦n⟧) :=
category_theory.functor.map_zero _ _ _

end add_group

section add_comm_monoid

variables {C A} [add_comm_monoid A] [has_shift C A]
variables (X Y : C) (f : X ⟶ Y)

/-- When shifts are indexed by an additive commutative monoid, then shifts commute. -/
def shift_comm (i j : A) : X⟦i⟧⟦j⟧ ≅ X⟦j⟧⟦i⟧ :=
(shift_add X i j).symm ≪≫ ((shift_monoidal_functor C A).to_functor.map_iso
  (opaque_eq_to_iso $ add_comm i j : _)).app X ≪≫ shift_add X j i

@[simp] lemma shift_comm_symm (i j : A) : (shift_comm X i j).symm = shift_comm X j i :=
begin
  ext, dsimp [shift_comm], simpa
end

variables {X Y}

/-- When shifts are indexed by an additive commutative monoid, then shifts commute. -/
lemma shift_comm' (i j : A) :
  f⟦i⟧'⟦j⟧' = (shift_comm _ _ _).hom ≫ f⟦j⟧'⟦i⟧' ≫ (shift_comm _ _ _).hom :=
by simp [shift_comm]

@[reassoc] lemma shift_comm_hom_comp (i j : A) :
  (shift_comm X i j).hom ≫ f⟦j⟧'⟦i⟧' = f⟦i⟧'⟦j⟧' ≫ (shift_comm Y i j).hom :=
by rw [shift_comm', ← shift_comm_symm, iso.symm_hom, iso.inv_hom_id_assoc]

end add_comm_monoid

end category_theory


/- structural subtyping -/
import ..phrase

namespace flow_analysis

open phrase
lemma structural_subtyping.base {a b : security_class} (h : a ≤ b) :
  ∃τ τ', base a = base τ ∧ base b = base τ' ∧ τ ≤ τ'
       ∨ base a = var τ ∧ base a = base b
       ∨ base a = cmd τ ∧ base b = cmd τ' ∧ τ' ≤ τ
:= begin
  apply exists.intro a,
  apply exists.intro b,
  cc,
end

lemma structural_subtyping.reflex {ρ : phrase} :
  ∃τ τ', ρ = base τ ∧ ρ = base τ' ∧ τ ≤ τ'
       ∨ ρ = var τ ∧ ρ = ρ
       ∨ ρ = cmd τ ∧ ρ = cmd τ' ∧ τ' ≤ τ
:= begin
  cases ρ,
  repeat {apply exists.intro ρ},
  repeat {simp},
end

lemma structural_subtyping.trans {a b c : phrase}
    (ihab : ∃τ τ', a = base τ ∧ b = base τ' ∧ τ ≤ τ'
                 ∨ a = var τ ∧ a = b
                 ∨ a = cmd τ ∧ b = cmd τ' ∧ τ' ≤ τ)
    (ihbc : ∃τ τ', b = base τ ∧ c = base τ' ∧ τ ≤ τ'
                 ∨ b = var τ ∧ b = c
                 ∨ b = cmd τ ∧ c = cmd τ' ∧ τ' ≤ τ):
  ∃ (τ τ' : security_class),
    a = base τ ∧ c = base τ' ∧ τ ≤ τ' ∨
      a = var τ ∧ a = c ∨ a = cmd τ ∧ c = cmd τ' ∧ τ' ≤ τ
:= begin
  cases a,
  case phrase.base : {
    cases ihab with x ihab,
    cases ihab with y ihab,
    repeat { cases ihab, },
    cases ihab_right,
    cases ihbc with y' ihbc,
    cases ihbc with z ihbc,
    repeat { cases ihbc, },
    cases ihbc_right,
    apply exists.intro x,
    apply exists.intro z,
    apply or.inl,
    apply and.intro ihab_left,
    apply and.intro ihbc_right_left,
    simp[ihab_right_left] at ihbc_left,
    simp[ihbc_left] at *,
    apply le_trans ihab_right_right ihbc_right_right,
    repeat { cc, },
  },
  case phrase.var : {
    repeat { cases ihab with _ ihab, cases ihbc with _ ihbc, },
    repeat { apply exists.intro a },
    repeat { cc, },
  },
  case phrase.cmd : {
    cases ihab with x ihab,
    cases ihab with y ihab,
    repeat { cases ihab, },
    repeat { cc, },
    cases ihab_right with ihby ihyx,
    cases ihbc with y' ihbc,
    cases ihbc with z ihbc,
    repeat { cases ihbc with _ ihbc, },
    repeat { cc, },
    simp[ihby] at *,
    apply exists.intro x,
    apply exists.intro y',
    cc,
    apply exists.intro x,
    apply exists.intro security_class.low,
    repeat { apply or.inr, },
    apply and.intro ihab_left,
    apply and.intro ihbc_left_1,
    cases x,
    apply security_class.le.lower,
    apply security_class.le.refl,
  },
end

lemma structural_subtyping.cmd {a b : security_class}
    (ih : ∃τ τ', base a = base τ ∧ base b = base τ' ∧ τ ≤ τ'
               ∨ base a = var τ ∧ base a = base b
               ∨ base a = cmd τ ∧ base b = cmd τ' ∧ τ' ≤ τ):
  ∃ (τ τ' : security_class),
    cmd b = base τ ∧ cmd a = base τ' ∧ τ ≤ τ' ∨
      cmd b = var τ ∧ cmd b = cmd a ∨ cmd b = cmd τ ∧ cmd a = cmd τ' ∧ τ' ≤ τ
:= begin
  cases ih with y ih,
  cases ih with x ih,
  apply exists.intro x,
  apply exists.intro y,
  cc,
end

/- Lemma 4.1 (Structural Subtyping)
 - If ⊢ ρ ⊆ ρ', then either
 - (a) ρ is of the form base τ, ρ' is of the form base τ' and τ ≤ τ'
 - (b) ρ is of the form var τ and ρ' = ρ, or
 - (c) ρ is of the form cmd τ, ρ' is of the form cmd τ' and τ' ≤ τ
-/
lemma structural_subtyping {ρ ρ' : phrase} (h : ρ ⊆ₛ ρ') :
  ∃τ τ', (ρ = base τ ∧ ρ' = base τ' ∧ τ ≤ τ')
       ∨ (ρ = var τ ∧ ρ = ρ')
       ∨ (ρ = cmd τ ∧ ρ' = cmd τ' ∧ τ' ≤ τ)
:= begin
  induction h,
  case phrase.ss.base : a b h {
    apply structural_subtyping.base h,
  },
  case phrase.ss.reflex : ρ {
    apply structural_subtyping.reflex,
  },
  case phrase.ss.trans : a b c _ _ ihab ihbc {
    apply structural_subtyping.trans ihab ihbc,
  },
  case phrase.ss.cmd : a b hab ih {
    apply structural_subtyping.cmd ih,
  },
end

end flow_analysis


/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .fol

open fol set

universes u v

/-- Given an xs : list α, an x : α, a set T on α such that everything in xs which is not x is in T, return the sublist which excludes x, a proof that this list is now a subset of T, and a proof that everything in this list was not the forbidden element x. --/
def list_except {α : Type u} [decidable_eq α] (xs : list α) (x : α) (T : set α)
  (h : ∀ y ∈ xs, y ≠ x → y ∈ T) :
  Σ' ys : list α, ({ϕ | ϕ ∈ ys} ⊆ T ∧ (∀ y ∈ ys, y ≠ x)) ∧ (∀ y ∈ xs, y ≠ x → y ∈ ys) :=
begin
  existsi xs.filter (≠ x),
  refine ⟨⟨_, _⟩, _⟩,
  { intros y hy, apply h y (list.mem_of_mem_filter hy), apply list.of_mem_filter hy },
  { intros y hy, apply list.of_mem_filter hy },
  { intros y hy hxy, apply list.mem_filter_of_mem hy hxy }
end

open classical

/- Couldn't find this def in set.basic... sure it's around somewhere-/
/-- Given x ∈ f '' S, choose a lift x' in the preimage of x; return x' and a proof that x' is a lift --/
noncomputable def image_lift {α : Type u} {β : Type v} {f : α → β} {S : set α} (x ∈ f '' S) : Σ' (x' : α), x' ∈ S ∧ f x' = x :=
begin
  apply psigma_of_exists, apply (set.mem_image _ _ _).mp H
end

/-- Given a list xs : list β, a set S : set α, a proof that {x | x ∈ xs} ⊆ f '' S, return a list of lifts ys : list α, a proof that ys ⊆ S and a proof that f '' ys = xs --/
noncomputable def image_lift_list {α : Type u} {β : Type v} {f : α → β} {S : set α} {xs : list β} (h_sub : {x | x ∈ xs} ⊆ f '' S) : Σ' (ys : list α), ({y' | y' ∈ ys} ⊆ S) ∧ f '' {y | y ∈ ys} = {x | x ∈ xs} :=
begin
  apply psigma_of_exists,
  rcases list.exists_of_to_set_subset_image h_sub with ⟨ys, hys, hys'⟩,
  refine ⟨ys, hys, _⟩, subst hys', ext,
  apply list.mem_map.symm
end

/-- Any proof from a set of formulas is provable from a finset of subformulas. --/
lemma proof_compactness {L : Language.{u}} {ψ : formula L} {T : set $ formula L} :
  (T ⊢' ψ) → ∃Γ : finset (formula L), ↑Γ ⊢' ψ ∧ ↑Γ ⊆ T :=
begin
  haveI : decidable_eq (formula L) := λx y, classical.prop_decidable _,
  intro P, induction P with P, induction P,
  { exact ⟨{P_A}, ⟨axm1⟩, set.singleton_subset_iff.mpr P_h⟩ },
  { rcases P_ih with ⟨Γ, H, K⟩, refine ⟨Γ \ {P_A}, impI' $ weakening' (by simp) H, by simp [K]⟩ },
  { rcases P_ih_h₁ with ⟨Γ₁, H₁, K₁⟩, rcases P_ih_h₂ with ⟨Γ₂, H₂, K₂⟩,
    refine ⟨Γ₁ ∪ Γ₂, impE' _ (weakening' (by simp) H₁) (weakening' (by simp) H₂), by simp [K₁, K₂]⟩ },
  { rcases P_ih with ⟨Γ, H, K⟩, refine ⟨Γ \ {∼P_A}, falsumE' $ weakening' (by simp) H, by simp [K]⟩ },
  { rcases P_ih with ⟨Γ, H, K⟩, rcases finset.subset_image_iff.mp K with ⟨Γ', K', hΓ⟩,
    subst hΓ, simp only [finset.coe_image] at H K,
    exact ⟨Γ', allI' H, K'⟩ },
  { rcases P_ih with ⟨Γ, H, K⟩, exact ⟨Γ, allE₂' H, K⟩ },
  { exact ⟨∅, ref' _ _, empty_subset _⟩ },
  { rcases P_ih_h₁ with ⟨Γ₁, H₁, K₁⟩, rcases P_ih_h₂ with ⟨Γ₂, H₂, K₂⟩,
    refine ⟨Γ₁ ∪ Γ₂, subst₂' _ _ _ (weakening' (by simp) H₁) (weakening' (by simp) H₂), by simp [K₁, K₂]⟩ }
end

lemma theory_proof_compactness {L : Language} {T : Theory L} {ψ : sentence L} (hψ : T ⊢' ψ) :
  ∃Γ : finset (sentence L), ↑Γ ⊢' ψ ∧ ↑Γ ⊆ T :=
begin
  haveI : decidable_eq (sentence L) := λx y, classical.prop_decidable _,
  haveI : decidable_eq (formula L) := λx y, classical.prop_decidable _,
  rcases proof_compactness hψ with ⟨Γ, H, K⟩,
  rcases finset.subset_image_iff.mp K with ⟨Γ', K', hΓ⟩,
  subst hΓ, simp only [finset.coe_image] at H K,
  exact ⟨Γ', H, K'⟩
end

lemma theory_proof_compactness_iff {L : Language} {T : Theory L} {ψ : sentence L} :
  T ⊢' ψ ↔ ∃Γ : finset (sentence L), ↑Γ ⊢' ψ ∧ ↑Γ ⊆ T :=
⟨theory_proof_compactness, λ⟨Γ, H, K⟩, weakening' (image_subset _ K) H⟩

lemma is_consistent_union {L : Language} {T₁ T₂ : Theory L} (h₁ : is_consistent T₁)
  (h₂ : ∀ψ ∈ T₂, insert (∼ψ) T₁ ⊢' (⊥ : sentence L)) : is_consistent (T₁ ∪ T₂) :=
begin
  haveI : decidable_eq (sentence L) := λx y, classical.prop_decidable _,
  have lem : ∀(T₀ : finset (sentence L)), ↑T₀ ⊆ T₂ → is_consistent (T₁ ∪ ↑T₀),
  { refine finset.induction _ _,
    { intro hT, rw [finset.coe_empty, union_empty], exact h₁ },
    { intros ψ s hψ ih hs hT, simp [insert_subset] at hs,
      apply ih hs.2, apply sprf_by_cases ψ,
      { simp at hT, exact hT },
      { apply weakening' _ (h₂ _ hs.1),
        apply image_subset, apply insert_subset_insert, apply subset_union_left }}},
  intro h, rcases theory_proof_compactness h with ⟨T₀, h₀, hT⟩,
  have : decidable_pred (∈ T₁) := λx, classical.prop_decidable _,
  let T₀' := T₀.filter (∉ T₁),
  refine lem T₀' _ _,
  { intros x hx, simp [T₀'] at hx, exact (hT hx.1).resolve_left hx.2 },
  { apply weakening' _ h₀, apply image_subset, rw [←inter_union_diff (↑T₀) T₁],
    apply union_subset_union, apply inter_subset_right,
    intros x hx, rw [finset.mem_coe, finset.mem_filter], exact hx }
end


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

import category_theory.limits.shapes.binary_products

universes v u

open category_theory category_theory.category category_theory.limits
namespace category_theory

variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

variables [has_binary_products.{v} C]

local attribute [tidy] tactic.case_bash

@[simps]
def prod_functor : C ⥤ C ⥤ C :=
{ obj := λ X, { obj := λ Y, X ⨯ Y, map := λ Y Z, limits.prod.map (𝟙 X) },
  map := λ Y Z f, { app := λ T, limits.prod.map f (𝟙 T) }}

@[simp] lemma prod_left_def {X Y : C} : limit.π (pair X Y) walking_pair.left = limits.prod.fst := rfl
@[simp] lemma prod_right_def {X Y : C} : limit.π (pair X Y) walking_pair.right = limits.prod.snd := rfl

lemma prod.hom_ext {A X Y : C} {a b : A ⟶ X ⨯ Y} (h1 : a ≫ limits.prod.fst = b ≫ limits.prod.fst) (h2 : a ≫ limits.prod.snd = b ≫ limits.prod.snd) : a = b :=
begin
  apply limit.hom_ext,
  rintros (_ | _),
  simpa,
  simpa
end

lemma prod_map_comm {A B X Y : C} (f : A ⟶ B) (g : X ⟶ Y) :
  limits.prod.map (𝟙 _) f ≫ limits.prod.map g (𝟙 _) = limits.prod.map g (𝟙 _) ≫ limits.prod.map (𝟙 _) f :=
begin
  apply prod.hom_ext, simp, erw id_comp, erw comp_id, simp, erw id_comp, erw comp_id
end

lemma prod_functorial {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  limits.prod.map (f ≫ g) (𝟙 W) = limits.prod.map f (𝟙 W) ≫ limits.prod.map g (𝟙 W) :=
begin
  apply prod.hom_ext,
  simp, simp, dsimp, simp
end
lemma prod_functorial' {X Y Z W : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  limits.prod.map (𝟙 W) (f ≫ g) = limits.prod.map (𝟙 W) f ≫ limits.prod.map (𝟙 W) g :=
begin
  apply prod.hom_ext,
  simp, dsimp, simp, simp
end

end category_theory


-- Copyright (C) 2020 by @ljt12138

import tactic pal.basics pal.proof

namespace pal_logic

lemma useless_condition {α agent : Type} (φ ψ : sentence α agent) :
  ⊢ ψ → ⊢ φ↣ψ :=
begin
  intros a,
  have ht : ⊢ ψ ↣ φ ↣ ψ, { existsi proof.ax1 _ _, prover },
  cases a, cases ht,
  existsi proof.mp _ _, prover
end

lemma know_truth {α agent : Type} {φ : sentence α agent} (i : agent) :
  ⊢ φ → ⊢ □(i:φ) :=
begin
  intros h, cases h,
  existsi proof.truth _, prover
end

lemma id_provable {α agent : Type} (φ : sentence α agent) :
  ⊢ φ ↣ φ :=
begin
  existsi (proof.mp (proof.mp (proof.ax2 _ _ _)
                              (proof.ax1 _ _))
                    (proof.ax1 φ φ)),
  prover
end

lemma hs_rule {α agent : Type} (φ ψ γ : sentence α agent) :
  ⊢ φ ↣ ψ → ⊢ ψ ↣ γ → ⊢ φ ↣ γ :=
begin
  intros a₁ a₂,
  have h₁ : ⊢ φ ↣ ψ ↣ γ, { apply useless_condition, assumption },
  cases h₁, cases a₁,
  existsi proof.mp (proof.mp (proof.ax2 _ _ _) _) _, prover
end

lemma explosion {α agent : Type} (φ : sentence α agent) :
  ⊢ (⊥ : sentence α agent) ↣ φ :=
begin
  have h₁ : ⊢ (⊥ ↣ (φ ↣ ⊥) ↣ ⊥ : sentence α agent),
  { existsi proof.ax1 _ _, prover },
  have h₂ : ⊢ ((φ ↣ ⊥) ↣ ⊥) ↣ φ,
  { existsi proof.ax3 _, prover },
  apply hs_rule, repeat {assumption}
end

lemma double_Γ_equiv {α agent : Type} (Γ : list (sentence α agent)) :
  consistent Γ → consistent (Γ++Γ) :=
begin
  intros a₁, simp at *, intros a₂,
  apply a₁, clear a₁,
  cases a₂,
  existsi proof.conj _ _ _ _ _,
  apply proof_of.conj, exact a₂_h, simp
end

lemma mp_via_ax2 {α agent : Type} (φ ψ γ : sentence α agent) :
  ⊢ φ ↣ ψ ↣ γ → ⊢ φ ↣ ψ → ⊢ φ ↣ γ :=
begin
  intros a₁ a₂, cases a₁, cases a₂,
  existsi proof.mp (proof.mp (proof.ax2 _ _ _) _) _, prover
end

lemma uncurry {α agent : Type} (φ ψ γ : sentence α agent) :
  ⊢ φ ↣ ψ ↣ γ → ⊢ φ & ψ ↣ γ :=
begin
  intros a, cases a,
  existsi proof.uncurry _ _ _, prover
end

lemma curry {α agent : Type} (φ ψ γ : sentence α agent) :
  ⊢ φ & ψ ↣ γ → ⊢ φ ↣ ψ ↣ γ :=
begin
  intros a, cases a,
  existsi proof.curry _ _ _, prover
end

lemma dni {α agent : Type} (φ : sentence α agent) :
  ⊢ φ ↣ (φ↣⊥) ↣ ⊥ :=
begin
  have h₁ : ⊢ φ & (φ ↣ ⊥) ↣ φ,
  { apply uncurry, existsi proof.ax1 _ _, prover },
  have h₂ : ⊢ φ & (φ ↣ ⊥) ↣ (φ ↣ ⊥),
  { apply uncurry, apply useless_condition, apply id_provable },
  apply curry, apply mp_via_ax2, repeat {assumption}
end

lemma drop_mem {α : Type} (φ : α) (Γ : list α) :
  ∃ Γ', Γ' ⊆ Γ ∧ φ ∉ Γ' ∧ Γ ⊆ φ :: Γ' :=
begin
  classical,
  induction Γ with ψ Γ ih,
  { existsi list.nil, simp },
  {
    cases ih with Γ' ih₁,
    cases classical.em (φ = ψ),
    {
      existsi Γ', split,
      { apply list.subset_cons_of_subset, exact ih₁.left }, split,
      { exact ih₁.right.left },
      { simp, split, { left, rewrite h }, { exact ih₁.right.right }}
    },
    {
      existsi (list.cons ψ Γ'), split,
      { simp, apply list.subset_cons_of_subset, exact ih₁.left }, split,
      {
        intros contra, simp at contra, cases contra,
        exact h contra, exact ih₁.right.left contra
      },
      {
        simp, intros γ ht,
        cases ih₁.right.right ht,
        { rewrite h_1, simp },
        { simp, right, right, exact h_1 }
      }
    }
  }
end

lemma add_assumption {α agent : Type} {φ ψ : sentence α agent} {Γ : list _} :
  ⊢ φ & conjunction Γ ↣ ψ ↔ ⊢ conjunction (φ :: Γ) ↣ ψ :=
begin
  split,
  {
    intros h, cases Γ with ψ Γ',
    {
      have ht₁ := curry _ _ _ h, simp at ht₁, simp,
      have ht₂ : ⊢ φ ↣ ((⊥ : sentence α agent) ↣ ⊥),
      { apply useless_condition, apply id_provable },
      cases ht₁, cases ht₂,
      existsi (proof.mp (proof.mp (proof.ax2 _ _ _) _) _),
      prover
    },
    { unfold conjunction, exact h }
  },
  {
    intros h, cases Γ with ψ Γ',
    {
      simp at h, cases h,
      existsi proof.conjl _ _ _, prover
    },
    { unfold conjunction at h, exact h }
  }
end

lemma drop_assumption {α agent : Type} {φ ψ : sentence α agent} {Γ : list _} :
  ⊢ φ & conjunction Γ ↣ ψ → ∃ Γ', Γ' ⊆ Γ ∧ φ ∉ Γ' ∧ ⊢ φ & conjunction Γ' ↣ ψ :=
begin
  intros h,
  cases drop_mem φ Γ with Γ' h₁,
  existsi Γ', split,
  { exact h₁.left }, split,
  { exact h₁.right.left },
  {
    apply add_assumption.mpr,
    have ht₁ := add_assumption.mp h,
    have ht₂ : (list.cons φ Γ) ⊆ φ :: Γ', { simp, exact h₁.right.right },
    cases ht₁, existsi proof.conj _ _ _ _ _,
    apply proof_of.conj, assumption, assumption
  }
end

lemma and_swap {α agent : Type} {φ ψ γ : sentence α agent} :
  ⊢ φ & ψ ↣ γ → ⊢ ψ & φ ↣ γ :=
begin
  have h₁ : ∀ φ ψ : sentence α agent, φ & ψ = conjunction [φ, ψ] := by simp,
  rewrite h₁, rewrite h₁,
  intros h₂,
  have h₃ : [φ, ψ] ⊆ [ψ, φ] := by simp,
  cases h₂,
  existsi proof.conj _ _ _ _ _,
  apply proof_of.conj, assumption, assumption
end

lemma contra_imp_conseq {α agent : Type} {φ : sentence α agent} {Γ : list (sentence α agent)} :
  φ ∈ Γ → ⊢ conjunction Γ ↣ ⊥ → ∃ Γ', Γ' ⊆ Γ ∧ φ ∉ Γ' ∧ ⊢ conjunction Γ' ↣ (φ ↣ ⊥) :=
begin
  intros h₁ h₂,
  have h₃ : ⊢ (φ & conjunction Γ) ↣ ⊥,
  {
    apply add_assumption.mpr, cases h₂,
    existsi proof.conj _ _ _ _ _, apply proof_of.conj, exact h₂_h, simp
  },
  cases drop_assumption h₃ with Γ' h₄,
  existsi Γ', split,
  { exact h₄.left }, split,
  { exact h₄.right.left },
  { apply curry, apply and_swap, exact h₄.right.right }
end

lemma conj_subset {α agent : Type} {φ : sentence α agent} {Γ₁ Γ₂ : list (sentence α agent)} :
  ⊢ conjunction Γ₁ ↣ φ → Γ₁ ⊆ Γ₂ → ⊢ conjunction Γ₂ ↣ φ :=
begin
  intros h₁ h₂,
  cases h₁,
  existsi proof.conj _ _ _ _ _,
  apply proof_of.conj, exact h₁_h, exact h₂
end

lemma know_and_intro {α agent : Type} {φ ψ : sentence α agent} {i : agent} :
  ⊢ □(i : φ) ↣ □(i : ψ) ↣ □(i : φ&ψ) :=
begin
  have h₁ : ⊢ □(i : φ↣ψ↣φ&ψ),
  { apply know_truth, apply curry, apply id_provable },
  have h₂ : ⊢ □(i : φ) ↣ □(i : ψ↣φ&ψ),
  { cases h₁, existsi proof.mp (proof.ax4 _ _ _) _, prover },
  apply hs_rule, exact h₂,
  existsi proof.ax4 _ _ _, prover
end

end pal_logic


import Lean

namespace SciLean.ConvIf

@[inline]
abbrev convIf {α} (P : Prop) (_ : Decidable P) (x : P → α) (y : ¬P → α) : α := if h : P then x h else y h

def convIf.rhs {α} (P : Prop) [inst : Decidable P] (a : α) := convIf P inst (λ _ => a) (λ _ => a)

theorem convIf.id {α} (P : Prop) [inst : Decidable P] (a : α) : a = convIf P inst (λ _ => a) (λ _ => a) :=
by
  simp[convIf]; cases inst; rename_i q; simp[q]; rename_i q; simp[q]; done

open Lean.Parser.Tactic.Conv
syntax (name := conv_if) "if" ident ":" term  "then" convSeq "else" convSeq : conv

open Lean.Elab Tactic Conv in
@[tactic conv_if]
def convIfTactic : Tactic
| `(conv| if $h : $P then $trueConv else $falseConv) => do
   withMainContext do

     let p ← elabTerm P none
     let t' ← Lean.Meta.mkAppM ``convIf.rhs #[p, (← getLhs)]
     let h' ← Lean.Meta.mkAppM ``convIf.id  #[p, (← getLhs)]

     updateLhs t' h'
     evalTactic (←
       `(convSeq| unfold convIf.rhs
                  conv => enter[3]; intro $h; ($trueConv)
                  conv => enter[4]; intro $h; ($falseConv)
                  unfold convIf))
| _ => throwUnsupportedSyntax


import group_theory.group_action.option
import mathlib.group_action
import mathlib.pointwise
import phase1.allowable

noncomputable theory

open function set with_bot
open_locale cardinal pointwise

universe u

namespace con_nf
variables [params.{u}] [position_data.{}]

open code Iio_index

variables (α : Λ) [core_tangle_cumul α] {β : Iio_index α} {γ : Iio α}

abbreviation extensions := Π β : Iio α, set (tangle β)

namespace semitangle

variables [positioned_tangle_cumul α] [almost_tangle_cumul α]

/-- Keeps track of the preferred extension of a semitangle, along with coherence conditions
relating each extension of the semitangle. -/
@[nolint has_nonempty_instance] inductive preference (members : extensions α)
| base (atoms : set (tangle (⊥ : Iio_index α))) :
    (∀ γ, A_map bot_ne_coe atoms = members γ) →
    preference
| proper (β : Iio α) :
    (mk β (members β) : code α).is_even →
    (∀ (γ : Iio α) (hβγ : Iio_coe β ≠ γ), A_map hβγ (members β) = members γ) →
    preference

variables {α} {members : extensions α}

/-- The `-1`-extension associated with a given semitangle extension. -/
def preference.atoms : preference α members → set atom
| (preference.base atoms _) := (atoms : set (tangle ⊥))
| (preference.proper _ _ _) := ∅

lemma preference.base_heq_base {m₁ m₂ : extensions α} {s₁ s₂ h₁ h₂}
  (hm : m₁ = m₂) (hs : s₁ = s₂) :
  (preference.base s₁ h₁ : preference α m₁) == (preference.base s₂ h₂ : preference α m₂) :=
by cases hm; cases hs; refl

lemma preference.proper_heq_proper {m₁ m₂ : extensions α} {β₁ β₂ h₁ h₂ h₃ h₄}
  (hm : m₁ = m₂) (hs : β₁ = β₂) :
  (preference.proper β₁ h₁ h₂ : preference α m₁) ==
    (preference.proper β₂ h₃ h₄ : preference α m₂) :=
by cases hm; cases hs; refl

end semitangle

open semitangle

variables [positioned_tangle_cumul α] [almost_tangle_cumul α]

/-- A *semitangle* may become an element of our model of tangled type theory.
We keep track of its members, written as tangles of all lower levels `β < α`. -/
@[nolint has_nonempty_instance]
structure semitangle :=
(members : extensions α)
(pref : preference α members)

variables {α}
namespace semitangle

/-- The membership relation for nonempty semitangles. -/
def mem (t : tangle γ) (s : semitangle α) : Prop := t ∈ s.members γ

notation t ` ∈ₛₜ `:50 s:50 := mem t s

/-- The even code associated to a nonempty semitangle. -/
def repr_code : semitangle α → code α
| ⟨exts, preference.base atoms hA⟩ := ⟨⊥, atoms⟩
| ⟨exts, preference.proper β rep hA⟩ := ⟨β, exts β⟩

@[simp] lemma repr_code_base (exts : extensions α) (atoms hA) :
  repr_code ⟨exts, preference.base atoms hA⟩ = ⟨⊥, atoms⟩ := rfl

@[simp] lemma repr_code_proper (exts : extensions α) (β rep hA) :
  repr_code ⟨exts, preference.proper β rep hA⟩ = ⟨β, exts β⟩ := rfl

lemma repr_code_spec : Π (s : semitangle α), (repr_code s : code α).is_even
| ⟨exts, preference.proper β rep hA⟩ := rep
| ⟨exts, preference.base atoms hA⟩ := is_even_bot _

lemma repr_code_members_ne :
  Π (s : semitangle α) (γ : Iio α) (hcγ : (repr_code s : code α).1 ≠ γ),
  (A_map_code γ (repr_code s)).2 = s.members γ
| ⟨exts, preference.proper β rep hA⟩ γ hcγ := by rw snd_A_map_code; exact hA _ hcγ
| ⟨exts, preference.base atoms hA⟩ γ hcγ := hA _

-- Remark: This formulation of extensionality holds only for types larger than type zero, since
-- it doesn't take into account any `-1`-extension.
lemma ext_core (x y : semitangle α) : (∃ γ, γ < α) → x.members = y.members → x = y :=
begin
  obtain ⟨xs, hxs⟩ := x,
  obtain ⟨ys, hys⟩ := y,
  dsimp,
  rintro ⟨γ, hγ⟩ rfl,
  have γ : Iio α := ⟨γ, hγ⟩,
  refine congr_arg (λ h, ⟨xs, h⟩) _,
  obtain ⟨atoms₁, hA₁⟩ | ⟨β, even₁, hA₁⟩ := hxs;
    obtain ⟨atoms₂, hA₂⟩ | ⟨γ, even₂, hA₂⟩ := hys,
  { simp_rw A_map_injective ((hA₁ γ).trans (hA₂ _).symm) },
  { cases (is_even_bot _).A_map_code_ne even₂ bot_ne_mk_coe (sigma.ext_iff.2 ⟨rfl, (hA₁ γ).heq⟩) },
  { cases (is_even_bot _).A_map_code_ne even₁ bot_ne_mk_coe (sigma.ext_iff.2 ⟨rfl, (hA₂ β).heq⟩) },
  { simp only,
    refine not_ne_iff.1 (λ hβγ, even₂.A_map_code_ne even₁ (Iio.coe_injective.ne hβγ.symm) $
      sigma.ext_iff.2 ⟨rfl, heq_of_eq _⟩),
    rw snd_A_map_code,
    exact hA₂ β (λ h, hβγ.symm (Iio.coe_injective h)) }
end

/-- One useful form of extensionality in tangled type theory. Two nonempty semitangles are equal if
their even codes are equivalent (and hence equal, by uniqueness). -/
lemma ext_code : ∀ {x y : semitangle α}, (repr_code x : code α) ≡ repr_code y → x = y
| ⟨x, preference.base atoms₁ hA₁⟩ ⟨y, preference.base atoms₂ hA₂⟩ h := begin
  obtain rfl := code.equiv.bot_bot_iff.1 h,
  obtain rfl : x = y := funext (λ γ, (hA₁ _).symm.trans $ hA₂ _),
  refl,
end
| ⟨x, preference.base s hA₁⟩ ⟨y, preference.proper γ even₂ hA₂⟩ h := begin
  change code.mk _ _ ≡ code.mk _ _ at h,
  obtain ⟨δ, hδ⟩ := (code.equiv.bot_left_iff.1 h).resolve_left
    (ne_of_apply_ne sigma.fst bot_ne_mk_coe),
  rw hδ at even₂,
  cases even₂.not_is_odd ((is_even_bot _).A_map_code bot_ne_mk_coe),
end
| ⟨x, preference.proper γ even₁ hA₁⟩ ⟨y, preference.base s hA₂⟩ h := begin
  change code.mk _ _ ≡ code.mk _ _ at h,
  obtain ⟨δ, hδ⟩ := (code.equiv.bot_right_iff.1 h).resolve_left
    (ne_of_apply_ne sigma.fst mk_coe_ne_bot),
  rw hδ at even₁,
  cases even₁.not_is_odd ((is_even_bot _).A_map_code bot_ne_mk_coe),
end
| ⟨x, preference.proper γ even₁ hA₁⟩ ⟨y, preference.proper δ even₂ hA₂⟩ h := begin
  dsimp at h,
  simp only [code.equiv_iff, sigma.ext_iff, mem_Iio, Iio.coe_inj, ne.def, fst_A_map_code,
    snd_A_map_code, Iio.coe_mk] at h,
  obtain ⟨rfl, h⟩ | ⟨-, γ, hδγ, rfl, h⟩ | ⟨-, δ, hγδ, rfl, h⟩ |
    ⟨c, hc, γ, hcγ, δ, hcδ, ⟨⟨rfl, hx'⟩, hx⟩, _⟩ := h,
  { suffices : x = y,
    { subst this },
    refine funext (λ ε, _),
    obtain rfl | hδε := eq_or_ne δ ε,
    { exact h.eq.symm },
    refine (hA₁ _ (λ h, hδε (Iio.coe_injective h))).symm.trans
      (eq.trans _ $ hA₂ _ (λ h, hδε (Iio.coe_injective h))),
    dsimp,
    rw h.eq },
  { rw h.eq at even₁,
    cases (even₂.A_map_code $ Iio.coe_injective.ne hδγ).not_is_even even₁ },
  { rw h.eq at even₂,
    cases (even₁.A_map_code $ Iio.coe_injective.ne hγδ).not_is_even even₂ },
  { rw hx.eq at even₁,
    cases (hc.A_map_code hcγ).not_is_even even₁ }
end

/-- Extensionality in tangled type theory. Two nonempty semitangles are equal if their
`β`-extensions are equal for *any* choice of `γ < α`.
TODO: This proof can be golfed quite a bit just by cleaning up the `simp` calls. -/
lemma ext (x y : semitangle α) (h : x.members γ = y.members γ) : x = y :=
begin
  obtain ⟨xs, hxs⟩ := x,
  obtain ⟨ys, hys⟩ := y,
  dsimp only at h,
  refine ext_code _,
  obtain ⟨atoms₁, hA₁⟩ | ⟨β, even₁, hA₁⟩ := hxs;
    obtain ⟨atoms₂, hA₂⟩ | ⟨δ, even₂, hA₂⟩ := hys,
  { refine (code.equiv.A_map_right _ (code.is_even_bot _) γ bot_ne_mk_coe).trans _,
    simp only [ne.def, Iio_index.bot_ne_coe, not_false_iff, A_map_code_mk_ne,
      repr_code_base, subtype.coe_mk],
    rw [hA₁ γ, h, ← hA₂ γ],
    exact code.equiv.A_map_left _ (code.is_even_bot _) γ bot_ne_mk_coe },
  { simp only [repr_code_base, subtype.coe_mk, repr_code_proper],
    obtain rfl | hδγ := eq_or_ne δ γ,
    { simp only [is_even_bot, mem_Iio, subtype.val_eq_coe, set_coe.forall,
        ne.def, Iio.coe_inj] at *,
      have := hA₁ δ δ.prop,
      rw subtype.coe_eta at this,
      rw [← h, ← this],
      exact code.equiv.A_map_right _ (code.is_even_bot _) _ bot_ne_mk_coe },
    { refine (code.equiv.A_map_right _ (code.is_even_bot _) γ bot_ne_mk_coe).trans _,
      simp only [ne.def, Iio_index.bot_ne_coe, not_false_iff, A_map_code_mk_ne],
      rw [hA₁ γ, h, ←hA₂ γ (Iio.coe_injective.ne hδγ), ← A_map_code_mk_ne],
      exact code.equiv.A_map_left _ even₂ γ (Iio.coe_injective.ne hδγ) } },
  { simp only [repr_code_proper, subtype.coe_mk, repr_code_base],
    obtain rfl | hβγ := eq_or_ne β γ,
    { dsimp only [mem_Iio, ne.def, subtype.val_eq_coe, set_coe.forall] at *,
      rw [h, ←hA₂ β],
      exact code.equiv.A_map_left _ (code.is_even_bot _) _ bot_ne_mk_coe },
    { refine (code.equiv.A_map_right _ even₁ γ $ Iio.coe_injective.ne hβγ).trans _,
      dsimp only [mem_Iio, ne.def, subtype.val_eq_coe, set_coe.forall] at *,
      rw A_map_code_mk_ne _ _ (Iio.coe_injective.ne hβγ),
      rw [hA₁ γ (Iio.coe_injective.ne hβγ), h, ←hA₂ γ],
      exact code.equiv.A_map_left _ (code.is_even_bot _) γ bot_ne_mk_coe } },
  { simp only [repr_code_proper, subtype.coe_mk],
    obtain rfl | hβγ := eq_or_ne β γ,
    { obtain rfl | hδβ := eq_or_ne δ β,
      { rw h },
      { have := A_map_code_ne β (code.mk δ (ys δ)) (Iio.coe_injective.ne hδβ),
        dsimp only [mem_Iio, ne.def, subtype.val_eq_coe, set_coe.forall, code.snd_mk] at *,
        rw [h, ←hA₂ _ (Iio.coe_injective.ne hδβ), ← code.mk_def, ← this],
        exact code.equiv.A_map_left _ even₂ _ (Iio.coe_injective.ne hδβ) } },
    obtain rfl | hδγ := eq_or_ne δ γ,
    { have := A_map_code_ne δ (code.mk β (xs β)) (Iio.coe_injective.ne hβγ),
      dsimp only [mem_Iio, ne.def, subtype.val_eq_coe, set_coe.forall, code.snd_mk] at *,
      simp_rw [←h, ←hA₁ _ (Iio.coe_injective.ne hβγ), ← code.mk_def, ← this],
      exact code.equiv.A_map_right _ even₁ _ (Iio.coe_injective.ne hβγ) },
    refine (code.equiv.A_map_right _ even₁ γ $ Iio.coe_injective.ne hβγ).trans _,
    have := A_map_code_ne γ (code.mk ↑δ (ys δ)) (Iio.coe_injective.ne hδγ),
    dsimp only [mem_Iio, ne.def, subtype.val_eq_coe, set_coe.forall, code.snd_mk] at *,
    rw A_map_code_ne,
    rw [code.snd_mk, hA₁ γ (Iio.coe_injective.ne hβγ), h, ←hA₂ γ (Iio.coe_injective.ne hδγ)],
    rw ← this,
    exact code.equiv.A_map_left _ even₂ γ (Iio.coe_injective.ne hδγ) }
end

/-- Extensionality in tangled type theory. Two nonempty semitangles are equal if their
`β`-extensions are equal for *any* choice of `β < α`. -/
lemma ext' (x y : semitangle α) (h : ∀ t : tangle γ, t ∈ₛₜ x ↔ t ∈ₛₜ y) : x = y :=
ext x y $ set.ext h

/-- Extensionality at the lowest level of tangled type theory.
At type 0, all nonempty semitangles have a `-1`-extension.
Therefore, the extensionality principle in this case applies to the `-1`-extensions. -/
lemma ext_zero (x y : semitangle α) (α_zero : is_min α) (h : x.pref.atoms = y.pref.atoms) :
  x = y :=
begin
  obtain ⟨xs, ⟨atoms₁, hA₁⟩ | ⟨γ, _, _⟩⟩ := x, swap,
  { cases α_zero.not_lt γ.2 },
  obtain ⟨ys, ⟨atoms₂, hA₂⟩ | ⟨γ, _, _⟩⟩ := y, swap,
  { cases α_zero.not_lt γ.2 },
  have : atoms₁ = atoms₂ := h,
  subst this,
  suffices : xs = ys, by subst this,
  ext β -,
  cases α_zero.not_lt β.2,
end

/-- Construct a semitangle from an even nonempty code. -/
def intro (s : set (tangle β)) (heven : (code.mk β s : code α).is_even) : semitangle α :=
⟨extension s, match β, s, heven with
  | ⟨⊥, _⟩, s, _ := preference.base s $ λ β, rfl
  | ⟨(γ : Λ), hγ⟩, s, heven := preference.proper ⟨γ, coe_lt_coe.1 hγ⟩
    (by { convert heven, exact extension_self (show set (tangle $ Iio_coe ⟨γ, _⟩), from s) }) $
      λ δ hδ, by { rw extension_ne s δ hδ, congr,
        exact extension_self (show set (tangle $ Iio_coe ⟨γ, _⟩), from s) }
  end⟩

@[simp] lemma exts_intro (s : set (tangle β)) (heven) :
  (intro s heven).members = extension s := rfl

end semitangle

open semitangle

variables [core_tangle_data α]

namespace allowable_perm
variables {f : allowable_perm α} {e : extensions α}

@[simp] lemma smul_extension_apply (f : allowable_perm α) (s : set (tangle β)) :
  f • extension s γ = extension (f • s) γ :=
begin
  by_cases β = γ,
  { subst h,
    simp only [extension_eq, cast_eq], },
  { simp only [extension_ne _ _ h, smul_A_map], },
end

@[simp] lemma smul_extension (f : allowable_perm α) (s : set (tangle β)) :
  f • extension s = extension (f • s) :=
begin
  ext γ : 1,
  rw ← smul_extension_apply,
  refl,
end

lemma smul_aux₁ {s : set (tangle (⊥ : Iio_index α))}
  (h : ∀ (γ : Iio α), A_map bot_ne_coe s = (e γ : set (tangle (Iio_coe γ)))) (γ : Iio α) :
  A_map bot_ne_coe (f • s) = (f • e) γ :=
by simpa only [smul_A_map] using congr_arg (λ c, f • c) (h γ)

lemma smul_aux₂ (h : ∀ (δ : Iio α) (hγδ : Iio_coe γ ≠ δ),
  A_map hγδ (e γ) = (e δ : set (tangle (Iio_coe δ)))) (δ : Iio α) (hγδ : Iio_coe γ ≠ δ) :
  A_map hγδ ((f • e) γ) = (f • e) δ :=
by simpa only [smul_A_map] using congr_arg (λ c, f • c) (h δ hγδ)

/-- Allowable permutations act on nonempty semitangles. -/
noncomputable! instance : has_smul (allowable_perm α) (semitangle α) :=
{ smul := λ f t, ⟨f • t.members, begin
    obtain ⟨members, ⟨s, h⟩ | ⟨γ, ht, h⟩⟩ := t,
    { exact preference.base (f • s) (smul_aux₁ h) },
    { exact preference.proper _ ht.smul (smul_aux₂ h) }
    end⟩ }

@[simp] lemma members_smul (f : allowable_perm α) (s : semitangle α) :
  (f • s).members = f • s.members := rfl

@[simp] lemma smul_base (f : allowable_perm α) (e : extensions α) (s h) :
  f • (⟨e, preference.base s h⟩ : semitangle α) =
    ⟨f • e, preference.base (f • s) (smul_aux₁ h)⟩ := rfl

@[simp] lemma smul_proper (f : allowable_perm α) (e : extensions α) (γ ht h) :
  f • (⟨e, preference.proper γ ht h⟩ : semitangle α) =
    ⟨f • e, preference.proper _ ht.smul (smul_aux₂ h)⟩ := rfl

instance mul_action_semitangle : mul_action (allowable_perm α) (semitangle α) := {
  one_smul := begin
    rintro ⟨exts, ⟨s, h⟩ | ⟨γ, ht, h⟩⟩,
    { rw smul_base,
      simp only [one_smul, eq_self_iff_true, true_and],
      refine preference.base_heq_base _ _,
      rw one_smul,
      refl, },
    { rw smul_proper,
      simp only [one_smul, eq_self_iff_true, true_and],
      refine semitangle.preference.proper_heq_proper _ rfl,
      rw one_smul, },
  end,
  mul_smul := begin
    rintro f g ⟨exts, ⟨s, h⟩ | ⟨γ, ht, h⟩⟩,
    { simp only [smul_base, mul_smul, eq_self_iff_true, true_and],
      refine preference.base_heq_base _ _,
      rw mul_smul,
      refl, },
    { simp only [smul_proper, mul_smul, eq_self_iff_true, true_and],
      refine semitangle.preference.proper_heq_proper _ rfl,
      rw mul_smul, },
  end
}

end allowable_perm

variables (α)

/-- A tangle at the new level `α` is a semitangle supported by a small support.
This is `τ_α` in the blueprint.
Unlike the type `tangle`, this is not an opaque definition, and we can inspect and unfold it. -/
@[nolint has_nonempty_instance]
def new_tangle := {s : semitangle α // supported α (allowable_perm α) s}

variables {α} {c d : code α} {S : set (support_condition α)}

open mul_action

/-- If a set of support conditions supports a code, it supports all equivalent codes. -/
protected lemma code.equiv.supports (hcd : c ≡ d) (hS : supports (allowable_perm α) S c) :
  supports (allowable_perm α) S d :=
λ f h, (hcd.symm.smul.trans $ (code.equiv.of_eq $ hS f h).trans hcd).unique rfl

lemma code.equiv.supports_iff (hcd : c ≡ d) :
  supports (allowable_perm α) S c ↔ supports (allowable_perm α) S d :=
⟨hcd.supports, hcd.symm.supports⟩

/-- If two codes are equivalent, one is supported if and only if the other is. -/
lemma code.equiv.small_supported_iff (hcd : c ≡ d) :
  supported α (allowable_perm α) c ↔ supported α (allowable_perm α) d :=
⟨λ ⟨⟨s, hs, h⟩⟩, ⟨⟨s, hs, hcd.supports h⟩⟩, λ ⟨⟨s, hs, h⟩⟩, ⟨⟨s, hs, hcd.symm.supports h⟩⟩⟩

@[simp] lemma smul_intro (f : allowable_perm α) (s : set (tangle β)) (hs) :
  f • intro s hs = intro (f • s) hs.smul :=
begin
  cases β,
  induction β_val using with_bot.rec_bot_coe,
  { simp only [intro, allowable_perm.smul_base, allowable_perm.smul_extension,
      eq_self_iff_true, true_and],
    refine preference.base_heq_base _ rfl,
    rw allowable_perm.smul_extension },
  { simp only [intro, allowable_perm.smul_proper, allowable_perm.smul_extension,
      eq_self_iff_true, true_and],
    refine preference.proper_heq_proper _ rfl,
    rw allowable_perm.smul_extension }
end

-- TODO: Move next two lemmas elsewhere.
lemma allowable_to_struct_perm_bot (π : allowable (⊥ : Iio_index α)) :
  core_tangle_data.allowable_to_struct_perm π = struct_perm.to_bot_iso.to_monoid_hom π := rfl

lemma _root_.con_nf.semiallowable_perm.to_allowable_bot (π : semiallowable_perm α) :
  semiallowable_perm.to_allowable ⊥ π = struct_perm.to_near_litter_perm
    (semiallowable_perm.to_struct_perm π) :=
begin
  unfold semiallowable_perm.to_allowable semiallowable_perm.to_struct_perm
    struct_perm.to_near_litter_perm struct_perm.lower allowable.to_struct_perm,
  rw dif_neg with_bot.bot_ne_coe,
  simp only [monoid_hom.coe_mk, monoid_hom.coe_comp, mul_equiv.coe_to_monoid_hom,
    comp_app, struct_perm.of_coe_to_coe, allowable_to_struct_perm_bot, mul_equiv.symm_apply_apply],
  refl,
end

/-- For any near-litter `N`, the code `(α, -1, N)` is a tangle at level `α`.
This is called a *typed near litter*. -/
def new_typed_near_litter (N : near_litter) : new_tangle α :=
⟨intro (show set (tangle (⊥ : Iio_index α)), from N.2.1) $
  code.is_even_bot _, ⟨⟨{(sum.inr N, default)}, small_singleton _, λ π h, begin
    simp only [subtype.val_eq_coe, option.smul_some, smul_intro, option.some_inj],
    have := show (struct_perm.lower (bot_lt_coe α).le (semiallowable_perm.to_struct_perm ↑π)) •
      sum.inr N = sum.inr N, from congr_arg prod.fst (h rfl),
    simp only [sum.smul_inr] at this,
    have : π • N = N := this,
    conv_rhs { rw ← this },
    congr' 1,
    ext : 1,
    simp only [coe_smul_nonempty, subtype.coe_mk, allowable_perm.snd_smul_near_litter],
    unfold has_smul.smul has_smul.comp.smul,
    simp only [semiallowable_perm.to_allowable_bot (allowable_perm.coe_hom π)],
  end⟩⟩⟩

/-- For any supported tangle `x`, the code `(α, β, {x})` is a tangle at level `α`. -/
def supported_singleton (x : tangle β) (supp : supported α (allowable_perm α) x) :
  new_tangle α :=
⟨intro {x} (code.is_even_singleton _), begin
  unfreezingI { obtain ⟨s, hs₁, hs₂⟩ := supp },
  refine ⟨⟨s, hs₁, λ π h, _⟩⟩,
  conv_rhs { rw ← hs₂ π h },
  simp only [smul_set_singleton, smul_nonempty_mk, option.smul_some, smul_intro],
end⟩

/-- For any small set `B` of supported `β`-tangles, the code `(α, β, B)` is a tangle at level `α` if
it is even. -/
def supported_set (s : set (tangle β)) (hs : small s) (hc : (mk β s).is_even)
  (symm : ∀ b ∈ s, supported α (allowable_perm α) b) :
  new_tangle α :=
⟨intro s hc, begin
  have symm : Π b ∈ s, support α (allowable_perm α) b,
  { intros b hb, exact (symm b hb).some },
  refine ⟨⟨⋃ b ∈ s, symm b ‹_›, hs.bUnion (λ i hi, (symm _ _).small), λ π h, _⟩⟩,
  suffices : π • s = s,
  { simp only [option.smul_some, smul_intro, option.some_inj, this] },
  have : ∀ x ∈ s, π • x = x,
  { intros x hx,
    refine (symm x hx).supports π _,
    intros a ha,
    refine h _,
    simp only [mem_Union, set_like.mem_coe],
    refine ⟨x, hx, ha⟩ },
  ext : 2,
  refine ⟨λ hx, _, λ hx, _⟩,
  { have := this (π⁻¹ • x) _,
    { rw smul_inv_smul at this,
      rw this,
      rwa ←mem_smul_set_iff_inv_smul_mem },
    { rwa ←mem_smul_set_iff_inv_smul_mem } },
  { rw ← this x hx,
    exact smul_mem_smul_set hx }
end⟩

variables {α}

namespace new_tangle

instance : has_coe (new_tangle α) (semitangle α) := coe_subtype

lemma coe_injective : injective (coe : new_tangle α → semitangle α) := subtype.coe_injective

end new_tangle

namespace allowable_perm

/-- Allowable permutations act on `α`-tangles. -/
--Yaël: I suspect we can generalize `supports.smul` so that it applies here
instance has_smul_new_tangle : has_smul (allowable_perm α) (new_tangle α) :=
⟨λ π t, ⟨π • t, t.2.map $ λ s, { carrier := π • s, small := s.2.image, supports := begin
  intros σ h,
  have := s.supports (π⁻¹ * σ * π) _,
  { conv_rhs { rw [← subtype.val_eq_coe, ← this, ← mul_smul, ← mul_assoc, ← mul_assoc,
      mul_inv_self, one_mul, mul_smul] },
    refl },
  { intros a ha,
    rw [mul_smul, mul_smul, inv_smul_eq_iff],
    exact h (smul_mem_smul_set ha) },
end }⟩⟩

@[simp, norm_cast] lemma coe_smul_new_tangle (f : allowable_perm α) (t : new_tangle α) :
  (↑(f • t) : semitangle α) = f • t := rfl

instance mul_action_new_tangle : mul_action (allowable_perm α) (new_tangle α) :=
new_tangle.coe_injective.mul_action _ coe_smul_new_tangle

end allowable_perm

end con_nf


import .sform .pform .norm

namespace polya.field

--namespace nterm
--
--variables {α : Type} [discrete_field α]
--variables {γ : Type} [const_space γ]
--variables [morph γ α] {ρ : dict α}
--
--instance coe_atom  : has_coe num (nterm γ) := ⟨atom⟩
--instance coe_const : has_coe γ (nterm γ) := ⟨const⟩
--
--instance : has_zero (nterm γ) := ⟨const 0⟩
--instance : has_one (nterm γ) := ⟨const 1⟩
--
--instance : has_add (nterm γ) := ⟨sform.add⟩
--instance : has_mul (nterm γ) := ⟨pform.mul⟩
--instance : has_pow (nterm γ) ℤ := ⟨λ (x : nterm γ) (n : ℤ), pow_mul (n : znum) x⟩
--
--instance : has_neg (nterm γ) := ⟨scale (-1)⟩
--instance : has_sub (nterm γ) := ⟨λ x y, x + -y⟩
--instance : has_inv (nterm γ) := ⟨λ x, x ^ (-1 : ℤ)⟩
--instance : has_div (nterm γ) := ⟨λ x y, x * y⁻¹⟩
--
--instance pow_nat : has_pow (nterm γ) ℕ := ⟨λ (x : nterm γ) (n : ℕ), x ^ (n : ℤ)⟩
--
--section
--
--variables {x y : nterm γ} {i : num} {n : ℤ} {c : γ}
--
--@[simp] theorem eval_zero  : eval ρ (0 : nterm γ) = 0 := by apply morph.morph_zero'
--@[simp] theorem eval_one   : eval ρ (1 : nterm γ) = 1 := by apply morph.morph_one'
--@[simp] theorem eval_const : eval ρ (const c) = c     := rfl
--@[simp] theorem eval_atom  : eval ρ (atom i : nterm γ) = ρ.val i := rfl
--
--@[simp] theorem eval_add : eval ρ (x + y) = eval ρ x + eval ρ y := sform.eval_add
--@[simp] theorem eval_mul : eval ρ (x * y) = eval ρ x * eval ρ y := pform.eval_mul
--@[simp] theorem eval_pow : eval ρ (x ^ n) = eval ρ x ^ n        := by { convert eval_pow_mul, rw znum.to_of_int }
--
--@[simp] theorem eval_neg : eval ρ (-x)    = - x.eval ρ          := by { refine eq.trans eval_scale _, rw [morph.morph_neg, morph.morph_one', mul_neg_one] }
--@[simp] theorem eval_sub : eval ρ (x - y) = x.eval ρ - y.eval ρ := by { refine eq.trans eval_add _, rw [eval_neg, sub_eq_add_neg] }
--@[simp] theorem eval_inv : eval ρ (x⁻¹)   = (x.eval ρ)⁻¹        := by { rw [← fpow_inv, ← eval_pow], refl }
--@[simp] theorem eval_div : eval ρ (x / y) = x.eval ρ / y.eval ρ := by { rw [division_def, ← eval_inv, ← eval_mul], refl }
--
--@[simp] theorem eval_pow_nat {n : ℕ} : eval ρ (x ^ n) = eval ρ x ^ n := eval_pow
--
--end
--
--end nterm

@[derive decidable_eq, derive has_reflect]
inductive term : Type
| atom : num → term
| add  : term → term → term
| sub  : term → term → term
| mul  : term → term → term
| div  : term → term → term
| neg  : term → term
| inv  : term → term
| numeral : ℕ → term
| pow_nat : term → ℕ → term
| pow_int : term → ℤ → term

namespace term

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def eval (ρ : dict α) : term → α
| (atom i)  := ρ.val i
| (add x y) := eval x + eval y
| (sub x y) := eval x - eval y
| (mul x y) := eval x * eval y
| (div x y) := (eval x) / (eval y)
| (neg x)   := - eval x
| (inv x)   := (eval x)⁻¹
| (numeral n)   := (n : α)
| (pow_nat x n) := eval x ^ n
| (pow_int x n) := eval x ^ n

def to_nterm : term → nterm γ
| (atom i)  := ↑i
| (add x y) := to_nterm x + to_nterm y
| (sub x y) := to_nterm x - to_nterm y
| (mul x y) := to_nterm x * to_nterm y
| (div x y) := to_nterm x / to_nterm y
| (neg x)   := - to_nterm x
| (inv x)   := (to_nterm x)⁻¹
| (numeral n)   := ↑(n : γ)
| (pow_nat x n) := to_nterm x ^ n
| (pow_int x n) := to_nterm x ^ n

theorem correctness {x : term} :
  nterm.eval ρ (@to_nterm γ _ x) = eval ρ x :=
begin
  induction x with
    i           --atom
    x y ihx ihy --add
    x y ihx ihy --sub
    x y ihx ihy --mul
    x y ihx ihy --div
    x ihx       --neg
    x ihx       --inv
    n           --numeral
    x n ihx     --pow_nat
    x n ihx,    --pow_int
  repeat { unfold to_nterm, unfold eval },
  repeat { simp [nterm.eval] },
  repeat { simp [nterm.eval, ihx] },
  repeat { simp [nterm.eval, ihx, ihy] },
  --{ rw [fpow_inv, division_def] },
  --{ rw fpow_inv }
end

end term

def norm (γ : Type) [const_space γ] (x : term) : nterm γ :=
nterm.norm $ @term.to_nterm γ _ x

def norm_hyps (γ : Type) [const_space γ] (x : term) : list (nterm γ) :=
nterm.norm_hyps $ @term.to_nterm γ _ x

variables {γ : Type} [const_space γ]
variables {α : Type} [discrete_field α]
variables [morph γ α] {ρ : dict α}

theorem correctness {x : term} {ρ : dict α} :
  (∀ t ∈ norm_hyps γ x, nterm.eval ρ t ≠ 0) →
  term.eval ρ x = nterm.eval ρ (norm γ x) :=
begin
  intro H,
  unfold norm,
  apply eq.symm, apply eq.trans,
  { apply nterm.correctness, unfold nterm.nonzero,
    intros t ht, apply H, exact ht },
  { apply term.correctness }
end

open nterm

def aux1 (t1 t2 : nterm γ) : nterm γ × nterm γ × γ :=
if t2.coeff = 0 then
  (t1.term, 0, t1.coeff)
else
  (t2.term, t1.scale (t2.coeff⁻¹), -t2.coeff)

def aux2 (t1 t2 : nterm γ) : nterm γ × nterm γ × γ :=
if t2.term < t1.term then
  aux1 (t2.scale (-1)) (t1.scale (-1))
else
  aux1 t1 t2

theorem eval_aux1 {t1 t2 t3 t4 : nterm γ} {c : γ} :
  (t3, t4, c) = aux1 t1 t2 →
  eval ρ t1 - eval ρ t2 = (eval ρ t3 - eval ρ t4) * c :=
begin
  unfold aux1,
  by_cases h1 : t2.coeff = 0,
  { rw if_pos h1, intro h2,
    rw [prod.mk.inj_iff] at h2, cases h2 with h2 h3,
    rw [prod.mk.inj_iff] at h3, cases h3 with h3 h4,
    rw [eval_term_coeff t1, eval_term_coeff t2, h1, h2, h3, h4],
    simp [morph.morph_neg] },
  { rw if_neg h1, intro h2,
    rw [prod.mk.inj_iff] at h2, cases h2 with h2 h3,
    rw [prod.mk.inj_iff] at h3, cases h3 with h3 h4,
    rw [h2, h3, h4],
    rw [morph.morph_neg, mul_neg_eq_neg_mul_symm, neg_mul_eq_neg_mul, neg_sub, sub_mul],
    rw [← eval_term_coeff], congr' 1,
    rw [eval_scale, mul_assoc, ← morph.morph_mul, inv_mul_cancel],
    rw [morph.morph_one, mul_one], --simp
    exact h1 }
end

theorem eval_aux2 {t1 t2 t3 t4 : nterm γ} {c : γ} :
  (t3, t4, c) = aux2 t1 t2 →
  eval ρ t1 - eval ρ t2 = (eval ρ t3 - eval ρ t4) * c :=
begin
  unfold aux2,
  by_cases h1 : t2.term < t1.term,
  { rw if_pos h1, intro h2,
    have : eval ρ (t2.scale (-1)) - eval ρ (t1.scale (-1)) = (eval ρ t3 - eval ρ t4) * ↑c,
    { exact eval_aux1 h2 },
    rw ← this, simp [morph.morph_neg] },
  { rw if_neg h1, intro h2, exact eval_aux1 h2 }
end

def norm2 (γ : Type) [const_space γ] (t1 t2 : term) : nterm γ × nterm γ × γ :=
  aux2 (norm γ t1) (norm γ t2)

theorem eval_norm2 {t1 t2 : term} {nt1 nt2 : nterm γ} {c : γ} :
  nonzero ρ (norm_hyps γ t1) →
  nonzero ρ (norm_hyps γ t2) →
  (nt1, nt2, c) = norm2 γ t1 t2 →
  term.eval ρ t1 - term.eval ρ t2 =
    (nterm.eval ρ nt1 - nterm.eval ρ nt2) * c :=
begin
  unfold norm2,
  intros h1 h2 h3,
  apply eq.trans,
  { show _ = eval ρ (norm γ t1) - eval ρ (norm γ t2), rw [correctness h1, correctness h2] },
  { exact eval_aux2 h3 }
end

end polya.field


import data.hash_map library_dev.data.list.set

namespace state

@[inline] def modify {σ : Type} : (σ → σ) → state σ unit :=
λ f s, ((), f s)

def inc : state ℕ unit := modify (λ n, n + 1)
def dec : state ℕ unit := modify (λ n, n - 1)
end state

namespace list

def dnth {α : Type*} [decidable_eq α] [inhabited α] (xs : list α) (n : ℕ) : α :=
match xs^.nth n with
| (some x) := x
| none     := default α
end

def at_nth {α : Type*} (xs : list α) (idx : ℕ) (x : α) : Prop := nth xs idx = some x

def set_nth {α : Type*} : list α → ℕ → α → option (list α)
| (x::xs) 0     a := some (a :: xs)
| (x::xs) (i+1) a := do ys ← set_nth xs i a, return (x :: ys)
| []      _     _ := none

lemma at_nth_of_dnth_lt {α : Type*} [decidable_eq α] [inhabited α] {xs : list α} {idx : ℕ} :
  idx < length xs → at_nth xs idx (dnth xs idx) := sorry

lemma at_nth_of_len {α : Type*} {xs ys : list α} {x : α} {k : ℕ} : k = length xs → at_nth (xs ++ x :: ys) k x := sorry

end list
namespace hash_map

def dfind {α : Type*} [decidable_eq α] {β : α → Type*} [∀ a, inhabited (β a)] (m : hash_map α β) (a : α) : β a :=
match m^.find a with
| (some b) := b
| none     := default (β a)
end

end hash_map

section seq
variables {α : Type*} (rel : α → α → Prop)

inductive star : α → α → Prop
| rfl    : ∀ (x : α), star x x
| rtrans : ∀ (x y z : α), rel x y → star y z → star x y

end seq

namespace star
variables {α : Type*} (rel : α → α → Prop)

lemma trans (x y z : α) : star rel x y → star rel y z → star rel x z := sorry

end star

namespace compiler
open tactic list

structure var : Type := (id : ℕ)

namespace var
instance : decidable_eq var := by mk_dec_eq_instance
end var

@[reducible] def vstate : Type := hash_map var (λ v : var, ℕ)
def empty_vstate : vstate := mk_hash_map (λ v : var, v^.id)

inductive aexp : Type
| aconst : ℕ → aexp
| avar   : var → aexp
| aadd   : aexp → aexp → aexp
| asub   : aexp → aexp → aexp
| amul   : aexp → aexp → aexp

inductive bexp : Type
| btrue  : bexp
| bfalse : bexp
| bnot   : bexp → bexp
| band   : bexp → bexp → bexp
| beq    : aexp → aexp → bexp
| ble    : aexp → aexp → bexp

def aeval (st : vstate) : aexp → ℕ
| (aexp.aconst n) := n
| (aexp.avar v) := st^.dfind v
| (aexp.aadd e₁ e₂) := aeval e₁ + aeval e₂
| (aexp.asub e₁ e₂) := aeval e₁ - aeval e₂
| (aexp.amul e₁ e₂) := aeval e₁ * aeval e₂

def beval (st : vstate) : bexp → bool
| (bexp.btrue)      := tt
| (bexp.bfalse)     := ff
| (bexp.bnot b)     := bnot (beval b)
| (bexp.band b₁ b₂) := beval b₁ && beval b₂
| (bexp.beq e₁ e₂)  := aeval st e₁ = aeval st e₂
| (bexp.ble e₁ e₂)  := aeval st e₁ ≤ aeval st e₂

inductive com : Type
| cskip  : com
| cass   : var → aexp → com
| cseq   : com → com → com
| cif    : bexp → com → com → com
| cwhile : bexp → com → com

open com

inductive ceval : com → vstate → vstate → Prop
| eskip : ∀ st, ceval cskip st st
| eass  : ∀ st a n x, aeval st a = n → ceval (cass x a) st (st^.insert x n)
| eseq : ∀ c₁ c₂ st₁ st₂ st₃, ceval c₁ st₁ st₂ → ceval c₂ st₂ st₃ → ceval (cseq c₁ c₂) st₁ st₃
| eift : ∀ st₁ st₂ b c₁ c₂, beval st₁ b = tt → ceval c₁ st₁ st₂ → ceval (cif b c₁ c₂) st₁ st₂
| eiff : ∀ st₁ st₂ b c₁ c₂, beval st₁ b = ff → ceval c₂ st₁ st₂ → ceval (cif b c₁ c₂) st₁ st₂
| ewhilet : ∀ st₁ st₂ st₃ b c, beval st₁ b = tt → ceval c st₁ st₂ → ceval (cwhile b c) st₂ st₃ → ceval (cwhile b c) st₁ st₃
| ewhilef : ∀ st b c, beval st b = ff → ceval (cwhile b c) st st

open ceval

inductive instruction : Type
| iconst : ℕ → instruction
| iget   : ℕ → instruction
| iset   : ℕ → instruction
| iadd   : instruction
| isub   : instruction
| imul   : instruction
| ibf    : ℕ → instruction
| ibb    : ℕ → instruction
| ibeq   : ℕ → instruction
| ibne   : ℕ → instruction
| ible   : ℕ → instruction
| ibgt   : ℕ → instruction
| ihalt  : instruction

open instruction

@[reducible] def code := list instruction.

@[reducible] def stack : Type := list ℕ
@[reducible] def config : Type := ℕ × stack

inductive veval (c : code) : config -> config -> Prop
| vconst : ∀ pc stk n, at_nth c pc (iconst n) → veval (pc, stk) (pc + 1, n :: stk)
| vget   : ∀ pc stk n v, at_nth c pc (iget n) → at_nth stk n v → veval (pc, stk) (pc + 1, v :: stk)
| vset   : ∀ pc stk n v stk', at_nth c pc (iset n) → set_nth stk n v = some stk' → veval (pc, v :: stk) (pc + 1, stk')
| vadd   : ∀ pc stk n n₁ n₂, at_nth c pc iadd → n = n₁ + n₂ → veval (pc, n₂ :: n₁ :: stk) (pc + 1, n :: stk)
| vsub   : ∀ pc stk n₁ n₂, at_nth c pc iadd → veval (pc, n₂ :: n₁ :: stk) (pc + 1, (n₁ - n₂) :: stk)
| vmul   : ∀ pc stk n₁ n₂, at_nth c pc iadd → veval (pc, n₂ :: n₁ :: stk) (pc + 1, (n₁ * n₂) :: stk)
| vbf    : ∀ pc stk ofs pc', at_nth c pc (ibf ofs) → pc' = (pc + ofs) + 1 → veval (pc, stk) (pc', stk)
| vbb    : ∀ pc stk ofs pc', at_nth c pc (ibf ofs) → pc' + ofs = pc + 1 → veval (pc, stk) (pc', stk)
| vbeq   : ∀ pc stk ofs n₁ n₂ pc', at_nth c pc (ibeq ofs) → pc' = (if n₁ = n₂ then (pc + ofs) + 1 else pc + 1) → veval (pc, n₂ :: n₁ :: stk) (pc', stk)
| vbne   : ∀ pc stk ofs n₁ n₂ pc', at_nth c pc (ibne ofs) → pc' = (if n₁ = n₂ then pc + 1 else (pc + ofs) + 1) → veval (pc, n₂ :: n₁ :: stk) (pc', stk)
| vble   : ∀ pc stk ofs n₁ n₂ pc', at_nth c pc (ible ofs) → pc' = (if n₁ ≤ n₂ then (pc + ofs) + 1 else pc + 1) → veval (pc, n₂ :: n₁ :: stk) (pc', stk)
| vbgt   : ∀ pc stk ofs n₁ n₂ pc', at_nth c pc (ibgt ofs) → pc' = (if n₁ ≤ n₂ then pc + 1 else (pc + ofs) + 1) → veval (pc, n₂ :: n₁ :: stk) (pc', stk)

def vhalts (c : code) (stk_init stk_fin : stack) : Prop :=
∃ pc, at_nth c pc ihalt ∧ star (veval c) (0, stk_init) (pc, stk_fin)

def collect_assigned_vars : com → list var
| (cskip)       := []
| (cass v _)    := [v]
| (cseq c₁ c₂)  := collect_assigned_vars c₁ ∪ collect_assigned_vars c₂
| (cif b c₁ c₂) := collect_assigned_vars c₁ ∪ collect_assigned_vars c₂
| (cwhile b c)  := collect_assigned_vars c

@[reducible] def stack_offsets : Type := hash_map var (λ v : var, ℕ)

def compute_stack_offsets_core : list var → stack_offsets → stack_offsets
| []        s := s
| (v :: vs) s := compute_stack_offsets_core vs (s^.insert v (length vs))

def compute_stack_offsets (c : com) : stack_offsets :=
compute_stack_offsets_core (collect_assigned_vars c) (mk_hash_map (λ (v : var), v^.id))

-- TODO(dhs): not sure if this is the best way to do it
def agree (offsets : stack_offsets) (vofs : ℕ) (st : vstate) (stk : stack) : Prop :=
  ∀ (v : var), st^.dfind v = dnth stk (offsets^.dfind v + vofs)

lemma agree_push {offsets : stack_offsets} {vofs : ℕ} {st : vstate} {stk : stack} {n : ℕ} :
  agree offsets vofs st stk → agree offsets (vofs + 1) st (n :: stk) := sorry

lemma agree_insert {offsets : stack_offsets} {vofs : ℕ} {st : vstate} {stk : stack} :
  agree offsets vofs st stk →
  ∀ v n,
  agree offsets vofs (hash_map.insert st v n) (update_nth stk (hash_map.dfind offsets v) n) := sorry

inductive codeseq_at : code → ℕ → code → Prop
| intro : ∀ code₁ code₂ code₃ pc, pc = length code₁ → codeseq_at (code₁ ++ code₂ ++ code₃) pc code₂

def compile_aexp_core (offsets : stack_offsets) : aexp → ℕ → code
| (aexp.aconst n)   vofs := [iconst n]
| (aexp.avar v)     vofs := [iget $ offsets^.dfind v + vofs]
| (aexp.aadd e₁ e₂) vofs := compile_aexp_core e₂ vofs ++ compile_aexp_core e₁ (vofs + 1) ++ [iadd]
| (aexp.asub e₁ e₂) vofs := compile_aexp_core e₂ vofs ++ compile_aexp_core e₁ (vofs + 1) ++ [isub]
| (aexp.amul e₁ e₂) vofs := compile_aexp_core e₂ vofs ++ compile_aexp_core e₁ (vofs + 1) ++ [imul]

def compile_aexp (offsets : stack_offsets) (e : aexp) := compile_aexp_core offsets e 0

-- TODO(dhs): weaken the forall?
def astack_contains_vars (offsets : stack_offsets) : stack → ℕ → aexp → Prop
| stk vofs (aexp.aconst n)   := true
| stk vofs (aexp.avar v)     := offsets^.dfind v + vofs < length stk
| stk vofs (aexp.aadd e₁ e₂) := astack_contains_vars stk vofs e₂ ∧ ∀ x, astack_contains_vars (x :: stk) (vofs + 1) e₁
| stk vofs (aexp.asub e₁ e₂) := astack_contains_vars stk vofs e₂ ∧ ∀ x, astack_contains_vars (x :: stk) (vofs + 1) e₁
| stk vofs (aexp.amul e₁ e₂) := astack_contains_vars stk vofs e₂ ∧ ∀ x, astack_contains_vars (x :: stk) (vofs + 1) e₁

lemma compile_aexp_core_correct :
  ∀ code st e pc stk offsets vofs,
    codeseq_at code pc (compile_aexp_core offsets e vofs)
    → agree offsets vofs st stk
    → astack_contains_vars offsets stk vofs e
    → star (veval code) (pc, stk) (pc + length (compile_aexp_core offsets e vofs), aeval st e :: stk)

| .(_) st (aexp.aconst n) .(pc) stk offsets vofs (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_astack :=
begin
simp [compile_aexp_core, length, aeval],
apply star.rtrans,
apply veval.vconst,
apply at_nth_of_len H_pc,
apply star.rfl
end

| .(_) st (aexp.avar v) .(pc) stk offsets vofs (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_astack :=
begin
simp [compile_aexp_core, length, aeval],
apply star.rtrans,
apply veval.vget,
apply at_nth_of_len H_pc,
simp [agree] at H_agree,
simp [astack_contains_vars] at H_astack,
rw H_agree,
apply at_nth_of_dnth_lt H_astack,
apply star.rfl
end

| .(_) st (aexp.aadd e₁ e₂) .(pc) stk offsets vofs (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_astack :=
begin
simp [compile_aexp_core, length, aeval],
apply star.trans,
-- Compile e₂
apply compile_aexp_core_correct _ st e₂ _ _ offsets vofs _ H_agree (and.left H_astack),
rw ← append_assoc,
apply codeseq_at.intro _ _ _ _ H_pc,
-- Compile e₁
apply star.trans,
apply compile_aexp_core_correct _ st e₁ _ _ offsets (vofs+1) _ (agree_push H_agree) (and.right H_astack _),
have H_assoc :
(code₁ ++ (compile_aexp_core offsets e₂ vofs ++ (compile_aexp_core offsets e₁ (vofs + 1) ++ iadd :: code₃)))
=
(code₁ ++ compile_aexp_core offsets e₂ vofs) ++ (compile_aexp_core offsets e₁ (vofs + 1)) ++ iadd :: code₃ := sorry,
rw H_assoc, clear H_assoc,
apply codeseq_at.intro _ _ _ _,
simp [H_pc, length_append],

-- Add instruction
apply star.rtrans,
have H_assoc :
code₁ ++ (compile_aexp_core offsets e₂ vofs ++ (compile_aexp_core offsets e₁ (vofs + 1) ++ iadd :: code₃))
=
(code₁ ++ compile_aexp_core offsets e₂ vofs ++ compile_aexp_core offsets e₁ (vofs + 1)) ++ [iadd] ++ code₃ := sorry,
rw H_assoc, clear H_assoc,

have H_one_at_end :
pc + (1 + (length (compile_aexp_core offsets e₂ vofs) + length (compile_aexp_core offsets e₁ (vofs + 1))))
=
(pc + length (compile_aexp_core offsets e₂ vofs) + length (compile_aexp_core offsets e₁ (vofs + 1))) + 1 := sorry,
rw H_one_at_end, clear H_one_at_end,
apply veval.vadd,

have H_cons :
code₁ ++ compile_aexp_core offsets e₂ vofs ++ compile_aexp_core offsets e₁ (vofs + 1) ++ [iadd] ++ code₃
=
(code₁ ++ compile_aexp_core offsets e₂ vofs ++ compile_aexp_core offsets e₁ (vofs + 1)) ++ (iadd :: code₃) := sorry,
rw H_cons, clear H_cons,
apply at_nth_of_len,
simp [H_pc, length_append],
simp,
apply star.rfl,

end

def compile_bexp (offsets : stack_offsets) : bexp → bool → ℕ → code
| (bexp.btrue)      cond ofs := if cond then [ibf ofs] else []
| (bexp.bfalse)     cond ofs := if cond then [] else [ibf ofs]
| (bexp.bnot b)     cond ofs := compile_bexp b (bnot cond) ofs
| (bexp.band b₁ b₂) cond ofs := let code₂ := compile_bexp b₂ cond ofs,
                                    code₁ := compile_bexp b₁ ff (if cond then length code₂ else ofs + length code₂)
                                in  code₁ ++ code₂

| (bexp.beq e₁ e₂)  cond ofs := compile_aexp_core offsets e₂ 0 ++ compile_aexp_core offsets e₁ 1 ++ (if cond then [ibeq ofs] else [ibne ofs])
| (bexp.ble e₁ e₂)  cond ofs := compile_aexp_core offsets e₂ 0 ++ compile_aexp_core offsets e₁ 1 ++ (if cond then [ible ofs] else [ibgt ofs])

-- TODO(dhs): weaken the forall?
-- TODO(dhs): is this even right? We'll see soon.
def bstack_contains_vars (offsets : stack_offsets) : stack → bexp → Prop
| stk (bexp.btrue)      := true
| stk (bexp.bfalse)     := true
| stk (bexp.bnot b)     := bstack_contains_vars stk b
| stk (bexp.band b₁ b₂) := bstack_contains_vars stk b₁ ∧ bstack_contains_vars stk b₂
| stk (bexp.beq e₁ e₂)  := astack_contains_vars offsets stk 0 e₂ ∧ ∀ x, astack_contains_vars offsets (x::stk) 1 e₁
| stk (bexp.ble e₁ e₂)  := astack_contains_vars offsets stk 0 e₂ ∧ ∀ x, astack_contains_vars offsets (x::stk) 1 e₁

--set_option pp.all true
--set_option trace.type_context.is_def_eq true
--set_option trace.type_context.is_def_eq_detail true

lemma compile_bexp_correct :
  ∀ code st b cond ofs pc stk offsets,
    codeseq_at code pc (compile_bexp offsets b cond ofs)
    → agree offsets 0 st stk
    → bstack_contains_vars offsets stk b
    → star (veval code) (pc, stk)
                        (pc + (length (compile_bexp offsets b cond ofs) + ite (beval st b = cond) ofs 0), stk)
/-
| .(_) st (bexp.btrue) cond ofs .(pc) stk offsets (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_bstack :=
begin
simp [compile_bexp, compile_aexp_core, length, aeval, beval],
cases cond,
{ simp, apply star.rfl },
simp,
apply star.rtrans,
apply veval.vbf _ _ ofs,
apply at_nth_of_len H_pc,
simp,
apply star.rfl
end

| .(_) st (bexp.bfalse) cond ofs .(pc) stk offsets (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_bstack :=
begin
simp [compile_bexp, compile_aexp_core, length, aeval, beval],
cases cond,
{ simp, apply star.rtrans, apply veval.vbf _ _ ofs, apply at_nth_of_len H_pc, simp, apply star.rfl },
{ simp, apply star.rfl },
end

| .(_) st (bexp.bnot b) cond ofs .(pc) stk offsets (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_bstack :=
begin
simp [compile_bexp, compile_aexp_core, length, aeval, beval],
-- TODO(dhs): come on, Lean
have H_bnot : ∀ beq, (@ite (bnot (beval st b) = cond) beq _ ofs 0) = (ite (beval st b = bnot cond) ofs 0) := sorry,
rw H_bnot, clear H_bnot,

apply compile_bexp_correct (code₁ ++ (compile_bexp offsets b (bnot cond) ofs ++ code₃)) st b (bnot cond) ofs pc stk offsets _ H_agree H_bstack,
rw ← append_assoc,
apply codeseq_at.intro _ _ _ _ H_pc,

end
-/

| .(_) st (bexp.band b₁ b₂) cond ofs .(pc) stk offsets (codeseq_at.intro code₁ ._ code₃ pc H_pc) H_agree H_bstack :=
begin
simp [compile_bexp, compile_aexp_core, length, aeval, beval],
-- b₁
apply star.trans,

have H_assoc :
(code₁ ++
          (compile_bexp offsets b₁ ff
               (ite ↑cond (length (compile_bexp offsets b₂ cond ofs))
                  (ofs + length (compile_bexp offsets b₂ cond ofs))) ++
             (compile_bexp offsets b₂ cond ofs ++ code₃)))
=
(code₁ ++
          (compile_bexp offsets b₁ ff
               (ite ↑cond (length (compile_bexp offsets b₂ cond ofs))
                  (ofs + length (compile_bexp offsets b₂ cond ofs)))) ++
             (compile_bexp offsets b₂ cond ofs ++ code₃)) := sorry,
rw H_assoc, clear H_assoc,

apply compile_bexp_correct _ st b₁ ff _ pc stk offsets _ H_agree (and.left H_bstack),
tactic.rotate 1,
apply codeseq_at.intro _ _ _ _ H_pc,

--
cases cond,
simp,
have H_em : (beval st b₁ = ff ∨ beval st b₁ = tt) := sorry,
cases H_em with H_ff H_tt,
simp [H_ff],
apply star.rfl,
simp [H_tt],
have H_assoc :
(code₁ ++
          (compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs)) ++
             (compile_bexp offsets b₂ ff ofs ++ code₃)))
=
(code₁ ++ compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs)) ++ (compile_bexp offsets b₂ ff ofs ++ code₃)) := sorry,
rw H_assoc, clear H_assoc,

-- TODO(dhs): why won't it unify?
have H_come_on_lean : ∀ bdec, @ite (beval st b₂ = ff) bdec _ ofs 0 = ite (beval st b₂ = ff) ofs 0 := sorry,

have H_rec₂ := compile_bexp_correct (code₁ ++ compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs)) ++
          (compile_bexp offsets b₂ ff ofs ++ code₃)) st b₂ ff ofs (pc + length (compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs)))) stk offsets,
simp [H_come_on_lean] at H_rec₂,
simp [H_come_on_lean],
apply H_rec₂,
clear H_rec₂,
have H_assoc :
    (code₁ ++
       (compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs)) ++
          (compile_bexp offsets b₂ ff ofs ++ code₃)))
=
    (code₁ ++ compile_bexp offsets b₁ ff (ofs + length (compile_bexp offsets b₂ ff ofs))) ++
          compile_bexp offsets b₂ ff ofs ++ code₃ := sorry,
rw H_assoc, clear H_assoc,
apply codeseq_at.intro,
simp [H_pc],
exact H_agree,
exact and.right H_bstack,

-- cond = tt
exact sorry
end

-- Example program
---------------------------
-- (cass `x 1)
-- (cass `y (+ x x))
-- (cass `z (+ x (+ y x))

-- Want
--------------------------
-- Initial stack: [x:=0, y:=0, z:=0]
-- cass `x 1 ==>  push 1, iset 1 ==> [x:=1, y:=0, z:=0]
-- cass `y (+ x x) ==> iget 0, iget 1, iadd, iset 2 ==> [x:=2, y:=4, z:=0]
-- cass `z (+ x (+ y x)) ==> iget 0, iget 2, iget 2, iadd, iadd, iset 3

definition compile_com (offsets : stack_offsets) : com → code
| cskip         := []
| (cass v e)    := compile_aexp offsets e ++ [iset $ offsets^.dfind v]
| (cseq c₁ c₂)  := compile_com c₁ ++ compile_com c₂

| (cif b c₁ c₂) := let code₁ := compile_com c₁,
                       code₂ := compile_com c₂
                   in  compile_bexp offsets b false (length code₁ + 1) ++ code₁ ++ [ibf (length code₂)] ++ code₂
| (cwhile b c)  := let code_body := compile_com c,
                       code_test := compile_bexp offsets b ff (length code_body + 1)
                   in  code_test ++ code_body ++ [ibb (length code_test + length code_body + 1)]

-- TODO(dhs): is this _strong_ enough, with `offsets` an argument?
-- TODO(dhs): is this _weak_ enough, to prove?
theorem compile_correct_terminating_alt :
  ∀ code st c st',
    ceval c st st' →
      ∀ offsets stk pc, codeseq_at code pc (compile_com offsets c) →
                agree offsets 0 st stk →
                ∃ stk', star (veval code) (pc, stk) (pc + length (compile_com offsets c), stk')
                        ∧ agree offsets 0 st' stk'
| code ._ ._ ._ (eskip st) :=
begin
simp [compile_com, length],
intros offsets stk pc H_codeseq H_agree,
apply exists.intro stk,
split,
exact H_agree,
apply star.rfl
end

| code ._ ._ ._ (eass st a n x H_aeval) :=
begin
simp [compile_com, length],
intros offsets stk pc H_codeseq H_agree,
apply exists.intro (update_nth stk (offsets^.dfind x) n),
split,
apply agree_insert H_agree,
apply compile_aexp_core_correct,
end

| code ._ ._ ._ (eseq c₁ c₂ st₁ st₂ st₃ H_c₁ H_c₂) :=
begin

end

| code ._ ._ ._ (eift st₁ st₂ b c₁ c₂ H_beval_t H_ceval₁) :=
begin

end

| code ._ ._ ._ (eiff st₁ st₂ b c₁ c₂ H_beval_f H_ceval₂) :=
begin

end

| code ._ ._ ._ (ewhilet st₁ st₂ st₃ b c H_beval_t H_ceval_step H_ceval_loop) :=
begin

end

| code ._ ._ ._ (ewhilef st b c H_beval_f) :=
begin

end

end compiler


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.opposites
import Mathlib.PostPort

universes u₁ v₁ v₂ u₂

namespace Mathlib

namespace category_theory

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `𝟙 _`
which usually leads to dependent type theory hell.
-/
def eq_to_hom {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : X ⟶ Y :=
  eq.mpr sorry 𝟙

@[simp] theorem eq_to_hom_refl {C : Type u₁} [category C] (X : C) (p : X = X) : eq_to_hom p = 𝟙 :=
  rfl

@[simp] theorem eq_to_hom_trans {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} (p : X = Y) (q : Y = Z) : eq_to_hom p ≫ eq_to_hom q = eq_to_hom (Eq.trans p q) := sorry

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `iso.refl _`
which usually leads to dependent type theory hell.
-/
def eq_to_iso {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : X ≅ Y :=
  iso.mk (eq_to_hom p) (eq_to_hom (Eq.symm p))

@[simp] theorem eq_to_iso.hom {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : iso.hom (eq_to_iso p) = eq_to_hom p :=
  rfl

@[simp] theorem eq_to_iso.inv {C : Type u₁} [category C] {X : C} {Y : C} (p : X = Y) : iso.inv (eq_to_iso p) = eq_to_hom (Eq.symm p) :=
  rfl

@[simp] theorem eq_to_iso_refl {C : Type u₁} [category C] {X : C} (p : X = X) : eq_to_iso p = iso.refl X :=
  rfl

@[simp] theorem eq_to_iso_trans {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} (p : X = Y) (q : Y = Z) : eq_to_iso p ≪≫ eq_to_iso q = eq_to_iso (Eq.trans p q) := sorry

@[simp] theorem eq_to_hom_op {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) : has_hom.hom.op (eq_to_hom h) = eq_to_hom (congr_arg opposite.op (Eq.symm h)) := sorry

@[simp] theorem eq_to_hom_unop {C : Type u₁} [category C] {X : Cᵒᵖ} {Y : Cᵒᵖ} (h : X = Y) : has_hom.hom.unop (eq_to_hom h) = eq_to_hom (congr_arg opposite.unop (Eq.symm h)) := sorry

protected instance eq_to_hom.is_iso {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) : is_iso (eq_to_hom h) :=
  is_iso.mk (iso.inv (eq_to_iso h))

@[simp] theorem inv_eq_to_hom {C : Type u₁} [category C] {X : C} {Y : C} (h : X = Y) : inv (eq_to_hom h) = eq_to_hom (Eq.symm h) :=
  rfl

namespace functor

/-- Proving equality between functors. This isn't an extensionality lemma,
  because usually you don't really want to do this. -/
theorem ext {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h_obj : ∀ (X : C), obj F X = obj G X) (h_map : ∀ (X Y : C) (f : X ⟶ Y), map F f = eq_to_hom (h_obj X) ≫ map G f ≫ eq_to_hom (Eq.symm (h_obj Y))) : F = G := sorry

/-- Proving equality between functors using heterogeneous equality. -/
theorem hext {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h_obj : ∀ (X : C), obj F X = obj G X) (h_map : ∀ (X Y : C) (f : X ⟶ Y), map F f == map G f) : F = G := sorry

-- Using equalities between functors.

theorem congr_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h : F = G) (X : C) : obj F X = obj G X :=
  Eq._oldrec (Eq.refl (obj F X)) h

theorem congr_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h : F = G) {X : C} {Y : C} (f : X ⟶ Y) : map F f = eq_to_hom (congr_obj h X) ≫ map G f ≫ eq_to_hom (Eq.symm (congr_obj h Y)) := sorry

end functor

@[simp] theorem eq_to_hom_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C} {Y : C} (p : X = Y) : functor.map F (eq_to_hom p) = eq_to_hom (congr_arg (functor.obj F) p) := sorry

@[simp] theorem eq_to_iso_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) {X : C} {Y : C} (p : X = Y) : functor.map_iso F (eq_to_iso p) = eq_to_iso (congr_arg (functor.obj F) p) := sorry

@[simp] theorem eq_to_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (h : F = G) (X : C) : nat_trans.app (eq_to_hom h) X = eq_to_hom (functor.congr_obj h X) :=
  eq.drec (Eq.refl (nat_trans.app (eq_to_hom (Eq.refl F)) X)) h

theorem nat_trans.congr {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) {X : C} {Y : C} (h : X = Y) : nat_trans.app α X = functor.map F (eq_to_hom h) ≫ nat_trans.app α Y ≫ functor.map G (eq_to_hom (Eq.symm h)) := sorry


-- import temporal_logic.tactic
import temporal_logic.lemmas

universes u u₀ u₁

open predicate temporal

namespace temporal
namespace fairness

section defs

variables p q A : cpred

def wf : cpred :=
◇◻p ⟶ ◻◇A

def sf : cpred :=
◻◇p ⟶ ◻◇A

def sched : cpred :=
◇◻p ⟶ ◻◇q ⟶ ◻◇(p ⋀ q ⋀ A)

instance persistent_sched : persistent (sched p q A) :=
by { unfold sched, apply_instance }

end defs

lemma sched_imp_sched {Γ p q A A' : cpred}
  (hA : Γ ⊢ ◻(A ⟶ A'))
: Γ ⊢ sched p q A ⟶ sched p q A' :=
begin [temporal]
  dsimp [sched],
  mono*, apply hA,
end

-- TODO(Simon) replace ~> with ◻◇_ ⟶ ◻◇_

structure one_to_one_po (S p q A p' q' A' : cpred) : Prop :=
  (delay : S ⟹ (p' ⋀ q' ~> p))
  (resched : S ⟹ (p' ⋀ q' ~> q))
  (stable : S ⟹ (◻◇p ⟶ ◇◻p' ⟶ ◇◻p))
  (sim : S ⟹ ◻(p ⟶ q ⟶ A ⟶ p' ⋀ q' ⋀ A'))

structure event (α : Type u₀) :=
(p q : pred' α) (A : act α)

def one_to_one_po' {α β} (S : cpred)
: event α → event β → tvar α → tvar β → Prop
| ⟨p₀,q₀,A₀⟩ ⟨p₁,q₁,A₁⟩ v w :=
one_to_one_po S
  (p₀!v) (q₀!v) ⟦ v | A₀ ⟧
  (p₁!w) (q₁!w) ⟦ w | A₁ ⟧

namespace one_to_one
section one_to_one

parameters {S p q A : cpred}
parameters {p' q' A' : cpred}
parameters po : one_to_one_po S p q A p' q' A'
parameters Γ : cpred
parameters hS : Γ ⊢ S
private def H₀ : Γ ⊢ p' ⋀ q' ~> p :=
po.delay Γ hS

private def H₁ : Γ ⊢ ◻◇p ⟶ ◇◻p' ⟶ ◇◻p :=
po.stable Γ hS

private def H₂ : Γ ⊢ ◻(p ⟶ q ⟶ A ⟶ p' ⋀ q' ⋀ A') :=
po.sim Γ hS
private def H₃ : Γ ⊢ p' ⋀ q' ~> q :=
po.resched Γ hS

include po hS

lemma replacement
: Γ ⊢ sched p q A ⟶ sched p' q' A' :=
begin [temporal]
  simp [sched], intros,
  have swc := coincidence a_1 a_2,
  have wc : ◇◻p,
  { assume_negation, simp at h,
    have H₁ := H₁ po Γ hS,
    have H₀ := H₀ po Γ hS,
    apply H₁ _ a_1,
    apply inf_often_of_leads_to H₀ swc, },
  have sc : ◻◇q,
  { have H₃ := H₃ po Γ hS,
    apply inf_often_of_leads_to H₃ swc, },
  replace a := a wc sc, revert a,
  { have H₂ := H₂ po Γ hS,
    intros H₃, replace H₃ := coincidence wc H₃,
    henceforth! at H₃ ⊢, eventually H₃ ⊢,
    casesm* _ ⋀ _,
    apply H₂ ; assumption, },
end

end one_to_one
end one_to_one
export one_to_one (replacement)

namespace splitting
section splitting

parameters (t : Sort u)
-- TODO(Simon) Weaken proof obligation `H₀`. We can do with ◻◇_ ⟶ ◻◇ _
-- instead of _ ~> _. Use w i unless -p'
structure many_to_many_po (S : cpred) (w p q A : t → cpred) (p' q' A' : cpred) : Prop :=
  (delay : S ⟹ ∀∀ i, p' ⋀ q' ⋀ w i ~> p i ⋀ q i ⋀ w i)
  (stable : S ⟹ ∀∀ i, ◇(p i ⋀ w i) ⟶ ◇◻p' ⟶ ◇◻(p i ⋀ w i))
  (wfis : S ⟹ ◻(p' ⋀ q' ⟶ ∃∃ i, w i))
  (sim : S ⟹ ∀∀ i, ◻(p i ⟶ q i ⟶ A i ⟶ p' ⋀ q' ⋀ A'))
def many_to_many_po' {α β} (S : cpred) (w : t → cpred)
: (t → event α) → event β → tvar α → tvar β → Prop
| e ⟨p₁,q₁,A₁⟩ cv av :=
many_to_many_po S w
  (λ i, (e i).p!cv) (λ i, (e i).q!cv) (λ i, ⟦ cv | (e i).A ⟧)
  (p₁!av) (q₁!av) ⟦ av | A₁ ⟧

parameters {t}
parameters {w p q A : t → cpred}
parameters {p' q' A' S : cpred}
parameters po : many_to_many_po S w p q A p' q' A'
parameters {Γ : cpred}
parameters hS : Γ ⊢ S

-- variables H₀ : Γ ⊢ ∀∀ i, ◻◇(p' ⋀ q' ⋀ w i) ⟶ ◻◇p i ⋀ q i ⋀ w i
def H₀ : Γ ⊢ ∀∀ i, p' ⋀ q' ⋀ w i ~> p i ⋀ q i ⋀ w i :=
po.delay Γ hS

def H₁ : Γ ⊢ ∀∀ i, ◇(p i ⋀ w i) ⟶ ◇◻p' ⟶ ◇◻(p i ⋀ w i) :=
po.stable Γ hS

def H₂ : Γ ⊢ ∀∀ i, ◻(p i ⟶ q i ⟶ A i ⟶ p' ⋀ q' ⋀ A') :=
po.sim Γ hS

def H₃ : Γ ⊢ ◻(p' ⋀ q' ⟶ ∃∃ i, w i) :=
po.wfis Γ hS

include hS po H₀ H₁ H₂ H₃

open temporal
lemma splitting
: Γ ⊢ (∀∀ i, sched (p i) (q i) (A i)) ⟶ sched p' q' A' :=
begin [temporal]
  intro H₅,
  simp [sched] at *, intros hp' hq',
  have H₇ := temporal.leads_to_disj_gen temporal.fairness.splitting.H₀,
  replace H₇ := inf_often_of_leads_to H₇ _,
  replace H₇ : ∃∃ (i : t), ◇(p i ⋀ q i ⋀ w i),
  { henceforth at H₇, rw eventually_exists at H₇, },
  { cases H₇ with i H₇,
    have H₉ := temporal.fairness.splitting.H₁ i _ hp',
    have : ◻◇q i,
    { have := inf_often_of_leads_to (temporal.fairness.splitting.H₀ i) _, revert this,
      { mono!*, lifted_pred, show _, { intros, assumption } },
      rw_using : (p' ⋀ q' ⋀ w i) = (p' ⋀ w i ⋀ q'),
      { lifted_pred, tauto },
      apply coincidence _ hq',
      { apply stable_and_of_stable_of_stable hp',
        revert H₉, mono! * }, },
    replace this := H₅ i _ this,
    { have H₂ := temporal.fairness.splitting.H₂ i,
      replace this := coincidence H₉ this,
      henceforth! at this ⊢, eventually this ⊢,
      casesm* _ ⋀ _, apply H₂ ; assumption  },
    { revert H₉, mono!, lifted_pred,
      show _, { intros, assumption } },
    { revert H₇, mono!, lifted_pred }, },
  { have := coincidence hp' hq', revert this,
    have H₃ := temporal.fairness.splitting.H₃,
    mono!,
    intros hp,
    have := H₃ hp,
    revert this, apply p_exists_p_imp_p_exists,
    tauto, } ,
end

end splitting
end splitting
export splitting (splitting many_to_many_po many_to_many_po')
end fairness
end temporal