import .ctypes .cop .globalenvs

/- The Clight language: a simplified version of Compcert C where all
  expressions are pure and assignments and function calls are
  statements, not expressions. -/

namespace clight
open ctypes integers ast maps floats values memory word cop globalenvs
     errors ctypes.fundef ctypes.mode

/- * Abstract syntax -/

/- ** Expressions -/

/- Clight expressions correspond to the "pure" subset of C expressions.
  The main omissions are string literals and assignment operators
  ([=], [+=], [++], etc).  In Clight, assignment is a statement,
  not an expression.  Additionally, an expression can also refer to
  temporary variables, which are a separate class of local variables
  that do not reside in memory and whose address cannot be taken.

  As in Compcert C, all expressions are annotated with their types,
  as needed to resolve operator overloading and type-dependent behaviors. -/

inductive expr : Type
| Econst_int : int32 → type → expr       /- integer literal -/
| Econst_float : float → type → expr   /- double float literal -/
| Econst_single : float32 → type → expr /- single float literal -/
| Econst_long : int64 → type → expr    /- long integer literal -/
| Evar : ident → type → expr           /- variable -/
| Etempvar : ident → type → expr       /- temporary variable -/
| Ederef : expr → type → expr          /- pointer dereference (unary [*]) -/
| Eaddrof : expr → type → expr         /- address-of operator ([&]) -/
| Eunop : unary_operation → expr → type → expr  /- unary operation -/
| Ebinop : binary_operation → expr → expr → type → expr /- binary operation -/
| Ecast : expr → type → expr   /- type cast ([(ty) e]) -/
| Efield : expr → ident → type → expr /- access to a member of a struct or union -/
| Esizeof : type → type → expr         /- size of a type -/
| Ealignof : type → type → expr        /- alignment of a type -/
open clight.expr

/- Extract the type part of a type-annotated Clight expression. -/

def typeof : expr → type
| (Econst_int _ ty)    := ty
| (Econst_float _ ty)  := ty
| (Econst_single _ ty) := ty
| (Econst_long _ ty)   := ty
| (Evar _ ty)          := ty
| (Etempvar _ ty)      := ty
| (Ederef _ ty)        := ty
| (Eaddrof _ ty)       := ty
| (Eunop _ _ ty)       := ty
| (Ebinop _ _ _ ty)    := ty
| (Ecast _ ty)         := ty
| (Efield _ _ ty)      := ty
| (Esizeof _ ty)       := ty
| (Ealignof _ ty)      := ty

/- ** Statements -/

/- Clight statements are similar to those of Compcert C, with the addition
  of assigment (of a rvalue to a lvalue), assignment to a temporary,
  and function call (with assignment of the result to a temporary).
  The three C loops are replaced by a single infinite loop [Sloop s1
  s2] that executes [s1] then [s2] repeatedly.  A [continue] in [s1]
  branches to [s2]. -/

def label := ident

inductive statement : Type
| Sskip       : statement                    /- do nothing -/
| Sassign     : expr → expr → statement      /- assignment [lvalue = rvalue] -/
| Sset        : ident → expr → statement     /- assignment [tempvar = rvalue] -/
| Scall       : option ident → expr → list expr → statement
                                             /- function call -/
| Sbuiltin    : option ident → external_function → list type → list expr → statement
                                             /- builtin invocation -/
| Ssequence   : statement → statement → statement
                                             /- sequence -/
| Sifthenelse : expr → statement → statement → statement
                                             /- conditional -/
| Sloop       : statement → statement → statement
                                             /- infinite loop -/
| Sbreak      : statement                    /- [break] statement -/
| Scontinue   : statement                    /- [continue] statement -/
| Sreturn     : option expr → statement      /- [return] statement -/
| Sswitch     : expr → list (option ℤ × statement) → statement
                                             /- [switch] statement -/
                                             /- [None] is [default], [Some x] is [case x] -/
| Slabel      : label → statement → statement
| Sgoto       : label → statement
open statement

/- The C loops are derived forms. -/

def Swhile (e : expr) (s : statement) :=
Sloop (Ssequence (Sifthenelse e Sskip Sbreak) s) Sskip

def Sdowhile (s : statement) (e : expr) :=
Sloop s (Sifthenelse e Sskip Sbreak)

def Sfor (s1 : statement) (e2 : expr) (s3 : statement) (s4 : statement) :=
Ssequence s1 (Sloop (Ssequence (Sifthenelse e2 Sskip Sbreak) s3) s4)

/- ** Functions -/

/- A function definition is composed of its return type ([fn_return]),
  the names and types of its parameters ([fn_params]), the names
  and types of its local variables ([fn_vars]), and the body of the
  function (a statement, [fn_body]). -/

structure function : Type :=
(return : type)
(callconv : calling_convention)
(params : list (ident × type))
(vars : list (ident × type))
(temps : list (ident × type))
(body : statement)

def var_names (vars : list (ident × type)) : list ident :=
list.map prod.fst vars

/- Functions can either be defined ([Internal]) or declared as
  external functions ([External]). -/

def fundef := ctypes.fundef function

/- The type of a function definition. -/

def type_of_function (f : function) : type :=
Tfunction (type_of_params f.params) f.return f.callconv

def type_of_fundef : fundef → type
| (Internal fd) := type_of_function fd
| (External id args res cc) := Tfunction args res cc

/- ** Programs -/

/- As defined in module [Ctypes], a program, or compilation unit, is
  composed of:
- a list of definitions of functions and global variables;
- the names of functions and global variables that are public (not static);
- the name of the function that acts as entry point ("main" function).
- a list of definitions for structure and union names
- the corresponding composite environment
- a proof that this environment is consistent with the definitions. -/

def program := ctypes.program function

/- * Operational semantics -/

/- The semantics uses two environments.  The global environment
  maps names of functions and global variables to memory block references,
  and function pointers to their definitions.  (See module [Globalenvs].)
  It also contains a composite environment, used by type-dependent operations. -/

structure genv :=
(genv : Genv fundef type)
(cenv : composite_env)

instance coe_genv_genv : has_coe genv (Genv fundef type) := ⟨genv.genv⟩
instance coe_genv_cenv : has_coe genv composite_env := ⟨genv.cenv⟩

def globalenv (p : program) : genv :=
{ genv := Genv.globalenv (program_of_program p),
  cenv := p.comp_env }

/- The local environment maps local variables to block references and
  types.  The current value of the variable is stored in the
  associated memory block. -/

def env := PTree (block × type). /- map variable -> location & type -/

def empty_env : env := (∅ : PTree (block × type))

/- The temporary environment maps local temporaries to values. -/

def temp_env := PTree val

/- [deref_loc ty m b ofs v] computes the value of a datum
  of type [ty] residing in memory [m] at block [b], offset [ofs].
  If the type [ty] indicates an access by value, the corresponding
  memory load is performed.  If the type [ty] indicates an access by
  reference or by copy, the pointer [Vptr b ofs] is returned. -/

inductive deref_loc (ty : type) (m : mem) (b : block) (ofs : ptrofs) : val → Prop
| deref_loc_value (chunk v) :
      access_mode ty = By_value chunk →
      loadv chunk m (Vptr b ofs) = some v →
      deref_loc v
| deref_loc_reference :
      access_mode ty = By_reference →
      deref_loc (Vptr b ofs)
| deref_loc_copy :
      access_mode ty = By_copy →
      deref_loc (Vptr b ofs)

