import data.pfun
import o_minimal.sheaf.covers

section orelse_pure

open_locale classical

noncomputable def roption.orelse_pure {α : Type*} (x : roption α) (y : α) :=
if h : x.dom then x.get h else y

-- TODO: Is this actually useful?
lemma roption.orelse_pure_eq_iff {α : Type*} {x : roption α} {y : α} (z : α) :
  x.orelse_pure y = z ↔ (z ∈ x ∨ ¬ x.dom ∧ z = y) :=
begin
  unfold roption.orelse_pure,
  split_ifs with h; split; simp [h, roption.mem_eq, eq_comm]
end

end orelse_pure

namespace o_minimal

variables {R : Type*} {S : struc R}
variables {X : Type*} [definable_sheaf S X]
variables {Y : Type*} [definable_sheaf S Y]

instance roption.definable_sheaf : definable_sheaf S (roption X) :=
{ definable := λ K f,
    ∃ H : def_set S (pfun.dom f),
    definable S (pfun.as_subtype f),
  definable_precomp := λ L K φ f ⟨H, h⟩,
    ⟨φ.is_definable.preimage H,
     h.comp (definable_subtype.map (Def.definable_iff_def_fun.mpr φ.is_definable) (λ _, id))⟩,
  definable_cover := λ K f 𝓛 hf, begin
    have : def_set S (pfun.dom f) := Def.set_subcanonical 𝓛 _ (λ i, (hf i).fst),
    refine ⟨this, _⟩,
    letI : definable_rep S (pfun.dom f) :=
      subtype.definable_rep (definable_iff_def_set.mpr this),
    let 𝓛' : cover S (pfun.dom f) :=
      (cover_of_Def 𝓛).pullback subtype.val definable.subtype.val,
    refine definable_cover (pfun.as_subtype f) 𝓛' _,
    -- TODO: messy proof
    intro i,
    let ψ : (𝓛'.map i).obj → {l | (𝓛.map i).to_fun l ∈ pfun.dom f} :=
      λ l', ⟨l'.1.2, begin
        rcases l' with ⟨⟨⟨a, b⟩, c⟩, rfl : a = map_to.to_fun _ c⟩,
        exact b
      end⟩,
    have : (𝓛'.map i).to_fun = subtype.map (𝓛.map i) (λ _, id) ∘ ψ,
    { ext1 ⟨⟨⟨a, b⟩, c⟩, rfl : a = map_to.to_fun _ c⟩, refl },
    rw this,
    refine (hf i).snd.comp _,
    apply definable_of_subtype_val,
    exact definable.snd.comp definable.subtype.val
  end }

-- TODO: move this, and generalize?
lemma definable_eq {Z : Type*} [has_coordinates R Z] [definable_rep S Z] :
  definable S ((=) : Z → Z → Prop) :=
begin
  rw definable_iff_uncurry,
  rw definable_fun,
  intros K φ hφ,
  rw definable_rep.eq at hφ,
  exact def_set_eq (def_fun.fst.comp hφ) (def_fun.snd.comp hφ)
end

-- TODO: generalize to `Z` with definable equality?
lemma definable_roption.mem {Z : Type*} [has_coordinates R Z] [definable_rep S Z] :
  definable S ((∈) : Z → roption Z → Prop) :=
begin
  rw definable_iff_uncurry,
  rw definable_fun,
  intros K φ hφ,
  let K' := {k | (φ k).2.dom},
  have dK' : def_set S {k : ↥K | (φ k).snd.dom} := hφ.2.fst,
  letI : definable_rep S K' :=
    subtype.definable_rep (definable_iff_def_set.mpr dK'),
  have : definable S (λ (k' : {k | (φ k).2.dom}), (φ k'.val).1 = (φ k'.val).2.get k'.property),
  { let ψ₁ : K' → Z := λ k', (φ k'.val).1,
    have dψ₁ : definable S ψ₁ :=
      (definable_yoneda.mpr hφ.1).comp definable.subtype.val,
    let ψ₂ : K' → Z := λ k', (φ k'.val).2.get k'.property,
    have dψ₂ : definable S ψ₂ := hφ.2.snd,
    let ψ : K' → Z × Z := λ k', (ψ₁ k', ψ₂ k'),
    suffices dψ : definable S ψ,
    { have : definable S (λ (p : Z × Z), p.1 = p.2) :=
        definable_iff_uncurry.mp definable_eq,
      exact this.comp dψ },
    -- TODO: lemma
    begin [defin]
      intro k,
      app, app, exact definable.prod_mk.definable _,
      app, exact dψ₁.definable _, var,
      app, exact dψ₂.definable _, var
    end },
  rw definable_iff_def_set at this,
  convert def_fun.image def_fun_subtype_val this,
  { ext k,
    rw set.mem_image,
    conv_lhs { rw set.mem_def },
    simp only [function.uncurry, roption.mem_eq, exists_and_distrib_right,
      function.comp_app, exists_eq_right, subtype.exists,
      subtype.coe_mk, subtype.val_eq_coe],
    apply exists_congr, intro h,
    apply eq_comm },
  -- TODO: avoid this side goal somehow
  { exact dK' }
end

lemma definable_roption.dom : definable S (roption.dom : roption X → Prop) :=
begin
  rw definable_fun,
  intros K φ hφ,
  exact hφ.fst
end

lemma definable_orelse_pure :
  definable S (roption.orelse_pure : roption X → X → X) :=
begin
  rw definable_iff_uncurry,
  rw definable_fun,
  intros K φ hφ,
  rw ←definable_yoneda at ⊢ hφ,
  let s := {k | (φ k).1.dom},
  apply definable_if _ s,
  { exact definable_roption.dom.comp (definable.fst.comp hφ) },
  { suffices : definable S (λ (p : s), (φ p.val).1.get p.property),
    { convert this,
      ext ⟨k, hk⟩,
      change dite _ _ _ = (φ k).fst.get hk,
      -- exact dif_neg hk,   -- bad binder type on `dif_neg`
      split_ifs,
      { refl },
      { refl } },               -- what happened here??
    rw definable_yoneda at hφ,
    exact hφ.1.snd },
  { suffices : definable S (λ (p : sᶜ), (φ p.val).2),
    { convert this,
      ext ⟨k, hk⟩,
      change dite _ _ _ = (φ k).snd,
      -- exact dif_neg hk,   -- bad binder type on `dif_neg`
      split_ifs,
      { exact false.elim (hk h) },
      { refl } },
    exact definable.snd.comp (hφ.comp definable.subtype.val) }
end

lemma definable_roption_map :
  definable S (roption.map : (X → Y) → roption X → roption Y) :=
begin
  rw definable_iff_uncurry,
  rw definable_fun,
  intros K φ hφ,
  refine ⟨hφ.2.fst, _⟩,
  change definable S (λ (p : {k | (φ k).2.dom}), (φ p.1).1 (pfun.as_subtype (prod.snd ∘ φ) p)),
  begin [defin]
    intro p,
    app,
    app, exact definable.fst.definable _,
    app, exact (definable_yoneda.mpr hφ).definable _,
    app, exact definable.subtype.val.definable _,
    var,
    app, exact hφ.2.snd.definable _, var
  end
end

instance pfun.definable_sheaf : definable_sheaf S (X →. Y) :=
show definable_sheaf S (X → roption Y), by apply_instance

lemma definable_pfun_of_graph {Z : Type*} [has_coordinates R Z] [definable_rep S Z]
  {f : X →. Z} (df : definable S {p : X × Z | p.2 ∈ f p.1}) : definable S f :=
begin
  rw definable_fun,
  intros K φ hφ,
  rw ←definable_yoneda at hφ,
  have d : def_set S (pfun.dom (f ∘ φ)),
  { suffices : def_set S {k : K | ∃ z : Z, z ∈ f (φ k)},
    { convert this,
      ext k,
      simp [pfun.mem_dom] },
    apply def_set.exists,
    let ψ : K × Z → X × Z := λ p, (φ p.1, p.2),
    have dψ : definable S ψ,
    -- TODO: The tactic mode should be overkill for this
    begin [defin]
      intro p,
      app, app, exact definable.prod_mk.definable _,
      app, exact hφ.definable _,
      app, exact definable.fst.definable _,
      var,
      app, exact definable.snd.definable _,
      var,
    end,
    exact definable_iff_def_set.mp (df.comp dψ) },
  refine ⟨d, _⟩,
  apply definable_of_graph,
  let ψ : pfun.dom (f ∘ φ) × Z → X × Z := λ p, (φ p.1.val, p.2),
  have dψ : definable S ψ,
  begin [defin]                 -- TODO: ... and this
    intro p,
    app, app, exact definable.prod_mk.definable _,
    app, exact hφ.definable _,
    app, exact definable.subtype.val.definable _,
    app, exact definable.fst.definable _,
    var,
    app, exact definable.snd.definable _,
    var,
  end,
  convert df.comp dψ,
  ext ⟨⟨k, h⟩, z⟩,
  change (f (φ k)).get _ = z ↔ z ∈ f (φ k),
  rw [roption.get_eq_iff_eq_some, roption.eq_some_iff]
end

end o_minimal


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

variable (P : PFunctor)

namespace PFunctor

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

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

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

variable {P}

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

def bud : (z : Z P) → Type
| Z.bud => Unit
| Z.some a f => Σ (a : P.β a), bud (f a)

def extend : (z : Z P) → (b : bud z → P.α) → Z P
| Z.bud, b => Z.some (b ()) (λ _ => Z.bud)
| Z.some a f, b => Z.some a (λ bpa => extend (f bpa) (λ bf => b ⟨bpa, bf⟩))

theorem extend_injective_right : {z : Z P} → {b₁ b₂ : bud z → P.α} →
  extend z b₁ = extend z b₂ → b₁ = b₂
| Z.bud, b₁, b₂, h => funext (λ x => by
cases x; simp [extend] at h; exact h.1)
| Z.some a f, b₁, b₂, h => by
  apply funext
  intro x
  simp [extend] at h
  dsimp [bud] at x
  match x with
  | ⟨x₁, x₂⟩ => exact congrFun (extend_injective_right (congrFun h x₁)) x₂

@[simp] def bud_of_bud_extend : {z : Z P} → {bz : bud z → P.α} → (b : bud (extend z bz)) → bud z
| Z.bud, _, _ => ()
| Z.some _ _, _, ⟨pba, b⟩ => ⟨pba, bud_of_bud_extend b⟩

@[simp] def β_of_bud_extend : {z : Z P} → {bz : bud z → P.α} → (b : bud (extend z bz)) →
  P.β (bz (bud_of_bud_extend b))
| Z.bud, _, b => b.1
| Z.some _ _, _, ⟨_, b⟩ => β_of_bud_extend b

def mk_bud_extend : (z : Z P) → (bz : bud z → P.α) → (b : bud z) →
  (bp : P.β (bz b)) → bud (extend z bz)
| Z.bud, _, _, bp => ⟨bp, ()⟩
| Z.some _ _, _, b, bp => ⟨b.1, mk_bud_extend _ _ b.2 bp⟩

@[simp] theorem bud_of_bud_extend_mk_bud_extend : {z : Z P} → {bz : bud z → P.α}
  → (b : bud z) → (bp : P.β (bz b)) → bud_of_bud_extend (mk_bud_extend z bz b bp) = b
| Z.bud, _, _, _ => rfl
| Z.some a f, bz, ⟨_, _⟩, bp => by
simp [bud_of_bud_extend, mk_bud_extend]
simp [bud_of_bud_extend_mk_bud_extend]

@[simp] theorem β_of_bud_extend_mk_bud_extend : {z : Z P} → {bz : bud z → P.α}
  → (b : bud z) → (bp : P.β (bz b)) → β_of_bud_extend (mk_bud_extend z bz b bp) =
    cast (by simp) bp
| Z.bud, _, _, _ => rfl
| Z.some _ _, _, _, _ => by
simp [β_of_bud_extend, mk_bud_extend]
simp [β_of_bud_extend_mk_bud_extend]

structure M (P : PFunctor) : Type :=
( seq : Nat → Z P )
( leaf : (n : Nat) → bud (seq n) → P.α )
( zero_eq : seq 0 = Z.bud )
( succ_eq : (n : Nat) → seq (n+1) = extend (seq n) (leaf n) )

theorem M_ext : {m₁ m₂ : M P} → (h : ∀ n, m₁.seq n = m₂.seq n) → m₁ = m₂
| ⟨seq₁, leaf₁, zero_eq₁, succ_eq₁⟩,
  ⟨seq₂, leaf₂, zero_eq₂, succ_eq₂⟩, h => by
simp only [M.mk.injEq]
have hseq : seq₁ = seq₂ := funext h
subst hseq
simp
apply funext
intro n
apply funext
intro b
have := (succ_eq₁ n).symm.trans (succ_eq₂ n)
rw [extend_injective_right this]

theorem M_ext2 {m₁ m₂ : M P} (h : ∀ (n : Nat) (h : m₁.seq n = m₂.seq n),
  m₁.leaf n = (λ b => m₂.leaf n (by rw [← h]; exact b))) : m₁ = m₂ := by
apply M_ext
intro n
induction n with
| zero => simp [M.zero_eq]
| succ n ih => sorry

def bud_zero {m : M P} : bud (m.seq 0) :=
cast (by rw [M.zero_eq]; rfl) ()

def bud_succ {m : M P} {n : Nat} (b : bud (m.seq n)) (bp : P.β (m.leaf n b)) : bud (m.seq (n+1)) :=
by rw [M.succ_eq]; exact mk_bud_extend _ (m.leaf n) b bp

--theorem bud_of_bud_extend_bud_succ

def bud_of_bud_succ {m : M P} {n : Nat} (b : bud (m.seq (n+1))) : bud (m.seq n) :=
by rw [M.succ_eq] at b; exact bud_of_bud_extend b

def M_coalg_seq_aux (m : M P) (p : P.β (m.leaf 0 bud_zero)) :
  (n : Nat) → (z : Z P) × (bud z → bud (m.seq (n+1)))
| 0 => ⟨Z.bud, λ _ => bud_succ bud_zero p⟩
| n+1 =>
let sn := M_coalg_seq_aux m p n
⟨extend sn.1 (λ b =>  m.leaf _ (sn.2 b)),
  λ b => bud_succ (sn.2 (bud_of_bud_extend b)) (β_of_bud_extend b) ⟩

def M_coalg (m : M P) : P.obj (M P) :=
⟨m.leaf 0 bud_zero,
  λ b =>
    { seq := λ n => (M_coalg_seq_aux m b n).1,
      leaf := λ n b' =>
        M.leaf m n.succ (Sigma.snd (M_coalg_seq_aux m b n) b'),
      zero_eq := rfl,
      succ_eq := λ n => by rfl }⟩

theorem M_coalg_snd (m : M P) : (M_coalg m).2 =
   λ b =>
    { seq := λ n => (M_coalg_seq_aux m b n).1,
      leaf := λ n => _,
      zero_eq := rfl,
      succ_eq := λ n => by rfl } := rfl

theorem M_coalg_snd_app_seq (m : M P)
  (b : P.β (M_coalg m).1) : ((M_coalg m).2 b).seq =
    λ n => (M_coalg_seq_aux m b n).1 := rfl

def to_M_seq_aux {A : Type} (coalg : A → P.obj A) (a : A) :
  Nat → (z : Z P) × (bud z → A)
| 0 => ⟨Z.bud, λ _ => a⟩
| n+1 => let ⟨z, bz⟩ := to_M_seq_aux coalg a n
  ⟨extend z
    (λ b => (coalg (bz b)).1),
     λ b => bz (bud_of_bud_extend b) ⟩

def to_M {A : Type} (coalg : A → P.obj A) (a : A) : M P :=
{ seq := λ n => (to_M_seq_aux coalg a n).1,
  leaf := λ n b => (coalg ((to_M_seq_aux coalg a n).2 b)).1,
  zero_eq := rfl,
  succ_eq := λ _ => rfl }

theorem obj_ext {A : Type} {a b : P.obj A}
  (h₁ : a.1 = b.1) (h₂ : ∀ (x : P.β a.1), a.2 x = b.2 (cast (by rw [h₁]) x)) :
  a = b :=
match a, b with
| ⟨a₁, a₂⟩, ⟨b₁, b₂⟩ => by
dsimp at h₁
subst h₁
dsimp [cast] at h₂
simp [funext h₂]

theorem coalg_to_M {A : Type} (coalg : A → P.obj A) (a : A)
  (x : P.β (M_coalg (to_M coalg a)).1) (n : Nat) :
  M.leaf ((M_coalg (to_M coalg a)).2 x) n = sorry :=
by
  dsimp [M_coalg, to_M, to_M_seq_aux,
    M_coalg_seq_aux]
  simp

-- theorem to_M_hom {A : Type} (coalg : A → P.obj A) (a : A) :
--   M_coalg (to_M coalg a) = P.map (to_M coalg) (coalg a) :=
-- obj_ext rfl $ by
-- intro x
-- apply M_ext2
-- intro n h
-- simp
-- conv =>
--   congr
--   delta to_M
--   delta M_coalg
--   dsimp

theorem to_M_unique_aux {A : Type} (coalg : A → P.obj A) (a : A)
  (f : A → M P) (f_hom : ∀ (a : A), M_coalg (f a) = P.map f (coalg a)) :
  (n : Nat) → (show Σ (z : Z P), bud z → P.α from ⟨(f a).seq n, (f a).leaf n⟩) =
  ⟨(to_M_seq_aux coalg a n).1,
    λ b => (coalg ((to_M_seq_aux coalg a n).2 b)).1⟩
| 0 => by
  specialize f_hom a
  have := congrArg Sigma.fst f_hom
  dsimp [M_coalg] at this ⊢
  apply Sigma.ext <;>
  simp [to_M_seq_aux, M.zero_eq]
  apply funext
  intro x
  refine Eq.trans sorry (Eq.trans this ?x)
  rw [PFunctor.map]
  dsimp
  sorry
| n+1 => by
  dsimp
  apply Sigma.ext <;>
  simp [to_M_seq_aux, M.succ_eq]
  have := to_M_unique_aux coalg a f f_hom n
  dsimp at this

theorem to_M_unique {A : Type} (coalg : A → P.obj A) (a : A)
  (f : A → M P) (f_hom : ∀ (a : A), M_coalg (f a) = P.map f (coalg a)) (a : A) :
  f a = to_M coalg a := by
apply M_ext
intro n
induction n generalizing a with
| zero => simp [M.zero_eq]
| succ n ih =>
simp [M.succ_eq, to_M, to_M_seq_aux] at ih ⊢
simp [M_coalg, PFunctor.map] at f_hom
specialize ih a
dsimp at f_hom

-- . rw [M.zero_eq, M.zero_eq]
-- . rw [M.succ_eq, M.succ_eq]

end PFunctor


/-
File: signature_recover_public_key_nondet_bigint3_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
open tactic

open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.constants

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.bigint.nondet_bigint3 autogenerated soundness theorem -/

theorem auto_sound_nondet_bigint3
    -- arguments
    (range_check_ptr : F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_nondet_bigint3 σ.pc)
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 3))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 8 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 3)) (mem $ τ.ap - 4)
        (spec_nondet_bigint3 mem κ range_check_ptr (mem (τ.ap - 4)) (cast_BigInt3 mem (τ.ap - 3)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_nondet_bigint3 at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11⟩,
  -- let (ap reference)
  apply of_register_state,
  intros regstate_res regstateeq_res,
  generalize' hl_rev_res: cast_BigInt3 mem (regstate_res.ap + 5) = res,
  have hl_res := hl_rev_res.symm,
  rw [regstateeq_res] at hl_res, try { dsimp at hl_res },
  -- const
  set! MAX_SUM := (232113757366008801543585789 : F) with hc_MAX_SUM,
  -- compound assert eq
  step_assert_eq hpc0 hpc1 with temp0,
  step_assert_eq hpc2 with temp1,
  step_assert_eq hpc3 with temp2,
  step_assert_eq hpc4 with temp3,
  step_assert_eq hpc5 with temp4,
  have a0: mem (range_check_ptr) = MAX_SUM - (res.d0 + res.d1 + res.d2), {
    apply assert_eq_reduction temp4.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [temp0, temp1, temp2, (eq_sub_of_eq_add temp3)] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a0 }, try { arith_simps at a0 },
  clear temp0 temp1 temp2 temp3 temp4,
  -- tempvar
  step_assert_eq hpc6 hpc7 with tv_range_check_ptr0,
  generalize' hl_rev_range_check_ptr₁: (range_check_ptr + 4 : F) = range_check_ptr₁,
  have hl_range_check_ptr₁ := hl_rev_range_check_ptr₁.symm, clear hl_rev_range_check_ptr₁,
  have htv_range_check_ptr₁: range_check_ptr₁ = _, {
    apply eq.symm, apply eq.trans tv_range_check_ptr0,
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM, hl_range_check_ptr₁] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_range_check_ptr0,
  try { dsimp at hl_range_check_ptr₁ }, try { arith_simps at hl_range_check_ptr₁ },
  -- assert eq
  step_assert_eq hpc8 with temp0,
  have a8: mem (range_check_ptr₁ - 3) = res.d0, {
    apply assert_eq_reduction temp0.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM, hl_range_check_ptr₁, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a8 }, try { arith_simps at a8 },
  clear temp0,
  -- assert eq
  step_assert_eq hpc9 with temp0,
  have a9: mem (range_check_ptr₁ - 2) = res.d1, {
    apply assert_eq_reduction temp0.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM, hl_range_check_ptr₁, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a9 }, try { arith_simps at a9 },
  clear temp0,
  -- assert eq
  step_assert_eq hpc10 with temp0,
  have a10: mem (range_check_ptr₁ - 1) = res.d2, {
    apply assert_eq_reduction temp0.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM, hl_range_check_ptr₁, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a10 }, try { arith_simps at a10 },
  clear temp0,
  -- return
  step_ret hpc11,
  -- finish
  step_done, use_only [rfl, rfl],
  split, refl,
  -- range check condition
  use_only (4+0+0), split,
  linarith [],
  split,
  { arith_simps,
    rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_nondet_bigint3 mem _ range_check_ptr _ _,
  { apply sound_nondet_bigint3, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_nondet_bigint3],
  try { norm_num1 }, try { arith_simps },
  use_only [res],
  use [MAX_SUM, hc_MAX_SUM],
  use_only [a0],
  cases rc_h_range_check_ptr' (0) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a0.symm, hin_range_check_ptr], arith_simps, exact hn },
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁,try { norm_cast at rc_h_range_check_ptr₁' },
  use_only [range_check_ptr₁, hl_range_check_ptr₁],
  use_only [a8],
  cases rc_h_range_check_ptr' (1) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a8.symm, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [a9],
  cases rc_h_range_check_ptr' (2) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a9.symm, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [a10],
  cases rc_h_range_check_ptr' (3) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a10.symm, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hl_res, hc_MAX_SUM, hl_range_check_ptr₁, htv_range_check_ptr₁] }, },
  try { dsimp [cast_BigInt3] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import Lean
open Lean Elab Term

def «こんにちは» := "hello"
#eval «こんにちは»++«こんにちは»

def say (a : String) := a.capitalize
#eval say «こんにちは»

-- WRAP Sbar[decl] (e0:evt)× (誉める/ほめる/ガヲ(e0,太郎/たろう;太郎/たろう,次郎/じろう)) [0.85]
--   > S[v:1<1>][term|attr<4>][] λx0.(e0:evt)× (u0:誉める/ほめる/ガヲ(e0,太郎/たろう;太郎/たろう,次郎/じろう))× x0(e0) [0.95]
--     > T1/(T1\NP[ga]) λx0.x0(太郎/たろう;太郎/たろう) [0.99]
--       LEX 太郎 T1/(T1\NP[nc]) λx0.x0(太郎/たろう;太郎/たろう) (PN) [0.99]
--       LEX が T1/(T1\NP[ga])\NP[nc] λx0.λx1.x1(x0) (524) [1.00]
--     > S[v:1<1>][term|attr<4>][]\NP[ga] λx0.λx1.(e0:evt)× (u0:誉める/ほめる/ガヲ(e0,x0,次郎/じろう))× x1(e0) [0.96]
--       > T1/(T1\NP[o]) λx0.x0(次郎/じろう) [0.99]
--         LEX 次郎 T1/(T1\NP[nc]) λx0.x0(次郎/じろう) (PN) [0.99]
--         LEX を T1/(T1\NP[o])\NP[nc] λx0.λx1.x1(x0) (524) [1.00]
--       <B2 S[v:1<1>][term|attr][]\NP[ga]\NP[o] λx0.λx1.λx2.(e0:evt)× (u0:誉める/ほめる/ガヲ(e0,x1,x0))× x2(e0) [0.97]
--         LEX ほめ S[v:1][stem|neg|cont|+][]\NP[ga]\NP[o] λx0.λx1.λx2.(e0:evt)× (u0:誉める/ほめる/ガヲ(e0,x1,x0))× x2(e0) (JCon) [0.97]
--         LEX る S[v:5:r|v:1|v:5:ARU|+<1>][term|attr][]\S[v:5:r|v:1|v:5:ARU|+<1>][stem][] λx0.x0 (125) [1.00]
-- Sig. [太郎/たろう;太郎/たろう:entity, 次郎/じろう:entity, 誉める/ほめる/ガヲ:(x0:entity)→ (x1:entity)→ (e0:evt)→ type]

structure Entity where
  entity : Name
open Entity

def taro : Entity := ⟨`a⟩
def jiro : Entity := ⟨`b⟩
example : taro ≠ jiro := by
  admit

def «太郎が» :Entity := ⟨`«太郎が»⟩
def «次郎を» :Entity := ⟨`«次郎を»⟩

-- i==2 -> S\NP\NP:       \y.\x.\c.(e:event)X(op(e,x,y)X(ce)
inductive «ほめるsr» (ga wo : Entity) : Prop where
  | rel : Entity -> Entity -> «ほめるsr» ga wo

#check «ほめるsr» ({entity := `aa} : Entity) ({entity := `aa} : Entity)
def «ほめる» (ga wo : Entity) : Prop := «ほめるsr» ga wo

#check «ほめる» «太郎が» «次郎を»
def A := «ほめる» «太郎が» «次郎を»
def B := «ほめる» «次郎を» «太郎が»

def getCtors (typ : Name) : MetaM (List Name) := do
  let env ← getEnv
  match env.find? typ with
  | some (ConstantInfo.inductInfo val) =>
    pure val.ctors
  | _ => pure []

syntax (name := myanon) "⟨⟨" term+ "⟩⟩" : term

@[termElab myanon]
def myanonImpl : TermElab := fun stx typ? => do
  -- tryPostponeIfNoneOrMVar typ?
  let some typ := typ? | throwError "expected type must be known"
  let args := TSyntaxArray.mk stx[1].getSepArgs
  logInfo s!"{args}"
  if typ.isMVar then
    throwError "expected type must be known"
  let Expr.const base .. := typ.getAppFn | throwError s!"type is not of the expected form: {typ}"
  let [ctor] ← getCtors base | throwError "type doesn't have exactly one constructor"
  logInfo s!"stx:{stx}"
  let stx ← `($(mkIdent ctor) $args*) -- syntax quotations
  logInfo s!"stx2:{stx}"
  elabTerm stx typ -- call term elaboration recursively

-- #check (⟨⟨1 sorry⟩⟩ : Fin 12)
-- def oo: List Char := ⟨⟨ hello ⟩⟩
declare_syntax_cat hoge
syntax term : hoge
declare_syntax_cat ja_expr
syntax "こんにちは" : ja_expr
syntax "言う" : ja_expr
-- おそらく{任意の文法}+を使っている場合、空白が存在するだけでTerm.appのパーサーが当たってしまうようである
-- 空白は視認性が悪く、空白が存在するかどうかで振る舞い変わるのは望ましくないので
-- Term.app のパーサーが当たらないように回避する必要がある
-- 調査の結果{任意の文法}+で当たってしまうようなので、泥臭くTerm.appかどうかで場合分けしたほうがいいかも
syntax hoge+ : ja_expr

elab "ja(" je:ja_expr+ ")" : term => do
  let _a: Syntax := (je[0]!).raw
  logInfo s!"kk{je[1]!}"
  pure $ mkStrLit s!"o{je}"

#eval ja(こんにちは)
#eval ja(こんにちは言う)
#eval ja(«ほめる» «太郎が» «次郎を»)


import Yatima.Typechecker.TypecheckM
import Lean.PrettyPrinter

/-!
# Typechecker printing

This module provides rudimentary printing for universes, expressions, and values used for debugging
the typechecker.
-/

open Lean

open Yatima.Typechecker in
def Yatima.Typechecker.ConstNames.getF
    (constNames : ConstNames) (f : Lurk.F) : Format :=
  match constNames.find? f with
  | some name => toString name
  | none => toString f

namespace Yatima.IR
open Yatima.Typechecker

private abbrev indentD := Std.Format.indentD

private def join (as : Array α) (f : α → Format) : Format := Id.run do
  if h : 0 < as.size then
    let mut result ← f as[0]
    for a in as[1:] do
      result := f!"{result} {← f a}"
    return result
  else
    return .nil

private def prefixJoin (pre : Format) (as : Array α) (f : α → TypecheckM Format) : TypecheckM Format := do
  let mut result := .nil
  for a in as do
    result := f!"{result}{pre}{← f a}"
  return result

def Expr.isProp : Expr → Bool
  | .sort .zero => true
  | _ => false

def Expr.isAtom : Expr → Bool
  | .const .. | .var .. | .lit .. => true
  | .proj _ e => isAtom e
  | e => isProp e

def Expr.isBinder : Expr → Bool
  | .lam .. | .pi .. => true
  | _ => false

def Expr.isArrow : Expr → Bool
  -- | .pi dom img => !(body.isVarFree name) && bInfo == .default
  | _ => false

namespace PP

instance : ToFormat BinderInfo where format
  | .default        => "default"
  | .implicit       => "implicit"
  | .strictImplicit => "strict"
  | .instImplicit   => "inst"

instance : ToFormat QuotKind where format
  | .type => "Quot"
  | .ctor => "Quot.mk"
  | .lift => "Quot.lift"
  | .ind  => "Quot.ind"

open Std.Format in
mutual
  partial def paren (e : Expr) : TypecheckM Format :=
    if e.isAtom then ppExpr e
    else return f!"({← ppExpr e})"

  partial def ppUniv (u : Univ) : Format :=
    match u with
    | .succ a   => s!"{ppSuccUniv 1 a}"
    | .zero     => "0"
    | .imax a b => s!"(imax {ppUniv a} {ppUniv b})"
    | .max  a b => s!"(max {ppUniv a} {ppUniv b})"
    | .var  i => s!"_#{i}"

  partial def ppSuccUniv (acc : Nat) : Univ → Format
    | .zero => s!"{acc}"
    | .succ u => ppSuccUniv (acc + 1) u
    | u => s!"{acc}+{ppUniv u}"

  partial def ppUnivs (us : List Univ) : Format :=
    bracket "{" (joinSep (us.map ppUniv) ", ") "}"

  partial def ppExpr (e : Expr) : TypecheckM Format := do
    let constNames := (← read).constNames
    match e with
    | .var name us => return f!"v_{name}@{ppUnivs us}"
    | .sort u => return f!"Sort {ppUniv u}"
    | .const name us =>
      return f!"{constNames.getF name}@{ppUnivs us}"
    | .app func body => match func with
      | .app .. => return f!"{← ppExpr func} {← paren body}"
      | _ => return f!"{← paren func} {← paren body}"
    | .lam type body =>
      return f!"fun (_ : {← ppExpr type}) =>{indentD (← ppExpr body)}"
    | .pi dom img =>
      return f!"(_ : {← ppExpr dom}) → {← ppExpr img}"
    | .letE type value body =>
      return f!"let _ : {← ppExpr type} := {← ppExpr value}"
        ++ ";" ++ .line ++ f!"{← ppExpr body}"
    | .lit lit => match lit with
      | .natVal num => return f!"{num}"
      | .strVal str => return f!"\"{str}\""
    | .proj idx expr => return f!"{← paren expr}.{idx})"
end

partial def ppDefinition (defn : Definition) : TypecheckM Format :=
  let part := if defn.part then "partial " else ""
  return f!"{part}def _ {defn.lvls} : {← ppExpr defn.type} :={indentD (← ppExpr defn.value)}"

partial def ppRecursorRule (rule : RecursorRule) : TypecheckM Format :=
  return f!"fields := {rule.fields}" ++ .line ++ f!"{← ppExpr rule.rhs}"

partial def ppRecursor (recr : Recursor) : TypecheckM Format :=
  let rules := Array.mk recr.rules
  let internal := if recr.internal then "internal" else "external"
  return f!"{internal} recursor _ (lvls := {recr.lvls}) : {← ppExpr recr.type}{indentD (← prefixJoin .line rules ppRecursorRule)}"

partial def ppConstructor (ctor : Constructor) : TypecheckM Format :=
  let fields := f!"idx := {ctor.idx}" ++ .line ++
                f!"params := {ctor.params}" ++ .line ++
                f!"fields := {ctor.fields}"
  return f!"| _ {ctor.lvls} : {← ppExpr ctor.type}{indentD fields}"

partial def ppConstructors (ctors : List Constructor) : TypecheckM Format :=
  return f!"{← prefixJoin .line (Array.mk ctors) ppConstructor}"

partial def ppInductive (ind : Inductive) : TypecheckM Format := do
  let indHeader := f!"inductive _ {ind.lvls} : {← ppExpr ind.type}"
  let fields := f!"recr := {ind.recr}" ++ .line ++
                f!"refl := {ind.refl}" ++ .line ++
                f!"unit := {ind.unit}" ++ .line ++
                f!"params := {ind.params}" ++ .line ++
                f!"indices := {ind.indices}" ++ .line ++
                f!"struct := {ind.struct}"
  return f!"{indHeader} with{indentD fields}"

partial def ppConst (const : Const) : TypecheckM Format :=
  match const with
  | .axiom ax => return f!"axiom _ {ax.lvls} : {← ppExpr ax.type}"
  | .theorem thm =>
    return f!"theorem _ {thm.lvls} : {← ppExpr thm.type} :={indentD (← ppExpr thm.value)}"
  | .opaque opaq =>
    return f!"opaque _ {opaq.lvls} {← ppExpr opaq.type} :={indentD (← ppExpr opaq.value)}"
  | .quotient quot =>
    return f!"quot _ {quot.lvls} : {← ppExpr quot.type} :={indentD (format quot.kind)}"
  | .definition defn =>
    ppDefinition defn
  | .inductiveProj ind => return f!"{reprStr ind}"
  | .constructorProj ctor => return f!"{reprStr ctor}"
  | .recursorProj recr => return f!"{reprStr recr}"
  | .definitionProj defn => return f!"{reprStr defn}"
  | .mutDefBlock block =>
    return f!"{← prefixJoin ("\n" ++ .line) (Array.mk block) ppDefinition}"
  | .mutIndBlock block =>
    return f!"{← prefixJoin ("\n" ++ .line) (Array.mk block) ppInductive}"

end Yatima.IR.PP

namespace Yatima.Typechecker

open IR PP Lean Std.Format

private abbrev indentD := Std.Format.indentD

def TypedExpr.isProp (t : TypedExpr) : Bool := match t.expr with
  | .sort .zero => true
  | _ => false

def TypedExpr.isAtom (t : TypedExpr) : Bool :=
  -- For some reason, Lean can't prove termination when you use projections
  let .mk _ expr := t
  match expr with
  | .const .. | .var .. | .lit .. => true
  | .proj _ _ e => isAtom e
  | _ => isProp t

namespace PP

mutual
  partial def paren (e : TypedExpr) : TypecheckM Format :=
    if e.isAtom then ppTypedExpr e
    else return f!"({← ppTypedExpr e})"

  /-- Printer of expressions -/
  partial def ppTypedExpr (t : TypedExpr) : TypecheckM Format := match t.expr with
    | .var idx => return f!"v_{idx}"
    | .sort u => return f!"Sort {ppUniv u}"
    | .const k univs =>
      return f!"{(← read).constNames.getF k}@{ppUnivs univs}"
    | .app fnc arg => match fnc.expr with
      | .app .. => return f!"{← ppTypedExpr fnc} {← paren arg}"
      | _ => return f!"{← paren fnc} {← paren arg}"
    | .lam dom bod =>
      return f!"fun (_ : {← ppTypedExpr dom}) =>{indentD (← ppTypedExpr bod)}"
    | .pi dom cod =>
      return f!"(_: {← ppTypedExpr dom}) → {← ppTypedExpr cod}"
    | .letE typ val bod => return f!"let _ : {← ppTypedExpr typ} := {← ppTypedExpr val} in {← ppTypedExpr bod}"
    | .lit (.natVal x) => return f!"{x}"
    | .lit (.strVal x) => return f!"\"{x}\""
    | .proj _ idx val => return f!"{← ppTypedExpr val}.{idx}"

end

mutual
  partial def parenWith (e : TypedExpr) (env : Env) : TypecheckM Format :=
    if e.isAtom then ppTypedExprWith e env
    else return f!"({← ppTypedExprWith e env})"

  /-- Auxiliary function to print the body of a lambda expression given `env : Env` -/
  private partial def ppTypedExprWith (t : TypedExpr) (env : Env) : TypecheckM Format :=
    match t.expr with
    | .var 0 => return f!"v_0"
    | .var (idx + 1) =>
      match env.exprs.get? idx with
     | some val => ppValue val.get
     | none => return f!"!_@{idx}!"
    | .sort u => return f!"Sort {ppUniv u}"
    | .const k univs => return f!"{(← read).constNames.getF k}@{ppUnivs univs}"
    | .app fnc arg => match fnc.expr with
      | .app .. => return f!"{← ppTypedExprWith fnc env} {← parenWith arg env}"
      | _ => return f!"{← parenWith fnc env} {← parenWith arg env}"
    -- | .app _ fnc arg => f!"({← ppTypedExprWith fnc env} {← ppTypedExprWith arg env})"
    | .lam dom bod =>
      return f!"fun (_ : {← ppTypedExprWith dom env}) =>{indentD (← ppTypedExprWith bod env)}"
    | .pi dom cod =>
      return f!"(_ : {← ppTypedExprWith dom env}) → {← ppTypedExprWith cod env}"
    | .letE typ val bod => return f!"let _ : {← ppTypedExprWith typ env} := {← ppTypedExprWith val env} in {← ppTypedExprWith bod env}"
    | .lit (.natVal x) => return f!"{x}"
    | .lit (.strVal x) => return f!"\"{x}\""
    | .proj _ idx val => return f!"{← ppTypedExprWith val env}.{idx}"

  private partial def ppNeutral (neu : Neutral) : TypecheckM Format := match neu with
    | .fvar idx .. => return f!"fv_{idx}"
    | .const k univs => return f!"{(← read).constNames.getF k}@{ppUnivs univs}"
    | .proj _ idx val => return f!"{← ppValue val.value}.{idx}"

  /-- Auxiliary function to print a chain of unevaluated applications as a single application -/
  private partial def ppSpine (neu : Neutral) (args : Args) : TypecheckM Format := do
    List.foldrM (fun arg str => return f!"{str} {← ppValue arg.get}") (← ppNeutral neu) args

  /-- Printer of typechecker values -/
  partial def ppValue (val : Value) : TypecheckM Format :=
    match val with
    | .sort u => return f!"Sort {ppUniv u}"
    | .app neu args _ => ppSpine neu args
    | .lam dom bod ctx =>
      return f!"fun (_ : {← ppValue dom.get}) =>{indentD (← ppTypedExprWith bod ctx)}"
    | .pi dom cod ctx =>
      return f!"(_ : {← ppValue dom.get}) → {← ppTypedExprWith cod ctx}"
    | .lit (.natVal x) => return f!"{x}"
    | .lit (.strVal x) => return f!"\"{x}\""
    | .exception e => return f!"exception {e}"
end

-- instance : ToFormat TypedExpr where format := ppTypedExpr
-- instance : ToString TypedExpr where toString := pretty ∘ ppTypedExpr
-- instance : ToFormat Value where format := ppValue
-- instance : ToString Value where toString := pretty ∘ ppValue

def ppTypecheckCtx : TypecheckM Format := do
  let ⟨lvl, env, types, _, _, _, _, _, _, _⟩ ← read
  let env := ← match env with
    | .mk vals us => do
      let vals : List Value := vals.map (·.get)
      let fields := f!"vals := {← vals.mapM ppValue}" ++ line ++ f!"us := {us.map ppUniv}"
      return f!"env with{indentD fields}"
  let types ← types.mapM fun t => ppValue t.get
  let fields := f!"lvl := {lvl}" ++ line ++ f!"env := {env}" ++ line ++ f!"types := {types}"
  return f!"typecheckCtx with{indentD fields}"

end Yatima.Typechecker.PP


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.traversable.basic
import tactic.simpa

setup_tactic_parser

private meta def loc.to_string_aux : option name → string
| none := "⊢"
| (some x) := to_string x

/-- pretty print a `loc` -/
meta def loc.to_string : loc → string
| (loc.ns []) := ""
| (loc.ns [none]) := ""
| (loc.ns ls) := string.join $ list.intersperse " " (" at" :: ls.map loc.to_string_aux)
| loc.wildcard := " at *"

/-- shift `pos` `n` columns to the left -/
meta def pos.move_left (p : pos) (n : ℕ) : pos :=
{ line := p.line, column := p.column - n }

namespace tactic

attribute [derive decidable_eq] simp_arg_type

/-- Turn a `simp_arg_type` into a string. -/
meta instance simp_arg_type.has_to_string : has_to_string simp_arg_type :=
⟨λ a, match a with
| simp_arg_type.all_hyps := "*"
| (simp_arg_type.except n) := "-" ++ to_string n
| (simp_arg_type.expr e) := to_string e
| (simp_arg_type.symm_expr e) := "←" ++ to_string e
end⟩

open list

/-- parse structure instance of the shape `{ field1 := value1, .. , field2 := value2 }` -/
meta def struct_inst : lean.parser pexpr :=
do tk "{",
   ls ← sep_by (skip_info (tk ","))
     ( sum.inl <$> (tk ".." *> texpr) <|>
       sum.inr <$> (prod.mk <$> ident <* tk ":=" <*> texpr)),
   tk "}",
   let (srcs,fields) := partition_map id ls,
   let (names,values) := unzip fields,
   pure $ pexpr.mk_structure_instance
     { field_names := names,
       field_values := values,
       sources := srcs }

/-- pretty print structure instance -/
meta def struct.to_tactic_format (e : pexpr) : tactic format :=
do r ← e.get_structure_instance_info,
   fs ← mzip_with (λ n v,
     do v ← to_expr v >>= pp,
        pure $ format!"{n} := {v}" )
     r.field_names r.field_values,
   let ss := r.sources.map (λ s, format!" .. {s}"),
   let x : format := format.join $ list.intersperse ", " (fs ++ ss),
   pure format!" {{{x}}}"

/-- Attribute containing a table that accumulates multiple `squeeze_simp` suggestions -/
@[user_attribute]
private meta def squeeze_loc_attr :
  user_attribute unit (option (list (pos × string × list simp_arg_type × string))) :=
{ name := `_squeeze_loc,
  parser := fail "this attribute should not be used",
  descr := "table to accumulate multiple `squeeze_simp` suggestions" }

/-- dummy declaration used as target of `squeeze_loc` attribute -/
def squeeze_loc_attr_carrier := ()

run_cmd squeeze_loc_attr.set ``squeeze_loc_attr_carrier none tt

/-- Format a list of arguments for use with `simp` and friends. This omits the
list entirely if it is empty.

Patch: `pp` was changed to `to_string` because it was getting rid of prefixes
that would be necessary for some disambiguations. -/
meta def render_simp_arg_list : list simp_arg_type → format
| [] := ""
| args := (++) " " $ to_line_wrap_format $ args.map to_string

/-- Emit a suggestion to the user. If inside a `squeeze_scope` block,
the suggestions emitted through `mk_suggestion` will be aggregated so that
every tactic that makes a suggestion can consider multiple execution of the
same invocation.
If `at_pos` is true, make the suggestion at `p` instead of the current position. -/
meta def mk_suggestion (p : pos) (pre post : string) (args : list simp_arg_type)
  (at_pos := ff) : tactic unit :=
do xs ← squeeze_loc_attr.get_param ``squeeze_loc_attr_carrier,
   match xs with
   | none := do
     let args := render_simp_arg_list args,
     if at_pos then
       @scope_trace _ p.line p.column $
         λ _, _root_.trace sformat!"{pre}{args}{post}" (pure () : tactic unit)
     else
       trace sformat!"{pre}{args}{post}"
   | some xs := do
     squeeze_loc_attr.set ``squeeze_loc_attr_carrier ((p,pre,args,post) :: xs) ff
   end

/-- translate a `pexpr` into a `simp` configuration -/
meta def parse_config : option pexpr → tactic (simp_config_ext × format)
| none := pure ({}, "")
| (some cfg) :=
  do e ← to_expr ``(%%cfg : simp_config_ext),
     fmt ← has_to_tactic_format.to_tactic_format cfg,
     prod.mk <$> eval_expr simp_config_ext e
             <*> struct.to_tactic_format cfg

/-- translate a `pexpr` into a `dsimp` configuration -/
meta def parse_dsimp_config : option pexpr → tactic (dsimp_config × format)
| none := pure ({}, "")
| (some cfg) :=
  do e ← to_expr ``(%%cfg : simp_config_ext),
     fmt ← has_to_tactic_format.to_tactic_format cfg,
     prod.mk <$> eval_expr dsimp_config e
             <*> struct.to_tactic_format cfg

/-- `same_result proof tac` runs tactic `tac` and checks if the proof
produced by `tac` is equivalent to `proof`. -/
meta def same_result (pr : proof_state) (tac : tactic unit) : tactic bool :=
do s ← get_proof_state_after tac,
   pure $ some pr = s

/--
Consumes the first list of `simp` arguments, accumulating required arguments
on the second one and unnecessary arguments on the third one.
-/
private meta def filter_simp_set_aux
  (tac : bool → list simp_arg_type → tactic unit)
  (args : list simp_arg_type) (pr : proof_state) :
  list simp_arg_type → list simp_arg_type →
  list simp_arg_type → tactic (list simp_arg_type × list simp_arg_type)
| [] ys ds := pure (ys, ds)
| (x :: xs) ys ds :=
  do b ← same_result pr (tac tt (args ++ xs ++ ys)),
     if b
       then filter_simp_set_aux xs ys (ds.concat x)
       else filter_simp_set_aux xs (ys.concat x) ds

declare_trace squeeze.deleted

/--
`filter_simp_set g call_simp user_args simp_args` returns `args'` such that, when calling
`call_simp tt /- only -/ args'` on the goal `g` (`g` is a meta var) we end up in the same
state as if we had called `call_simp ff (user_args ++ simp_args)` and removing any one
element of `args'` changes the resulting proof.
-/
meta def filter_simp_set
  (tac : bool → list simp_arg_type → tactic unit)
  (user_args simp_args : list simp_arg_type) : tactic (list simp_arg_type) :=
do some s ← get_proof_state_after (tac ff (user_args ++ simp_args)),
   (simp_args', _)  ← filter_simp_set_aux tac user_args s simp_args [] [],
   (user_args', ds) ← filter_simp_set_aux tac simp_args' s user_args [] [],
   when (is_trace_enabled_for `squeeze.deleted = tt ∧ ¬ ds.empty)
     trace!"deleting provided arguments {ds}",
   pure (user_args' ++ simp_args')

/-- make a `simp_arg_type` that references the name given as an argument -/
meta def name.to_simp_args (n : name) : simp_arg_type :=
simp_arg_type.expr $ @expr.local_const ff n n (default) pexpr.mk_placeholder

/-- If the `name` is (likely) to be overloaded, then prepend a `_root_` on it. The `expr` of an
overloaded name is constructed using `expr.macro`; this is how we guess whether it's overloaded. -/
meta def prepend_root_if_needed (n : name) : tactic name :=
do x ← resolve_name' n,
return $ match x with
| expr.macro _ _ := `_root_ ++ n
| _ := n
end

/-- tactic combinator to create a `simp`-like tactic that minimizes its
argument list.

 * `slow`: adds all rfl-lemmas from the environment to the initial list (this is a slower but more
           accurate strategy)
 * `no_dflt`: did the user use the `only` keyword?
 * `args`:    list of `simp` arguments
 * `tac`:     how to invoke the underlying `simp` tactic
-/
meta def squeeze_simp_core
  (slow no_dflt : bool) (args : list simp_arg_type)
  (tac : Π (no_dflt : bool) (args : list simp_arg_type), tactic unit)
  (mk_suggestion : list simp_arg_type → tactic unit) : tactic unit :=
do v ← target >>= mk_meta_var,
   args ← if slow then do
     simp_set ← attribute.get_instances `simp,
     simp_set ← simp_set.mfilter $ has_attribute' `_refl_lemma,
     simp_set ← simp_set.mmap $ resolve_name' >=> pure ∘ simp_arg_type.expr,
     pure $ args ++ simp_set
   else pure args,
   g ← retrieve $ do
   { g ← main_goal,
     tac no_dflt args,
     instantiate_mvars g },
   let vs := g.list_constant',
   vs ← vs.mfilter is_simp_lemma,
   vs ← vs.mmap strip_prefix,
   vs ← vs.mmap prepend_root_if_needed,
   with_local_goals' [v] (filter_simp_set tac args $ vs.map name.to_simp_args)
     >>= mk_suggestion,
   tac no_dflt args

namespace interactive

/-- combinator meant to aggregate the suggestions issued by multiple calls
of `squeeze_simp` (due, for instance, to `;`).

Can be used as:

```lean
example {α β} (xs ys : list α) (f : α → β) :
  (xs ++ ys.tail).map f = xs.map f ∧ (xs.tail.map f).length = xs.length :=
begin
  have : xs = ys, admit,
  squeeze_scope
  { split; squeeze_simp,
    -- `squeeze_simp` is run twice, the first one requires
    -- `list.map_append` and the second one
    -- `[list.length_map, list.length_tail]`
    -- prints only one message and combine the suggestions:
    -- > Try this: simp only [list.length_map, list.length_tail, list.map_append]
    squeeze_simp [this]
    -- `squeeze_simp` is run only once
    -- prints:
    -- > Try this: simp only [this] },
end
```

-/
meta def squeeze_scope (tac : itactic) : tactic unit :=
do none ← squeeze_loc_attr.get_param ``squeeze_loc_attr_carrier | pure (),
   squeeze_loc_attr.set ``squeeze_loc_attr_carrier (some []) ff,
   finally tac $ do
     some xs ← squeeze_loc_attr.get_param ``squeeze_loc_attr_carrier | fail "invalid state",
     let m := native.rb_lmap.of_list xs,
     squeeze_loc_attr.set ``squeeze_loc_attr_carrier none ff,
     m.to_list.reverse.mmap' $ λ ⟨p,suggs⟩, do
       { let ⟨pre,_,post⟩ := suggs.head,
         let suggs : list (list simp_arg_type) := suggs.map $ prod.fst ∘ prod.snd,
         mk_suggestion p pre post (suggs.foldl list.union []) tt, pure () }

/--
`squeeze_simp`, `squeeze_simpa` and `squeeze_dsimp` perform the same
task with the difference that `squeeze_simp` relates to `simp` while
`squeeze_simpa` relates to `simpa` and `squeeze_dsimp` relates to
`dsimp`. The following applies to `squeeze_simp`, `squeeze_simpa` and
`squeeze_dsimp`.

`squeeze_simp` behaves like `simp` (including all its arguments)
and prints a `simp only` invocation to skip the search through the
`simp` lemma list.

For instance, the following is easily solved with `simp`:

```lean
example : 0 + 1 = 1 + 0 := by simp
```

To guide the proof search and speed it up, we may replace `simp`
with `squeeze_simp`:

```lean
example : 0 + 1 = 1 + 0 := by squeeze_simp
-- prints:
-- Try this: simp only [add_zero, eq_self_iff_true, zero_add]
```

`squeeze_simp` suggests a replacement which we can use instead of
`squeeze_simp`.

```lean
example : 0 + 1 = 1 + 0 := by simp only [add_zero, eq_self_iff_true, zero_add]
```

`squeeze_simp only` prints nothing as it already skips the `simp` list.

This tactic is useful for speeding up the compilation of a complete file.
Steps:

   1. search and replace ` simp` with ` squeeze_simp` (the space helps avoid the
      replacement of `simp` in `@[simp]`) throughout the file.
   2. Starting at the beginning of the file, go to each printout in turn, copy
      the suggestion in place of `squeeze_simp`.
   3. after all the suggestions were applied, search and replace `squeeze_simp` with
      `simp` to remove the occurrences of `squeeze_simp` that did not produce a suggestion.

Known limitation(s):
  * in cases where `squeeze_simp` is used after a `;` (e.g. `cases x; squeeze_simp`),
    `squeeze_simp` will produce as many suggestions as the number of goals it is applied to.
    It is likely that none of the suggestion is a good replacement but they can all be
    combined by concatenating their list of lemmas. `squeeze_scope` can be used to
    combine the suggestions: `by squeeze_scope { cases x; squeeze_simp }`
  * sometimes, `simp` lemmas are also `_refl_lemma` and they can be used without appearing in the
    resulting proof. `squeeze_simp` won't know to try that lemma unless it is called as
    `squeeze_simp?`
-/
meta def squeeze_simp
  (key : parse cur_pos)
  (slow_and_accurate : parse (tk "?")?)
  (use_iota_eqn : parse (tk "!")?) (no_dflt : parse only_flag) (hs : parse simp_arg_list)
  (attr_names : parse with_ident_list) (locat : parse location)
  (cfg : parse struct_inst?) : tactic unit :=
do (cfg',c) ← parse_config cfg,
   squeeze_simp_core slow_and_accurate.is_some no_dflt hs
     (λ l_no_dft l_args, simp use_iota_eqn none l_no_dft l_args attr_names locat cfg')
     (λ args,
        let use_iota_eqn := if use_iota_eqn.is_some then "!" else "",
            attrs := if attr_names.empty then ""
                     else string.join (list.intersperse " " (" with" :: attr_names.map to_string)),
            loc := loc.to_string locat in
        mk_suggestion (key.move_left 1)
          sformat!"Try this: simp{use_iota_eqn} only"
          sformat!"{attrs}{loc}{c}" args)

/-- see `squeeze_simp` -/
meta def squeeze_simpa
  (key : parse cur_pos)
  (slow_and_accurate : parse (tk "?")?)
  (use_iota_eqn : parse (tk "!")?) (no_dflt : parse only_flag) (hs : parse simp_arg_list)
  (attr_names : parse with_ident_list) (tgt : parse (tk "using" *> texpr)?)
  (cfg : parse struct_inst?) : tactic unit :=
do (cfg',c) ← parse_config cfg,
   tgt' ← traverse (λ t, do t ← to_expr t >>= pp,
                            pure format!" using {t}") tgt,
   squeeze_simp_core slow_and_accurate.is_some no_dflt hs
     (λ l_no_dft l_args, simpa use_iota_eqn none l_no_dft l_args attr_names tgt cfg')
     (λ args,
        let use_iota_eqn := if use_iota_eqn.is_some then "!" else "",
            attrs := if attr_names.empty then ""
                     else string.join (list.intersperse " " (" with" :: attr_names.map to_string)),
            tgt' := tgt'.get_or_else "" in
        mk_suggestion (key.move_left 1)
          sformat!"Try this: simpa{use_iota_eqn} only"
          sformat!"{attrs}{tgt'}{c}" args)

/-- `squeeze_dsimp` behaves like `dsimp` (including all its arguments)
and prints a `dsimp only` invocation to skip the search through the
`simp` lemma list. See the doc string of `squeeze_simp` for examples.
 -/
meta def squeeze_dsimp
  (key : parse cur_pos)
  (slow_and_accurate : parse (tk "?")?)
  (use_iota_eqn : parse (tk "!")?)
  (no_dflt : parse only_flag) (hs : parse simp_arg_list)
  (attr_names : parse with_ident_list) (locat : parse location)
  (cfg : parse struct_inst?) : tactic unit :=
do (cfg',c) ← parse_dsimp_config cfg,
   squeeze_simp_core slow_and_accurate.is_some no_dflt hs
     (λ l_no_dft l_args, dsimp l_no_dft l_args attr_names locat cfg')
     (λ args,
        let use_iota_eqn := if use_iota_eqn.is_some then "!" else "",
            attrs := if attr_names.empty then ""
                     else string.join (list.intersperse " " (" with" :: attr_names.map to_string)),
            loc := loc.to_string locat in
        mk_suggestion (key.move_left 1)
          sformat!"Try this: dsimp{use_iota_eqn} only"
          sformat!"{attrs}{loc}{c}" args)

end interactive
end tactic

open tactic.interactive
add_tactic_doc
{ name       := "squeeze_simp / squeeze_simpa / squeeze_dsimp / squeeze_scope",
  category   := doc_category.tactic,
  decl_names :=
   [``squeeze_simp,
    ``squeeze_dsimp,
    ``squeeze_simpa,
    ``squeeze_scope],
  tags       := ["simplification", "Try this"],
  inherit_description_from := ``squeeze_simp }


syntax "have" ":" term : tactic
example : False := by
  have : True := by simp [  -- should *not* parse the shorter `have` syntax and then fail on `:=`


import AwesomeDashboards.Prometheus

def node_boot_time_seconds : Metric := {
  name := "node_boot_time_seconds"
  type := MetricType.gauge
  labels := []
  unit := MetricUnit.seconds
}

def node_filesystem_avail_bytes : Metric := {
  name := "node_filesystem_avail_bytes"
  type := MetricType.gauge
  labels := ["device", "fstype", "mountpoint"]
  unit := MetricUnit.bytes
}

def process_cpu_seconds_total : Metric := {
  name := "process_cpu_seconds_total"
  type := MetricType.counter
  labels := []
  unit := MetricUnit.seconds
}

def node_network_receive_bytes_total : Metric := {
  name := "node_network_receive_bytes_total"
  type := MetricType.counter
  labels := ["device"]
  unit := MetricUnit.bytes
}

def node_exporter : Exporter := {
  metrics := [node_boot_time_seconds, node_filesystem_avail_bytes, process_cpu_seconds_total, node_network_receive_bytes_total]
}

def lm : List KeyValuePair := [{key := "__name__", value := "node_filesystem_avail_bytes"}]
def v := InstantVector.selector {equal := lm} 0

#eval InstantVector.typesafe v node_exporter
#eval List.map (λ l => l.key) (lm.filter $ is_name)
#eval List.all (lm.filter $ is_name) (λ l => "node_filesystem_avail_bytes" = l.key )

example : InstantVector.typesafe (InstantVector.selector {equal := lm} 0) node_exporter := by simp

def avail_bytes : InstantVector InstantVectorType.vector := [pql| node_filesystem_avail_bytes-node_filesystem_avail_bytes]
#eval unitOf node_exporter avail_bytes
#eval RangeVector.unitOf node_exporter $ RangeVector.selector (LabelMatchers.empty.withName "node_network_receive_bytes_total") 5
#eval unitOf node_exporter [pql| rate(node_network_receive_bytes_total{}[5])]
#eval [pql| rate(node_network_receive_bytes_total{device="vda"}[120])]


import .definitions3 .qi

lemma exp.vcgen.extension {P: prop} {e: exp} {Q: propctx}: (P ⊢ e : Q) → (P ⊩ e : Q) :=
  begin

    assume e_verified: P ⊢ e : Q,

    induction e_verified,

    case exp.vcgen.tru P y e' Q y_not_in_P e'_verified ih {
      apply exp.dvcgen.tru,
      from y_not_in_P,
      from ih
    },

    case exp.vcgen.fals P y e' Q y_not_in_P e'_verified ih {
      apply exp.dvcgen.fals,
      from y_not_in_P,
      from ih
    },

    case exp.vcgen.num P y n e' Q y_not_in_P e'_verified ih {
      apply exp.dvcgen.num,
      from y_not_in_P,
      from ih
    },

    case exp.vcgen.func P f fx R S e₁ e₂ Q₁ Q₂ f_not_in_P fx_not_in_P f_neq_fx fx_in_R fv_R fv_S
                        e₁_verified e₂_verified func_vc ih₁ ih₂ {
      apply exp.dvcgen.func,
      from f_not_in_P,
      from fx_not_in_P,
      from f_neq_fx,
      from fx_in_R,
      from fv_R,
      from fv_S,
      from ih₁,
      from ih₂,
      from vc_valid_from_inst_valid func_vc
    },

    case exp.vcgen.unop op P e' x₁ y Q x_free_in_P y_not_in_P e'_verified vc_valid ih {
      apply exp.dvcgen.unop,
      from x_free_in_P,
      from y_not_in_P,
      from ih,
      from vc_valid_from_inst_valid vc_valid
    },

    case exp.vcgen.binop op P e' x₁ x₂ y Q x₁_free_in_P x₂_free_in_P y_not_in_P e'_verified vc_valid ih {
      apply exp.dvcgen.binop,
      from x₁_free_in_P,
      from x₂_free_in_P,
      from y_not_in_P,
      from ih,
      from vc_valid_from_inst_valid vc_valid
    },

    case exp.vcgen.app P y f e' x₁ Q f_free_in_P x₁_free_in_P y_not_in_P e'_verified vc_valid ih {
      apply exp.dvcgen.app,
      from f_free_in_P,
      from x₁_free_in_P,
      from y_not_in_P,
      from ih,
      from vc_valid_from_inst_valid vc_valid
    },

    case exp.vcgen.ite P e₁ e₂ y Q₁ Q₂ y_free_in_P e₁_verified e₂_verified vc_valid ih₁ ih₂ {
      apply exp.dvcgen.ite,
      from y_free_in_P,
      from ih₁,
      from ih₂,
      from vc_valid_from_inst_valid vc_valid
    },

    case exp.vcgen.return P y y_free_in_P {
      apply exp.dvcgen.return,
      from y_free_in_P
    }
  end

lemma exp.dvcgen.return.inv {P: prop} {x: var} {Q: propctx}: (P ⊩ exp.return x : Q) → x ∈ FV P :=
  assume return_verified: P ⊩ exp.return x : Q,
  begin
    cases return_verified,
    case exp.dvcgen.return x_free {
      show x ∈ FV P, from x_free
    }
  end

lemma stack.dvcgen.top.inv {R: spec} {σ: env} {e: exp} {Q: propctx}:
  (⊩ₛ (R, σ, e) : Q) →
  ∃P Q₂, (⊩ σ: P) ∧ (FV R.to_prop ⊆ FV P) ∧ (σ ⊨ R.to_prop.to_vc) ∧ (R ⋀ P ⊩ e: Q₂) :=
  assume top_verified: ⊩ₛ (R, σ, e) : Q,
  begin
    cases top_verified,
    case stack.dvcgen.top P Q env_verified fv_R R_valid e_verified {
      show ∃P Q₂, (⊩ σ: P) ∧ (FV R.to_prop ⊆ FV P) ∧ (σ ⊨ R.to_prop.to_vc) ∧ (R ⋀ P ⊩ e: Q₂),
      from exists.intro P (exists.intro Q ⟨env_verified, ⟨fv_R, ⟨R_valid, e_verified⟩⟩⟩)
    }
  end

lemma env.dvcgen.inv {σ: env} {P: prop} {x: var} {v: value}:
      (⊩ σ : P) → (σ x = v) → ∃σ' Q', ⊩ (σ'[x↦v]) : Q' :=
  assume env_verified: ⊩ σ : P,
  assume σ_x_is_v: σ x = v,
  show ∃σ' Q', ⊩ (σ'[x↦v]) : Q', by begin
    induction env_verified,
    case env.dvcgen.empty { from
      have env.apply env.empty x = none, by unfold env.apply,
      have some v = none, from eq.trans σ_x_is_v.symm this,
      show ∃σ' Q', ⊩ (σ'[x↦v]) : Q', from false.elim (option.no_confusion this)
    },
    case env.dvcgen.tru σ' y Q y_not_in_σ' σ'_verified ih { from
      have env.apply (σ'[y↦value.true]) x = v, from σ_x_is_v,
      have h1: (if y = x ∧ option.is_none (σ'.apply x) then ↑value.true else σ'.apply x) = v,
      by { unfold env.apply at this, from this },
      if h2: y = x ∧ option.is_none (σ'.apply x) then (
        have (↑value.true) = ↑v, by { simp[h2] at h1, from h1 },
        have v_is_true: v = value.true, from (option.some.inj this).symm,
        have x_not_in_σ': x ∉ σ', from h2.left ▸ y_not_in_σ',
        have ⊩ (σ'[x↦value.true]) : Q ⋀ x ≡ value.true, from env.dvcgen.tru x_not_in_σ' σ'_verified,
        have ⊩ (σ'[x↦v]) : Q ⋀ x ≡ value.true, from v_is_true.symm ▸ this,
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q',
        from exists.intro σ' (exists.intro (Q ⋀ x ≡ value.true) this)
      ) else (
        have (σ'.apply x) = v, by { simp[h2] at h1, from h1 },
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q', from ih this
      )
    },
    case env.dvcgen.fls σ' y Q y_not_in_σ' σ'_verified ih { from
      have env.apply (σ'[y↦value.false]) x = v, from σ_x_is_v,
      have h1: (if y = x ∧ option.is_none (σ'.apply x) then ↑value.false else σ'.apply x) = v,
      by { unfold env.apply at this, from this },
      if h2: y = x ∧ option.is_none (σ'.apply x) then (
        have (↑value.false) = ↑v, by { simp[h2] at h1, from h1 },
        have v_is_false: v = value.false, from (option.some.inj this).symm,
        have x_not_in_σ': x ∉ σ', from h2.left ▸ y_not_in_σ',
        have ⊩ (σ'[x↦value.false]) : Q ⋀ x ≡ value.false, from env.dvcgen.fls x_not_in_σ' σ'_verified,
        have ⊩ (σ'[x↦v]) : Q ⋀ x ≡ value.false, from v_is_false.symm ▸ this,
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q',
        from exists.intro σ' (exists.intro (Q ⋀ x ≡ value.false) this)
      ) else (
        have (σ'.apply x) = v, by { simp[h2] at h1, from h1 },
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q', from ih this
      )
    },
    case env.dvcgen.num n σ' y Q y_not_in_σ' σ'_verified ih { from
      have env.apply (σ'[y↦value.num n]) x = v, from σ_x_is_v,
      have h1: (if y = x ∧ option.is_none (σ'.apply x) then ↑(value.num n) else σ'.apply x) = v,
      by { unfold env.apply at this, from this },
      if h2: y = x ∧ option.is_none (σ'.apply x) then (
        have ↑(value.num n) = ↑v, by { simp[h2] at h1, from h1 },
        have v_is_num: v = value.num n, from (option.some.inj this).symm,
        have x_not_in_σ': x ∉ σ', from h2.left ▸ y_not_in_σ',
        have ⊩ (σ'[x↦value.num n]) : Q ⋀ x ≡ value.num n, from env.dvcgen.num x_not_in_σ' σ'_verified,
        have ⊩ (σ'[x↦v]) : Q ⋀ x ≡ value.num n, from v_is_num.symm ▸ this,
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q',
        from exists.intro σ' (exists.intro (Q ⋀ x ≡ value.num n) this)
      ) else (
        have (σ'.apply x) = v, by { simp[h2] at h1, from h1 },
        show ∃σ' Q', ⊩ (σ'[x↦v]) : Q', from ih this
      )
    },
    case env.dvcgen.func f σ₂ σ₁ g gx R S e Q₁ Q₂ Q₃ f_not_in_σ₁ g_not_in_σ₂ gx_not_in_σ₂ g_neq_gx
                        σ₁_verified σ₂_verified x_free_in_R fv_R fv_S e_verified func_vc ih₁ ih₂ { from
      have env.apply (σ₁[f↦value.func g gx R S e σ₂]) x = v, from σ_x_is_v,
      have h1: (if f = x ∧ option.is_none (σ₁.apply x) then ↑(value.func g gx R S e σ₂) else σ₁.apply x) = v,
      by { unfold env.apply at this, from this },
      if h2: f = x ∧ option.is_none (σ₁.apply x) then (
        have ↑(value.func g gx R S e σ₂) = ↑v, by { simp[h2] at h1, from h1 },
        have v_is_num: v = value.func g gx R S e σ₂, from (option.some.inj this).symm,
        have x_not_in_σ₁: x ∉ σ₁, from h2.left ▸ f_not_in_σ₁,
        have ⊩ (σ₁[x↦value.func g gx R S e σ₂]) :
                  (Q₁
                  ⋀ x ≡ value.func g gx R S e σ₂
                  ⋀ prop.subst_env (σ₂[g↦value.func g gx R S e σ₂]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
        from env.dvcgen.func x_not_in_σ₁ g_not_in_σ₂ gx_not_in_σ₂ g_neq_gx
                             σ₁_verified σ₂_verified x_free_in_R fv_R fv_S e_verified func_vc,
        have ⊩ (σ₁[x↦v]) :
                  (Q₁
                  ⋀ x ≡ value.func g gx R S e σ₂
                  ⋀ prop.subst_env (σ₂[g↦value.func g gx R S e σ₂]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
        from v_is_num.symm ▸ this,
        show ∃σ₁ Q', ⊩ (σ₁[x↦v]) : Q',
        from exists.intro σ₁ (exists.intro (Q₁
                  ⋀ x ≡ value.func g gx R S e σ₂
                  ⋀ prop.subst_env (σ₂[g↦value.func g gx R S e σ₂]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))) this)
      ) else (
        have (σ₁.apply x) = v, by { simp[h2] at h1, from h1 },
        show ∃σ₁ Q₁, ⊩ (σ₁[x↦v]) : Q₁, from ih₁ this
      )
    }
  end

lemma env.dvcgen.tru.inv {σ: env} {x: var} {Q: prop}:
    (⊩ (σ[x ↦ value.true]) : Q ⋀ x ≡ value.true) → x ∉ σ ∧ (⊩ σ : Q) :=
  assume h: ⊩ (σ[x ↦ value.true]) : Q ⋀ x ≡ value.true,
  begin
    cases h,
    case env.dvcgen.tru h1 h2 { from ⟨h1, h2⟩ }
  end

lemma env.dvcgen.fls.inv {σ: env} {x: var} {Q: prop}:
    (⊩ (σ[x ↦ value.false]) : Q ⋀ x ≡ value.false) → x ∉ σ ∧ (⊩ σ : Q) :=
  assume h: ⊩ (σ[x ↦ value.false]) : Q ⋀ x ≡ value.false,
  begin
    cases h,
    case env.dvcgen.fls h1 h2 { from ⟨h1, h2⟩ }
  end

lemma env.dvcgen.num.inv {σ: env} {x: var} {n: ℕ} {Q: prop}:
    (⊩ (σ[x ↦ value.num n]) : Q ⋀ x ≡ value.num n) → x ∉ σ ∧ (⊩ σ : Q) :=
  assume h: ⊩ (σ[x ↦ value.num n]) : Q ⋀ x ≡ value.num n,
  begin
    cases h,
    case env.dvcgen.num h1 h2 { from ⟨h1, h2⟩ }
  end

lemma env.dvcgen.func.inv {σ₁ σ₂: env} {f g x: var} {R S: spec} {e: exp} {Q: prop}:
      (⊩ (σ₁[f ↦ value.func g x R S e σ₂]) : Q) →
      ∃Q₁ Q₂ Q₃,
      f ∉ σ₁ ∧
      g ∉ σ₂ ∧
      x ∉ σ₂ ∧
      g ≠ x ∧
      (⊩ σ₁ : Q₁) ∧
      (⊩ σ₂ : Q₂) ∧
      x ∈ FV R.to_prop.to_vc ∧
      FV R.to_prop ⊆ FV Q₂ ∪ { g, x } ∧
      FV S.to_prop ⊆ FV Q₂ ∪ { g, x } ∧
      (Q₂ ⋀ spec.func g x R S ⋀ R ⊩ e : Q₃) ∧
      ⦃ prop.implies (Q₂ ⋀ spec.func g x R S ⋀ R ⋀ Q₃ (term.app g x)) S ⦄ ∧
      (Q = (Q₁ ⋀
           ((f ≡ (value.func g x R S e σ₂)) ⋀
           prop.subst_env (σ₂[g↦value.func g x R S e σ₂])
           (prop.func g x R (Q₃ (term.app g ↑x) ⋀ S))))) :=
  assume h : ⊩ (σ₁[f ↦ value.func g x R S e σ₂]) : Q,
  begin
    cases h,
    case env.dvcgen.func Q₁ Q₂ Q₃ f_not_in_σ₁ g_not_in_σ₂ x_not_in_σ₂ g_neq_x
                        σ₁_verified σ₂_verified x_free_in_R fv_R fv_S e_verified func_vc {
      from ⟨Q₁, ⟨Q₂, ⟨Q₃,
           ⟨f_not_in_σ₁, ⟨g_not_in_σ₂, ⟨x_not_in_σ₂, ⟨g_neq_x, ⟨σ₁_verified,
           ⟨σ₂_verified, ⟨x_free_in_R, ⟨fv_R, ⟨fv_S, ⟨e_verified, ⟨func_vc, rfl⟩⟩⟩⟩⟩⟩⟩⟩⟩⟩⟩⟩⟩⟩
    }
  end

lemma env.dvcgen.copy {σ₁ σ₂: env} {P₁ P₂} {x y: var} {v: value}:
      (⊩ σ₁ : P₁) → (y ∉ σ₁) → (⊩ (σ₂[x↦v]) : P₂) → ∃P₃, (⊩ (σ₁[y↦v]) : P₁ ⋀ P₃) :=
  assume σ₁_verified: ⊩ σ₁ : P₁,
  assume y_not_in_σ₁: y ∉ σ₁,
  assume σ₂_xv_verified: ⊩ (σ₂[x↦v]) : P₂,
  show ∃P₃, (⊩ (σ₁[y↦v]) : P₁ ⋀ P₃), by begin
    cases σ₂_xv_verified,
    case env.dvcgen.tru { from
      have ⊩ (σ₁[y↦value.true]) : P₁ ⋀ y ≡ value.true,
      from env.dvcgen.tru y_not_in_σ₁ σ₁_verified,
      show ∃P₃, ⊩ (σ₁[y↦value.true]) : P₁ ⋀ P₃, from exists.intro (y ≡ value.true) this
    },
    case env.dvcgen.fls { from
      have ⊩ (σ₁[y↦value.false]) : P₁ ⋀ y ≡ value.false,
      from env.dvcgen.fls y_not_in_σ₁ σ₁_verified,
      show ∃P₃, ⊩ (σ₁[y↦value.false]) : P₁ ⋀ P₃, from exists.intro (y ≡ value.false) this
    },
    case env.dvcgen.num n { from
      have ⊩ (σ₁[y↦value.num n]) : P₁ ⋀ y ≡ value.num n,
      from env.dvcgen.num y_not_in_σ₁ σ₁_verified,
      show ∃P₃, ⊩ (σ₁[y↦value.num n]) : P₁ ⋀ P₃, from exists.intro (y ≡ value.num n) this
    },
    case env.dvcgen.func σ₃ f fx R S e Q₃ Q₄ Q₂ x_not_in_σ₂ f_not_in_σ₃ fx_not_in_σ₃
                        f_neq_fx σ₂_verified σ₃_verified x_free_in_R fv_R fv_S e_verified func_vc { from
      have ⊩ (σ₁[y↦value.func f fx R S e σ₃]) : (P₁
        ⋀ y ≡ value.func f fx R S e σ₃
        ⋀ prop.subst_env (σ₃[f↦value.func f fx R S e σ₃]) (prop.func f fx R (Q₃ (term.app f fx) ⋀ S))),
      from env.dvcgen.func y_not_in_σ₁ f_not_in_σ₃ fx_not_in_σ₃
                        f_neq_fx σ₁_verified σ₃_verified x_free_in_R fv_R fv_S e_verified func_vc,
      show ∃P₃, ⊩ (σ₁[y↦value.func f fx R S e σ₃]) : P₁ ⋀ P₃,
      from exists.intro (
        y ≡ value.func f fx R S e σ₃
       ⋀ prop.subst_env (σ₃[f↦value.func f fx R S e σ₃]) (prop.func f fx R (Q₃ (term.app f fx) ⋀ S)))
      this
    }
  end

lemma exp.dvcgen.inj {P: prop} {Q: propctx} {e: exp}: (P ⊩ e : Q) → ∀Q', (P ⊩ e : Q') → (Q = Q') :=
  assume h1: P ⊩ e : Q,
  begin
    induction h1,

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_3,
    rw[this],

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_3,
    rw[this],

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_3,
    rw[this],

    intros Q' h2,
    cases h2,
    have h3: (Q₁ = Q₁_1), from ih_1 Q₁_1 a_15,
    rw[←h3] at a_16,
    have : (Q₂ = Q₂_1), from ih_2 Q₂_1 a_16,
    rw[this],
    rw[h3],

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_6,
    rw[this],

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_8,
    rw[this],

    intros Q' h2,
    cases h2,
    have : (Q_1 = Q_2), from ih_1 Q_2 a_8,
    rw[this],

    intros Q' h2,
    cases h2,
    have : (Q₁ = Q₁_1), from ih_1 Q₁_1 a_5,
    rw[this],
    have : (Q₂ = Q₂_1), from ih_2 Q₂_1 a_6,
    rw[this],
    refl,

    intros Q' h2,
    cases h2,
    refl
  end

lemma env.dvcgen.inj {P: prop} {σ: env}: (⊩ σ : P) → ∀Q, (⊩ σ : Q) → (P = Q) :=
  assume h1: ⊩ σ : P,
  begin
    induction h1,

    intros Q h2,
    cases h2,
    refl,

    intros Q h2,
    cases h2,
    have : (Q = Q_1), from ih_1 Q_1 a_3,
    rw[this],
    refl,

    intros Q h2,
    cases h2,
    have : (Q = Q_1), from ih_1 Q_1 a_3,
    rw[this],
    refl,

    intros Q h2,
    cases h2,
    have : (Q = Q_1), from ih_1 Q_1 a_3,
    rw[this],
    refl,

    intros Q h2,
    cases h2,
    have h3: (Q₁ = Q₁_1), from ih_1 Q₁_1 a_15,
    rw[h3],
    have h4: (Q₂ = Q₂_1), from ih_2 Q₂_1 a_16,
    rw[←h4] at a_20,
    have : (Q₃ = Q₃_1), from exp.dvcgen.inj a_9 Q₃_1 a_20,
    rw[this],
    refl
  end

lemma stack.dvcgen.inj {s: dstack} {Q₁: propctx}: (⊩ₛ s : Q₁) → ∀Q₂, (⊩ₛ s : Q₂) → (Q₁ = Q₂) :=
  assume h1: ⊩ₛ s : Q₁,
  have ∀s' Q₂, (s = s') → (⊩ₛ s' : Q₂) → (Q₁ = Q₂), by begin
    cases h1,

    intros s' Q₂ h2 h3,
    cases h3,

    injection h2,
    have h4: (R = R_1), from h_1,
    have h6: (σ = σ_1), from h_2,
    have h7: (e = e_1), from h_3,
    have h8: (P = P_1), from env.dvcgen.inj a P_1 (h6.symm ▸ a_4),
    have : ↑R ⋀ P ⊩ e : Q_1, from h4.symm ▸ h7.symm ▸ h8.symm ▸ a_7,
    have h9: (Q = Q_1), from exp.dvcgen.inj a_3 Q_1 this,
    rw[←h8],
    rw[←h9],

    contradiction,

    intros s' Q₂ h2 h3,
    cases h3,

    contradiction,

    injection h2,

    have h4: (P₁ = P₁_1), from env.dvcgen.inj a_2 P₁_1 (h_3.symm ▸ a_17),
    rw[h4.symm] at a_24,
    rw[h_4.symm] at a_24,
    rw[h_5.symm] at a_24,
    rw[h_7.symm] at a_24,
    rw[h_6.symm] at a_24,
    rw[h_2.symm] at a_24,
    have h5: (Q₁_1 = Q₁), from exp.dvcgen.inj a_9 Q₁ a_24,
    rw[←h4],
    rw[←h_5],
    rw[←h_6],
    rw[←h_4],
    rw[h5]
  end,
  show ∀Q₂, (⊩ₛ s : Q₂) → (Q₁ = Q₂),
  from λQ₂ h1, (this s Q₂) rfl h1


/-
Copyright (c) 2021-2022 by the authors listed in the file AUTHORS and their
institutional affiliations. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/

/-- The type of S-expressions. -/
inductive Sexp where
  | atom : String → Sexp
  | expr : List Sexp → Sexp
  deriving Repr, BEq, Inhabited

class ToSexp (α : Type u) where
  toSexp : α → Sexp

namespace Sexp

partial def serialize : Sexp → String
  | atom s  => s
  | expr ss => "(" ++ (" ".intercalate <| ss.map serialize) ++ ")"

def serializeMany (ss : List Sexp) : String :=
  ss.map serialize |> "\n".intercalate

instance : ToString Sexp :=
  ⟨serialize⟩

inductive ParseError where
  | /-- Incomplete input, for example missing a closing parenthesis. -/
    incomplete (msg : String)
  | /-- Malformed input, for example having too many closing parentheses. -/
    malformed (msg : String)

instance : ToString ParseError where
  toString
    | .incomplete msg => s!"incomplete input: {msg}"
    | .malformed msg  => s!"malformed input: {msg}"

/-- Tokenize `s` with the s-expression grammar. Supported token kinds are more or less as in
https://smtlib.cs.uiowa.edu/papers/smt-lib-reference-v2.6-r2021-05-12.pdf:
- parentheses `(`/`)`
- symbols `abc`
- quoted symbols `|abc|`
- string literals `"abc"` -/
partial def tokenize (s : Substring) : Except ParseError (Array Substring) :=
  go #[] s
where go (stk : Array Substring) (s : Substring) :=
  -- Note: not written using `do` notation to ensure tail-call recursion
  if s.isEmpty then .ok stk
  else
    let c := s.front
    if c == '"' || c == '|' then
      let s1 := s.drop 1 |>.takeWhile (· ≠ c)
      if s1.stopPos = s.stopPos then
        throw <| .incomplete s!"ending {c} missing after {s1}"
      else
        let s1 := ⟨s.str, s.startPos, s.next s1.stopPos⟩
        let s2 := ⟨s.str, s1.stopPos, s.stopPos⟩
        go (stk.push s1) s2
    else if c == ')' || c == '(' then
      go (stk.push <| s.take 1) (s.drop 1)
    else if c.isWhitespace then
      go stk (s.drop 1)
    else
      let tk := s.takeWhile fun c =>
        !c.isWhitespace && c != '(' && c != ')' && c != '|' && c != '"'
      -- assertion: tk.bsize > 0 as otherwise we would have gone into one of the branches above
      go (stk.push tk) (s.extract ⟨tk.bsize⟩ ⟨s.bsize⟩)

mutual
partial def parseOneAux : List Substring → Except ParseError (Sexp × List Substring)
  | tk :: tks => do
    if tk.front == ')' then
      throw <| .malformed "unexpected ')'"
    if tk.front == '(' then
      if let (ss, _tk :: tks) ← parseManyAux tks then
        -- assertion: _tk == ')' since parseManyAux only stops on ')'
        return (expr ss.toList, tks)
      else
        throw <| .incomplete "expected ')'"
    else
      return (atom tk.toString, tks)
  | [] => throw <| .incomplete "expected a token, got none"

partial def parseManyAux :=
  go #[]
where go (stk : Array Sexp) : List Substring → Except ParseError (Array Sexp × List Substring)
  | tk :: tks => do
    if tk.front == ')' then .ok (stk, tk :: tks)
    else
      let (e, tks) ← parseOneAux (tk :: tks)
      go (stk.push e) tks
  | [] => .ok (stk, [])
end

/-- Parse all the s-expressions in the given string. For example, `"(abc) (def)"` contains two. -/
def parseMany (s : String) : Except ParseError (List Sexp) := do
  let tks ← tokenize s.toSubstring
  let (sexps, tks) ← parseManyAux tks.toList
  if !tks.isEmpty then
    throw <| .malformed s!"unexpected '{tks.get! 0}'"
  return sexps.toList

/-- Parse a single s-expression. Note that the string may contain extra data, but parsing will
succeed as soon as the single s-exp is complete. -/
def parseOne (s : String) : Except ParseError Sexp := do
  let tks ← tokenize s.toSubstring
  let (sexp, _) ← parseOneAux tks.toList
  return sexp

end Sexp