import grid utils data.vector

open utils

namespace grid

attribute [simp, reducible]
def Q (α : Type*) [grid α] := relative_grid.carrier α

end grid

open grid

section cautomatons

structure cautomaton (α : Type) [decidable_eq α] :=
  (g     : vec_grid₀ α)
  (empty : α)
  (neigh : point → list point)
  (bound : (bounding_box → bounding_box) ⊕ (α → vec_grid₀ α → point → α))
  (f     : α → list α → α)

end cautomatons

section cautomaton_instances

variables {α : Type} [decidable_eq α] [has_to_string α] (a : cautomaton α)

open grid

def cautomaton_to_str := grid_str a.g

instance : has_to_string (cautomaton α) := ⟨cautomaton_to_str⟩

instance : has_repr (cautomaton α) := ⟨cautomaton_to_str⟩

end cautomaton_instances

section cautomaton_quot_setoid_eq

variables {α : Type} [decidable_eq α] (a a₁ a₂ a₃ : cautomaton α)

end cautomaton_quot_setoid_eq

namespace cautomaton

end cautomaton

namespace cautomatons

open cautomaton grid

def neumann : point → list point
  | ⟨x, y⟩ :=
  [            ⟨x, y - 1⟩,
   ⟨x - 1, y⟩,             ⟨x + 1, y⟩,
               ⟨x, y + 1⟩             ]

def moore : point → list point
  | ⟨x, y⟩ :=
  [ ⟨x - 1, y - 1⟩, ⟨x, y - 1⟩, ⟨x + 1, y - 1⟩,
    ⟨x - 1, y    ⟩,             ⟨x + 1, y    ⟩,
    ⟨x - 1, y + 1⟩, ⟨x, y + 1⟩, ⟨x + 1, y + 1⟩ ]

def bounded_neigh {α} [grid α] (g : α)
  (f : point → list point) (p : grid_point g) : list point := f p

instance neigh_gridpoint_coe {α} [grid α] (g : α) :
  has_coe (point → list point)
          (grid_point g → list point) := ⟨bounded_neigh g⟩

def ext_id : bounding_box → bounding_box := id

def ext_one (bb : bounding_box) : bounding_box :=
  ⟨⟨bb.1.1 - 1, bb.1.2 - 1⟩, ⟨bb.2.1 + 1, bb.2.2 + 1⟩,
  ⟨
    (add_lt_add (grid_bounded_iff.1 bb.h).1 dec_trivial),
    (add_lt_add (grid_bounded_iff.1 bb.h).2 dec_trivial)⟩
  ⟩

lemma rows_of_box_ext_one {bb} :
  rows_of_box (ext_one bb) = rows_of_box bb + 2 :=
begin
  cases bb with p₁ p₂ h,
  simp [ext_one, rows_of_box],
  rw ← int.coe_nat_eq_coe_nat_iff,
  rw int.coe_nat_add, simp,
  rw grid_bounded_iff at h, cases h,
  repeat { rw int.nat_abs_of_nonneg }; linarith
end

lemma cols_of_box_ext_one {bb} :
  cols_of_box (ext_one bb) = cols_of_box bb + 2 :=
begin
  cases bb with p₁ p₂ h,
  simp [ext_one, cols_of_box],
  rw ← int.coe_nat_eq_coe_nat_iff,
  rw int.coe_nat_add, simp,
  rw grid_bounded_iff at h, cases h,
  repeat { rw int.nat_abs_of_nonneg }; linarith
end

lemma bl_ext_one {bb} : (ext_one bb).p₁ = ⟨bb.p₁.x - 1, bb.p₁.y - 1⟩ := rfl

lemma tr_ext_one {bb} : (ext_one bb).p₂ = ⟨bb.p₂.x + 1, bb.p₂.y + 1⟩ := rfl

end cautomatons

section cautomaton_props

variables {α : Type} [decidable_eq α] (a : cautomaton α)

end cautomaton_props

section cautomaton_ops

open function list prod relative_grid

variables variables {α : Type} [decidable_eq α] (a : cautomaton α)

def asize := size a.g

def bbox_of_caut := grid_bounds a.g

theorem caut_eq_iff {a₁ a₂ : cautomaton α}
  (hempty : a₁.empty = a₂.empty)
  (hneigh : a₁.neigh = a₂.neigh)
  (hbound : a₁.bound = a₂.bound)
  (hf : a₁.f = a₂.f)
  (hext : a₁.bound = a₂.bound) : a₁ = a₂ ↔ a₁.g = a₂.g :=
  ⟨λh, by simp [h], λh, by cases a₁; cases a₂; congr; cc⟩

private lemma pres_nonempty {α β : Type} {f} {filtered : list (α × β)}
  {l : list ℤ}
  (h : ¬empty_list filtered) (h₁ : l = map f ((fst ∘ unzip) filtered)) :
  ¬empty_list l :=
  by simp [h₁, map_empty_iff_l_empty, unzip_fst_empty_iff_l_empty, h]

def compute_bounds : bounding_box :=
  let bounded  := gip_g a.g in
  let mapped   := ℘ a.g in
  let zipped   := zip bounded mapped in
  let filtered := filter (λx, snd x ≠ a.empty) zipped in
  if h : empty_list filtered
  then ⟨gbl a.g, gtr a.g, grid_is_bounding_box⟩ else
  let unzipped := fst ∘ unzip $ filtered in
  let xs       := map point.x unzipped in
  let ys       := map point.y unzipped in
  let min_x    := min_element xs (pres_nonempty h $ by simp) in
  let max_x    := max_element xs (pres_nonempty h $ by simp) in
  let min_y    := min_element ys (pres_nonempty h $ by simp) in
  let max_y    := max_element ys (pres_nonempty h $ by simp) in
  ⟨⟨min_x, min_y⟩, ⟨max_x + 1, max_y + 1⟩,
  begin
    simp [(↗), min_x, max_x, min_y, max_y];
    split; rw add_comm; exact int.lt_add_one_of_le (min_elem_le_max_elem _ _)
  end⟩

lemma compute_bounds_pres_overlaid
  : overlaid_by (compute_bounds a) ⟨gbl a.g, gtr a.g, grid_is_bounding_box⟩
  :=
begin
  simp [overlaid_by, compute_bounds],
  generalize h₂ : gip_g a.g = indices,
  by_cases h : empty_list (filter (λ (x : point × α), x.snd ≠ a.empty)
                                  (zip indices ℘ (a.g))); simp [h₂, h],
  {exact ⟨⟨le_refl _, le_refl _⟩, ⟨le_refl _, le_refl _⟩⟩},
  {
    split; split,
    {
      apply le_min_elem_of_all _ _ _ (λx, λh₁, _),
      simp at h₁, rcases h₁ with ⟨y₁, rest, h₃⟩, subst h₃,
      apply (zunzip_filter_first_irrel rest),
      rw ← h₂, intros y h₄,
      have h₅ := gip_g_in_grid h₄,
      simp [flip, is_in_grid, grid_bounds] at h₅,
      exact h₅.2.1
    },
    {
      rw [add_comm, ← sub_le_sub_iff_right (1 : ℤ), add_sub_assoc],
      have : 1 - 1 = (0 : ℤ), from dec_trivial, rw this, rw add_zero,
      apply max_le_elem_of_all _ _ _ (λx, λh₁, _),
      simp at h₁, rcases h₁ with ⟨y₁, rest, h₃⟩, subst h₃,
      apply (zunzip_filter_first_irrel rest), rw ← h₂, intros y h₄,
      have h₅ := gip_g_in_grid h₄,
      simp [flip, is_in_grid, grid_bounds] at h₅,
      simp [gtr],
      rw [add_comm (-1 : ℤ), ← sub_eq_add_neg, int.le_sub_one_iff],
      exact h₅.2.2
    },
    {
      rw [add_comm, ← sub_le_sub_iff_right (1 : ℤ), add_sub_assoc],
      have : 1 - 1 = (0 : ℤ), from dec_trivial, rw [this, add_zero],
      apply max_le_elem_of_all _ _ _ (λx, λh₁, _),
      simp at h₁, rcases h₁ with ⟨y₁, rest, h₃⟩, subst h₃,
      apply (zunzip_filter_first_irrel rest),
      rw ← h₂, intros y h₄,
      have h₅ := gip_g_in_grid h₄,
      simp [flip, is_in_grid, grid_bounds] at h₅,
      rw int.le_sub_one_iff,
      exact h₅.1.2
    },
    {
      apply le_min_elem_of_all _ _ _ (λx, λh₁, _),
      simp at h₁, rcases h₁ with ⟨y₁, rest, h₃⟩, subst h₃,
      simp [expand_gtr, point.x, point.y],
      apply (zunzip_filter_first_irrel rest),
      rw ← h₂, intros y h₄,
      have h₅ := gip_g_in_grid h₄,
      simp [flip, is_in_grid, grid_bounds, expand_gtr, point.x] at h₅,
      rcases h₅ with ⟨⟨h₅, h₆⟩, ⟨h₇, h₈⟩⟩,
      linarith
    }
  }
end

lemma compute_bounds_pres_grid :
    uncurry (↗) (points_of_box $ compute_bounds a) :=
begin
  generalize h : compute_bounds a = bounds,
  simp [points_of_box, uncurry, bounds.h]
end

lemma in_nth_of_zip  {e₁ : point} {e₂} :
  (e₁, e₂) ∈ zip (gip_g a.g) ℘(a.g) →
    (∀{H₁} {H₂}, e₂ = abs_data a.g ⟨⟨e₁.y, H₁⟩, ⟨e₁.x, H₂⟩⟩) :=
begin
  intros H₀ H₁ H₂,
  rw mem_iff_nth_le at H₀,
  cases H₀ with i H₀r, cases H₀r with H₀r₁ H₀r₂,
  symmetry' at H₀r₂,
  have leneq : length (gip_g a.g) = length ℘(a.g),
    by simp [length_gip_g, length_generate_eq_size],
  have len₁ : i < length ℘(a.g),
    { rw [length_zip, leneq, min_self] at H₀r₁, exact H₀r₁ },
  have len₂ : i < length (gip_g a.g),
    { rw [length_zip, ← leneq, min_self] at H₀r₁, exact H₀r₁ },
  have eq : nth_le (gip_g (a.g)) i len₂ = e₁ ∧
            nth_le ℘(a.g) i len₁ = e₂, from nth_le_zip' H₀r₂,
  cases eq with eq₁ eq₂, rw ← eq₂,
  rw nth_generate, rw nth_le_gip_g at eq₁,
  congr, rw ← eq₁, rw ← eq₁
end

lemma in_zip_dep {p} {e} {i} {hi}
  (h : (p, e) = nth_le (zip (gip_g a.g) ℘(a.g)) i hi) :
  nth_le (gip_g (a.g)) i
    begin
      have leneq : length (gip_g a.g) = length (℘(a.g)),
        by simp [length_gip_g, length_generate_eq_size],
      rw [length_zip, leneq, min_self] at hi,
      simpa [leneq]
    end = p ∧ nth_le ℘(a.g) i
    begin
      have leneq : length (gip_g a.g) = length (℘(a.g)),
        by simp [length_gip_g, length_generate_eq_size],
      rw [length_zip, leneq, min_self] at hi,
      simpa [leneq]
    end = e ∧
  i = |p.y - a.g.o.y| * a.g.c + |p.x - a.g.o.x| :=
begin
  have : nth_le (gip_g (a.g)) i
    begin
      have leneq : length (gip_g a.g) = length (℘(a.g)),
        by simp [length_gip_g, length_generate_eq_size],
      rw [length_zip, leneq, min_self] at hi,
      simpa [leneq]
    end = p ∧ nth_le ℘(a.g) i
    begin
      have leneq : length (gip_g a.g) = length (℘(a.g)),
        by simp [length_gip_g, length_generate_eq_size],
      rw [length_zip, leneq, min_self] at hi,
      simpa [leneq]
    end = e,
    from nth_le_zip' h,
  have ieq : i = |p.y - a.g.o.y| * a.g.c + |p.x - a.g.o.x|,
    {
      have leneq : length (gip_g a.g) = length (℘(a.g)),
        by simp [length_gip_g, length_generate_eq_size],
      cases this with h₁ h₂, clear h₂, clear h,
      rw [length_zip, leneq, min_self] at hi, rw ← leneq at hi, clear leneq,
      rw nth_le_gip_g at h₁, rw length_gip_g at hi,
      rw ← h₁,
      simp [bl, cols], rw mod_add_div_coe
    },
  exact ⟨this.1, this.2, ieq⟩
end

lemma nth_le_gen_iff_abs_data_gip {i} {H} {H₁} {e} :
  nth_le ℘(a.g) i H = e ↔
  abs_data a.g ⟨
    ⟨(nth_le (gip_g a.g) i H₁).y,
      begin
        simp [nth_le_gip_g], split,
          {norm_cast, linarith},
          {
            apply add_lt_of_lt_sub_left,
            simp [expand_gtr, bl],
            rw length_generate_eq_size at H, unfold size at H,
            norm_cast,
            rw nat.div_lt_iff_lt_mul _ _,
            exact H,
            have := a.g.h, simp [cols],
            apply pos_of_mul_pos_left this,
            apply zero_le _
          }
      end⟩,
    ⟨(nth_le (gip_g a.g) i H₁).x,
      begin
        simp [nth_le_gip_g], split,
          {norm_cast},
          {
            apply add_lt_of_lt_sub_left,
            simp [expand_gtr, bl],
            apply int.mod_lt_of_pos,
            have := a.g.h, simp [cols],
            apply pos_of_mul_pos_left this,
            apply zero_le _
          }
      end⟩
  ⟩ = e :=
begin
  split; intros h,
    {rw nth_generate at h, rw ← h, simp [nth_le_gip_g]},
    {rw nth_generate, rw ← h, simp [nth_le_gip_g]}
end

lemma mem_zip_gip_gen {p} {elem}
  (h : p ∈ a.g)
  (h₁ : elem = abs_data (a.g) {x := ⟨p.x, h.2⟩, y := ⟨p.y, h.1⟩}) :
  (p, elem) ∈ zip (gip_g (a.g)) ℘(a.g) :=
