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.


import .util

section tactic
open tactic
open interaction_monad.result
meta def tactic.try_verbose {α} (tac : tactic α) : tactic unit := λ s, match tac s with
| (exception msg pos state) := match msg with
  | (some thunk) := (tactic.trace format! "[try_verbose] FAILURE: {thunk ()}") s
  | none := success () s
  end
| (success _ s') := success () s'
end

end tactic

section mfold_with_binders

namespace expr

-- this should satisfy the following invariants:
-- the variable binding list should only inherit from higher binders, so there is a tree of local bindings
-- the accumulator α, however, should be folded across the entire tree
meta def expr.mfold_with_binders_aux {α : Type} : expr → α → (list expr) → (expr → α → (list expr) → tactic α) → (tactic α)
| e@(var k) acc bs f := f e acc bs
| e@(sort l) acc bs f := f e acc bs
| e@(const nm ls) acc bs f := f e acc bs
| e@(mvar _ _ _) acc bs f := f e acc bs
| e@(local_const _ _ _ _) acc bs f := f e acc bs
| e@(app e₁ e₂) acc bs f := do {
    r₀ ← f e acc bs,
    r₁ ← expr.mfold_with_binders_aux e₁ r₀ bs f,
    r₂ ← expr.mfold_with_binders_aux e₂ r₁ bs f,
    pure r₂
  }
| e@(lam var_name b_info var_type body) acc bs f := do {
    ⟨[b], e'⟩ ← tactic.open_n_lambdas e 1,
    r ← expr.mfold_with_binders_aux e' acc (b::bs) f,
    pure r
  }
| e@(pi var_name b_info var_type body) acc bs f := do {
    ⟨[b], e'⟩ ← tactic.open_n_pis e 1,
    r ← expr.mfold_with_binders_aux e' acc (b::bs) f,
    pure r
  }
| e@(elet var_name var_type var_assignment body) acc bs f := do {
    expr.mfold_with_binders_aux e.reduce_let acc bs f
  }
| e@(macro _ _) acc bs f := do {
  (e.unfold_macros) >>= (λ x, f x acc bs)
}

meta def mfold_with_binders {α : Type} : expr → α → (expr → α → (list expr) → tactic α) → tactic α :=
λ e acc f, expr.mfold_with_binders_aux e acc [] f

end expr

end mfold_with_binders

section generic

-- TODO(): probably buggy! don't trust io.fs.get_line
meta def readlines (f : io.handle) : io (list string) := do {
  ls ← io.iterate [] (λ acc, do {
     do {
      r ← buffer.to_string <$> io.fs.get_line f,
      mcond (io.fs.is_eof f) (pure none) $ do
      -- io.put_str_ln $ "GOT STRING: " ++ r,
      pure ∘ pure $ acc ++ [r]
    }
  }),
  pure ls
}

-- note(): use this instead
meta def readlines' (f : io.handle) : io (list string) := do {
  list.filter (λ x, !(x = "")) <$> (string.split (= '\n') <$> buffer.to_string <$> io.fs.read_to_end f)
}

meta def dump_step
  {datapoint_type : Type}
  {worker_fn_options_type : Type}
  (r : tactic.ref ℕ)
  (decl : declaration)
  (dest_handle : io.handle)
  (serialization_guard : datapoint_type → tactic bool)
  (worker_fn : expr → worker_fn_options_type → tactic (list datapoint_type))
  (serialization_fn : datapoint_type → tactic string)
  (worker_fn_options : worker_fn_options_type)
  (desc : string)
: tactic unit :=
do {
  tactic.trace format!"[dump_{desc}_step] PROCESSING DECL {decl.to_name}",
  pf ← tactic.get_proof decl,
  dps ← worker_fn pf worker_fn_options,
  for_ dps $ λ dp, do {
    mcond (bnot <$> serialization_guard dp) (pure ()) $ do
    msg ← serialization_fn dp,
    tactic.unsafe_run_io $ io.fs.put_str_ln dest_handle msg
  },
  tactic.modify_ref r nat.succ
}

/- TODO(): it is inefficient to eagerly produce an entire list of datapoints first before serialization.
  In practice, this seems to work OK, but we might hit performance problems when we try to do everything at once
  might be better to make `serialization_fn` an argument to `worker_fn` and have it write datapoints to the file
  in a loop. -/
meta def dump_from_decls_file
  /- `datapoint_type` and `worker_fn_options_type` should be inferred automatically from `worker_fn` -/
  {datapoint_type : Type}
  {worker_fn_options_type : Type}

  /- used to populate stdout trace message -/
  (desc : string)
  /- file containing a list of Lean declarations -/
  (decls_file : string)
  /- destination filepath for the serialized datapoints -/
  (dest : string)
  /- returns tt if OK to serialize-/
  (serialization_guard : datapoint_type → tactic bool)
  /- responsible for extracting a list of datapoints from the declaration -/
  (worker_fn : expr → worker_fn_options_type → tactic (list datapoint_type))
  /- responsible for writing the datapoint_type to a string, which is then written to the file -/
  (serialization_fn : datapoint_type → tactic string)
  /- configuration (e.g. recursion limits) for the worker_fn, which is responsible for extracting datapoints -/
  (worker_fn_options : worker_fn_options_type)