/- Symmetrically, [assign_loc ty m b ofs v m'] returns the
  memory state after storing the value [v] in the datum
  of type [ty] residing in memory [m] at block [b], offset [ofs].
  This is allowed only if [ty] indicates an access by value or by copy.
  [m'] is the updated memory state. -/

inductive assign_loc (ce : composite_env) (ty : type) (m : mem) (b : block) (ofs : ptrofs) :
                                            val → mem → Prop
| assign_loc_value (v chunk m') :
      access_mode ty = By_value chunk →
      storev chunk m (Vptr b ofs) v = some m' →
      assign_loc v m'
| assign_loc_copy (b' ofs' bytes m') :
      access_mode ty = By_copy →
      (sizeof ce ty > 0 →
        alignof_blockcopy ce ty ∣ unsigned ofs' ∧
        alignof_blockcopy ce ty ∣ unsigned ofs) →
      b' ≠ b ∨ unsigned ofs' = unsigned ofs
              ∨ unsigned ofs' + sizeof ce ty ≤ unsigned ofs
              ∨ unsigned ofs + sizeof ce ty ≤ unsigned ofs' →
      load_bytes m b' (unsigned ofs') (sizeof ce ty) = some bytes →
      store_bytes m b (unsigned ofs) bytes = some m' →
      assign_loc (Vptr b' ofs') m'

section semantics

parameter (ge : genv)

/- Allocation of function-local variables.
  [alloc_variables e1 m1 vars e2 m2] allocates one memory block
  for each variable declared in [vars], and associates the variable
  name with this block.  [e1] and [m1] are the initial local environment
  and memory state.  [e2] and [m2] are the final local environment
  and memory state. -/

inductive alloc_variables : env → mem → list (ident × type) → env → mem → Prop
| nil (e m) : alloc_variables e m [] e m
| cons (e) (m : mem) (id ty vars m2 e2) :
      alloc_variables (PTree.set id (m.nextblock, ty) e)
        (m.alloc 0 (sizeof ge ty)) vars e2 m2 →
      alloc_variables e m ((id, ty) :: vars) e2 m2

/- Initialization of local variables that are parameters to a function.
  [bind_parameters e m1 params args m2] stores the values [args]
  in the memory blocks corresponding to the variables [params].
  [m1] is the initial memory state and [m2] the final memory state. -/

inductive bind_parameters (e : env) : mem → list (ident × type) → list val → mem → Prop
| nil (m) : bind_parameters m [] [] m
| cons (m id ty params v1 vl b m1 m2) :
      PTree.get id e = some (b, ty) →
      assign_loc ge ty m b 0 v1 m1 →
      bind_parameters m1 params vl m2 →
      bind_parameters m ((id, ty) :: params) (v1 :: vl) m2

/- Initialization of temporary variables -/

def create_undef_temps : list (ident × type) → temp_env
| [] := (∅ : PTree val)
| ((id, t) :: temps') := PTree.set id Vundef (create_undef_temps temps')

/- Initialization of temporary variables that are parameters to a function. -/

def bind_parameter_temps : list (ident × type) → list val → temp_env → option temp_env
 | []              []        le := some le
 | ((id, t) :: xl) (v :: vl) le := bind_parameter_temps xl vl (PTree.set id v le)
 | _               _         _  := none

/- Return the list of blocks in the codomain of [e], with low and high bounds. -/

def block_of_binding : ident × block × type → block × ℕ × ℕ
| (id, b, ty) := (b, 0, sizeof ge ty)

def blocks_of_env (e : env) : list (block × ℕ × ℕ) :=
(PTree.elements e).map block_of_binding

/- Optional assignment to a temporary -/

def set_opttemp : option ident → val → temp_env → temp_env
| none      v le := le
| (some id) v le := PTree.set id v le

/- Selection of the appropriate case of a [switch], given the value [n]
  of the selector expression. -/

def labeled_statements := list (option ℤ × statement)

def select_switch_default : labeled_statements → labeled_statements
| [] := []
| ((none, s) :: sl')   := ((none, s) :: sl')
| ((some i, s) :: sl') := select_switch_default sl'

def select_switch_case (n : ℤ) : labeled_statements → option labeled_statements
| []                   := none
| ((none, s) :: sl')   := select_switch_case sl'
| ((some i, s) :: sl') := if i = n then some ((some i, s) :: sl') else select_switch_case sl'

def select_switch (n : ℤ) (sl : labeled_statements) : labeled_statements :=
(select_switch_case n sl).get_or_else (select_switch_default sl)

/- Turn a labeled statement into a sequence -/

def seq_of_labeled_statement : labeled_statements → statement
| [] := Sskip
| ((_, s) :: sl') := Ssequence s (seq_of_labeled_statement sl')

/- ** Evaluation of expressions -/

section expr

parameters (e : env) (le : temp_env) (m : mem)

/- [eval_expr ge e m a v] defines the evaluation of expression [a]
  in r-value position.  [v] is the value of the expression.
  [e] is the current environment and [m] is the current memory state. -/

mutual inductive eval_expr, eval_lvalue
with eval_expr : expr → val → Prop
| eval_Econst_int (i ty)    : eval_expr (Econst_int i ty) (Vint i)
| eval_Econst_float (f ty)  : eval_expr (Econst_float f ty) (Vfloat f)
| eval_Econst_single (f ty) : eval_expr (Econst_single f ty) (Vsingle f)
| eval_Econst_long (i ty)   : eval_expr (Econst_long i ty) (Vlong i)
| eval_Etempvar (id ty v)   :
      (le^!id) = some v →
      eval_expr (Etempvar id ty) v
| eval_Eaddrof (a ty loc ofs) :
      eval_lvalue a loc ofs →
      eval_expr (Eaddrof a ty) (Vptr loc ofs)
| eval_Eunop (op a ty v1 v) :
      eval_expr a v1 →
      sem_unary_operation op m v1 (typeof a) = some v →
      eval_expr (Eunop op a ty) v
| eval_Ebinop (op a1 a2 ty v1 v2 v) :
      eval_expr a1 v1 →
      eval_expr a2 v2 →
      sem_binary_operation ge op m v1 (typeof a1) v2 (typeof a2) = some v →
      eval_expr (Ebinop op a1 a2 ty) v
| eval_Ecast (a ty v1 v) :
      eval_expr a v1 →
      sem_cast m v1 (typeof a) ty = some v →
      eval_expr (Ecast a ty) v
| eval_Esizeof (ty1 ty) :
      eval_expr (Esizeof ty1 ty) (Vptrofs (repr (sizeof ge ty1)))
| eval_Ealignof (ty1 ty) :
      eval_expr (Ealignof ty1 ty) (Vptrofs (repr (alignof ge ty1)))
| eval_Elvalue (a loc ofs v) :
      eval_lvalue a loc ofs →
      deref_loc (typeof a) m loc ofs v →
      eval_expr a v

/- [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a]
  in l-value position.  The result is the memory location [b, ofs]
  that contains the value of the expression [a]. -/

with eval_lvalue : expr → block → ptrofs → Prop
| eval_Evar_local (id l ty) :
      (e^!id) = some (l, ty) →
      eval_lvalue (Evar id ty) l 0
| eval_Evar_global (id l ty) :
      (e^!id) = none →
      Genv.find_symbol ge.genv id = some l →
      eval_lvalue (Evar id ty) l 0
| eval_Ederef (a ty l ofs) :
      eval_expr a (Vptr l ofs) →
      eval_lvalue (Ederef a ty) l ofs
 | eval_Efield_struct (a i ty l ofs id co att delta) :
      eval_expr a (Vptr l ofs) →
      typeof a = Tstruct id att →
      (ge.cenv^!id) = some co →
      field_offset ge i co.co_members = OK delta →
      eval_lvalue (Efield a i ty) l (ofs + repr delta)
 | eval_Efield_union (a i ty l ofs id co att) :
      eval_expr a (Vptr l ofs) →
      typeof a = Tunion id att →
      (ge.cenv^!id) = some co →
      eval_lvalue (Efield a i ty) l ofs

/- [eval_exprlist ge e m al tyl vl] evaluates a list of r-value
  expressions [al], cast their values to the types given in [tyl],
  and produces the list of cast values [vl].  It is used to
  evaluate the arguments of function calls. -/

inductive eval_exprlist : list expr → list type → list val → Prop
| nil : eval_exprlist [] [] []
| cons (a bl ty tyl v1 v2 vl) :
      eval_expr a v1 →
      sem_cast m v1 (typeof a) ty = some v2 →
      eval_exprlist bl tyl vl →
      eval_exprlist (a :: bl) (ty :: tyl) (v2 :: vl)

end expr

/- ** Transition semantics for statements and functions -/

/- Continuations -/

inductive cont : Type
| Kstop : cont
| Kseq : statement → cont → cont       /- [Kseq s2 k] = after [s1] in [s1;s2] -/
| Kloop1 : statement → statement → cont → cont /- [Kloop1 s1 s2 k] = after [s1] in [Sloop s1 s2] -/
| Kloop2 : statement → statement → cont → cont /- [Kloop1 s1 s2 k] = after [s2] in [Sloop s1 s2] -/
| Kswitch : cont → cont       /- catches [break] statements arising out of [switch] -/
| Kcall : option ident →                  /- where to store result -/
          function →                      /- calling function -/
          env →                           /- local env of calling function -/
          temp_env →                      /- temporary env of calling function -/
          cont → cont
open cont

/- Pop continuation until a call or stop -/

def call_cont : cont → cont
| (Kseq s k)       := call_cont k
| (Kloop1 s1 s2 k) := call_cont k
| (Kloop2 s1 s2 k) := call_cont k
| (Kswitch k)      := call_cont k
| k                := k

def is_call_cont : cont → bool
| Kstop             := tt
| (Kcall _ _ _ _ _) := tt
| _                 := ff

/- States -/

inductive state : Type
| State
      (f : function)
      (s : statement)
      (k : cont)
      (e : env)
      (le : temp_env)
      (m : mem)
| Callstate
      (fd : fundef)
      (args : list val)
      (k : cont)
      (m : mem)
| Returnstate
      (res : val)
      (k : cont)
      (m : mem)

/- Find the statement and manufacture the continuation
  corresponding to a label -/

mutual def find_label, find_label_ls (lbl : label)
with find_label : statement → cont → option (statement × cont)
| (Ssequence s1 s2)     := λk, find_label s1 (Kseq s2 k) <|> find_label s2 k
| (Sifthenelse a s1 s2) := λk, find_label s1 k <|> find_label s2 k
| (Sloop s1 s2)         := λk, find_label s1 (Kloop1 s1 s2 k) <|> find_label s2 (Kloop2 s1 s2 k)
| (Sswitch e sl)        := λk, find_label_ls sl (Kswitch k)
| (Slabel lbl' s')      := λk, if lbl = lbl' then some (s', k) else find_label s' k
| _                     := λk, none
with find_label_ls : list (option ℤ × statement) → cont → option (statement × cont)
| []                    := λk, none
| ((_, s) :: sl')       := λk, find_label s (Kseq (seq_of_labeled_statement sl') k) <|> find_label_ls sl' k

#exit
/- Semantics for allocation of variables and binding of parameters at
  function entry.  Two semantics are supported: one where
  parameters are local variables, reside in memory, and can have their address
  taken; the other where parameters are temporary variables and do not reside
  in memory.  We parameterize the [step] transition relation over the
  parameter binding semantics, then instantiate it later to give the two
  semantics described above. -/

parameter function_entry : function → list val → mem → env → temp_env → mem → Prop

/- Transition relation -/

inductive step : state → trace → state → Prop :=

| step_assign :   ∀ f a1 a2 k e le m loc ofs v2 v m',
      eval_lvalue e le m a1 loc ofs →
      eval_expr e le m a2 v2 →
      sem_cast v2 (typeof a2) (typeof a1) m = some v →
      assign_loc ge (typeof a1) m loc ofs v m' →
      step (State f (Sassign a1 a2) k e le m)
        E0 (State f Sskip k e le m')

| step_set :   ∀ f id a k e le m v,
      eval_expr e le m a v →
      step (State f (Sset id a) k e le m)
        E0 (State f Sskip k e (PTree.set id v le) m)

| step_call :   ∀ f optid a al k e le m tyargs tyres cconv vf vargs fd,
      classify_fun (typeof a) = fun_case_f tyargs tyres cconv →
      eval_expr e le m a vf →
      eval_exprlist e le m al tyargs vargs →
      Genv.find_funct ge vf = some fd →
      type_of_fundef fd = Tfunction tyargs tyres cconv →
      step (State f (Scall optid a al) k e le m)
        E0 (Callstate fd vargs (Kcall optid f e le k) m)

| step_builtin :   ∀ f optid ef tyargs al k e le m vargs t vres m',
      eval_exprlist e le m al tyargs vargs →
      external_call ef ge vargs m t vres m' →
      step (State f (Sbuiltin optid ef tyargs al) k e le m)
         t (State f Sskip k e (set_opttemp optid vres le) m')

| step_seq :  ∀ f s1 s2 k e le m,
      step (State f (Ssequence s1 s2) k e le m)
        E0 (State f s1 (Kseq s2 k) e le m)
| step_skip_seq : ∀ f s k e le m,
      step (State f Sskip (Kseq s k) e le m)
        E0 (State f s k e le m)
| step_continue_seq : ∀ f s k e le m,
      step (State f Scontinue (Kseq s k) e le m)
        E0 (State f Scontinue k e le m)
| step_break_seq : ∀ f s k e le m,
      step (State f Sbreak (Kseq s k) e le m)
        E0 (State f Sbreak k e le m)

| step_ifthenelse :  ∀ f a s1 s2 k e le m v1 b,
      eval_expr e le m a v1 →
      bool_val v1 (typeof a) m = some b →
      step (State f (Sifthenelse a s1 s2) k e le m)
        E0 (State f (if b then s1 else s2) k e le m)

| step_loop : ∀ f s1 s2 k e le m,
      step (State f (Sloop s1 s2) k e le m)
        E0 (State f s1 (Kloop1 s1 s2 k) e le m)
| step_skip_or_continue_loop1 :  ∀ f s1 s2 k e le m x,
      x = Sskip ∨ x = Scontinue →
      step (State f x (Kloop1 s1 s2 k) e le m)
        E0 (State f s2 (Kloop2 s1 s2 k) e le m)
| step_break_loop1 :  ∀ f s1 s2 k e le m,
      step (State f Sbreak (Kloop1 s1 s2 k) e le m)
        E0 (State f Sskip k e le m)
| step_skip_loop2 : ∀ f s1 s2 k e le m,
      step (State f Sskip (Kloop2 s1 s2 k) e le m)
        E0 (State f (Sloop s1 s2) k e le m)
| step_break_loop2 : ∀ f s1 s2 k e le m,
      step (State f Sbreak (Kloop2 s1 s2 k) e le m)
        E0 (State f Sskip k e le m)

| step_return_0 : ∀ f k e le m m',
      Mem.free_list m (blocks_of_env e) = some m' →
      step (State f (Sreturn none) k e le m)
        E0 (Returnstate Vundef (call_cont k) m')
| step_return_1 : ∀ f a k e le m v v' m',
      eval_expr e le m a v →
      sem_cast v (typeof a) f.(fn_return) m = some v' →
      Mem.free_list m (blocks_of_env e) = some m' →
      step (State f (Sreturn (some a)) k e le m)
        E0 (Returnstate v' (call_cont k) m')
| step_skip_call : ∀ f k e le m m',
      is_call_cont k →
      Mem.free_list m (blocks_of_env e) = some m' →
      step (State f Sskip k e le m)
        E0 (Returnstate Vundef k m')

| step_switch : ∀ f a sl k e le m v n,
      eval_expr e le m a v →
      sem_switch_arg v (typeof a) = some n →
      step (State f (Sswitch a sl) k e le m)
        E0 (State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch k) e le m)
| step_skip_break_switch : ∀ f x k e le m,
      x = Sskip ∨ x = Sbreak →
      step (State f x (Kswitch k) e le m)
        E0 (State f Sskip k e le m)
| step_continue_switch : ∀ f k e le m,
      step (State f Scontinue (Kswitch k) e le m)
        E0 (State f Scontinue k e le m)

| step_label : ∀ f lbl s k e le m,
      step (State f (Slabel lbl s) k e le m)
        E0 (State f s k e le m)

| step_goto : ∀ f lbl k e le m s' k',
      find_label lbl f.(fn_body) (call_cont k) = some (s', k') →
      step (State f (Sgoto lbl) k e le m)
        E0 (State f s' k' e le m)

| step_internal_function : ∀ f vargs k m e le m1,
      function_entry f vargs m e le m1 →
      step (Callstate (Internal f) vargs k m)
        E0 (State f f.(fn_body) k e le m1)

| step_external_function : ∀ ef targs tres cconv vargs k m vres t m',
      external_call ef ge vargs m t vres m' →
      step (Callstate (External ef targs tres cconv) vargs k m)
         t (Returnstate vres k m')

| step_returnstate : ∀ v optid f e le k m,
      step (Returnstate v (Kcall optid f e le k) m)
        E0 (State f Sskip k e (set_opttemp optid v le) m)

/- ** Whole-program semantics -/

/- Execution of whole programs are described as sequences of transitions
  from an initial state to a final state.  An initial state is a [Callstate]
  corresponding to the invocation of the ``main'' function of the program
  without arguments and with an empty continuation. -/

inductive initial_state (p : program) : state → Prop :=
| initial_state_intro : ∀ b f m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = some m0 →
      Genv.find_symbol ge p.(prog_main) = some b →
      Genv.find_funct_ptr ge b = some f →
      type_of_fundef f = Tfunction Tnil type_int32s cc_default →
      initial_state p (Callstate f nil Kstop m0)

/- A final state is a [Returnstate] with an empty continuation. -/

inductive final_state : state → int32 → Prop :=
| final_state_intro : ∀ r m,
      final_state (Returnstate (Vint r) Kstop m) r

end SEMANTICS

/- The two semantics for function parameters.  First, parameters as local variables. -/

inductive function_entry1 (ge : genv) (f : function) (vargs : list val) (m : mem) (e : env) (le : temp_env) (m' : mem) : Prop :=
| function_entry1_intro : ∀ m1,
      list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) →
      alloc_variables ge empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 →
      bind_parameters ge e m1 f.(fn_params) vargs m' →
      le = create_undef_temps f.(fn_temps) →
      function_entry1 ge f vargs m e le m'

def step1 (ge : genv) := step ge (function_entry1 ge)

/- Second, parameters as temporaries. -/

inductive function_entry2 (ge : genv)  (f : function) (vargs : list val) (m : mem) (e : env) (le : temp_env) (m' : mem) : Prop :=
| function_entry2_intro :
      list_norepet (var_names f.(fn_vars)) →
      list_norepet (var_names f.(fn_params)) →
      list_disjoint (var_names f.(fn_params)) (var_names f.(fn_temps)) →
      alloc_variables ge empty_env m f.(fn_vars) e m' →
      bind_parameter_temps f.(fn_params) vargs (create_undef_temps f.(fn_temps)) = some le →
      function_entry2 ge f vargs m e le m'

def step2 (ge : genv) := step ge (function_entry2 ge)

/- Wrapping up these definitions in two small-step semantics. -/

def semantics1 (p : program) :=
  let ge := globalenv p in
  Semantics_gen step1 (initial_state p) final_state ge ge

def semantics2 (p : program) :=
  let ge := globalenv p in
  Semantics_gen step2 (initial_state p) final_state ge ge

/- This semantics is receptive to changes in events. -/

lemma semantics_receptive :
  ∀ (p : program), receptive (semantics1 p)
Proof
  intros. unfold semantics1
  set (ge := globalenv p). constructor; simpl; intros
/- receptiveness -/
  assert (t1 = E0 → ∃ s2, step1 ge s t2 s2)
    intros. subst. inv H0. ∃ s1; auto
  inversion H; subst; auto
  /- builtin -/
  exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]
  econstructor; econstructor; eauto
  /- external -/
  exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]
  ∃ (Returnstate vres2 k m2). econstructor; eauto
/- trace length -/
  red; simpl; intros. inv H; simpl; try omega
  eapply external_call_trace_length; eauto
  eapply external_call_trace_length; eauto
Qed.


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro

! This file was ported from Lean 3 source module tactic.chain
! leanprover-community/mathlib commit a8629a591ccfe7aa27241e843ca13ed7ed7fd152
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Ext

open Interactive

namespace Tactic

/-
This file defines a `chain` tactic, which takes a list of tactics,
and exhaustively tries to apply them to the goals, until no tactic succeeds on any goal.

Along the way, it generates auxiliary declarations, in order to speed up elaboration time
of the resulting (sometimes long!) proofs.

This tactic is used by the `tidy` tactic.
-/
-- α is the return type of our tactics. When `chain` is called by `tidy`, this is string,
-- describing what that tactic did as an interactive tactic.
variable {α : Type}

inductive TacticScript (α : Type) : Type
  | base : α → tactic_script
  | work (index : ℕ) (first : α) (later : List tactic_script) (closed : Bool) : tactic_script
#align tactic.tactic_script Tactic.TacticScript

unsafe def tactic_script.to_string : TacticScript String → String
  | tactic_script.base a => a
  | tactic_script.work n a l c =>
    "work_on_goal " ++ toString (n + 1) ++ " { " ++
        ", ".intercalate (a :: l.map tactic_script.to_string) ++
      " }"
#align tactic.tactic_script.to_string tactic.tactic_script.to_string

unsafe instance : ToString (TacticScript String) where toString s := s.toString

unsafe instance tactic_script_unit_has_to_string : ToString (TacticScript Unit)
    where toString s := "[chain tactic]"
#align tactic.tactic_script_unit_has_to_string tactic.tactic_script_unit_has_to_string

unsafe def abstract_if_success (tac : expr → tactic α) (g : expr) : tactic α := do
  let type ← infer_type g
  let is_lemma ← is_prop type
  if is_lemma then
      -- there's no point making the abstraction, and indeed it's slower
        tac
        g
    else do
      let m ← mk_meta_var type
      let a ← tac m
      (do
            let val ← instantiate_mvars m
            guard (val = [])
            let c ← new_aux_decl_name
            let gs ← get_goals
            set_goals [g]
            add_aux_decl c type val ff >>= unify g
            set_goals gs) <|>
          unify m g
      return a
#align tactic.abstract_if_success tactic.abstract_if_success

mutual
  /--
  `chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
  until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
  -/
  unsafe def chain_single {α} (tac : tactic α) : expr → tactic (α × List (TacticScript α))
    | g => do
      set_goals [g]
      let a ← tac
      let l ← get_goals >>= chain_many
      return (a, l)
  /--
  `chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
  until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
  -/
  unsafe def chain_many {α} (tac : tactic α) : List expr → tactic (List (TacticScript α))
    | [] => return []
    | [g] =>
      (do
          let (a, l) ← chain_single g
          return (tactic_script.base a :: l)) <|>
        return []
    | gs => chain_iter gs []
  /--
  `chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
  until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
  -/
  unsafe def chain_iter {α} (tac : tactic α) :
      List expr → List expr → tactic (List (TacticScript α))
    | [], _ => return []
    | g :: later_goals, stuck_goals =>
      (-- we keep the goals up to date, so they are correct at the end
        do
          let (a, l) ← abstract_if_success chain_single g
          let new_goals ← get_goals
          let w := TacticScript.work stuck_goals.length a l (new_goals = [])
          let current_goals := stuck_goals.reverse ++ new_goals ++ later_goals
          set_goals current_goals
          let l' ← chain_many current_goals
          return (w :: l')) <|>
        chain_iter later_goals (g :: stuck_goals)
end
#align tactic.chain_single tactic.chain_single
#align tactic.chain_many tactic.chain_many
#align tactic.chain_iter tactic.chain_iter

unsafe def chain_core {α : Type} [ToString (TacticScript α)] (tactics : List (tactic α)) :
    tactic (List String) := do
  let results ← get_goals >>= chain_many (first tactics)
  when results (fail "`chain` tactic made no progress")
  return (results toString)
#align tactic.chain_core tactic.chain_core

variable [ToString (TacticScript α)] [has_to_format α]

initialize
  registerTraceClass.1 `chain

unsafe def trace_output (t : tactic α) : tactic α := do
  let tgt ← target
  let r ← t
  let name ← decl_name
  trace f! "`chain` successfully applied a tactic during elaboration of {Name}:"
  let tgt ← pp tgt
  trace f! "previous target: {tgt}"
  trace f! "tactic result: {r}"
  let tgt ← try_core target
  let tgt ←
    match tgt with
      | some tgt => pp tgt
      | none => return "no goals"
  trace f! "new target: {tgt}"
  pure r
#align tactic.trace_output tactic.trace_output

unsafe def chain (tactics : List (tactic α)) : tactic (List String) :=
  chain_core (if is_trace_enabled_for `chain then tactics.map trace_output else tactics)
#align tactic.chain tactic.chain

end Tactic


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

import history

universe u

open objects interpret

/- For class C we have a state space Σ(C) consisting of a this identity and an assignment of fields to values. -/
@[derive decidable_eq]
structure state_space {α β : Type} [objects α β]
    (self : class_name α) :=
  (map (f : field_name self) : value (field_type f))
  (this : value (type.ref self))
  (N : value.not_null this)
def state_space.id {α β : Type} [objects α β]
    {self : class_name α} (σ : state_space self) : β :=
  value.the_object σ.N
lemma state_space.class_of_id {α β : Type} [objects α β]
  {self : class_name α} (σ : state_space self) :
  class_of α σ.id = self :=
begin
  unfold state_space.id, apply value.class_of_the_object
end
/- A state space can be updated. -/
def state_space.update {α β : Type} [objects α β]
    {C : class_name α} (f : field_name C)
    (v : value (field_type f)) : state_space C → state_space C
| ⟨map, this, N⟩ := ⟨λg, if H : f = g
    then cast begin rewrite H end v else map g,this,N⟩
/- A state space can be updated, given a field variable in a typing environment related to the same class. -/
def state_space.updatev {α β : Type} [objects α β]
    {C : class_name α} {e : tenv C} {ty : type α}
    (fvar : fvar e ty) (v : value ty)
    (σ : state_space C) : state_space C :=
  σ.update fvar.idx (cast begin rewrite fvar.H end v)
notation Σ(C) := state_space C

/- An active process consists of: a value list (of the arguments of the current method), a value list (of the local variables), and a list of statements. -/
@[derive decidable_eq]
structure active_process {α β : Type} [objects α β]
    (C : class_name α) :=
  (e : tenv C)
  (args : vallist e.args) (store : vallist e.locals)
  (body : list (statement e))
/- Given a state and active process, we can lookup the value of a read variable. -/
def active_process.lookup {α β : Type} [objects α β]
    {C : class_name α}
    (σ : Σ(C)) (π : active_process C)
    {tx : type α} : rvar π.e tx → value tx
| (rvar.tvar t) := cast begin rewrite t.H end σ.this
| (rvar.fvar f) := cast begin rewrite f.H end $ σ.map f.idx
| (rvar.pvar p) := π.args.lookup p.idx
| (rvar.lvar l) := π.store.lookup l.idx

/- A process is either nil or an active process. -/
@[derive decidable_eq]
inductive process {α β : Type} [objects α β] (C : class_name α)
| nil : process
| active (a : active_process C) : process

/- Evaluating a pure expression to a list of values. -/
def eval {α β : Type} [interpret α β]
    {C : class_name α}
    (σ : Σ(C)) (π : active_process C) :
    Π {l : list (type α)}, pexp π.e l → vallist l
| _ (pexp.const .(π.e) sym) := vallist.single $
    (interp sym) vallist.nil
| _ (pexp.app f r) := vallist.single $
    (interp f) (eval r)
| _ (pexp.lookup r) := vallist.single (π.lookup σ r)
| _ (pexp.equal l r) := vallist.single $ value.term $
    cast data_type_booleanr $ to_bool (eval l = eval r)
| _ (pexp.cons h t) := vallist.consl (eval h) (eval t)

/- Given a method and arguments, we can activate a process. -/
def process.activate {α β : Type} [objects α β]
    (p : program α) (c : class_name α) (m : method_name c)
    (τ : vallist (param_types m)) : process c :=
  process.active ⟨(p.body m).tenv,τ,default _,(p.body m).S⟩

def process.schedule {α β : Type} [interpret α β]
    (pr : program α) {θ : global_history α β}
    {C : class_name α} (σ : Σ(C)) (d : callsite α β)
    (H : global_history.sched θ (state_space.id σ) = some d)
    : process C :=
  callsite.elim d (λc o m τ g,
    let p := process.activate pr c m τ,
      G : process c = process C := begin
        have F : state_space.id σ = o.val,
          apply eq.symm,
          apply global_history.sched_object θ (σ.id) ⟨o,m,τ⟩,
          rw ← g, apply H,
        rewrite o.property,
        rewrite ← F,
        rewrite state_space.class_of_id
      end
    in cast G p)


/-
Copyright (c) 2017 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.basic
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

namespace option

theorem coe_def {α : Type u_1} : coe = some :=
  rfl

theorem some_ne_none {α : Type u_1} (x : α) : some x ≠ none :=
  fun (h : some x = none) => option.no_confusion h

@[simp] theorem get_mem {α : Type u_1} {o : Option α} (h : ↥(is_some o)) : get h ∈ o :=
  option.cases_on o
    (fun (h : ↥(is_some none)) => eq.dcases_on h (fun (a : tt = false) => bool.no_confusion a) (Eq.refl tt) (HEq.refl h))
    (fun (o : α) (h : ↥(is_some (some o))) => idRhs (some o = some o) rfl) h

theorem get_of_mem {α : Type u_1} {a : α} {o : Option α} (h : ↥(is_some o)) : a ∈ o → get h = a := sorry

@[simp] theorem not_mem_none {α : Type u_1} (a : α) : ¬a ∈ none :=
  fun (h : a ∈ none) => option.no_confusion h

@[simp] theorem some_get {α : Type u_1} {x : Option α} (h : ↥(is_some x)) : some (get h) = x :=
  option.cases_on x
    (fun (h : ↥(is_some none)) => eq.dcases_on h (fun (a : tt = false) => bool.no_confusion a) (Eq.refl tt) (HEq.refl h))
    (fun (x : α) (h : ↥(is_some (some x))) => idRhs (some (get h) = some (get h)) rfl) h

@[simp] theorem get_some {α : Type u_1} (x : α) (h : ↥(is_some (some x))) : get h = x :=
  rfl

@[simp] theorem get_or_else_some {α : Type u_1} (x : α) (y : α) : get_or_else (some x) y = x :=
  rfl

@[simp] theorem get_or_else_coe {α : Type u_1} (x : α) (y : α) : get_or_else (↑x) y = x :=
  rfl

theorem get_or_else_of_ne_none {α : Type u_1} {x : Option α} (hx : x ≠ none) (y : α) : some (get_or_else x y) = x := sorry

theorem mem_unique {α : Type u_1} {o : Option α} {a : α} {b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
  some.inj (Eq.trans (Eq.symm ha) hb)

theorem some_injective (α : Type u_1) : function.injective some :=
  fun (_x _x_1 : α) => iff.mp some_inj

/-- `option.map f` is injective if `f` is injective. -/
theorem map_injective {α : Type u_1} {β : Type u_2} {f : α → β} (Hf : function.injective f) : function.injective (option.map f) := sorry

theorem ext {α : Type u_1} {o₁ : Option α} {o₂ : Option α} : (∀ (a : α), a ∈ o₁ ↔ a ∈ o₂) → o₁ = o₂ := sorry

theorem eq_none_iff_forall_not_mem {α : Type u_1} {o : Option α} : o = none ↔ ∀ (a : α), ¬a ∈ o := sorry

@[simp] theorem none_bind {α : Type u_1} {β : Type u_1} (f : α → Option β) : none >>= f = none :=
  rfl

@[simp] theorem some_bind {α : Type u_1} {β : Type u_1} (a : α) (f : α → Option β) : some a >>= f = f a :=
  rfl

@[simp] theorem none_bind' {α : Type u_1} {β : Type u_2} (f : α → Option β) : option.bind none f = none :=
  rfl

@[simp] theorem some_bind' {α : Type u_1} {β : Type u_2} (a : α) (f : α → Option β) : option.bind (some a) f = f a :=
  rfl

@[simp] theorem bind_some {α : Type u_1} (x : Option α) : x >>= some = x :=
  bind_pure

@[simp] theorem bind_eq_some {α : Type u_1} {β : Type u_1} {x : Option α} {f : α → Option β} {b : β} : x >>= f = some b ↔ ∃ (a : α), x = some a ∧ f a = some b := sorry

@[simp] theorem bind_eq_some' {α : Type u_1} {β : Type u_2} {x : Option α} {f : α → Option β} {b : β} : option.bind x f = some b ↔ ∃ (a : α), x = some a ∧ f a = some b := sorry

@[simp] theorem bind_eq_none' {α : Type u_1} {β : Type u_2} {o : Option α} {f : α → Option β} : option.bind o f = none ↔ ∀ (b : β) (a : α), a ∈ o → ¬b ∈ f a := sorry

@[simp] theorem bind_eq_none {α : Type u_1} {β : Type u_1} {o : Option α} {f : α → Option β} : o >>= f = none ↔ ∀ (b : β) (a : α), a ∈ o → ¬b ∈ f a :=
  bind_eq_none'

theorem bind_comm {α : Type u_1} {β : Type u_2} {γ : Type u_3} {f : α → β → Option γ} (a : Option α) (b : Option β) : (option.bind a fun (x : α) => option.bind b (f x)) = option.bind b fun (y : β) => option.bind a fun (x : α) => f x y := sorry

theorem bind_assoc {α : Type u_1} {β : Type u_2} {γ : Type u_3} (x : Option α) (f : α → Option β) (g : β → Option γ) : option.bind (option.bind x f) g = option.bind x fun (y : α) => option.bind (f y) g :=
  option.cases_on x (Eq.refl (option.bind (option.bind none f) g))
    fun (x : α) => Eq.refl (option.bind (option.bind (some x) f) g)

theorem join_eq_some {α : Type u_1} {x : Option (Option α)} {a : α} : join x = some a ↔ x = some (some a) := sorry

theorem join_ne_none {α : Type u_1} {x : Option (Option α)} : join x ≠ none ↔ ∃ (z : α), x = some (some z) := sorry

theorem join_ne_none' {α : Type u_1} {x : Option (Option α)} : ¬join x = none ↔ ∃ (z : α), x = some (some z) := sorry

theorem bind_id_eq_join {α : Type u_1} {x : Option (Option α)} : x >>= id = join x := sorry

theorem join_eq_join {α : Type u_1} : mjoin = join := sorry

theorem bind_eq_bind {α : Type u_1} {β : Type u_1} {f : α → Option β} {x : Option α} : x >>= f = option.bind x f :=
  rfl

@[simp] theorem map_eq_map {α : Type u_1} {β : Type u_1} {f : α → β} : Functor.map f = option.map f :=
  rfl

theorem map_none {α : Type u_1} {β : Type u_1} {f : α → β} : f <$> none = none :=
  rfl

theorem map_some {α : Type u_1} {β : Type u_1} {a : α} {f : α → β} : f <$> some a = some (f a) :=
  rfl

@[simp] theorem map_none' {α : Type u_1} {β : Type u_2} {f : α → β} : option.map f none = none :=
  rfl

@[simp] theorem map_some' {α : Type u_1} {β : Type u_2} {a : α} {f : α → β} : option.map f (some a) = some (f a) :=
  rfl

theorem map_eq_some {α : Type u_1} {β : Type u_1} {x : Option α} {f : α → β} {b : β} : f <$> x = some b ↔ ∃ (a : α), x = some a ∧ f a = b := sorry

@[simp] theorem map_eq_some' {α : Type u_1} {β : Type u_2} {x : Option α} {f : α → β} {b : β} : option.map f x = some b ↔ ∃ (a : α), x = some a ∧ f a = b := sorry

theorem map_eq_none {α : Type u_1} {β : Type u_1} {x : Option α} {f : α → β} : f <$> x = none ↔ x = none := sorry

@[simp] theorem map_eq_none' {α : Type u_1} {β : Type u_2} {x : Option α} {f : α → β} : option.map f x = none ↔ x = none := sorry

theorem map_congr {α : Type u_1} {β : Type u_2} {f : α → β} {g : α → β} {x : Option α} (h : ∀ (a : α), a ∈ x → f a = g a) : option.map f x = option.map g x := sorry

@[simp] theorem map_id' {α : Type u_1} : option.map id = id :=
  map_id

@[simp] theorem map_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} (h : β → γ) (g : α → β) (x : Option α) : option.map h (option.map g x) = option.map (h ∘ g) x := sorry

theorem comp_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} (h : β → γ) (g : α → β) (x : Option α) : option.map (h ∘ g) x = option.map h (option.map g x) :=
  Eq.symm (map_map h g x)

@[simp] theorem map_comp_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β) (g : β → γ) : option.map g ∘ option.map f = option.map (g ∘ f) := sorry

theorem mem_map_of_mem {α : Type u_1} {β : Type u_2} {a : α} {x : Option α} (g : α → β) (h : a ∈ x) : g a ∈ option.map g x :=
  iff.mpr mem_def (Eq.symm (iff.mp mem_def h) ▸ map_some')

theorem bind_map_comm {α : Type u_1} {β : Type u_1} {x : Option (Option α)} {f : α → β} : x >>= option.map f = option.map (option.map f) x >>= id := sorry

theorem join_map_eq_map_join {α : Type u_1} {β : Type u_2} {f : α → β} {x : Option (Option α)} : join (option.map (option.map f) x) = option.map f (join x) := sorry

theorem join_join {α : Type u_1} {x : Option (Option (Option α))} : join (join x) = join (option.map join x) := sorry

theorem mem_of_mem_join {α : Type u_1} {a : α} {x : Option (Option α)} (h : a ∈ join x) : some a ∈ x :=
  iff.mpr mem_def (Eq.symm (iff.mp mem_def h) ▸ iff.mp join_eq_some h)

@[simp] theorem pbind_eq_bind {α : Type u_1} {β : Type u_2} (f : α → Option β) (x : Option α) : (pbind x fun (a : α) (_x : a ∈ x) => f a) = option.bind x f := sorry

theorem map_bind {α : Type u_1} {β : Type u_1} {γ : Type u_1} (f : β → γ) (x : Option α) (g : α → Option β) : option.map f (x >>= g) =
  do
    let a ← x
    option.map f (g a) := sorry

theorem map_bind' {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : β → γ) (x : Option α) (g : α → Option β) : option.map f (option.bind x g) = option.bind x fun (a : α) => option.map f (g a) := sorry

theorem map_pbind {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : β → γ) (x : Option α) (g : (a : α) → a ∈ x → Option β) : option.map f (pbind x g) = pbind x fun (a : α) (H : a ∈ x) => option.map f (g a H) := sorry

theorem pbind_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β) (x : Option α) (g : (b : β) → b ∈ option.map f x → Option γ) : pbind (option.map f x) g = pbind x fun (a : α) (h : a ∈ x) => g (f a) (mem_map_of_mem f h) :=
  option.cases_on x (fun (g : (b : β) → b ∈ option.map f none → Option γ) => Eq.refl (pbind (option.map f none) g))
    (fun (x : α) (g : (b : β) → b ∈ option.map f (some x) → Option γ) => Eq.refl (pbind (option.map f (some x)) g)) g

@[simp] theorem pmap_none {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β) {H : ∀ (a : α), a ∈ none → p a} : pmap f none H = none :=
  rfl

@[simp] theorem pmap_some {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β) {x : α} (h : p x) : pmap f (some x) = fun (_x : ∀ (a : α), a ∈ some x → p a) => some (f x h) :=
  rfl

theorem mem_pmem {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β) (x : Option α) {a : α} (h : ∀ (a : α), a ∈ x → p a) (ha : a ∈ x) : f a (h a ha) ∈ pmap f x h :=
  eq.mpr (id (Eq._oldrec (Eq.refl (f a (h a ha) ∈ pmap f x h)) (propext mem_def)))
    (Eq._oldrec (fun (h : ∀ (a_1 : α), a_1 ∈ some a → p a_1) (ha : a ∈ some a) => Eq.refl (pmap f (some a) h))
      (Eq.symm (eq.mp (Eq._oldrec (Eq.refl (a ∈ x)) (propext mem_def)) ha)) h ha)

theorem pmap_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {p : α → Prop} (f : (a : α) → p a → β) (g : γ → α) (x : Option γ) (H : ∀ (a : α), a ∈ option.map g x → p a) : pmap f (option.map g x) H =
  pmap (fun (a : γ) (h : p (g a)) => f (g a) h) x fun (a : γ) (h : a ∈ x) => H (g a) (mem_map_of_mem g h) := sorry

theorem map_pmap {α : Type u_1} {β : Type u_2} {γ : Type u_3} {p : α → Prop} (g : β → γ) (f : (a : α) → p a → β) (x : Option α) (H : ∀ (a : α), a ∈ x → p a) : option.map g (pmap f x H) = pmap (fun (a : α) (h : p a) => g (f a h)) x H := sorry

@[simp] theorem pmap_eq_map {α : Type u_1} {β : Type u_2} (p : α → Prop) (f : α → β) (x : Option α) (H : ∀ (a : α), a ∈ x → p a) : pmap (fun (a : α) (_x : p a) => f a) x H = option.map f x := sorry

theorem pmap_bind {α : Type u_1} {β : Type u_1} {γ : Type u_1} {x : Option α} {g : α → Option β} {p : β → Prop} {f : (b : β) → p b → γ} (H : ∀ (a : β), a ∈ x >>= g → p a) (H' : ∀ (a : α) (b : β), b ∈ g a → b ∈ x >>= g) : pmap f (x >>= g) H =
  do
    let a ← x
    pmap f (g a) fun (b : β) (h : b ∈ g a) => H b (H' a b h) := sorry

theorem bind_pmap {α : Type u_1} {β : Type u_2} {γ : Type u_2} {p : α → Prop} (f : (a : α) → p a → β) (x : Option α) (g : β → Option γ) (H : ∀ (a : α), a ∈ x → p a) : pmap f x H >>= g = pbind x fun (a : α) (h : a ∈ x) => g (f a (H a h)) := sorry

theorem pbind_eq_none {α : Type u_1} {β : Type u_2} {x : Option α} {f : (a : α) → a ∈ x → Option β} (h' : ∀ (a : α) (H : a ∈ x), f a H = none → x = none) : pbind x f = none ↔ x = none := sorry

theorem pbind_eq_some {α : Type u_1} {β : Type u_2} {x : Option α} {f : (a : α) → a ∈ x → Option β} {y : β} : pbind x f = some y ↔ ∃ (z : α), ∃ (H : z ∈ x), f z H = some y := sorry

@[simp] theorem pmap_eq_none_iff {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β} {x : Option α} {h : ∀ (a : α), a ∈ x → p a} : pmap f x h = none ↔ x = none := sorry

@[simp] theorem pmap_eq_some_iff {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β} {x : Option α} {hf : ∀ (a : α), a ∈ x → p a} {y : β} : pmap f x hf = some y ↔ ∃ (a : α), ∃ (H : x = some a), f a (hf a H) = y := sorry

@[simp] theorem join_pmap_eq_pmap_join {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β} {x : Option (Option α)} (H : ∀ (a : Option α), a ∈ x → ∀ (a_1 : α), a_1 ∈ a → p a_1) : join (pmap (pmap f) x H) = pmap f (join x) fun (a : α) (h : a ∈ join x) => H (some a) (mem_of_mem_join h) a rfl := sorry

@[simp] theorem seq_some {α : Type u_1} {β : Type u_1} {a : α} {f : α → β} : some f <*> some a = some (f a) :=
  rfl

@[simp] theorem some_orelse' {α : Type u_1} (a : α) (x : Option α) : option.orelse (some a) x = some a :=
  rfl

@[simp] theorem some_orelse {α : Type u_1} (a : α) (x : Option α) : (some a <|> x) = some a :=
  rfl

@[simp] theorem none_orelse' {α : Type u_1} (x : Option α) : option.orelse none x = x :=
  option.cases_on x (Eq.refl (option.orelse none none)) fun (x : α) => Eq.refl (option.orelse none (some x))

@[simp] theorem none_orelse {α : Type u_1} (x : Option α) : (none <|> x) = x :=
  none_orelse' x

@[simp] theorem orelse_none' {α : Type u_1} (x : Option α) : option.orelse x none = x :=
  option.cases_on x (Eq.refl (option.orelse none none)) fun (x : α) => Eq.refl (option.orelse (some x) none)

@[simp] theorem orelse_none {α : Type u_1} (x : Option α) : (x <|> none) = x :=
  orelse_none' x

@[simp] theorem is_some_none {α : Type u_1} : is_some none = false :=
  rfl

@[simp] theorem is_some_some {α : Type u_1} {a : α} : is_some (some a) = tt :=
  rfl

theorem is_some_iff_exists {α : Type u_1} {x : Option α} : ↥(is_some x) ↔ ∃ (a : α), x = some a := sorry

@[simp] theorem is_none_none {α : Type u_1} : is_none none = tt :=
  rfl

@[simp] theorem is_none_some {α : Type u_1} {a : α} : is_none (some a) = false :=
  rfl

@[simp] theorem not_is_some {α : Type u_1} {a : Option α} : is_some a = false ↔ is_none a = tt := sorry

theorem eq_some_iff_get_eq {α : Type u_1} {o : Option α} {a : α} : o = some a ↔ ∃ (h : ↥(is_some o)), get h = a := sorry

theorem not_is_some_iff_eq_none {α : Type u_1} {o : Option α} : ¬↥(is_some o) ↔ o = none := sorry

theorem ne_none_iff_is_some {α : Type u_1} {o : Option α} : o ≠ none ↔ ↥(is_some o) := sorry

theorem ne_none_iff_exists {α : Type u_1} {o : Option α} : o ≠ none ↔ ∃ (x : α), some x = o := sorry

theorem ne_none_iff_exists' {α : Type u_1} {o : Option α} : o ≠ none ↔ ∃ (x : α), o = some x :=
  iff.trans ne_none_iff_exists (exists_congr fun (_x : α) => eq_comm)

theorem bex_ne_none {α : Type u_1} {p : Option α → Prop} : (∃ (x : Option α), ∃ (H : x ≠ none), p x) ↔ ∃ (x : α), p (some x) := sorry

theorem ball_ne_none {α : Type u_1} {p : Option α → Prop} : (∀ (x : Option α), x ≠ none → p x) ↔ ∀ (x : α), p (some x) := sorry

theorem iget_mem {α : Type u_1} [Inhabited α] {o : Option α} : ↥(is_some o) → iget o ∈ o := sorry

theorem iget_of_mem {α : Type u_1} [Inhabited α] {a : α} {o : Option α} : a ∈ o → iget o = a := sorry

@[simp] theorem guard_eq_some {α : Type u_1} {p : α → Prop} [decidable_pred p] {a : α} {b : α} : guard p a = some b ↔ a = b ∧ p a := sorry

@[simp] theorem guard_eq_some' {p : Prop} [Decidable p] (u : Unit) : guard p = some u ↔ p := sorry

theorem lift_or_get_choice {α : Type u_1} {f : α → α → α} (h : ∀ (a b : α), f a b = a ∨ f a b = b) (o₁ : Option α) (o₂ : Option α) : lift_or_get f o₁ o₂ = o₁ ∨ lift_or_get f o₁ o₂ = o₂ := sorry

@[simp] theorem lift_or_get_none_left {α : Type u_1} {f : α → α → α} {b : Option α} : lift_or_get f none b = b :=
  option.cases_on b (Eq.refl (lift_or_get f none none)) fun (b : α) => Eq.refl (lift_or_get f none (some b))

@[simp] theorem lift_or_get_none_right {α : Type u_1} {f : α → α → α} {a : Option α} : lift_or_get f a none = a :=
  option.cases_on a (Eq.refl (lift_or_get f none none)) fun (a : α) => Eq.refl (lift_or_get f (some a) none)

@[simp] theorem lift_or_get_some_some {α : Type u_1} {f : α → α → α} {a : α} {b : α} : lift_or_get f (some a) (some b) = ↑(f a b) :=
  rfl

/-- given an element of `a : option α`, a default element `b : β` and a function `α → β`, apply this
function to `a` if it comes from `α`, and return `b` otherwise. -/
def cases_on' {α : Type u_1} {β : Type u_2} : Option α → β → (α → β) → β :=
  sorry

@[simp] theorem cases_on'_none {α : Type u_1} {β : Type u_2} (x : β) (f : α → β) : cases_on' none x f = x :=
  rfl

@[simp] theorem cases_on'_some {α : Type u_1} {β : Type u_2} (x : β) (f : α → β) (a : α) : cases_on' (some a) x f = f a :=
  rfl

@[simp] theorem cases_on'_coe {α : Type u_1} {β : Type u_2} (x : β) (f : α → β) (a : α) : cases_on' (↑a) x f = f a :=
  rfl

@[simp] theorem cases_on'_none_coe {α : Type u_1} {β : Type u_2} (f : Option α → β) (o : Option α) : cases_on' o (f none) (f ∘ coe) = f o :=
  option.cases_on o (Eq.refl (cases_on' none (f none) (f ∘ coe)))
    fun (o : α) => Eq.refl (cases_on' (some o) (f none) (f ∘ coe))


import Lean

/-
(1) How are the source information, comments etc stored in the Syntax tree? In particular, how can one recreate the original source?
-/

elab "#reprint" e:term : command => do
  let some val := e.raw.reprint | throwError "failed to reprint"
  IO.println val

#reprint
  let x : Nat := 3 -- My comment 1
  x + 2 /- another comment here -/

elab "#repr" e:term : command => do
  IO.println (repr e)

#check Lean.SourceInfo

#repr
  let x : Nat := 3 -- My comment 1
  x + 2 /- another comment here -/

/-
(2) I am comfortable with the usual token level parsers but could not understand the code for `commentBody` and such parsers. How does one parse at character level?

-/

section
open Lean Parser
partial def commandCommentBodyFn (c : ParserContext) (s : ParserState) : ParserState :=
  go s
where
  go (s : ParserState) : ParserState := Id.run do
    let input := c.input
    let i     := s.pos
    if input.atEnd i then return s.mkUnexpectedError "unterminated command comment"
    let curr := input.get i
    let i    := input.next i
    if curr != '-' then return go (s.setPos i)
    let curr := input.get i
    let i    := input.next i
    if curr != '/' then return go (s.setPos i)
    let curr := input.get i
    let i    := input.next i
    if curr != '/' then return go (s.setPos i)
    -- Found '-//'
    return s.setPos i

def commandCommentBody : Parser :=
  { fn := rawFn commandCommentBodyFn (trailingWs := true) }

@[combinator_parenthesizer commandCommentBody] def commandCommentBody.parenthesizer := PrettyPrinter.Parenthesizer.visitToken
@[combinator_formatter commandCommentBody] def commandCommentBody.formatter := PrettyPrinter.Formatter.visitAtom Name.anonymous

@[command_parser] def commandComment := leading_parser "//-" >> commandCommentBody >> ppLine

end

open Lean Elab Command in
@[command_elab commandComment] def elabCommandComment : CommandElab := fun stx => do
   let .atom _ val := stx[1] | return ()
   let str := val.extract 0 (val.endPos - ⟨3⟩)
   IO.println s!"str := {repr str}"

//- My command comment hello world -//

/-
(3) How does one split a `tacticSeq` into individual tactics, with the goal of running them one by one logging state along the way?
-/
section
open Lean Parser Elab Tactic

def getTactics (s : TSyntax ``tacticSeq) : Array (TSyntax `tactic) :=
  match s with
  | `(tacticSeq| { $[$t]* }) => t
  | `(tacticSeq| $[$t]*) => t
  | _ => #[]

elab "seq" s:tacticSeq : tactic => do
  -- IO.println s
  let tacs := getTactics s
  for tac in tacs do
    let gs ← getUnsolvedGoals
    withRef tac <| addRawTrace (goalsToMessageData gs)
    evalTactic tac

example (h : x = y) : 0 + x = y := by
  seq rw [h]; rw [Nat.zero_add]
  done

example (h : x = y) : 0 + x = y := by
  seq rw [h]
      rw [Nat.zero_add]
  done

example (h : x = y) : 0 + x = y := by
  seq { rw [h]; rw [Nat.zero_add] }
  done

end

/-
(4) Related to the above, how does one parse and run all the commands in a file updating the environment, with modifications to the running in some cases (specifically when running a `tacticSeq` log state at each step)?
-/

#check Lean.Elab.runFrontend


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 .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