/- Observable events, execution traces, and semantics of external calls. -/

import .globalenvs .memory

namespace events
open integers word floats ast globalenvs values memory
     ast.typ memory.perm_kind

/- * Events and traces -/

/- The observable behaviour of programs is stated in terms of
  input/output events, which represent the actions of the program
  that the external world can observe.  CompCert leaves much flexibility as to
  the exact content of events: the only requirement is that they
  do not expose memory states nor pointer values
  (other than pointers to global variables), because these
  are not preserved literally during compilation.  For concreteness,
  we use the following type for events.  Each event represents either:

- A system call (e.g. an input/output operation), recording the
  name of the system call, its parameters, and its result.

- A volatile load from a global memory location, recording the chunk
  and address being read and the value just read.

- A volatile store to a global memory location, recording the chunk
  and address being written and the value stored there.

- An annotation, recording the text of the annotation and the values
  of the arguments.

  The values attached to these events are of the following form.
  As mentioned above, we do not expose pointer values directly.
  Pointers relative to a global variable are shown with the name
  of the variable instead of the block identifier.
-/

inductive eventval : Type
| EVint        : int32 → eventval
| EVlong       : int64 → eventval
| EVfloat      : float → eventval
| EVsingle     : float32 → eventval
| EVptr_global : ident → ptrofs → eventval
open eventval

inductive event : Type
| syscall : string → list eventval → eventval → event
| vload   : memory_chunk → ident → ptrofs → eventval → event
| vstore  : memory_chunk → ident → ptrofs → eventval → event
| annot   : string → list eventval → event

/- * Relating values and event values -/

namespace eventval

def type : eventval → typ
| (EVint _)          := Tint
| (EVlong _)         := Tlong
| (EVfloat _)        := Tfloat
| (EVsingle _)       := Tsingle
| (EVptr_global _ _) := Tptr

/- Symbol environment used to translate between global variable names and their block identifiers. -/

section
variable (ge : Senv)

/- Translation between values and event values. -/

def to_val : eventval → option val
| (EVint i)             := some (Vint i)
| (EVlong i)            := some (Vlong i)
| (EVfloat f)           := some (Vfloat f)
| (EVsingle f)          := some (Vsingle f)
| (EVptr_global id ofs) :=
  do guard (Senv.public_symbol ge id),
     b ← Senv.find_symbol ge id,
     return (Vptr b ofs)

def matchv (ev : eventval) (t : typ) (v : val) : Prop :=
ev.type = t ∧ ev.to_val ge = some v

def list_match (evl : list eventval) (tl : list typ) (vl : list val) : Prop :=
evl.map type = tl ∧ mmap (to_val ge) evl = some vl

/- Some properties of these translation predicates. -/

lemma match_type {ev ty v} : matchv ge ev ty v → val.has_type v ty := sorry'

lemma match_lessdef {ev ty v1 v2} :
  matchv ge ev ty v1 → val.lessdef v1 v2 → matchv ge ev ty v2 := sorry'

lemma list_match_lessdef {evl tyl vl1} :
  list_match ge evl tyl vl1 →
  ∀ vl2, list.forall2 val.lessdef vl1 vl2 → list_match ge evl tyl vl2 := sorry'

/- Determinism -/

lemma match_determ_1 {ev ty v1 v2} :
  matchv ge ev ty v1 → matchv ge ev ty v2 → v1 = v2 := sorry'

lemma match_determ_2 {ev1 ev2 ty v} :
  matchv ge ev1 ty v → matchv ge ev2 ty v → ev1 = ev2 := sorry'

lemma list_match_determ_2 {evl1 tyl vl} :
  list_match ge evl1 tyl vl →
  ∀ evl2, list_match ge evl2 tyl vl → evl1 = evl2 := sorry'

/- Validity -/

def valid : eventval → bool
| (EVptr_global id ofs) := Senv.public_symbol ge id
| _                     := tt

lemma match_receptive {ev1 ty v1 ev2} :
  matchv ge ev1 ty v1 →
  valid ge ev1 → valid ge ev2 → type ev1 = type ev2 →
  ∃ v2, matchv ge ev2 ty v2 := sorry'

lemma match_valid {ev ty v} :
  matchv ge ev ty v → valid ge ev := sorry'

lemma match_same_type {ev1 ty v1 ev2 v2} :
  matchv ge ev1 ty v1 → matchv ge ev2 ty v2 → type ev1 = type ev2 := sorry'

end
end eventval

/- Invariance under changes to the global environment -/

section eventval_inv

parameters {ge1 ge2 : Senv}
parameter (public_preserved : ∀ id,
  Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)

lemma eventval_valid_preserved {ev} :
  eventval.valid ge1 ev → eventval.valid ge2 ev := sorry'

parameter (symbols_preserved : ∀ id,
  Senv.find_symbol ge2 id = Senv.find_symbol ge1 id)

lemma eventval_match_preserved {ev ty v} :
  eventval.matchv ge1 ev ty v → eventval.matchv ge2 ev ty v := sorry'

lemma eventval_list_match_preserved :
  ∀ evl tyl vl,
  eventval.list_match ge1 evl tyl vl → eventval.list_match ge2 evl tyl vl := sorry'

end eventval_inv

/- Compatibility with memory injections -/

section eventval_inject

