import computability.partrec
import computability.partrec_code
import data.pfun
import tactic
import rpartrec
import rcomputability_tactic

open encodable denumerable part

@[simp] lemma eval_eval_opt {α β} (f : α →. β) [D : decidable_pred f.dom] {x} :
  @pfun.eval_opt _ _ f D x = @part.to_option _ (f x) (D x) := rfl

@[simp] theorem mem_to_option' {α} {o : part α} [decidable o.dom] {a : α} :
  to_option o = some a ↔ a ∈ o := mem_to_option

theorem mem_to_option_none {α} {o : part α} [D : decidable o.dom] {a : α} :
  to_option o = none ↔ o = none :=
by { unfold to_option, by_cases h : o.dom; simp [h],
     { exact λ h0, part.eq_none_iff'.mp h0 h },
     { exact part.eq_none_iff'.mpr h } }

namespace nat.rpartrec

inductive code : Type
| oracle : code
| zero   : code
| succ   : code
| left   : code
| right  : code
| pair   : code → code → code
| comp   : code → code → code
| prec   : code → code → code
| rfind' : code → code

end nat.rpartrec

namespace nat.rpartrec.code
open nat (mkpair unpair) nat.rpartrec (code)

protected def const : ℕ → code
| 0     := zero
| (n+1) := comp succ (const n)

protected def id : code := pair left right

def curry (c : code) (n : ℕ) : code :=
comp c (pair (code.const n) code.id)

def ctrans (c : code) : code → code
| oracle       := c
| zero         := zero
| succ         := succ
| left         := left
| right        := right
| (pair cf cg) := pair (ctrans cf) (ctrans cg)
| (comp cf cg) := comp (ctrans cf) (ctrans cg)
| (prec cf cg) := prec (ctrans cf) (ctrans cg)
| (rfind' cf)  := rfind' (ctrans cf)

def encode_code : code → ℕ
| oracle       := 0
| zero         := 1
| succ         := 2
| left         := 3
| right        := 4
| (pair cf cg) := (bit0 $ bit0 (mkpair (encode_code cf) (encode_code cg))) + 5
| (comp cf cg) := (bit0 $ bit1 (mkpair (encode_code cf) (encode_code cg))) + 5
| (prec cf cg) := (bit1 $ bit0 (mkpair (encode_code cf) (encode_code cg))) + 5
| (rfind' cf)  := (bit1 $ bit1 (encode_code cf)) + 5

def of_nat_code : ℕ → code
| 0 := oracle
| 1 := zero
| 2 := succ
| 3 := left
| 4 := right
| (e+5) :=
  have div8 : e.div2.div2 ≤ e :=
    by { simp[nat.div2_val], exact le_trans (nat.div_le_self (e/2) 2) (nat.div_le_self e 2) },
  have e.div2.div2 < e + 5 := nat.lt_succ_iff.mpr (le_trans div8 (nat.le.intro rfl)),
  have e.div2.div2.unpair.1 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_left_le _) div8) (nat.le.intro rfl)),
  have e.div2.div2.unpair.2 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_right_le _) div8) (nat.le.intro rfl)),
  match e.bodd, e.div2.bodd with
  | ff, ff := pair (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | ff, tt := comp (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | tt, ff := prec (of_nat_code e.div2.div2.unpair.1)
    (of_nat_code e.div2.div2.unpair.2)
  | tt, tt := rfind' (of_nat_code e.div2.div2)
  end

private lemma encode_of_nat_code : ∀ e, encode_code (of_nat_code e) = e
| 0     := by simp[of_nat_code, encode_code]
| 1     := by simp[of_nat_code, encode_code]
| 2     := by simp[of_nat_code, encode_code]
| 3     := by simp[of_nat_code, encode_code]
| 4     := by simp[of_nat_code, encode_code]
| (e+5) :=
have div8 : e.div2.div2 ≤ e :=
    by { simp[nat.div2_val],
         exact le_trans (nat.div_le_self (e/2) 2) (nat.div_le_self e 2) },
  have e.div2.div2 < e + 5 := nat.lt_succ_iff.mpr (le_trans div8 (nat.le.intro rfl)),
  have e.div2.div2.unpair.1 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_left_le _) div8) (nat.le.intro rfl)),
  have e.div2.div2.unpair.2 < e + 5 := nat.lt_succ_iff.mpr
    (le_trans (le_trans (nat.unpair_right_le _) div8) (nat.le.intro rfl)),
  have IH : _ := encode_of_nat_code e.div2.div2,
  have IH1 : _ := encode_of_nat_code e.div2.div2.unpair.1,
  have IH2 : _ := encode_of_nat_code e.div2.div2.unpair.2,
  begin
    suffices :
      (of_nat_code (e + 5)).encode_code =
      nat.bit e.bodd (nat.bit e.div2.bodd e.div2.div2) + 5,
    { simp[nat.bit_decomp, this] },
    simp [encode_code, of_nat_code],
    cases e.bodd; cases e.div2.bodd;
    simp [encode_code, of_nat_code, nat.bit, IH, IH1, IH2],
  end

private lemma of_nat_code_encode : ∀ c, of_nat_code (encode_code c) = c
| oracle       := by simp[of_nat_code, encode_code]
| zero         := by simp[of_nat_code, encode_code]
| succ         := by simp[of_nat_code, encode_code]
| left         := by simp[of_nat_code, encode_code]
| right        := by simp[of_nat_code, encode_code]
| (pair cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (comp cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (prec cf cg) := by { simp[encode_code, of_nat_code],
    exact ⟨of_nat_code_encode cf, of_nat_code_encode cg⟩ }
| (rfind' cf)  := by { simp[encode_code, of_nat_code],
    exact of_nat_code_encode cf }

instance : denumerable code := mk' ⟨encode_code, of_nat_code, of_nat_code_encode, encode_of_nat_code⟩

def evaln : ℕ → (ℕ → option ℕ) → code → ℕ → option ℕ
| 0     f _            := λ _, none
| (s+1) f oracle       := λ n, guard (n ≤ s) >> f n
| (s+1) f zero         := λ n, guard (n ≤ s) >> pure 0
| (s+1) f succ         := λ n, guard (n ≤ s) >> pure (nat.succ n)
| (s+1) f left         := λ n, guard (n ≤ s) >> pure n.unpair.1
| (s+1) f right        := λ n, guard (n ≤ s) >> pure n.unpair.2
| (s+1) f (pair cf cg) := λ n, guard (n ≤ s) >>
    mkpair <$> evaln (s+1) f cf n <*> evaln (s+1) f cg n
| (s+1) f (comp cf cg) := λ n, guard (n ≤ s) >>
    do x ← evaln (s+1) f cg n, evaln (s+1) f cf x
| (s+1) f (prec cf cg) := λ n, guard (n ≤ s) >>
    n.unpaired (λ a n,
    n.cases (evaln (s+1) f cf a) $ λ y, do
    i ← evaln s f (prec cf cg) (mkpair a y),
    evaln (s+1) f cg (mkpair a (mkpair y i)))
| (s+1) f (rfind' cf)  := λ n, guard (n ≤ s) >>
    n.unpaired (λ a m, do
    x ← evaln (s+1) f cf (mkpair a m),
    if x = 0 then pure m else
    evaln s f (rfind' cf) (mkpair a (m+1)))
-- evaln s f c x = { c }ᶠₛ (x)

@[simp] theorem evaln_0 {f c n} : evaln 0 f c n = none :=
by induction c; simp [evaln]

theorem evaln_inclusion : ∀ {s c} {f g : ℕ → option ℕ},
  (∀ x y, x < s → f x = some y → g x = some y) →
  ∀ {x y}, evaln s f c x = some y →  evaln s g c x = some y
| 0 c _ _ := by simp[evaln]
| (s+1) oracle f g := λ h n y,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega,
         cases this; simp[(>>), this], exact h _ _ (nat.lt_succ_iff.mpr this),
         intros _ c, exfalso, exact option.not_mem_none _ c }
| (s+1) zero         f g := by simp[evaln]
| (s+1) succ         f g := by simp[evaln]
| (s+1) left         f g := by simp[evaln]
| (s+1) right        f g := by simp[evaln]
| (s+1) (pair cf cg) f g := λ h n y,
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e hf,
         have : ∃ y, evaln (s + 1) f cf n = some y,
         { cases evaln (s + 1) f cf n; simp, simp[(<*>), hf] at hf ⊢, exact hf },
         rcases this with ⟨y0, hy0⟩, have IH₀' := IH₀ hy0,
          have : ∃ y, evaln (s + 1) f cg n = some y,
         { cases evaln (s + 1) f cg n; simp, simp[(<*>), hf] at hf ⊢, exact hf },
         rcases this with ⟨y1, hy1⟩, have IH₁' := IH₁ hy1,
         simp[hy0, hy1, IH₀', IH₁'] at hf ⊢, exact ⟨e, hf⟩ }
| (s+1) (comp cf cg) f g := λ h n y,
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e z hz hy,
         refine ⟨e, z, IH₁ hz, IH₀ hy⟩ }
| (s+1) (prec cf cg) f g := λ h n y,
    have l0 : ∀ x y, x < s → f x = some y → g x = some y :=
      λ x y e, h x y (nat.lt.step e),
    have IH₀ : _ := @evaln_inclusion s (cf.prec cg) _ _ l0,
    have IH₁ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₂ : _ := @evaln_inclusion (s+1) cg _ _ h,
    by { simp[evaln, (>>)], assume e hf,
         cases n.unpair.snd with n0; simp at hf ⊢, exact ⟨e, IH₁ hf⟩,
         rcases hf with ⟨z, hz0, hz1⟩,
         refine ⟨e, z, IH₀ hz0, IH₂ hz1⟩ }
| (s+1) (rfind' cf)  f g := λ h n y,
    have l0 : ∀ x y, x < s → f x = some y → g x = some y :=
      λ x y e, h x y (nat.lt.step e),
    have IH₀ : _ := @evaln_inclusion (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_inclusion s cf.rfind' _ _ l0,
    by { simp[evaln, (>>)], assume e z ez ey,
         refine ⟨e, z, IH₀ ez, _⟩,
         cases z with z0; simp at ey ⊢, exact ey, exact IH₁ ey }

theorem evaln_use : ∀ {s c} {f g : ℕ → option ℕ},
  (∀ x, x < s → f x = g x) → evaln s f c = evaln s g c
| 0     c            _ _  := by simp[evaln]
| (s+1) oracle       _ _  := λ h, funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega,
         cases this; simp[(>>), this], exact h _ (nat.lt_succ_iff.mpr this), refl }
| (s+1) zero         f g := by simp[evaln]
| (s+1) succ         f g := by simp[evaln]
| (s+1) left         f g := by simp[evaln]
| (s+1) right        f g := by simp[evaln]
| (s+1) (pair cf cg) f g := λ h,
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }
| (s+1) (comp cf cg) f g := λ h,
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }
| (s+1) (prec cf cg) f g := λ h,
    have l0 : ∀ (x : ℕ), x < s → f x = g x := λ x e, h x (nat.lt.step e),
    have IH₀ : _ := @evaln_use s (cf.prec cg) _ _ l0,
    have IH₁ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₂ : _ := @evaln_use (s+1) cg _ _ h,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁, IH₂] }
| (s+1) (rfind' cf)  f g := λ h,
    have l0 : ∀ (x : ℕ), x < s → f x = g x := λ x e, h x (nat.lt.step e),
    have IH₀ : _ := @evaln_use (s+1) cf _ _ h,
    have IH₁ : _ := @evaln_use s cf.rfind' _ _ l0,
    funext $ λ n,
    by { simp[evaln], have : n ≤ s ∨ ¬ n ≤ s, omega, cases this;
         simp[(>>), this, IH₀, IH₁] }

theorem evaln_use' {s} {f g : ℕ → option ℕ} (h : ∀ x, x < s → f x = g x) :
  evaln s f = evaln s g :=
funext $ λ c, evaln_use h

theorem evaln_bound {f} : ∀ {k c n x}, x ∈ evaln k f c n → n < k
| 0     c n x h := by simp [evaln] at h; cases h
| (k+1) c n x h := begin
  suffices : ∀ {o : option ℕ}, x ∈ guard (n ≤ k) >> o → n < k + 1,
  { cases c; rw [evaln] at h; try { exact this h } },
  simpa [(>>)] using nat.lt_succ_of_le
end

theorem evaln_bound_none {f k c n} (h : k ≤ n) : evaln k f c n = none :=
by { cases e : evaln k f c n with v; simp,
     have := evaln_bound e, exact nat.lt_le_antisymm this h }

theorem evaln_mono : ∀ {s₁ s₂ c f n x},
  s₁ ≤ s₂ → evaln s₁ f c n = some x → evaln s₂ f c n = some x
| 0      _      _            _ _ _ := λ _ h, by simp [evaln] at h; cases h
| (s₀+1) 0      _            _ _ _ := λ e h, by exfalso; exact nat.not_succ_le_zero s₀ e
| (s₀+1) (s₁+1) oracle       f n x := λ hs,
    by { simp[evaln], have : n ≤ s₀ ∨ ¬ n ≤ s₀, omega,
         cases this; simp[(>>), this], exact λ e, ⟨by omega, e⟩,
         intros _ c, exfalso, exact option.not_mem_none _ c }
| (s₀+1) (s₁+1) zero         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) succ         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) left         f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) right        f n x := λ hs,
    by simp[evaln, (>>)]; exact λ _ e, ⟨by omega, e⟩
| (s₀+1) (s₁+1) (pair cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)], assume e0 ex,
         have : ∃ y, evaln (s₀ + 1) f cf n = some y,
         { cases evaln (s₀ + 1) f cf n; simp[(<*>)] at ex ⊢, exact ex },
         rcases this with ⟨y₀, hy₀⟩,
         have : ∃ y, evaln (s₀ + 1) f cg n = some y,
         { cases evaln (s₀ + 1) f cg n; simp[(<*>)] at ex ⊢, exact ex },
         rcases this with ⟨y₁, hy₁⟩,
         simp[hy₀, hy₁, IH₀ _ _ hy₀, IH₁ _ _ hy₁] at ex ⊢,
         exact ⟨le_trans e0 (nat.le_of_succ_le_succ hs), ex⟩ }
| (s₀+1) (s₁+1) (comp cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)], assume e0 y ey ex,
         refine ⟨le_trans e0 (nat.le_of_succ_le_succ hs), y, IH₁ _ _ ey, IH₀ _ _ ex⟩ }
| (s₀+1) (s₁+1) (prec cf cg) f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono s₀ s₁ (cf.prec cg) f n y (nat.le_of_succ_le_succ hs),
    have IH₁ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₂ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cg f n y hs,
    by { simp[evaln, (>>)],
         cases n.unpair.snd with n0; simp,
         assume e0 ex,
         exact ⟨le_trans e0 (nat.le_of_succ_le_succ hs), IH₁ _ _ ex⟩,
         assume e0 y ey ex,
         refine ⟨le_trans e0 (nat.le_of_succ_le_succ hs), y, IH₀ _ _ ey, IH₂ _ _ ex⟩ }
