/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.rbtree.default

universes u v

namespace Mathlib

namespace rbmap

/- Auxiliary instances -/

/- Helper lemmas for reusing rbtree results. -/

theorem eq_some_of_to_value_eq_some {α : Type u} {β : Type v} {e : Option (α × β)} {v : β} : to_value e = some v → ∃ (k : α), e = some (k, v) := sorry

theorem eq_none_of_to_value_eq_none {α : Type u} {β : Type v} {e : Option (α × β)} : to_value e = none → e = none := sorry

/- Lemmas -/

theorem not_mem_mk_rbmap {α : Type u} {β : Type v} {lt : α → α → Prop} (k : α) : ¬k ∈ mk_rbmap α β := sorry

theorem not_mem_of_empty {α : Type u} {β : Type v} {lt : α → α → Prop} {m : rbmap α β} (k : α) : empty m = tt → ¬k ∈ m := sorry

theorem not_mem_of_find_entry_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {m : rbmap α β} : find_entry m k = none → ¬k ∈ m := sorry

theorem not_mem_of_find_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {m : rbmap α β} : find m k = none → ¬k ∈ m := sorry

theorem mem_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {e : α × β} {m : rbmap α β} : find_entry m k₁ = some e → k₁ ∈ m := sorry

theorem mem_of_find_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : find m k = some v → k ∈ m := sorry

theorem find_entry_eq_find_entry_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} {k₁ : α} {k₂ : α} : strict_weak_order.equiv k₁ k₂ → find_entry m k₁ = find_entry m k₂ := sorry

theorem find_eq_find_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) : strict_weak_order.equiv k₁ k₂ → find m k₁ = find m k₂ := sorry

theorem find_entry_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ ∃ (e : α × β), find_entry m k = some e ∧ strict_weak_order.equiv k (prod.fst e) := sorry

theorem eqv_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : find_entry m k₁ = some (k₂, v) → strict_weak_order.equiv k₁ k₂ := sorry

theorem eq_of_find_entry_some {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : find_entry m k₁ = some (k₂, v) → k₁ = k₂ :=
  fun (h : find_entry m k₁ = some (k₂, v)) =>
    (fun (this : strict_weak_order.equiv k₁ k₂) => eq_of_eqv_lt this) (eqv_of_find_entry_some h)

theorem find_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ ∃ (v : β), find m k = some v := sorry

theorem constains_correct {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) : k ∈ m ↔ contains m k = tt := sorry

theorem mem_of_mem_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} {k₁ : α} {k₂ : α} : k₁ ∈ m → strict_weak_order.equiv k₁ k₂ → k₂ ∈ m := sorry