begin
  rw mem_iff_nth_le,
  let i := |p.x - ((a.g).o).x| + |p.y - ((a.g).o).y| * ((a.g).to_vec_grid).c,
  have H : i < size a.g,
    {
      simp [i, size, rows, cols, -sub_eq_add_neg], rw add_comm,
      apply linearize_array,
        {
          rcases h with ⟨⟨a₁, a₂⟩, ⟨a₃, a₄⟩⟩,
          simp [expand_gtr, gbl, bl, rows, cols] at a₁ a₂ a₃ a₄,
          rw ← int.coe_nat_lt_coe_nat_iff,
          rw int.nat_abs_of_nonneg; try { assumption },
          linarith, linarith
        },
        {
          rcases h with ⟨⟨a₁, a₂⟩, ⟨a₃, a₄⟩⟩,
          simp [expand_gtr, gbl, bl, rows, cols] at a₁ a₂ a₃ a₄,
          rw ← int.coe_nat_lt_coe_nat_iff,
          rw int.nat_abs_of_nonneg; try { assumption },
          linarith, linarith
        }
    },
  have leneq : length (gip_g a.g) = length ℘(a.g),
    by simp [length_gip_g, length_generate_eq_size],
  have H₀ : i < length (gip_g a.g),
    by rw length_gip_g; exact H,
  have H₁ : i < length (zip (gip_g a.g) ℘(a.g)),
    by rwa [length_zip, leneq, min_self, length_generate_eq_size],
  use i, use H₁, symmetry,
  rcases h with ⟨⟨a₁, a₂⟩, ⟨a₃, a₄⟩⟩,
  simp [expand_gtr, gbl, bl, rows, cols] at a₁ a₂ a₃ a₄,
  apply nth_le_zip,
  rw nth_le_gip_g, cases p, simp, split, ring,
  apply add_eq_of_eq_sub', simp [expand_gtr, bl, cols],
  repeat { rw int.nat_abs_of_nonneg; try { linarith } },
  apply int.mod_eq_of_lt; try { linarith },
  apply add_eq_of_eq_sub', simp [cols, bl], rw ← add_assoc,
  rw int.add_mul_div_right,
  rw int.div_eq_zero_of_lt; linarith,
  simp, intros contra, let falso := a.g.h,
  rw contra at falso, linarith,
  rw h₁, rw nth_generate, congr,
  simp [i],
  apply add_eq_of_eq_sub', simp [expand_gtr, bl, cols],
  rw int.add_mul_div_right,
  rw int.div_eq_zero_of_lt, rw int.nat_abs_of_nonneg; linarith,
  rw int.nat_abs_of_nonneg; linarith,
  rw int.nat_abs_of_nonneg; linarith,
  intros contra, let falso := a.g.h, simp at contra,
  rw contra at falso, linarith,
  simp [i],
  apply add_eq_of_eq_sub', simp [expand_gtr, bl, cols],
  repeat { rw int.nat_abs_of_nonneg; try { linarith } },
  apply int.mod_eq_of_lt; try { linarith }, exact H₀,
  rw ← leneq, exact H₀
end

lemma y_notin_elem_empty {x} {y} {H₁} {H₂}
  (notin : x ∉ map point.x
         ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
         (zip (gip_g (a.g)) ℘(a.g)))).fst)) :
  abs_data (a.g) {x := ⟨x, H₁⟩, y := ⟨y, H₂⟩} = a.empty :=
begin
  let p : point := ⟨x, y⟩,
  have eqp : p = ⟨x, y⟩, from rfl,
  have eq₁ : p ∈ gip_g a.g,
    {apply in_gip_g_of_in_g, exact ⟨H₂, H₁⟩},
  rw [mem_map, not_exists] at notin,
  let elem := abs_data a.g ⟨⟨p.y, H₂⟩, ⟨p.x, H₁⟩⟩,
  have eqelem : elem = abs_data a.g ⟨⟨p.y, H₂⟩, ⟨p.x, H₁⟩⟩, from rfl,
  specialize notin p, simp at notin,
  by_contradiction contra,
  have eq₂ : (p, elem) ∈
    filter (λ (x : point × α), ¬x.snd = a.empty) (zip (gip_g a.g) ℘(a.g)),
    {
      rw @mem_filter _ (λ (x : point × α), ¬x.snd = a.empty),
      simp, split, swap 2, rw eqelem, refine contra,
      apply mem_zip_gip_gen _ (in_grid_iff_in_gip_g.2 eq₁) eqelem
    },
  have eq₃ : p ∈ (unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                          (zip (gip_g (a.g)) ℘(a.g)))).fst,
    {rw in_unzip_iff, use elem, exact eq₂},
  contradiction
end

lemma x_notin_elem_empty {y} {x} {H₁} {H₂}
  (notin : y ∉ map point.y
         ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
         (zip (gip_g (a.g)) ℘(a.g)))).fst)) :
  abs_data (a.g) {x := ⟨x, H₁⟩, y := ⟨y, H₂⟩} = a.empty :=
begin
  let p : point := ⟨x, y⟩,
  have eqp : p = ⟨x, y⟩, from rfl,
  have eq₁ : p ∈ gip_g a.g,
    {apply in_gip_g_of_in_g, exact ⟨H₂, H₁⟩},
  rw [mem_map, not_exists] at notin,
  let elem := abs_data a.g ⟨⟨p.y, H₂⟩, ⟨p.x, H₁⟩⟩,
  have eqelem : elem = abs_data a.g ⟨⟨p.y, H₂⟩, ⟨p.x, H₁⟩⟩, from rfl,
  specialize notin p, simp at notin,
  by_contradiction contra,
  have eq₂ : (p, elem) ∈
    filter (λ (x : point × α), ¬x.snd = a.empty) (zip (gip_g a.g) ℘(a.g)),
    {
      rw @mem_filter _ (λ (x : point × α), ¬x.snd = a.empty),
      simp, split, swap 2, rw eqelem, refine contra,
      apply mem_zip_gip_gen _ (in_grid_iff_in_gip_g.2 eq₁) eqelem
    },
  have eq₃ : p ∈ (unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                          (zip (gip_g (a.g)) ℘(a.g)))).fst,
    {rw in_unzip_iff, use elem, exact eq₂},
  contradiction
end

lemma y_lt_min_elem_empty {x} {H₁} {H₂}
  (h : x < min_element (map point.x
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst)) H₁) :
  ∀y {H₃}, abs_data (a.g) {x := ⟨x, H₂⟩, y := ⟨y, H₃⟩} = a.empty :=
begin
  intros,
  have notin : x ∉ map point.x
               ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                          (zip (gip_g (a.g)) ℘(a.g)))).fst),
    from not_mem_of_lt_min_element H₁ h,
  apply y_notin_elem_empty _ notin
end

lemma add_one_y_gt_max_elem_empty {x} {H₁} {H₂}
  (h : 1 + max_element (map point.x
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst)) H₁ ≤ x) :
  ∀y {H₃}, abs_data (a.g) {x := ⟨x, H₂⟩, y := ⟨y, H₃⟩} = a.empty :=
begin
  intros,
  have notin : x ∉ (map point.x
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst)),
    from not_mem_of_add_one_max_elem_gt _ h,
  apply y_notin_elem_empty _ notin
end

lemma x_lt_min_elem_empty {y} {H₁} {H₂}
  (h : y < min_element (map point.y
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst)) H₁) :
  ∀x {H₃}, abs_data (a.g) {x := ⟨x, H₃⟩, y := ⟨y, H₂⟩} = a.empty :=
begin
  intros,
  have notin : y ∉ map point.y
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst),
    from not_mem_of_lt_min_element _ h,
  apply x_notin_elem_empty _ notin
end

lemma add_one_x_lt_max_elem_empty {y} {H₁} {H₂}
  (h : 1 + max_element (map point.y
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst)) H₁ ≤ y) :
  ∀x {H₃}, abs_data (a.g) {x := ⟨x, H₃⟩, y := ⟨y, H₂⟩} = a.empty :=
begin
  intros,
  have notin : y ∉ map point.y
             ((unzip (filter (λ (x : point × α), ¬x.snd = a.empty)
                        (zip (gip_g (a.g)) ℘(a.g)))).fst),
    from not_mem_of_add_one_max_elem_gt _ h,
  apply x_notin_elem_empty _ notin
end

lemma empty_of_mem_gip_nmem_compute {p : point}
  (h : p ∈ a.g)
  (h₁ : p ∉ compute_bounds a) :
  abs_data (a.g) {x := ⟨p.x, h.2⟩, y := ⟨p.y, h.1⟩} = a.empty :=