| (s₀+1) (s₁+1) (rfind' cf)  f n x := λ hs,
    have IH₀ : _ := λ n y, @evaln_mono (s₀+1) (s₁+1) cf f n y hs,
    have IH₁ : _ := λ n y, @evaln_mono s₀ s₁ cf.rfind' f n y (nat.le_of_succ_le_succ hs),
    by { simp[evaln, (>>), pure],
         assume e0 y ey ex,
         refine ⟨by omega, y, IH₀ _ _ ey, _⟩,
         cases y with y0; simp at ex ⊢, exact ex, exact IH₁ _ _ ex }

def eval (f : ℕ → option ℕ) : code → ℕ →. ℕ
| oracle       := λ n, f n
| zero         := pure 0
| succ         := nat.succ
| left         := ↑(λ n : ℕ, n.unpair.1)
| right        := ↑(λ n : ℕ, n.unpair.2)
| (pair cf cg) := λ n, mkpair <$> eval cf n <*> eval cg n
| (comp cf cg) := λ n, eval cg n >>= eval cf
| (prec cf cg) := nat.unpaired (λ a n,
    n.elim (eval cf a) (λ y IH, do i ← IH, eval cg (mkpair a (mkpair y i))))
| (rfind' cf) := nat.unpaired (λ a m,
    (nat.rfind (λ n, (λ m, m = 0) <$>
      eval cf (mkpair a (n + m)))).map (+ m))

theorem evaln_sound {f} : ∀ {s c n x},
  x ∈ evaln s f c n → x ∈ eval f c n
| 0     _ _ _ h := by simp [evaln] at h; cases h
| (s + 1) oracle n x h := by { simp [eval, evaln, (>>)] at h ⊢, exact h.2 }
| (s + 1) zero   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) succ   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) left   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) right   n x h :=
    by { simp [eval, evaln, (>>), pure, pfun.pure] at h ⊢, exact eq.symm h.2 }
| (s + 1) (pair cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>), (<*>)] at h ⊢,
        rcases h with ⟨_, y, hy, z, hz, ex⟩,
        refine ⟨y, IH₀ hy, z, IH₁ hz, ex⟩ }
| (s + 1) (comp cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>), (<*>)] at h ⊢,
        rcases h with ⟨_, y, hy, hz⟩,
        refine ⟨y, IH₁ hy, IH₀ hz⟩ }
| (s + 1) (prec cf cg) n x h :=
    have IH₀ : _ := @evaln_sound (s + 1) cf,
    have IH₁ : _ := @evaln_sound (s + 1) cg,
    by{ simp [eval, evaln, (>>)] at h ⊢,
        rcases h with ⟨_, hx⟩, revert hx,
        induction n.unpair.2 with m IH generalizing x; simp,
        { exact IH₀ },
        { refine λ y h₁ h₂, ⟨y, IH _ _, _⟩,
          { have := evaln_mono s.le_succ h₁,
        simp [evaln, (>>)] at this,
        exact this.2 },
        { exact IH₁ h₂ } } }
| (s + 1) (rfind' cf) n x h :=
    have IH₀ : _ := @evaln_sound (s+1) cf,
    have IH₁ : _ := @evaln_sound s cf.rfind',
  begin
    simp [eval, evaln, (>>)] at h ⊢,
    rcases h with ⟨_, m, hm, h⟩,
    cases e : m with m0; simp[e, pure] at hm h,
    { refine ⟨0, ⟨by simp; exact IH₀ hm, by simp⟩, by simp[h]⟩ },
    { have := IH₁ h,  simp[eval] at this,
      rcases this with ⟨y, ⟨hc0, hc1⟩, ex⟩,
      refine ⟨y+1, ⟨
        by simpa [add_comm, add_left_comm] using hc0, λ b eb, _⟩,
        by simpa [add_comm, add_left_comm] using ex⟩,
      { cases b with b0, refine ⟨m0 + 1, by simp; exact IH₀ hm, by simp⟩,
        have : b0.succ + n.unpair.snd = b0 + (n.unpair.snd + 1), omega,
        rw this, exact hc1 (nat.lt_of_succ_lt_succ eb) } }
  end

theorem evaln_complete {f : ℕ → option ℕ} {c n x} :
  x ∈ eval (λ x, f x) c n ↔ ∃ k, x ∈ evaln k f c n := ⟨λ h,
begin
  suffices : ∃ k, x ∈ evaln (k+1) f c n,
  { exact let ⟨k, h⟩ := this in ⟨k+1, h⟩ },
    induction c generalizing n x;
    simp [eval, evaln, pure, pfun.pure, (<*>), (>>)] at h ⊢,
    { exact ⟨⟨n, by refl⟩, h⟩ },
    { use n, have : min n n.unpair.fst.unpair.fst = n.unpair.fst.unpair.fst,
      { simp, exact le_trans (nat.unpair_left_le _) (nat.unpair_left_le _) }, simp [this,h] },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
    case nat.rpartrec.code.pair : cf cg hf hg
    { rcases h with ⟨x, hx, y, hy, rfl⟩,
      rcases hf hx with ⟨k₁, hk₁⟩, rcases hg hy with ⟨k₂, hk₂⟩,
      refine ⟨max k₁ k₂, le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₁, x, _, y, _, rfl⟩,
      exact evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₁,
      exact evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂ },
    case nat.rpartrec.code.comp : cf cg hf hg
    { rcases h with ⟨y, hy, hx⟩,
      rcases hf hx with ⟨k₁, hk₁⟩, rcases hg hy with ⟨k₂, hk₂⟩,
      refine ⟨max k₂ k₁, le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₂, y, _, _⟩,
      exact evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₂,
      exact evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₁ },
    case nat.rpartrec.code.prec : cf cg hf hg
    { revert h,
      generalize : n.unpair.1 = n₁, generalize : n.unpair.2 = n₂,
      induction n₂ with m IH generalizing x n; simp,
      { intro, rcases hf h with ⟨k, hk⟩,
        exact ⟨_, le_max_left _ _,
          evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk⟩ },
      { intros y hy hx,
        rcases IH hy with ⟨k₁, nk₁, hk₁⟩, rcases hg hx with ⟨k₂, hk₂⟩,
        refine ⟨(max k₁ k₂).succ, nat.le_succ_of_le $ le_max_of_le_left $
          le_trans (le_max_left _ (mkpair n₁ m)) nk₁, y,
          evaln_mono (nat.succ_le_succ $ le_max_left _ _) _,
          evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_right _ _) hk₂⟩,
        simp [evaln, (>>)],
        exact ⟨le_trans (le_max_right _ _) nk₁, hk₁⟩ } },
    case nat.rpartrec.code.rfind' : cf hf
    { rcases h with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩,
      suffices : ∃ k, y + n.unpair.2 ∈ evaln (k+1) f (rfind' cf)
        (mkpair n.unpair.1 n.unpair.2), {simpa [evaln, (>>)]},
      revert hy₁ hy₂, generalize : n.unpair.2 = m, intros,
      induction y with y IH generalizing m; simp [evaln, (>>)],
      { simp at hy₁, rcases hf hy₁ with ⟨k, hk⟩,
        exact ⟨_, nat.le_of_lt_succ $ evaln_bound hk, _, hk, by simp; refl⟩ },
      { rcases hy₂ (nat.succ_pos _) with ⟨a, ha, a0⟩,
        rcases hf ha with ⟨k₁, hk₁⟩,
        rcases IH m.succ
            (by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using hy₁)
            (λ i hi, by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using
              hy₂ (nat.succ_lt_succ hi))
          with ⟨k₂, hk₂⟩,
        use (max k₁ k₂).succ,
        rw [zero_add] at hk₁,
        use (nat.le_succ_of_le $ le_max_of_le_left $ nat.le_of_lt_succ $ evaln_bound hk₁),
        use a,
        use evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_left _ _) hk₁,
        simpa [nat.succ_eq_add_one, a0, -max_eq_left, -max_eq_right, add_comm, add_left_comm] using
            evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂ } },
end, λ ⟨k, h⟩, evaln_sound h⟩

theorem evaln_complete_dec {c f} [D : decidable_pred (eval f c).dom] : ∀ m, ∃ s₀,
  ∀ n a, n < m → eval f c n = some a → evaln s₀ f c n = some a := λ m,
begin
  induction m with m0 ih, simp,
  rcases ih with ⟨s₀, hs₀⟩,
  have e : eval f c m0 = none ∨ ∃ v, eval f c m0 = some v := eq_none_or_eq_some (eval f c m0),
  cases e,
  { refine ⟨s₀, λ n a en ha, _⟩,
    have : n < m0 ∨ n = m0, from nat.lt_succ_iff_lt_or_eq.mp en,
    cases this, { exact hs₀ _ _ this ha },
    { exfalso, rw this at ha, rw e at ha, exact part.some_ne_none _ (eq.symm ha) } },
  { rcases e with ⟨v, e⟩,
    have : v ∈ eval f c m0, simp[e],
    have : ∃ k, v ∈ evaln k f c m0 := evaln_complete.mp this, rcases this with ⟨s₁, hs₁⟩,
    refine ⟨max s₀ s₁, _⟩,
    intros n a en ha,
    have en' : n < m0 ∨ n = m0, from nat.lt_succ_iff_lt_or_eq.mp en,
    cases en',
    { have : evaln s₀ f c n = option.some a := hs₀ _ _ en' ha,
      show evaln (max s₀ s₁) f c n = option.some a,
        from evaln_mono (le_max_left s₀ s₁) this },
    { rw en',
      have : a = v, from part.some_inj.mp (by simp only [←e, ←ha, en']),
      show evaln (max s₀ s₁) f c m0 = option.some a, rw this,
        from evaln_mono (le_max_right s₀ s₁) hs₁ } }
end

theorem eval_inclusion {c x y} {f : ℕ → option ℕ} (h : y ∈ eval f c x) : ∃ s, ∀ {g : ℕ → option ℕ},
  (∀ x y, x < s → f x = some y → g x = some y) → y ∈ eval g c x :=
by { have : ∃ s, y ∈ evaln s f c x := evaln_complete.mp h, rcases this with ⟨s, hs⟩,
     refine ⟨s, λ g h, evaln_complete.mpr ⟨s, evaln_inclusion h hs⟩⟩ }

@[simp] theorem evaln_const (s f) :
  ∀ n m, evaln (s+1) f (code.const n) m = guard (n ≤ s+1) >> guard (m ≤ s) >> option.some n
| 0     m := by { simp[code.const, evaln, (>>), pure], }
| (n+1) m := have IH : _ := evaln_const n m,
  by { simp [code.const, evaln, IH, pure, (>>)],
    by_cases e1 : n ≤ s; simp[e1, failure, alternative.failure],
    by_cases e2 : m ≤ s; simp[e1, e2, failure, alternative.failure],
    refine ⟨n, ⟨⟨(le_add_right e1), (), rfl⟩, rfl⟩, e1, rfl⟩ }

@[simp] theorem eval_const (f) : ∀ n m, eval f (code.const n) m = part.some n
| 0     m := rfl
| (n+1) m := by simp! *

@[simp] theorem eval_id (f n) : eval f code.id n = part.some n := by simp! [(<*>)]

@[simp] theorem eval_curry (f c n x) : eval f (curry c n) x = eval f c (mkpair n x) :=
by simp! [(<*>)]

--@[simp] theorem eval_ctrans (f c₁ c₂ x) : eval (eval f c₁) c₂ x = eval f (ctrans c₁ c₂) x :=
--by simp! [(<*>)]

@[simp] theorem evaln_curry (s f c n x) :
  evaln s f (curry c n) x = evaln s f c (n.mkpair x) :=
begin
  cases s, simp,
  simp [curry, evaln],
  by_cases e0 : x ≤ s; simp [code.id, evaln, e0, pure, (>>), failure, alternative.failure],
  by_cases e1 : n ≤ s+1; simp [e0, e1, pure, (>>), (<*>), failure, alternative.failure],
  { cases e : evaln (s + 1) f c (n.mkpair x) with y; simp,
    have : n.mkpair x < s + 1, from evaln_bound e,
    have : n ≤ s + 1, from le_of_lt
      (gt_of_gt_of_ge this (nat.left_le_mkpair n x)),
    contradiction },
  { cases e : evaln (s + 1) f c (n.mkpair x) with y; simp,
    have : n.mkpair x ≤ s := nat.lt_succ_iff.mp (evaln_bound e),
    have : x ≤ s := le_trans (nat.right_le_mkpair _ _) this,
    contradiction }
end

section
open primrec

theorem pair_prim : primrec₂ pair :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem comp_prim : primrec₂ comp :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit1.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem prec_prim : primrec₂ prec :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 5)

theorem rfind_prim : primrec rfind' :=
of_nat_iff.2 $ encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit1.comp $
    encode_iff.2 $ primrec.of_nat code)
  (const 5)

theorem const_prim : primrec code.const :=
(primrec.id.nat_iterate (primrec.const zero)
  (comp_prim.comp (primrec.const succ) primrec.snd).to₂).of_eq $
λ n, by simp; induction n; simp [*, code.const, function.iterate_succ']

theorem curry_prim : primrec₂ curry :=
comp_prim.comp primrec.fst $
pair_prim.comp (const_prim.comp primrec.snd) (primrec.const code.id)

end

theorem rpartrec_rfind' {f} : nat.rpartrec f (nat.unpaired (λ a m,
  (nat.rfind (λ n, (λ m, m = 0) <$> f (nat.mkpair a (n + m)))).map (+ m))) :=
rpartrec.nat_iff.mp $
begin
  simp,
  have c₀ : primrec (λ (x : (ℕ × ℕ) × ℕ), x.2 + x.1.2) :=
  primrec.nat_add.comp primrec.snd (primrec.snd.comp primrec.fst),
  have c₁ : primrec (λ (m : ((ℕ × ℕ) × ℕ) × ℕ), to_bool (m.2 = 0)) :=
  primrec₂.comp primrec.eq primrec.snd (primrec.const 0),
  have c₂ : (λ (x : (ℕ × ℕ) × ℕ), f (x.1.1.mkpair (x.2 + x.1.2))) partrec_in f :=
  rpartrec.refl.comp (primrec₂.mkpair.comp (primrec.fst.comp primrec.fst) $
    primrec.nat_add.comp primrec.snd (primrec.snd.comp primrec.fst)).to_comp.to_rpart,
  have := (rpartrec.rfind (c₂.map c₁.to_rcomp.to₂).to₂).map c₀.to_rcomp.to₂,
  simp at this,
  exact this.comp primrec.unpair.to_rcomp
end