: io unit := do {
  nm_strs ← io.mk_file_handle decls_file io.mode.read >>= readlines',
  (nms : list (name × list name)) ← (nm_strs.filter $ λ nm_str, string.length nm_str > 0).mmap $ λ nm_str, do {
    ((io.run_tactic' ∘ parse_decl_nm_and_open_ns) $ nm_str)
  },
  dest_handle ← io.mk_file_handle dest io.mode.write,
  io.run_tactic $ do {
    env ← tactic.get_env,
    let total := nms.length,
    tactic.trace format!"TOTAL: {total}",
    tactic.using_new_ref (0 : ℕ) $ λ r,
    for_ nms $ λ ⟨nm, _⟩, do {
      decl ← optional (env.get nm),
      match decl with
      | (some decl) := do {
          dump_step r decl dest_handle serialization_guard worker_fn serialization_fn worker_fn_options desc
        }
      | none := do {
        tactic.trace format!"[WARNING] COULDN'T RESOLVE {nm}",
        tactic.modify_ref r nat.succ
      }
      end,
      count ← tactic.read_ref r,
      tactic.trace format!"PROGRESS: {count}/{total}"
    }
  }
}

end generic

section premise_selection

meta def gather_used_premises : expr → tactic (list expr) := λ e,
  let fn : expr → list expr → list expr → tactic (list expr) := λ e acc bs, do {
    match e with
      | ex@(expr.const nm levels) := mcond (tactic.is_proof ex) (pure $ ex::acc) (pure acc)
      | _ := pure acc
    end
  } in
  e.mfold_with_binders [] fn

meta def mk_type_annotation : expr → tactic (expr × expr) :=
λ h, prod.mk h <$> tactic.infer_type h

end premise_selection

section pp

meta def enable_verbose : tactic unit := do {
-- tactic.set_bool_option `pp.implicit true
  tactic.set_bool_option `pp.all true,
  tactic.set_bool_option `pp.implicit true, -- TODO(): can we get away with setting this `false`? this blows up the proof terms by a LOT
  tactic.set_bool_option `pp.universes false,
  tactic.set_bool_option `pp.notation true,
  tactic.set_bool_option `pp.generalized_field_notation true,
  tactic.set_bool_option `pp.structure_projections true,
  tactic.set_bool_option `pp.beta true,
  tactic.set_bool_option `pp.binder_types true,
  tactic.set_nat_option `pp.max_depth 128,
  tactic.set_nat_option `pp.max_steps 10000
}

meta def with_verbose {α} (tac : tactic α) : tactic α :=
tactic.save_options $ enable_verbose *> tac

end pp

section test_lemmas
  -- GOAL P Q : Prop ⊢ ((P → Q) → P) → P PROOFSTEP apply or.elim (em P)
  -- GOAL P Q : Prop ⊢ P → ((P → Q) → P) → P  P Q : Prop ⊢ ¬P → ((P → Q) → P) → P PROOFSTEP intros h _
  -- GOAL P Q : Prop, h : P, ᾰ : (P → Q) → P ⊢ P  P Q : Prop ⊢ ¬P → ((P → Q) → P) → P PROOFSTEP exact h
  -- GOAL P Q : Prop ⊢ ¬P → ((P → Q) → P) → P PROOFSTEP tauto!
lemma peirce_identity {P Q :Prop} : ((P → Q) → P) → P :=
begin
  apply or.elim (em P),
  intros h _,
  exact h,
  tauto!
end

end test_lemmas


theorem unsound : False := -- Error
  unsound

partial theorem unsound2 : False := -- Error
  unsound2

unsafe theorem unsound3 : False := -- Error
  unsound3

opaque unsound4 : False  -- Error

axiom magic : False -- OK
namespace Foo
partial def foo (x : Nat) : Nat := foo x  -- OK

unsafe def unsound2 : False := unsound  -- OK

partial def unsound3 : False := unsound3  -- Error

partial def unsound4 (x : Unit) : False := unsound4 ()  -- Error

partial def badcast1 (x : Nat) : Bool :=
  unsafeCast x -- Error: partial cannot use unsafe constant

partial def badcast2 (x : Nat) : Bool :=
  if x == 0 then unsafeCast x -- Error: partial cannot use unsafe constant
  else badcast2 (x + 1)

unsafe def badcast3 (x : Nat) : Bool := -- OK
  if x == 0 then unsafeCast x
  else badcast3 (x + 1)


/-
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 (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

notation, basic datatypes and type classes
-/
prelude
import Init.Prelude
import Init.SizeOf

universes u v w

def inline {α : Sort u} (a : α) : α := a

@[inline] def flip {α : Sort u} {β : Sort v} {φ : Sort w} (f : α → β → φ) : β → α → φ :=
  fun b a => f a b

/--
  Thunks are "lazy" values that are evaluated when first accessed using `Thunk.get/map/bind`.
  The value is then stored and not recomputed for all further accesses. -/
-- NOTE: the runtime has special support for the `Thunk` type to implement this behavior
structure Thunk (α : Type u) : Type u where
  -- TODO: make private
  fn : Unit → α

attribute [extern "lean_mk_thunk"] Thunk.mk

/-- Store a value in a thunk. Note that the value has already been computed, so there is no laziness. -/
@[extern "lean_thunk_pure"] protected def Thunk.pure (a : α) : Thunk α :=
  ⟨fun _ => a⟩
-- NOTE: we use `Thunk.get` instead of `Thunk.fn` as the accessor primitive as the latter has an additional `Unit` argument
@[extern "lean_thunk_get_own"] protected def Thunk.get (x : @& Thunk α) : α :=
  x.fn ()
@[inline] protected def Thunk.map (f : α → β) (x : Thunk α) : Thunk β :=
  ⟨fun _ => f x.get⟩
@[inline] protected def Thunk.bind (x : Thunk α) (f : α → Thunk β) : Thunk β :=
  ⟨fun _ => (f x.get).get⟩

abbrev Eq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} {b : α} (h : a = b) (m : motive a) : motive b :=
  Eq.ndrec m h

structure Iff (a b : Prop) : Prop where
  intro :: (mp : a → b) (mpr : b → a)

infix:20 " <-> " => Iff
infix:20 " ↔ "   => Iff

inductive Sum (α : Type u) (β : Type v) where
  | inl (val : α) : Sum α β
  | inr (val : β) : Sum α β

inductive PSum (α : Sort u) (β : Sort v) where
  | inl (val : α) : PSum α β
  | inr (val : β) : PSum α β

structure Sigma {α : Type u} (β : α → Type v) where
  fst : α
  snd : β fst

attribute [unbox] Sigma

structure PSigma {α : Sort u} (β : α → Sort v) where
  fst : α
  snd : β fst

inductive Exists {α : Sort u} (p : α → Prop) : Prop where
  | intro (w : α) (h : p w) : Exists p

/- Auxiliary type used to compile `for x in xs` notation. -/
inductive ForInStep (α : Type u) where
  | done  : α → ForInStep α
  | yield : α → ForInStep α

class ForIn (m : Type u₁ → Type u₂) (ρ : Type u) (α : outParam (Type v)) where
  forIn {β} [Monad m] (x : ρ) (b : β) (f : α → β → m (ForInStep β)) : m β

export ForIn (forIn)

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPRBC (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPRBC α β σ
  | «return»   : β → σ → DoResultPRBC α β σ
  | «break»    : σ → DoResultPRBC α β σ
  | «continue» : σ → DoResultPRBC α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultPR (α β σ : Type u) where
  | «pure»     : α → σ → DoResultPR α β σ
  | «return»   : β → σ → DoResultPR α β σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultBC (σ : Type u) where
  | «break»    : σ → DoResultBC σ
  | «continue» : σ → DoResultBC σ

/- Auxiliary type used to compile `do` notation. -/
inductive DoResultSBC (α σ : Type u) where
  | «pureReturn» : α → σ → DoResultSBC α σ
  | «break»      : σ → DoResultSBC α σ
  | «continue»   : σ → DoResultSBC α σ

class HasEquiv  (α : Sort u) where
  Equiv : α → α → Sort v

infix:50 " ≈ "  => HasEquiv.Equiv

class EmptyCollection (α : Type u) where
  emptyCollection : α

notation "{" "}" => EmptyCollection.emptyCollection
notation "∅"     => EmptyCollection.emptyCollection

/- Remark: tasks have an efficient implementation in the runtime. -/
structure Task (α : Type u) : Type u where
  pure :: (get : α)

attribute [extern "lean_task_pure"] Task.pure
attribute [extern "lean_task_get_own"] Task.get

namespace Task
/-- Task priority. Tasks with higher priority will always be scheduled before ones with lower priority. -/
abbrev Priority := Nat
def Priority.default : Priority := 0
-- see `LEAN_MAX_PRIO`
def Priority.max : Priority := 8
/--
  Any priority higher than `Task.Priority.max` will result in the task being scheduled immediately on a dedicated thread.
  This is particularly useful for long-running and/or I/O-bound tasks since Lean will by default allocate no more
  non-dedicated workers than the number of cores to reduce context switches. -/
def Priority.dedicated : Priority := 9

@[noinline, extern "lean_task_spawn"]
protected def spawn {α : Type u} (fn : Unit → α) (prio := Priority.default) : Task α :=
  ⟨fn ()⟩

@[noinline, extern "lean_task_map"]
protected def map {α : Type u} {β : Type v} (f : α → β) (x : Task α) (prio := Priority.default) : Task β :=
  ⟨f x.get⟩

@[noinline, extern "lean_task_bind"]
protected def bind {α : Type u} {β : Type v} (x : Task α) (f : α → Task β) (prio := Priority.default) : Task β :=
  ⟨(f x.get).get⟩

end Task

/- Some type that is not a scalar value in our runtime. -/
structure NonScalar where
  val : Nat

/- Some type that is not a scalar value in our runtime and is universe polymorphic. -/
inductive PNonScalar : Type u where
  | mk (v : Nat) : PNonScalar

theorem natAddZero (n : Nat) : n + 0 = n := rfl

theorem optParamEq (α : Sort u) (default : α) : optParam α default = α := rfl

/- Boolean operators -/

@[extern c inline "#1 || #2"] def strictOr  (b₁ b₂ : Bool) := b₁ || b₂
@[extern c inline "#1 && #2"] def strictAnd (b₁ b₂ : Bool) := b₁ && b₂

@[inline] def bne {α : Type u} [BEq α] (a b : α) : Bool :=
  !(a == b)

infix:50 " != " => bne

/- Logical connectives an equality -/

def implies (a b : Prop) := a → b

theorem implies.trans {p q r : Prop} (h₁ : implies p q) (h₂ : implies q r) : implies p r :=
  fun hp => h₂ (h₁ hp)

def trivial : True := ⟨⟩

theorem mt {a b : Prop} (h₁ : a → b) (h₂ : ¬b) : ¬a :=
  fun ha => h₂ (h₁ ha)

theorem notFalse : ¬False := id

-- proof irrelevance is built in
theorem proofIrrel {a : Prop} (h₁ h₂ : a) : h₁ = h₂ := rfl

theorem id.def {α : Sort u} (a : α) : id a = a := rfl

@[macroInline] def Eq.mp {α β : Sort u} (h : α = β) (a : α) : β :=
  h ▸ a

@[macroInline] def Eq.mpr {α β : Sort u} (h : α = β) (b : β) : α :=
  h ▸ b

theorem Eq.substr {α : Sort u} {p : α → Prop} {a b : α} (h₁ : b = a) (h₂ : p a) : p b :=
  h₁ ▸ h₂

theorem castEq {α : Sort u} (h : α = α) (a : α) : cast h a = a :=
  rfl

@[reducible] def Ne {α : Sort u} (a b : α) :=
  ¬(a = b)

infix:50 " ≠ "  => Ne

section Ne
variable {α : Sort u}
variable {a b : α} {p : Prop}

theorem Ne.intro (h : a = b → False) : a ≠ b := h

theorem Ne.elim (h : a ≠ b) : a = b → False := h

theorem Ne.irrefl (h : a ≠ a) : False := h rfl

theorem Ne.symm (h : a ≠ b) : b ≠ a :=
  fun h₁ => h (h₁.symm)

theorem falseOfNe : a ≠ a → False := Ne.irrefl

theorem neFalseOfSelf : p → p ≠ False :=
  fun (hp : p) (h : p = False) => h ▸ hp

theorem neTrueOfNot : ¬p → p ≠ True :=
  fun (hnp : ¬p) (h : p = True) =>
    have : ¬True := h ▸ hnp
    this trivial

theorem trueNeFalse : ¬True = False :=
  neFalseOfSelf trivial

end Ne

section
variable {α β φ : Sort u} {a a' : α} {b b' : β} {c : φ}

theorem HEq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} (m : motive a) {β : Sort u2} {b : β} (h : a ≅ b) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.ndrecOn.{u1, u2} {α : Sort u2} {a : α} {motive : {β : Sort u2} → β → Sort u1} {β : Sort u2} {b : β} (h : a ≅ b) (m : motive a) : motive b :=
  @HEq.rec α a (fun b _ => motive b) m β b h

theorem HEq.elim {α : Sort u} {a : α} {p : α → Sort v} {b : α} (h₁ : a ≅ b) (h₂ : p a) : p b :=
  eqOfHEq h₁ ▸ h₂

theorem HEq.subst {p : (T : Sort u) → T → Prop} (h₁ : a ≅ b) (h₂ : p α a) : p β b :=
  HEq.ndrecOn h₁ h₂

theorem HEq.symm (h : a ≅ b) : b ≅ a :=
  HEq.ndrecOn (motive := fun x => x ≅ a) h (HEq.refl a)

theorem heqOfEq (h : a = a') : a ≅ a' :=
  Eq.subst h (HEq.refl a)

theorem HEq.trans (h₁ : a ≅ b) (h₂ : b ≅ c) : a ≅ c :=
  HEq.subst h₂ h₁

theorem heqOfHEqOfEq (h₁ : a ≅ b) (h₂ : b = b') : a ≅ b' :=
  HEq.trans h₁ (heqOfEq h₂)

theorem heqOfEqOfHEq (h₁ : a = a') (h₂ : a' ≅ b) : a ≅ b :=
  HEq.trans (heqOfEq h₁) h₂

def typeEqOfHEq (h : a ≅ b) : α = β :=
  HEq.ndrecOn (motive := @fun (x : Sort u) _ => α = x) h (Eq.refl α)

end

theorem eqRecHEq {α : Sort u} {φ : α → Sort v} {a a' : α} : (h : a = a') → (p : φ a) → (Eq.recOn (motive := fun x _ => φ x) h p) ≅ p
  | rfl, p => HEq.refl p

theorem heqOfEqRecEq {α β : Sort u} {a : α} {b : β} (h₁ : α = β) (h₂ : Eq.rec (motive := fun α _ => α) a h₁ = b) : a ≅ b := by
  subst h₁
  apply heqOfEq
  exact h₂

theorem castHEq {α β : Sort u} : (h : α = β) → (a : α) → cast h a ≅ a
  | rfl, a => HEq.refl a

variable {a b c d : Prop}

theorem iffIffImpliesAndImplies (a b : Prop) : (a ↔ b) ↔ (a → b) ∧ (b → a) :=
  Iff.intro (fun h => And.intro h.mp h.mpr) (fun h => Iff.intro h.left h.right)

theorem Iff.refl (a : Prop) : a ↔ a :=
  Iff.intro (fun h => h) (fun h => h)

theorem Iff.rfl {a : Prop} : a ↔ a :=
  Iff.refl a

theorem Iff.trans (h₁ : a ↔ b) (h₂ : b ↔ c) : a ↔ c :=
  Iff.intro
    (fun ha => Iff.mp h₂ (Iff.mp h₁ ha))
    (fun hc => Iff.mpr h₁ (Iff.mpr h₂ hc))

theorem Iff.symm (h : a ↔ b) : b ↔ a :=
  Iff.intro (Iff.mpr h) (Iff.mp h)

theorem Iff.comm : (a ↔ b) ↔ (b ↔ a) :=
  Iff.intro Iff.symm Iff.symm

/- Exists -/

theorem Exists.elim {α : Sort u} {p : α → Prop} {b : Prop}
   (h₁ : Exists (fun x => p x)) (h₂ : ∀ (a : α), p a → b) : b :=
  h₂ h₁.1 h₁.2

/- Decidable -/

theorem decideTrueEqTrue (h : Decidable True) : @decide True h = true :=
  match h with
  | isTrue h  => rfl
  | isFalse h => False.elim <| h ⟨⟩

theorem decideFalseEqFalse (h : Decidable False) : @decide False h = false :=
  match h with
  | isFalse h => rfl
  | isTrue h  => False.elim h

/-- Similar to `decide`, but uses an explicit instance -/
@[inline] def toBoolUsing {p : Prop} (d : Decidable p) : Bool :=
  decide p (h := d)

theorem toBoolUsingEqTrue {p : Prop} (d : Decidable p) (h : p) : toBoolUsing d = true :=
  decideEqTrue (s := d) h

theorem ofBoolUsingEqTrue {p : Prop} {d : Decidable p} (h : toBoolUsing d = true) : p :=
  ofDecideEqTrue (s := d) h

theorem ofBoolUsingEqFalse {p : Prop} {d : Decidable p} (h : toBoolUsing d = false) : ¬ p :=
  ofDecideEqFalse (s := d) h

instance : Decidable True :=
  isTrue trivial

instance : Decidable False :=
  isFalse notFalse

namespace Decidable
variable {p q : Prop}

@[macroInline] def byCases {q : Sort u} [dec : Decidable p] (h1 : p → q) (h2 : ¬p → q) : q :=
  match dec with
  | isTrue h  => h1 h
  | isFalse h => h2 h

theorem em (p : Prop) [Decidable p] : p ∨ ¬p :=
  byCases Or.inl Or.inr

theorem byContradiction [dec : Decidable p] (h : ¬p → False) : p :=
  byCases id (fun np => False.elim (h np))

theorem ofNotNot [Decidable p] : ¬ ¬ p → p :=
  fun hnn => byContradiction (fun hn => absurd hn hnn)

theorem notAndIffOrNot (p q : Prop) [d₁ : Decidable p] [d₂ : Decidable q] : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q :=
  Iff.intro
    (fun h => match d₁, d₂ with
      | isTrue h₁,  isTrue h₂   => absurd (And.intro h₁ h₂) h
      | _,           isFalse h₂ => Or.inr h₂
      | isFalse h₁, _           => Or.inl h₁)
    (fun (h) ⟨hp, hq⟩ => match h with
      | Or.inl h => h hp
      | Or.inr h => h hq)

end Decidable

section
variable {p q : Prop}
@[inline] def  decidableOfDecidableOfIff (hp : Decidable p) (h : p ↔ q) : Decidable q :=
  if hp : p then
    isTrue (Iff.mp h hp)
  else
    isFalse fun hq => absurd (Iff.mpr h hq) hp

@[inline] def  decidableOfDecidableOfEq (hp : Decidable p) (h : p = q) : Decidable q :=
  h ▸ hp
end

@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (p → q) :=
  if hp : p then
    if hq : q then isTrue (fun h => hq)
    else isFalse (fun h => absurd (h hp) hq)
  else isTrue (fun h => absurd h hp)

instance {p q} [Decidable p] [Decidable q] : Decidable (p ↔ q) :=
  if hp : p then
    if hq : q then
      isTrue ⟨fun _ => hq, fun _ => hp⟩
    else
      isFalse fun h => hq (h.1 hp)
  else
    if hq : q then
      isFalse fun h => hp (h.2 hq)
    else
      isTrue ⟨fun h => absurd h hp, fun h => absurd h hq⟩

/- if-then-else expression theorems -/

theorem ifPos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t e : α} : (ite c t e) = t :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem ifNeg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t e : α} : (ite c t e) = e :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

theorem difPos {c : Prop} [h : Decidable c] (hc : c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = t hc :=
  match h with
  | isTrue  hc  => rfl
  | isFalse hnc => absurd hc hnc

theorem difNeg {c : Prop} [h : Decidable c] (hnc : ¬c) {α : Sort u} {t : c → α} {e : ¬ c → α} : (dite c t e) = e hnc :=
  match h with
  | isTrue hc   => absurd hc hnc
  | isFalse hnc => rfl

-- Remark: dite and ite are "defally equal" when we ignore the proofs.
theorem difEqIf (c : Prop) [h : Decidable c] {α : Sort u} (t : α) (e : α) : dite c (fun h => t) (fun h => e) = ite c t e :=
  match h with
  | isTrue hc   => rfl
  | isFalse hnc => rfl

instance {c t e : Prop} [dC : Decidable c] [dT : Decidable t] [dE : Decidable e] : Decidable (if c then t else e)  :=
  match dC with
  | isTrue hc  => dT
  | isFalse hc => dE

instance {c : Prop} {t : c → Prop} {e : ¬c → Prop} [dC : Decidable c] [dT : ∀ h, Decidable (t h)] [dE : ∀ h, Decidable (e h)] : Decidable (if h : c then t h else e h)  :=
  match dC with
  | isTrue hc  => dT hc
  | isFalse hc => dE hc

/- Inhabited -/

instance : Inhabited Prop where
  default := True

deriving instance Inhabited for NonScalar, PNonScalar, True, ForInStep

class inductive Nonempty (α : Sort u) : Prop where
  | intro (val : α) : Nonempty α

protected def Nonempty.elim {α : Sort u} {p : Prop} (h₁ : Nonempty α) (h₂ : α → p) : p :=
  h₂ h₁.1

instance {α : Sort u} [Inhabited α] : Nonempty α where
  val := arbitrary

theorem nonemptyOfExists {α : Sort u} {p : α → Prop} : Exists (fun x => p x) → Nonempty α
  | ⟨w, h⟩ => ⟨w⟩

/- Subsingleton -/

class Subsingleton (α : Sort u) : Prop where
  intro :: allEq : (a b : α) → a = b

protected def Subsingleton.elim {α : Sort u} [h : Subsingleton α] : (a b : α) → a = b :=
  h.allEq

protected def Subsingleton.helim {α β : Sort u} [h₁ : Subsingleton α] (h₂ : α = β) (a : α) (b : β) : a ≅ b := by
  subst h₂
  apply heqOfEq
  apply Subsingleton.elim

instance (p : Prop) : Subsingleton p :=
  ⟨fun a b => proofIrrel a b⟩

instance (p : Prop) : Subsingleton (Decidable p) :=
  Subsingleton.intro fun
    | isTrue t₁ => fun
      | isTrue t₂  => rfl
      | isFalse f₂ => absurd t₁ f₂
    | isFalse f₁ => fun
      | isTrue t₂  => absurd t₂ f₁
      | isFalse f₂ => rfl

theorem recSubsingleton
     {p : Prop} [h : Decidable p]
     {h₁ : p → Sort u}
     {h₂ : ¬p → Sort u}
     [h₃ : ∀ (h : p), Subsingleton (h₁ h)]
     [h₄ : ∀ (h : ¬p), Subsingleton (h₂ h)]
     : Subsingleton (Decidable.casesOn (motive := fun _ => Sort u) h h₂ h₁) :=
  match h with
  | isTrue h  => h₃ h
  | isFalse h => h₄ h

structure Equivalence {α : Sort u} (r : α → α → Prop) : Prop where
  refl  : ∀ x, r x x
  symm  : ∀ {x y}, r x y → r y x
  trans : ∀ {x y z}, r x y → r y z → r x z

def emptyRelation {α : Sort u} (a₁ a₂ : α) : Prop :=
  False

def Subrelation {α : Sort u} (q r : α → α → Prop) :=
  ∀ {x y}, q x y → r x y

def InvImage {α : Sort u} {β : Sort v} (r : β → β → Prop) (f : α → β) : α → α → Prop :=
  fun a₁ a₂ => r (f a₁) (f a₂)

inductive TC {α : Sort u} (r : α → α → Prop) : α → α → Prop where
  | base  : ∀ a b, r a b → TC r a b
  | trans : ∀ a b c, TC r a b → TC r b c → TC r a c

/- Subtype -/

namespace Subtype
def existsOfSubtype {α : Type u} {p : α → Prop} : { x // p x } → Exists (fun x => p x)
  | ⟨a, h⟩ => ⟨a, h⟩

variable {α : Type u} {p : α → Prop}

protected theorem eq : ∀ {a1 a2 : {x // p x}}, val a1 = val a2 → a1 = a2
  | ⟨x, h1⟩, ⟨_, _⟩, rfl => rfl

theorem eta (a : {x // p x}) (h : p (val a)) : mk (val a) h = a := by
  cases a
  exact rfl

instance {α : Type u} {p : α → Prop} {a : α} (h : p a) : Inhabited {x // p x} where
  default := ⟨a, h⟩

instance {α : Type u} {p : α → Prop} [DecidableEq α] : DecidableEq {x : α // p x} :=
  fun ⟨a, h₁⟩ ⟨b, h₂⟩ =>
    if h : a = b then isTrue (by subst h; exact rfl)
    else isFalse (fun h' => Subtype.noConfusion h' (fun h' => absurd h' h))

end Subtype

/- Sum -/

section
variable {α : Type u} {β : Type v}

instance Sum.inhabitedLeft [h : Inhabited α] : Inhabited (Sum α β) where
  default := Sum.inl arbitrary

instance Sum.inhabitedRight [h : Inhabited β] : Inhabited (Sum α β) where
  default := Sum.inr arbitrary

instance {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] : DecidableEq (Sum α β) := fun a b =>
  match a, b with
  | Sum.inl a, Sum.inl b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inr b =>
    if h : a = b then isTrue (h ▸ rfl)
    else isFalse fun h' => Sum.noConfusion h' fun h' => absurd h' h
  | Sum.inr a, Sum.inl b => isFalse fun h => Sum.noConfusion h
  | Sum.inl a, Sum.inr b => isFalse fun h => Sum.noConfusion h

end

/- Product -/

instance [Inhabited α] [Inhabited β] : Inhabited (α × β) where
  default := (arbitrary, arbitrary)

instance [DecidableEq α] [DecidableEq β] : DecidableEq (α × β) :=
  fun (a, b) (a', b') =>
    match decEq a a' with
    | isTrue e₁ =>
      match decEq b b' with
      | isTrue e₂  => isTrue (e₁ ▸ e₂ ▸ rfl)
      | isFalse n₂ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₂' n₂
    | isFalse n₁ => isFalse fun h => Prod.noConfusion h fun e₁' e₂' => absurd e₁' n₁

instance [BEq α] [BEq β] : BEq (α × β) where
  beq := fun (a₁, b₁) (a₂, b₂) => a₁ == a₂ && b₁ == b₂

instance [LT α] [LT β] : LT (α × β) where
  lt s t := s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)

instance prodHasDecidableLt
    [LT α] [LT β] [DecidableEq α] [DecidableEq β]
    [(a b : α) → Decidable (a < b)] [(a b : β) → Decidable (a < b)]
    : (s t : α × β) → Decidable (s < t) :=
  fun t s => inferInstanceAs (Decidable (_ ∨ _))

theorem Prod.ltDef [LT α] [LT β] (s t : α × β) : (s < t) = (s.1 < t.1 ∨ (s.1 = t.1 ∧ s.2 < t.2)) :=
  rfl

theorem Prod.ext (p : α × β) : (p.1, p.2) = p := by
  cases p; rfl

def Prod.map {α₁ : Type u₁} {α₂ : Type u₂} {β₁ : Type v₁} {β₂ : Type v₂}
    (f : α₁ → α₂) (g : β₁ → β₂) : α₁ × β₁ → α₂ × β₂
  | (a, b) => (f a, g b)

/- Dependent products -/

theorem exOfPsig {α : Type u} {p : α → Prop} : (PSigma (fun x => p x)) → Exists (fun x => p x)
  | ⟨x, hx⟩ => ⟨x, hx⟩

protected theorem PSigma.eta {α : Sort u} {β : α → Sort v} {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂}
    (h₁ : a₁ = a₂) (h₂ : Eq.ndrec b₁ h₁ = b₂) : PSigma.mk a₁ b₁ = PSigma.mk a₂ b₂ := by
  subst h₁
  subst h₂
  exact rfl

/- Universe polymorphic unit -/

theorem PUnit.subsingleton (a b : PUnit) : a = b := by
  cases a; cases b; exact rfl

@[simp] theorem PUnit.eq_punit (a : PUnit) : a = ⟨⟩ :=
  PUnit.subsingleton a ⟨⟩

instance : Subsingleton PUnit :=
  Subsingleton.intro PUnit.subsingleton

instance : Inhabited PUnit where
  default := ⟨⟩

instance : DecidableEq PUnit :=
  fun a b => isTrue (PUnit.subsingleton a b)

/- Setoid -/

class Setoid (α : Sort u) where
  r : α → α → Prop
  iseqv {} : Equivalence r

instance {α : Sort u} [Setoid α] : HasEquiv α :=
  ⟨Setoid.r⟩

namespace Setoid

variable {α : Sort u} [Setoid α]

theorem refl (a : α) : a ≈ a :=
  (Setoid.iseqv α).refl a

theorem symm {a b : α} (hab : a ≈ b) : b ≈ a :=
  (Setoid.iseqv α).symm hab

theorem trans {a b c : α} (hab : a ≈ b) (hbc : b ≈ c) : a ≈ c :=
  (Setoid.iseqv α).trans hab hbc

end Setoid

/- Propositional extensionality -/

axiom propext {a b : Prop} : (a ↔ b) → a = b

theorem Eq.propIntro {a b : Prop} (h₁ : a → b) (h₂ : b → a) : a = b :=
  propext <| Iff.intro h₁ h₂

gen_injective_theorems% Prod
gen_injective_theorems% PProd
gen_injective_theorems% MProd
gen_injective_theorems% Subtype
gen_injective_theorems% Fin
gen_injective_theorems% Array
gen_injective_theorems% Sum
gen_injective_theorems% PSum
gen_injective_theorems% Nat
gen_injective_theorems% Option
gen_injective_theorems% List
gen_injective_theorems% Except
gen_injective_theorems% EStateM.Result
gen_injective_theorems% Lean.Name
gen_injective_theorems% Lean.Syntax

/- Quotients -/

-- Iff can now be used to do substitutions in a calculation
theorem iffSubst {a b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  Eq.subst (propext h₁) h₂

namespace Quot
axiom sound : ∀ {α : Sort u} {r : α → α → Prop} {a b : α}, r a b → Quot.mk r a = Quot.mk r b

protected theorem liftBeta {α : Sort u} {r : α → α → Prop} {β : Sort v}
    (f : α → β)
    (c : (a b : α) → r a b → f a = f b)
    (a : α)
    : lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem indBeta {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (p : (a : α) → motive (Quot.mk r a))
    (a : α)
    : (ind p (Quot.mk r a) : motive (Quot.mk r a)) = p a :=
  rfl

protected abbrev liftOn {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : (a b : α) → r a b → f a = f b) : β :=
  lift f c q

protected theorem inductionOn {α : Sort u} {r : α → α → Prop} {motive : Quot r → Prop}
    (q : Quot r)
    (h : (a : α) → motive (Quot.mk r a))
    : motive q :=
  ind h q

theorem existsRep {α : Sort u} {r : α → α → Prop} (q : Quot r) : Exists (fun a => (Quot.mk r a) = q) :=
  Quot.inductionOn (motive := fun q => Exists (fun a => (Quot.mk r a) = q)) q (fun a => ⟨a, rfl⟩)

section
variable {α : Sort u}
variable {r : α → α → Prop}
variable {motive : Quot r → Sort v}

@[reducible, macroInline]
protected def indep (f : (a : α) → motive (Quot.mk r a)) (a : α) : PSigma motive :=
  ⟨Quot.mk r a, f a⟩

protected theorem indepCoherent
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : (a b : α) → r a b → Quot.indep f a = Quot.indep f b  :=
  fun a b e => PSigma.eta (sound e) (h a b e)

protected theorem liftIndepPr1
    (f : (a : α) → motive (Quot.mk r a))
    (h : ∀ (a b : α) (p : r a b), Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r)
    : (lift (Quot.indep f) (Quot.indepCoherent f h) q).1 = q := by
 induction q using Quot.ind
 exact rfl

protected abbrev rec
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    (q : Quot r) : motive q :=
  Eq.ndrecOn (Quot.liftIndepPr1 f h q) ((lift (Quot.indep f) (Quot.indepCoherent f h) q).2)

protected abbrev recOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (h : (a b : α) → (p : r a b) → Eq.ndrec (f a) (sound p) = f b)
    : motive q :=
 Quot.rec f h q

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quot.mk r a))]
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    : motive q := by
  induction q using Quot.rec
  apply f
  apply Subsingleton.elim

protected abbrev hrecOn
    (q : Quot r)
    (f : (a : α) → motive (Quot.mk r a))
    (c : (a b : α) → (p : r a b) → f a ≅ f b)
    : motive q :=
  Quot.recOn q f fun a b p => eqOfHEq <|
    have p₁ : Eq.ndrec (f a) (sound p) ≅ f a := eqRecHEq (sound p) (f a)
    HEq.trans p₁ (c a b p)

end
end Quot

def Quotient {α : Sort u} (s : Setoid α) :=
  @Quot α Setoid.r

namespace Quotient

@[inline]
protected def mk {α : Sort u} [s : Setoid α] (a : α) : Quotient s :=
  Quot.mk Setoid.r a

def sound {α : Sort u} [s : Setoid α] {a b : α} : a ≈ b → Quotient.mk a = Quotient.mk b :=
  Quot.sound

protected abbrev lift {α : Sort u} {β : Sort v} [s : Setoid α] (f : α → β) : ((a b : α) → a ≈ b → f a = f b) → Quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : Setoid α] {motive : Quotient s → Prop} : ((a : α) → motive (Quotient.mk a)) → (q : Quot Setoid.r) → motive q :=
  Quot.ind

protected abbrev liftOn {α : Sort u} {β : Sort v} [s : Setoid α] (q : Quotient s) (f : α → β) (c : (a b : α) → a ≈ b → f a = f b) : β :=
  Quot.liftOn q f c

protected theorem inductionOn {α : Sort u} [s : Setoid α] {motive : Quotient s → Prop}
    (q : Quotient s)
    (h : (a : α) → motive (Quotient.mk a))
    : motive q :=
  Quot.inductionOn q h

theorem existsRep {α : Sort u} [s : Setoid α] (q : Quotient s) : Exists (fun (a : α) => Quotient.mk a = q) :=
  Quot.existsRep q

section
variable {α : Sort u}
variable [s : Setoid α]
variable {motive : Quotient s → Sort v}

@[inline]
protected def rec
    (f : (a : α) → motive (Quotient.mk a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    (q : Quotient s)
    : motive q :=
  Quot.rec f h q

protected abbrev recOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    (h : (a b : α) → (p : a ≈ b) → Eq.ndrec (f a) (Quotient.sound p) = f b)
    : motive q :=
  Quot.recOn q f h

protected abbrev recOnSubsingleton
    [h : (a : α) → Subsingleton (motive (Quotient.mk a))]
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    : motive q :=
  Quot.recOnSubsingleton (h := h) q f

protected abbrev hrecOn
    (q : Quotient s)
    (f : (a : α) → motive (Quotient.mk a))
    (c : (a b : α) → (p : a ≈ b) → f a ≅ f b)
    : motive q :=
  Quot.hrecOn q f c
end

section
universes uA uB uC
variable {α : Sort uA} {β : Sort uB} {φ : Sort uC}
variable [s₁ : Setoid α] [s₂ : Setoid β]

protected abbrev lift₂
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    (q₁ : Quotient s₁) (q₂ : Quotient s₂)
    : φ := by
  apply Quotient.lift (fun (a₁ : α) => Quotient.lift (f a₁) (fun (a b : β) => c a₁ a a₁ b (Setoid.refl a₁)) q₂) _ q₁
  intros
  induction q₂ using Quotient.ind
  apply c; assumption; apply Setoid.refl

protected abbrev liftOn₂
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (f : α → β → φ)
    (c : (a₁ : α) → (b₁ : β) → (a₂ : α) → (b₂ : β) → a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ = f a₂ b₂)
    : φ :=
  Quotient.lift₂ f c q₁ q₂

protected theorem ind₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (h : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₂
    {motive : Quotient s₁ → Quotient s₂ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (h : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    : motive q₁ q₂ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  apply h

protected theorem inductionOn₃
    [s₃ : Setoid φ]
    {motive : Quotient s₁ → Quotient s₂ → Quotient s₃ → Prop}
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (q₃ : Quotient s₃)
    (h : (a : α) → (b : β) → (c : φ) → motive (Quotient.mk a) (Quotient.mk b) (Quotient.mk c))
    : motive q₁ q₂ q₃ := by
  induction q₁ using Quotient.ind
  induction q₂ using Quotient.ind
  induction q₃ using Quotient.ind
  apply h

end

section Exact

variable   {α : Sort u}

private def rel [s : Setoid α] (q₁ q₂ : Quotient s) : Prop :=
  Quotient.liftOn₂ q₁ q₂
    (fun a₁ a₂ => a₁ ≈ a₂)
    (fun a₁ a₂ b₁ b₂ a₁b₁ a₂b₂ =>
      propext (Iff.intro
        (fun a₁a₂ => Setoid.trans (Setoid.symm a₁b₁) (Setoid.trans a₁a₂ a₂b₂))
        (fun b₁b₂ => Setoid.trans a₁b₁ (Setoid.trans b₁b₂ (Setoid.symm a₂b₂)))))

private theorem rel.refl [s : Setoid α] (q : Quotient s) : rel q q :=
  Quot.inductionOn (motive := fun q => rel q q) q (fun a => Setoid.refl a)

private theorem eqImpRel [s : Setoid α] {q₁ q₂ : Quotient s} : q₁ = q₂ → rel q₁ q₂ :=
  fun h => Eq.ndrecOn h (rel.refl q₁)

theorem exact [s : Setoid α] {a b : α} : Quotient.mk a = Quotient.mk b → a ≈ b :=
  fun h => eqImpRel h

end Exact

section
universes uA uB uC
variable {α : Sort uA} {β : Sort uB}
variable [s₁ : Setoid α] [s₂ : Setoid β]

protected abbrev recOnSubsingleton₂
    {motive : Quotient s₁ → Quotient s₂ → Sort uC}
    [s : (a : α) → (b : β) → Subsingleton (motive (Quotient.mk a) (Quotient.mk b))]
    (q₁ : Quotient s₁)
    (q₂ : Quotient s₂)
    (g : (a : α) → (b : β) → motive (Quotient.mk a) (Quotient.mk b))
    : motive q₁ q₂ := by
  induction q₁ using Quot.recOnSubsingleton
  induction q₂ using Quot.recOnSubsingleton
  apply g
  intro a; apply s
  induction q₂ using Quot.recOnSubsingleton
  intro a; apply s
  inferInstance

end
end Quotient

section
variable {α : Type u}
variable (r : α → α → Prop)

instance {α : Sort u} {s : Setoid α} [d : ∀ (a b : α), Decidable (a ≈ b)] : DecidableEq (Quotient s) :=
  fun (q₁ q₂ : Quotient s) =>
    Quotient.recOnSubsingleton₂ (motive := fun a b => Decidable (a = b)) q₁ q₂
      fun a₁ a₂ =>
        match d a₁ a₂ with
        | isTrue h₁  => isTrue (Quotient.sound h₁)
        | isFalse h₂ => isFalse fun h => absurd (Quotient.exact h) h₂

/- Function extensionality -/

namespace Function
variable {α : Sort u} {β : α → Sort v}

def Equiv (f₁ f₂ : ∀ (x : α), β x) : Prop := ∀ x, f₁ x = f₂ x

protected theorem Equiv.refl (f : ∀ (x : α), β x) : Equiv f f :=
  fun x => rfl

protected theorem Equiv.symm {f₁ f₂ : ∀ (x : α), β x} : Equiv f₁ f₂ → Equiv f₂ f₁ :=
  fun h x => Eq.symm (h x)

protected theorem Equiv.trans {f₁ f₂ f₃ : ∀ (x : α), β x} : Equiv f₁ f₂ → Equiv f₂ f₃ → Equiv f₁ f₃ :=
  fun h₁ h₂ x => Eq.trans (h₁ x) (h₂ x)

protected theorem Equiv.isEquivalence (α : Sort u) (β : α → Sort v) : Equivalence (@Function.Equiv α β) := {
  refl := Equiv.refl
  symm := Equiv.symm
  trans := Equiv.trans
}

end Function

section
open Quotient
variable {α : Sort u} {β : α → Sort v}

@[instance]
private def funSetoid (α : Sort u) (β : α → Sort v) : Setoid (∀ (x : α), β x) :=
  Setoid.mk (@Function.Equiv α β) (Function.Equiv.isEquivalence α β)

private def extfunApp (f : Quotient <| funSetoid α β) (x : α) : β x :=
  Quot.liftOn f
    (fun (f : ∀ (x : α), β x) => f x)
    (fun f₁ f₂ h => h x)

theorem funext {f₁ f₂ : ∀ (x : α), β x} (h : ∀ x, f₁ x = f₂ x) : f₁ = f₂ := by
  show extfunApp (Quotient.mk f₁) = extfunApp (Quotient.mk f₂)
  apply congrArg
  apply Quotient.sound
  exact h

end

instance {α : Sort u} {β : α → Sort v} [∀ a, Subsingleton (β a)] : Subsingleton (∀ a, β a) where
  allEq f₁ f₂ :=
    funext (fun a => Subsingleton.elim (f₁ a) (f₂ a))

/- Squash -/

def Squash (α : Type u) := Quot (fun (a b : α) => True)

def Squash.mk {α : Type u} (x : α) : Squash α := Quot.mk _ x

theorem Squash.ind {α : Type u} {motive : Squash α → Prop} (h : ∀ (a : α), motive (Squash.mk a)) : ∀ (q : Squash α), motive q :=
  Quot.ind h

@[inline] def Squash.lift {α β} [Subsingleton β] (s : Squash α) (f : α → β) : β :=
  Quot.lift f (fun a b _ => Subsingleton.elim _ _) s

instance : Subsingleton (Squash α) where
  allEq a b := by
    induction a using Squash.ind
    induction b using Squash.ind
    apply Quot.sound
    trivial

namespace Lean
/- Kernel reduction hints -/

/--
  When the kernel tries to reduce a term `Lean.reduceBool c`, it will invoke the Lean interpreter to evaluate `c`.
  The kernel will not use the interpreter if `c` is not a constant.
  This feature is useful for performing proofs by reflection.

  Remark: the Lean frontend allows terms of the from `Lean.reduceBool t` where `t` is a term not containing
  free variables. The frontend automatically declares a fresh auxiliary constant `c` and replaces the term with
  `Lean.reduceBool c`. The main motivation is that the code for `t` will be pre-compiled.

  Warning: by using this feature, the Lean compiler and interpreter become part of your trusted code base.
  This is extra 30k lines of code. More importantly, you will probably not be able to check your developement using
  external type checkers (e.g., Trepplein) that do not implement this feature.
  Keep in mind that if you are using Lean as programming language, you are already trusting the Lean compiler and interpreter.
  So, you are mainly losing the capability of type checking your developement using external checkers.

  Recall that the compiler trusts the correctness of all `[implementedBy ...]` and `[extern ...]` annotations.
  If an extern function is executed, then the trusted code base will also include the implementation of the associated
  foreign function.
-/
constant reduceBool (b : Bool) : Bool := b

/--
  Similar to `Lean.reduceBool` for closed `Nat` terms.

  Remark: we do not have plans for supporting a generic `reduceValue {α} (a : α) : α := a`.
  The main issue is that it is non-trivial to convert an arbitrary runtime object back into a Lean expression.
  We believe `Lean.reduceBool` enables most interesting applications (e.g., proof by reflection). -/
constant reduceNat (n : Nat) : Nat := n

axiom ofReduceBool (a b : Bool) (h : reduceBool a = b) : a = b
axiom ofReduceNat (a b : Nat) (h : reduceNat a = b)    : a = b

end Lean


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


example : False := _

example : True := trivial

example : True := trivial