begin
  unfold compute_bounds at h₁,
  simp [flip, is_in_grid, is_in_grid', is_bounded] at h,
  rcases h with ⟨⟨B₁, B₂⟩, ⟨B₃, B₄⟩⟩,
  simp [expand_gtr, bl, cols, rows] at B₁ B₂ B₃ B₄,
  let i := |p.y - a.g.o.y| * a.g.c + |p.x - a.g.o.x|,
  have A₁ : p.y - a.g.o.y ≥ 0, by linarith,
  have A₂ : p.x - a.g.o.x ≥ 0, by linarith,
  have A₃ : i < size a.g,
    {
      simp [i, size, rows, cols, -sub_eq_add_neg, -add_comm],
      apply linearize_array,
        {
          rw ← int.coe_nat_lt_coe_nat_iff,
          rw int.nat_abs_of_nonneg; try { assumption },
          linarith
        },
        {
          rw ← int.coe_nat_lt_coe_nat_iff,
          rw int.nat_abs_of_nonneg; try { assumption },
          linarith
        }
    },
  have A₄ : 0 ≤ i, by linarith,
  cases p with x y,
  have eq₁ : (bl (a.g)).x + ↑|↑i| % ↑(cols (a.g)) = x,
    {
      simp, norm_cast, simp [-sub_eq_add_neg, bl],
      simp only [cols],
      repeat { rw int.nat_abs_of_nonneg; try { assumption } },
      ring, simp [-sub_eq_add_neg] at *,
      rw add_eq_of_eq_neg_add, simp,
      rw ← sub_eq_add_neg,
      rw int.mod_eq_of_lt,
      linarith,
      linarith
    },
  have eq₂ : (bl (a.g)).y + ↑|↑i| / ↑(cols (a.g)) = y,
    {
      simp, norm_cast, simp [-sub_eq_add_neg, bl],
      simp only [cols],
      repeat { rw int.nat_abs_of_nonneg; try { assumption } },
      ring, simp [-sub_eq_add_neg] at *,
      rw add_eq_of_eq_neg_add, simp,
      rw ← sub_eq_add_neg,
      rw ← add_assoc, ring,
      rw int.add_mul_div_right,
      rw int.div_eq_zero_of_lt,
      simp,
      linarith,
      linarith,
      linarith
    },
  by_cases eq :
    empty_list (filter (λ (x : point × α), x.snd ≠ a.empty)
                       (zip (gip_g (a.g)) ℘(a.g))),
      {
        unfold empty_list at eq, symmetry' at eq,
        rw filter_eq_nil at eq, simp at eq,
        apply eq ⟨x, y⟩,
        simp [flip, is_in_grid, is_in_grid', is_bounded] at h,
        refine @nth_le_in_grid _ (int.nat_abs i) _ _ _ _,
        rw length_zip,
        rw length_gip_g, rw length_generate_eq_size, unfold size,
        rw min_eq_right, exact A₃, exact le_refl _,
        rw nth_le_zip, rw nth_le_gip_g,
          {congr, exact eq₁, exact eq₂},
          {
            rw nth_generate, congr,
            exact eq₂, exact eq₁
          },
        rw length_gip_g, exact A₃,
        rw length_generate_eq_size, exact A₃
      },
      {
        simp [eq, flip, is_in_grid, is_bounded, -not_and] at h₁,
        rw not_and_distrib at h₁, cases h₁, rw not_and_distrib at h₁,
        cases h₁,
          {
            simp only [point.x, point.y] at *,
            rw not_le at h₁,
            apply x_lt_min_elem_empty _ h₁
          },
          {
            rw not_lt at h₁,
            apply add_one_x_lt_max_elem_empty _ h₁
          },
        rw not_and_distrib at h₁, cases h₁,
          {
            rw not_le at h₁,
            apply y_lt_min_elem_empty _ h₁
          },
          {
            rw not_lt at h₁,
            apply add_one_y_gt_max_elem_empty _ h₁
          }
      }
end

lemma exists_p_of_in_generate {x} (h : x ∈ ℘(a.g)) :
  ∃(p : point) (H : p ∈ gip_g a.g),
    abs_data a.g ⟨
      ⟨p.y, begin rw ← in_grid_iff_in_gip_g at H, exact H.1 end⟩,
      ⟨p.x, begin rw ← in_grid_iff_in_gip_g at H, exact H.2 end⟩
    ⟩ = x :=
begin
  rw mem_iff_nth_le at h,
  rcases h with ⟨i, ⟨h₁, h₂⟩⟩,
  have : i < length (gip_g (a.g)),
    {rw length_gip_g, rw length_generate_eq_size at h₁, exact h₁},
  let p := nth_le (gip_g a.g) i this,
  have eqp : p = nth_le (gip_g (a.g)) i this, from rfl,
  use p, intros,
  rw ← h₂,
  rw nth_generate, simp [nth_le_gip_g, bl, cols, eqp],
  have : p ∈ gip_g (a.g), { rw eqp, apply nth_le_mem },
  use this, congr
end

def canonical_grid :=
  compute_bounds a = ⟨gbl a.g, gtr a.g, grid_is_bounding_box⟩

def make_canonical : cautomaton α :=
  {a with g := ↑(subgrid a.g (compute_bounds a) (compute_bounds_pres_overlaid _))}

def is_canonical := make_canonical a = a

def aut_eq (a₁ a₂ : cautomaton α) : Prop :=
  (band : bool → bool → bool) (℘(make_canonical a₁).g = ℘(make_canonical a₂).g)
  $ (band : bool → bool → bool)
    ((make_canonical a₁).g.r = (make_canonical a₂).g.r)
    ((make_canonical a₁).g.c = (make_canonical a₂).g.c)

infix ` ~ₐ `:100 := aut_eq

instance decidable_aut_eq {α} [decidable_eq α] {a₁ a₂} :
  decidable (@aut_eq α _ a₁ a₂) := by simp [(~ₐ)]; apply_instance

def ext_aut (a : cautomaton α) : cautomaton α :=
  match a.bound with
    | (sum.inr _) := a
    | (sum.inl ext) :=
    let new_bb := ext (grid_bounds a.g) in
    let new_grid :=
      fgrid₀.mk
        (rows_of_box new_bb)
        (cols_of_box new_bb)
        (mul_pos rows_of_box_pos cols_of_box_pos)
        new_bb.p₁
        (λx y, if h : (⟨y, x⟩ : point) ∈ a.g
               then abs_data a.g $ grid_point_of_prod'
                       ((make_bounded h.1), (make_bounded h.2))
               else a.empty) in
    ⟨new_grid, a.empty, a.neigh, a.bound, a.f⟩
  end

def default_if_nex {α : Type*} [grid α] (empty : carrier α)
  (g : α) (p : point) : carrier α :=
  if h : p ∈ g
  then abs_data g (grid_point_of_prod' (in_grid_bounded g p h))
  else empty

section boundary

private lemma bound_periodic_modulo'
  {a} {b : ℤ} {c} (h : a > 0) :
  b ≤ (b + a) - 1 - (b - c - 1) % a :=
begin
  simp, repeat { rw ← sub_eq_add_neg },
  rw [
    ← add_sub_assoc, ← sub_eq_add_neg,
    ← le_add_iff_nonneg_left (1 : ℤ)
  ],
  change (1 : ℤ) with (0 + 1),
  rw int.add_one_le_iff, simp [-sub_eq_add_neg],
  rw ← add_sub_assoc, simp,
  apply lt_add_of_neg_add_lt, simp,
  apply int.mod_lt_of_pos,
  simpa [h]
end

private lemma bound_periodic_modulo''
  {a} {b : ℤ} {c} (h : a > 0) :
  (b + a) - 1 - (b - c - 1) % a < b + a :=
begin
  simp, rw ← add_assoc, repeat { rw ← sub_eq_add_neg },
  rw neg_lt,
  apply int.lt_of_add_one_le, simp [-sub_eq_add_neg],
  apply int.mod_nonneg,
  simp, linarith
end

def bound_periodic {α : Type*} [grid α] (empty : carrier α)
  (g : α) (p : point) : carrier α :=
  if h : p ∈ g
  then abs_data g (grid_point_of_prod' (in_grid_bounded g p h))
  else
    if b₁ : is_bounded (gbl g).y (gtr g).y p.y
    then
      if p₁ : p.x ≥ (gtr g).x
      then abs_data g ⟨
        make_bounded b₁,
        ⟨(gbl g).x + (p.x - (gbl g).x) % cols g,
         begin
           split,
             {
               have : cols g > 0, from cols_pos,
               apply le_add_of_nonneg_right (int.mod_nonneg _ _),
               linarith
             },
             {simp [expand_gtr, int.mod_lt_of_pos, cols_pos]}
         end
        ⟩
      ⟩
      else abs_data g ⟨
        make_bounded b₁,
        ⟨(gtr g).x - 1 - ((gbl g).x - p.x - 1) % cols g,
         have h₂ : p.x < (gbl g).x,
           {
             by_cases p₃ : (gbl g).x ≤ p.x,
               {
                 have contra : is_bounded (gbl g).x (gtr g).x p.x,
                   from ⟨p₃, lt_of_not_ge p₁⟩,
                 simp only [(∉), flip, is_in_grid'] at h,
                 finish
               },
             {linarith}
           },
          ⟨
            bound_periodic_modulo' cols_pos,
            bound_periodic_modulo'' cols_pos
          ⟩
        ⟩
      ⟩
    else
    if b₂ : is_bounded (gbl g).x (gtr g).x p.x
    then
      if p₂ : p.y ≥ (gtr g).y
      then abs_data g ⟨
        ⟨(gbl g).y + (p.y - (gbl g).y) % rows g,
          ⟨
            begin
              simp only [gbl, le_add_iff_nonneg_right, sub_eq_add_neg],
              rw ← sub_eq_add_neg,
              apply int.mod_nonneg, simp,
              have : 0 < rows g, from rows_pos,
              linarith
            end,
            by simp [expand_gtr, int.mod_lt_of_pos, rows_pos]
          ⟩
        ⟩,
        make_bounded b₂
      ⟩
      else abs_data g ⟨
        ⟨(gtr g).y - 1 - ((gbl g).y - p.y - 1) % rows g,
          have h₂ : p.y < (gbl g).y,
            {
              replace p₂ := lt_of_not_ge p₂,
              by_cases p₃ : (gbl g).y ≤ p.y,
                {
                  have contra : is_bounded (gbl g).y (gtr g).y p.y,
                    from ⟨p₃, p₂⟩,
                  contradiction
                },
                {linarith}
            },
          ⟨
            bound_periodic_modulo' rows_pos,
            bound_periodic_modulo'' rows_pos
          ⟩
        ⟩,
        make_bounded b₂
      ⟩
    else empty

def bound_const {α : Type*} [grid α]
  (const : carrier α) (g : α) (p : point) : carrier α := default_if_nex const g p

end boundary

def next_gen (a : cautomaton α) : cautomaton α :=
  let new_grid := (ext_aut a).g in
  let cells := ℘ new_grid in
  let neighs := map a.neigh (gip_g new_grid) in
  let defaulted :=
    match a.bound with
      | (sum.inr boundf) := boundf a.empty new_grid
      | _ := @bound_const (vec_grid₀ α) _ a.empty new_grid
    end in
  let neigh_cells := map (list.map defaulted) neighs in
  let new_cells := zip_with a.f cells neigh_cells in
  let grid :=
    @vec_grid₀.mk _
      ⟨grid_rows new_grid, grid_cols new_grid,
       mul_pos rows_pos cols_pos,
      ⟨new_cells, by simp [
                       zip_with_len_l,
                       length_generate_eq_size,
                       size,
                       rows_eq_try_sub_bly,
                       cols_eq_trx_sub_blx,
                       length_gip_g,
                       length_gip,
                       grid_is_bounding_box
                     ]
                  ⟩⟩ new_grid.o in
    let next_config := (⟨grid, a.empty, a.neigh, a.bound, a.f⟩ : cautomaton α) in
    match a.bound with
      | (sum.inl _) := make_canonical next_config
      | _ := next_config
    end

attribute [simp]
lemma next_gen_empty : (next_gen a).empty = a.empty :=
  by cases a with _ _ _ bound _; cases bound; refl

attribute [simp]
lemma next_gen_neigh : (next_gen a).neigh = a.neigh :=
  by cases a with _ _ _ bound _; cases bound; refl

attribute [simp]
lemma next_gen_f : (next_gen a).f = a.f :=
  by cases a with _ _ _ bound _; cases bound; refl

attribute [simp]
lemma next_gen_ext : (next_gen a).bound = a.bound :=
  by cases a with _ _ _ bound _; cases bound; refl

attribute [simp]
lemma iterate_next_gen_empty {n} : (iterate next_gen a n).empty = a.empty :=
  by induction n with n ih; simp [iterate_zero, *, iterate_one]

attribute [simp]
lemma iterate_next_gen_neigh {n} : (iterate next_gen a n).neigh = a.neigh :=
  by induction n with n ih; simp [iterate_zero, *, iterate_one]

attribute [simp]
lemma iterate_next_gen_f {n} : (iterate next_gen a n).f = a.f :=
  by induction n with n ih; simp [iterate_zero, *, iterate_one]

attribute [simp]
lemma iterate_next_gen_ext {n} : (iterate next_gen a n).bound = a.bound :=
  by induction n with n ih; simp [iterate_zero, *, iterate_one]

def step_n (n : ℕ) := iterate next_gen a n

def periodic := {n // n ≠ 0 ∧ step_n a n = a}

def count_at_single {α : Type} [decidable_eq α] (neigh : list α) (valid : α) :=
  list.sum ∘ map (λc, if c = valid then 1 else 0) $ neigh

def yield_at_if_in_neigh {α : Type} [decidable_eq α]
  (a : cautomaton α) (p : point) :=
  if p ∈ a.neigh p
  then some $ @default_if_nex (vec_grid₀ α) _ a.empty a.g p
  else none

lemma step_n_zero : step_n a 0 = a := rfl

lemma step_n_succ {n} : step_n a (nat.succ n) = next_gen (step_n a n) := rfl

def yield_at (p : point) : α := @default_if_nex (vec_grid₀ α) _ a.empty a.g p

def mod_at (p : point) (x : α) (a : cautomaton α) : cautomaton α :=
  ⟨modify_at p x a.g, a.empty, a.neigh, a.bound, a.f⟩

def mod_many (l : list (point × α)) (a : cautomaton α) : cautomaton α :=
  ⟨modify_many l a.g, a.empty, a.neigh, a.bound, a.f⟩

end cautomaton_ops

section counting

variables {α : Type} [decidable_eq α] (a : cautomaton α)

def count (c : α) : ℕ := count_grid a.g c

lemma count_grid_eq_count {x} : count a x = count_grid a.g x := rfl

lemma count_cast_foa (a : vec_grid₀ α) {x} : count_grid ↑a x = count_grid a x :=
  by unfold_coes; simp [count_grid, gen_aof_eq_gen, gen_foa_eq_gen]

lemma count_cast_aof (a : fgrid₀ α) {x} : count_grid ↑a x = count_grid a x :=
  by unfold_coes; simp [count_grid, gen_aof_eq_gen, gen_foa_eq_gen]

lemma yield_at_nonempty {p} {a : cautomaton α}
  (h : yield_at a p ≠ a.empty) : p ∈ a.g :=
begin
  by_contradiction contra,
  unfold yield_at default_if_nex at h,
  rw dif_neg contra at h,
  contradiction
end

lemma count_uneq_in_subgrid' {a : cautomaton α} {x} (h : x ≠ a.empty) :
  list.count x (subgrid' (a.g) (compute_bounds a) (compute_bounds_pres_overlaid _)) =
  0 :=
begin
  unfold subgrid' list.count,
  rw list.countp_eq_length_filter,
  unfold list.attach,
  rw list.map_pmap,
  rw list.length_eq_zero,
  rw list.filter_eq_nil,
  intros cell H,
  rw list.mem_pmap at H,
  cases H with p rest, cases rest with h₁ h₂,
  have : (abs_data (a.g) ∘ inject_filter_bounded (a.g)) ⟨p, h₁⟩ = a.empty,
    {
      rw list.mem_filter at h₁,
      cases h₁ with h₂ h₃,
      simp [(∘), inject_filter_bounded, grid_point_of_mem, make_bounded],
      apply empty_of_mem_gip_nmem_compute,
      rw in_grid_iff_in_gip_g, exact h₂,
      exact h₃
    },
  cc
end

lemma count_nonempty_compute_bounds {a : cautomaton α} {x} (h : x ≠ a.empty) :
  list.count x (℘ a.g) =
  list.count x ℘(subgrid a.g (compute_bounds a) (compute_bounds_pres_overlaid _)) :=
begin
  rw @count_split _ _ _ a.g (compute_bounds a) (compute_bounds_pres_overlaid _),
  rw count_uneq_in_subgrid' h,
  refl
end

lemma count_nonempty_make_canonical {a : cautomaton α} {x} (h : x ≠ a.empty) :
  count a x = count (make_canonical a) x :=
begin
  unfold make_canonical count count_grid,
  simp only [cautomaton.g],
  unfold_coes, rw gen_aof_eq_gen,
  exact count_nonempty_compute_bounds h
end

end counting

namespace cardinals

section cardinals

variables {α : Type} [decidable_eq α] (a : cautomaton α) (p : point)
          (neigh : point → list point)

def neigh_with_NW := ∀p : point, point.mk (p.x - 1) (p.y - 1) ∈ neigh p

def neigh_with_N  := ∀p : point, point.mk p.x       (p.y - 1) ∈ neigh p

def neigh_with_NE := ∀p : point, point.mk (p.x + 1) (p.y - 1) ∈ neigh p

def neigh_with_W  := ∀p : point, point.mk (p.x - 1) p.y       ∈ neigh p

def neigh_with_E  := ∀p : point, point.mk (p.x + 1) p.y       ∈ neigh p

def neigh_with_SW := ∀p : point, point.mk (p.x - 1) (p.y + 1) ∈ neigh p

def neigh_with_S  := ∀p : point, point.mk p.x       (p.y + 1) ∈ neigh p

def neigh_with_SE := ∀p : point, point.mk (p.x + 1) (p.y + 1) ∈ neigh p

open cautomatons

lemma neumann_N : neigh_with_N neumann :=
  λ⟨x, y⟩, by simp [neumann]

lemma neumann_W : neigh_with_W neumann :=
  λ⟨x, y⟩, by simp [neumann]

lemma neumann_E : neigh_with_E neumann :=
  λ⟨x, y⟩, by simp [neumann]

lemma neumann_S : neigh_with_S neumann :=
  λ⟨x, y⟩, by simp [neumann]

lemma moore_NW : neigh_with_NW moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_N : neigh_with_N moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_NE : neigh_with_NE moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_W : neigh_with_W moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_E : neigh_with_E moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_SW : neigh_with_SW moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_S : neigh_with_S moore :=
  λ⟨x, y⟩, by simp [moore]

lemma moore_SE : neigh_with_SE moore :=
  λ⟨x, y⟩, by simp [moore]

def NW (h : neigh_with_NW a.neigh) := yield_at a ⟨p.x - 1, p.y - 1⟩

def N (h : neigh_with_N a.neigh) := yield_at a ⟨p.x, p.y - 1⟩

def NE (h : neigh_with_NE a.neigh) := yield_at a ⟨p.x + 1, p.y - 1⟩

def W (h : neigh_with_W a.neigh) := yield_at a ⟨p.x - 1, p.y⟩

def E (h : neigh_with_E a.neigh) := yield_at a ⟨p.x + 1, p.y⟩

def SW (h : neigh_with_SW a.neigh) := yield_at a ⟨p.x - 1, p.y + 1⟩

def S (h : neigh_with_S a.neigh) := yield_at a ⟨p.x, p.y + 1⟩

def SE (h : neigh_with_SE a.neigh) := yield_at a ⟨p.x + 1, p.y + 1⟩

end cardinals

end cardinals


/- Copyright 2019 (c) Hans-Dieter Hiep. All rights reserved. Released under MIT license as described in the file LICENSE. -/

import syntax

universe u

open signature list

/- Fix a signature. We consider an interpretation of reference types and data types. Reference types are interpreted as object identities. Each object identity is associated to a single class name. Equality is decidable for objects. Each record name is uniquely associated to a data type. A data type comprises an inhabited Lean type with decidable equality. The built-in boolean is associated to Lean's bool with false as default. -/
structure datatype :=
  (host : Type)
  (inhabited_host: inhabited host)
  (decidable_host: decidable_eq host)
instance datatype.decidable_eq (d : datatype) :
  decidable_eq d.host := d.decidable_host
instance datatype.inhabited_eq (d : datatype) :
  inhabited d.host := d.inhabited_host
def datatype.default (d : datatype) : d.host :=
  default d.host

class objects (α β : Type) extends signature α :=
(class_of: β → class_name α)
(encodable_object: encodable β)
(decidable_object: decidable_eq β) -- redundant
(data_type: record_name α → datatype)
(data_type_boolean:
  (data_type (boolean_name α)).host = bool)
(data_type_boolean_inhabited:
  (cast data_type_boolean (data_type (boolean_name α))
    .inhabited_host.default) = ff)
open objects

lemma data_type_booleanr {α β : Type} [objects α β] :
  bool = (data_type (boolean_name α)).host :=
begin symmetry, apply data_type_boolean end
instance objects.decidable_eq {α β : Type} [objects α β] :
  decidable_eq β := decidable_object α β
instance objects.encodable {α β : Type} [objects α β] :
  encodable β := encodable_object α β

/- We treat values as being of a type. A value of a reference type is an object of the same class, or null. A value of a data type is a term of the associated type in Lean. -/
@[derive decidable_eq]
inductive value {α β : Type} [objects α β] : type α → Type
| object {c : class_name α} :
    {o : β // c = class_of α o} → value (type.ref c)
| null (c : class_name α) :
    value (type.ref c)
| term {r : record_name α} :
    (data_type r).host → value (type.data r)
/- The default value of a reference type is null, and the default value of a data type is the default in Lean. -/
instance value.inhabited {α β : Type} [objects α β] :
    Π{ty : type α}, inhabited (value ty)
| (type.ref c) := ⟨value.null c⟩
| (type.data r) := ⟨value.term (data_type r).default⟩
-- Projection of value to term
def value.unterm {α β : Type} [objects α β]
    {r : record_name α} : Π (x : value (type.data r)),
    (data_type r).host
| (value.term t) := t
-- Projection of boolean value to bool
def value.unbool {α β : Type} [objects α β] :
    Π (x : value (boolean α)), bool
| (value.term t) := cast (data_type_boolean α β) t
-- Projection of value to potential object
def value.unobject {α β : Type} [objects α β]
    {c : class_name α} : Π (x : value (type.ref c)), option β
| (value.object o) := o
| (value.null _) := none
def value.not_null {α β : Type} [objects α β]
    {c : class_name α} (x : value (type.ref c)) : Prop :=
  x ≠ value.null c
-- Projection of not-null value to object identity
def value.the_object {α β : Type} [objects α β]
    {c : class_name α} : Π {x : value (type.ref c)},
    value.not_null x → β
| (value.object o) _ := o
| (value.null .(c)) G := begin exfalso, apply G, refl end
lemma value.class_of_the_object {α β : Type} [objects α β]
  {c : class_name α} {x : value (type.ref c)}
  (G : value.not_null x) :
  class_of α (value.the_object G) = c :=
begin
  cases x,
  {unfold value.the_object, apply eq.symm,
   simp [coe,lift_t,has_lift_t.lift],
   simp [coe_t,has_coe_t.coe,coe_b,has_coe.coe],
   exact x_a.property},
  {exfalso, apply G, refl}
end

/- Given a list of types, we have a value list of values with matching types. -/
@[derive decidable_eq]
inductive vallist {α β : Type} [objects α β] :
    list (type α) → Type
| nil : vallist []
| cons {ty : type α} {l : list (type α)} :
  value ty → vallist l → vallist (ty::l)
def vallist.default {α β : Type} [objects α β] :
    Π(l : list (type α)), vallist l
| [] := vallist.nil
| (t :: l) := vallist.cons (default (value t))
    (vallist.default l)
instance vallist.inhabited {α β : Type} [objects α β]
    (l : list (type α)) : inhabited (vallist l) :=
  ⟨vallist.default l⟩
/- A value list of a single type is just a value. -/
def vallist.single {α β : Type} [objects α β] {ty : type α}
    (v : value ty) : vallist [ty] :=
  vallist.cons v vallist.nil
/- There is a unique value of a single value list. -/
def vallist.the {α β : Type} [objects α β] {ty : type α} :
    vallist [ty] → value ty
| (vallist.cons h vallist.nil) := h
/- A value list of a single type can be appended at the front to form a new value list. -/
def vallist.consl {α β : Type} [objects α β]
    {ty : type α} {l : list (type α)}
    (h : vallist [ty]) (t : vallist l) : vallist (ty :: l) :=
  vallist.cons (h.the) t
/- Given a value list and an index in the list of types, we obtain a value. -/
def vallist.lookup {α β : Type} [objects α β] {ty : type α} :
    Π {l : context α}, vallist l → list_at ty l → value ty
| (x :: xs) (vallist.cons v _) (list_at.here .(x) .(xs)) := v
| (x :: xs) (vallist.cons _ ys) (list_at.tail .(x) zs) :=
    vallist.lookup ys zs
/- Given a value list and an index and a new value, we obtain a new value list which updates the given index. -/
def vallist.update {α β : Type} [objects α β] {ty : type α} :
    Π {l : context α}, vallist l → list_at ty l →
    value ty → vallist l
| (x :: xs) (vallist.cons _ tl) (list_at.here .(x) .(xs)) v :=
    vallist.cons v tl
| (x :: xs) (vallist.cons v ys) (list_at.tail .(x) zs) w :=
    vallist.cons v (vallist.update ys zs w)

/- An interpretation consists of a mapping from constant symbols to values, and from function symbols to functions over value lists to values. -/
class interpret (α β : Type) extends objects α β :=
  (interp {args : list (type α)} {result : type α}
    {s : symbol_name α} (sym : symbol args result s):
    vallist args → value result)


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.basic
import Mathlib.category_theory.eq_to_hom
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Bundled Monads

We define bundled (co)monads as a structure consisting of a functor `func : C ⥤ C` endowed with
a term of type `(co)monad func`. See `category_theory.monad.basic` for the definition.
The type of bundled (co)monads on a category `C` is denoted `(Co)Monad C`.

We also define morphisms of bundled (co)monads as morphisms of their underlying (co)monads
in the sense of `category_theory.(co)monad_hom`. We construct a category instance on `(Co)Monad C`.
-/

namespace category_theory

/-- Bundled monads. -/
structure Monad (C : Type u) [category C] where
  func : C ⥤ C
  str :
    autoParam (monad func)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])

/-- Bundled comonads -/
structure Comonad (C : Type u) [category C] where
  func : C ⥤ C
  str :
    autoParam (comonad func)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])

namespace Monad

/-- The initial monad. TODO: Prove it's initial. -/
def initial (C : Type u) [category C] : Monad C := mk 𝟭

protected instance inhabited {C : Type u} [category C] : Inhabited (Monad C) :=
  { default := initial C }

protected instance func.category_theory.monad {C : Type u} [category C] {M : Monad C} :
    monad (func M) :=
  str M

/-- Morphisms of bundled monads. -/
def hom {C : Type u} [category C] (M : Monad C) (N : Monad C) := monad_hom (func M) (func N)

namespace hom

end hom

protected instance hom.inhabited {C : Type u} [category C] {M : Monad C} : Inhabited (hom M M) :=
  { default := monad_hom.id (func M) }

protected instance category_theory.category {C : Type u} [category C] : category (Monad C) :=
  category.mk

/-- The forgetful functor from `Monad C` to `C ⥤ C`. -/
def forget (C : Type u) [category C] : Monad C ⥤ C ⥤ C :=
  functor.mk func fun (_x _x_1 : Monad C) (f : _x ⟶ _x_1) => monad_hom.to_nat_trans f

@[simp] theorem comp_to_nat_trans {C : Type u} [category C] {M : Monad C} {N : Monad C}
    {L : Monad C} (f : M ⟶ N) (g : N ⟶ L) :
    monad_hom.to_nat_trans (f ≫ g) =
        nat_trans.vcomp (monad_hom.to_nat_trans f) (monad_hom.to_nat_trans g) :=
  rfl

@[simp] theorem assoc_func_app {C : Type u} [category C] {M : Monad C} {X : C} :
    functor.map (func M) (nat_trans.app μ_ X) ≫ nat_trans.app μ_ X =
        nat_trans.app μ_ (functor.obj (func M) X) ≫ nat_trans.app μ_ X :=
  monad.assoc X

end Monad

namespace Comonad

/-- The terminal comonad. TODO: Prove it's terminal. -/
def terminal (C : Type u) [category C] : Comonad C := mk 𝟭

protected instance inhabited {C : Type u} [category C] : Inhabited (Comonad C) :=
  { default := terminal C }

protected instance func.category_theory.comonad {C : Type u} [category C] {M : Comonad C} :
    comonad (func M) :=
  str M

/-- Morphisms of bundled comonads. -/
def hom {C : Type u} [category C] (M : Comonad C) (N : Comonad C) := comonad_hom (func M) (func N)

namespace hom

end hom

protected instance hom.inhabited {C : Type u} [category C] {M : Comonad C} : Inhabited (hom M M) :=
  { default := comonad_hom.id (func M) }

protected instance category_theory.category {C : Type u} [category C] : category (Comonad C) :=
  category.mk

/-- The forgetful functor from `CoMonad C` to `C ⥤ C`. -/
def forget (C : Type u) [category C] : Comonad C ⥤ C ⥤ C :=
  functor.mk func fun (_x _x_1 : Comonad C) (f : _x ⟶ _x_1) => comonad_hom.to_nat_trans f

@[simp] theorem comp_to_nat_trans {C : Type u} [category C] {M : Comonad C} {N : Comonad C}
    {L : Comonad C} (f : M ⟶ N) (g : N ⟶ L) :
    comonad_hom.to_nat_trans (f ≫ g) =
        nat_trans.vcomp (comonad_hom.to_nat_trans f) (comonad_hom.to_nat_trans g) :=
  rfl

@[simp] theorem coassoc_func_app {C : Type u} [category C] {M : Comonad C} {X : C} :
    nat_trans.app δ_ X ≫ functor.map (func M) (nat_trans.app δ_ X) =
        nat_trans.app δ_ X ≫ nat_trans.app δ_ (functor.obj (func M) X) :=
  comonad.coassoc X

end Mathlib


import tactic

universes u v w

class is_lawful_monad_lift (m : Type u → Type v) (n : Type u → Type w) [has_monad_lift m n] [monad m] [monad n] :=
(monad_lift_pure : ∀ {α} (x : α),
  has_monad_lift.monad_lift (pure x : m α) = (pure x : n α))
(monad_lift_bind : ∀ {α β} (x : m α) (f : α → m β),
  (has_monad_lift.monad_lift $ x >>= f : n β) =
  has_monad_lift.monad_lift x >>= has_monad_lift.monad_lift ∘ f )

class is_lawful_monad_lift_t (m : Type u → Type v) (n : Type u → Type w) [has_monad_lift_t m n] [monad m] [monad n] :=
(monad_lift_pure : ∀ {α} (x : α),
  has_monad_lift_t.monad_lift (pure x : m α) = (pure x : n α))
(monad_lift_bind : ∀ {α β} (x : m α) (f : α → m β),
  (has_monad_lift_t.monad_lift $ x >>= f : n β) =
  has_monad_lift_t.monad_lift x >>= has_monad_lift_t.monad_lift ∘ f )

lemma is_lawful_monad_lift_t.monad_lift_and_then  (m : Type u → Type v) (n : Type u → Type w)
  [has_monad_lift_t m n] [monad m] [monad n] [is_lawful_monad_lift_t m n]
  {α β} (x : m α) (f : m β) :
  (has_monad_lift_t.monad_lift $ x >> f : n β) =
  has_monad_lift_t.monad_lift x >> has_monad_lift_t.monad_lift f :=
by { simp [(>>),is_lawful_monad_lift_t.monad_lift_bind n] }

export is_lawful_monad_lift_t (monad_lift_pure monad_lift_bind monad_lift_and_then)

instance has_lawful_monad_lift_t_trans (m n o) [monad m] [monad n] [monad o]
  [has_monad_lift n o] [has_monad_lift_t m n]
  [is_lawful_monad_lift n o] [is_lawful_monad_lift_t m n] : is_lawful_monad_lift_t m o :=
by constructor; intros; simp [monad_lift];
   [ simp [monad_lift_pure m n,is_lawful_monad_lift.monad_lift_pure n o],
     simp [monad_lift_bind n,is_lawful_monad_lift.monad_lift_bind o] ]

instance has_lawful_monad_lift_t_refl (m) [monad m] : is_lawful_monad_lift_t m m :=
by constructor; intros; simp [monad_lift]

class is_lawful_monad_state (σ : out_param (Type u)) (m : Type u → Type v) [monad m] [monad_state σ m] :=
(lift_pure : ∀ {α} (x : α),
  monad_state.lift (pure x : state σ α) = (pure x : m α))
(lift_bind  : ∀ {α β} (x : state σ α) (f : α → state σ β),
  (monad_state.lift $ x >>= f : m β) =
  monad_state.lift x >>= monad_state.lift ∘ f )
(lift_put : ∀ (x : σ),
  monad_state.lift (put x : state σ punit) = (put x : m punit))
(lift_get :
  monad_state.lift (get : state σ σ) = (get : m σ))
open is_lawful_monad_state

lemma is_lawful_monad_state.lift_and_then {m} [monad m] {α β σ} [monad_state σ m] [is_lawful_monad_state σ m] (x : state σ α) (f : state σ β) :
  (monad_state.lift $ x >> f : m β) =
  monad_state.lift x >> monad_state.lift f :=
by { simp [(>>),lift_bind m] }

instance (σ : (Type u)) (m : Type u → Type v) [monad m] [is_lawful_monad m] : is_lawful_monad_state σ (state_t σ m) :=
by { constructor; intros; try { refl },
     { simp [(>>=),state_t.bind,monad_state.lift,id_bind],
       congr, ext z, cases x.run z, refl }, }

instance (σ σ' : (Type u)) (m : Type u → Type v) [monad m] [is_lawful_monad m] [monad_state σ m] [is_lawful_monad_state σ m] :
  is_lawful_monad_state σ (reader_t σ' m) :=
by { constructor; intros; simp [monad_state.lift,lift_pure m,lift_bind m]; refl }

instance (σ : (Type u)) (m : Type u → Type v) [monad m] [is_lawful_monad m] : is_lawful_monad_lift m (state_t σ m) :=
by { constructor; intros; try { refl },
     all_goals
     { simp [(>>=),state_t.bind,state_t.lift,has_monad_lift.monad_lift,id_bind,bind_assoc]; refl }, }

instance (σ : (Type u)) (m : Type u → Type v) [monad m] : is_lawful_monad_lift m (reader_t σ m) :=
by { constructor; intros; refl }

-- class is_lawful_monad_reader (σ : out_param (Type u)) (m : Type u → Type v) [monad m] [monad_reader σ m] :=
-- (lift_pure {} : ∀ {α} (x : α),
--   monad_reader.lift (pure x : reader σ α) = (pure x : m α))
-- (lift_bind {} : ∀ {α β} (x : state σ α) (f : α → state σ β),
--   (monad_state.lift $ x >>= f : m β) =
--   monad_state.lift x >>= monad_state.lift ∘ f )

-- instance (σ : (Type u)) (m : Type u → Type v) [monad m] [is_lawful_monad m] : is_lawful_monad_state σ (state_t σ m) :=
-- by { constructor; intros,
--      { refl },
--      { simp [(>>=),state_t.bind,monad_state.lift,id_bind],
--        congr, ext z, cases x.run z, refl } }

-- class is_lawful_monad_state


/- Provides simplification lemmas for applicative laws. -/

universe variables u

@[simp]
lemma fmap_pure {m : Type u → Type u} [hm : applicative m] {α β : Type u} (f : α → β) (v : α) :
  f <$> (pure v : m α) = pure (f v) := applicative.map_pure m f v


import for_mathlib.category_theory.localization.derived_functor

noncomputable theory

open category_theory category_theory.category

namespace category_theory

namespace structured_arrow

variables {C₁ C₂ C₃ D₁ D₂ D₃ : Type*} [category C₁] [category C₂]
  [category C₃] [category D₁] [category D₂] [category D₃]
  {P₁ : C₁ ⥤ D₁} {P₂ : C₂ ⥤ D₂} {P₃ : C₃ ⥤ D₃}
  {A : C₁ ⥤ C₂} {B : D₁ ⥤ D₂} {A' : C₂ ⥤ C₃} {B' : D₂ ⥤ D₃}
  (τ : P₁ ⋙ B ⟶ A ⋙ P₂) (τ' : P₂ ⋙ B' ⟶ A' ⋙ P₃) (Y : D₁)

@[simps]
def whisker :
  structured_arrow Y P₁ ⥤ structured_arrow (B.obj Y) P₂ :=
{ obj := λ X, structured_arrow.mk (B.map X.hom ≫ τ.app X.right),
  map := λ X X' f, structured_arrow.hom_mk (A.map f.right) begin
    dsimp,
    simp only [← structured_arrow.w f, category.assoc, B.map_comp],
    erw τ.naturality,
    refl,
  end, }

-- unnecessary
@[simps]
def whisker_comp_iso
  (τ'' : P₁ ⋙ (B ⋙ B') ⟶ (A ⋙ A') ⋙ P₃)
  (hτ : τ'' = (functor.associator P₁ B B').inv ≫ whisker_right τ B' ≫
    (functor.associator A P₂ B').hom ≫ whisker_left A τ' ≫ (functor.associator A A' P₃).inv) :
  whisker τ Y ⋙ whisker τ' (B.obj Y) ≅
    whisker τ'' Y :=
nat_iso.of_components (λ X, structured_arrow.iso_mk (iso.refl _) begin
  dsimp,
  simp only [hτ, functor.map_comp, assoc, functor.map_id, comp_id, nat_trans.comp_app, functor.associator_inv_app,
    whisker_right_app, functor.associator_hom_app, whisker_left_app, id_comp],
end) (by tidy)

instance full_whisker [full A] [faithful B] [is_iso τ] : full (whisker τ Y) :=
functor.full_of_surjective _ (λ X₁ X₂ f, begin
  refine ⟨structured_arrow.hom_mk (A.preimage f.right) (B.map_injective _), _⟩,
  { have eq := structured_arrow.w f,
    dsimp at eq,
    erw [B.map_comp, ← cancel_mono (τ.app X₂.right), ← eq, assoc, assoc, τ.naturality],
    dsimp,
    simp only [functor.image_preimage], },
  { ext,
    dsimp,
    simp, },
end)

instance faithful_whisker [faithful A] : faithful (whisker τ Y) :=
⟨λ X₁ X₂ f₁ f₂ hf, begin
  ext,
  exact A.map_injective ((structured_arrow.proj _ _).congr_map hf),
end⟩

instance ess_surj [ess_surj A] [full B] [is_iso τ] : ess_surj (whisker τ Y) :=
⟨λ X, ⟨structured_arrow.mk (B.preimage (X.hom ≫
  P₂.map (A.obj_obj_preimage_iso X.right).inv ≫ (inv τ).app _)),
  ⟨structured_arrow.iso_mk (A.obj_obj_preimage_iso X.right) begin
    dsimp,
    simp only [nat_iso.is_iso_inv_app, functor.image_preimage, assoc, is_iso.inv_hom_id, comp_id,
      ← P₂.map_comp, iso.inv_hom_id, P₂.map_id],
  end⟩⟩⟩

instance is_equivalence_whisker
  [is_iso τ] [is_equivalence A] [full B] [faithful B] : is_equivalence (whisker τ Y) :=
begin
  haveI : ess_surj A := -- `ess_surj_of_is_equivalence` should be an instance
    ⟨λ X, ⟨(is_equivalence.inverse A).obj X, ⟨is_equivalence.counit_iso.app X⟩⟩⟩,
  apply equivalence.of_fully_faithfully_ess_surj,
end

end structured_arrow

namespace functor

namespace is_right_derived_functor

section

variables {C D D' H : Type*} [category C] [category D] [category D'] [category H]
  {F : C ⥤ D} (RF : H ⥤ D) {L : C ⥤ H} (α : F ⟶ L ⋙ RF) (e : D ≌ D')
  (W : morphism_property C) [L.is_localization W]

lemma of_equivalence_comp_right [RF.is_right_derived_functor α]
  (β : F ⋙ e.functor ⟶ L ⋙ RF ⋙ e.functor)
  (hβ : β = whisker_right α e.functor ≫ (functor.associator _ _ _).hom) :
  (RF ⋙ e.functor).is_right_derived_functor β :=
begin
  let e' : (whiskering_left C H D).obj L ⋙ (whiskering_right C D D').obj e.functor ≅
    (whiskering_right H D D').obj e.functor ⋙ (whiskering_left C H D').obj L :=
    nat_iso.of_components (λ X, iso.refl _) (by tidy),
  exact ⟨⟨limits.is_initial.of_iso (limits.is_initial.is_initial_obj (structured_arrow.whisker e'.hom F) (structured_arrow.mk α)
    (is_right_derived_functor.is_initial α).some)
    (structured_arrow.iso_mk (iso.refl _) (by { rw hβ, tidy, }))⟩⟩,
end

instance of_equivalence_comp_right' [RF.is_right_derived_functor α] (G : D ⥤ D')
  [is_equivalence G] :
  (RF ⋙ G).is_right_derived_functor (whisker_right α G ≫ (functor.associator _ _ _).hom) :=
of_equivalence_comp_right RF α (as_equivalence G) _ rfl

instance has_right_derived_functor_equivalence_comp_right (G : D ⥤ D')
  [is_equivalence G] [F.has_right_derived_functor W] :
  (F ⋙ G).has_right_derived_functor W :=
is_right_derived_functor.has_right_derived_functor (F ⋙ G)
  (F.right_derived_functor W.Q W ⋙ G) W.Q
  (whisker_right (F.right_derived_functor_α W.Q W) G ≫ (functor.associator _ _ _).hom) W

end

section

variables {C C' D H H' : Type*} [category C] [category C'] [category D] [category H] [category H']
  {F' : C' ⥤ D} (RF' : H' ⥤ D) {L' : C' ⥤ H'} (α' : F' ⟶ L' ⋙ RF') {L : C ⥤ H}
  {G : C ⥤ C'} {G' : H ⥤ H'} (e : G ⋙ L' ≅ L ⋙ G')
  [is_equivalence G] [is_equivalence G']
  (W : morphism_property C) [L.is_localization W]
  (W' : morphism_property C') [L'.is_localization W']

lemma of_equivalence_comp_left [RF'.is_right_derived_functor α']
  (α : G ⋙ F' ⟶ L ⋙ (G' ⋙ RF'))
  (hα : α = whisker_left G α' ≫ (functor.associator _ _ _).inv ≫
      whisker_right e.hom RF' ≫ (functor.associator _ _ _).hom) :
  (G' ⋙ RF').is_right_derived_functor α :=
begin
  let e' : (whiskering_left C' H' D).obj L' ⋙ (whiskering_left C C' D).obj G ≅
    (whiskering_left H H' D).obj G' ⋙ (whiskering_left C H D).obj L :=
    nat_iso.of_components (λ X, iso_whisker_right e X) (by tidy),
  exact ⟨⟨limits.is_initial.of_iso (limits.is_initial.is_initial_obj
    (structured_arrow.whisker e'.hom F') (structured_arrow.mk α')
    (is_right_derived_functor.is_initial α').some) (structured_arrow.iso_mk (iso.refl _)
    (by { rw hα, tidy, }))⟩⟩,
end

instance of_equivalence_comp_left' [RF'.is_right_derived_functor α'] :
  (G' ⋙ RF').is_right_derived_functor (whisker_left G α' ≫ (functor.associator _ _ _).inv ≫
      whisker_right e.hom RF' ≫ (functor.associator _ _ _).hom) :=
of_equivalence_comp_left RF' α' e _ rfl

lemma _root_.category_theory.functor.has_right_derived_functor_equivalence_comp_right
  [F'.has_right_derived_functor W'] :
  (G ⋙ F').has_right_derived_functor W :=
is_right_derived_functor.has_right_derived_functor (G ⋙ F') _ _
    ((whisker_left G (F'.right_derived_functor_α L' W') ≫ (functor.associator _ _ _).inv ≫
    whisker_right e.hom _ ≫ (functor.associator _ _ _).hom)) W

end

end is_right_derived_functor

end functor

end category_theory


import reducibility friedberg_muchnik
open encodable denumerable part

-- Degrees of Unsolvability

attribute [instance, priority 0] classical.prop_decidable

@[notation_class] class has_jump (α : Type*) := (jump : α → α)

postfix `⁺`:(max+1) := has_jump.jump

theorem equivalence_of_t_reducible_equiv (α) [primcodable α] :
  equivalence (@t_reducible_equiv α α _ _) :=
⟨λ x, t_reducible_equiv.refl x,
 λ _ _, t_reducible_equiv.symm,
 λ _ _ _, t_reducible_equiv.trans⟩

def turing_degree : Type :=
quotient (⟨t_reducible_equiv, equivalence_of_t_reducible_equiv ℕ⟩ : setoid (set ℕ))

notation `𝐃` := turing_degree

namespace turing_degree

def deg (A : set ℕ) : 𝐃 := quotient.mk' A

@[elab_as_eliminator]
protected lemma ind_on {C : 𝐃 → Prop} (d : 𝐃)
  (h : ∀ p : set ℕ, C (deg p)) : C d :=
quotient.induction_on' d h

@[elab_as_eliminator, reducible]
protected def lift_on {φ} (d : 𝐃) (f : set ℕ → φ)
  (h : ∀ p q, p ≡ₜ q → f p = f q) : φ :=
quotient.lift_on' d f h

@[simp]
protected lemma lift_on_eq {φ} (p : set ℕ) (f : set ℕ → φ)
  (h : ∀ p q, t_reducible_equiv p q → f p = f q) : (deg p).lift_on f h = f p :=
rfl

@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ} (d₁ d₂ : 𝐃) (f : set ℕ → set ℕ → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ≡ₜ q₁ → p₂ ≡ₜ q₂ → f p₁ p₂ = f q₁ q₂) : φ :=
quotient.lift_on₂' d₁ d₂ f h

@[simp]
protected lemma lift_on₂_eq {φ} (p q : set ℕ) (f : set ℕ → set ℕ → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ≡ₜ q₁ → p₂ ≡ₜ q₂ → f p₁ p₂ = f q₁ q₂) :
  (deg p).lift_on₂ (deg q) f h = f p q := rfl

@[simp] lemma of_eq_of {p q} : deg p = deg q ↔ p ≡ₜ q :=
by simp [deg, quotient.eq']

instance : has_le 𝐃 :=
⟨λ d₁ d₂, turing_degree.lift_on₂ d₁ d₂ (≤ₜ) $
 λ p₁ p₂ q₁ q₂ hp hq, propext
 ⟨λ hpq, (hp.2.trans hpq).trans hq.1, λ hpq, (hp.1.trans hpq).trans hq.2⟩⟩

@[simp] lemma of_le_of {A B} : deg A ≤ deg B ↔ A ≤ₜ B := by refl

instance : semilattice_sup_bot 𝐃 :=
{ le := (≤),
  sup := λ a b, turing_degree.lift_on₂ a b (λ A B, deg (Join₂ A B)) (λ A₁ B₁ A₂ B₂ hA hB,
   by { simp, split,
        { have lmm₁ : A₁ ≤ₜ Join₂ A₂ B₂, from hA.1.trans (le_Join₂_left _ _).to_turing,
          have lmm₂ : B₁ ≤ₜ Join₂ A₂ B₂, from hB.1.trans (le_Join₂_right _ _).to_turing,
          refine Join₂_le A₁ B₁ _ lmm₁ lmm₂ },
        { have lmm₁ : A₂ ≤ₜ Join₂ A₁ B₁, from hA.2.trans (le_Join₂_left _ _).to_turing,
          have lmm₂ : B₂ ≤ₜ Join₂ A₁ B₁, from hB.2.trans (le_Join₂_right _ _).to_turing,
          refine Join₂_le A₂ B₂ _ lmm₁ lmm₂ } }),
  bot := deg ∅,
  le_refl := λ d, by induction d using turing_degree.ind_on; simp,
  le_trans := λ a b c,
  by { induction a using turing_degree.ind_on,
       induction b using turing_degree.ind_on,
       induction c using turing_degree.ind_on,
       exact t_reducible.trans },
  le_antisymm := λ a b,
  by { induction a using turing_degree.ind_on,
       induction b using turing_degree.ind_on,
       intros hp hq,
       simp only [*, t_reducible_equiv, of_le_of, of_eq_of, true_and] at * },
  le_sup_left := λ a b,
  by { induction a using turing_degree.ind_on,
       induction b using turing_degree.ind_on,
       simp[has_sup.sup], exact (le_Join₂_left _ _).to_turing },
  le_sup_right := λ a b,
  by { induction a using turing_degree.ind_on,
       induction b using turing_degree.ind_on,
       simp[has_sup.sup], exact (le_Join₂_right _ _).to_turing },
  sup_le := λ a b c,
  by { induction a using turing_degree.ind_on,
       induction b using turing_degree.ind_on,
       induction c using turing_degree.ind_on,
       simp[has_sup.sup], exact Join₂_le a b c },
  bot_le := λ a, by { induction a using turing_degree.ind_on, simp, exact computable_le _ computable_0 } }

lemma of_sup_of {A B} : deg A ⊔ deg B = deg (Join₂ A B) := rfl

instance : inhabited 𝐃 := ⟨⊥⟩

def djump : 𝐃 → 𝐃 :=
λ d, turing_degree.lift_on d (λ d, deg d′)
(λ A B ⟨ab, ba⟩, by { simp, exact
 ⟨(le_le_Jump ab).to_many_one.to_turing, (le_le_Jump ba).to_many_one.to_turing⟩ })

instance : has_jump 𝐃 := ⟨djump⟩

def djump_itr (d : 𝐃) : ℕ → 𝐃
| 0     := d
| (n+1) := (djump_itr n)⁺

@[simp] lemma of_jump {A} : (deg A)⁺ = deg A′ := rfl

def re_degree := {d // ∃ R : set ℕ, r.e. R ∧ d = deg R}

notation `𝐑` := re_degree

instance : has_coe 𝐑 𝐃 := ⟨subtype.val⟩

instance : semilattice_sup_bot 𝐑 :=
  { le := λ a b, (a : 𝐃) ≤ (b : 𝐃),
    sup := λ a b, ⟨(a : 𝐃) ⊔ (b : 𝐃),
      by { rcases a with ⟨a, A, reA, rfl⟩, rcases b with ⟨b, B, reB, rfl⟩,
           refine ⟨Join₂ A B, re_Join_of_re_re reA reB, by simp[of_sup_of]⟩ }⟩,
    bot := ⟨⊥, ∅, re_pred_0, rfl⟩,
    le_refl := by simp,
    le_trans := λ ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, by {simp, exact le_trans },
    le_antisymm := λ ⟨a, _⟩ ⟨b, _⟩, by { simp, exact le_antisymm },
    bot_le := λ ⟨a, _⟩, by simp,
    le_sup_left := λ ⟨a, _⟩ ⟨b, _⟩, by simp,
    le_sup_right := λ ⟨a, _⟩ ⟨b, _⟩, by simp,
    sup_le := λ ⟨a, _⟩ ⟨b, _⟩ ⟨c, _⟩, by { simp[-sup_le_iff], exact sup_le } }

instance : semilattice_sup_top 𝐑 :=
  { top := ⟨⊥⁺, (∅ : set ℕ)′, re_pred_Jump_0, rfl⟩,
    le_top := λ ⟨a, R, reR, rfl⟩, by { simp[has_top.top, show ⊥⁺ = deg ∅′, by refl],
    exact (re_many_one_reducible_to_0'.mp reR).to_turing },
    ..re_degree.semilattice_sup_bot }

def High := {d : 𝐑 | (d : 𝐃)⁺ = ⊥⁺⁺}

def Low  := {d : 𝐑 | (d : 𝐃)⁺ = ⊥⁺}

@[simp] lemma of_lt_of {A B} : deg A < deg B ↔ A <ₜ B := by refl

theorem lt_djump (d : 𝐃) : d < d⁺ :=
by { induction d using turing_degree.ind_on, simp,
     exact lt_Jump _ }

theorem djump_neq (d : 𝐃) : d ≠ d⁺ := λ h,
by { have : d⁺ ≤ d, rw ←h,
     exact (lt_djump d).2 this }

instance : nontrivial 𝐃 := ⟨⟨⊥, ⊥⁺, djump_neq ⊥⟩⟩

lemma jump_order_preserving (a b : 𝐃) (le : a ≤ b) : a⁺ ≤ b⁺ :=
by { induction a using turing_degree.ind_on,
     induction b using turing_degree.ind_on,
     simp at le ⊢, exact (le_le_Jump le).to_turing }

theorem friedberg_muchnik : ∃ a b : 𝐑, ¬a ≤ b ∧ ¬b ≤ a :=
by rcases friedberg_muchnik.incomparable_re_sets with ⟨I₀, I₁, re₀, re₁, nle₀, nle₁⟩;
   refine ⟨⟨deg I₀, I₀, re₀, rfl⟩, ⟨deg I₁, I₁, re₁, rfl⟩, nle₁, nle₀⟩

end turing_degree


structure PFunctor : Type 1 :=
( α : Type )
( β : α → Type )

variable (P : PFunctor)

namespace PFunctor

def obj (X : Type) : Type :=
Σ (a : P.α), P.β a → X

def map {X Y : Type} (f : X → Y) (x : P.obj X) : P.obj Y :=
⟨x.1, λ a => f (x.2 a)⟩

inductive Z (P : PFunctor) : Type
| bud : Z P
| some (a : P.α) (f : P.β a → Z P) : Z P

variable {P}

def of_α (a : P.α) : Z P :=
Z.some a (λ _ => Z.bud)

inductive bud : Z P → Type
| bud : bud (@Z.bud P)
| some {a : P.α} {f : P.β a → Z P} {p : P.β a} (b : bud (f p)) :
    bud (Z.some a f)

inductive is_extension : Z P → Z P → Prop
| bud (z : Z P) : is_extension Z.bud z
| some {a : P.α} {f₁ f₂ : P.β a → Z P} (h : ∀ p : P.β a, is_extension (f₁ p) (f₂ p)) :
  is_extension (Z.some a f₁) (Z.some a f₂)

theorem is_extension.refl : (z : Z P) → is_extension z z
| Z.bud => is_extension.bud _
| Z.some _ _ => is_extension.some (λ _ => is_extension.refl _)

inductive extends_at {P : PFunctor}: (z₁ : Z P) → (b : bud z) → Z P → Type
| bud {a : P.α} {f : P.β a → Z P} : extends_at (@Z.bud P) (@bud.bud P) (Z.some a f)
| some {a : P.α} {f₁ f₂ : P.β a → Z P} {p : P.β a} (b : bud (f₁ p))
  (h : extends_at (f₁ p) b (f₂ p)) :
    extends_at (Z.some a f₁) (bud.some b) (Z.some a f₂)

structure M' (P : PFunctor) : Type :=
( s : Z P → Prop )
( bud_mem : s Z.bud )
( extension_pair {z₁ z₂ : Z P} : s z₁ → s z₂ →
  ∃ z₃ : Z P, s z₃ ∧ is_extension z₁ z₃ ∧ is_extension z₂ z₃ )
( extend {z : Z P} : s z → bud z → Z P )
( extend_extends {z : Z P} (h : s z) (b : bud z) :
    extends_at z b (extend h b) )

def M'.constructor (m : M' P) : P.α :=
let z := m.extend m.bud_mem bud.bud
have hz : extends_at Z.bud bud.bud z := m.extend_extends m.bud_mem bud.bud
match z, hz with
| Z.some a _, _ => a

def M.branch (m : M' P) (a : P.β m.constructor) : M' P :=

def M'_coalg (m : M' P) : P.obj (M' P) :=
let z := m.extend m.bud_mem bud.bud
have hz : extends_at Z.bud bud.bud z := m.extend_extends m.bud_mem bud.bud
match z, hz with
| Z.some a f, _ => ⟨a, λ p =>
  { s := λ z => z = Z.bud ∨ ∃ f : P.β a → Z P, m.s (Z.some a f) ∧ z = f p,
    bud_mem := Or.inl rfl,
    extension_pair := @λ z₁ z₂ hz₁ hz₂ =>
      match z₁, z₂, hz₁, hz₂ with
      | _, z₂, Or.inl rfl, hz₂ =>
        ⟨z₂, hz₂, is_extension.bud _, is_extension.refl _⟩
      | z₁, _, hz₁, Or.inl rfl =>
        ⟨z₁, hz₁, is_extension.refl _, is_extension.bud _⟩
      | _, _, Or.inr ⟨f₁, hf₁, rfl⟩, Or.inr ⟨f₂, hf₂, rfl⟩ =>
        match m.extension_pair hf₁ hf₂ with
        | ⟨Z.some _ f, h₁, is_extension.some h₂, is_extension.some h₃⟩ =>
          ⟨f p, Or.inr ⟨f, h₁, rfl⟩, h₂ p, h₃ p⟩,
    extend := @λ z hz b =>
      match z, hz, b with
      | Z.bud, _, bud.bud => f p
      | Z.some a' f', h, @bud.some _ _ _ p' h' =>
        _
    extend_extends := sorry
       }⟩

-- def M'.rel (m₁ m₂ : M' P) : Prop :=
-- ∃ m₃ : M' P, (∀ z, m₁.s z → m₃.s z) ∧ (∀ z, m₂.s z → m₃.s z)

-- def M'.rel.refl (m : M' P) : M'.rel m m :=
-- ⟨m, λ _ => id, λ _ => id⟩

-- def M'.rel.symm {m₁ m₂ : M' P} : M'.rel m₁ m₂ → M'.rel m₂ m₁
-- | ⟨m₃, h₁, h₂⟩ => ⟨m₃, h₂, h₁⟩

-- def M'.rel.trans {m₁ m₂ m₃ : M' P} : M'.rel m₁ m₂ → M'.rel m₂ m₃ → M'.rel m₁ m₃
-- | ⟨n, hn₁, hn₂⟩, ⟨o, ho₁, ho₂⟩ =>
--   ⟨{ s := λ z => n.s z ∨ o.s z,
--      bud_mem := Or.inl n.s.bud_mem,
--      extension_pair := _  }


import Aesop

axiom Scheme : Type
axiom P : Scheme → Prop
axiom Q : Scheme → Prop
axiom R : Scheme → Prop
axiom S : Scheme → Prop

@[aesop 99%] axiom Q_of_P (X : Scheme) (h : P X) : Q X
@[aesop 99%] axiom R_of_Q (X : Scheme) (h : Q X) : R X

@[aesop 99%] axiom S_of__R_of_P (X : Scheme) (h : P X → R X) : S X

theorem thm : S X := by {
  aesop;
}

#print thm


import data.list.alist
import .presheaf2

namespace o_minimal

variables {R : Type*} {S : struc R}

structure sect (Γ : Def S) (X : Type*) [definable_psh S X] :=
(to_fun : Γ → X)
(definable : definable_psh.definable to_fun)

infixr ` ⊢ `:10 := sect

def sect.precomp {Γ' Γ : Def S} {X : Type*} [definable_psh S X]
  (σ : Γ ⊢ X) (φ : Hom Γ' Γ) : Γ' ⊢ X :=
{ to_fun := σ.to_fun ∘ φ.to_fun,
  definable := definable_psh.definable_precomp φ σ.definable }

lemma begin_lem {X : Type*} [definable_psh S X] {x : X} :
  definable S x ↔ ∀ (Γ : Def S), definable_psh.definable (λ (γ : Γ), x) :=
begin
  unfold definable,
  split; intro H,
  { intro Γ,
    let u : Hom Γ pt := ⟨λ _, default _, by exact pt.definable⟩,
    exact definable_psh.definable_precomp u H },
  { apply H }
end

lemma intro_lem₁ {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  (f : X → Y) :
  (∀ (Γ : Def S), definable S (λ (γ : Γ), f)) ↔
  (∀ (Γ : Def S) (x : Γ → X), definable S x → definable S (λ (γ : Γ), f (x γ))) :=
sorry

lemma definable_fun' {Γ : Def S} {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  {f : Γ → X → Y} : definable_psh.definable f ↔
  (∀ (Γ' : Def S) (π : Hom Γ' Γ) (g : Γ' ⊢ X),
   definable_psh.definable (λ γ_1, f (π.to_fun γ_1) (g.to_fun γ_1))) :=
begin
  split; intro H,
  { intros Γ' π g,
    have : definable_psh.definable (λ γ', (π.to_fun γ', g.to_fun γ')) :=
      ⟨π.is_definable, g.definable⟩,
    exact H Γ' this },
  { intros M g hg,
    exact H M ⟨_, hg.1⟩ ⟨_, hg.2⟩ }
end

lemma definable.app_ctx' {Γ : Def S} {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  (f : Γ → X → Y) {hf : definable_psh.definable f} (x : Γ → X) {hx : definable_psh.definable x} :
  definable_psh.definable (λ γ, f γ (x γ)) :=
begin
  have : definable_psh.definable (λ γ, (γ, x γ)) :=
    ⟨(Def.id _).is_definable, hx⟩,
  exact hf Γ this
end

lemma definable_const {Γ : Def S} {X : Type*} [definable_psh S X] {x : X} :
  definable S x → definable_psh.definable (λ (_ : Γ), x) :=
λ H, begin_lem.mp H Γ

end o_minimal

namespace tactic.interactive

open tactic
open interactive interactive.types

meta def defin_start : tactic unit :=
`[rw o_minimal.begin_lem, intro Γ]

/-- Return the variable representing the definable context. -/
meta def guess_ctx_var : tactic expr :=
do `(o_minimal.definable_psh.definable (λ (_ : ↥%%var), _)) ← target,
   -- trace var,
   return var

/-- Return a list of "definable" variables along with their processed types. -/
meta def guess_defin_vars (ctx_var : expr) : tactic (list (expr × expr)) :=
do l ← local_context,
   -- some kind of moption_map?
   l ← l.mmap (λ var,
     (do `(o_minimal.sect %%ctx_var %%ty) ← infer_type var,
         return $ some (var, ty)) <|> return none),
   let l' := l.filter_map id,
   -- trace l',
   return l'

meta def guess_defin_vars' : tactic (list (expr × expr)) :=
guess_ctx_var >>= guess_defin_vars

/-- Goal should look like
  ⊢ definable_psh.definable (λ γ, λ x, e)
We want to "intro" `x` as a definable variable, and leave
  ⊢ definable_psh.definable (λ γ, e)
as the new goal.

Strategy:
By `definable_fun'` it's enough to check the new goal
for an arbitrary context extension π : Γ' → Γ and section x : Γ' ⊢ α.
However, we also have to move any existing definable variables from Γ to Γ'.
So, we proceed as follows:
* Identify the variables `γ` (`i_var`) and `Γ` (`ctx_var`) in the goal
  `definable_psh.definable (λ (γ : Γ), body)`.
  Here `body` is expected to be a function whose argument `x`
  we want to intro.
* Use `definable_fun'` but then intro only `Γ'` and `π`.
* For each existing definable variable `p`, we add a let binding
  `p' := p.precomp π`.
* Now intro the new variable `x` (`new_var`) as well, and build a new function
  (λ (γ' : Γ'), body' (x.to_fun γ')), by making the following replacements:
  - each old `p` becomes `p'`;
  - `i` becomes `i'`;
  - `Γ` becomes `Γ'`.
  The claim is that the new expression is well-typed and definitionally equal
  (in the context of the let-bound variables `p'`, ...) to the current goal.
  Moreover, it only mentions the new `Γ'` and `p'`.
* Now we cover our tracks:
  - clear the bodies of the let bindings `p'`, so that we can:
  - clear the old definable variables, `π`, and the old `Γ`.

The tactic reuses the same user-visible names for the new `Γ` and `γ`.
This is nice for interactive use, but not so nice for debugging the tactic.
In the latter case, add `name.append_after _ 1` when generating names.
-/
meta def defin_intro (var : parse ident_) : tactic unit :=
let trace : Π {α : Type} [has_to_tactic_format α] (a : α), tactic unit :=
  λ _ _ _, tactic.skip in       -- comment this for debugging
do `(o_minimal.definable_psh.definable %%f) ← target,
   ([i_var], body) ← open_n_lambdas f 1,
   ctx_var ← guess_ctx_var,
   trace i_var,
   trace body,
   `[rw definable_fun'],
   new_ctx_var ← tactic.intro ctx_var.local_pp_name,
   proj_var ← tactic.intro `π,
   defin_vars ← guess_defin_vars ctx_var,
   -- do something to them:
   -- * for each old variable `p`, create a new variable `p'`
   --   which is let-bound to `p.precomp π`
   defin_var_list ← defin_vars.mmap (λ ⟨dvar, dvar_ty⟩, do
     -- "let p' := p.precomp π,"
     new_body ← to_expr ``((%%dvar).precomp %%proj_var),
     new_dvar ← tactic.pose dvar.local_pp_name none new_body,
     return (sigma.mk dvar new_dvar)),
   new_i_type ← to_expr ``(↥%%new_ctx_var),
   new_i_var ← mk_local' i_var.local_pp_name f.binding_info new_i_type,
   -- * replace variables `p` → `p'` in `body`, and also the γ and Γ vars
   let var_map :=
     (defin_var_list.to_alist.insert i_var new_i_var).insert ctx_var new_ctx_var,
   let body' := body.replace (λ e _, do
     -- for "efficiency", first check whether we have a variable at all
     guard (e.is_local_constant),
     -- then, look up the whole expression in our map
     var_map.lookup e),
   -- do the actual intro
   new_var ← tactic.intro var,
   new_var' ← to_expr ``((%%new_var).to_fun %%new_i_var),
   new_f ← tactic.lambdas [new_i_var] (body'.subst new_var'),
   trace new_f,
   new_target ← to_expr
     ``(o_minimal.definable_psh.definable %%new_f),
   tactic.change new_target,
   -- for each defin var:
   -- * forget its let binding (so that we can do the `clear`s below)
   --   (using `clear_value` from mathlib's `tactic.core`)
   -- * clear the original variable
   tactic.clear_value (defin_var_list.map sigma.snd),
   defin_var_list.mmap (λ ⟨dvar, new_dvar⟩, do tactic.clear dvar),
   tactic.clear proj_var,
   tactic.clear ctx_var,
   return ()

/-- Goal should look like
 ⊢ definable_psh.definable (λ γ, f x)
and we want to produce
 ⊢ definable_psh.definable (λ γ, f)
 ⊢ definable_psh.definable (λ γ, x)
This is just `apply definable.app_ctx'`,
but Lean needs help with the unification problem.
-/
meta def defin_app : tactic unit :=
do `(o_minimal.definable_psh.definable %%e) ← target,
   ([i_var], body) ← open_n_lambdas e 1,
   (expr.app f x) ← pure body,
   f' ← tactic.lambdas [i_var] f,
   x' ← tactic.lambdas [i_var] x,
   `[apply o_minimal.definable.app_ctx' %%f' %%x'],
   return ()

/-- Goal should look like
 ⊢ definable_psh.definable (λ γ, p.to_fun γ)
where p : Γ ⊢ α. Just apply `sect.definable`.
-/
meta def defin_var : tactic unit :=
`[refine o_minimal.sect.definable _]

end tactic.interactive

-- Now dress it up

meta def defin := tactic

meta instance : monad defin :=
show monad tactic, by apply_instance

meta instance : interactive.executor defin :=
{ config_type := unit,
  inhabited := by apply_instance,
  execute_with := λ _ tac, tactic.interactive.defin_start >> tac }

namespace defin

meta def execute (tac : defin unit) : tactic unit :=
tactic.interactive.defin_start >> tac

meta def step := @tactic.step   -- what does this even do
meta def istep := @tactic.istep -- ditto
meta def solve1 : defin unit → defin unit := tactic.solve1

open tactic

-- Tactic state display borrows liberally from
-- https://github.com/unitb/temporal-logic
-- file temporal_logic.tactic

/-- Replace any occurrences of `p.to_fun γ` with simply `p`.
This is rather crude, but these aren't expected to appear
outside the execution of a defin tactic. (More sophisticated
would be to process only those variables which are sections
over the context variable that appears in the goal.)
The resulting expression is intended to be used for display purposes. -/
meta def shorten (E : expr) : expr :=
E.replace $ λ e _, match e with
  | `(o_minimal.sect.to_fun %%p _) := some p
  | _ := none
end

meta structure hyp_data : Type :=
(crisp : bool)
(var : expr)
(ty : expr)
(val : option expr)

/-- Return information about a local hypothesis `l`. -/
meta def get_hyp_data (l : expr) : defin hyp_data :=
do ty ← infer_type l,
   val ← try_core (shorten <$> local_def_value l),
   match ty with
   | `(o_minimal.sect %%Γ %%ty') := return ⟨ff, l, shorten ty', val⟩
   | _ := return ⟨tt, l, shorten ty, val⟩
   end

meta def decl_to_fmt (s : tactic_state) (crisp : bool) (vs : list expr)
  (ty : expr) (val : option expr) : format :=
let vs' := format.join $ (vs.map s.format_expr).intersperse " ",
    t := s.format_expr ty,
    sep := if crisp then "::" else ":" in
match val with
| (some val) := format! "{vs'} {sep} {t} := {s.format_expr val}"
| none := format! "{vs'} {sep} {t}"
end

meta def goal_to_fmt (g : expr) : defin (thunk format) :=
do set_goals [g],
   s ← read,
   `(o_minimal.definable_psh.definable (λ (_ : ↥%%Γ), %%body)) ← target
     | pure (λ _, to_fmt s),
   lc ← local_context,
   ctx_var ← tactic.interactive.guess_ctx_var,
   dat ← (lc.filter (λ l, l ≠ ctx_var)).mmap get_hyp_data,
   return $ λ _, format.intercalate format.line
     [format.intercalate ("," ++ format.line) $ dat.map $ λ d,
        decl_to_fmt s d.crisp [d.var] d.ty d.val,
      format! "⊢ {s.format_expr (shorten body)} def"]

meta def save_info (p : pos) : defin unit :=
do gs ← get_goals,
   fmt ← gs.mmap goal_to_fmt,
   set_goals gs,
   tactic.save_info_thunk p (λ _,
     let header := if fmt.length > 1 then format! "{fmt.length} goals\n" else "",
         eval : thunk format → format := λ f, f () in
     if fmt.empty
       then "no goals"
       else format.join ((fmt.map eval).intersperse (format.line ++ format.line)))

namespace interactive

meta def swap := tactic.interactive.swap
meta def exact := tactic.interactive.exact
meta def solve1 : defin unit → defin unit := tactic.interactive.solve1

meta def intro := tactic.interactive.defin_intro
meta def app := tactic.interactive.defin_app
meta def var := tactic.interactive.defin_var

meta def trace_state : defin unit :=
do s ← read,
   trace s.to_format

end interactive

end defin

namespace o_minimal

variables {R : Type*} {S : struc R}

local infixr ` ⊢ `:10 := sect

example : definable S (λ p q, (q ∧ p) ∧ q) :=
begin
  defin_start,
  defin_intro p,
  defin_intro q,
  defin_app,
  swap,
  { defin_var },
  defin_app,
  { exact definable_const definable_and },
  defin_app,
  { defin_app,
    { exact definable_const definable_and },
    defin_var },
  { defin_var },
end

example : definable S (λ p q, (q ∧ p) ∧ q) :=
begin [defin]
  intro p,
  intro q,
  app,
  swap,
  { var },
  app,
  { exact definable_const definable_and },
  app,
  { app,
    { exact definable_const definable_and },
    var },
  { var },
end

example : definable S and :=
begin [defin]
  intro p,
  intro q,
  exact struc.def_coords.inter p.definable q.definable
end

example {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z] : definable S (@function.curry X Y Z) :=
begin
  unfold function.curry,
  begin [defin]
    intro f,
    intro x,
    intro y,
    app, { var },
    exact ⟨x.definable, y.definable⟩
    /-
    app,
    app,
    exact definable_const definable_prod_mk,
    var,
    var, -/
  end
end

#exit

-- stuff after this uses pi type instances, which we don't need yet

variables {Y : Type*} [definable_psh S Y] (y : Y)

--set_option trace.class_instances true
example : definable S (λ (X : set Y) (h : nonempty X), true) :=
begin
  defin_start, rw ←definable_yoneda, -- TODO: combine these

  -- "intro X",
  rw definable_fun', intros Γ' π p,
  -- now we need to pull back any variables mentioning Γ
  -- to use Γ' -- there aren't any yet ✓
  -- since that's done, we can dispose of the old context
  clear π Γ,
  rename Γ' → Γ,

  -- "intro x",
  rw definable_fun', intros Γ' π, -- don't intro q just yet
  -- this time we need to deal with p
  have : ∀ d, p.to_fun (π.to_fun d) = (p.precomp π).to_fun d := λ d, rfl,
  simp only [this],
  generalize H : (p.precomp π) = p', clear this H p, rename p' → p,
  -- okay, now it's safe to intro q
  intro q,
  -- dispose of old context again
  clear π Γ,
  rename Γ' → Γ,

  -- we're done with intros!
end

end o_minimal


import tactic
import category_theory.functor
import data.W.basic
import category_theory.closed.types
import algebra.category.CommRing.basic
import algebra.category.Module.basic

universes w x u v

open category_theory

variables (𝒞 : Type u) [category.{v} 𝒞]

@[protect_proj] structure struc : Type (max u v (w+1) (x+1)) :=
( F : 𝒞 → Type w )
( hom : Π (A B : sigma F) (f : A.1 ⟶ B.1), Type x )
( id : Π (A : sigma F), Σ f : A.1 ⟶ A.1, hom A A f )
( id_fst' : Π (A : sigma F), (id A).fst = 𝟙 A.1 )
( comp : Π {A B C : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g),
    Σ h : A.1 ⟶ C.1, hom A C h )
( comp_fst' : Π {A B C : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g),
    (comp f g).fst = f.1 ≫ g.1)
( id_comp' : Π {A B : sigma F} (f : Σ f : A.1 ⟶ B.1, hom A B f),
    comp (id A) f = f )
( comp_id' : Π {A B : sigma F} (f : Σ f : A.1 ⟶ B.1, hom A B f),
    comp f (id B) = f )
( assoc' : Π {A B C D : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g)
    (h : Σ h : C.1 ⟶ D.1, hom C D h),
    comp (comp f g) h = comp f (comp g h) )

namespace struc

instance : has_coe_to_fun (struc 𝒞) (λ _, 𝒞 → Type w) :=
{ coe := struc.F }

variables {𝒞} {F : struc 𝒞}

@[simp] lemma id_comp {A B : sigma F} (f : Σ (f : A.fst ⟶ B.fst), F.hom A B f) :
  F.comp (F.id A) f = f := F.id_comp' _

@[simp] lemma comp_id {A B : sigma F} (f : Σ (f : A.fst ⟶ B.fst), F.hom A B f) :
  F.comp f (F.id B) = f := F.comp_id' _

@[simp] lemma assoc {A B C D : sigma F}
  (f : Σ f : A.1 ⟶ B.1, F.hom A B f)
  (g : Σ g : B.1 ⟶ C.1, F.hom B C g)
  (h : Σ h : C.1 ⟶ D.1, F.hom C D h):
  F.comp (F.comp f g) h = F.comp f (F.comp g h) :=
F.assoc' _ _ _

@[simp] lemma id_fst₁ (A : sigma F) : (F.id A).fst = 𝟙 A.1 := F.id_fst' _

@[simp] lemma comp_fst₁ {A B C : sigma F}
  (f : Σ f : A.1 ⟶ B.1, F.hom A B f)
  (g : Σ g : B.1 ⟶ C.1, F.hom B C g) :
  (F.comp f g).fst = f.1 ≫ g.1 := F.comp_fst' _ _

instance : category_struct (sigma F) :=
{ hom := λ A B, Σ (f : A.1 ⟶ B.1), F.hom A B f,
  id := F.id,
  comp := F.comp }

variable {F}

def sigma_category : category (sigma F) :=
{ id_comp' := F.id_comp',
  comp_id' := F.comp_id',
  assoc' := F.assoc' }

@[simp] lemma comp_fst {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).fst = f.1 ≫ g.1 := struc.comp_fst₁ f g

@[simp] lemma id_fst {A : sigma F} : sigma.fst (𝟙 A) = 𝟙 A.1 := struc.id_fst₁ _

instance (X : 𝒞) : category_struct (F X) :=
{ hom := λ A B, F.hom ⟨X, A⟩ ⟨X, B⟩ (𝟙 X),
  id := λ A, (F.id ⟨X, A⟩).snd,
  comp := λ A B C f g, begin
    have := (F.comp ⟨(F.id ⟨X, B⟩).fst, f⟩ _).snd,
  end }

lemma id_def {X : 𝒞} (x : F X) : 𝟙 x = F.id x := rfl

lemma comp_def (X : 𝒞) (A B C : F X) (f : A ⟶ B) (g : B ⟶ C) :
  f ≫ g = F.hom_iso (𝟙 X ≫ 𝟙 X) A C (𝟙 X) A C (iso.refl X) (iso.refl X)
    (by simp) (by simp) (by simp) (F.comp f g) := rfl

instance (X : 𝒞) : category (F X) :=
{ id_comp' := λ A B f, begin
      simp [id_def, comp_def],
      rw [← equiv.trans_apply, F.hom_iso_trans],
      simp
    end,
  comp_id' := λ A B f, begin
      simp [id_def, comp_def],
      rw [← equiv.trans_apply, F.hom_iso_trans],
      simp
    end,
  assoc' := λ A B C D f g h,
      begin
        simp only [comp_def, ← F.hom_iso_comp],
        erw F.hom_iso_comp,
      end }

def forget : sigma₂ F ⥤ 𝒞 :=
{ obj := sigma.fst,
  map := λ _ _, sigma.fst }

def thing (X : 𝒞) : F X ⥤ sigma₂ F :=
{ obj := λ A, ⟨X, A⟩,
  map := λ A B f, ⟨𝟙 X, f⟩,
  map_id' := λ A, rfl,
  map_comp' := λ A B C f g, sigma.ext
    (by simp) begin
      simp only [comp_snd],
      rw [struc.comp_eq_cast F f g (𝟙 X ≫ 𝟙 X) rfl (𝟙 X)
        (category.comp_id _)],
      symmetry,
      rw [← cast_eq_iff_heq],
      simp, refl,
      simp,
    end }

open opposite

protected def op (F : struc 𝒞) : struc 𝒞ᵒᵖ :=
{ F := λ A, F.F (unop A),
  hom := λ A B f a b, F.hom f.unop b a,
  id := λ A a, F.id a,
  comp := λ A B C a b c f g f' g' h hH,
    F.comp g' f' (by simp [← hH]),
  id_comp := λ A B f a b f', F.comp_id _,
  comp_id := λ A B f a b f', F.id_comp _,
  assoc := λ A B C D f g h a b c d f' g' h',
    by rw F.assoc_left; refl }

def unop (F : struc 𝒞ᵒᵖ) : struc 𝒞 :=
{ F := λ A, F.F (op A),
  hom := λ A B f a b, F.hom f.op b a,
  id := λ A a, F.id a,
  comp := λ A B C a b c f g f' g' h hH,
     F.comp g' f' (by simp [← hH]),
  id_comp := λ A B f a b f', F.comp_id _,
  comp_id := λ A B f a b f', F.id_comp _,
  assoc := λ A B C D f g h a b c d f' g' h',
    by rw F.assoc_left; refl }

def of_functor (F : 𝒞 ⥤ Type w) : struc 𝒞 :=
{ F := F.obj,
  hom := λ A B f a b, plift (F.map f a = b),
  id := λ A a, ⟨by simp⟩,
  comp := λ A B C a b c f g h₁ h₂ _ h, ⟨by simp [← h, F.map_comp, h₁.down, h₂.down]⟩,
  assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
    begin simp [h₁.down, h₂.down, h₃.down] end,
  id_comp := λ _ _ _ _ _ h,
    begin simp [h.down] end,
  comp_id := λ _ _ _ _ _ h,
    begin simp [h.down] end }

def Module₂ : struc Ring :=
{ F := λ R, Module R,
  hom := λ R S f M₁ M₂, M₁ →ₛₗ[f] M₂,
  id := λ R M, linear_map.id,
  comp := λ R S T M₁ M₂ M₃ f g f' g' _ h,
    @linear_map.comp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ⟨h⟩ g' f',
  id_comp := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl
    end,
  comp_id := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl,
    end,
  assoc := λ R S T U f g h M₁ M₂ M₃ M₄ f' g' h',
    begin
      cases f, cases g, cases h, cases f', cases g', cases h',
      refl
    end }

def pi.struc (F : 𝒞 ⥤ Type) (G : struc (sigma₂ (of_functor F))) : struc 𝒞 :=
{ F := λ X, Π a : F.obj X, G.F ⟨X, a⟩,
  hom := λ X Y f x y, Π (a : F.obj X),
    @struc.hom _ _ G ⟨X, a⟩ ⟨Y, F.map f a⟩ ⟨f, ⟨rfl⟩⟩ (x a) (y (F.map f a)),
  id := λ X x a, by convert (G.id (x a)); simp,
  comp := λ X Y Z x y z f g f' g' h H a,
    by convert struc.comp G (f' a) (g' (F.map f a)) rfl; subst H; simp,
  id_comp := λ X a, begin
    intros,
    ext,
    simp,

  end }

-- Maybe think about W.

end struc


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

/-!
# A type for VM-erased data

This file defines a type `erased α` which is classically isomorphic to `α`,
but erased in the VM. That is, at runtime every value of `erased α` is
represented as `0`, just like types and proofs.
-/

/-- `erased α` is the same as `α`, except that the elements
  of `erased α` are erased in the VM in the same way as types
  and proofs. This can be used to track data without storing it
  literally. -/
def erased (α : Sort u) := psigma fun (s : α → Prop) => ∃ (a : α), (fun (b : α) => a = b) = s

namespace erased

/-- Erase a value. -/
def mk {α : Sort u_1} (a : α) : erased α := psigma.mk (fun (b : α) => a = b) sorry

/-- Extracts the erased value, noncomputably. -/
def out {α : Sort u_1} : erased α → α := sorry

/--
Extracts the erased value, if it is a type.

Note: `(mk a).out_type` is not definitionally equal to `a`.
-/
def out_type (a : erased (Sort u)) := out a

/-- Extracts the erased value, if it is a proof. -/
theorem out_proof {p : Prop} (a : erased p) : p := out a

@[simp] theorem out_mk {α : Sort u_1} (a : α) : out (mk a) = a :=
  let h : ∃ (x : α), (fun (b : α) => x = b) = fun (b : α) => a = b := mk._proof_1 a;
  id (cast (Eq.symm (congr_fun (classical.some_spec h) a)) rfl)

@[simp] theorem mk_out {α : Sort u_1} (a : erased α) : mk (out a) = a := sorry

theorem out_inj {α : Sort u_1} (a : erased α) (b : erased α) (h : out a = out b) : a = b := sorry

/-- Equivalence between `erased α` and `α`. -/
def equiv (α : Sort u_1) : erased α ≃ α := equiv.mk out mk mk_out out_mk

protected instance has_repr (α : Type u) : has_repr (erased α) :=
  has_repr.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str
                (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

protected instance has_to_string (α : Type u) : has_to_string (erased α) :=
  has_to_string.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str
                (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

/-- Computably produce an erased value from a proof of nonemptiness. -/
def choice {α : Sort u_1} (h : Nonempty α) : erased α := mk (Classical.choice h)

@[simp] theorem nonempty_iff {α : Sort u_1} : Nonempty (erased α) ↔ Nonempty α := sorry

protected instance inhabited {α : Sort u_1} [h : Nonempty α] : Inhabited (erased α) :=
  { default := choice h }

/--
`(>>=)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `monad`).
-/
def bind {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) : erased β :=
  psigma.mk (fun (b : β) => psigma.fst (f (out a)) b) sorry

@[simp] theorem bind_eq_out {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) :
    bind a f = f (out a) :=
  sorry

/--
Collapses two levels of erasure.
-/
def join {α : Sort u_1} (a : erased (erased α)) : erased α := bind a id

@[simp] theorem join_eq_out {α : Sort u_1} (a : erased (erased α)) : join a = out a :=
  bind_eq_out a id

/--
`(<$>)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `functor`).
-/
def map {α : Sort u_1} {β : Sort u_2} (f : α → β) (a : erased α) : erased β := bind a (mk ∘ f)

@[simp] theorem map_out {α : Sort u_1} {β : Sort u_2} {f : α → β} (a : erased α) :
    out (map f a) = f (out a) :=
  sorry

protected instance monad : Monad erased :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := mk },
        toSeq :=
          { seq :=
              fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β α (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β β (map (function.const α id) a) b } },
    toBind := { bind := bind } }

@[simp] theorem pure_def {α : Type u_1} : pure = mk := rfl

@[simp] theorem bind_def {α : Type u_1} {β : Type u_1} : bind = bind := rfl

@[simp] theorem map_def {α : Type u_1} {β : Type u_1} : Functor.map = map := rfl

protected instance is_lawful_monad : is_lawful_monad erased := sorry

end Mathlib


import Architectural.ArchWithContracts

variables {Φ Var : Type} [fintype Var] [decidable_eq Var] [AssertionLang Φ Var]

def isCorrectDecompositionImpl
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
  : Prop :=
(∀ (S' : Component Var) (h : S' ∈ A.subs), (Is S' h).satisfiesContract (A.contracts.find_val S').iget)
   → (@CompositeImplementation Var _ _ _ _ S {..A} Is).satisfiesContract A.parent

def isCorrectDecompositionEnv
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) : Prop :=
∀ (S'' : Component Var) (h'': S'' ∈ A.subs) ,
(E.satisfiesContract A.parent ∧
(∀ (S' : Component Var) {S' ∈ A.subs.erase S''}, (Is S' (list.mem_of_mem_erase H)).satisfiesContract (A.contracts.find_val S').iget) →
(CompositeEnvironment A.to_Architecture S'' Is E).satisfiesContract (A.contracts.find_val S'').iget)

def isCorrectDecomposition
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :=
isCorrectDecompositionImpl A Is ∧
isCorrectDecompositionEnv A Is E

namespace Claim

def correctDecompositionImpl
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is :Implementations A.to_Architecture)
(σ : Trace Var) : Prop :=
(∀ (S' : Component Var) {S' ∈ A.subs}, ∀ σ',(σ' ∈ (Is S' H) ∧
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.A))) →
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.G))) → ( (σ ∈ (@CompositeImplementation Var _ _ _ _ S ↑A Is) ∧ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.A))) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.G)))

-- example {C : Contract Φ Var} {σ : Trace Var}  :
-- (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.A)) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.G))
-- ↔ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.nf)) :=
-- begin
--   split,
--   intro H,
--   rw AssertionLang.disj_def,
--   rw AssertionLang.compl_def,
--   simp,
--   rw ← imp_iff_not_or, exact H,
--    intro H,
--   rw AssertionLang.disj_def at H,
--   rw AssertionLang.compl_def at H,
--   simp at H,
--   rw ← imp_iff_not_or at H, exact H,
-- end

def correctDecompositionImpl'
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is :Implementations A.to_Architecture)
(σ : Trace Var) : Prop :=
(∀ (S' : Component Var) {S' ∈ A.subs}, ∀ σ',(σ' ∈ (Is S' H) ∧
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.A))) →
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.G))) →
( (σ ∈ (@CompositeImplementation Var _ _ _ _ S ↑A Is) ∧ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.A))) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.G)))

def correctDecompositionEnv
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is :Implementations A.to_Architecture)
(E : Env Var) (σ : Trace Var) : Prop :=
∀ (S'' : Component Var) {S'' ∈ A.subs},
E.satisfiesContract A.parent →
(∀ (S' : Component Var) {S' ∈ A.subs.erase S''}, (Is S' (list.mem_of_mem_erase H)).satisfiesContract (A.contracts.find_val S').iget) →
(σ ∈ (CompositeEnvironment A.to_Architecture S'' Is E)) → σ ∈ (@AssertionLang.sem Φ Var _ _ _ ((A.contracts.find_val S'').iget).A)

def correctDecomposition
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is : Implementations A.to_Architecture)
(E : Env Var) : Claim (Trace Var) :=
{
  X := set.univ,
  P :=
  λ σ, correctDecompositionImpl A Is σ ∧ correctDecompositionEnv A Is E σ
}

end Claim
-- def correctDecompositionImplProperty
-- (A : ArchWithContracts S)
-- (Is : Implementations A)  : Property (Trace Var) := λ σ,
-- (∀ (S' : Component Var) {S' ∈ A.subs},
--     (∀ σ', σ' ∈ (Is S' H) ∧ σ' ∈ $\llparenthesis$(A.contracts.get S').A$\rrparenthesis$
--   → (σ' ∈ $\llparenthesis$(A.contracts.get S').G$\rrparenthesis$))
-- → ((σ ∈ CompositeImplementation A Is ∧ σ ∈ $\llparenthesis$S.C.A$\rrparenthesis$)
-- → σ ∈ $\llparenthesis$S.C.G$\rrparenthesis$)

-- def correctDecompositionEnvProperty
-- {S : ComponentWithContract Φ Var}
-- (A : ArchWithContracts S)
-- (Is :Implementations A)
-- (E : Env Var)  : Property (Trace Var) :=λ σ,
-- ∀ (S'' : Component Var),
--   E.satisfiesContract S.C →
--   (∀ (S' : Component Var) {S' ∈ A.subs},
--   (Is S' H).satisfies (A.contracts.get S')) →
--  (σ ∈ CompositeEnvironment A S'' Is E) →
--  σ ∈ {{((A.contracts.get S'')).A}}
theorem
claim_imp_correctDecomp
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
⟦Claim.correctDecomposition A Is E⟧ → isCorrectDecomposition A Is E :=
begin
  intro clm,
  rw meaning at clm, split, {
    intro h,
    intro s,
    replace clm := clm s,
    rw [Claim.correctDecomposition] at clm,
    simp at clm, replace clm := clm.1,
    intro h',
    cases h' with h₂ h₃,
    rw Claim.correctDecompositionImpl at clm,
    apply clm,
    intros S' S'' hMem,
    replace h := h S'',
    rw Impl.satisfiesContract at h,
    rw CompositeImplementation at h₂, simp at h₂,
    intro h'', apply h,split, exact h₂,
    exact h₃,
  },
  {
    rintros S'' h₄ ⟨h₅, h₆⟩ s,
    replace clm := clm s, rw [Claim.correctDecomposition] at clm,
    simp at clm, replace clm := clm.2 S'' h₅ h₆, exact clm,
    rw Claim.correctDecompositionEnv at clm, assumption,
}
end

theorem decompCorrectImpClaim
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
isCorrectDecomposition A Is E →
⟦Claim.correctDecomposition A Is  E⟧ :=
begin
  intro h,
  rw Claim.correctDecomposition, rw meaning, simp,
  rw forall_and_distrib,
  split,
  {
    intro s,
    rw Claim.correctDecompositionImpl,
    revert s,simp,
    replace h := h.1,
    rw isCorrectDecompositionImpl at h,
    intros σ' h₂ h₃,
    rw CompositeImplementation at h₃,
    intros h₄,
    rw Impl.satisfiesContract at h,
    simp at h,
    apply h,
    intros S' h',
    replace h₂ := h₂ S' h',
    intros σ h₅, cases h₅ with L R,
    replace h₂ := h₂ σ L R, simp,
    apply h₂,split, rw CompositeImplementation, apply h₃, assumption,
  },
  {
    intros σ, intros _, intros S'' mem,
    replace h := h.2,
    rw isCorrectDecompositionEnv at h,
    simp at h,
    replace h := h S'' mem,
    intros s smem, rw Env.satisfiesContract at h,
    simp at h,
    apply h,
    intros h₂, apply s, exact smem,
  }

end

theorem decompositionCorrectAsClaim
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
isCorrectDecomposition A Is E ↔ ⟦Claim.correctDecomposition A Is E⟧ :=
iff.intro (decompCorrectImpClaim A Is  E) (claim_imp_correctDecomp A Is  E)


import for_mathlib.category_theory.localization.predicate

noncomputable theory

open category_theory category_theory.category

namespace category_theory

namespace morphism_property

namespace is_inverted_by

/-
lemma op {C D : Type*} [category C] [category D]
  {W : morphism_property C} {L : C ⥤ D} (h : W.is_inverted_by L) :
  W.op.is_inverted_by L.op := λ X Y f hf,
by { haveI := h f.unop hf, dsimp, apply_instance, }

lemma right_op {C D : Type*} [category C] [category D]
  {W : morphism_property C} {L : Cᵒᵖ ⥤ D} (h : W.op.is_inverted_by L):
  W.is_inverted_by L.right_op := λ X Y f hf,
by { haveI := h f.op hf, dsimp, apply_instance, }-/

end is_inverted_by

end morphism_property

variables {C D : Type*} [category C] [category D] {L : C ⥤ D}
  {W : morphism_property C}

namespace localization

def strict_universal_property_fixed_target.op {E : Type*} [category E]
  (h : strict_universal_property_fixed_target L W Eᵒᵖ):
  strict_universal_property_fixed_target L.op W.op E :=
{ inverts := h.inverts.op,
  lift := λ F hF, (h.lift F.right_op hF.right_op).left_op,
  fac := λ F hF, begin
    convert congr_arg functor.left_op (h.fac F.right_op hF.right_op),
    exact F.right_op_left_op_eq.symm,
  end,
  uniq := λ F₁ F₂ eq, begin
    suffices : F₁.right_op = F₂.right_op,
    { rw [← F₁.right_op_left_op_eq, ← F₂.right_op_left_op_eq, this], },
    have eq' := congr_arg functor.right_op eq,
    exact h.uniq _ _ eq',
  end, }

instance is_localization_op : W.Q.op.is_localization W.op :=
functor.is_localization.mk' W.Q.op W.op
  (strict_universal_property_fixed_target_Q W _).op
  (strict_universal_property_fixed_target_Q W _).op

end localization

namespace functor

variables (L W)

instance is_localization.op [h : L.is_localization W] : L.op.is_localization W.op :=
is_localization.of_equivalence_target W.Q.op W.op L.op (localization.equivalence_from_model L W).op
  (nat_iso.op (localization.Q_comp_equivalence_from_model_functor_iso L W).symm)

end functor

end category_theory