theorem exists_code {f g : ℕ →. ℕ} [D : decidable_pred (λ x, x ∈ g.dom)] :
  nat.rpartrec g f ↔ ∃ c, eval (g.eval_opt) c = f := ⟨λ h,
begin
  induction h,
  case nat.rpartrec.oracle
  { exact ⟨oracle, by { simp[eval], funext n, exact of_to_option (g n) }⟩ },
  case nat.rpartrec.zero   { exact ⟨zero, rfl⟩ },
  case nat.rpartrec.succ   { exact ⟨succ, rfl⟩ },
  case nat.rpartrec.left   { exact ⟨left, rfl⟩ },
  case nat.rpartrec.right  { exact ⟨right, rfl⟩ },
  case nat.rpartrec.pair : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨pair e₀ e₁, rfl⟩ },
  case nat.rpartrec.comp : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨comp e₀ e₁, rfl⟩ },
  case nat.rpartrec.prec : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨prec e₀ e₁, rfl⟩ },
  case nat.rpartrec.rfind : f₀ pf₀ hf₀
  { rcases hf₀ with ⟨e₀, rfl⟩,
    refine ⟨comp (rfind' e₀) (pair nat.rpartrec.code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, part.map_id'],  },
end,λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.rpartrec.code.oracle
  { simp[eval], unfold_coes, simp, exact nat.rpartrec.oracle },
  case nat.rpartrec.code.zero { exact nat.rpartrec.zero },
  case nat.rpartrec.code.succ { exact nat.rpartrec.succ },
  case nat.rpartrec.code.left { exact nat.rpartrec.left },
  case nat.rpartrec.code.right { exact nat.rpartrec.right },
  case nat.rpartrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.rpartrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.rpartrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.rpartrec.code.rfind' : cf pf { exact nat.rpartrec.trans rpartrec_rfind' pf },
end⟩

theorem exists_code_opt {f : ℕ →. ℕ} {g : ℕ → option ℕ} :
  nat.rpartrec ↑ʳg f ↔ ∃ c, eval g c = f := ⟨λ h,
begin
  induction h,
  case nat.rpartrec.oracle
  { exact ⟨oracle, rfl⟩ },
  case nat.rpartrec.zero   { exact ⟨zero, rfl⟩ },
  case nat.rpartrec.succ   { exact ⟨succ, rfl⟩ },
  case nat.rpartrec.left   { exact ⟨left, rfl⟩ },
  case nat.rpartrec.right  { exact ⟨right, rfl⟩ },
  case nat.rpartrec.pair : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨pair e₀ e₁, rfl⟩ },
  case nat.rpartrec.comp : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨comp e₀ e₁, rfl⟩ },
  case nat.rpartrec.prec : f₀ f₁ pf₀ pf₁ hf₀ hf₁
  { rcases hf₀ with ⟨e₀, rfl⟩, rcases hf₁ with ⟨e₁, rfl⟩,
    exact ⟨prec e₀ e₁, rfl⟩ },
  case nat.rpartrec.rfind : f₀ pf₀ hf₀
  { rcases hf₀ with ⟨e₀, rfl⟩,
    refine ⟨comp (rfind' e₀) (pair nat.rpartrec.code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, part.map_id'],  },
end,λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.rpartrec.code.oracle
  { simp[eval], exact nat.rpartrec.oracle },
  case nat.rpartrec.code.zero { exact nat.rpartrec.zero },
  case nat.rpartrec.code.succ { exact nat.rpartrec.succ },
  case nat.rpartrec.code.left { exact nat.rpartrec.left },
  case nat.rpartrec.code.right { exact nat.rpartrec.right },
  case nat.rpartrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.rpartrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.rpartrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.rpartrec.code.rfind' : cf pf { exact nat.rpartrec.trans rpartrec_rfind' pf },
end⟩

end nat.rpartrec.code
open nat.rpartrec

variables {α : Type*} {σ : Type*} {β : Type*} {τ : Type*} {γ : Type*} {μ : Type*}
variables [primcodable α] [primcodable σ] [primcodable β] [primcodable τ] [primcodable γ] [primcodable μ]

def univn (α σ) [primcodable α] [primcodable σ] (s : ℕ) (f : β → option τ) (e : ℕ) :
  α → option σ := (λ a,
(code.evaln s
  (λ n, (decode β n).bind (λ a, (f a).map encode ))
  (of_nat code e) (encode a))
.bind (λ x, (decode σ x)))

notation `⟦`e`⟧*`f:max` [`s`]` := univn _ _ s f e
notation `⟦`e`⟧^`f:max` [`s`]` := univn _ _ s ↑ₒf e

def univ (α σ) [primcodable α] [primcodable σ] (f : β → option τ) (e : ℕ) : α →. σ := (λ a,
(code.eval
  (λ n, (decode β n).bind (λ a, (f a).map encode))
  (of_nat code e) (encode a))
.bind (λ x, (decode σ x)))

notation `⟦`e`⟧*`f:max := univ _ _ f e
notation `⟦`e`⟧^`f:max := univ _ _ ↑ₒf e

notation `⟦`e`⟧ᵪ*`f:max` [`s`]` := univn ℕ bool s f e
notation `⟦`e`⟧ₙ*`f:max` [`s`]` := univn ℕ ℕ s f e
notation `⟦`e`⟧ᵪ*`f:max := univ ℕ bool f e
notation `⟦`e`⟧ₙ*`f:max := univ ℕ ℕ f e

notation `⟦`e`⟧ᵪ^`f:max` [`s`]` := univn ℕ bool s ↑ₒf e
notation `⟦`e`⟧ₙ^`f:max` [`s`]` := univn ℕ ℕ s ↑ₒf e
notation `⟦`e`⟧ᵪ^`f:max := univ ℕ bool ↑ₒf e
notation `⟦`e`⟧ₙ^`f:max := univ ℕ ℕ ↑ₒf e

def univn0 (α σ) [primcodable α] [primcodable σ] (s : ℕ) (e : ℕ) : α → option σ :=
univn α σ s (λ x, none : ℕ → option ℕ) e

def univ0 (α σ) [primcodable α] [primcodable σ] (e : ℕ) : α →. σ :=
univ α σ (λ x, some 0 : ℕ → option ℕ) e

notation `⟦`e`⟧⁰`:max` [`s`]` := univn0 _ _ s e
notation `⟦`e`⟧⁰`:max := univ0 _ _ e

def re_set (α σ) [primcodable α] [primcodable σ] (p : β → option τ) (e : ℕ) : set α :=
{x | (⟦e⟧*p x : part σ).dom}

def re_set0 (α σ) [primcodable α] [primcodable σ] (e : ℕ) : set α :=
{x | (univ0 α σ e x : part σ).dom}

notation `W⟦`e`⟧^`f:max := re_set _ _ ↑ₒf e

notation `W⟦`e`⟧ᵪ^`f:max := re_set ℕ bool ↑ₒf e
notation `W⟦`e`⟧ₙ^`f:max := re_set ℕ ℕ ↑ₒf e
notation `W⟦`e`⟧ᵪ⁰`:max := re_set0 ℕ bool e
notation `W⟦`e`⟧ₙ⁰`:max := re_set0 ℕ ℕ e

def curry {α} [primcodable α] (e : ℕ) (n : α) : ℕ := encode (code.curry (of_nat _ e) (encode n))

-- smn定理
@[simp] theorem eval_curry (f : γ → option τ) (e : ℕ) (n : β) (x : α) :
  (⟦curry e n⟧*f x : part σ) = (⟦e⟧*f (n, x) : part σ) :=
by { simp[curry, univ] }

namespace rpartrec

theorem curry_prim {α} [primcodable α] : primrec₂ (@curry α _) :=
(primrec.encode.comp $ code.curry_prim.comp
  ((primrec.of_nat code).comp primrec.fst) ((@primrec.encode α _).comp primrec.snd))

open primrec

theorem univn_sound {e} {p : β → option τ} {x : α} {y : σ} {s : ℕ} :
  ⟦e⟧*p [s] x = some y → ⟦e⟧*p x = some y :=
by { simp[univn, univ, part.eq_some_iff],
     exact λ s h e, ⟨s, code.evaln_sound h, e⟩ }

theorem univn_complete {p : β → option τ} {e x} {n : α} :
  x ∈ (⟦e⟧*p n : part σ) ↔ ∃ s, ⟦e⟧*p [s] n = some x :=
by { simp[univn, univ, part.eq_some_iff], split,
     { rintros ⟨a, ha, ea⟩,
       rcases code.evaln_complete.mp ha with ⟨s, hs⟩,
       refine ⟨s, a, hs, ea⟩ },
     { rintros ⟨s, a, ha, ea⟩,
       have := code.evaln_complete.mpr ⟨s, ha⟩,
       refine ⟨a, this, ea⟩ } }

theorem univn_dom_complete {p : β → option τ} {e} {n : α} :
  (⟦e⟧*p n : part σ).dom ↔ ∃ s, (⟦e⟧*p [s] n : option σ).is_some :=
by { simp[part.dom_iff_mem, option.is_some_iff_exists], split,
     { rintros ⟨y, h⟩, rcases univn_complete.mp h with ⟨s, h⟩, refine ⟨s, y, h⟩ },
     { rintros ⟨s, y, h⟩, have := univn_complete.mpr ⟨s, h⟩, refine ⟨y, this⟩ } }