parameter (f : block → option (block × ℤ))
parameters (ge1 ge2 : Senv)

def symbols_inject : Prop :=
   (∀ id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)
∧ (∀ id b1 b2 delta,
     f b1 = some (b2, delta) → Senv.find_symbol ge1 id = some b1 →
     delta = 0 ∧ Senv.find_symbol ge2 id = some b2)
∧ (∀ id b1,
     Senv.public_symbol ge1 id = tt → Senv.find_symbol ge1 id = some b1 →
     ∃ b2, f b1 = some (b2, 0) ∧ Senv.find_symbol ge2 id = some b2)
∧ (∀ b1 b2 delta,
     f b1 = some (b2, delta) →
     Senv.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1)

parameter symb_inj : symbols_inject

lemma eventval_match_inject {ev ty v1 v2} :
  eventval.matchv ge1 ev ty v1 → val.inject f v1 v2 → eventval.matchv ge2 ev ty v2 := sorry'

lemma eventval_match_inject_2 :
  ∀ ev ty v1,
  eventval.matchv ge1 ev ty v1 →
  ∃ v2, eventval.matchv ge2 ev ty v2 ∧ val.inject f v1 v2 := sorry'

lemma eventval_list_match_inject {evl tyl vl1} :
  eventval.list_match ge1 evl tyl vl1 →
  ∀ vl2, list.forall2 (val.inject f) vl1 vl2 → eventval.list_match ge2 evl tyl vl2 := sorry'

end eventval_inject

/- * Matching traces. -/

section match_traces

parameter ge : Senv

/- Matching between traces corresponding to single transitions.
  Arguments (provided by the program) must be equal.
  Results (provided by the outside world) can vary as long as they
  can be converted safely to values. -/

def match_events : event → event → Prop
| (event.syscall id args res1)    (event.syscall id' args' res2)      :=
  id = id' ∧ args = args' ∧ res1.valid ge ∧ res2.valid ge ∧ res1.type = res2.type
| (event.vload chunk id ofs res1) (event.vload chunk' id' ofs' res2)  :=
  chunk = chunk' ∧ id = id' ∧ ofs = ofs' ∧ res1.valid ge ∧ res2.valid ge ∧ res1.type = res2.type
| (event.vstore chunk id ofs arg) (event.vstore chunk' id' ofs' arg') :=
  chunk = chunk' ∧ id = id' ∧ ofs = ofs' ∧ arg = arg'
| (event.annot id args)           (event.annot id' args')             :=
  id = id' ∧ args = args'
| _                               _                                   := false

inductive match_traces : list event → list event → Prop
| nil : match_traces [] []
| evt (e1 e2) : match_events e1 e2 → match_traces [e1] [e2]

end match_traces

/- Invariance by change of global environment -/

lemma match_traces_preserved {ge1 ge2}
  (public_preserved : ∀ id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id)
  {t1 t2} : match_traces ge1 t1 t2 → match_traces ge2 t1 t2 := sorry'

/- An output trace is a trace composed only of output events,
  that is, events that do not take any result from the outside world. -/

def output_event : event → bool
| (event.vstore _ _ _ _) := tt
| (event.annot _ _)      := tt
| _                      := ff

def output_trace (t : list event) : bool := t.all output_event

/- * Semantics of external functions -/

/- For each external function, its behavior is defined by a predicate relating:
- the global symbol environment
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).
-/

def extcall_sem : Type := Senv → list val → mem → list event → val → mem → Prop

/- We now specify the expected properties of this predicate. -/