theorem mem_insert_of_incomp {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬lt k₁ k₂ ∧ ¬lt k₂ k₁ → k₁ ∈ insert m k₂ v :=
  fun (h : ¬lt k₁ k₂ ∧ ¬lt k₂ k₁) => to_rbmap_mem (rbtree.mem_insert_of_incomp m (eqv_entries_of_eqv_keys v v h))

theorem mem_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (k : α) (m : rbmap α β) (v : β) : k ∈ insert m k v :=
  to_rbmap_mem (rbtree.mem_insert (k, v) m)

theorem mem_insert_of_equiv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : strict_weak_order.equiv k₁ k₂ → k₁ ∈ insert m k₂ v :=
  mem_insert_of_incomp m v

theorem mem_insert_of_mem {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {m : rbmap α β} (k₂ : α) (v : β) : k₁ ∈ m → k₁ ∈ insert m k₂ v :=
  fun (h : k₁ ∈ m) => to_rbmap_mem (rbtree.mem_insert_of_mem (k₂, v) (to_rbtree_mem' v h))

theorem equiv_or_mem_of_mem_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → strict_weak_order.equiv k₁ k₂ ∨ k₁ ∈ m := sorry

theorem incomp_or_mem_of_mem_ins {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → ¬lt k₁ k₂ ∧ ¬lt k₂ k₁ ∨ k₁ ∈ m :=
  equiv_or_mem_of_mem_insert

theorem eq_or_mem_of_mem_ins {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} {v : β} {m : rbmap α β} : k₁ ∈ insert m k₂ v → k₁ = k₂ ∨ k₁ ∈ m := sorry

theorem find_entry_insert_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) {k₁ : α} {k₂ : α} (v : β) : strict_weak_order.equiv k₁ k₂ → find_entry (insert m k₁ v) k₂ = some (k₁, v) := sorry

theorem find_entry_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) (k : α) (v : β) : find_entry (insert m k v) k = some (k, v) :=
  find_entry_insert_of_eqv m v (refl k)

theorem find_insert_of_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) {k₁ : α} {k₂ : α} (v : β) : strict_weak_order.equiv k₁ k₂ → find (insert m k₁ v) k₂ = some v := sorry

theorem find_insert {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] (m : rbmap α β) (k : α) (v : β) : find (insert m k v) k = some v :=
  find_insert_of_eqv m v (refl k)

theorem find_entry_insert_of_disj {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : lt k₁ k₂ ∨ lt k₂ k₁ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ := sorry

theorem find_entry_insert_of_not_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬strict_weak_order.equiv k₁ k₂ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ := sorry

theorem find_entry_insert_of_ne {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : k₁ ≠ k₂ → find_entry (insert m k₁ v) k₂ = find_entry m k₂ :=
  fun (h : k₁ ≠ k₂) => find_entry_insert_of_not_eqv m v fun (h' : strict_weak_order.equiv k₁ k₂) => h (eq_of_eqv_lt h')

theorem find_insert_of_disj {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : lt k₁ k₂ ∨ lt k₂ k₁ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem find_insert_of_not_eqv {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : ¬strict_weak_order.equiv k₁ k₂ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem find_insert_of_ne {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k₁ : α} {k₂ : α} (m : rbmap α β) (v : β) : k₁ ≠ k₂ → find (insert m k₁ v) k₂ = find m k₂ := sorry

theorem mem_of_min_eq {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → k ∈ m :=
  fun (h : min m = some (k, v)) => to_rbmap_mem (rbtree.mem_of_min_eq h)

theorem mem_of_max_eq {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → k ∈ m :=
  fun (h : max m = some (k, v)) => to_rbmap_mem (rbtree.mem_of_max_eq h)

theorem eq_leaf_of_min_eq_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} : min m = none → m = mk_rbmap α β :=
  rbtree.eq_leaf_of_min_eq_none

theorem eq_leaf_of_max_eq_none {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {m : rbmap α β} : max m = none → m = mk_rbmap α β :=
  rbtree.eq_leaf_of_max_eq_none

theorem min_is_minimal {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → ∀ {k' : α}, k' ∈ m → strict_weak_order.equiv k k' ∨ lt k k' := sorry

theorem max_is_maximal {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → ∀ {k' : α}, k' ∈ m → strict_weak_order.equiv k k' ∨ lt k' k := sorry

theorem min_is_minimal_of_total {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : min m = some (k, v) → ∀ {k' : α}, k' ∈ m → k = k' ∨ lt k k' := sorry

theorem max_is_maximal_of_total {α : Type u} {β : Type v} {lt : α → α → Prop} [DecidableRel lt] [is_strict_total_order α lt] {k : α} {v : β} {m : rbmap α β} : max m = some (k, v) → ∀ {k' : α}, k' ∈ m → k = k' ∨ lt k' k := sorry


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yury Kudryashov
-/
import tactic.transform_decl
import tactic.algebra

/-!
# Transport multiplicative to additive

This file defines an attribute `to_additive` that can be used to
automatically transport theorems and definitions (but not inductive
types and structures) from a multiplicative theory to an additive theory.

Usage information is contained in the doc string of `to_additive.attr`.

### Missing features

* Automatically transport structures and other inductive types.

* For structures, automatically generate theorems like `group α ↔
  add_group (additive α)`.

* Rewrite rules for the last part of the name that work in more
  cases. E.g., we can replace `monoid` with `add_monoid` etc.
-/

namespace to_additive
open tactic exceptional

section performance_hack -- see Note [user attribute parameters]

local attribute [semireducible] reflected

local attribute [instance, priority 9000]
private meta def hacky_name_reflect : has_reflect name :=
λ n, `(id %%(expr.const n []) : name)

/-- An auxiliary attribute used to store the names of the additive versions of declarations
that have been processed by `to_additive`. -/
@[user_attribute]
private meta def aux_attr : user_attribute (name_map name) name :=
{ name      := `to_additive_aux,
  descr     := "Auxiliary attribute for `to_additive`. DON'T USE IT",
  cache_cfg := ⟨λ ns,
                ns.mfoldl
                  (λ dict n', do
                   let n := match n' with
                            | name.mk_string s pre := if s = "_to_additive" then pre else n'
                            | _ := n'
                            end,
                    param ← aux_attr.get_param_untyped n',
                    pure $ dict.insert n param.app_arg.const_name)
                  mk_name_map, []⟩,
  parser    := lean.parser.ident }

end performance_hack

/-- A command that can be used to have future uses of `to_additive` change the `src` namespace
to the `tgt` namespace.

For example:
```
run_cmd to_additive.map_namespace `quotient_group `quotient_add_group
```

Later uses of `to_additive` on declarations in the `quotient_group` namespace will be created
in the `quotient_add_group` namespaces.
-/
meta def map_namespace (src tgt : name) : command :=
do let n := src.mk_string "_to_additive",
   let decl := declaration.thm n [] `(unit) (pure (reflect ())),
   add_decl decl,
   aux_attr.set n tgt tt

/-- `value_type` is the type of the arguments that can be provided to `to_additive`.
`to_additive.parser` parses the provided arguments into `name` for the target and an
optional doc string. -/
@[derive has_reflect, derive inhabited]
structure value_type : Type := (tgt : name) (doc : option string)

/-- `add_comm_prefix x s` returns `"comm_" ++ s` if `x = tt` and `s` otherwise. -/
meta def add_comm_prefix : bool → string → string
| tt s := ("comm_" ++ s)
| ff s := s

/-- Dictionary used by `to_additive.guess_name` to autogenerate names. -/
meta def tr : bool → list string → list string
| is_comm ("one" :: "le" :: s)        := add_comm_prefix is_comm "nonneg"    :: tr ff s
| is_comm ("one" :: "lt" :: s)        := add_comm_prefix is_comm "pos"       :: tr ff s
| is_comm ("le" :: "one" :: s)        := add_comm_prefix is_comm "nonpos"    :: tr ff s
| is_comm ("lt" :: "one" :: s)        := add_comm_prefix is_comm "neg"       :: tr ff s
| is_comm ("mul" :: "support" :: s)   := add_comm_prefix is_comm "support"   :: tr ff s
| is_comm ("mul" :: "indicator" :: s) := add_comm_prefix is_comm "indicator" :: tr ff s
| is_comm ("mul" :: s)                := add_comm_prefix is_comm "add"       :: tr ff s
| is_comm ("smul" :: s)               := add_comm_prefix is_comm "vadd"      :: tr ff s
| is_comm ("inv" :: s)                := add_comm_prefix is_comm "neg"       :: tr ff s
| is_comm ("div" :: s)                := add_comm_prefix is_comm "sub"       :: tr ff s
| is_comm ("one" :: s)                := add_comm_prefix is_comm "zero"      :: tr ff s
| is_comm ("prod" :: s)               := add_comm_prefix is_comm "sum"       :: tr ff s
| is_comm ("finprod" :: s)            := add_comm_prefix is_comm "finsum"    :: tr ff s
| is_comm ("npow" :: s)               := add_comm_prefix is_comm "nsmul"     :: tr ff s
| is_comm ("gpow" :: s)               := add_comm_prefix is_comm "gsmul"     :: tr ff s
| is_comm ("monoid" :: s)      := ("add_" ++ add_comm_prefix is_comm "monoid")    :: tr ff s
| is_comm ("submonoid" :: s)   := ("add_" ++ add_comm_prefix is_comm "submonoid") :: tr ff s
| is_comm ("group" :: s)       := ("add_" ++ add_comm_prefix is_comm "group")     :: tr ff s
| is_comm ("subgroup" :: s)    := ("add_" ++ add_comm_prefix is_comm "subgroup")  :: tr ff s
| is_comm ("semigroup" :: s)   := ("add_" ++ add_comm_prefix is_comm "semigroup") :: tr ff s
| is_comm ("magma" :: s)       := ("add_" ++ add_comm_prefix is_comm "magma")     :: tr ff s
| is_comm ("comm" :: s)        := tr tt s
| is_comm (x :: s)             := (add_comm_prefix is_comm x :: tr ff s)
| tt []                        := ["comm"]
| ff []                        := []

/-- Autogenerate target name for `to_additive`. -/
meta def guess_name : string → string :=
string.map_tokens ''' $
λ s, string.intercalate (string.singleton '_') $
tr ff (s.split_on '_')

/-- Return the provided target name or autogenerate one if one was not provided. -/
meta def target_name (src tgt : name) (dict : name_map name) : tactic name :=
(if tgt.get_prefix ≠ name.anonymous -- `tgt` is a full name
 then pure tgt
 else match src with
      | (name.mk_string s pre) :=
        do let tgt_auto := guess_name s,
           guard (tgt.to_string ≠ tgt_auto)
             <|> trace ("`to_additive " ++ src.to_string ++ "`: correctly autogenerated target " ++
               "name, you may remove the explicit " ++ tgt_auto ++ " argument."),
           pure $ name.mk_string
                 (if tgt = name.anonymous then tgt_auto else tgt.to_string)
                 (pre.map_prefix dict.find)
      | _ := fail ("to_additive: can't transport " ++ src.to_string)
      end) >>=
(λ res,
  if res = src
  then fail ("to_additive: can't transport " ++ src.to_string ++ " to itself")
  else pure res)

/-- the parser for the arguments to `to_additive` -/
meta def parser : lean.parser value_type :=
do
  tgt ← optional lean.parser.ident,
  e ← optional interactive.types.texpr,
  doc ← match e with
      | some pe := some <$> ((to_expr pe >>= eval_expr string) : tactic string)
      | none := pure none
      end,
  return ⟨tgt.get_or_else name.anonymous, doc⟩

private meta def proceed_fields_aux (src tgt : name) (prio : ℕ) (f : name → tactic (list string)) :
  command :=
do
  src_fields ← f src,
  tgt_fields ← f tgt,
  guard (src_fields.length = tgt_fields.length) <|>
    fail ("Failed to map fields of " ++ src.to_string),
  (src_fields.zip tgt_fields).mmap' $
    λ names, guard (names.fst = names.snd) <|>
      aux_attr.set (src.append names.fst) (tgt.append names.snd) tt prio

/-- Add the `aux_attr` attribute to the structure fields of `src`
so that future uses of `to_additive` will map them to the corresponding `tgt` fields. -/
meta def proceed_fields (env : environment) (src tgt : name) (prio : ℕ) : command :=
let aux := proceed_fields_aux src tgt prio in
do
aux (λ n, pure $ list.map name.to_string $ (env.structure_fields n).get_or_else []) >>
aux (λ n, (list.map (λ (x : name), "to_" ++ x.to_string) <$> get_tagged_ancestors n)) >>
aux (λ n, (env.constructors_of n).mmap $
          λ cs, match cs with
                | (name.mk_string s pre) :=
                  (guard (pre = n) <|> fail "Bad constructor name") >>
                  pure s
                | _ := fail "Bad constructor name"
                end)

/--
The attribute `to_additive` can be used to automatically transport theorems
and definitions (but not inductive types and structures) from a multiplicative
theory to an additive theory.

To use this attribute, just write:

```
@[to_additive]
theorem mul_comm' {α} [comm_semigroup α] (x y : α) : x * y = y * x := comm_semigroup.mul_comm
```

This code will generate a theorem named `add_comm'`.  It is also
possible to manually specify the name of the new declaration, and
provide a documentation string:

```
@[to_additive add_foo "add_foo doc string"]
/-- foo doc string -/
theorem foo := sorry
```

The transport tries to do the right thing in most cases using several
heuristics described below.  However, in some cases it fails, and
requires manual intervention.

If the declaration to be transported has attributes which need to be
copied to the additive version, then `to_additive` should come last:

```
@[simp, to_additive] lemma mul_one' {G : Type*} [group G] (x : G) : x * 1 = x := mul_one x
```

The exception to this rule is the `simps` attribute, which should come after `to_additive`:

```
@[to_additive, simps]
instance {M N} [has_mul M] [has_mul N] : has_mul (M × N) := ⟨λ p q, ⟨p.1 * q.1, p.2 * q.2⟩⟩
```

## Implementation notes

The transport process generally works by taking all the names of
identifiers appearing in the name, type, and body of a declaration and
creating a new declaration by mapping those names to additive versions
using a simple string-based dictionary and also using all declarations
that have previously been labeled with `to_additive`.

In the `mul_comm'` example above, `to_additive` maps:
* `mul_comm'` to `add_comm'`,
* `comm_semigroup` to `add_comm_semigroup`,
* `x * y` to `x + y` and `y * x` to `y + x`, and
* `comm_semigroup.mul_comm'` to `add_comm_semigroup.add_comm'`.

Even when `to_additive` is unable to automatically generate the additive
version of a declaration, it can be useful to apply the attribute manually:

```
attribute [to_additive foo_add_bar] foo_bar
```

This will allow future uses of `to_additive` to recognize that
`foo_bar` should be replaced with `foo_add_bar`.

### Handling of hidden definitions

Before transporting the “main” declaration `src`, `to_additive` first
scans its type and value for names starting with `src`, and transports
them. This includes auxiliary definitions like `src._match_1`,
`src._proof_1`.

After transporting the “main” declaration, `to_additive` transports
its equational lemmas.

### Structure fields and constructors

If `src` is a structure, then `to_additive` automatically adds
structure fields to its mapping, and similarly for constructors of
inductive types.

For new structures this means that `to_additive` automatically handles
coercions, and for old structures it does the same, if ancestry
information is present in `@[ancestor]` attributes. The `ancestor`
attribute must come before the `to_additive` attribute, and it is
essential that the order of the base structures passed to `ancestor` matches
between the multiplicative and additive versions of the structure.

### Name generation

* If `@[to_additive]` is called without a `name` argument, then the
  new name is autogenerated.  First, it takes the longest prefix of
  the source name that is already known to `to_additive`, and replaces
  this prefix with its additive counterpart. Second, it takes the last
  part of the name (i.e., after the last dot), and replaces common
  name parts (“mul”, “one”, “inv”, “prod”) with their additive versions.

* Namespaces can be transformed using `map_namespace`. For example:
  ```
  run_cmd to_additive.map_namespace `quotient_group `quotient_add_group
  ```

  Later uses of `to_additive` on declarations in the `quotient_group`
  namespace will be created in the `quotient_add_group` namespaces.

* If `@[to_additive]` is called with a `name` argument `new_name`
  /without a dot/, then `to_additive` updates the prefix as described
  above, then replaces the last part of the name with `new_name`.

* If `@[to_additive]` is called with a `name` argument
  `new_namespace.new_name` /with a dot/, then `to_additive` uses this
  new name as is.

As a safety check, in the first two cases `to_additive` double checks
that the new name differs from the original one.

-/
@[user_attribute]
protected meta def attr : user_attribute unit value_type :=
{ name      := `to_additive,
  descr     := "Transport multiplicative to additive",
  parser    := parser,
  after_set := some $ λ src prio persistent, do
    guard persistent <|> fail "`to_additive` can't be used as a local attribute",
    env ← get_env,
    val ← attr.get_param src,
    dict ← aux_attr.get_cache,
    tgt ← target_name src val.tgt dict,
    aux_attr.set src tgt tt,
    let dict := dict.insert src tgt,
    if env.contains tgt
    then proceed_fields env src tgt prio
    else do
      transform_decl_with_prefix_dict dict src tgt
        [`reducible, `_refl_lemma, `simp, `instance, `refl, `symm, `trans, `elab_as_eliminator,
         `no_rsimp],
      mwhen (has_attribute' `simps src)
        (trace "Apply the simps attribute after the to_additive attribute"),
      match val.doc with
      | some doc := add_doc_string tgt doc
      | none := skip
      end }

add_tactic_doc
{ name                     := "to_additive",
  category                 := doc_category.attr,
  decl_names               := [`to_additive.attr],
  tags                     := ["transport", "environment", "lemma derivation"] }

end to_additive

/- map operations -/
attribute [to_additive] has_mul has_one has_inv has_div


namespace List

@[simp] theorem filter_nil {p : α → Bool} : filter p [] = [] := by
  simp!

theorem cons_eq_append (a : α) (as : List α) : a :: as = [a] ++ as := rfl

theorem filter_cons (a : α) (as : List α) :
  filter p (a :: as) = if p a then a :: filter p as else filter p as :=
  sorry

@[simp] theorem filter_append {as bs : List α} {p : α → Bool} :
  filter p (as ++ bs) = filter p as ++ filter p bs :=
  match as with
  | []      => by simp
  | a :: as => by
    rw [filter_cons, cons_append, filter_cons]
    cases p a
    simp [filter_append]
    simp [filter_append]

-- the previous contains a more complicated version of
def f : Nat → Nat
  | 0 => 1
  | i+1 => (fun x => f x) i


import heap.lemmas heap.tactic misc prop
import data.nat.basic

universes u

namespace separation
open memory finmap

variables (value : Type)

@[reducible]
def ST (α : Type) := state_t (heap value) set α

open state_t
variables {value} {α : Type}
include value
local notation `ST` := ST value

def read (p : ptr) : ST value :=
do m ← get,
   match m.lookup p with
   | none := @monad_lift set _ _ _ ∅
   | (some x) := pure x
   end

def assign (p : ptr) (v : value) : ST punit :=
modify (finmap.insert p v)

def assign_vals (p : ptr) (vs : list value) : ST punit :=
modify $ (∪ heap.mk (vs.enum_from p))

def choice (p : α → Prop) : ST α :=
@monad_lift set (state_t _ set) _ _ (p : set α)

def alloc (vs : list value) : ST ptr :=
do m ← get,
   p ← choice $ λ p : ptr, ∀ i < vs.length, (p + i) ∉ m,
   assign_vals p vs,
   pure p

section

variable value

def alloc' (n : ℕ) : ST ptr :=
choice (λ v : list value, v.length = n) >>= alloc

def dealloc (p : ptr) (n : ℕ) : ST unit :=
do m ← get,
   modify $ erase_all p n

end

def for' : Π  (k : ℕ) (n : ℕ) (f : ℕ → ST punit), ST punit
| _ 0 f := pure punit.star
| k (nat.succ n) f := f k >> for' k.succ n f

def for : Π (n : ℕ) (f : ℕ → ST punit), ST punit
| 0 f := pure punit.star
| (nat.succ n) f := for n f >> f n

-- def clone (p : tptr (list value)) (n : ℕ) : ST ptr :=
-- do q ← alloc' value n,
--    for n (λ i,
--      do v ← read (p + i),
--         assign (q + i) v),
--    pure q

-- def map (p : ptr) (f : ℕ → value → value) (n : ℕ) : ST punit :=
-- for n (λ i,
--   do v ← read (p + i),
--      assign (p + i) (f i v) )

section talloc

-- open

variables (value) (α) [fixed_storable value α] (n : ℕ)
-- local notation `ST` := ST value
local notation `tptr` := tptr value

def malloc : ST (tptr (list value)) :=
tptr.mk _ _ <$> alloc' value n

def ralloc : ST (tptr (list α)) :=
tptr.mk _ _ <$> alloc' value (n * fixed_size value α)

def ralloc1 : ST (tptr α) :=
tptr.mk _ _ <$> alloc' value (fixed_size value α)

variables {α}

variables {value}

def free (p : tptr (list α)) (n : ℕ) : ST unit :=
dealloc value p.get (n * fixed_size value α)

end talloc

@[simp]
lemma mem_run_modify (x : punit) (h h' : heap value) (g : heap value → heap value) :
  (x,h') ∈ (modify g : ST punit).run h ↔ h' = g h :=
by simp only [modify,state_t.modify,pure,state_t.run,punit.punit_eq_iff, true_and, id.def, iff_self, set.mem_singleton_iff, prod.mk.inj_iff, prod.map]

@[simp]
lemma mem_bind_run {β} (x' : β) (h h' : heap value) (f : ST α) (g : α → ST β) :
  (x',h') ∈ (f >>= g).run h ↔ (∃ x'' h'', (x'',h'') ∈ f.run h ∧ (x',h') ∈ (g x'').run h'') :=
by simp only [exists_prop, state_t.run_bind, set.mem_Union, set.bind_def, iff_self, prod.exists]

@[simp]
lemma mem_choice_run (x' : α) (h h' : heap value) (p : α → Prop) :
  (x',h') ∈ (choice p : ST α).run h ↔ p x' ∧ h' = h :=
by simp only [choice, set.mem_Union, set.bind_def, set.mem_singleton_iff, prod.mk.inj_iff, run_monad_lift, set.pure_def];
   split; simp only [and_imp, exists_imp_distrib]; intros; try { subst x' }; repeat { split }; assumption

@[simp]
lemma mem_run_pure (x x' : α) (h h' : heap value) :
  (x',h') ∈ (pure x : ST α).run h ↔  x' = x ∧ h' = h :=
by simp only [iff_self, set.mem_singleton_iff, prod.mk.inj_iff, set.pure_def, state_t.run_pure]

@[simp]
lemma mem_run_get (x' : heap value) (h h' : heap value) :
  (x',h') ∈ (get : ST _).run h ↔  x' = h ∧ h' = h :=
by simp only [get, monad_state.lift, pure, set.mem_singleton_iff, prod.mk.inj_iff, id.def, state_t.run_get]

@[simp]
lemma mem_run_read (x' : value) (p : ptr) (h h' : heap value) :
  (x',h') ∈ (read p : ST _).run h ↔ h.lookup p = some x' ∧ h' = h :=
begin
  simp only [read, monad_state.lift, pure, exists_prop, set.mem_Union, set.bind_def, mem_run_get, prod.mk.inj_iff, run_bind, prod.exists], split,
  { rintro ⟨a,b,⟨h'',H⟩,H'⟩, cases h : (lookup p b); subst_vars; rw h at H'; simp [read] at H', cases H', casesm* _ ∧ _,
    subst_vars, rw h, exact ⟨rfl,rfl⟩ },
  { rintro ⟨h,⟨⟩,⟨⟩⟩, refine ⟨_,_,⟨rfl,rfl⟩,_⟩, simp [h,read] }
end

section tactic

open tactic
omit value

meta def sane_names : tactic unit :=
do ls ← local_context,
   ls.reverse.mmap' $ λ l,
     when (l.local_pp_name.to_string.length > 5) $ do
       t ← infer_type l,
       n ← revert l,
       let fn := t.get_app_fn,
       let v := if fn.is_constant
                   then fn.const_name.update_prefix name.anonymous
                else if fn.is_local_constant
                   then fn.local_pp_name
                   else `h,
       v ← get_unused_name v,
       intro $ mk_simple_name $ (v.to_string.to_list.take 1).as_string,
       intron (n - 1),
       skip

end tactic

open list

@[simp]
lemma mem_run_alloc_cons (v : value) (vs : list value) (h h' : heap value) (p : ptr) :
  (p, h') ∈ (alloc (v :: vs)).run h ↔ ∃ h'', some h' = some h'' ⊗ some (maplet p v) ∧ p ∉ h ∧ (p+1, h'') ∈ (alloc vs).run h :=
begin
  simp [alloc,assign_vals,enum_from], split; intro h; casesm * [Exists _, _ ∧ _]; subst_vars;
  constructor_matching* [_ ∧ _, Exists _]; try { assumption <|> refl <|> sane_names },
  { have : disjoint (maplet p v) (heap.mk (enum_from (p + 1) vs)) := disjoint_maplet_heap_mk_add_one _ _,
    rw [← union_eq_add_of_disjoint,union_comm_of_disjoint this,union_assoc],
    rw disjoint_union_left, refine ⟨_,this.symm⟩,
    symmetry, simp [disjoint_maplet], apply h_1 0 (nat.zero_lt_one_add _) },
  { apply h_1 0, linarith },
  { introv hi, specialize h_1 (1 + i) (nat.add_lt_add_left hi _),
    rw ← nat.add_assoc at h_1, exact h_1, },
  { introv hi, cases i, { exact n },
    specialize h_1 i, rw [← nat.succ_eq_add_one,nat.succ_add_eq_succ_add] at h_1,
    rw [nat.add_comm,nat.succ_eq_add_one] at hi,
    apply h_1 (nat.lt_of_add_lt_add_right hi) },
  { have : disjoint (maplet p v) (heap.mk (enum_from (p + 1) vs)),
    { simp },
    rw [union_comm_of_disjoint this, ← union_assoc],
    apply eq_union_of_eq_add e }
end

@[simp]
lemma mem_run_alloc (vs : list value) (h h' : heap value) (p : ptr) :
  (p, h') ∈ (alloc vs).run h ↔ some h' = some h ⊗ some (heap.mk $ vs.enum_from p) :=
begin
  induction vs generalizing p h',
  { simp [alloc,assign_vals,list.enum_from], },
  { simp only [some_mk_enum_from_cons, mem_run_alloc_cons, vs_ih, add_zero], split,
    { simp only [and_imp, exists_imp_distrib], intros h'' H₀ H₁ H₂,
      simp only [*, memory.add_assoc, and_true, eq_self_iff_true], congr' 1,
      rw memory.add_comm, },
    { rintro H₀, existsi h ∪ heap.mk (enum_from (p + 1) vs_tl),
      rw [H₀,union_eq_add_of_disjoint,memory.add_assoc], split,
      { clear_except, congr' 1, apply memory.add_comm },
      split, {
         have : disjoint (maplet p vs_hd) h, prove_disjoint,
         apply this, simp },
      { exact rfl },
      prove_disjoint } }
end

end separation


import tactic data.vector.basic data.vector.zip algebra.big_operators.basic algebra.big_operators.norm_num
 vorspiel lencodable

open_locale big_operators

universes u v

namespace turing_machine

inductive language (Γ : Type u)
| blank : language
| start : language
| chr   : Γ → language

notation `␣` := language.blank
notation `␤` := language.start

namespace language
variables {Γ : Type u}

instance : inhabited (language Γ) := ⟨␣⟩

def language_equiv_option_sum_bool : language Γ ≃ bool ⊕ Γ :=
{ to_fun := λ l, match l with | ␣ := sum.inl ff | ␤ := sum.inl tt | chr x := sum.inr x end,
  inv_fun := λ l, match l with | (sum.inl ff) := ␣ | (sum.inl tt) := ␤ | sum.inr x := chr x end,
  left_inv := λ l, by rcases l; simp; refl,
  right_inv := λ l, by { rcases l; simp, { rcases l; refl }, refl } }

instance [fintype Γ] : fintype (language Γ) := fintype.of_equiv (bool ⊕ Γ) language_equiv_option_sum_bool.symm

end language

class state_lang (Q : Type u) :=
(start : Q)
(halt : Q)

instance {Q R} [state_lang Q] [state_lang R] : state_lang (Q ⊕ R) := ⟨sum.inl state_lang.start, sum.inr state_lang.halt⟩

end turing_machine

namespace turing_machine
open state_lang

variables
  (Γ : Type u) -- 言語
  (Q : Type v) [state_lang Q] -- 状態
  (ι : ℕ) -- テープの数

inductive instruction
| stay  : instruction
| right : instruction
| left  : instruction

namespace instruction

instance : inhabited instruction := ⟨stay⟩

@[simp] def apply : instruction → ℕ → ℕ
| stay  ι := ι
| right ι := ι + 1
| left  ι := ι - 1

@[simp] lemma apply_default (n) : apply default n = n := rfl

@[simp] lemma default_nth (ι : ℕ) (i) : (default : vector instruction ι).nth i = stay :=
by { unfold default, simp }

def equiv_unit_sums : instruction ≃ unit ⊕ unit ⊕ unit :=
{ to_fun := λ i, match i with | stay := sum.inl () | right := sum.inr (sum.inl ()) | left := sum.inr (sum.inr ()) end,
  inv_fun := λ i, match i with | sum.inl () := stay | sum.inr (sum.inl ()) := right | sum.inr (sum.inr ()) := left end,
  left_inv := λ i, by rcases i; refl,
  right_inv := λ i, by { rcases i; simp, rcases i, refl, rcases i; rcases i; refl } }

instance : fintype instruction := fintype.of_equiv (unit ⊕ unit ⊕ unit) equiv_unit_sums.symm

@[simp] lemma card : fintype.card instruction = 3 := by simpa using fintype.card_congr equiv_unit_sums

variables {ι}

def Stay : vector instruction ι := vector.repeat stay ι

@[simp] lemma Stay_nth (i : fin ι) : Stay.nth i = stay := by simp[Stay]

def Right : vector instruction ι := vector.repeat right ι

@[simp] lemma Right_nth (i : fin ι) : Right.nth i = right := by simp[Right]

def Left : vector instruction ι := vector.repeat left ι

@[simp] lemma Left_nth (i : fin ι) : Left.nth i = left := by simp[Left]

end instruction

structure word :=
(c : Q)
(z : vector Γ ι)
(u : vector instruction ι)
(q : Q)
(x : vector Γ ι)

notation `⟮` c `, ` z `; ` u ` | ` q `, ` x `⟯`:80 := word.mk c z u q x

namespace word

def equiv_prod : word Γ Q ι ≃ Q × vector Γ ι × vector instruction ι × Q × vector Γ ι :=
{ to_fun := λ w, match w with ⟮c, z; u | q, x⟯ := (c, z, u, q, x) end,
  inv_fun := λ w, match w with (c, z, u, q, x) := ⟮c, z; u | q, x⟯ end,
  left_inv := λ w, by rcases w; refl,
  right_inv := λ w, by rcases w with ⟨_, w⟩; rcases w with ⟨_, w⟩; rcases w with ⟨_, w⟩; rcases w with ⟨_, w⟩; refl }

open fintype

instance [fintype Γ] [fintype Q] : fintype (word Γ Q ι) :=
fintype.of_equiv (Q × vector Γ ι × vector instruction ι × Q × vector Γ ι) (equiv_prod _ _ _).symm

lemma card [fintype Γ] [fintype Q] : card (word Γ Q ι) = card Q^2 * (3 * card Γ^2)^ι :=
calc card (word Γ Q ι) = card Q * card Γ^ι * 3^ι * card Q * card Γ^ι
  : by simpa[mul_assoc] using fintype.card_congr (equiv_prod Γ Q ι)
                   ... = card Q * card Q * 3^ι * card Γ^ι * card Γ^ι
  : by ring
                   ... = card Q^2 * (3 * card Γ^2)^ι
  : by simp[pow_two, mul_pow]; ring

end word

structure model :=
(state : Q)
(tape : vector (ℕ → Γ) ι)
(head : vector ℕ ι)

notation `⟦` q `, ` T `, ` H `⟧` := model.mk q T H

structure sentence :=
(carrier : set (word Γ Q ι))
(proper' : ∀ c z u q x, ⟮c, z; u | q, x⟯ ∈ carrier → q ≠ state_lang.halt ∧ c ≠ state_lang.start)

namespace sentence
variables {Γ Q ι}
variables (σ : sentence Γ Q ι)

instance : set_like (sentence Γ Q ι) (word Γ Q ι) := ⟨sentence.carrier, λ ⟨_, _⟩ ⟨_, _⟩, by simp⟩

lemma mem_def (w : word Γ Q ι) : w ∈ σ ↔ w ∈ σ.carrier := iff.rfl

lemma proper {c z u q x} : ⟮c, z; u | q, x⟯ ∈ σ → q ≠ state_lang.halt ∧ c ≠ state_lang.start := σ.proper' _ _ _ _ _

@[simp] lemma start_notin (c z u x) : ⟮c, z; u | halt, x⟯ ∉ σ := λ A, by simpa using σ.proper A

@[simp] lemma halt_notin (z u q x) : ⟮start, z; u | q, x⟯ ∉ σ := λ A, by simpa using σ.proper A

lemma carrier_finite [fintype Γ] [fintype Q] : σ.carrier.finite := set.to_finite _

noncomputable instance [fintype Γ] [fintype Q] : fintype (sentence Γ Q ι) := fintype.of_injective carrier (λ ⟨_, _⟩ ⟨_, _⟩, by simp)

def is_halt (q : Q) : Prop := ∀ ⦃c z u x⦄, ⟮c, z; u | q, x⟯ ∉ σ

def is_start (c : Q) : Prop := ∀ ⦃z u x q⦄, ⟮c, z; u | q, x⟯ ∉ σ

lemma coe_carrier : (σ : set (word Γ Q ι)) = σ.carrier := by refl

end sentence

variables {Γ Q ι}

namespace model
variables (σ : sentence Γ Q ι)

@[ext] lemma ext : ∀ {m₁ m₂ : model Γ Q ι}
  (hs : m₁.state = m₂.state)
  (ht : m₁.tape = m₂.tape)
  (hh : m₁.head = m₂.head), m₁ = m₂
| ⟦q₁, T₁, H₁⟧ ⟦q₂, T₂, H₂⟧ hs ht hh :=
  by { simp at hs ht hh, simp[hs, ht, hh] }

def read (T : vector (ℕ → Γ) ι) (H : vector ℕ ι) : vector Γ ι := @vector.zip_with (ℕ → Γ) ℕ Γ ι (λ t h, t h) T H

@[simp] lemma read_nth (T : vector (ℕ → Γ) ι) (H : vector ℕ ι) (i) : (read T H).nth i = (T.nth i) (H.nth i) :=
by simp[read]

@[irreducible] def reduct_tape (T H) (x : vector Γ ι) : vector (ℕ → Γ) ι :=
  @vector.zip_with3 (ℕ → Γ) ℕ Γ (ℕ → Γ) ι (λ t h x, λ n, if n = h then x else t n) T H x

@[irreducible] def reduct_head (H) (u : vector instruction ι) : vector ℕ ι :=
  vector.zip_with instruction.apply u H

@[simp] lemma reduct_tape_nth (T H) (x : vector Γ ι) (i) :
  (reduct_tape T H x).nth i = (λ n, if n = H.nth i then x.nth i else T.nth i n) :=
by simp[reduct_tape]

@[simp] lemma reduct_head_nth  (H) (u : vector instruction ι) (i) :
  (reduct_head H u).nth i = (u.nth i).apply (H.nth i) :=
by simp[reduct_head]

inductive reduction : model Γ Q ι → model Γ Q ι → Prop
| intro : ∀ (q : Q) (T : vector (ℕ → Γ) ι) (H : vector ℕ ι) (c : Q) (z : vector Γ ι) (u : vector instruction ι),
    ⟮c, z; u | q, read T H⟯ ∈ σ → reduction ⟦q, T, H⟧ ⟦c, reduct_tape T H z, reduct_head H u⟧

notation m₀ ` ⟶¹[`:60  σ `] ` :0 m₁ := reduction σ m₀ m₁

def is_halt (m : model Γ Q ι) : Prop := ∀ m', ¬m ⟶¹[σ] m'

def time_reductions : ℕ → model Γ Q ι → model Γ Q ι → Prop := relation.power (reduction σ)

notation m₀ ` ⟶^(`:80 s `)[`  σ `] ` :80 m₁ := time_reductions σ s m₀ m₁

def time_bounded_reductions : ℕ → model Γ Q ι → model Γ Q ι → Prop := relation.power_le (reduction σ)

notation m₀ ` ⟶^(≤ `:80 s `)[`  σ `] ` :80 m₁ := time_bounded_reductions σ s m₀ m₁

def time_bounded_reductions_halt (s : ℕ) (m m' : model Γ Q ι) : Prop := is_halt σ m' ∧ m ⟶^(≤ s)[σ] m'

notation m₀ ` ⟶^(≤ `:80 s `)[`  σ `]↓ ` :80 m₁ := time_bounded_reductions_halt σ s m₀ m₁

def is_halt_in_step (s : ℕ) (m : model Γ Q ι) : Prop := ∀ (m') (s' > s), ¬ m ⟶^(s')[σ] m'

def reductions : model Γ Q ι → model Γ Q ι → Prop := relation.trans_gen (reduction σ)

notation m₀ ` ⟶*[`:80  σ `] ` :0 m₁ := reductions σ m₀ m₁

end model

variables {Γ Q ι}
def sentence.deterministic (σ : sentence Γ Q ι) : Prop :=
∀ ⦃q x c₁ c₂ z₁ z₂ u₁ u₂⦄, ⟮c₁, z₁; u₁ | q, x⟯ ∈ σ → ⟮c₂, z₂; u₂ | q, x⟯ ∈ σ → c₁ = c₂ ∧ z₁ = z₂ ∧ u₁ = u₂

namespace sentence

inductive of_fun_aux (δ : Q → vector Γ ι → option (Q × vector Γ ι × vector instruction ι)) : set (word Γ Q ι)
| intro : ∀ {q x c z u}, δ q x = some ⟨c, z, u⟩ → of_fun_aux ⟮c, z; u | q, x⟯

def of_fun (δ : Q → vector Γ ι → option (Q × vector Γ ι × vector instruction ι))
  (H : ∀ {q x c z u}, δ q x = some ⟨c, z, u⟩ → q ≠ halt ∧ c ≠ start) : sentence Γ Q ι :=
{ carrier := of_fun_aux δ,
  proper' := λ c z u q x, by { rintro ⟨_, _, _, _, _, h⟩, exact H h } }

namespace of_fun
variables (δ : Q → vector Γ ι → option (Q × vector Γ ι × vector instruction ι))

lemma carrier_eq {H} : (of_fun δ H).carrier = of_fun_aux δ := rfl

@[simp] lemma mem_iff {H} {c z u q x} : ⟮c, z; u | q, x⟯ ∈ of_fun δ H ↔ δ q x = some ⟨c, z, u⟩ :=
by { simp[sentence.mem_def], split,
  { rintros ⟨_, _, _, _, _, h⟩, exact h }, { intros h, exact of_fun_aux.intro h } }

lemma none_is_halt {q H} : (of_fun δ H).is_halt q ↔ ∀ x, δ q x = none :=
by { simp [is_halt, mem_iff, option.eq_none_iff_forall_not_mem], split,
  { rintros h x c ⟨z, u⟩ eqn, exact h eqn }, { rintros h c z u x, exact h x c (z, u) } }

lemma of_fn.deterministic {H} : deterministic (of_fun δ H) :=
λ _ _ _ _ _ _ _ _, by { simp, intros h₁ h₂, simpa[h₁] using h₂ }

end of_fun

namespace deterministic
variables {σ : sentence Γ Q ι} {m₁ m₂ : model Γ Q ι}

lemma reduction (d : deterministic σ) : relation.deterministic (model.reduction σ) := λ m m₁ m₂ h₁ h₂,
begin
  rcases h₁ with ⟨q₁, T₁, H₁, c₁, z₁, u₁, mem₁⟩,
  rcases h₂ with ⟨q₂, T₂, H₂, c₂, z₂, u₂, mem₂⟩,
  rcases d mem₁ mem₂ with ⟨rfl, rfl, rfl⟩,
  refl
end

lemma time_reductions (d : deterministic σ) {n} : relation.deterministic (model.time_reductions σ n) :=
relation.power.deterministic (reduction @d)

end deterministic

end sentence

section TM

def tape_of (x : list Γ) : ℕ → language Γ
| 0       := ␤
| (n + 1) := if h : n < x.length then language.chr (x.nth_le n h) else ␣

-- ␤ x₁ x₂ ... xₙ ␣ ␣ ␣ ...

@[simp] lemma tape_of_of_zero {x : list Γ} : tape_of x 0 = ␤ := by simp[tape_of]

@[simp] lemma tape_of_of_lt {n} {x : list Γ} (gt : n > 0) (le : n ≤ x.length) :
  tape_of x n = language.chr (x.nth_le (n - 1) (by { cases n, { simp at gt, contradiction }, { simpa using nat.succ_le_iff.mp le} })) :=
by { cases n, { simp at gt, contradiction },
     { simp[tape_of, show n < x.length, from nat.succ_le_iff.mp le] } }

@[simp] lemma tape_of_list_of_ge {n} {x : list Γ} (h : n ≥ x.length + 1) : tape_of x n = ␣ :=
by { cases n, { simp at h, contradiction },
     { simp[tape_of], have : n ≥ x.length, exact nat.succ_le_succ_iff.mp h, exact nat.le_lt_antisymm this } }

structure fun_time_bounded_computable_by_NDTM (f : vector (list Γ) ι → vector (list Γ) ι) (T : ℕ → ℕ) :=
(Q : Type*)
(Q_fin : finite Q)
(Q_state : state_lang Q)
(σ : sentence (language Γ) Q ι)
(reduction : ∀ (X : vector (list Γ) ι),
  model.is_halt_in_step σ (T X.length) (⟦start, X.map tape_of, default⟧) ∧
  ⟦start, X.map tape_of, default⟧ ⟶^(≤ T X.length)[σ]↓ ⟦halt, (f X).map tape_of, default⟧)

structure fun_time_bounded_computable_by_TM (f : vector (list Γ) ι → vector (list Γ) ι) (T : ℕ → ℕ)
  extends fun_time_bounded_computable_by_NDTM f T :=
(deterministic : σ.deterministic)

end TM

namespace sentence
open model sentence.deterministic relation
variables {R : Type*} [state_lang R] (f : Q → R) {σ : sentence Γ Q ι}

@[simp] def word.map_q : word Γ Q ι → word Γ R ι
| ⟮c, z; u | q, x⟯ := ⟮f c, z; u | f q, x⟯

@[simp] def map_q (σ : sentence Γ Q ι) (f : Q → R) (H : ∀ c z u q x, ⟮c, z; u | q, x⟯ ∈ σ → f q ≠ halt ∧ f c ≠ start) :
  sentence Γ R ι :=
{ carrier := word.map_q f '' σ,
  proper' := by { rintros c z u q x ⟨⟨c', z', u', q', x'⟩, h, eqn⟩,
                  simp at eqn, rcases eqn with ⟨rfl, rfl, rfl, rfl, rfl⟩, exact H _ _ _ _ _ h } }

end sentence

namespace model
open sentence sentence.deterministic relation
variables {m₁ m₂ m₃ : model Γ Q ι} {σ : sentence Γ Q ι}

@[simp] lemma reduct_tape_read {T : vector (ℕ → Γ) ι} {H : vector ℕ ι} : reduct_tape T H (read T H) = T :=
by { ext, simp, rintros rfl, refl }

@[simp] lemma reduct_head_Stay {H : vector ℕ ι} : reduct_head H instruction.Stay = H :=
by { ext, simp, }

lemma reduction.iff {q₁ q₂ : Q} {T₁ T₂ : vector (ℕ → Γ) ι} {H₁ H₂ : vector ℕ ι}  :
  (⟦q₁, T₁, H₁⟧ ⟶¹[σ] ⟦q₂, T₂, H₂⟧) ↔
  (∃ (z : vector Γ ι) (u : vector instruction ι), ⟮q₂, z; u | q₁, read T₁ H₁⟯ ∈ σ ∧ T₂ = reduct_tape T₁ H₁ z ∧ H₂ = reduct_head H₁ u) :=
⟨by { rintros ⟨_, _, _, _, z, u, mem⟩, refine ⟨z, u, mem, rfl, rfl⟩ },
 by { rintros ⟨z, u, mem, rfl, rfl⟩, refine ⟨_, _, _, _, z, u, mem⟩ }⟩

@[simp] lemma time_bounded_reductions.refl {s} : m₁ ⟶^(≤ s)[σ] m₁ := power_le.refl

lemma time_reductions.refl : m₁ ⟶^(0)[σ] m₁ := power.zero _

@[simp] lemma time_reductions_zero_iff : (m₁ ⟶^(0)[σ] m₂) ↔ m₁ = m₂ := power.zero_iff

lemma time_bounded_reductions.of_le {s₁ s₂} (le : s₁ ≤ s₂) (h : m₁ ⟶^(≤ s₁)[σ] m₂) :
  m₁ ⟶^(≤ s₂)[σ] m₂ := power_le.of_le le h

lemma time_reductions.add {s₁ s₂} (h₁ : m₁ ⟶^(s₁)[σ] m₂) (h₂ : m₂ ⟶^(s₂)[σ] m₃) :
  m₁ ⟶^(s₁ + s₂)[σ] m₃ := power.add h₁ h₂

lemma time_bounded_reductions.add {s₁ s₂} (h₁ : m₁ ⟶^(≤ s₁)[σ] m₂) (h₂ : m₂ ⟶^(≤ s₂)[σ] m₃) :
  m₁ ⟶^(≤ s₁ + s₂)[σ] m₃ := power_le.add h₁ h₂

lemma time_bounded_reductions.sum {m : ℕ → model Γ Q ι} {s : ℕ → ℕ}
  (h : ∀ k, m k ⟶^(≤ s k)[σ] m (k + 1)) (k : ℕ) : (m 0) ⟶^(≤ ∑ i in finset.range k, s i)[σ] (m k) :=
by { induction k with k IH, { simp }, { simpa[finset.sum_range_succ] using IH.add (h k) } }

lemma reduction.of_ss (r : m₁ ⟶¹[σ] m₂) {τ : sentence Γ Q ι} (ss : σ ≤ τ) : m₁ ⟶¹[τ] m₂ :=
by { rcases r with ⟨q, T, H, c, z, u, mem⟩, refine ⟨_, _, _, _, _, _, ss mem⟩ }

lemma time_reductions.of_ss {n} (r : m₁ ⟶^(n)[σ] m₂) {τ : sentence Γ Q ι} (ss : σ ≤ τ) : m₁ ⟶^(n)[τ] m₂ :=
by { induction n with n IH generalizing m₂, { rcases r, simp },
     { rcases r with (_ | ⟨_, _, m₁₁, _, r₁_₁₁, r₁₁_₂⟩), exact (IH r₁_₁₁).succ (r₁₁_₂.of_ss ss) } }

lemma time_bounded_reductions.of_ss {k} (r : m₁ ⟶^(≤ k)[σ] m₂) {τ : sentence Γ Q ι} (ss : σ ≤ τ) : m₁ ⟶^(≤ k)[τ] m₂ :=
by { rcases r with ⟨n, le, r⟩, refine ⟨n, le, time_reductions.of_ss r ss⟩ }

section
variables {R : Type*} [state_lang R] (f : Q → R)

@[simp] def map_q : model Γ Q ι → model Γ R ι
| ⟦q, T, H⟧ := ⟦f q, T, H⟧

instance [has_coe Q R] : has_coe (model Γ Q ι) (model Γ R ι) := ⟨λ m, m.map_q coe⟩

variables (m m' : model Γ Q ι) {f}

@[simp] lemma map_q_tape (m : model Γ Q ι) : (m.map_q f).tape = m.tape := by cases m; simp

@[simp] lemma map_q_head (m : model Γ Q ι) : (m.map_q f).head = m.head := by cases m; simp

@[simp] lemma map_q_state (m : model Γ Q ι) : (m.map_q f).state = f m.state := by cases m; simp

variables (f)

lemma reduction.map_q {H} (h : m₁ ⟶¹[σ] m₂) : m₁.map_q f ⟶¹[σ.map_q f H] m₂.map_q f :=
by { rcases h with ⟨q, T, H, c, z, u, mem⟩, simp, refine ⟨_, _, _, _, _, _, _⟩, simp[sentence.mem_def], refine ⟨_, mem, by simp⟩ }

lemma time_reductions.map_q {H} {n} (h : m₁ ⟶^(n)[σ] m₂) : m₁.map_q f ⟶^(n)[σ.map_q f H] m₂.map_q f :=
by { induction n with n IH generalizing m₂, { rcases h, simp },
     { rcases h with (_ | ⟨_, _, m₁₁, _, r₁_₁₁, r₁₁_₂⟩), refine (IH r₁_₁₁).succ (r₁₁_₂.map_q f) } }

lemma time_bounded_reduction.map_q {H} {k} (h : m₁ ⟶^(≤ k)[σ] m₂) : m₁.map_q f ⟶^(≤ k)[σ.map_q f H] m₂.map_q f :=
by { rcases h with ⟨n, le, r⟩, refine ⟨n, le, time_reductions.map_q f r⟩ }

variables {f}

lemma deterministic.map_q {H} (inj : function.injective f) (d : deterministic σ) : deterministic (σ.map_q f H) :=
begin
  rintros r x d₁ d₂ z₁ z₂ u₁ u₂ h₁ h₂,
  rcases h₁ with ⟨⟨c₁, z₁', u₁', q₁, x₁'⟩, mem₁, eq₁⟩,
  have : f c₁ = d₁ ∧ z₁ = z₁' ∧ u₁ = u₁' ∧ f q₁ = r ∧ x = x₁', { simp at eq₁, simp[eq₁] },
  rcases this with ⟨rfl, rfl, rfl, rfl, rfl⟩,
  rcases h₂ with ⟨⟨c₂, z₂', u₂', q₂, x₂'⟩, mem₂, eq₂⟩,
  have : f c₂ = d₂ ∧ z₂ = z₂' ∧ u₂ = u₂' ∧ f q₁ = f q₂ ∧ x = x₂', { simp at eq₂, simp[eq₂] },
  rcases this with ⟨rfl, rfl, rfl, eqn, rfl⟩,
  have : q₁ = q₂, from (inj eqn), rcases this with rfl,
  simp [d mem₁ mem₂]
end

end

variables {R : Type v} [state_lang R]

namespace sentence
variables {Q R} (q c : Q) (h : q ≠ halt ∧ c ≠ start)

inductive fix_q_aux : word Γ Q ι → Prop
| intro : ∀ (z : vector Γ ι), fix_q_aux ⟮c, z; instruction.Stay | q, z⟯

def fix_q (q c : Q) (h : q ≠ halt ∧ c ≠ start) : sentence Γ Q ι :=
{ carrier := fix_q_aux q c,
  proper' := λ c' z u q' x, by { rintros ⟨⟩, exact h } }

@[simp] lemma fix_q_mem (z : vector Γ ι) :
  ⟮c, z; instruction.Stay | q, z⟯ ∈ (fix_q q c h : sentence Γ Q ι) :=
fix_q_aux.intro _

lemma fix_q_mem_iff {c z u q x q₁ q₂ h} :
  ⟮c, z; u| q, x⟯ ∈ (fix_q q₁ q₂ h : sentence Γ Q ι) ↔ c = q₂ ∧ z = x ∧ q = q₁ ∧ u = instruction.Stay :=
⟨by { rintros ⟨⟩, simp; refl }, by { rintros ⟨rfl, rfl, rfl, rfl⟩, exact fix_q_aux.intro _ }⟩

lemma fix_q.deterministic : deterministic (fix_q q c h : sentence Γ Q ι) :=
by { rintros q' x c₁ c₂ z₁ z₂ u₁ u₂ h₁ h₂, rcases h₁, rcases h₂, simp }

@[simp] lemma fix_q_reduction (T : vector (ℕ → Γ) ι) (H : vector ℕ ι) : ⟦q, T, H⟧ ⟶¹[fix_q q c h] ⟦c, T, H⟧ :=
reduction.iff.mpr ⟨read T H, instruction.Stay, by simp, by simp⟩

instance : has_union (sentence Γ Q ι) := ⟨λ σ τ,
{ carrier := σ ∪ τ,
  proper' := by { rintros c z u q x (h | h), { exact σ.proper h }, { exact τ.proper h } } }⟩

def deterministic.union {σ τ : sentence Γ Q ι} (d₁ : deterministic σ) (d₂ : deterministic τ)
  (h : ∀ {q x c₁ c₂ z₁ z₂ u₁ u₂}, ⟮c₁, z₁; u₁ | q, x⟯ ∈ σ → ⟮c₂, z₂; u₂ | q, x⟯ ∈ τ → c₁ = c₂ ∧ z₁ = z₂ ∧ u₁ = u₂) :
  deterministic (σ ∪ τ) :=
begin
  rintros q x c₁ c₂ z₁ z₂ u₁ u₂ (h₁ | h₁) (h₂ | h₂),
  { exact d₁ h₁ h₂ }, { exact h h₁ h₂ }, { simp [h h₂ h₁] }, { exact d₂ h₁ h₂ }
end

instance : has_Sup (sentence Γ Q ι) := ⟨λ s,
{ carrier := ⋃₀ (carrier '' s),
  proper' := λ c z u q x h, by { simp at h, rcases h with ⟨σ, _, hσ⟩, exact σ.proper hσ } }⟩

lemma Sup_carrier (s : set (sentence Γ Q ι)) : ↑(Sup s) = ⋃₀ (carrier '' s) := by refl

lemma coe_supr {α : Sort*} {f : α → sentence Γ Q ι} : (↑(⨆ i, f i) : set (word Γ Q ι)) = ⋃ i, (f i) :=
by { unfold supr, rw [Sup_carrier], simp, refl }

def deterministic.Sup {s : set (sentence Γ Q ι)} (d : ∀ σ ∈ s, deterministic σ)
  (h : ∀ (σ ∈ s) (τ ∈ s) {q x c₁ c₂ z₁ z₂ u₁ u₂},
    ⟮c₁, z₁; u₁ | q, x⟯ ∈ σ → ⟮c₂, z₂; u₂ | q, x⟯ ∈ τ → c₁ = c₂ ∧ z₁ = z₂ ∧ u₁ = u₂) :
  deterministic (Sup s) :=
begin
  rintros q x c₁ c₂ z₁ z₂ u₁ u₂ ⟨_, ⟨σ, hσs, rfl⟩, hσ⟩ ⟨_, ⟨τ, hτs, rfl⟩, hτ⟩,
  refine h _ hσs _ hτs hσ hτ
end

def comp_suml (σ : sentence Γ Q ι) : sentence Γ (Q ⊕ R) ι := σ.map_q sum.inl (by { intros _ _ _ _ _ h, unfold halt start, simp[σ.proper h] })

def comp_sumr (τ : sentence Γ R ι) : sentence Γ (Q ⊕ R) ι := τ.map_q sum.inr (by { intros _ _ _ _ _ h, unfold halt start, simp[τ.proper h] })

def comp (σ : sentence Γ Q ι) (τ : sentence Γ R ι) : sentence Γ (Q ⊕ R) ι :=
(σ.map_q sum.inl (by { intros _ _ _ _ _ h, unfold halt start, simp[σ.proper h] })) ∪
(τ.map_q sum.inr (by { intros _ _ _ _ _ h, unfold halt start, simp[τ.proper h] })) ∪
(fix_q (sum.inl (halt : Q)) (sum.inr (start : R)) (by unfold halt start; simp))

infix ` ▷ `:80 := comp

lemma comp.deterministic {σ : sentence Γ Q ι} {τ : sentence Γ R ι}
  (d₁ : deterministic σ) (d₂ : deterministic τ) : deterministic (σ ▷ τ) :=
begin
  refine (deterministic.union (deterministic.union (deterministic.map_q sum.inl_injective d₁) (deterministic.map_q sum.inr_injective d₂) _)
           (fix_q.deterministic _ _ _) _),
  { rintros (q | r) _ _ _ _ _ _ _ ⟨⟨c₁, z₁, u₁, q, x⟩, mem₁, eqn₁⟩ ⟨⟨c₂, z₂, u₂, q', x'⟩, mem₂, eqn₂⟩,
    { simp at eqn₂, contradiction },
    { simp at eqn₁, contradiction } },
  { rintros _ _ _ _ _ _ _ _ (⟨⟨c, z, u, q, x⟩, mem, eqn⟩ | ⟨⟨c, z, u, q, x⟩, mem, eqn⟩) ⟨⟩,
    { simp at eqn, rcases eqn with ⟨rfl, rfl, rfl, rfl, rfl⟩, exfalso, simpa using mem },
    { simp at eqn, contradiction } }
end

def dsum (σ : sentence Γ Q ι) (τ : sentence Γ R ι) (c : Q → R → Prop) : sentence Γ (Q ⊕ R) ι :=
(σ.map_q sum.inl (by { intros _ _ _ _ _ h, unfold halt start, simp[σ.proper h] })) ∪
(τ.map_q sum.inr (by { intros _ _ _ _ _ h, unfold halt start, simp[τ.proper h] })) ∪
(⨆ (q : Q) (r : R) (h : c q r), (fix_q (sum.inl q) (sum.inr r) (by unfold halt start; simp)))

lemma dsum.deterministic {σ : sentence Γ Q ι} {τ : sentence Γ R ι}
  (d₁ : deterministic σ) (d₂ : deterministic τ) (c : Q → R → Prop)
  (dc : ∀ q r₁ r₂, c q r₁ → c q r₂ → r₁ = r₂)
  (hc : ∀ q r, c q r → σ.is_halt q) : deterministic (dsum σ τ c) :=
begin
  refine (deterministic.union
    (deterministic.union (deterministic.map_q sum.inl_injective d₁) (deterministic.map_q sum.inr_injective d₂) _)
      (deterministic.Sup _ _) _),
  { rintros (q | r) _ _ _ _ _ _ _ ⟨⟨c₁, z₁, u₁, q, x⟩, mem₁, eqn₁⟩ ⟨⟨c₂, z₂, u₂, q', x'⟩, mem₂, eqn₂⟩,
    { simp at eqn₂, contradiction },
    { simp at eqn₁, contradiction } },
  { rintros σ ⟨q, rfl⟩, show (⨆ r (h : c q r), fix_q (sum.inl q) (sum.inr r) _).deterministic,
    refine deterministic.Sup _ _,
    { rintros _ ⟨r, rfl⟩, refine deterministic.Sup (by simpa using λ _, fix_q.deterministic _ _ _) _,
      { rintros _ ⟨_, rfl⟩ _ ⟨_, rfl⟩ (q | r); { intros _ _ _ _ _ _ _ h₁ h₂, exact fix_q.deterministic _ _ _ h₁ h₂ } } },
    { rintros _ ⟨r₁, rfl⟩ _ ⟨r₂, rfl⟩ (q' | r');
      { rintros _ _ _ _ _ _ _ ⟨_, ⟨_, ⟨hc₁, rfl⟩, rfl⟩, h₁⟩ ⟨_, ⟨_, ⟨hc₂, rfl⟩, rfl⟩, h₂⟩,
        have : r₁ = r₂, from dc _ _ _ hc₁ hc₂, rcases this with rfl,
        exact fix_q.deterministic _ _ (by unfold halt start; simp) h₁ h₂ } } },
  { rintros _ ⟨q₁, rfl⟩ _ ⟨q₂, rfl⟩ (q | r),
    { rintros _ _ _ _ _ _ _
        ⟨_, ⟨_, ⟨r₁, rfl⟩, rfl⟩, ⟨_, ⟨_, ⟨hc₁, rfl⟩, rfl⟩, h₁⟩⟩
        ⟨_, ⟨_, ⟨r₂, rfl⟩, rfl⟩, ⟨_, ⟨_, ⟨hc₂, rfl⟩, rfl⟩, h₂⟩⟩,
      simp at h₁ h₂,
      have : c₁ = sum.inr r₁ ∧ z₁ = x ∧ q = q₁ ∧ u₁ = instruction.Stay,
      { simpa using fix_q_mem_iff.mp h₁, unfold halt start; simp },
      rcases this with ⟨rfl, rfl, rfl, rfl⟩,
      have : c₂ = sum.inr r₂ ∧ z₂ = z₁ ∧ q = q₂ ∧ u₂ = instruction.Stay,
      { simpa using fix_q_mem_iff.mp h₂, unfold halt start; simp },
      rcases this with ⟨rfl, rfl, rfl, rfl⟩,
      have : r₁ = r₂, from dc _ _ _ hc₁ hc₂, rcases this with rfl,
      simp },
    { simp,  rintros _ _ _ _ _ _ _
        ⟨_, ⟨_, ⟨r₁, rfl⟩, rfl⟩, ⟨_, ⟨_, ⟨hc₁, rfl⟩, rfl⟩, h₁⟩⟩ _,
      have : false, { simpa using (fix_q_mem_iff.mp h₁), unfold start halt; simp },
      contradiction } },
  { rintros (q | r),
    { rintros x _ _ _ _ _ _ (⟨⟨c₁, z₁, u₁, q₁, x₁⟩, wmem, hw⟩ | ⟨⟨c₁, z₁, u₁, q₁, x₁⟩, wmem, hw⟩),
      { simp at hw, rcases hw with ⟨rfl, rfl, rfl, rfl, rfl⟩,
        rintros ⟨_, ⟨_, ⟨q', rfl⟩, rfl⟩, ⟨_, ⟨_, ⟨r', rfl⟩, rfl⟩, H, ⟨_, ⟨hc', rfl⟩, rfl⟩, h₁⟩⟩,
        have : q₁ = q',
        { have := fix_q_mem_iff.mp h₁, simp at this, rcases this with ⟨rfl, rfl, rfl, rfl⟩; refl,
          unfold start halt; simp },
        rcases this with rfl,
        have : false := hc _ _ hc' wmem, contradiction },
      { simp at hw, contradiction } },
    { rintros x _ _ _ _ _ _ (⟨⟨c₁, z₁, u₁, q₁, x₁⟩, wmem, hw⟩ | ⟨⟨c₁, z₁, u₁, q₁, x₁⟩, wmem, hw⟩),
      { simp at hw, contradiction },
      { simp at hw, rcases hw with ⟨rfl, rfl, rfl, rfl, rfl⟩,
        rintros ⟨_, ⟨_, ⟨q', rfl⟩, rfl⟩, ⟨_, ⟨_, ⟨r', rfl⟩, rfl⟩, H, ⟨_, ⟨hc', rfl⟩, rfl⟩, h₁⟩⟩,
        have : false, { have := fix_q_mem_iff.mp h₁, simpa using this, unfold start halt; simp },
        contradiction } } }
end

end sentence

lemma time_reductions.comp_aux {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {n₁ n₂} {q r T₁ T₂ T₃ H₁ H₂ H₃}
  (h₁ : ⟦q, T₁, H₁⟧ ⟶^(n₁)[σ] ⟦halt, T₂, H₂⟧) (h₂ : ⟦start, T₂, H₂⟧ ⟶^(n₂)[τ] ⟦r, T₃, H₃⟧) :
  ⟦sum.inl q, T₁, H₁⟧ ⟶^(n₁ + n₂ + 1)[σ ▷ τ] ⟦sum.inr r, T₃, H₃⟧ :=
begin
  have h₁ : ⟦sum.inl q, T₁, H₁⟧ ⟶^(n₁)[σ ▷ τ] ⟦sum.inl halt, T₂, H₂⟧,
  from time_reductions.of_ss (time_reductions.map_q sum.inl h₁)
    (by { simp[(▷)], refine set.subset_union_of_subset_left (set.subset_union_left _ _) _,
          { intros _ _ _ _ _ h, unfold halt start, simp[σ.proper h] } }),
  have h : ⟦sum.inl halt, T₂, H₂⟧ ⟶¹[σ ▷ τ] ⟦sum.inr start, T₂, H₂⟧,
  from reduction.of_ss (sentence.fix_q_reduction _ _ _ _ _)
    (by { simp[(▷)], refine set.subset_union_right _ _, { unfold halt start; simp } }),
  have h₂ : ⟦sum.inr start, T₂, H₂⟧ ⟶^(n₂)[σ ▷ τ] ⟦sum.inr r, T₃, H₃⟧,
  from time_reductions.of_ss (time_reductions.map_q sum.inr h₂)
    (by { simp[(▷)], refine set.subset_union_of_subset_left (set.subset_union_right _ _) _,
          { intros _ _ _ _ _ h, unfold halt start, simp[τ.proper h] } }),
  simpa[show n₁.succ + n₂ = n₁ + n₂ + 1, by omega] using (h₁.succ h).add h₂
end

lemma time_reductions.comp {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {n₁ n₂ : ℕ} {T₁ T₂ T₃ H₁ H₂ H₃}
  (h₁ : ⟦start, T₁, H₁⟧ ⟶^(n₁)[σ] ⟦halt, T₂, H₂⟧) (h₂ : ⟦start, T₂, H₂⟧ ⟶^(n₂)[τ] ⟦halt, T₃, H₃⟧) :
  ⟦start,  T₁, H₁⟧ ⟶^(n₁ + n₂ + 1)[σ ▷ τ] ⟦halt, T₃, H₃⟧ :=
time_reductions.comp_aux h₁ h₂

lemma time_bounded_reductions.comp {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {k₁ k₂ : ℕ} {T₁ T₂ T₃ H₁ H₂ H₃}
  (h₁ : ⟦start, T₁, H₁⟧ ⟶^(≤ k₁)[σ] ⟦halt, T₂, H₂⟧) (h₂ : ⟦start, T₂, H₂⟧ ⟶^(≤ k₂)[τ] ⟦halt, T₃, H₃⟧) :
  ⟦start,  T₁, H₁⟧ ⟶^(≤ k₁ + k₂ + 1)[σ ▷ τ] ⟦halt, T₃, H₃⟧ :=
by { rcases h₁ with ⟨n₁, le₁, h₁⟩, rcases h₂ with ⟨n₂, le₂, h₂⟩, refine ⟨n₁ + n₂ + 1, by linarith, time_reductions.comp h₁ h₂⟩ }

lemma time_reductions.dsum_left {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {q₁ q₂ T₁ T₂ H₁ H₂} {n}
  (h : ⟦q₁, T₁, H₁⟧ ⟶^(n)[σ] ⟦q₂, T₂, H₂⟧) (φ : Q → R → Prop) :
  ⟦sum.inl q₁, T₁, H₁⟧ ⟶^(n)[sentence.dsum σ τ φ] ⟦sum.inl q₂, T₂, H₂⟧ :=
by exact time_reductions.of_ss (time_reductions.map_q sum.inl h)
    (by { simp, refine set.subset_union_of_subset_left (set.subset_union_left _ _) _,
          { intros _ _ _ _ _ h, unfold halt start, simp[σ.proper h] } })

lemma time_reductions.dsum_right {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {r₁ r₂ T₁ T₂ H₁ H₂} {n}
  (h : ⟦r₁, T₁, H₁⟧ ⟶^(n)[τ] ⟦r₂, T₂, H₂⟧) (φ : Q → R → Prop) :
  ⟦sum.inr r₁, T₁, H₁⟧ ⟶^(n)[sentence.dsum σ τ φ] ⟦sum.inr r₂, T₂, H₂⟧ :=
by exact time_reductions.of_ss (time_reductions.map_q sum.inr h)
    (by { simp, refine set.subset_union_of_subset_left (set.subset_union_right _ _) _,
          { intros _ _ _ _ _ h, unfold halt start, simp[τ.proper h] } })

lemma time_reductions.dsum {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {n₁ n₂} {q₁ q₂ r₂ r₃ T₁ T₂ T₃ H₁ H₂ H₃}
  (φ : Q → R → Prop) (h : φ q₂ r₂)
  (h₁ : ⟦q₁, T₁, H₁⟧ ⟶^(n₁)[σ] ⟦q₂, T₂, H₂⟧) (h₂ : ⟦r₂, T₂, H₂⟧ ⟶^(n₂)[τ] ⟦r₃, T₃, H₃⟧) :
  ⟦sum.inl q₁, T₁, H₁⟧ ⟶^(n₁ + n₂ + 1)[sentence.dsum σ τ φ] ⟦sum.inr r₃, T₃, H₃⟧ :=
begin
  have h₁ : ⟦sum.inl q₁, T₁, H₁⟧ ⟶^(n₁)[sentence.dsum σ τ φ] ⟦sum.inl q₂, T₂, H₂⟧,
  from time_reductions.dsum_left h₁ φ,
  have h : ⟦sum.inl q₂, T₂, H₂⟧ ⟶¹[sentence.dsum σ τ φ] ⟦sum.inr r₂, T₂, H₂⟧,
  from reduction.of_ss (sentence.fix_q_reduction _ _ _ _ _)
    (by { refine set.subset_union_of_subset_right _ _, { unfold halt start; simp },
      simp[sentence.coe_supr], refine set.subset_Union₃ q₂ r₂ h }),
  have h₂ : ⟦sum.inr r₂, T₂, H₂⟧ ⟶^(n₂)[sentence.dsum σ τ φ] ⟦sum.inr r₃, T₃, H₃⟧,
  from time_reductions.dsum_right h₂ φ,
  simpa[show n₁.succ + n₂ = n₁ + n₂ + 1, by omega] using (h₁.succ h).add h₂
end

lemma time_bounded_reductions.dsum {σ : sentence Γ Q ι} {τ : sentence Γ R ι} {n₁ n₂} {q₁ q₂ r₂ r₃ T₁ T₂ T₃ H₁ H₂ H₃}
  (φ : Q → R → Prop) (h : φ q₂ r₂)
  (h₁ : ⟦q₁, T₁, H₁⟧ ⟶^(≤ n₁)[σ] ⟦q₂, T₂, H₂⟧) (h₂ : ⟦r₂, T₂, H₂⟧ ⟶^(≤ n₂)[τ] ⟦r₃, T₃, H₃⟧) :
  ⟦sum.inl q₁, T₁, H₁⟧ ⟶^(≤ n₁ + n₂ + 1)[sentence.dsum σ τ φ] ⟦sum.inr r₃, T₃, H₃⟧ :=
by{ rcases h₁ with ⟨n₁, le₁, h₁⟩, rcases h₂ with ⟨n₂, le₂, h₂⟩,
    refine ⟨n₁ + n₂ + 1, by linarith, time_reductions.dsum φ h h₁ h₂⟩ }

end model

namespace blang
open instruction model
variables (Γ Q ι) [inhabited Γ] [bfin Γ]

def list_less_than (k : ℕ) := {l : list (option bool) // l.length ≤ k}

instance (k : ℕ) : inhabited (list_less_than k) := ⟨⟨[], by simp⟩⟩

namespace read

inductive state
| intro (q : Q) (i : fin (bentropy Γ).succ) (v : vector (vector bool (bentropy Γ)) ι) : state

variables {Γ Q ι}

instance [state_lang Q] : state_lang (state Γ Q ι) :=
⟨state.intro start 0 default, state.intro halt ⊤ default⟩

def δ : state Γ Q ι → vector bool ι → option (state Γ Q ι × vector bool ι × vector instruction ι)
| ⟨q, i, v⟩ x := if h : i < ⊤ then
    let newstate : state Γ Q ι :=
      ⟨q, ⟨i + 1, nat.succ_lt_succ (fin.lt_top_iff.mp h)⟩, (v.sim_update_nth (vector.rep ⟨i, fin.lt_top_iff.mp h⟩) x)⟩ in
  some ⟨newstate, x, Right⟩ else none

@[simp] lemma δ_top {q v x} : δ (⟨q, ⊤, v⟩ : state Γ Q ι) x = none := by simp[δ]

def σ : sentence bool (state Γ Q ι) ι := sentence.of_fun δ
(by { unfold start halt,
      intros q x c z u eqn, split; rintros rfl,
      { simpa using eqn },
      { rcases q with ⟨q, i, v⟩, by_cases C : i < ⊤; simp[C, δ, fin.ext_iff] at eqn; contradiction } })

section
variables (v : vector (vector bool (bentropy Γ)) ι) (T : vector (ℕ → bool) ι) (H : vector ℕ ι)

lemma σ_reduction (q : Q) (i : fin (bentropy Γ).succ) (h : i < ⊤) :
  ⟦⟨q, i, v⟩, T, H⟧ ⟶¹[σ]
  ⟦⟨q, ⟨i + 1, nat.succ_lt_succ (fin.lt_top_iff.mp h)⟩,
    v.sim_update_nth (vector.rep ⟨i, fin.lt_top_iff.mp h⟩) (read T H)⟩, T, H.map nat.succ⟧ :=
reduction.iff.mpr (⟨read T H, Right, by simp[σ, δ, h], by simp, by ext; simp⟩)

@[simp] lemma σ_is_halt (q : Q) (v : vector (vector bool (bentropy Γ)) ι) : σ.is_halt ⟨q, ⊤, v⟩ :=
by intros c z u x; simp[σ]

def memory :
  fin (bentropy Γ).succ → vector (vector bool (bentropy Γ)) ι
| ⟨0, _⟩      := v
| ⟨s + 1, hn⟩ := (memory ⟨s, by omega⟩).sim_update_nth (vector.rep ⟨s, by omega⟩) (read T (H.map ((+) s)))

@[simp] lemma memory_0 : memory v T H 0 = v := by unfold has_zero.zero; rw [memory]

lemma σ_time_reductions (q : Q) :
  ∀ (s : fin (bentropy Γ).succ), ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, s, memory v T H s⟩, T, H.map ((+) s)⟧
| ⟨0, _⟩      := by { simp, ext, simp, }
| ⟨s + 1, hs⟩ := by {
    let s' : fin (bentropy Γ).succ := ⟨s, by omega⟩,
    have r : ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, ⟨s, _⟩, memory v T H ⟨s, _⟩⟩, T, H.map ((+) s)⟧,
    from σ_time_reductions ⟨s, by omega⟩,
    have : ⟦⟨q, ⟨s, _⟩, memory v T H ⟨s, _⟩⟩, T, H.map ((+) s)⟧ ⟶¹[σ] ⟦⟨q, ⟨s + 1, _⟩, memory v T H ⟨s + 1, _⟩⟩, T, _⟧,
    by simpa[memory] using
      σ_reduction (memory v T H s') T (H.map ((+) s)) q s' (by simp[fin.lt_top_iff]; exact nat.succ_lt_succ_iff.mp hs),
    rw [show (H.map ((+) s)).map nat.succ = H.map ((+) s.succ), by ext; simp[nat.succ_add]] at this,
    exact r.succ this }

lemma memory_nth_nth_of_lt : ∀ (s : fin (bentropy Γ).succ) k i (h : ↑i < s),
  ((memory v T H s).nth k).nth i = T.nth k (i + H.nth k)
| ⟨0, _⟩ k i hi := by simp at hi; contradiction
| ⟨s + 1, hs⟩ k ⟨i, hi⟩ h := by {
    have : i = s ∨ i < s, from eq_or_lt_of_le (nat.lt_succ_iff.mp (by simpa using h)),
    rcases this with (rfl | lt); simp[memory, vector.nth_sim_update_nth_if],
    { have : s ≠ i, from ne_of_gt lt,
      simp[this],
      simpa using memory_nth_nth_of_lt ⟨s, lt_trans (lt_add_one s) hs⟩ k ⟨i, hi⟩ (by simpa using lt) } }

lemma σ_time_reductions_top (q : Q) : ⟦⟨q, 0, v⟩, T, H⟧ ⟶^(bentropy Γ)[σ] ⟦⟨q, ⊤, memory v T H ⊤⟩, T, H.map ((+) (bentropy Γ))⟧ :=
σ_time_reductions v T H q ⊤

lemma memory_nth_nth (k i) : ((memory v T H ⊤).nth k).nth i = T.nth k (i + H.nth k) :=
memory_nth_nth_of_lt v T H ⊤ k i (by simp[fin.lt_top_iff]; exact fin.is_lt i)

end

end read

namespace write

inductive state
| intro (q : Q) (i : fin (bentropy Γ).succ) (v : vector (vector bool (bentropy Γ)) ι) (u : vector instruction ι) : state

variables {Γ Q ι}

instance [state_lang Q] : state_lang (state Γ Q ι) :=
⟨state.intro start ⊤ default Stay, state.intro halt 0 default Stay⟩

def δ : state Γ Q ι → vector bool ι → option (state Γ Q ι × vector bool ι × vector instruction ι)
| ⟨q, ⟨0, _⟩, v, u⟩      x := none
| ⟨q, ⟨i + 1, hi⟩, v, u⟩ x :=
    let newstate : state Γ Q ι := ⟨q, ⟨i, by omega⟩, v, u⟩,
        i' : fin (bentropy Γ)  := ⟨i, nat.succ_lt_succ_iff.mp hi⟩ in
  some ⟨newstate, v.map (λ x, x.nth i'), Left⟩

@[simp] lemma δ_top {q v x u} : δ (⟨q, 0, v, u⟩ : state Γ Q ι) x = none := by unfold has_zero.zero; rw [δ]

def σ : sentence bool (state Γ Q ι) ι := sentence.of_fun δ
(by { unfold start halt,
      intros q x c z u eqn, split; rintros rfl,
      { simpa using eqn },
      { rcases q with ⟨q, ⟨i, hi⟩, v, u⟩, rcases i; simp[δ] at eqn,
        { contradiction },
        { have lt : i < bentropy Γ, from nat.succ_lt_succ_iff.mp hi,
          have eq : i = bentropy Γ, by simpa[fin.coe_top] using (fin.eq_iff_veq _ _).mp eqn.1.2.1,
          simp[eq] at lt, contradiction } } })

section
variables (v : vector (vector bool (bentropy Γ)) ι) (u : vector instruction ι) (T : vector (ℕ → bool) ι) (H : vector ℕ ι)

def σ_tape_reduct (i) :=
vector.zip_with3 (λ (t : ℕ → bool) h (x : vector bool (bentropy Γ)) n, if n = h then x.nth i else t n) T H v

lemma σ_reduction (q : Q) (i : ℕ) (hi) :
  ⟦⟨q, ⟨i + 1, hi⟩, v, u⟩, T, H⟧ ⟶¹[σ]
  ⟦⟨q, ⟨i, by omega⟩, v, u⟩, σ_tape_reduct v T H ⟨i, nat.succ_lt_succ_iff.mp hi⟩, H.map nat.pred⟧ :=
reduction.iff.mpr (⟨v.map (λ x, x.nth ⟨i, (by omega)⟩), Left, by simp[σ, δ]; refl,
  by { simp[reduct_tape, σ_tape_reduct], ext, simp }, by { ext, simp, exact nat.pred_eq_sub_one _ }⟩)

@[simp] lemma σ_is_halt (q : Q) : σ.is_halt ⟨q, 0, v, u⟩ :=
λ c z u x, by simp[σ]

def Tape : fin (bentropy Γ).succ → vector (vector bool (bentropy Γ)) ι → vector (ℕ → bool) ι → vector ℕ ι → vector (ℕ → bool) ι
| ⟨0, _⟩      v T H := T
| ⟨s + 1, hn⟩ v T H := Tape ⟨s, by omega⟩ v (σ_tape_reduct v T H ⟨s, nat.succ_lt_succ_iff.mp hn⟩) (H.map nat.pred)

@[simp] lemma Tape_0 : Tape 0 v T H = T := by unfold has_zero.zero; rw [Tape]

lemma σ_time_reductions (q : Q) :
  ∀ (s : fin (bentropy Γ).succ) (T H), ⟦⟨q, s, v, u⟩, T, H⟧ ⟶^(s)[σ] ⟦⟨q, 0, v, u⟩, Tape s v T H, (H.map (λ h, h - s))⟧
| ⟨0, _⟩      T H := by { simp, ext, simp }
| ⟨s + 1, hs⟩ T H := by {
    let s' : fin (bentropy Γ).succ := ⟨s, by omega⟩,
    let s'' : fin (bentropy Γ) := ⟨s, by { exact nat.succ_lt_succ_iff.mp hs}⟩,
    have r : ⟦⟨q, ⟨s, _⟩, v, u⟩, _, H.map nat.pred⟧ ⟶^(s)[σ] ⟦⟨q, 0, v, u⟩, _, H.map (λ h, h - (s + 1))⟧,
    { have := σ_time_reductions ⟨s, by omega⟩ (σ_tape_reduct v T H ⟨s, by omega⟩) (H.map nat.pred), simp at this,
      rw[show (H.map nat.pred).map (λ h, h - s) = H.map (λ h, h - (s + 1)),
         by { ext; simp;  rw[nat.pred_sub, nat.pred_eq_sub_one, tsub_tsub] }] at this,
      exact this },
    have : ⟦⟨q, ⟨s + 1, _⟩, v, u⟩, T, H⟧ ⟶¹[σ] ⟦⟨q, ⟨s, _⟩, v, u⟩, _, H.map nat.pred⟧,
    from σ_reduction v u T H q s hs,
    have : ⟦⟨q, ⟨s + 1, _⟩, v, u⟩, T, H⟧ ⟶^(s+1)[σ] ⟦⟨q, 0, v, u⟩, _, H.map (λ h, h - (s + 1))⟧,
    from relation.power.succ_inv this r,
    simpa[Tape, @sub_add_eq_sub_sub ℕ] using this }

end

end write

end blang

namespace universal_tm
variables {Γ Q ι}

abbreviation lang := word Γ Q ι ⊕ vector Γ ι

end universal_tm

end turing_machine


/-
# Message Fields

Building on the basic data definitions in [Core](Core.md), this module defines the message
fields that group together related information, and which in turn are combined to
define the messages.

For each field example text from an ATS message is provided, together with the corresponding
Lean value. Lean has a variety of ways to populate structure values, and all variants are
demonstrated.
-/

import LeanSpec.FPL.Core
import LeanSpec.lib.Temporal

open Core Temporal

namespace FPL.Field

/-
## Field 7: Aircraft identification and SSR mode and code

Field 7 is concerned with how a flight is identified for communication with air traffic control.
-/
structure Field7 where
  f7a  : AircraftIdentification
  f7bc : Option SsrCode

/-
### Field 7 Example

`-SAS912/A5100`
-/
example := Field7.mk ⟨"SAS912", by simp⟩ (some ⟨"5100", by simp⟩)

/-
## Field 8: Flight rules and type of flight

Field 8 provides information that determines how a flight is handled.
-/
structure Field8 where
  f8a : FlightRules
  f8b : Option TypeOfFlight

/-
### Field 8 Example

`-IS`
-/
example := Field8.mk .i (some .s)

/-
## Field 9: Number and type of aircraft and wake turbulence category

Field 9 provides information about the aircraft that will be used to conduct the flight.
-/
structure Field9 where
  f9a : Option NumberOfAircraft    -- only included for formation flights
  f9b : Option Doc8643.Designator  -- `none` indicates ZZZZ (refer field 18 TYP)
  f9c : WakeTurbulenceCategory

/-
`-2FK27/M`
-/
example := Field9.mk (some ⟨2, by simp⟩) (some ⟨"FK27", by simp⟩) .m

/-
### Field 9 Example

`-ZZZZ/L`
-/
example := Field9.mk none none .l

/-
## Field 10: Equipment and capabilities

Field 10 documents what equipment and capabilities the flight/aircraft has.
These items communicate what air traffic control can expect of the flight,
and limitations placed on the flight.
-/

structure Field10 where
  f10a : List CommNavAppCode    -- empty list indicates `N`
  f10b : List SurveillanceCode  -- empty list indicates `N`
  -- Exclude invalid combinations.
  inv  : ¬ (.b1 ∈ f10b ∧ .b2 ∈ f10b) ∧
         ¬ (.u1 ∈ f10b ∧ .u2 ∈ f10b) ∧
         ¬ (.v1 ∈ f10b ∧ .v2 ∈ f10b)

/-
### Field 10 Example

`-SAFR/SV1`
-/
example := (⟨[.s, .a, .f, .r], [.s, .v1], by simp⟩ : Field10)

/-
## Field 13: Departure aerodrome and time

Field 13 concerns the departure point and departure time of the flight.

A flight plan can be filed in the air, in which case AFIL is specified in the
departure point field.
-/
inductive ADep
  | adep (_ : Doc7910.Designator)
  | afil
deriving DecidableEq

def Field13a := Option ADep  -- `none` indicates ZZZZ (refer field 18 DEP)

structure Field13 where
  f13a : Field13a
  f13b : DTG

/-
### Field 13 Examples

`-EHAM0730`
-/
example := Field13.mk (some (.adep ⟨"EHAM", by simp⟩)) 63072027000

/-
`-AFIL1625`
-/
example : Field13 := ⟨some .afil, 63072059100⟩

/-
The designator in Field 13, if there is one.
-/
def Field13.desigOf : Field13 → Option Doc7910.Designator
  | ⟨some (.adep desig), _⟩ => desig
  | _                       => none

/-
## Field 15: Route

Field 15 describes the route the aircraft will follow to go from departure to destination.
This includes the level/altitude the flight operates at, and the speed of the aircraft.

Climbing between two levels, the upper limit can be specified, or _PLUS_ used to
indicate there is no nominated upper level.
-/
inductive UpperLevel
  | level (_ : VerticalPositionOfAircraft)
  | plus

/-
Indication of the change in speed and level.
-/
structure SpeedLevelChange where
  speed : TrueAirspeed
  level : VerticalPositionOfAircraft
  upper : Option UpperLevel

/-
### Speed/Level Change Example

`N0540A055PLUS`
-/
example : SpeedLevelChange where
  speed := ⟨⟨⟨540, sorry⟩, .kt, .ias, by simp⟩, sorry⟩
  level := ⟨5500, .feet, .altitude⟩
  upper := some .plus

/-
A specific point along the route, together with changes to speed, level and flight rules
planned to occur at the point.
-/
structure RoutePoint where
  pos  : Position
  chg  : Option SpeedLevelChange
  frul : Option FlightRule

/-
Between two points on a route, the aircraft can follow a documented ATS route, or
proceed directly.
-/
inductive Connector
  | rte (_ :RouteDesignator)
  | dct

/-
A route element is a point (and associated data) followed by the path to
the next element. Either, but not both, may be omitted.
-/
structure RouteElement where
  point : Option RoutePoint
  rte   : Option Connector
  -- At least one of point or connecting route must be populated.
  inv   : ¬ (point.isNone ∧ rte.isNone)

/-
The named waypoint in a route element, if there is one.
-/
def RouteElement.waypointOf : RouteElement → Option Waypoint
  | ⟨some rp, _, _⟩ => rp.pos.waypointOf
  | _               => none

/-
The ATS route designator in a route element, if there is one.
-/
def RouteElement.atsRteOf : RouteElement → Option RouteDesignator
  | ⟨_, some (.rte rd), _⟩ => rd
  | _                      => none

/-
Does the route element indicate _direct_ to the next point?
-/
def RouteElement.isDct : RouteElement → Bool
  | ⟨_, some .dct, _⟩ => true
  | _                 => false

/-
The flight rules change in a route element, if there is one.
-/
def RouteElement.ruleOf : RouteElement → Option FlightRule
  | ⟨some rp, _, _⟩ => rp.frul
  | _               => none

/-
Indicator the route description has been truncated.
-/
inductive Truncate | t

/-
The route consists of:
- optional standard instrument departure (SID);
- the non-empty list of elements;
- optional standard arrival route (STAR) or truncation indicator.
-/
structure Route where
  sid            : Option RouteDesignator
  elements       : List RouteElement
  starOrTruncate : Option (RouteDesignator ⊕ Truncate)
  -- Must be at least one route element.
  inv            : elements ≠ ∅ ∧
  -- Consecutive flight rules changes must be distinct.
                   let rules := (elements.map RouteElement.ruleOf).reduceOption
                   rules.Chain' (· ≠ ·) ∧
  -- DCT must be followed by an explicit point.
                   elements.Chain' (·.isDct → ·.point.isSome) ∧
  -- An ATS route designator must connect to another designator or a named point.
                   elements.Chain'
                     (fun re₁ re₂ ↦ re₁.atsRteOf.isSome →
                        re₂.waypointOf.isSome ∨ (re₂.point.isNone ∧ re₂.atsRteOf.isSome))

/-
The list of named waypoints in a route.
-/
def Route.waypoints (rte : Route) : List Waypoint :=
  (rte.elements.map RouteElement.waypointOf).reduceOption

/-
Field 15 consists of:
- the initial requested cruising speed;
- the initial requested cruising level;
- the route description.
-/
structure Field15 where
  f15a : TrueAirspeed
  f15b : Option VerticalPositionOfAircraft  -- `none` indicates VFR
  f15c : Route

/-
### Field 15 Example

`-M079F380 DCT WOL H65 RAZZI Q29 LIZZI DCT`
-/
def exElems := [
  RouteElement.mk none (some .dct) (by simp),
  RouteElement.mk (mkWpt ⟨"WOL", by simp⟩) (some (.rte ⟨"H65", by simp⟩)) (by simp),
  RouteElement.mk (mkWpt ⟨"RAZZI", by simp⟩) (some (.rte ⟨"Q29", by simp⟩)) (by simp),
  RouteElement.mk (mkWpt ⟨"LIZZI", by simp⟩) (some .dct) (by simp)
]
where mkWpt (wpt : Waypoint) : Option RoutePoint :=
  some ⟨.wpt wpt, none, none⟩

example := {
  f15a := ⟨⟨⟨0.79, sorry⟩, .mach, .tas, by simp⟩, by simp⟩,  -- M079
  f15b := some ⟨380, .feet, .flightLevel⟩,                   -- F380
  f15c := ⟨none, exElems, none, sorry⟩ : Field15             -- DCT WOL H65 RAZZI Q29 LIZZI DCT
}

/-
## Field 16: Destination aerodrome and total estimated elapsed time, destination alternate aerodrome(s)

Field 16 concerns the destination aerodrome, the flight time, and alternate destinations in the event
diversion is required.
-/
def Field16a := Option Doc7910.Designator  -- `none` indicates ZZZZ (refer field 18 DEST)

/-
Up to two alternates are allowed.
-/
def maxAlternateDestinations := 2

/-
Field 16 consists of:
- the planned destination aerodrome;
- the total estimated elapsed time (TEET) - i.e. the estimated flight duration;
- alternate destination aerodromes in case of a diversion.
-/
structure Field16 where
  f16a : Field16a
  f16b : Duration
  f16c : List Field16a
  -- TEET must be less than one day.
  inv  : f16b < Duration.oneDay ∧
  -- Upper limit on number of alternate aerodromes.
         f16c.length ≤ maxAlternateDestinations

/-
### Field 16 Example

`-EHAM0645 EBBR ZZZZ`
-/
example := Field16.mk (some ⟨"EHAM", by simp⟩) 24300 [some ⟨"EBBR", by simp⟩, none] (by simp)

/-
Are a departure and destination aerodrome the same?
-/
def adepIsAdes : Field13a → Field16a → Bool
  | none, none                       => True
  | some (.adep desig₁), some desig₂ => desig₁ = desig₂
  | _, _                             => False

/-
## Field 17: Arrival aerodrome and time

Field 17 concerns the actual arrival point and time, which will differ from the
planned destination in the event of a diversion.

Field 17 consists of:
- the actual arrival aerodrome designator;
- the actual arrival time;
- the name of the arrival aerodrome, if it has no designator.
-/

structure Field17 where
  f17a : Option Doc7910.Designator  -- `none` indicates ZZZZ
  f17b : DTG
  f17c : Option FreeText
  -- Exactly one of designator and aerodrome name must be populated.
  inv  : f17a.isNone ↔ f17c.isSome

/-
### Field 17 Example

`-ZZZZ1620 DEN HELDER`
-/
example := Field17.mk none 63072058800 (some ⟨"DEN HELDER", by simp⟩)

/-
## Field 18: Other information

Field 18 contains diverse other information about the flight.

The flight plan framework is presently undergoing major revision to benefit from the latest
information management best practices. The extant flight plan format has largely remained
unchanged for over 50 years. Allowed changes are limited by the the need for backwards
compatibility. As a result, additional information has typically been added as extra
data in field 18, with the result it is a rather disparate collection. It also means
that related information is recorded in separate parts of the message. For example, codes
that indicate navigation capability are presented in field 10a, but more recent Performance
Based Navigation (PBN) codes appears in item _PBN_ of field 18.

Up to 8 PBN codes may be specified.
-/
def maxPbnCodes := 8

/-
The elapsed time from departure to a point en-route. Usually a point where control is passed
between ATS providers.
-/
structure ElapsedTimePoint where
  point    : Doc7910.FIRDesignator ⊕ Position
  duration : Duration

/-
The `<` order relation on EET points. Ordered by the duration.
-/
instance : LT ElapsedTimePoint where
  lt et₁ et₂ := LT.lt et₁.duration et₂.duration

/-
The `<` relation is decidable.
-/
instance (x y : ElapsedTimePoint) : Decidable (x < y) :=
  inferInstanceAs (Decidable (x.duration < y.duration))

/-
A point on the route where a delay occurs. The flight goes _off plan_ for
the duration. An example is a law enforcement flight that intends to conduct
covert operations and does not want to provide details of where it is flying.
-/
structure DelayPoint where
  point    : Waypoint
  duration : Duration

/-
The route to an alternate destination if the flight decides to divert en-route.
-/
structure RouteToRevisedDestination where
  destination : Doc7910.Designator
  route       : FreeText

/-
The various items that make up field 18.
-/
structure Field18 where
  sts  : List SpecialHandling
  pbn  : List PBNCode
  nav  : Option FreeText
  com  : Option FreeText
  dat  : Option FreeText
  sur  : Option FreeText
  dep  : Option (NameAndPosition ⊕ ATSUnit)
  dest : Option NameAndPosition
  reg  : List Registration
  eet  : List ElapsedTimePoint
  sel  : Option SelcalCode
  typ  : List (Option NumberOfAircraft × AircraftType)
  code : Option AircraftAddress
  dle  : List DelayPoint
  opr  : Option FreeText
  orgn : Option FreeText
  per  : Option AircraftPerformance
  altn : List NameAndPosition
  ralt : List LandingSite
  talt : List LandingSite
  rif  : Option RouteToRevisedDestination
  rmk  : Option FreeText
  -- Upper limit on number of PBN codes.
  inv  : pbn.length ≤ maxPbnCodes ∧
  -- Upper limit on number of alternate aerodromes.
         altn.length ≤ maxAlternateDestinations ∧
  -- EETs must be presented in ascending order.
         eet.ascendingStrict

/-
### Field 18 Example

`-PBN/A1B1C1D1O2S2T1 NAV/RNP2 REG/VHXYZ SEL/AFPQ CODE/7C6DDF OPR/FLYOU ORGN/YSSYABCO PER/C`
-/
example : Field18 := {
  sts := [],
  pbn := [.a1, .b1, .c1, .d1, .o2, .s2, .t1],
  nav := some ⟨"RNP2", by simp⟩,
  com := none,
  dat := none,
  sur := none,
  dep := none,
  dest := none,
  reg := [⟨"VHXYZ", by simp⟩]
  eet := [],
  sel := some ⟨"AFPQ", by simp⟩,
  typ := [],
  code := some ⟨"7C6DDF", by simp⟩,
  dle := [],
  opr := some ⟨"FLYOU", by simp⟩,
  orgn := some ⟨"YSSYABCO", by simp⟩,
  per := some .c,
  altn := [],
  ralt := [],
  talt := [],
  rif := none,
  rmk := none,
  inv := sorry
}

/-
## Field 22: Amendment

Field 22 specifies changes to an existing flight plan.
If any part of a field changes, the entire content of the new field
must be included in field 22, not just the sub-item that is changing.
-/
structure Field22 where
  f7  : Option Field7
  f8  : Option Field8
  f9  : Option Field9
  f10 : Option Field10
  f13 : Option Field13
  f15 : Option Field15
  f16 : Option Field16
  f18 : Option Field18
  -- At least one amendment must be specified.
  inv : ¬ (f7.isNone ∧f8.isNone ∧ f9.isNone ∧ f10.isNone ∧ f13.isNone ∧ f15.isNone ∧ f16.isNone ∧ f18.isNone)

/-
### Field 22 Example

`-8/IX-13/EDDN1230`
-/
example : Field22 where
  f7 := none
  f8 := some ⟨.i, some .x⟩
  f9 := none
  f10 := none
  f13 := some ⟨some (.adep ⟨"EDDN", by simp⟩), 63072027000⟩
  f15 := none
  f16 := none
  f18 := none
  inv := by simp

/-
## Consistency checks between fields

As noted earlier, the legacy nature of the flight planning messages means related information
is spread across disparate fields. As a result a number of constraints are required to ensure
consistency between fields. The majority of these relate to the relationship between field 18
other fields.

### Fields 8 and 15 (requested level)

 - If initial requested cruising level is VFR, initial flight rules must be V or Z.
-/
def F8F15Level : Field8 → Field15 → Prop
  | f8, ⟨_, none, _⟩ => f8.f8a ∈ [.v, .z]
  | _, _             => True

/-
### Fields 8 and 15 (flight rules)

- Rule changes only allowed if initial rules is Y or Z.
- If initial rules is Y (IFR first), first change must be to VFR.
- If initial rules is Z (VFR first), first change must be to IFR.
-/
def F8F15Rule (f8 : Field8) (f15 : Field15) : Prop :=
  match (f15.f15c.elements.map RouteElement.ruleOf).reduceOption with
  | []        => f8.f8a ∈ [.i, .v]
  | .vfr :: _ => f8.f8a = .y
  | .ifr :: _ => f8.f8a = .z

/-
### Fields 9 and 18 (TYP)

- If designator in field 9b, field 18 TYP not populated.
- If ZZZZ in field 9b, aircraft type in field 18 TYP.
-/
def F9F18Typ : Field9 → Option Field18 → Prop
  | -- If designator in 9b, 18 TYP not populated.
    {f9b := some _, ..}, none
  | {f9b := some _, ..}, some {typ := [], ..}
  | -- If ZZZZ in 9b, must have aircraft type in 18 TYP.
    {f9b := none, ..}, some {typ := _::_, ..} => True
  | -- Any other combination is invalid.
    _, _                                      => False

/-
### Fields 10 and 18 (STS)

- Can't specify W (RVSM capable) in Field 10a and NONRVSM on Field 18 STS.
-/
def F10F18Sts : Field10 → Option Field18 → Prop
  | f10, some f18 => ¬ (.w ∈ f10.f10a ∧ .nonrvsm ∈ f18.sts)
  | _, _          => True

/-
### Fields 10 and 18 (PBN)

- If R specified in field 10a, PBN capability must be provided in Field 18 PBN.
-/
def F10F18Pbn : Field10 → Option Field18 → Prop
  | f10, none     => .r ∉ f10.f10a
  | f10, some f18 => .r ∈ f10.f10a ↔ f18.pbn ≠ ∅

/-
### Fields 10 and 18 (COM/NAV/DAT)

- If Z specified in field 10a, other information must be provided in at least one of COM,
NAV or DAT in Field 18.
-/
def F10F18Z : Field10 → Option Field18 → Prop
  | f10, none     => .z ∉ f10.f10a
  | f10, some f18 => .z ∈ f10.f10a ↔ f18.com.isSome ∨ f18.nav.isSome ∨ f18.dat.isSome

/-
### Fields 13 and 18 (DEP)

- If designator in field 13a, field 18 DEP not populated.
- If ZZZZ in field 13a, departure point in field 18 DEP.
- If AFIL in field 13a, ATS unit in field 18 DEP.
-/
def F13F18Dep : Field13 → Option Field18 → Prop
  | -- If designator in 13a, 18 DEP not populated.
    ⟨(some (.adep _)), _⟩, none
  | ⟨some (.adep _), _⟩, some {dep := none, ..}
  | -- If ZZZZ in 13a, must have departure point in 18 DEP.
    ⟨none, _⟩, some {dep := some (.inl _), ..}
  | -- If AFIL in 13a, must have ATS unit in 18 DEP.
    ⟨some .afil, _⟩, some {dep := some (.inr _), ..} => True
  | -- Any other combination is invalid.
    _, _                                             => False

/-
### Fields 15 and 18 (DLE)

- A delay point must be explicitly named in the route.
-/
def F15F18Dle : Field15 → Option Field18 → Prop
  | f15, some f18 => f18.dle.map (·.point) ⊆ f15.f15c.waypoints
  | _, _          => True

/-
### Fields 16 and 18 (DEST)

- If designator in field 16a, field 18 DEST not populated.
- If ZZZZ in field 16a, destination point in field 18 DEST.
-/
def F16F18Dest : Field16 → Option Field18 → Prop
  | -- If designator in 16a, 18 DEST not populated.
    {f16a := some _, ..}, none
  | {f16a := some _, ..}, some {dest := none, ..}
  | -- If ZZZZ in 16a, must have destination point in 18 DEST.
    {f16a := none, ..}, some {dest := some _, ..} => True
  | -- Any other combination is invalid.
    _, _                                          => False

/-
### Fields 16 and 18 (EET)

- All EETs must be less than the flight duration.
-/
def F16F18Eet : Field16 → Option Field18 → Prop
  | {f16b := teet, ..}, some f18 => f18.eet.all (·.duration < teet)
  | _, _                         => True

/-
### Fields 16 and 18 (DLE)

- The sum of the delays at the route points must be less than the flight duration.
-/
def F16F18Dle : Field16 → Option Field18 → Prop
  | {f16b := teet, ..}, some f18 => (f18.dle.map (·.duration)).add 0 < teet
  | _, _                         => True

/-
### Fields 16 and 18 (ALTN)

- For each ZZZZ entry in Field 16c, there must be a corresponding entry in Field 18 ALTN.
-/
def F16F18Altn : Field16 → Option Field18 → Prop
  | {f16c := [], ..}, none => True
  | {f16c := altn16, ..}, some {altn := altn18, ..}
                           => (altn16.filter (·.isNone)).length = altn18.length
  | _, _                   => False

/-
### Fields 16 and 17 (destination and arrival)

- Destination, if provided, must differ from actual arrival aerodrome.
-/
def F16F17Dest : Field16a → Option Field17 → Prop
  | some dest, some {f17a := some arr, ..} => dest ≠ arr
  | _, _                                   => True

end FPL.Field