theorem univn_mono {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (eqn : s₀ ≤ s₁) : ⟦e⟧*p [s₀] x = some y → ⟦e⟧*p [s₁] x = some y :=
by { simp [univn], intros z h eqn_z,
     refine ⟨z, code.evaln_mono eqn h, eqn_z⟩ }

theorem univn_dom_mono {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α}
  (eqn : s₀ ≤ s₁) : (⟦e⟧*p [s₀] x : option σ).is_some → (⟦e⟧*p [s₁] x : option σ).is_some :=
begin
  cases C : (⟦e⟧*p [s₀] x : option σ) with y; simp,
  simp[univn_mono eqn C]
end

theorem univn_mono_eq {e} {p : β → option τ} {s₀ s₁ : ℕ} {x : α} {y₀ y₁ : σ}
  (h₀ : ⟦e⟧*p [s₀] x = some y₀) (h₁ : ⟦e⟧*p [s₁] x = some y₁) : y₀ = y₁ :=
begin
  have : s₀ ≤ s₁ ∨ s₁ ≤ s₀, from le_total _ _,
  cases this,
  { have := univn_mono this h₀, simp [this] at h₁, exact h₁ },
  { have := univn_mono this h₁, simp [this] at h₀, exact eq.symm h₀ }
end

theorem univn_use {s e} {p q : ℕ → option β}
  (h : ∀ x, x < s → p x = q x) : (⟦e⟧*p [s] : α → option σ) = ⟦e⟧*q [s] :=
begin
  simp [univn],
  suffices :
    code.evaln s (λ n, option.map encode (p n)) (of_nat code e) =
    code.evaln s (λ n, option.map encode (q n)) (of_nat code e),
  { funext, rw this },
  apply code.evaln_use, intros u eqn, congr, exact h _ eqn
end

theorem univn_tot_use {s e} {f g : ℕ → β}
  (h : ∀ x, x < s → f x = g x) : (⟦e⟧^f [s] : α → option σ) = ⟦e⟧^g [s] :=
univn_use (λ x lt, by simp[h x lt])

theorem univn_mono_use {e} {p q : ℕ → option τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (h : ∀ x < s₀, p x = q x) (eqn : s₀ ≤ s₁) : ⟦e⟧*p [s₀] x = some y → ⟦e⟧*q [s₁] x = some y := λ eq_y,
  have (⟦e⟧*p [s₀] x : option σ) = ⟦e⟧*q [s₀] x, from congr_fun (univn_use h) x,
univn_mono eqn (by simp[←this, eq_y])

theorem univn_tot_mono_use {e} {f g : ℕ → τ} {s₀ s₁ : ℕ} {x : α} {y : σ}
  (h : ∀ x < s₀, f x = g x) (eqn : s₀ ≤ s₁) : ⟦e⟧^f [s₀] x = some y → ⟦e⟧^g [s₁] x = some y :=
univn_mono_use (by simp; exact h) eqn

theorem eval_inclusion {e} {x : α} {y : σ} {p : ℕ → option τ}
  (h : y ∈ (⟦e⟧*p x : part σ)) : ∃ s, ∀ {q : ℕ → option τ},
  (∀ x y, x < s → p x = some y → q x = some y) → y ∈ (⟦e⟧*q x : part σ) :=
by { simp [part.eq_some_iff, univ] at h ⊢, rcases h with ⟨a, h, e⟩,
     rcases nat.rpartrec.code.eval_inclusion h with ⟨s, hs⟩,
     refine ⟨s, λ g h, ⟨a, hs (λ x y e ey, _), e⟩⟩, simp at ey, rcases ey with ⟨a, ea, ey⟩,
     have := h _ _ e ea, simp[this, ey] }

theorem eval_inclusion_tot {e} {x : α} {y : σ}
  {f : ℕ → τ} (h : y ∈ (⟦e⟧^f x : part σ)) : ∃ s, ∀ {g : ℕ → τ},
  (∀ x y, x < s → f x = y → g x = y) → y ∈ (⟦e⟧^g x : part σ) :=
by { rcases eval_inclusion h with ⟨s, hs⟩, refine ⟨s, λ g hfg, hs _⟩,
     simp, exact hfg }

end rpartrec

theorem rcomputable.curry {α} [primcodable α] {σ : Type*} {τ : Type*} [primcodable σ] [primcodable τ]
  {o : σ →. τ} : (@curry α _) computable₂_in o := rpartrec.curry_prim.to_rcomp


import tactic data.nat.digits .yeet

theorem unyeetable_3p2 : ¬ ∃ b, yeet b 3 2 :=
begin
  rintro ⟨b, h⟩,
  unfold yeet at h,
  cases b, { change 9 = 3 at h, norm_num at h },
  cases b, { change 9 = 5 at h, norm_num at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  have h2b : 2 < b + 4 := by linarith,
  have h3b : 3 < b + 4 := by linarith,
  rw nat.digits_of_lt _ _ dec_trivial h2b at h,
  rw nat.digits_of_lt _ _ dec_trivial h3b at h,
  change 9 = nat.of_digits _ [3, 2] at h,
  change 9 = 3 + (b + 4) * 2 at h,
  rw [add_mul, ←add_assoc, add_comm, ←add_assoc] at h,
  exact absurd (le_trans (le_add_right (le_refl _)) (ge_of_eq h)) dec_trivial
end

theorem unyeetable_3p4 : ¬ ∃ b, yeet b 3 4 :=
begin
  rintro ⟨b, h⟩,
  unfold yeet at h,
  cases b, { change _ = 3 at h, norm_num at h },
  cases b, { change _ = 7 at h, norm_num at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  cases b, { norm_num [nat.of_digits] at h },
  have h3b : 3 < b + 5 := by linarith,
  have h4b : 4 < b + 5 := by linarith,
  rw nat.digits_of_lt _ _ dec_trivial h3b at h,
  rw nat.digits_of_lt _ _ dec_trivial h4b at h,
  norm_num [nat.of_digits] at h,
  apply_fun (% 4) at h,
  norm_num at h
end


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.uliftable
import Mathlib.Lean3Lib.system.random
import Mathlib.system.random.basic
import Mathlib.PostPort

universes u u_1 v

namespace Mathlib

/-!
# `gen` Monad

This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `gen` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/

namespace slim_check

/-- Monad to generate random examples to test properties with.
It has a `nat` parameter so that the caller can decide on the
size of the examples. -/
def gen (α : Type u) :=
  reader_t (ulift ℕ) rand α

/-- Execute a `gen` inside the `io` monad using `i` as the example
size and with a fresh random number generator. -/
def io.run_gen {α : Type} (x : gen α) (i : ℕ) : io α :=
  io.run_rand (reader_t.run x (ulift.up i))

namespace gen

/-- Lift `random.random` to the `gen` monad. -/
def choose_any (α : Type u) [random α] : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => rand.random α

/-- Lift `random.random_r` to the `gen` monad. -/
def choose {α : Type u} [preorder α] [bounded_random α] (x : α) (y : α) (p : x ≤ y) : gen ↥(set.Icc x y) :=
  reader_t.mk fun (_x : ulift ℕ) => rand.random_r x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat (x : ℕ) (y : ℕ) (p : x ≤ y) : gen ↥(set.Icc x y) :=
  choose x y p

/-- Generate a `nat` example between `x` and `y`. -/
def choose_nat' (x : ℕ) (y : ℕ) (p : x < y) : gen ↥(set.Ico x y) :=
  (fun (this : ∀ (i : ℕ), x < i → i ≤ y → Nat.pred i < y) => subtype.map Nat.pred sorry <$> choose (x + 1) y p) sorry

protected instance uliftable : uliftable gen gen :=
  reader_t.uliftable' (equiv.trans equiv.ulift (equiv.symm equiv.ulift))

protected instance has_orelse : has_orelse gen :=
  has_orelse.mk
    fun (α : Type u) (x y : gen α) =>
      do
        let b ← uliftable.up (choose_any Bool)
        ite (↥(ulift.down b)) x y

/-- Get access to the size parameter of the `gen` monad. For
reasons of universe polymorphism, it is specified in
continuation passing style. -/
def sized {α : Type u} (cmd : ℕ → gen α) : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Apply a function to the size parameter. -/
def resize {α : Type u} (f : ℕ → ℕ) (cmd : gen α) : gen α :=
  reader_t.mk fun (_x : ulift ℕ) => sorry

/-- Create `n` examples using `cmd`. -/
def vector_of {α : Type u} (n : ℕ) (cmd : gen α) : gen (vector α n) :=
  sorry

/-- Create a list of examples using `cmd`. The size is controlled
by the size parameter of `gen`. -/
def list_of {α : Type u} (cmd : gen α) : gen (List α) :=
  sized
    fun (sz : ℕ) =>
      do
        uliftable.up (choose_nat 0 (sz + 1) sorry)
        sorry

/-- Given a list of example generators, choose one to create an example. -/
def one_of {α : Type u} (xs : List (gen α)) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/-- Given a list of example generators, choose one to create an example. -/
def elements {α : Type u} (xs : List α) (pos : 0 < list.length xs) : gen α :=
  do
    uliftable.up (choose_nat' 0 (list.length xs) pos)
    sorry

/--
`freq_aux xs i _` takes a weighted list of generator and a number meant to select one of the generators.

If we consider `freq_aux [(1, gena), (3, genb), (5, genc)] 4 _`, we choose a generator by splitting
the interval 1-9 into 1-1, 2-4, 5-9 so that the width of each interval corresponds to one of the
number in the list of generators. Then, we check which interval 4 falls into: it selects `genb`.
-/
def freq_aux {α : Type u} (xs : List (ℕ+ × gen α)) (i : ℕ) : i < list.sum (list.map (subtype.val ∘ prod.fst) xs) → gen α :=
  sorry

/--
`freq [(1, gena), (3, genb), (5, genc)] _` will choose one of `gena`, `genb`, `genc` with
probabiities proportional to the number accompanying them. In this example, the sum of
those numbers is 9, `gena` will be chosen with probability ~1/9, `genb` with ~3/9 (i.e. 1/3)
and `genc` with probability 5/9.
-/
def freq {α : Type u} (xs : List (ℕ+ × gen α)) (pos : 0 < list.length xs) : gen α :=
  let s : ℕ := list.sum (list.map (subtype.val ∘ prod.fst) xs);
  (fun (ha : 1 ≤ s) =>
      (fun (this : 0 ≤ s - 1) =>
          uliftable.adapt_up gen gen (choose_nat 0 (s - 1) this)
            fun (i : ↥(set.Icc 0 (s - 1))) => freq_aux xs (subtype.val i) sorry)
        sorry)
    sorry

/-- Generate a random permutation of a given list. -/
def permutation_of {α : Type u} (xs : List α) : gen (Subtype (list.perm xs)) :=
  sorry


import syntax.syntaxCLK
import syntax.axiomsCLK
import semantics.semanticsCLK

local attribute [instance] classical.prop_decidable

open set

---------------------- Soundness ----------------------

noncomputable theorem soundnessCLK {agents : Type} [hN: fintype agents] (φ : formCLK agents) : axCLK φ → global_valid φ :=
begin
intro h,
induction h,

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  exact h1, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2 h3,
  apply h1,
    { exact h3,},

    { apply h2,
      exact h3 }, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  by_contradiction hf,
  exact (h1 hf) (h2 hf), },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  exact and.intro h1 h2, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact h1.left, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact h1.right, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1 h2,
  by_contradiction hf,
  exact h1 hf h2, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  exact m.f.E.liveness s h h1, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s,
  simp [s_entails_CLK],
  exact m.f.E.safety s h, },

{ unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
  intros m s h1,
  apply m.f.E.N_max,
  by_contradiction,
  exact h1 h, },

{ unfold global_valid valid_m,
  intros m s,
  have := m.f.E.monoticity s h_G {t: m.f.states | s_entails_CLK m t (h_φ & h_ψ)} {t: m.f.states | s_entails_CLK m t h_φ} _,
  { unfold s_entails_CLK s_entails_CLK.aux at ⊢ this,
    exact this },
  intros t h1,
  unfold s_entails_CLK s_entails_CLK.aux at h1,
  exact h1.left, },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1,
    exact m.f.E.superadd s h_G h_F {t: m.f.states | s_entails_CLK m t h_φ} {t: m.f.states | s_entails_CLK m t h_ψ} h1.left h1.right h_hInt, },

  { unfold global_valid valid_m,
    intros m s,
    have := h_ih_hImp m s,
    unfold s_entails_CLK s_entails_CLK.aux at ⊢ this,
    apply this,
    exact h_ih_hL m s, },

  { intros m s,
    have heq: {t: m.f.states | s_entails_CLK m t h_φ} = {t: m.f.states | s_entails_CLK m t h_ψ}, from
      begin
        apply set.ext,
        intros u,
        have h_ih := h_ih m u,
        unfold s_entails_CLK s_entails_CLK.aux at h_ih,
        cases h_ih,
        apply iff.intro,

        { intro hu,
          exact h_ih_left hu, },

        { intro hu,
          exact h_ih_right hu, }
      end,
    unfold s_entails_CLK s_entails_CLK.aux,
    apply and.intro,

    { intro h1,
      unfold s_entails_CLK s_entails_CLK.aux at *,
      rw ← heq,
      exact h1, },

    { intro h1,
      unfold s_entails_CLK s_entails_CLK.aux at *,
      rw heq,
      exact h1, } },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1 h2 t ht,
    exact h1 t ht (h2 t ht), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h,
    exact h s (m.f.rfl h_i s), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h t ht u hu,
    exact h u (m.f.trans h_i s t u ht hu), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s h1 h2,
    exact h1 (h2 s (m.f.rfl h_i s)), },

  { unfold global_valid valid_m s_entails_CLK s_entails_CLK.aux,
    intros m s t h2,
    apply h_ih, },
end

inductive single : Type
  | one: single

lemma univ_single : (set.univ: set single) = {single.one} :=
begin
  rw eq_comm,
  rw set.eq_univ_iff_forall,
  intro x,
  cases x,
  simp,
end

lemma single_nonempty : nonempty single :=
begin
  apply exists_true_iff_nonempty.mp,
  apply exists.intro single.one,
  exact trivial,
end

def m_ex (ha: nonempty agents) : modelCLK agents  :=

{ f :=
  { states := single,
    hs := single_nonempty,
    ha := ha,
    E  :=
    { E := λ s G, {{single.one}},
      liveness :=
      begin
        intros _ _ hf,
        simp at hf,
        rw set.ext_iff at hf,
        simp at hf,
        apply hf single.one,
        refl,
      end,
      safety:=
        begin
          intros _ _, simp at *,
          exact univ_single,
        end,
      N_max :=
        begin
          intros _ _ hxc, simp at *,
          rw ←univ_single at *,
          have hcond : {single.one} ≠ (∅: set single),

            { intro hf,
              rw set.ext_iff at hf,
              simp at *,
              apply hf single.one,
              refl, },
          simp [hcond] at *, by_contradiction,
          have hex: ∃ x, x ∈ X, from nonempty_def.mp (ne_empty_iff_nonempty.mp hxc),
          cases hex with s hs,
          cases s,
          rw ←singleton_subset_iff at hs,
          rw ←univ_single at hs,
          exact h (univ_subset_iff.mp hs),
        end,
      monoticity:=
        begin
          intros _ _ _ _ hxy hx,
          simp [←univ_single] at *,
          rw hx at hxy,
          exact univ_subset_iff.mp hxy,
        end,
      superadd:=
      begin
        intros _ _ _ _ _ hX hY hGF,
        simp at *,
        simp[hX, hY],
      end },
    rel := λ a s, {s},
    rfl := by simp,
    sym :=
    begin
      intros i s t h,
      simp at *,
      rw h,
    end,
    trans :=
    begin
      intros i s t u hst htu,
      simp at *,
      simp[hst, htu],
    end, },
  v := λ _, {}, }

lemma nprfalseCLK {agents: Type} (ha: nonempty agents) [fintype agents] : ¬ @axCLK agents (⊥) :=
begin
apply (mt (soundnessCLK (@formCLK.bot agents))),
intro hf ,
simp[global_valid, valid_m, s_entails_CLK] at hf,
apply hf (m_ex ha),
exact single.one,
end


import analysis.inner_product_space.pi_L2
import topology.paracompact

--OUTPUT 1
theorem ℝn_paracompact (n : ℕ) : paracompact_space (euclidean_space ℝ (fin n)) :=
begin
  -- Let $\mathcal{A}$ be an open covering of $\mathbb{R}^n$.
  assume A : set (euclidean_space ℝ (fin n)),
  assume hA : is_open_cover A,
  -- We now construct a locally finite open refinement $\mathcal{C}$ of $\mathcal{A}$ that covers $\mathbb{R}^n$.
  -- First, we define a collection of pen balls.
  -- Let $B_0 = \phi$, and for each $n \in \mathbb{N}$, let $B_m$ denote the ball of radius $m$ centered at 0.
  have h1 : ∀ m : ℕ, ∃ Bm : set (euclidean_space ℝ (fin n)), is_open Bm ∧ is_ball Bm (0 : euclidean_space ℝ (fin n)) m, from by auto [is_open_ball],
  -- Given $m$, set $\Bar{B_m}$ is compact in $\mathbb{R}^n$ by the Heine-Borel theorem,
  have h2 : ∀ m : ℕ, is_compact (closure (classical.some (h1 m).exists)), from by auto [is_compact_closure, is_compact_ball],
  -- so choose finitely many elements of $\mathcal{A}$ that cover $\Bar{B_m}$ and intersect each one with the open set $\mathbb{R}^n \setminus \Bar{B_{m - 1}}$,
  have h3 : ∀ m : ℕ, ∃ Cm : set (euclidean_space ℝ (fin n)), is_open Cm ∧ is_finite Cm ∧ (∀ (U : set (euclidean_space ℝ (fin n))) (hU : U ∈ A), U ∩ Cm ≠ ∅) ∧ (Cm ⊆ (euclidean_space ℝ (fin n)) \ (classical.some (h1 (m - 1)).exists)), from by auto [is_open_inter, is_open_compl, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is_open_closure, is_open_ball, is
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem ℝn_paracompact (n : ℕ) : paracompact_space (euclidean_space ℝ (fin n)) :=
begin
  -- Let $\mathcal{A}$ be an open covering of $\mathbb{R}^n$.
  assume A : set (euclidean_space ℝ (fin n)),
  assume hA : is_open_cover A,
  -- We now construct a locally finite open refinement $\mathcal{C}$ of $\mathcal{A}$ that covers $\mathbb{R}^n$.
  -- First, we define a collection of pen balls.
  -- Let $B_0 = \phi$, and for each $n \in \mathbb{N}$, let $B_m$ denote the ball of radius $m$ centered at 0.
  let B : ℕ → set (euclidean_space ℝ (fin n)) := λ m, {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) m) ∧ x = y},
  have hB : ∀ m : ℕ, B m = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) m) ∧ x = y}, from by auto [B],
  have hB0 : B 0 = ∅, from by auto [B, hB],
  have hBm : ∀ m : ℕ, B m = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) m) ∧ x = y}, from by auto [B, hB],
  have hBm1 : ∀ m : ℕ, B (m + 1) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 1)) ∧ x = y}, from by auto [B, hB],
  have hBm2 : ∀ m : ℕ, B (m + 2) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 2)) ∧ x = y}, from by auto [B, hB],
  have hBm3 : ∀ m : ℕ, B (m + 3) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 3)) ∧ x = y}, from by auto [B, hB],
  have hBm4 : ∀ m : ℕ, B (m + 4) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 4)) ∧ x = y}, from by auto [B, hB],
  have hBm5 : ∀ m : ℕ, B (m + 5) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 5)) ∧ x = y}, from by auto [B, hB],
  have hBm6 : ∀ m : ℕ, B (m + 6) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 6)) ∧ x = y}, from by auto [B, hB],
  have hBm7 : ∀ m : ℕ, B (m + 7) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 7)) ∧ x = y}, from by auto [B, hB],
  have hBm8 : ∀ m : ℕ, B (m + 8) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 8)) ∧ x = y}, from by auto [B, hB],
  have hBm9 : ∀ m : ℕ, B (m + 9) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 9)) ∧ x = y}, from by auto [B, hB],
  have hBm10 : ∀ m : ℕ, B (m + 10) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 10)) ∧ x = y}, from by auto [B, hB],
  have hBm11 : ∀ m : ℕ, B (m + 11) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 11)) ∧ x = y}, from by auto [B, hB],
  have hBm12 : ∀ m : ℕ, B (m + 12) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 12)) ∧ x = y}, from by auto [B, hB],
  have hBm13 : ∀ m : ℕ, B (m + 13) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 13)) ∧ x = y}, from by auto [B, hB],
  have hBm14 : ∀ m : ℕ, B (m + 14) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 14)) ∧ x = y}, from by auto [B, hB],
  have hBm15 : ∀ m : ℕ, B (m + 15) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 15)) ∧ x = y}, from by auto [B, hB],
  have hBm16 : ∀ m : ℕ, B (m + 16) = {x : euclidean_space ℝ (fin n) | ∃ y : euclidean_space ℝ (fin n), y ∈ (ball (0 : euclidean_space ℝ (fin n)) (m + 16)) ∧ x
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem ℝn_paracompact (n : ℕ) : paracompact_space (euclidean_space ℝ (fin n)) :=
begin
  -- Let $\mathcal{A}$ be an open covering of $\mathbb{R}^n$.
  assume A : set (euclidean_space ℝ (fin n)),
  assume hA : is_open_cover A,
  -- We now construct a locally finite open refinement $\mathcal{C}$ of $\mathcal{A}$ that covers $\mathbb{R}^n$.
  have h1 : ∃ C : set (euclidean_space ℝ (fin n)), is_open_cover C ∧ is_locally_finite C ∧ is_open_refinement A C, from by auto [paracompact_space.paracompact_iff_locally_finite_open_refinement],
  -- Let $B_0 = \phi$, and for each $n \in \mathbb{N}$, let $B_m$ denote the ball of radius $m$ centered at 0.
  have h2 : ∀ m : ℕ, ∃ Bm : set (euclidean_space ℝ (fin n)), is_ball Bm (0 : euclidean_space ℝ (fin n)) m, from by auto [is_ball],
  -- Given $m$, set $\Bar{B_m}$ is compact in $\mathbb{R}^n$ by the Heine-Borel theorem,
  have h3 : ∀ m : ℕ, ∃ Bm : set (euclidean_space ℝ (fin n)), is_ball Bm (0 : euclidean_space ℝ (fin n)) m ∧ is_compact Bm, from by auto [is_ball, is_compact],
  -- so choose finitely many elements of $\mathcal{A}$ that cover $\Bar{B_m}$ and intersect each one with the open set $\mathbb{R}^n \setminus \Bar{B_{m - 1}}$,
  have h4 : ∀ m : ℕ, ∃ Cm : set (euclidean_space ℝ (fin n)), is_ball Cm (0 : euclidean_space ℝ (fin n)) m ∧ is_compact Cm ∧ is_finite Cm ∧ is_open_cover Cm, from by auto [is_ball, is_compact, is_finite, is_open_cover],
  -- and let $\mathcal{C}_{m}$ denote this collection of open sets (each an open subset of an element of $\mathcal{A}$).
  have h5 : ∀ m : ℕ, ∃ Cm : set (euclidean_space ℝ (fin n)), is_ball Cm (0 : euclidean_space ℝ (fin n)) m ∧ is_compact Cm ∧ is_finite Cm ∧ is_open_cover Cm ∧ is_open_refinement A Cm, from by auto [is_ball, is_compact, is_finite, is_open_cover, is_open_refinement],
  -- So $\mathcal{C} = \bigcup_{m = 0}^{\infty} \mathcal{C}_m$ is an open refinement of $\mathcal{A}$.
  have h6 : ∃ C : set (euclidean_space ℝ (fin n)), is_open_refinement A C, from by auto [is_open_refinement],
  -- Note that $\mathcal{C}$ covers $\mathbb{R}^n$ since for any $x \in \mathbb{R}^n$, there is a smallest $m \in \mathbb{N}$ such that $x \in \Bar{B_{m}}$ (namely, some $m$ where $\rVert x \lVert \leq m \leq \rVert x \lVert + 1$), and so $x$ is an element of $\mathcal{C}_m$.
  have h7 : ∃ C : set (euclidean_space ℝ (fin n)), is_open_refinement A C ∧ is_open_cover C, from by auto [is_open_refinement, is_open_cover],
  -- Now collection $\mathcal{C}$ is locally finite since for given $x \in \mathbb{R}^n$, neighborhood $B_m$ intersects only finitely many elements of $\mathcal{C}$, namely those elements in collection $\mathcal{C}_1 \cup \mathcal{C}_2 \cup \cdots \mathcal{C}_m$.
  have h8 : ∃ C : set (euclidean_space ℝ (fin n)), is_open_refinement A C ∧ is_open_cover C ∧ is_locally_finite C, from by auto [is_open_refinement, is_open_cover, is_locally_finite],
  -- So $\mathcal{C}$ is a locally finite open refinement of $\mathcal{A}$ that covers $\mathbb{R}^n$, hence $\mathbb{R}^n$ is paracompact.
  show paracompact_space (euclidean_space ℝ (fin n)), from by auto [paracompact_space.paracompact_iff_locally_finite_open_refinement],
end

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

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

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
\mathbb{R}^n is paracompact
$\mathbb{R}^n$ is paracompact for all $n$.
`proof`
Let $\mathcal{A}$ be an open covering of $\mathbb{R}^n$. We now construct a locally finite open refinement $\mathcal{C}$ of $\mathcal{A}$ that covers $\mathbb{R}^n$. First, we define a collection of pen balls. Let $B_0 = \phi$, and for each $n \in \mathbb{N}$, let $B_m$ denote the ball of radius $m$
centered at 0. Given $m$, set $\Bar{B_m}$ is compact in $\mathbb{R}^n$ by the Heine-Borel theorem, so choose finitely many elements of $\mathcal{A}$ that cover $\Bar{B_m}$ and intersect each one with the open set $\mathbb{R}^n \setminus \Bar{B_{m - 1}}$, and let $\mathcal{C}_{m}$ denote this collection of open sets (each an open subset of an element of $\mathcal{A}$). So $\mathcal{C} = \bigcup_{m = 0}^{\infty} \mathcal{C}_m$ is an open refinement of $\mathcal{A}$. Note that $\mathcal{C}$ covers $\mathbb{R}^n$ since for any $x \in \mathbb{R}^n$, there is a smallest $m \in \mathbb{N}$ such that $x \in \Bar{B_{m}}$ (namely, some $m$ where $\rVert x \lVert \leq m \leq \rVert x \lVert + 1$), and so $x$ is an element of $\mathcal{C}_m$. Now collection $\mathcal{C}$ is locally finite since for given $x \in \mathbb{R}^n$, neighborhood $B_m$ intersects only finitely many elements of $\mathcal{C}$, namely those elements in collection $\mathcal{C}_1 \cup \mathcal{C}_2 \cup \cdots \mathcal{C}_m$. So $\mathcal{C}$ is a locally finite open refinement of $\mathcal{A}$ that covers $\mathbb{R}^n$, hence $\mathbb{R}^n$ is paracompact.

QED
-/
theorem  ℝn_paracompact (n : ℕ) : paracompact_space (euclidean_space ℝ (fin n)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


import FOL.deduction FOL.semantics FOL.lindenbaum order.filter.ultrafilter data.finset.basic
open encodable

universes u v

namespace fol
open_locale logic_symbol
open logic.semantics

variables {L : language.{u}} {I : Type u} [inhabited I] (F : ultrafilter I) {𝔄 : I → Structure L}

local notation (name := dom) `|`M`|` := Structure.dom M

def uequiv : (Π i, |𝔄 i|) → (Π i, |𝔄 i|) → Prop :=
λ u₁ u₂, {i | u₁ i = u₂ i} ∈ F

notation u` ~[`:80 F`] `v:80 := uequiv F u v

@[simp] lemma uequiv_refl (u : Π i, |𝔄 i|) : u ~[F] u :=
by { simp[uequiv], exact F.univ_sets }

lemma uequiv_symm {u₁ u₂ : Π i, |𝔄 i|} : u₁ ~[F] u₂ → u₂ ~[F] u₁ :=
by { simp[uequiv], have : {i | u₁ i = u₂ i} = {i | u₂ i = u₁ i}, { ext, simp, exact eq_comm }, simp[this] }

lemma uequiv_trans {u₁ u₂ u₃ : Π i, |𝔄 i|} : u₁ ~[F] u₂ → u₂ ~[F] u₃ → u₁ ~[F] u₃ :=
by { simp[uequiv], intros h₁ h₂,
     have : {i | u₁ i = u₂ i} ∩ {i | u₂ i = u₃ i} ⊆ {i | u₁ i = u₃ i},
     { intros i hi, simp* at* },
     exact F.sets_of_superset (F.inter_sets h₁ h₂) this }

theorem uequiv_equivalence : equivalence (@uequiv L I _ F 𝔄) :=
⟨uequiv_refl F, λ _ _ , uequiv_symm F, λ _ _ _, uequiv_trans F⟩

@[reducible, simp, instance]
def ult (𝔄 : I → Structure L) (F : ultrafilter I) : setoid (Π i, |𝔄 i|) := ⟨@uequiv L I _ F 𝔄, uequiv_equivalence F⟩

def Ult (𝔄 : I → Structure L) (F : ultrafilter I) : Type* :=
quotient (ult 𝔄 F: setoid (Π i, |𝔄 i|))

def to_quotient {𝔄 : I → Structure L} {F : ultrafilter I} (u : Π i, |𝔄 i|) : Ult 𝔄 F := quotient.mk' u

notation `⟦`u`⟧*` :max := to_quotient u

instance : inhabited (Ult 𝔄 F) := ⟨⟦λ i, default⟧*⟩

namespace Ult
open logic.semantics

@[elab_as_eliminator]
protected lemma ind_on {C : Ult 𝔄 F → Prop} (u : Ult 𝔄 F)
  (h : ∀ u : Π i, |𝔄 i|, C ⟦u⟧*) : C u :=
quotient.induction_on' u h

@[elab_as_eliminator, reducible]
protected def lift_on {φ} (d : Ult 𝔄 F) (f : (Π i, |𝔄 i|) → φ)
  (h : ∀ (v u : Π i, |𝔄 i|), v ~[F] u → f v = f u) : φ :=
quotient.lift_on' d f h

@[simp]
protected lemma lift_on_eq {φ} (u₀ : Π i, |𝔄 i|) (f : (Π i, |𝔄 i|) → φ)
  (h : ∀ v u, v ~[F] u → f v = f u) : fol.Ult.lift_on F ⟦u₀⟧* f h = f u₀ := rfl

@[elab_as_eliminator, reducible, simp]
protected def lift_on₂ {φ} (u₁ u₂ : Ult 𝔄 F) (f : (Π i, |𝔄 i|) → (Π i, |𝔄 i|) → φ)
  (h : ∀ u₁ u₂ v₁ v₂, u₁ ~[F] v₁ → u₂ ~[F] v₂ → f u₁ u₂ = f v₁ v₂) : φ :=
quotient.lift_on₂' u₁ u₂ f h

@[simp]
protected lemma lift_on₂_eq {φ} (u₁ u₂ : Π i, |𝔄 i|) (f : (Π i, |𝔄 i|) → (Π i, |𝔄 i|) → φ)
  (h : ∀ t₁ t₂ u₁ u₂, (t₁ ~[F] u₁) → (t₂ ~[F] u₂) → f t₁ t₂ = f u₁ u₂) :
  fol.Ult.lift_on₂ F ⟦u₁⟧* ⟦u₂⟧* f h = f u₁ u₂ := rfl

@[elab_as_eliminator, reducible]
protected def lift_on_finitary {φ} {n : ℕ} (v : finitary (Ult 𝔄 F) n) (f : finitary (Π i, |𝔄 i|) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, |𝔄 i|) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp]
protected lemma lift_on_finitary_eq {φ} {n} (v : finitary (Π i, |𝔄 i|) n) (f : finitary (Π i, |𝔄 i|) n → φ)
  (h : ∀ v₁ v₂ : finitary (Π i, |𝔄 i|) n, (∀ n, (v₁ n) ~[F] (v₂ n)) → f v₁ = f v₂) :
  fol.Ult.lift_on_finitary F (λ x, ⟦v x⟧*) f h = f v :=
quotient.lift_on_finitary_eq v f h

@[simp] lemma of_eq_of {u₁ u₂ : Π i, |𝔄 i|} : (⟦u₁⟧* : Ult 𝔄 F) = ⟦u₂⟧* ↔ u₁ ~[F] u₂ :=
by simp[to_quotient, quotient.eq']

lemma equivs_mem {n} {v₁ v₂ : finitary (Π i, |𝔄 i|) n} (h : ∀ (x : fin n), {i : I | v₁ x i = v₂ x i} ∈ F) :
  {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ∈ F :=
begin
  induction n with n IH,
  { have : {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)} = set.univ,
    { ext i, simp }, rw this, exact F.univ_sets },
  { have ss : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ⊆ {i : I | (λ x, v₁ x i) = (λ x, v₂ x i)},
    { intros i hi, simp[finitary.tail] at*,
      funext x, refine fin.cases _ _ x,
      { exact hi.1 },
      { intros j, have := congr_fun hi.2 j, simp at this, exact this } },
    have : {i | v₁ 0 i = v₂ 0 i} ∩ {i | (λ x, v₁.tail x i) = (λ x, v₂.tail x i)} ∈ F,
      from (F.inter_sets (h _) (@IH v₁.tail v₂.tail (λ x, h _))),
    refine F.sets_of_superset this ss }
end

lemma fn_equiv {n} {v₁ v₂ : finitary (Π i, |𝔄 i|) n} (h : ∀ x, v₁ x ~[F] v₂ x) (f : L.fn n) :
  (λ i, (𝔄 i).fn f (λ x, v₁ x i)) ~[F] (λ i, (𝔄 i).fn f (λ x, v₂ x i)) :=
begin
  simp[uequiv] at*,
  have : {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).fn f (λ x, v₁ x i) = (𝔄 i).fn f (λ x, v₂ x i)},
  { intros i hi, simp* at* },
  exact F.sets_of_superset (equivs_mem F h) this
end

lemma pr_equiv : ∀ {n} {v₁ v₂ : finitary (Π i, |𝔄 i|) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F ↔ {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F :=
begin
  suffices : ∀ {n} {v₁ v₂ : finitary (Π i, |𝔄 i|) n} (h : ∀ x, v₁ x ~[F] v₂ x) (p : L.pr n),
  {i | (𝔄 i).pr p (λ x, v₁ x i)} ∈ F → {i | (𝔄 i).pr p (λ x, v₂ x i)} ∈ F,
  { intros n v₁ v₂ eqn p, refine ⟨this eqn p, this (λ x, uequiv_symm _ (eqn x)) p⟩ },
  intros n v₁ v₂ eqn p h,
  have : {i | (𝔄 i).pr p (λ x, v₁ x i)} ∩ {i | (λ x, v₁ x i) = (λ x, v₂ x i)} ⊆ {i | (𝔄 i).pr p (λ x, v₂ x i)},
  { intros i hi, simp* at*, simp[←hi.2], exact hi.1 },
  refine F.sets_of_superset (F.inter_sets h (equivs_mem _ eqn)) this
end

def product_fn (n) (f : L.fn n) : finitary (Ult 𝔄 F) n → Ult 𝔄 F :=
λ v, fol.Ult.lift_on_finitary F v (λ v, (⟦λ i, (𝔄 i).fn f (λ x, v x i)⟧* : Ult 𝔄 F)) $ λ u₁ u₂ eqn,
by { simp, exact fn_equiv F eqn f }

def product_pr (n) (p : L.pr n) : finitary (Ult 𝔄 F) n → Prop :=
λ v, fol.Ult.lift_on_finitary F v (λ v, {i | (𝔄 i).pr p (λ x, v x i)} ∈ F) $ λ u₁ u₂ eqn,
by { simp, exact pr_equiv F eqn p }

def product (𝔄 : I → Structure L) (F : ultrafilter I) : Structure L := ⟨Ult 𝔄 F, ⟨default⟩, product_fn F, product_pr F⟩
notation `ℿ `𝔄` ⫽ `F:90 := product 𝔄 F

variables {F}

@[simp] lemma ult_eq : Ult 𝔄 F = |ℿ 𝔄 ⫽ F| := rfl

private lemma Structure_exists (p : formula L) {e : ∀ i, ℕ → |𝔄 i|} (h : {i | ∃ u, 𝔄 i ⊧[u ⌢ e i] p } ∈ F) :
  ∃ (u : Π i, |𝔄 i|), {i | 𝔄 i ⊧[(u i) ⌢ e i] p} ∈ F :=
begin
  have : ∀ i, ∃ u, i ∈ {i | ∃ u, 𝔄 i ⊧[u ⌢ e i] p} → 𝔄 i ⊧[u ⌢ e i] p,
  { intros i, simp, by_cases C : i ∈ {i | ∃ u, 𝔄 i ⊧[u ⌢ e i] p}; simp at C,
    { rcases C with ⟨u, hu⟩, refine ⟨u, λ v _, hu⟩ },
    { refine ⟨default, λ _ h, _⟩, exfalso, refine C _ h } },
  rcases classical.skolem.mp this with ⟨u, hu⟩,
  refine ⟨u, _⟩, exact F.sets_of_superset h hu
end

lemma Structure_fn_eq {n} (f : L.fn n) : (ℿ 𝔄 ⫽ F).fn f = product_fn F _ f := rfl

lemma Structure_pr_eq {n} (r : L.pr n) : (ℿ 𝔄 ⫽ F).pr r = product_pr F _ r := rfl

lemma models_pr_iff_lmm : ∀ (t : term L) (e : ∀ i, ℕ → |𝔄 i|),
  (@term.val _ (ℿ 𝔄 ⫽ F) (λ n, ⟦λ i, e i n⟧*) t) = ⟦λ i, @term.val _ (𝔄 i) (λ n, e i n) t⟧*
| (#n)                _ := by simp
| (@term.app _ n f v) e :=
  by { simp[Structure_fn_eq, product_fn],
       let v' : finitary (Π i, |𝔄 i|) n := λ x i, (v x).val (𝔄 i) (e i),
       have : (λ x, @term.val _ (ℿ 𝔄 ⫽ F) (λ n, ⟦(λ i, e i n)⟧*) (v x)) = λ x, ⟦v' x⟧*,
       { funext x, simp[v', models_pr_iff_lmm (v x)] },
       simp[this] }

lemma models_pr_iff {n} (r : L.pr n) (v : finitary (term L) n) (e : ∀ i, ℕ → |𝔄 i|) :
  (ℿ 𝔄 ⫽ F).pr r (λ x, (v x).val (ℿ 𝔄 ⫽ F) (λ n, ⟦λ i, e i n⟧*)) ↔ {i | (𝔄 i).pr r (λ x, (v x).val (𝔄 i) (e i))} ∈ F :=
by simp[models_pr_iff_lmm, Structure_pr_eq, product_pr]

-- Łoś's theorem
theorem fundamental_param : ∀ (p : formula L) (e : ∀ i, ℕ → |𝔄 i|),
  ℿ 𝔄 ⫽ F ⊧[λ n, ⟦λ i, e i n⟧*] p ↔ {i | 𝔄 i ⊧[e i] p} ∈ F
| ⊤                 _ := by { simp, exact F.univ_sets }
| (formula.app p v) e := models_pr_iff p _ _
| (t₁ =' t₂)      e := by simp[models_pr_iff_lmm]; refl
| (p ⟶ q)       e := by { simp[fundamental_param p, fundamental_param q],
    show {i | 𝔄 i ⊧[e i] p} ∈ F → {i | 𝔄 i ⊧[e i] q} ∈ F ↔ {i | 𝔄 i ⊧[e i] p → 𝔄 i ⊧[e i] q} ∈ F,
    split,
    { intros h, by_cases C : {i | 𝔄 i ⊧[e i] p} ∈ F,
      { have : {i | 𝔄 i ⊧[e i] q} ⊆ {i | 𝔄 i ⊧[e i] p → 𝔄 i ⊧[e i] q}, { intros i hi, simp* at* },
        exact F.sets_of_superset (h C) this },
      { have : {i | 𝔄 i ⊧[e i] p}ᶜ ∈ F, from ultrafilter.compl_mem_iff_not_mem.mpr C,
        have ss : {i | 𝔄 i ⊧[e i] p}ᶜ ⊆ {i | 𝔄 i ⊧[e i] p → 𝔄 i ⊧[e i] q},
        { intros i hi, simp* at* },
        exact F.sets_of_superset this ss } },
    { intros h₁ h₂,
      have : {i | 𝔄 i ⊧[e i] p} ∩ {i | 𝔄 i ⊧[e i] p → 𝔄 i ⊧[e i] q} ⊆ {i | 𝔄 i ⊧[e i] q},
      { intros i hi, simp at*, refine hi.2 hi.1 },
      exact filter.mp_mem h₂ h₁ } }
| (∼p)          e := by { simp[fundamental_param p], exact ultrafilter.eventually_not.symm }
| (∀.p)          e := by { simp,
    calc
      (∀ u, ℿ 𝔄 ⫽ F ⊧[u ⌢ λ n, ⟦λ i, e i n⟧*] p)
          ↔ (∀ (u : Π i, |𝔄 i|), ℿ 𝔄 ⫽ F ⊧[λ n, ⟦λ i, (λ i, (u i) ⌢ (e i)) i n⟧*] p) :
        by { have eqn: ∀ u, (⟦u⟧* ⌢ λ n, ⟦(λ i, e i n)⟧*) = (λ n, ⟦(λ i, (u i) ⌢ e i $ n)⟧* : ℕ → |ℿ 𝔄 ⫽ F|),
             { intros i, funext x, cases x; simp[concat] }, simp, split,
             { intros h u, have := h ⟦u⟧*, simp[eqn] at this, exact this },
             { intros h u, induction u using fol.Ult.ind_on, simp[eqn, h] } }
      ... ↔ (∀ (u : Π i, |𝔄 i|), {i | 𝔄 i ⊧[u i ⌢ e i] p} ∈ F) :
        by { split, { intros h u, simp[←fundamental_param  p _, h] }, { intros h u, simp[fundamental_param  p _, h] } }
      ... ↔ {i | ∀ (u : |𝔄 i|), 𝔄 i ⊧[u ⌢ e i] p} ∈ F :
        by { split,
             { contrapose,
               simp[←ultrafilter.compl_mem_iff_not_mem, set.compl_def], intros h,
               show ∃ (u : Π i, |𝔄 i|), {i | ¬𝔄 i ⊧[u i ⌢ e i] p} ∈ F, from Structure_exists (∼p) h },
             { refine λ h u, F.sets_of_superset h (λ _ _ , by simp* at*) } } }

theorem fundamental {p : formula L} :
  ℿ 𝔄 ⫽ F ⊧ p ↔ {i | 𝔄 i ⊧ p} ∈ F :=
begin
  calc
    ℿ 𝔄 ⫽ F ⊧ p ↔ ℿ 𝔄 ⫽ F ⊧ nfal p p.arity : nfal_models_iff.symm
    ...         ↔ {i | 𝔄 i ⊧ nfal p p.arity} ∈ F :
      by simpa[eval_is_sentence_iff _ (formula.nfal_is_sentence p)] using fundamental_param (nfal p p.arity) (λ i n, default)
    ...         ↔ {i | 𝔄 i ⊧ p} ∈ F :
      by { have : {i | 𝔄 i ⊧ nfal p p.arity} = {i | 𝔄 i ⊧ p},
           { ext i, simp, refine nfal_models_iff },
           simp[this] }
end

end Ult
end fol

namespace fol
variables {L : language.{u}}

def finTheory (T : Theory L) := {S : finset (formula L) // ∀ {x}, x ∈ S → x ∈ T}

variables {T : Theory L}

def finTheory.empty {T : Theory L} : finTheory T := ⟨∅, by simp⟩
instance : inhabited (finTheory T) := ⟨⟨∅, by simp⟩⟩

noncomputable def finTheory.insert (P : finTheory T) (p : formula L) (h : p ∈ T) : finTheory T :=
⟨insert p P.val, λ x hx,  by { simp at hx, cases hx, simp[hx, h], refine P.property hx }⟩

@[simp] lemma finTheory.insert_val (P : finTheory T) (p : formula L) (h : T p) :
  (P.insert p h).val = insert p P.val := rfl

instance : has_coe (finTheory T) (set (formula L)) := ⟨λ S, {p | p ∈ S.val}⟩

namespace compactness

variables (𝔄 : finTheory T → Structure L)

def formdomain (p : formula L) : set (finTheory T) := {i | 𝔄 i ⊧ p}

def F : set (set (finTheory T)) := {x | ∃ p, T p ∧ x = formdomain 𝔄 p}

private lemma finite_intersection_lmm (h : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)), (↑S : set (set (finTheory T))) ⊆ F 𝔄 →
  ∃ P : finTheory T,
  (∀ p, p ∈ P.val → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ P.val ∧ S' = formdomain 𝔄 p) :=
begin
  intros S, induction S using finset.induction with i S i_fresh IH,
  { intros _, simp[set.nonempty], rcases h with ⟨p₀, hyp_p₀⟩,
    refine ⟨⟨∅, by simp⟩, _⟩, unfold_coes, simp },
  { intros h, simp at*,
    have lmm₁ : ↑S ⊆ F 𝔄, from set.subset.trans (set.subset_insert _ _) h,
    have : ∃ (P : finTheory T),
      (∀ p, p ∈ ↑P → formdomain 𝔄 p ∈ S) ∧ (∀ S', S' ∈ S → ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p),
    from IH lmm₁, rcases this with ⟨P, IH₁, IH₂⟩,
    have : ∃ p, T p ∧ i = formdomain 𝔄 p, from h (set.mem_insert i ↑S),
    rcases this with ⟨p, hyp_p, rfl⟩,
    refine ⟨P.insert p hyp_p, _, _, _⟩; unfold_coes; simp,
    { refine λ q hyp_q, or.inr (IH₁ _ hyp_q) },
    { refine ⟨p, or.inl rfl, rfl⟩ },
    { intros S' hyp_S',
      have : ∃ p, p ∈ ↑P ∧ S' = formdomain 𝔄 p, from IH₂ _ hyp_S', rcases this with ⟨p, hyp, rfl⟩,
      refine ⟨p, or.inr hyp, rfl⟩ } }
end

theorem finite_intersection (h : ∃ p, T p) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∀ S : finset (set (finTheory T)),
  (↑S : set (set (finTheory T))) ⊆ F 𝔄 → (⋂₀ (↑S : set (set (finTheory T)))).nonempty :=
begin
  intros S hS, have := finite_intersection_lmm _ h H S hS, rcases this with ⟨P, hyp⟩,
  refine ⟨P, λ S' hS', _⟩,
  have := hyp.2 S' hS', rcases this with ⟨p, hyp_p, rfl⟩, simp[formdomain] at*,
  refine H _ _ hyp_p
end

theorem ultrafilter_exists (h : ∃ p, p ∈ T) (H : ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p) :
  ∃ U : ultrafilter (finTheory T), F 𝔄 ⊆ U.to_filter.sets :=
ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ (finite_intersection _ h H)

theorem compact (T : Theory L) :
  Satisfiable T ↔ ∀ S : finset (formula L), ↑S ⊆ T → Satisfiable (S : Theory L) :=
  ⟨by { intros H S hyp_S, rcases H with ⟨𝔄, hyp⟩,
        refine ⟨𝔄, λ p h, hyp (hyp_S h)⟩ },
   by { suffices : (∀ S : finTheory T, Satisfiable (S : Theory L)) → Satisfiable T,
        { intros h, refine this (λ S, _),
          rcases h S.val (λ p, S.property) with ⟨𝔄, hyp_𝔄⟩, refine ⟨𝔄, hyp_𝔄⟩ },
    intros H, by_cases C : T = ∅,
        { rcases C with rfl, refine empty_has_Structure },
        { have ex : ∃ p, p ∈ T, { by_contra, simp at*, refine C _, { ext x, simp, refine h _ } },
          have : ∃ (𝔄 : finTheory T → Structure L), ∀ (i : finTheory T) p, p ∈ i.val → 𝔄 i ⊧ p,
          from classical.skolem.mp H, rcases this with ⟨𝔄, hyp_𝔄⟩,
          have := ultrafilter_exists _ ex hyp_𝔄, rcases this with ⟨U, hyp_U⟩,
          use ℿ 𝔄 ⫽ U, intros p hyp_p, rw Ult.fundamental,
          have : {i | 𝔄 i ⊧ p} ∈ F 𝔄, { refine ⟨p, hyp_p, rfl⟩ },
          exact hyp_U this } }⟩

end compactness

end fol


import Runtime.Network.Graph.Path.Child

namespace Network.Graph.Path

inductive Sibling : Path graph start → Path graph start → Prop
  | nil : Sibling nil nil
  | cons : (path₁ ≻ parent) → (path₂ ≻ parent) → Sibling path₁ path₂

infix:40 " ≂ " => Sibling

theorem Sibling.refl : ∀ path : Path graph start, (path ≂ path)
  | .nil => nil
  | .cons _ subpath => by have ⟨_, h⟩ := Succ.cons subpath; exact cons h h

theorem Sibling.symm : (path₁ ≂ path₂) → (path₂ ≂ path₁)
  | nil => nil
  | cons h₁ h₂ => cons h₂ h₁

theorem Sibling.iff_eq_prefix : (path₁ ≂ path₂) ↔ (path₁.prefix? = path₂.prefix?) := by
  constructor
  case mp =>
    cases path₁ <;> cases path₂
    case nil.nil => simp
    case cons.cons => intro h; cases h; simp_all [Succ]
    case nil.cons => intro h; cases h; case _ h _ => have := h.isCons; contradiction
    case cons.nil => intro h; cases h; case _ h   => have := h.isCons; contradiction
  case mpr =>
    intro h
    by_cases path₁.prefix?.isSome
    case inr hp =>
      have hc₁ := isNil_iff_not_isCons.mpr <| mt prefix?_isSome_iff_isCons.mpr hp; simp at hc₁
      rw [h] at hp
      have hc₂ := isNil_iff_not_isCons.mpr <| mt prefix?_isSome_iff_isCons.mpr hp; simp at hc₂
      simp [hc₁, hc₂, Sibling.nil]
    case inl hp =>
      have ⟨_, hp₁⟩ := Option.isSome_iff_exists.mp hp
      rw [h] at hp
      have ⟨_, hp₂⟩ := Option.isSome_iff_exists.mp hp
      simp_all
      exact Sibling.cons hp₁ hp₂

instance : Decidable (path₁ ≂ path₂) :=
  if h : path₁.prefix? = path₂.prefix?
  then isTrue <| Sibling.iff_eq_prefix.mpr h
  else isFalse <| mt Sibling.iff_eq_prefix.mp h

end Network.Graph.Path


import util.predicate
import util.classical
import util.meta.tactic
import tactic.linarith

@[user_attribute]
meta def strengthening_attr : user_attribute :=
{ name := `strengthening
, descr := "
Strenghtening lemmas to facilitate the stripping of small details in application.
Expected shape `∀ p : pred' α, ⊩ f p ⟶ g p`
" }

run_cmd mk_simp_attr `tl_simp [`simp]
run_cmd
do ns ← attribute.get_instances `simp,
   let ns : list name := ns.filter (λ n, name.is_prefix_of `predicate n),
   n ← tactic.mk_const (mk_simp_attr_decl_name `tl_simp),
   ns.mmap' (λ n, user_attribute.set simp_attr.tl_simp n () tt),
   return ()

namespace tactic.interactive
open lean interactive.types
open interactive lean.parser tactic
open list (hiding map) functor predicate
local postfix *:9001 := many

meta def TL_unfold (cs : parse ident*) (loc : parse location) : tactic unit :=
do unfold_coes loc, unfold (cs ++ [`var.apply,`pred'.mk]) loc

end tactic.interactive

namespace temporal

open predicate nat

universes u u₀ u₁ u₂ u₃

variables {α : Sort u₀} {β : Sort u₁} {γ : Sort u₂} {φ : Sort u₃}

@[reducible]
def tvar := var ℕ

@[reducible]
def cpred := tvar Prop

abbreviation act (β : Sort u) := β → β → Prop

def eventually (p : cpred) : cpred :=
⟨ λ i, ∃ j, p.apply (i+j) ⟩
def henceforth (p : cpred) : cpred :=
⟨ λ i, ∀ j, p.apply (i+j) ⟩
def next (p : tvar α) : tvar α :=
⟨ λ i, p.apply (i.succ) ⟩

def until (p q : cpred) : cpred :=
⟨ λ i, ∃ j, i+j ⊨ q ∧ ∀ k < j, i+k ⊨ p ⟩

def wait (p q : cpred) : cpred :=
until p q ⋁ henceforth p

def action (a : act α) (v : tvar α) : cpred :=
lifted₂ a v (next v)

@[lifted_fn, reducible]
def pair {α β} (x : tvar α) (y : tvar β) : tvar (α × β) :=
lifted₂ prod.mk x y

notation `⦃` x₀ `,` x₁ `⦄` := pair x₀ x₁
notation `⦃` x₀ `,` x₁ `,` x₂ `⦄` := pair x₀ (pair x₁ x₂)
notation `⦃` x₀ `,` x₁ `,` x₂ `,` x₃ `⦄` := pair x₀ (pair x₁ (pair x₂ x₃))
notation `⦃` x₀ `,` x₁ `,` x₂ `,` x₃ `,` x₄ `⦄` := pair x₀ (pair x₁ (pair x₂ (pair x₃ x₄)))
-- notation `⦃` x `,` l:(foldl `,` (h t, pair h t) x `⦄`)  := l

prefix `⊙`:90 := next
prefix `◇`:95 := eventually -- \di
prefix `◻`:95 := henceforth -- \sqw
infixl `  𝒰  `:95 := until -- \McU
infixl `  𝒲  `:95 := wait -- \McU
notation `⟦ `:max v ` | `:50 R ` ⟧`:0 := action R v
notation `⟦ `:max v `,` v' ` | `:50 R ` ⟧`:0 := action R (pair v v')
notation `⟦ `:max v₀ `,` v₁ `,` v₂ ` | `:50 R ` ⟧`:0 := action R (pair v₀ (pair v₁ v₂))
notation `⟦ `:max v₀ `,` v₁ `,` v₂ `,` v₃ ` | `:50 R ` ⟧`:0 := action R (pair v₀ (pair v₁ (pair v₂ v₃)))

def tl_leads_to (p q : cpred) : cpred :=
◻(p ⟶ ◇q)

infix ` ~> `:55 := tl_leads_to

def to_fun_var (f : var γ α → var γ β) : var γ (α → β) :=
⟨ λ i x, (f ↑x).apply i ⟩

def to_fun_var' (f : tvar α → tvar α → tvar β) : tvar (α → α → β) :=
⟨ λ i x y, (f x y).apply i ⟩

class persistent (p : cpred) : Prop :=
  (is_persistent : ◻p = p)
export persistent (is_persistent)

lemma tl_imp_intro (h : cpred) [persistent h] {p q : cpred}
  (h' : h ⟹ (p ⟶ q))
: ctx_impl h p q :=
begin
  constructor, intro,
  exact (h' True).apply σ trivial,
end

lemma tl_imp_elim (h : cpred) [persistent h] {p q : cpred}
  (h' : ctx_impl h p q)
: h ⟹ (p ⟶ q) :=
begin
  intro, revert Γ,
  apply intro_p_imp h',
end

lemma tl_imp_intro' (h : cpred) [persistent h] {p q : cpred}
  (h' : p ⟹ q)
: ctx_impl h p q :=
h' _

@[tl_simp, simp]
lemma hence_true : ◻(True : cpred) = True :=
begin
  ext1,
  split ; intro h,
  { trivial },
  { intro, trivial }
end

@[tl_simp, simp]
lemma next_true : ⊙True = True :=
by lifted_pred

@[tl_simp, simp]
lemma next_false : ⊙False = False :=
by lifted_pred [next]

instance true_persistent
: persistent (True : cpred) :=
by { constructor, simp with tl_simp, }

lemma tl_imp_elim' {p q : cpred}
  (h : ctx_impl True p q)
: p ⟹ q :=
begin
  simp [ctx_impl] at h,
  apply h,
end

@[strengthening]
lemma eventually_weaken (p : cpred)
: (p ⟹ ◇ p) :=
begin
  pointwise with τ h,
  unfold eventually,
  existsi 0,
  apply h
end
open stream

@[strengthening]
lemma next_entails_eventually (p : cpred)
: ⊙p ⟹ ◇p :=
by { lifted_pred [eventually], intro, existsi 1, assumption }

@[strengthening]
lemma henceforth_entails_next (p : cpred)
: ◻p ⟹ ⊙p :=
by { lifted_pred [eventually], intro h, apply h 1 }

@[strengthening]
lemma henceforth_str (p : cpred) :
  (◻p ⟹ p) :=
begin
  pointwise with τ h, apply h 0
end

local infix ` <$> ` := fun_app_to_var
local infix ` <*> ` := combine_var

lemma init_eq_action {p : α → Prop} (v : tvar α)
: ⟨p⟩ ! v = ⟦ v | λ s s', p s ⟧ :=
by { cases v, refl }

lemma coe_eq (v : tvar α) (x : α)
: ⟨λ y, y = x⟩ ! v = v ≃ x :=
by { cases v, refl }

lemma init_eq_action' {p : pred' α} (v : tvar α)
: (p ! v) = ⟦ v | λ s s', p.apply s ⟧ :=
by { cases v, cases p, refl }

lemma next_eq_action {p : α → Prop} (v : tvar α)
: ⊙(p <$> v) = ⟦ v | λ s s' : α, p s' ⟧ :=
by { cases v, refl }

lemma action_eq {A : act α} (v : tvar α)
: ⟦ v | A ⟧ = (A : tvar (act α)) v (⊙v) :=
by { cases v, refl }

lemma next_eq_action' {p : pred' α} (v : tvar α)
: ⊙(p ! v) = ⟦ v | λ s s' : α, p.apply s' ⟧ :=
by { cases v, cases p, refl }

lemma not_action {A : act α} (v : tvar α)
: -⟦ v | A ⟧ = ⟦ v | λ s s', ¬ A s s' ⟧ :=
rfl

lemma action_imp (p q : act α) (v : tvar α)
: (⟦ v | λ s s' : α, p s s' → q s s' ⟧ : cpred) = ⟦ v | p ⟧ ⟶ ⟦ v | q ⟧ :=
rfl

lemma action_and_action (p q : act α) (v : tvar α)
: ⟦ v | p ⟧ ⋀ ⟦ v | q ⟧ = ⟦ v | λ s s' : α, p s s' ∧ q s s' ⟧ :=
rfl

lemma action_or_action (p q : act α) (v : tvar α)
: ⟦ v | p ⟧ ⋁ ⟦ v | q ⟧ = ⟦ v | λ s s' : α, p s s' ∨ q s s' ⟧ :=
rfl

lemma action_false (v : tvar α)
: (⟦ v | λ _ _, false ⟧ : cpred) = False :=
by { funext x, refl }

variables {Γ : cpred}

lemma unlift_action (A : act α) (v : tvar α)
  (h : ∀ σ σ', A σ σ')
: Γ ⊢ ⟦ v | A ⟧ :=
begin
  constructor, simp_intros [action],
  apply h
end

@[tl_simp, simp]
lemma eventually_eventually (p : cpred) : ◇◇ p = ◇ p :=
begin
  ext k,
  split
  ; unfold eventually
  ; intro h
  ; cases h with i h,
  { cases h with j h,
    existsi (i+j),
    simp at h, apply h, },
  { existsi (0 : ℕ),
    existsi i,
    apply h }
end

@[tl_simp, simp]
lemma henceforth_henceforth (p : cpred) : ◻◻ p = ◻ p :=
begin
  ext _,
  split
  ; intro h,
  { intro i,
    have h' := h i 0,
    simp [drop_drop] at h',
    apply h' },
  { intros i j,
    simp [drop_drop],
    apply h }
end

lemma henceforth_next_intro (p : cpred)
: ◻p = ◻(p ⋀ ⊙p) :=
by { lifted_pred, split ; intros h i,
     { split, apply h i, specialize h (succ i),
       simp [add_succ] at h, simp [next,h], },
     { apply (h i).left }}

/- True / False -/

@[tl_simp, simp]
lemma hence_false : ◻(False : cpred) = False :=
begin
  ext _,
  split ; intro h,
  { cases h 0 },
  { cases h }
end

@[tl_simp, simp]
lemma event_false : ◇(False : cpred) = False :=
begin
  ext _,
  split ; intro h,
  { cases h with _ h, cases h },
  { cases h }
end

@[tl_simp, simp]
lemma eventually_true : ◇(True : cpred) = True :=
begin
  ext1,
  split ; intro h,
  { trivial },
  { apply exists.intro 0, trivial }
end

/- monotonicity -/

@[monotonic]
lemma eventually_tl_imp_eventually {h p q : cpred}
  [persistent h]
  (f : ctx_impl h p q)
: ctx_impl h (◇p) (◇q) :=
begin
  unfold ctx_impl at ⊢ f,
  rw ← is_persistent h at *,
  pointwise f with τ h',
  apply exists_imp_exists,
  intro i,
  apply f,
  rw ← henceforth_henceforth at h',
  apply h',
end

@[monotonic]
lemma eventually_entails_eventually {p q : cpred}
  (f : p ⟹ q)
: (◇p) ⟹ (◇q) :=
begin
  apply tl_imp_elim',
  mono,
end

lemma eventually_imp_eventually {p q : cpred} {Γ}
 (f : Γ ⊢ ◻ (p ⟶ q))
: Γ ⊢ (◇p) ⟶ (◇q) :=
begin
  constructor, introv hΓ,
  apply exists_imp_exists,
  intro i,
  apply f.apply _ hΓ,
end

@[monotonic]
lemma henceforth_tl_imp_henceforth {h p q : cpred}
  [persistent h]
  (f : ctx_impl h p q)
: ctx_impl h (◻p) (◻q) :=
begin
  unfold ctx_impl at *,
  rw ← is_persistent h,
  pointwise f with i h',
  simp [henceforth], intro_mono i,
  apply f ,
  apply  h',
end

@[monotonic]
lemma henceforth_entails_henceforth {p q : cpred}
  (f : p ⟹ q)
: (◻p) ⟹ (◻q) :=
begin
  refine tl_imp_elim' _,
  mono
end

lemma henceforth_imp_henceforth {p q : cpred} {Γ}
  (h : Γ ⊢ ◻ (p ⟶ q))
: Γ ⊢ (◻p) ⟶ (◻q) :=
begin
  pointwise h with τ,
  specialize h τ, simp [henceforth] at ⊢ h,
  introv h₀ h₁,
  solve_by_elim,
end

lemma inf_often_entails_inf_often {p q : cpred} (f : p ⟹ q)
: ◻◇p ⟹ ◻◇q :=
by mono*

lemma stable_entails_stable {p q : cpred} (f : p ⟹ q)
: ◇◻p ⟹ ◇◻q :=
by mono*

lemma henceforth_and (p q : cpred)
: ◻(p ⋀ q) = ◻p ⋀ ◻q :=
begin
  ext1,
  repeat { split ; intros }
  ; intros i ; try { simp, split },
  { apply (a i).left },
  { apply (a i).right },
  { apply a.left },
  { apply a.right },
end

lemma eventually_or (p q : cpred)
: ◇(p ⋁ q) = ◇p ⋁ ◇q :=
begin
  ext1,
  simp [eventually,exists_or],
end

lemma henceforth_forall (P : α → cpred)
: ◻(∀∀ x, P x) = ∀∀ x, ◻P x :=
begin
  ext1,
  simp [henceforth,p_forall],
  rw forall_swap,
end

@[tl_simp, simp]
lemma not_henceforth (p : cpred) : (- ◻p) = (◇-p) :=
begin
  ext1,
  simp [henceforth,not_forall_iff_exists_not,eventually],
end

@[tl_simp, simp]
lemma not_eventually (p : cpred)
: (-◇p) = (◻-p) :=
begin
  ext1,
  simp [henceforth,not_forall_iff_exists_not,eventually],
end

@[tl_simp, simp, predicate]
lemma models_to_fun_var (σ : γ) (x : var γ α → var γ β)
: σ ⊨ to_fun_var x = λ i, σ ⊨ x i :=
by { refl }

@[tl_simp, simp, predicate]
lemma models_to_fun_var' (σ : ℕ) (f : tvar (α → α → β))
: σ ⊨ to_fun_var' (λ x, var_seq $ var_seq f x) = σ ⊨ f :=
by { casesm* tvar _, dunfold to_fun_var', simp_coes [var_seq], }

@[tl_simp, simp, predicate]
lemma models_to_fun_var''' (σ : ℕ) (f : tvar α → tvar α → tvar β) (x y : tvar α)
: (σ ⊨ to_fun_var' f x y) = (σ ⊨ f x y) :=
sorry

@[tl_simp, simp, predicate, lifted_fn]
lemma to_fun_var_fn_coe_proj (f : var γ α) (g : var β φ → var β γ) (w : var β φ)
: to_fun_var (λ w, f ! g w) w = f ! to_fun_var g w :=
by { funext, lifted_pred, simp!, }

@[tl_simp, simp, predicate, lifted_fn]
lemma to_fun_var_fn_coe (g : var β (φ → γ)) (w : var β φ)
: to_fun_var (λ w, g w) w = g w :=
by { funext, lifted_pred, simp!, }

@[tl_simp, simp, predicate, lifted_fn]
lemma to_fun_var_fn_coe' (f : tvar (α → α → β)) (w w' : tvar α)
: ⇑(to_fun_var' $ λ w w', f w w') w w' = f w w' :=
by { lifted_pred, }

@[tl_simp, simp, predicate, lifted_fn]
lemma to_fun_var_p_exists' (f : γ → tvar α → tvar α → tvar Prop) (w w' : tvar α)
: ⇑(to_fun_var' $ λ w w', ∃∃ x : γ, f x w w') w w' = ∃∃ x : γ, to_fun_var' (f x) w w' :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var_lift₁ (f : φ → β) (g : var γ α → var γ φ) (w : var γ α)
: (to_fun_var (λ (w : var γ α), lifted₁ f (g w))) w = lifted₁ f (to_fun_var g w) :=
by { lifted_pred, simp! }

@[lifted_fn]
lemma to_fun_var_lift₂ {σ} (f : φ → σ → β)
  (g₀ : var γ α → var γ φ)
  (g₁ : var γ α → var γ σ) (w : var γ α)
: (to_fun_var (λ (w : var γ α), lifted₂ f (g₀ w) (g₁ w))) w =
  lifted₂ f (to_fun_var g₀ w) (to_fun_var g₁ w) :=
by { lifted_pred, simp }

@[lifted_fn]
lemma to_fun_var_coe (w : var γ α) (v : var γ β)
: to_fun_var (λ (w : var γ α), v) w = v :=
by { lifted_pred, simp }

@[lifted_fn]
lemma to_fun_var_id (w : var γ α)
: to_fun_var (λ w : var γ α, w) w = w :=
by { lifted_pred, simp }

@[lifted_fn]
lemma to_fun_var'_fn_coe (f : var φ β) (g : tvar α → tvar α → tvar φ) (w w' : tvar α)
: (to_fun_var' (λ (w w' : tvar α), f ! g w w')) w w' = f ! to_fun_var' g w w'  :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var'_coe (w w' : tvar α) (v : tvar β)
: (to_fun_var' (λ (w w' : tvar α), v)) w w' = v :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var'_id (w w' : tvar α)
: to_fun_var' (λ w w' : tvar α, w) w w' = w :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var'_id' (w w' : tvar α)
: to_fun_var' (λ w w' : tvar α, w') w w' = w' :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var'_lift₂ {σ} (f : φ → σ → β)
  (g₀ : tvar α → tvar α → tvar φ)
  (g₁ : tvar α → tvar α → tvar σ) (w w' : tvar α)
: to_fun_var' (λ (w w' : tvar α), lifted₂ f (g₀ w w') (g₁ w w')) w w' =
  lifted₂ f (to_fun_var' g₀ w w') (to_fun_var' g₁ w w') :=
by { lifted_pred, }

@[lifted_fn]
lemma to_fun_var'_action {σ} (f : tvar α → tvar β)
  (A : act β)
  (g₁ : tvar α → tvar α → tvar σ) (w w' : tvar α)
: to_fun_var' (λ (w w' : tvar α), ⟦ f w | A ⟧ ) w w' =
  ⟦ f w | A ⟧ :=
by { lifted_pred, }

@[tl_simp, simp, predicate]
lemma models_coe (σ : α) (x : β)
: σ ⊨ ↑x = x :=
by { refl }

@[tl_simp, simp, predicate]
lemma models_action (A : act α) (v : tvar α) (i : ℕ)
: i ⊨ ⟦ v | A ⟧ ↔ A (i ⊨ v) (succ i ⊨ v) :=
by { refl }

@[tl_simp, simp, predicate]
lemma models_next (p : tvar α) (t : ℕ)
: t ⊨ ⊙p = succ t ⊨ p :=
by refl

lemma induct' (p : cpred) {Γ}
  (h : Γ ⊢ ◻ (p ⟶ ⊙p))
: Γ ⊢ ◻ (p ⟶ ◻p) :=
begin
  constructor,
  intros τ hΓ k hp i,
  induction i with i,
  assumption,
  have := h.apply τ hΓ (k+i) (cast (by simp) i_ih),
  simp [next] at this,
  simp [add_succ,this],
end

lemma induct (p : cpred) {Γ}
  (h : Γ ⊢ ◻ (p ⟶ ⊙p))
: Γ ⊢ p ⟶ ◻p :=
henceforth_str (p ⟶ ◻p) Γ (induct' _ h)

lemma induct_evt' (p q : cpred) {Γ}
  (h : Γ ⊢ ◻ (p ⟶ -q ⟶ ⊙p ⋁ ⊙q))
: Γ ⊢ ◻ (p ⟶ ◇q ⋁ ◻p) :=
begin
  lifted_pred using h,
  simp only [henceforth] with tl_simp at *,
  intros,
  simp [or_iff_not_imp,eventually],
  intros hnq k,
  induction k with k,
  { simp [a] },
  { simp [add_succ],
    specialize h _ k_ih (hnq _),
    rw [or_comm,or_iff_not_imp] at h,
    apply h, rw [← add_succ,← add_succ],
    apply hnq }
end

lemma eventually_exists (P : α → cpred)
: ◇(∃∃ x, P x) = ∃∃ x, ◇P x :=
begin
  ext1,
  unfold eventually p_exists,
  split
  ; intro H
  ; cases H with i H
  ; cases H with j H
  ; exact ⟨_,_,H⟩ ,
end

lemma one_point_elim {t} (Γ p : cpred) (v : tvar t)
  (h : ∀ x : t, Γ ⊢ (↑x ≃ v) ⟶ p)
: Γ ⊢ p :=
begin
  rw [← p_forall_to_fun] at h,
  constructor,
  intros i h',
  apply h.apply  i h' (v.apply $ i),
  simp,
end

local attribute [instance] classical.prop_decidable

lemma until_not_of_eventually {Γ p : cpred} :
  Γ ⊢ ◇p ⟶ -p 𝒰 p :=
begin
  lifted_pred, intro h,
  cases h with i h,
  induction i using nat.strong_induction_on with i ih,
  by_cases h' : ∃ j < i, σ + j ⊨ p,
  { rcases h' with ⟨j,h₀,h₁⟩,
    apply ih _ h₀ h₁ },
  { simp only [not_exists] at h',
    existsi [i,h], apply h' }
end

lemma until_backward_induction {Γ p q : cpred}
  (h' : Γ ⊢ ◻(p ⟶ q))
  (h : Γ ⊢ ◻(⊙q ⟶ -p ⟶ q)) :
  Γ ⊢ ◇p ⟶ q 𝒰 p :=
begin
  suffices : Γ ⊢ -p 𝒰 p ⟶ q 𝒰 p,
  { have h' := @until_not_of_eventually Γ p,
    lifted_pred using this h', tauto },
  lifted_pred using h h',
  dsimp [until],
  apply exists_imp_exists,
  rintros i ⟨h₀,h₁⟩,
  existsi h₀,
  introv h₂,
  generalize h₃ : (i - (k + 1)) = n,
  induction n generalizing k,
  { apply h, dsimp [next], rw ← add_succ, apply h', convert h₀,
    apply le_antisymm, apply succ_le_of_lt h₂,
    apply nat.le_of_sub_eq_zero h₃, apply h₁ _ h₂, },
  { apply h,
    { have h₄ : k + 1 ≤ i := succ_le_of_lt h₂,
      dsimp [next], rw ← add_succ,
      apply n_ih, rw nat.sub_eq_iff_eq_add at h₃; try { assumption },
      { rw [h₃,succ_add], apply succ_lt_succ,
        apply lt_of_lt_of_le (lt_succ_self _),
        apply nat.le_add_left },
      { apply succ.inj,
        rw [← h₃,succ_add,← succ_sub,succ_sub_succ_eq_sub],
        apply succ_le_of_lt, rw nat.sub_eq_iff_eq_add at h₃; try { assumption },
        rw h₃, apply lt_add_of_pos_left, apply zero_lt_succ }, },
    apply h₁ _ h₂, },
end

lemma henceforth_until {Γ p q : cpred}
  (h : Γ ⊢ ◻(p 𝒰 q)) :
  Γ ⊢ ◻(p ⋁ q) :=
begin
  lifted_pred using h,
  intro i, specialize h i,
  rcases h with ⟨⟨j⟩,h₀,h₁⟩,
  { right, apply h₀ },
  { left, apply h₁ 0, apply zero_lt_succ }
end

lemma henceforth_until' {Γ p : cpred} (q : cpred)
  (h : Γ ⊢ ◻(p 𝒰 (p ⋀ q))) :
  Γ ⊢ ◻p :=
begin
  replace h := henceforth_until h,
  suffices : p ⋁ p ⋀ q = p, { simp [this] at h, exact h },
  lifted_pred, tauto,
end

def nelist (α : Type*) := { xs : list α // xs.empty = ff }

def nelist.head {α : Type*} : nelist α → α
 | ⟨ x::xs, _ ⟩ := x

def nelist.tail {α : Type*} : nelist α → option (nelist α)
 | ⟨ x::x'::xs, _ ⟩ := some ⟨ x'::xs, rfl ⟩
 | ⟨ _ :: [], _ ⟩ := none

def nelist.uncons {α : Type*} : nelist α → α ⊕ (α × nelist α)
 | ⟨ x::x'::xs, _ ⟩ := sum.inr (x,⟨x'::xs,rfl⟩)
 | ⟨ x :: [], _ ⟩ := sum.inl x

def nelist.single {α : Type*} : α → nelist α
 | x := ⟨ x :: [] ,rfl ⟩

def nelist.cons {α : Type*} : α → nelist α → nelist α
 | x ⟨ xs, _⟩ := ⟨ x::xs,rfl ⟩

noncomputable def epsilon [nonempty α] (p : tvar (α → Prop)) : tvar α :=
⟨ λ i, classical.epsilon $ i ⊨ p ⟩

section witness
variables x₀ : tvar α
variables f : tvar (α → α)
variables (i : ℕ)

open classical nat

private def w : ℕ → α
 | 0 := i ⊨ x₀
 | (succ j) := (i + j ⊨ f) (w j)

lemma fwd_witness
: ⊩ ∃∃ w, w ≃ x₀ ⋀ ◻( ⊙w ≃ f w ) :=
begin
  lifted_pred,
  existsi (⟨ λ i, w x₀ f x (i - x) ⟩ : tvar α),
  simp [nat.sub_self,w],
  intro i,
  have h : x + i ≥ x := nat.le_add_right _ _,
  simp [next,nat.add_sub_cancel_left,succ_sub h,w],
end

variables {P : cpred}
variables (j : ℕ)

local attribute [instance] classical.prop_decidable

lemma first_P {p : ℕ → Prop} (h : ∃ i, p i) :
  (∃ i, (∀ j < i, ¬ p j) ∧ p i) :=
begin
  cases h with i h,
  induction i using nat.strong_induction_on with i ih,
  by_cases h' : (∀ (j : ℕ), j < i → ¬p j),
  { exact ⟨_,h',h⟩, },
  { simp [not_forall] at h',
    rcases h' with ⟨j,h₀,h₁⟩,
    apply ih _ h₀ h₁, }
end

noncomputable def next_P {x} (h : x ⊨ ◻◇P) (y : ℕ) : ℕ :=
classical.some (first_P (h y))

lemma next_P_eq_self {x} (h : x ⊨ ◻◇P) (y : ℕ)
  (h' : x+y ⊨ P) :
  next_P h y = 0 :=
begin
  simp [next_P],
  apply_some_spec,
  intros h, by_contradiction h₂,
  replace h₂ := nat.lt_of_le_and_ne (nat.zero_le _) (ne.symm h₂),
  apply h.1 _ h₂,
  simp [h']
end

lemma next_P_eq_succ {x} (h : x ⊨ ◻◇P) (y : ℕ)
  (h' : ¬ x+y ⊨ P) :
  next_P h y = succ (next_P h (succ y)) :=
begin
  simp [next_P],
  apply_some_spec, apply_some_spec,
  simp, intros h₀ h₁ h₂ h₃,
  by_contradiction h₄,
  replace h₄ := lt_or_gt_of_ne (h₄),
  cases h₄,
  cases x_1,
  { apply h', convert h₃ using 2, },
  { replace h₄ := lt_of_succ_lt_succ h₄,
    apply h₀ _ h₄, convert h₃ using 2, simp [add_succ] },
  { apply h₂ _ h₄, convert h₁ using 2, simp [add_succ] },
end

lemma back_witness {Γ}
  (h : Γ ⊢ ◻◇P)
: Γ ⊢ ∃∃ w, ◻( (P ⋀ w ≃ x₀) ⋁ (- P ⋀ w ≃ ⊙(f w)) ) :=
begin
  lifted_pred using h,
  existsi (⟨ λ i, w x₀ f (i) (next_P h (i - x)) ⟩ : tvar α),
  intro j, simp [nat.add_sub_cancel_left,w],
  by_cases h' : x + j ⊨ P; simp [next_P_eq_self,*,w],
  rw [next_P_eq_succ,w],
  congr' 1,
  { admit },
  have : (succ (x + j) - x) = succ j, admit,
  rw this, clear this,
end

end witness

end temporal


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

namespace Mathlib

namespace tactic

namespace interactive

/--
This is a "finishing" tactic modification of `simp`. It has two forms.

* `simpa [rules, ...] using e` will simplify the goal and the type of
  `e` using `rules`, then try to close the goal using `e`.

  Simplifying the type of `e` makes it more likely to match the goal
  (which has also been simplified). This construction also tends to be
  more robust under changes to the simp lemma set.

* `simpa [rules, ...]` will simplify the goal and the type of a
  hypothesis `this` if present in the context, then try to close the goal using
  the `assumption` tactic. -/