def loc_out_of_bounds (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ¬ perm m b ofs Max Nonempty

def loc_not_writable (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ¬ perm m b ofs Max Writable

def loc_unmapped (f : meminj) (b : block) (ofs : ℕ) : Prop :=
  f b = none

def loc_out_of_reach (f : meminj) (m : mem) (b : block) (ofs : ℕ) : Prop :=
  ∀ b0 delta,
  f b0 = some (b, delta) → ¬ perm_Z m b0 (ofs - delta) Max Nonempty

def inject_separated (f f' : meminj) (m1 m2 : mem) : Prop :=
  ∀ b1 b2 delta,
  f b1 = none → f' b1 = some (b2, delta) →
  ¬ valid_block m1 b1 ∧ ¬ valid_block m2 b2

structure extcall_properties (sem : extcall_sem) (sg : signature) : Prop :=
/- The return value of an external call must agree with its signature. -/
(well_typed :
  ∀ ge vargs m1 t vres m2,
  sem ge vargs m1 t vres m2 →
  vres.has_type (proj_sig_res sg))

/- The semantics is invariant under change of global environment that preserves symbols. -/
(symbols_preserved :
  ∀ ge1 ge2 vargs m1 t vres m2,
  Senv.equiv ge1 ge2 →
  sem ge1 vargs m1 t vres m2 →
  sem ge2 vargs m1 t vres m2)

/- External calls cannot invalidate memory blocks.  (Remember that
  freeing a block does not invalidate its block identifier.) -/
(valid_block :
  ∀ ge vargs m1 t vres m2 b,
  sem ge vargs m1 t vres m2 →
  valid_block m1 b → valid_block m2 b)

/- External calls cannot increase the max permissions of a valid block.
    They can decrease the max permissions, e.g. by freeing. -/
(max_perm :
  ∀ ge vargs m1 t vres m2 b ofs p,
  sem ge vargs m1 t vres m2 →
  memory.valid_block m1 b → perm m2 b ofs Max p → perm m1 b ofs Max p)

/- External call cannot modify memory unless they have [Max, Writable]
   permissions. -/
(readonly :
  ∀ ge vargs m1 t vres m2,
  sem ge vargs m1 t vres m2 →
  unchanged_on (loc_not_writable m1) m1 m2)

/- External calls must commute with memory extensions, in the
  following sense. -/
(mem_extends :
  ∀ ge vargs m1 t vres m2 m1' vargs',
  sem ge vargs m1 t vres m2 →
  extends' m1 m1' →
  list.forall2 lessdef vargs vargs' →
  ∃ vres', ∃ m2',
      sem ge vargs' m1' t vres' m2'
  ∧ lessdef vres vres'
  ∧ extends' m2 m2'
  ∧ unchanged_on (loc_out_of_bounds m1) m1' m2')

/- External calls must commute with memory injections,
  in the following sense. -/
(mem_inject :
  ∀ ge1 ge2 vargs m1 t vres m2 f m1' vargs',
  symbols_inject f ge1 ge2 →
  sem ge1 vargs m1 t vres m2 →
  inject f m1 m1' →
  list.forall2 (val.inject f) vargs vargs' →
  ∃ f', ∃ vres', ∃ m2',
      sem ge2 vargs' m1' t vres' m2'
  ∧ inject f' vres vres'
  ∧ inject f' m2 m2'
  ∧ unchanged_on (loc_unmapped f) m1 m2
  ∧ unchanged_on (loc_out_of_reach f m1) m1' m2'
  ∧ inject_incr f f'
  ∧ inject_separated f f' m1 m1')

/- External calls produce at most one event. -/
(trace_length :
  ∀ ge vargs m t vres m',
  sem ge vargs m t vres m' → t.length ≤ 1)

/- External calls must be receptive to changes of traces by another, matching trace. -/
(receptive :
  ∀ ge vargs m t1 vres1 m1 t2,
  sem ge vargs m t1 vres1 m1 → match_traces ge t1 t2 →
  ∃ vres2 m2, sem ge vargs m t2 vres2 m2)

/- External calls must be deterministic up to matching between traces. -/
(determ :
  ∀ ge vargs m t1 vres1 m1 t2 vres2 m2,
  sem ge vargs m t1 vres1 m1 → sem ge vargs m t2 vres2 m2 →
  match_traces ge t1 t2 ∧ (t1 = t2 → vres1 = vres2 ∧ m1 = m2))

/- * Semantics of volatile memory accesses -/

inductive volatile_load (ge) (chunk : memory_chunk) (m b ofs) :
    list event → val → Prop
| volatile_load_vol (id ev v) :
    Senv.block_is_volatile ge b = tt →
    Senv.find_symbol ge id = some b →
    eventval.matchv ge ev chunk.type v →
    volatile_load [event.vload chunk id ofs ev] (load_result chunk v)
| volatile_load_nonvol (v) :
    Senv.block_is_volatile ge b = ff →
    load chunk m b (unsigned ofs) = some v →
    volatile_load [] v

inductive volatile_store (ge) (chunk : memory_chunk) (m b ofs v) :
    list event → mem → Prop
| volatile_store_vol (id ev) :
    Senv.block_is_volatile ge b = tt →
    Senv.find_symbol ge id = some b →
    eventval.matchv ge ev chunk.type (load_result chunk v) →
    volatile_store [event.vstore chunk id ofs ev] m
| volatile_store_nonvol (m') :
    Senv.block_is_volatile ge b = ff →
    store chunk m b (unsigned ofs) v = some m' →
    volatile_store [] m'

/- ** Semantics of volatile loads -/

inductive volatile_load_sem (chunk : memory_chunk) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (b ofs m t v) :
  volatile_load ge chunk m b ofs t v →
  volatile_load_sem [Vptr b ofs] m t v m.

lemma volatile_load_preserved {ge1 ge2 chunk m b ofs t v} :
  Senv.equiv ge1 ge2 →
  volatile_load ge1 chunk m b ofs t v →
  volatile_load ge2 chunk m b ofs t v := sorry'

lemma volatile_load_extends {ge chunk m b ofs t v m'} :
  volatile_load ge chunk m b ofs t v →
  extends' m m' →
  ∃ v', volatile_load ge chunk m' b ofs t v' ∧ lessdef v v' := sorry'

lemma volatile_load_inject {ge1 ge2 f chunk m b ofs t v b' ofs' m'} :
  symbols_inject f ge1 ge2 →
  volatile_load ge1 chunk m b ofs t v →
  inject f (Vptr b ofs) (Vptr b' ofs') →
  inject f m m' →
  ∃ v', volatile_load ge2 chunk m' b' ofs' t v' ∧ inject f v v' := sorry'

lemma volatile_load_receptive {ge chunk m b ofs t1 t2 v1} :
  volatile_load ge chunk m b ofs t1 v1 → match_traces ge t1 t2 →
  ∃ v2, volatile_load ge chunk m b ofs t2 v2 := sorry'

lemma volatile_load_ok {chunk} :
  extcall_properties (volatile_load_sem chunk)
  ⟨[Tptr], some chunk.type, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of volatile stores -/

inductive volatile_store_sem (chunk : memory_chunk) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (b ofs m1 v t m2) :
  volatile_store ge chunk m1 b ofs v t m2 →
  volatile_store_sem [Vptr b ofs, v] m1 t Vundef m2.

lemma volatile_store_preserved {ge1 ge2 chunk m1 b ofs v t m2} :
  Senv.equiv ge1 ge2 →
  volatile_store ge1 chunk m1 b ofs v t m2 →
  volatile_store ge2 chunk m1 b ofs v t m2 := sorry'

lemma volatile_store_readonly {ge chunk1 m1 b1 ofs1 v t m2} :
  volatile_store ge chunk1 m1 b1 ofs1 v t m2 →
  unchanged_on (loc_not_writable m1) m1 m2 := sorry'

lemma volatile_store_extends {ge chunk m1 b ofs v t m2 m1' v'} :
  volatile_store ge chunk m1 b ofs v t m2 →
  extends' m1 m1' →
  lessdef v v' →
  ∃ m2',
     volatile_store ge chunk m1' b ofs v' t m2'
  ∧ extends' m2 m2'
  ∧ unchanged_on (loc_out_of_bounds m1) m1' m2' := sorry'

lemma volatile_store_inject {ge1 ge2 f chunk m1 b ofs v t m2 m1' b' ofs' v'} :
  symbols_inject f ge1 ge2 →
  volatile_store ge1 chunk m1 b ofs v t m2 →
  inject f (Vptr b ofs) (Vptr b' ofs') →
  inject f v v' →
  inject f m1 m1' →
  ∃ m2',
       volatile_store ge2 chunk m1' b' ofs' v' t m2'
    ∧ inject f m2 m2'
    ∧ unchanged_on (loc_unmapped f) m1 m2
    ∧ unchanged_on (loc_out_of_reach f m1) m1' m2' := sorry'

lemma volatile_store_receptive {ge chunk m b ofs v t1 m1 t2} :
  volatile_store ge chunk m b ofs v t1 m1 → match_traces ge t1 t2 → t1 = t2 := sorry'

lemma volatile_store_ok {chunk} :
  extcall_properties (volatile_store_sem chunk) ⟨[Tptr, chunk.type], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of dynamic memory allocation (malloc) -/

inductive extcall_malloc_sem (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (sz : ptrofs) (m m' : mem) :
  store Mptr (m.alloc 0 (unsigned sz + Mptr.size)) m.nextblock 0 (Vptrofs sz) = some m' →
  extcall_malloc_sem [Vptrofs sz] m [] (Vptr m.nextblock Mptr.size) m'

lemma extcall_malloc_ok :
  extcall_properties extcall_malloc_sem ⟨[Tptr], some Tptr, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of dynamic memory deallocation (free) -/

inductive extcall_free_sem (ge : Senv) :
              list val → mem → list event → val → mem → Prop
| mk (b) (lo : ptrofs) (sz m m') :
  load Mptr m b (unsigned lo - Mptr.size) = some (Vptrofs sz) →
  unsigned sz > 0 →
  free m b (unsigned lo - Mptr.size) (unsigned lo + unsigned sz) = some m' →
  extcall_free_sem [Vptr b lo] m [] Vundef m'

lemma extcall_free_ok :
  extcall_properties extcall_free_sem ⟨[Tptr], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of [memcpy] operations. -/

inductive extcall_memcpy_sem (sz al : ℕ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (bdst bsrc) (odst osrc : ptrofs) (m bytes m') :
  al = 1 ∨ al = 2 ∨ al = 4 ∨ al = 8 → al ∣ sz →
  (sz > 0 → al ∣ unsigned osrc ∧ al ∣ unsigned odst) →
  bsrc ≠ bdst ∨ unsigned osrc = unsigned odst
                ∨ unsigned osrc + sz ≤ unsigned odst
                ∨ unsigned odst + sz ≤ unsigned osrc →
  load_bytes m bsrc (unsigned osrc) sz = some bytes →
  store_bytes m bdst (unsigned odst) bytes = some m' →
  extcall_memcpy_sem [Vptr bdst odst, Vptr bsrc osrc] m [] Vundef m'

lemma extcall_memcpy_ok (sz al) :
  extcall_properties (extcall_memcpy_sem sz al) ⟨[Tptr, Tptr], none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of annotations. -/

inductive extcall_annot_sem (text : string) (targs : list typ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (vargs m args) : eventval.list_match ge args targs vargs →
  extcall_annot_sem vargs m [event.annot text args] Vundef m

lemma extcall_annot_ok (text targs) :
  extcall_properties (extcall_annot_sem text targs) ⟨targs, none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

inductive extcall_annot_val_sem (text : string) (targ : typ) (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (varg m arg) :
  eventval.matchv ge arg targ varg →
  extcall_annot_val_sem [varg] m [event.annot text [arg]] varg m

lemma extcall_annot_val_ok (text targ) :
  extcall_properties (extcall_annot_val_sem text targ) ⟨[targ], some targ, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

inductive extcall_debug_sem (ge : Senv) :
  list val → mem → list event → val → mem → Prop
| mk (vargs m) : extcall_debug_sem vargs m [] Vundef m

lemma extcall_debug_ok (targs) :
  extcall_properties extcall_debug_sem ⟨targs, none, cc_default⟩ :=
{ well_typed        := sorry',
  symbols_preserved := sorry',
  valid_block       := sorry',
  max_perm          := sorry',
  readonly          := sorry',
  mem_extends       := sorry',
  mem_inject        := sorry',
  trace_length      := sorry',
  receptive         := sorry',
  determ            := sorry' }

/- ** Semantics of external functions. -/

/- For functions defined outside the program ([EF_external],
  [EF_builtin] and [EF_runtime]), we do not define their
  semantics, but only assume that it satisfies
  [extcall_properties]. -/

constant external_functions_sem : string → signature → extcall_sem

constant external_functions_properties {id sg} :
  extcall_properties (external_functions_sem id sg) sg

/- We treat inline assembly similarly. -/

constant inline_assembly_sem : string → signature → extcall_sem

constant inline_assembly_properties {id sg} :
  extcall_properties (inline_assembly_sem id sg) sg

/- ** Combined semantics of external calls -/

/- Combining the semantics given above for the various kinds of external calls,
  we define the predicate [external_call] that relates:
- the external function being invoked
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).

This predicate is used in the semantics of all CompCert languages. -/

noncomputable def external_call : external_function → extcall_sem
| (EF_external name sg)      := external_functions_sem name sg
| (EF_builtin name sg)       := external_functions_sem name sg
| (EF_runtime name sg)       := external_functions_sem name sg
| (EF_vload chunk)           := volatile_load_sem chunk
| (EF_vstore chunk)          := volatile_store_sem chunk
| EF_malloc                  := extcall_malloc_sem
| EF_free                    := extcall_free_sem
| (EF_memcpy sz al)          := extcall_memcpy_sem sz al
| (EF_annot txt targs)       := extcall_annot_sem txt targs
| (EF_annot_val txt targ)    := extcall_annot_val_sem txt targ
| (EF_inline_asm txt sg clb) := inline_assembly_sem txt sg
| (EF_debug kind txt targs)  := extcall_debug_sem

theorem external_call_spec (ef) :
  extcall_properties (external_call ef) (ef_sig ef) := sorry'

def external_call_well_typed        (ef) := (external_call_spec ef).well_typed
def external_call_symbols_preserved (ef) := (external_call_spec ef).symbols_preserved
def external_call_valid_block       (ef) := (external_call_spec ef).valid_block
def external_call_max_perm          (ef) := (external_call_spec ef).max_perm
def external_call_readonly          (ef) := (external_call_spec ef).readonly
def external_call_mem_extends       (ef) := (external_call_spec ef).mem_extends
def external_call_mem_inject_gen    (ef) := (external_call_spec ef).mem_inject
def external_call_trace_length      (ef) := (external_call_spec ef).trace_length
def external_call_receptive         (ef) := (external_call_spec ef).receptive
def external_call_determ            (ef) := (external_call_spec ef).determ

/- Corollary of [external_call_valid_block]. -/

lemma external_call_nextblock (ef ge vargs m1 t vres m2) :
  external_call ef ge vargs m1 t vres m2 →
  m1.nextblock ≤ m2.nextblock := sorry'

/- Special case of [external_call_mem_inject_gen] (for backward compatibility) -/

def meminj_preserves_globals {F V} (ge : Genv F V) (f : block → option (block × ℤ)) : Prop :=
     (∀ id b, Genv.find_symbol ge id = some b → f b = some (b, 0))
  ∧ (∀ b gv, Genv.find_var_info ge b = some gv → f b = some (b, 0))
  ∧ (∀ b1 b2 delta gv, Genv.find_var_info ge b2 = some gv → f b1 = some (b2, delta) → b2 = b1)

lemma external_call_mem_inject {ef F V} {ge : Genv F V} {vargs m1 t vres m2 f m1' vargs'} :
  meminj_preserves_globals ge f →
  external_call ef ge vargs m1 t vres m2 →
  inject f m1 m1' →
  list.forall2 (val.inject f) vargs vargs' →
  ∃ f' vres' m2',
     external_call ef ge vargs' m1' t vres' m2'
    ∧ inject f' vres vres'
    ∧ inject f' m2 m2'
    ∧ unchanged_on (loc_unmapped f) m1 m2
    ∧ unchanged_on (loc_out_of_reach f m1) m1' m2'
    ∧ inject_incr f f'
    ∧ inject_separated f f' m1 m1' := sorry'

/- Corollaries of [external_call_determ]. -/

lemma external_call_match_traces {ef ge vargs m t1 vres1 m1 t2 vres2 m2} :
  external_call ef ge vargs m t1 vres1 m1 →
  external_call ef ge vargs m t2 vres2 m2 →
  match_traces ge t1 t2 := sorry'

lemma external_call_deterministic {ef ge vargs m t vres1 m1 vres2 m2} :
  external_call ef ge vargs m t vres1 m1 →
  external_call ef ge vargs m t vres2 m2 →
  vres1 = vres2 ∧ m1 = m2 := sorry'

/- * Evaluation of builtin arguments -/

section eval_builtin_arg

parameters {A : Type} (ge : Senv) (e : A → val) (sp : val) (m : mem)

def eval_builtin_arg : builtin_arg A → option val
| (BA x) := some (e x)
| (BA_int n) := some (Vint n)
| (BA_long n) := some (Vlong n)
| (BA_float n) := some (Vfloat n)
| (BA_single n) := some (Vsingle n)
| (BA_loadstack chunk ofs) := loadv chunk m (offset_ptr sp ofs)
| (BA_addrstack ofs) := some (offset_ptr sp ofs)
| (BA_loadglobal chunk id ofs) := loadv chunk m (Senv.symbol_address ge id ofs)
| (BA_addrglobal id ofs) := some (Senv.symbol_address ge id ofs)
| (BA_splitlong hi lo) :=
  do vhi ← eval_builtin_arg hi,
     vlo ← eval_builtin_arg lo,
     return (long_of_words vhi vlo)

def eval_builtin_args (al : list (builtin_arg A)) : option (list val) :=
mmap eval_builtin_arg al

end eval_builtin_arg

/- Invariance by change of global environment. -/

section eval_builtin_arg_preserved

parameters {A F1 V1 F2 V2 : Type} {ge1 : Genv F1 V1} {ge2 : Genv F2 V2}
           (e : A → val) (sp : val) (m : mem)

parameter (symbols_preserved : ∀ id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id)

lemma eval_builtin_arg_preserved {a v} :
  eval_builtin_arg ge1 e sp m a = some v → eval_builtin_arg ge2 e sp m a = some v := sorry'

lemma eval_builtin_args_preserved {al vl} :
  eval_builtin_args ge1 e sp m al = some vl → eval_builtin_args ge2 e sp m al = some vl := sorry'

end eval_builtin_arg_preserved

/- Compatibility with the "is less defined than" relation. -/

section eval_builtin_arg_lessdef

parameters {A : Type} (ge : Senv) {e1 e2 : A → val} (sp : val) {m1 m2 : mem}

parameter env_lessdef : ∀ x, val.lessdef (e1 x) (e2 x)
parameter mem_extends : extends' m1 m2

lemma eval_builtin_arg_lessdef {a v1} :
  eval_builtin_arg ge e1 sp m1 a = some v1 →
  ∃ v2, eval_builtin_arg ge e2 sp m2 a = some v2 ∧ lessdef v1 v2 := sorry'

lemma eval_builtin_args_lessdef {al vl1} :
  eval_builtin_args ge e1 sp m1 al = some vl1 →
  ∃ vl2, eval_builtin_args ge e2 sp m2 al = some vl2 ∧ list.forall2 lessdef vl1 vl2 := sorry'

end eval_builtin_arg_lessdef

end events


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


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

import Aesop
import Lean

open Lean Lean.Meta Lean.Elab.Tactic

set_option aesop.check.all true
set_option aesop.check.script false

-- When rules add declarations to the environment, Aesop must copy these
-- declarations during proof extraction.

def falso : TacticM Unit := do
  addDecl $ .axiomDecl {
    name := `someaxiom
    levelParams := []
    type := mkConst ``False
    isUnsafe := false
  }
  closeMainGoal (mkConst `someaxiom)

example : False := by
  aesop (add safe falso)

-- A more complex example with dependencies between the rules.

def falso₂ : TacticM Unit := do
  addDecl $ .axiomDecl {
    name := `someaxiom₂
    levelParams := []
    type := ← mkArrow (mkConst ``Nat) (mkConst ``False)
    isUnsafe := false
  }
  addDecl $ .defnDecl {
    name := `fromsomeaxiom₂
    levelParams := []
    type := mkConst ``False
    value := mkApp (mkConst `someaxiom₂) (mkConst ``Nat.zero)
    hints := .regular 0
    safety := .safe
  }
  closeMainGoal (mkConst `fromsomeaxiom₂)

example : False := by
  aesop (add safe falso₂)


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


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

namespace Option

def toMonad [Monad m] [Alternative m] : Option α → m α
  | none     => failure
  | some a   => pure a

@[inline] def toBool : Option α → Bool
  | some _ => true
  | none   => false

@[inline] def isSome : Option α → Bool
  | some _ => true
  | none   => false

@[inline] def isNone : Option α → Bool
  | some _ => false
  | none   => true

@[inline] def isEqSome [BEq α] : Option α → α → Bool
  | some a, b => a == b
  | none,   _ => false

@[inline] protected def bind : Option α → (α → Option β) → Option β
  | none,   b => none
  | some a, b => b a

@[inline] protected def map (f : α → β) (o : Option α) : Option β :=
  Option.bind o (some ∘ f)

@[inline] protected def mapM [Monad m] (f : α → m β) (o : Option α) : m (Option β) := do
  if let some a := o then
    return some (← f a)
  else
    return none

theorem map_id : (Option.map id : Option α → Option α) = id :=
  funext (fun o => match o with | none => rfl | some x => rfl)

instance : Functor Option where
  map := Option.map

@[inline] protected def filter (p : α → Bool) : Option α → Option α
  | some a => if p a then some a else none
  | none   => none

@[inline] protected def all (p : α → Bool) : Option α → Bool
  | some a => p a
  | none   => true

@[inline] protected def any (p : α → Bool) : Option α → Bool
  | some a => p a
  | none   => false

@[macroInline] protected def orElse : Option α → (Unit → Option α) → Option α
  | some a, _ => some a
  | none,   b => b ()

instance : OrElse (Option α) where
  orElse := Option.orElse

@[inline] protected def lt (r : α → α → Prop) : Option α → Option α → Prop
  | none, some x     => True
  | some x,   some y => r x y
  | _, _             => False

instance (r : α → α → Prop) [s : DecidableRel r] : DecidableRel (Option.lt r)
  | none,   some y => isTrue  trivial
  | some x, some y => s x y
  | some x, none   => isFalse not_false
  | none,   none   => isFalse not_false

end Option

deriving instance DecidableEq for Option
deriving instance BEq for Option

instance [LT α] : LT (Option α) where
  lt := Option.lt (· < ·)


/- 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 tidy.command.rfl_lemma

-- structure metype (A B : Type) :=
-- (v : ℕ)

-- structure a_dummy (C D : Type) :=
-- (map'      : Π {X Y : Type}, (C → X → Y) → metype C D)

-- def a_dummy.map {C D : Type} (F : a_dummy C D) {X Y : Type} (f : C → X → Y) : metype C D := F.map' f

-- def lol (E F : Type) [has_lt ℕ] : a_dummy F E :=
-- { map' := λ X Y, λ f, ⟨F, E, 42⟩ }.

-- -- We'd like one of these please:
-- @[simp] lemma lol_map2
--   (E F : Type) [has_lt ℕ] {X Y : Type} (f : F → X → Y) :
--   (lol E F).map f = ⟨F, E, 42⟩ := rfl.

-- -- Try `rfl_lemma` + `?`, trace version, both private and public mode
-- namespace eg1
-- private rfl_lemma? lol map

-- #check lol_map
-- end eg1

-- namespace eg2
-- rfl_lemma? lol map

-- #check lol_map
-- end eg2

-- -- Try `rfl_lemma` vanilla version, both private and public mode
-- namespace eg3
-- private rfl_lemma lol map

-- #check lol_map
-- end eg3

-- namespace eg4
-- rfl_lemma lol map

-- #check lol_map
-- end eg4


import data.rat.defs
import data.fintype.card
import data.polynomial.eval
import algebra.group.basic
import algebra.algebra.basic
import algebra.big_operators.intervals
import ring_theory.algebraic
import ring_theory.int.basic

-- This code is a perfect example of how *NOT* to use Lean
-- There are some `sorry`s because I attempted to refactor my old code
-- to make it more idiomatic, but I just gave up halfway...

namespace rat
theorem pow_num_denom (q : ℚ) (n : ℕ) : q ^ n = rat.mk (q.num ^ n) (↑q.denom ^ n) :=
sorry

theorem div_mk_div_cancel_right {a b c : ℤ} (c0 : c ≠ 0) :
  rat.mk (c * a) (c * b) = rat.mk a b :=
by rw [mul_comm c a, mul_comm c b, rat.div_mk_div_cancel_left c0]

theorem sum_same_denom {n : ℕ} {num : fin (n + 1) → ℤ} {denom : ℤ} :
  finset.univ.sum (λ x : fin (n + 1), rat.mk (num x) denom) =
  rat.mk (finset.univ.sum (λ x : fin (n + 1), num x)) denom := by {
  induction n with i hi,
    repeat {rw fin.sum_univ_one},
  repeat {rw @fin.sum_univ_succ _ _ i.succ _},
  repeat {rw rat.add_mk},
  congr,
  apply hi,
}
end rat

-- The ring of integers of ℚ is ℤ
theorem int_of_algebraic_rat (r : ℚ) (hr : is_integral ℤ r) : r.denom = 1 :=
begin
  obtain ⟨p, hp1, hp2⟩ := hr,
  set n := p.nat_degree with hn,
  set P := r.num with hP,
  set Q : ℤ := ↑r.denom with hQ,

  by_cases p.nat_degree = 0,
  { rw [polynomial.eq_C_of_nat_degree_eq_zero h,
      polynomial.eval₂_C,
      algebra_map_int_eq,
      ring_hom.eq_int_cast,
      rat.coe_int_eq_mk,
      rat.mk_eq_zero one_ne_zero,
      ←h,
      polynomial.monic.coeff_nat_degree hp1]
      at hp2,
    exact false.elim (one_ne_zero hp2) },

  have Qpow : ∀ n : ℕ, Q ^ n ≠ 0 := sorry,
  rw [polynomial.eval₂_eq_sum,
    polynomial.sum_over_range, -- generates an intermediate goal...
    ←fin.sum_univ_eq_sum_range]
    at hp2,
  simp_rw [algebra_map_int_eq,
    ring_hom.eq_int_cast,
    rat.coe_int_eq_mk,
    rat.pow_num_denom,
    rat.mul_def one_ne_zero $ Qpow _,
    one_mul,
    rat.mk_eq_div] at hp2,

  swap, -- ...which we immediately handle
  { intro n, simp },

  have : (λ x : fin (n + 1), ((p.coeff (x : ℕ) * P ^ ↑x) / Q ^ (x : ℕ))) =
    (λ x : fin (n + 1), ((p.coeff (x : ℕ) * P ^ (x : ℕ) * Q ^ (n -(x : ℕ))) / Q ^ n : ℚ)) := by {
    funext,
    calc ((p.coeff ↑x * P ^ ↑x) / Q ^ ↑x : ℚ)
      = ((p.coeff ↑x * P ^ ↑x * Q ^ (n-↑x)) / (Q ^ ↑x * Q ^ (n-↑x)) : ℚ) : sorry
    ... = ((p.coeff ↑x * P ^ ↑x * Q ^ (n-↑x)) / Q ^ n : ℚ) : sorry,
  },

  -- Tedious rewriting lemmas
  have h1 : ∀ x : ℕ, x ≤ n → rat.mk (P ^ x) (Q ^ x) =
    rat.mk (Q ^ (n - x) * P ^ x) (Q ^ n) := by {
    intros x hx,
    calc rat.mk (P ^ x) (Q ^ x)
      = rat.mk (Q ^ (n - x) * P ^ x) (Q ^ (n - x) * Q ^ x) :
        rat.mk_mul_num_and_denom (Qpow x) (Qpow (n - x))
    ... = rat.mk (Q ^ (n - x) * P ^ x) (Q ^ n) : by rw [←pow_add, nat.sub_add_cancel hx]
  },

  have h2 : (λ x : fin (n + 1), rat.mk (p.coeff ↑x) 1 * rat.mk (P ^ ↑x) (Q ^ ↑x)) =
    (λ x : fin (n + 1), rat.mk (p.coeff ↑x * Q ^ (n - ↑x) * P ^ ↑x) (Q ^ n)) := by {
    funext,
    rw [h1 x $ nat.le_of_lt_succ x.is_lt,
      rat.mul_def one_ne_zero (Qpow n),
      ←mul_assoc, one_mul]
  },

  rw [h2,
    rat.sum_same_denom,
    rat.mk_eq_zero $ Qpow n,
  -- Just to extract one term out...
    fin.sum_univ_eq_sum_range (λ x : ℕ, p.coeff x * Q ^ (n - x) * P ^ x) (n + 1),
    eq_add_of_sub_eq $ finset.sum_range_succ_sub_top _,
    ←fin.sum_univ_eq_sum_range (λ x : ℕ, p.coeff x * Q ^ (n - x) * P ^ x) n]
    at hp2,
  dsimp at hp2,
  clear h1 h2,

  have h3 : (λ x : fin n, (p.coeff (↑x : ℕ)) * Q ^ (n - (↑x : ℕ)) * P ^ (↑x : ℕ)) =
    (λ x : fin n, Q * ((p.coeff (↑x : ℕ)) * Q ^ (n - (↑x : ℕ) - 1) * P ^ (↑x : ℕ))) := by {
    funext,
    have : Q ^ (n - ↑x) = Q * Q ^ (n - ↑x - 1) :=
      calc Q ^ (n - ↑x) = Q ^ (n - ↑x).pred.succ : by rw nat.succ_pred_eq_of_pos (nat.sub_pos_of_lt x.is_lt)
      ... = Q * Q ^ (n - ↑x - 1) : by rw [pow_succ, nat.pred_eq_sub_one],
    -- idk why `ring` tactic hangs
    rw [this, ←mul_assoc (p.coeff ↑x) _ _, mul_comm (p.coeff ↑x) Q,
      mul_assoc Q _ _, mul_assoc Q _ _]
  },

  rw [h3, ←finset.mul_sum, polynomial.monic.leading_coeff hp1,
    one_mul, nat.sub_self, pow_zero, one_mul] at hp2,
  clear h3,

  obtain ⟨a, b, hab⟩ := (is_coprime.pow_left_iff $ nat.pos_of_ne_zero h).mpr
    ((@int.coprime_iff_nat_coprime P Q).mpr r.cop),
  replace hp2 := congr_arg (λ x : ℤ, a * x) hp2,
  dsimp at hp2,
  rw [mul_add, mul_zero] at hp2,

  rw ←eq_sub_iff_add_eq at hab,
  rw [hab, int.sub_eq_add_neg, add_comm, add_assoc, add_eq_zero_iff_eq_neg,
    ←mul_assoc, mul_comm b Q, mul_comm a Q, mul_assoc Q a _,
    neg_mul_eq_mul_neg, ←mul_add, neg_mul_eq_mul_neg]
    at hp2,
  clear hab,

  rw [←int.nat_abs_of_nat r.denom,
    int.eq_one_of_dvd_one (le_of_lt $ int.pos_of_pos_nat r.pos) ⟨_, hp2⟩,
    int.nat_abs_one],
end


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


/-
Copyright (c) 2019 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import data.set
import algebra.category.Mon.basic

@[derive has_coe_to_sort] def X : Type := set ℕ

@[derive ring] def T := ℤ

class binclass (T1 T2 : Type)

instance : binclass ℤ ℤ := ⟨⟩

@[derive [ring, binclass ℤ]] def U := ℤ

@[derive λ α, binclass α ℤ] def V := ℤ

-- test instance naming
example := U.ring
example := U.binclass
example := V.binclass

@[derive ring] def id_ring (α) [ring α] : Type := α

@[derive decidable_eq] def S := ℕ

@[derive decidable_eq] inductive P | a | b | c

open category_theory

-- Test that `delta_instance` works in the presence of universe metavariables.
attribute [derive large_category] Mon

-- test deriving instances on function types
@[derive monad]
meta def my_tactic : Type → Type :=
tactic


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