/- This module defines the type of values that is used in the dynamic
  semantics of all our intermediate languages. -/

import .lib .integers .floats .ast

namespace values
open integers word floats ast ast.typ ast.memory_chunk

def block : Type := pos_num
instance eq_block : decidable_eq block := by tactic.mk_dec_eq_instance
instance coe_block : has_coe block ℕ := ⟨λp, num.pos p⟩
instance dlo_block : decidable_linear_order block := pos_num.decidable_linear_order
instance block_one : has_one block := ⟨(1 : pos_num)⟩

/- A value is either:
- a machine integer;
- a floating-point number;
- a pointer: a pair of a memory address and an integer offset with respect
  to this address;
- the [Vundef] value denoting an arbitrary bit pattern, such as the
  value of an uninitialized variable.
-/

inductive val : Type
| Vundef  : val
| Vint    : int32 → val
| Vlong   : int64 → val
| Vfloat  : float → val
| Vsingle : float32 → val
| Vptr    : block → ptrofs → val
export val
instance coe_int32_val : has_coe int32 val := ⟨Vint⟩
instance coe_int64_val : has_coe int64 val := ⟨Vlong⟩
instance coe_Int32_val : has_coe (@word W32) val := ⟨Vint⟩
instance coe_Int64_val : has_coe (@word W64) val := ⟨Vlong⟩
instance coe_float_val : has_coe float val := ⟨Vfloat⟩
instance coe_single_val : has_coe float32 val := ⟨Vsingle⟩
instance inhabited_val : inhabited val := ⟨Vundef⟩

def Vzero  : val := Vint 0
def Vone   : val := Vint 1
def Vmone  : val := Vint (-1)
instance val_zero : has_zero val := ⟨Vzero⟩
instance val_one : has_one val := ⟨Vone⟩

def Vtrue  : val := 1
def Vfalse : val := 0

def Vnullptr := if archi.ptr64 then Vlong 0 else Vint 0

def Vptrofs (n : ptrofs) : val :=
if archi.ptr64 then ptrofs.to_int64 n else ptrofs.to_int n

/- * Operations over values -/

/- The module [val] defines a number of arithmetic and logical operations
  over type [val].  Most of these operations are straightforward extensions
  of the corresponding integer or floating-point operations. -/

namespace val

instance val_eq : decidable_eq val := by tactic.mk_dec_eq_instance

def has_type : val → typ → Prop
| Vundef      _       := true
| (Vint _)    Tint    := true
| (Vlong _)   Tlong   := true
| (Vfloat _)  Tfloat  := true
| (Vsingle _) Tsingle := true
| (Vptr _ _)  Tint    := ¬ archi.ptr64
| (Vptr _ _)  Tlong   := archi.ptr64
| (Vint _)    Tany32  := true
| (Vsingle _) Tany32  := true
| (Vptr _ _)  Tany32  := ¬ archi.ptr64
| _           Tany64  := true
| _           _       := false

def has_type_list : list val → list typ → Prop
| []         []         := true
| (v1 :: vs) (t1 :: ts) := has_type v1 t1 ∧ has_type_list vs ts
| _          _          := false

def has_opttype (v : val) : option typ → Prop
| none     := v = Vundef
| (some t) := has_type v t

lemma Vptr_has_type (b ofs) : has_type (Vptr b ofs) Tptr :=
begin
  delta Tptr,
  ginduction archi.ptr64 with h,
  { intro h2, note := h.symm.trans h2, contradiction },
  { exact h }
end

lemma Vnullptr_has_type : has_type Vnullptr Tptr :=
by delta Tptr Vnullptr; cases archi.ptr64; trivial

lemma has_subtype (ty1 ty2 v) : subtype ty1 ty2 → has_type v ty1 → has_type v ty2 := sorry'

lemma has_subtype_list (tyl1 tyl2 vl) :
  subtype_list tyl1 tyl2 → has_type_list vl tyl1 → has_type_list vl tyl2 := sorry'

/- Truth values.  Non-zero integers are treated as [True].
  The integer 0 (also used to represent the null pointer) is [False].
  Other values are neither true nor false. -/

def to_bool : val → option bool
| (Vint n) := some (n ≠ 0)
| _ := none

/- Arithmetic operations -/

protected def neg : val → val
| (Vint n) := word.neg n
| _        := Vundef
instance : has_neg val := ⟨val.neg⟩

def negf : val → val
| (Vfloat f) := float.neg f
| _          := Vundef

def absf : val → val
| (Vfloat f) := float.abs f
| _          := Vundef

def negfs : val → val
| (Vsingle f) := float32.neg f
| _           := Vundef

def absfs : val → val
| (Vsingle f) := float32.abs f
| _           := Vundef

def make_total (ov : option val) : val :=
ov.get_or_else Vundef

def int_of_float : val → option val
| (Vfloat f) := Vint <$> float.to_int f
| _          := none

def intu_of_float : val → option val
| (Vfloat f) := Vint <$> float.to_intu f
| _          := none

def float_of_int : val → option val
| (Vint n) := float.of_int n
| _        := none

def float_of_intu : val → option val
| (Vint n) := float.of_intu n
| _        := none

def int_of_single : val → option val
| (Vsingle f) := Vint <$> float32.to_int f
| _           := none

def intu_of_single : val → option val
| (Vsingle f) := Vint <$> float32.to_intu f
| _           := none

def single_of_int : val → option val
| (Vint n) := float32.of_int n
| _        := none

def single_of_intu : val → option val
| (Vint n) := float32.of_intu n
| _        := none

def negint : val → val
| (Vint n) := word.neg n
| _        := Vundef

def notint : val → val
| (Vint n) := word.not n
| _        := Vundef

def of_bool (b : bool) : val := if b then Vtrue else Vfalse
instance : has_coe bool val := ⟨of_bool⟩

def boolval : val → val
| (Vint n)     := of_bool (n ≠ 0)
| (Vptr b ofs) := Vtrue
| _            := Vundef

def notbool : val → val
| (Vint n)     := of_bool (n = 0)
| (Vptr b ofs) := Vfalse
| _            := Vundef

def zero_ext (nbits : ℕ) : val → val
| (Vint n) := word.zero_ext nbits n
| _        := Vundef

def sign_ext (nbits : ℕ+) : val → val
| (Vint n) := word.sign_ext nbits n
| _        := Vundef

def single_of_float : val → val
| (Vfloat f) := float.to_single f
| _          := Vundef

def float_of_single : val → val
| (Vsingle f) := float.of_single f
| _           := Vundef

protected def add : val → val → val
| (Vint m)       (Vint n)       := Vint $ m + n
| (Vptr b1 ofs1) (Vint n)       := if archi.ptr64 then Vundef else Vptr b1 (ofs1 + ptrofs.of_int n)
| (Vint m)       (Vptr b2 ofs2) := if archi.ptr64 then Vundef else Vptr b2 (ofs2 + ptrofs.of_int m)
| _              _              := Vundef
instance : has_add val := ⟨val.add⟩

protected def sub : val → val → val
| (Vint m)       (Vint n)       := Vint $ m - n
| (Vptr b1 ofs1) (Vint n)       := if archi.ptr64 then Vundef else Vptr b1 (ofs1 - ptrofs.of_int n)
| (Vptr b1 ofs1) (Vptr b2 ofs2) := if archi.ptr64 ∨ b1 ≠ b2 then Vundef else ptrofs.to_int (ofs1 - ofs2)
| _              _              := Vundef
instance : has_sub val := ⟨val.sub⟩

protected def mul : val → val → val
| (Vint m) (Vint n) := Vint (m * n)
| _        _        := Vundef
instance : has_mul val := ⟨val.mul⟩

def mulhs : val → val → val
| (Vint m) (Vint n) := word.mulhs m n
| _        _        := Vundef

def mulhu : val → val → val
| (Vint m) (Vint n) := word.mulhu m n
| _        _        := Vundef

def divs : val → val → option val
| (Vint m) (Vint n) := if n = 0 ∨ m = repr (word.min_signed W32) ∧ n = -1
                       then none else some (m / n : word _)
| _        _        := none

def mods : val → val → option val
| (Vint m) (Vint n) := if n = 0 ∨ m = repr (@min_signed W32) ∧ n = -1
                       then none else some (m % n : word _)
| _        _        := none

def divu : val → val → option val
| (Vint m) (Vint n) := if n = 0 then none else word.divu m n
| _        _        := none

def modu : val → val → option val
| (Vint m) (Vint n) := if n = 0 then none else word.modu m n
| _        _        := none

def add_carry : val → val → val → val
| (Vint m) (Vint n) (Vint c) := word.add_carry m n c
| _        _        _        := Vundef

def sub_overflow : val → val → val
| (Vint m) (Vint n) := word.sub_overflow m n 0
| _        _        := Vundef

def negative : val → val
| (Vint n) := word.negative n
| _        := Vundef

protected def and : val → val → val
| (Vint m) (Vint n) := word.and m n
| _        _        := Vundef

protected def or : val → val → val
| (Vint m) (Vint n) := word.or m n
| _        _        := Vundef

protected def xor : val → val → val
| (Vint m) (Vint n) := word.xor m n
| _        _        := Vundef

def shl : val → val → val
| (Vint m) (Vint n) := if word.ltu n iwordsize
                       then word.shl m n else Vundef
| _        _        := Vundef

def shr : val → val → val
| (Vint m) (Vint n) := if word.ltu n iwordsize
                       then word.shr m n else Vundef
| _        _        := Vundef

def shr_carry : val → val → val
| (Vint m) (Vint n) := if word.ltu n iwordsize
                       then word.shr_carry m n else Vundef
| _        _        := Vundef

def shrx : val → val → option val
| (Vint m) (Vint n) := if word.ltu n (repr 31)
                       then word.shrx m n else none
| _        _        := none

def shru : val → val → val
| (Vint m) (Vint n) := if word.ltu n iwordsize
                       then word.shru m n else Vundef
| _        _        := Vundef

def rol : val → val → val
| (Vint m) (Vint n) := word.rol m n
| _        _        := Vundef

def rolm : val → int32 → int32 → val
| (Vint n) amount mask := word.rolm n amount mask
| _        amount mask := Vundef

def ror : val → val → val
| (Vint m) (Vint n) := word.ror m n
| _        _        := Vundef

def addf : val → val → val
| (Vfloat x) (Vfloat y) := Vfloat $ x + y
| _          _          := Vundef

def subf : val → val → val
| (Vfloat x) (Vfloat y) := Vfloat $ x - y
| _          _          := Vundef

def mulf : val → val → val
| (Vfloat x) (Vfloat y) := Vfloat $ x * y
| _          _          := Vundef

def divf : val → val → val
| (Vfloat x) (Vfloat y) := Vfloat $ x / y
| _          _          := Vundef

def float_of_words : val → val → val
| (Vint m) (Vint n) := float.from_words m n
| _        _        := Vundef

def addfs : val → val → val
| (Vsingle x) (Vsingle y) := float32.add x y
| _           _           := Vundef

def subfs : val → val → val
| (Vsingle x) (Vsingle y) := float32.sub x y
| _           _           := Vundef

def mulfs : val → val → val
| (Vsingle x) (Vsingle y) := float32.mul x y
| _           _           := Vundef

def divfs : val → val → val
| (Vsingle x) (Vsingle y) := float32.div x y
| _           _           := Vundef

/- Operations on 64-bit integers -/

def long_of_words : val → val → val
| (Vint m) (Vint n) := int64.ofwords m n
| _        _        := Vundef

def loword : val → val
| (Vlong n) := int64.loword n
| _         := Vundef

def hiword : val → val
| (Vlong n)  := int64.hiword n
| _ := Vundef

def negl : val → val
| (Vlong n) := Vlong $ -n
| _         := Vundef

def notl : val → val
| (Vlong n) := word.not n
| _ := Vundef

def long_of_int : val → val
| (Vint n) := Vlong $ scoe n
| _        := Vundef

def long_of_intu : val → val
| (Vint n) := Vlong $ ucoe n
| _        := Vundef

def long_of_float : val → option val
| (Vfloat f) := Vlong <$> float.to_long f
| _          := none

def longu_of_float : val → option val
| (Vfloat f) := Vlong <$> float.to_longu f
| _          := none

def long_of_single : val → option val
| (Vsingle f) := Vlong <$> float32.to_long f
| _           := none

def longu_of_single : val → option val
| (Vsingle f) := Vlong <$> float32.to_longu f
| _           := none

def float_of_long : val → option val
| (Vlong n) := float.of_long n
| _         := none

def float_of_longu : val → option val
| (Vlong n) := float.of_longu n
| _         := none

def single_of_long : val → option val
| (Vlong n) := float32.of_long n
| _         := none

def single_of_longu : val → option val
| (Vlong n) := float32.of_longu n
| _         := none

def addl : val → val → val
| (Vlong n1)     (Vlong n2)     := Vlong (n1 + n2)
| (Vptr b1 ofs1) (Vlong n2)     := if archi.ptr64 then Vptr b1 (ofs1 + ptrofs.of_int64 n2) else Vundef
| (Vlong n1)     (Vptr b2 ofs2) := if archi.ptr64 then Vptr b2 (ofs2 + ptrofs.of_int64 n1) else Vundef
| _              _              := Vundef

def subl : val → val → val
| (Vlong n1)     (Vlong n2)     := Vlong (n1 - n2)
| (Vptr b1 ofs1) (Vlong n2)     := if archi.ptr64 then Vptr b1 (ofs1 - ptrofs.of_int64 n2) else Vundef
| (Vptr b1 ofs1) (Vptr b2 ofs2) := if archi.ptr64 ∨ b1 ≠ b2 then Vundef else ptrofs.to_int64 (ofs1 - ofs2)
| _              _              := Vundef

def mull : val → val → val
| (Vlong m) (Vlong n) := Vlong (m * n)
| _         _         := Vundef

def mull' : val → val → val
| (Vint m) (Vint n) := Vlong (ucoe m * ucoe n)
| _        _        := Vundef

def mullhs : val → val → val
| (Vlong m) (Vlong n) := word.mulhs m n
| _         _         := Vundef

def mullhu : val → val → val
| (Vlong m) (Vlong n) := word.mulhu m n
| _         _         := Vundef

def divls : val → val → option val
| (Vlong m) (Vlong n) := if n = 0 ∨ m = repr (min_signed 64) ∧ n = -1
                         then none else some (m / n : word _)
| _         _         := none

def modls : val → val → option val
| (Vlong m) (Vlong n) := if n = 0 ∨ m = repr (min_signed 64) ∧ n = -1
                         then none else some (m % n : word _)
| _         _         := none

def divlu : val → val → option val
| (Vlong m) (Vlong n) := if n = 0 then none else word.divu m n
| _         _         := none

def modlu : val → val → option val
| (Vlong m) (Vlong n) := if n = 0 then none else word.modu m n
| _         _         := none

def subl_overflow : val → val → val
| (Vlong m) (Vlong n) := Vint $ ucoe $ word.sub_overflow m n 0
| _         _         := Vundef

def negativel : val → val
| (Vlong n) := Vint $ ucoe $ word.negative n
| _         := Vundef

def andl : val → val → val
| (Vlong m) (Vlong n) := word.and m n
| _         _         := Vundef

def orl : val → val → val
| (Vlong m) (Vlong n) := word.or m n
| _         _         := Vundef

def xorl : val → val → val
| (Vlong m) (Vlong n) := word.xor m n
| _         _         := Vundef

def shll : val → val → val
| (Vlong m) (Vint n) := if word.ltu n 64 then word.shl m (ucoe n) else Vundef
| _         _        := Vundef

def shrl : val → val → val
| (Vlong m) (Vint n) := if word.ltu n 64 then word.shr m (ucoe n) else Vundef
| _         _        := Vundef

def shrlu : val → val → val
| (Vlong m) (Vint n) := if word.ltu n 64 then word.shru m (ucoe n) else Vundef
| _         _        := Vundef

def shrxl : val → val → option val
| (Vlong m) (Vint n) := if word.ltu n 63 then word.shrx m (ucoe n) else none
| _         _        := none

def roll : val → val → val
| (Vlong m) (Vint n) := word.rol m (ucoe n)
| _         _        := Vundef

def rorl : val → val → val
| (Vlong m) (Vint n) := word.ror m (ucoe n)
| _         _        := Vundef

def rolml : val → int64 → int64 → val
| (Vlong n) amount mask := word.rolm n amount mask
| _         amount mask := Vundef

/- Comparisons -/

section comparisons

parameter valid_ptr : block → ℕ → bool
def weak_valid_ptr (b : block) (ofs : ℕ) := valid_ptr b ofs || valid_ptr b (ofs - 1)

def cmp_bool (c : comparison) : val → val → option bool
| (Vint m) (Vint n) := cmp c m n
| _        _        := none

def cmp_different_blocks : comparison → option bool
| Ceq := some ff
| Cne := some tt
| _   := none

def cmpu_bool (c : comparison) : val → val → option bool
| (Vint m) (Vint n) := some $ cmpu c m n
| (Vint m) (Vptr b2 ofs2) :=
  if archi.ptr64 then none else
  if m = 0 ∧ weak_valid_ptr b2 (unsigned ofs2)
  then cmp_different_blocks c
  else none
| (Vptr b1 ofs1) (Vptr b2 ofs2) :=
  if archi.ptr64 then none else
  if b1 = b2 then
    if weak_valid_ptr b1 (unsigned ofs1) ∧ weak_valid_ptr b2 (unsigned ofs2)
    then cmpu c ofs1 ofs2
    else none
  else
    if valid_ptr b1 (unsigned ofs1) ∧ valid_ptr b2 (unsigned ofs2)
    then cmp_different_blocks c
    else none
| (Vptr b1 ofs1) (Vint n) :=
  if archi.ptr64 then none else
  if n = 0 ∧ weak_valid_ptr b1 (unsigned ofs1)
  then cmp_different_blocks c
  else none
| _ _ := none

def cmpf_bool (c : comparison) : val → val → option bool
| (Vfloat x) (Vfloat y) := float.cmp c x y
| _          _          := none

def cmpfs_bool (c : comparison) : val → val → option bool
| (Vsingle x) (Vsingle y) := float32.cmp c x y
| _           _           := none

def cmpl_bool (c : comparison) : val → val → option bool
| (Vlong m) (Vlong n) := cmp c m n
| _         _         := none

def cmplu_bool (c : comparison) : val → val → option bool
| (Vlong n1) (Vlong n2) := some $ cmpu c n1 n2
| (Vlong n1) (Vptr b2 ofs2) :=
  if archi.ptr64 ∧ n1 = 0 ∧ weak_valid_ptr b2 (unsigned ofs2)
  then cmp_different_blocks c
  else none
| (Vptr b1 ofs1) (Vptr b2 ofs2) :=
  if ¬ archi.ptr64 then none else
  if b1 = b2 then
    if weak_valid_ptr b1 (unsigned ofs1) && weak_valid_ptr b2 (unsigned ofs2)
    then some (cmpu c ofs1 ofs2)
    else none
  else
    if valid_ptr b1 (unsigned ofs1) && valid_ptr b2 (unsigned ofs2)
    then cmp_different_blocks c
    else none
| (Vptr b1 ofs1) (Vlong n2) :=
  if archi.ptr64 ∧ n2 = 0 ∧ weak_valid_ptr b1 (unsigned ofs1)
  then cmp_different_blocks c
  else none
| _ _ := none

def of_optbool : option bool → val
| (some tt) := Vtrue
| (some ff) := Vfalse
| none := Vundef

def cmp (c : comparison) (v1 v2 : val) : val :=
of_optbool $ cmp_bool c v1 v2

def cmpu (c : comparison) (v1 v2 : val) : val :=
of_optbool $ cmpu_bool c v1 v2

def cmpf (c : comparison) (v1 v2 : val) : val :=
of_optbool $ cmpf_bool c v1 v2

def cmpfs (c : comparison) (v1 v2 : val) : val :=
of_optbool $ cmpfs_bool c v1 v2

def cmpl (c : comparison) (v1 v2 : val) : option val :=
of_bool <$> cmpl_bool c v1 v2

def cmplu (c : comparison) (v1 v2 : val) : option val :=
of_bool <$> cmplu_bool c v1 v2

def maskzero_bool : val → int32 → option bool
| (Vint n) mask := some $ word.and n mask = 0
| _        mask := none

end comparisons

/- Add the given offset to the given pointer. -/

def offset_ptr : val → ptrofs → val
| (Vptr b ofs) delta := Vptr b (ofs + delta)
| _            delta := Vundef

/- [load_result] reflects the effect of storing a value with a given
  memory chunk, then reading it back with the same chunk.  Depending
  on the chunk and the type of the value, some normalization occurs.
  For instance, consider storing the integer value [0xFFF] on 1 byte
  at a given address, and reading it back.  If it is read back with
  chunk [Mint8unsigned], zero-extension must be performed, resulting
  in [0xFF].  If it is read back as a [Mint8signed], sign-extension is
  performed and [0xFFFFFFFF] is returned. -/

def load_result : memory_chunk → val → val
| Mint8signed    (Vint n)     := word.sign_ext W8 n
| Mint8unsigned  (Vint n)     := word.zero_ext 8 n
| Mint16signed   (Vint n)     := word.sign_ext W16 n
| Mint16unsigned (Vint n)     := word.zero_ext 16 n
| Mint32         (Vint n)     := Vint n
| Mint32         (Vptr b ofs) := if archi.ptr64 then Vundef else Vptr b ofs
| Mint64         (Vlong n)    := Vlong n
| Mint64         (Vptr b ofs) := if archi.ptr64 then Vptr b ofs else Vundef
| Mfloat32       (Vsingle f)  := Vsingle f
| Mfloat64       (Vfloat f)   := Vfloat f
| Many32         (Vint n)     := Vint n
| Many32         (Vsingle f)  := Vsingle f
| Many32         (Vptr b ofs) := if archi.ptr64 then Vundef else Vptr b ofs
| Many64         v            := v
| _              _            := Vundef

lemma load_result_type (chunk v) : has_type (load_result chunk v) chunk.type := sorry'

lemma load_result_same {v ty} : has_type v ty → load_result (chunk_of_type ty) v = v := sorry'

/- Theorems on arithmetic operations. -/

theorem cast8unsigned_and (x) : zero_ext 8 x = val.and x (0xFF : int32) := sorry'

theorem cast16unsigned_and (x) : zero_ext 16 x = val.and x (0xFFFF : int32) := sorry'

theorem to_bool_of_bool (b1 b2) : (of_bool b1).to_bool = some b2 → b1 = b2 := sorry'

theorem to_bool_of_optbool (ob) : (of_optbool ob).to_bool = ob := sorry'

theorem notbool_negb_1 (b) : of_bool (bnot b) = notbool (of_bool b) := sorry'

theorem notbool_negb_2 (b) : of_bool b = notbool (of_bool (bnot b)) := sorry'

theorem notbool_negb_3 (ob) : of_optbool (bnot <$> ob) = notbool (of_optbool ob) := sorry'

set_option type_context.unfold_lemmas true
theorem notbool_idem2 (b) : notbool (notbool (of_bool b)) = of_bool b :=
by cases b; refl

theorem notbool_idem3 (x) : notbool (notbool (notbool x)) = notbool x := sorry'

theorem notbool_idem4 (ob) : notbool (notbool (of_optbool ob)) = of_optbool ob := sorry'

theorem add_comm (x y : val) : x + y = y + x := sorry'

theorem add_assoc (x y z : val) : (x + y) + z = x + (y + z) := sorry'

theorem neg_zero : (-0 : val) = 0 := sorry'

theorem neg_add (x y : val) : -(x + y) = -x + -y := sorry'

theorem zero_sub (x : val) : 0 - x = -x := sorry'

theorem sub_eq_add_neg (x y) : x - Vint y = x + Vint (-y) := sorry'

theorem sub_neg_eq_add (x y) : x - Vint (-y) = x + Vint y := sorry'

theorem sub_add_eq_add_sub (v1 v2 i) : v1 + Vint i - v2 = v1 - v2 + Vint i := sorry'

theorem sub_add_eq_sub_add_neg (v1 v2 i) : v1 - (v2 + Vint i) = v1 - v2 + Vint (-i) := sorry'

theorem mul_comm (x y : val) : x * y = y * x := sorry'

theorem mul_assoc (x y z : val) : (x * y) * z = x * (y * z) := sorry'

theorem right_distrib (x y z : val) : (x + y) * z = x * z + y * z := sorry'

theorem left_distrib (x y z : val) : x * (y + z) = x * y + x * z := sorry'

theorem mul_pow2 (x n logn) : is_power2 n = some logn →
  x * Vint n = shl x (Vint logn) := sorry'

theorem mods_divs (x y z) : mods x y = some z → ∃ v, divs x y = some v ∧ z = x - v * y := sorry'

theorem modu_divu (x y z) : modu x y = some z → ∃ v, divu x y = some v ∧ z = x - v * y := sorry'

theorem divs_pow2 (x n logn y) : is_power2 n = some logn → word.ltu logn 31 →
  divs x (Vint n) = some y → shrx x (Vint logn) = some y := sorry'

theorem divu_pow2 (x n logn y) : is_power2 n = some logn →
  divu x (Vint n) = some y → shru x (Vint logn) = y := sorry'

theorem modu_pow2 (x n logn y) : is_power2 n = some logn →
  modu x (Vint n) = some y → val.and x (Vint (n - 1)) = y := sorry'

theorem and_comm (x y) : val.and x y = val.and y x := sorry'

theorem and_assoc (x y z) : val.and (val.and x y) z = val.and x (val.and y z) := sorry'

theorem or_comm (x y) : val.or x y = val.or y x := sorry'

theorem or_assoc (x y z) : val.or (val.or x y) z = val.or x (val.or y z) := sorry'

theorem xor_commut (x y) : val.xor x y = val.xor y x := sorry'

theorem xor_assoc (x y z) : val.xor (val.xor x y) z = val.xor x (val.xor y z) := sorry'

theorem not_xor (x) : notint x = val.xor x (Vint (-1)) := sorry'

theorem shl_rolm (x n) : word.ltu n 32 → shl x (Vint n) = rolm x n (word.shl (-1) n) := sorry'

theorem shru_rolm (x n) : word.ltu n 32 →
  shru x (Vint n) = rolm x (32 - n) (word.shru (-1) n) := sorry'

theorem shrx_carry (x y z) : shrx x y = some z →
  shr x y + shr_carry x y = z := sorry'

theorem shrx_shr (x y z) : shrx x y = some z →
  ∃ p, ∃ q, x = Vint p ∧ y = Vint q ∧
    z = shr (if p < 0 then x + Vint (word.shl 1 q - 1) else x) (Vint q) := sorry'

theorem shrx_shr_2 (n x z) : shrx x (Vint n) = some z →
  z = if n = 0 then x else shr (x + shru (shr x 31) (Vint (32 - n))) (Vint n) := sorry'

theorem or_rolm (x n m1 m2) : val.or (rolm x n m1) (rolm x n m2) = rolm x n (word.or m1 m2) := sorry'

theorem rolm_rolm (x n1 m1 n2 m2) : rolm (rolm x n1 m1) n2 m2 =
  rolm x (word.modu (n1 + n2) 32) (word.and (word.rol m1 n2) m2) := sorry'

theorem rolm_zero (x m) : rolm x 0 m = val.and x (Vint m) := sorry'

theorem addl_comm (x y) : addl x y = addl y x := sorry'

theorem addl_assoc (x y z) : addl (addl x y) z = addl x (addl y z) := sorry'

theorem negl_addl_distr (x y) : negl (addl x y) = addl (negl x) (negl y) := sorry'

theorem subl_addl_opp (x y) : subl x (Vlong y) = addl x (Vlong (-y)) := sorry'

theorem subl_opp_addl : ∀ x y, subl x (Vlong (-y)) = addl x (Vlong y) := sorry'

theorem subl_addl_l (v1 v2 i) : subl (addl v1 (Vlong i)) v2 = addl (subl v1 v2) (Vlong i) := sorry'

theorem subl_addl_r (v1 v2 i) : subl v1 (addl v2 (Vlong i)) = addl (subl v1 v2) (Vlong (-i)) := sorry'

theorem mull_comm (x y) : mull x y = mull y x := sorry'

theorem mull_assoc (x y z) : mull (mull x y) z = mull x (mull y z) := sorry'

theorem mull_addl_distr_l (x y z) : mull (addl x y) z = addl (mull x z) (mull y z) := sorry'

theorem mull_addl_distr_r (x y z) : mull x (addl y z) = addl (mull x y) (mull x z) := sorry'

theorem andl_comm (x y) : andl x y = andl y x := sorry'

theorem andl_assoc (x y z) : andl (andl x y) z = andl x (andl y z) := sorry'

theorem orl_comm (x y) : orl x y = orl y x := sorry'

theorem orl_assoc (x y z) : orl (orl x y) z = orl x (orl y z) := sorry'

theorem xorl_commut (x y) : xorl x y = xorl y x := sorry'

theorem xorl_assoc (x y z) : xorl (xorl x y) z = xorl x (xorl y z) := sorry'

theorem notl_xorl (x) : notl x = xorl x (Vlong (-1)) := sorry'

theorem divls_pow2 (x n logn y) : int64.is_power2 n = some logn → word.ltu logn 63 →
  divls x (Vlong n) = some y →
  shrxl x (Vint logn) = some y := sorry'

theorem divlu_pow2 (x n logn y) : int64.is_power2 n = some logn →
  divlu x (Vlong n) = some y →
  shrlu x (Vint logn) = y := sorry'

theorem modlu_pow2 (x n logn y) : int64.is_power2 n = some logn →
  modlu x (Vlong n) = some y →
  andl x (Vlong (n - 1)) = y := sorry'

theorem shrxl_shrl_2 (n x z) : shrxl x (Vint n) = some z →
  z = if n = 0 then x else
    shrl (addl x (shrlu (shrl x (Vint 63)) (Vint (64 - n)))) (Vint n) := sorry'

theorem negate_cmp_bool (c x y) : cmp_bool (negate_comparison c) x y = bnot <$> cmp_bool c x y := sorry'

theorem negate_cmpu_bool (valid_ptr c x y) :
  cmpu_bool valid_ptr (negate_comparison c) x y = bnot <$> cmpu_bool valid_ptr c x y := sorry'

theorem negate_cmpl_bool (c x y) : cmpl_bool (negate_comparison c) x y = bnot <$> cmpl_bool c x y := sorry'

theorem negate_cmplu_bool (valid_ptr c x y) :
  cmplu_bool valid_ptr (negate_comparison c) x y = bnot <$> cmplu_bool valid_ptr c x y := sorry'

lemma not_of_optbool (ob) : of_optbool (bnot <$> ob) = notbool (of_optbool ob) := sorry'

theorem negate_cmp (c x y) : cmp (negate_comparison c) x y = notbool (cmp c x y) := sorry'

theorem negate_cmpu (valid_ptr c x y) :
  cmpu valid_ptr (negate_comparison c) x y =
    notbool (cmpu valid_ptr c x y) := sorry'

theorem swap_cmp_bool (c x y) : cmp_bool (swap_comparison c) x y = cmp_bool c y x := sorry'

theorem swap_cmpu_bool (valid_ptr c x y) :
  cmpu_bool valid_ptr (swap_comparison c) x y = cmpu_bool valid_ptr c y x := sorry'

theorem swap_cmpl_bool (c x y) : cmpl_bool (swap_comparison c) x y = cmpl_bool c y x := sorry'

theorem swap_cmplu_bool (valid_ptr c x y) :
  cmplu_bool valid_ptr (swap_comparison c) x y = cmplu_bool valid_ptr c y x := sorry'

theorem negate_cmpf_eq (v1 v2) : notbool (cmpf Cne v1 v2) = cmpf Ceq v1 v2 := sorry'

theorem negate_cmpf_ne (v1 v2) : notbool (cmpf Ceq v1 v2) = cmpf Cne v1 v2 := sorry'

theorem cmpf_le (v1 v2) : cmpf Cle v1 v2 = val.or (cmpf Clt v1 v2) (cmpf Ceq v1 v2) := sorry'

theorem cmpf_ge (v1 v2) : cmpf Cge v1 v2 = val.or (cmpf Cgt v1 v2) (cmpf Ceq v1 v2) := sorry'

theorem cmp_ne_0_optbool (ob) : cmp Cne (of_optbool ob) 0 = of_optbool ob := sorry'

theorem cmp_eq_1_optbool (ob) : cmp Ceq (of_optbool ob) 1 = of_optbool ob := sorry'

theorem cmp_eq_0_optbool (ob) : cmp Ceq (of_optbool ob) 0 = of_optbool (bnot <$> ob) := sorry'

theorem cmp_ne_1_optbool (ob) : cmp Cne (of_optbool ob) 1 = of_optbool (bnot <$> ob) := sorry'

theorem cmpu_ne_0_optbool (valid_ptr ob) :
  cmpu valid_ptr Cne (of_optbool ob) 0 = of_optbool ob := sorry'

theorem cmpu_eq_1_optbool (valid_ptr ob) :
  cmpu valid_ptr Ceq (of_optbool ob) 1 = of_optbool ob := sorry'

theorem cmpu_eq_0_optbool (valid_ptr ob) :
  cmpu valid_ptr Ceq (of_optbool ob) 0 = of_optbool (bnot <$> ob) := sorry'

theorem cmpu_ne_1_optbool (valid_ptr ob) :
  cmpu valid_ptr Cne (of_optbool ob) 1 = of_optbool (bnot <$> ob) := sorry'

lemma zero_ext_and (n v) : 0 < n → n < 32 →
  val.zero_ext n v = val.and v (Vint (repr (2^n - 1))) := sorry'

lemma rolm_lt_zero (v) : rolm v 1 1 = cmp Clt v 0 := sorry'

lemma rolm_ge_zero (v) : val.xor (rolm v 1 1) 1 = cmp Cge v 0 := sorry'

/- The ``is less defined'' relation between values.
    A value is less defined than itself, and [Vundef] is
    less defined than any value. -/

inductive lessdef : val → val → Prop
| refl (v) : lessdef v v
| undef (v) : lessdef Vundef v

lemma lessdef_of_eq : Π {v1 v2}, v1 = v2 → lessdef v1 v2
| v ._ rfl := lessdef.refl v

lemma lessdef_trans {v1 v2 v3} : lessdef v1 v2 → lessdef v2 v3 → lessdef v1 v3 :=
by intros h1 h2; cases h1; try {assumption}; cases h2; assumption

lemma lessdef_list_inv {vl1 vl2} : list.forall2 lessdef vl1 vl2 → vl1 = vl2 ∨ Vundef ∈ vl1 := sorry'

lemma lessdef_list_trans {vl1 vl2 vl3} :
  list.forall2 lessdef vl1 vl2 → list.forall2 lessdef vl2 vl3 → list.forall2 lessdef vl1 vl3 :=
@list.forall2.trans _ _ @lessdef_trans _ _ _

/- Compatibility of operations with the [lessdef] relation. -/

lemma load_result_lessdef (chunk v1 v2) :
  lessdef v1 v2 → lessdef (load_result chunk v1) (load_result chunk v2) := sorry'

lemma zero_ext_lessdef (n v1 v2) :
  lessdef v1 v2 → lessdef (zero_ext n v1) (zero_ext n v2) := sorry'

lemma sign_ext_lessdef (n v1 v2) :
  lessdef v1 v2 → lessdef (sign_ext n v1) (sign_ext n v2) := sorry'

lemma singleoffloat_lessdef (v1 v2) :
  lessdef v1 v2 → lessdef (single_of_float v1) (single_of_float v2) := sorry'

lemma add_lessdef (v1 v1' v2 v2') :
  lessdef v1 v1' → lessdef v2 v2' → lessdef (v1 + v2) (v1' + v2') := sorry'

lemma addl_lessdef (v1 v1' v2 v2') :
  lessdef v1 v1' → lessdef v2 v2' → lessdef (addl v1 v2) (addl v1' v2') := sorry'

lemma cmpu_bool_lessdef {valid_ptr valid_ptr' : block → ℕ → bool} {c v1 v1' v2 v2' b} :
  (∀ b ofs, valid_ptr b ofs → valid_ptr' b ofs) →
  lessdef v1 v1' → lessdef v2 v2' →
  cmpu_bool valid_ptr c v1 v2 = some b →
  cmpu_bool valid_ptr' c v1' v2' = some b := sorry'

lemma cmplu_bool_lessdef {valid_ptr valid_ptr' : block → ℕ → bool} {c v1 v1' v2 v2' b} :
  (∀ b ofs, valid_ptr b ofs → valid_ptr' b ofs) →
  lessdef v1 v1' → lessdef v2 v2' →
  cmplu_bool valid_ptr c v1 v2 = some b →
  cmplu_bool valid_ptr' c v1' v2' = some b := sorry'

lemma of_optbool_lessdef {ob ob'} :
  (∀ b, ob = some b → ob' = some b) →
  lessdef (of_optbool ob) (of_optbool ob') := sorry'

lemma long_of_words_lessdef {v1 v2 v1' v2'} :
  lessdef v1 v1' → lessdef v2 v2' → lessdef (long_of_words v1 v2) (long_of_words v1' v2') := sorry'

lemma loword_lessdef {v v'} : lessdef v v' → lessdef (loword v) (loword v') := sorry'

lemma hiword_lessdef {v v'} : lessdef v v' → lessdef (hiword v) (hiword v') := sorry'

lemma offset_ptr_zero (v) : lessdef (offset_ptr v 0) v := sorry'

lemma offset_ptr_assoc (v d1 d2) : offset_ptr (offset_ptr v d1) d2 = offset_ptr v (d1 + d2) := sorry'

/- * Values and memory injections -/

/- A memory injection [f] is a function from addresses to either [none]
  or [some] of an address and an offset.  It defines a correspondence
  between the blocks of two memory states [m1] and [m2]:
- if [f b = none], the block [b] of [m1] has no equivalent in [m2];
- if [f b = some (b', ofs)], the block [b] of [m2] corresponds to
  a sub-block at offset [ofs] of the block [b'] in [m2].
-/

def meminj : Type := block → option (block × ℤ)

/- A memory injection defines a relation between values that is the
  identity relation, except for pointer values which are shifted
  as prescribed by the memory injection.  Moreover, [Vundef] values
  inject into any other value. -/

inductive inject (mi : meminj) : val → val → Prop
| int (i) : inject (Vint i) (Vint i)
| long (i) : inject (Vlong i) (Vlong i)
| float (f) : inject (Vfloat f) (Vfloat f)
| single (f) : inject (Vsingle f) (Vsingle f)
| ptr (b1 ofs1 b2 ofs2 delta) :
      mi b1 = some (b2, delta) →
      (ofs2 : ptrofs) = ofs1 + repr delta →
      inject (Vptr b1 ofs1) (Vptr b2 ofs2)
| undef (v) : inject Vundef v

lemma inject_ptrofs (mi i) : inject mi (Vptrofs i) (Vptrofs i) := sorry'

section val_inj_ops

parameter f : meminj

lemma load_result_inject (chunk v1 v2) :
  inject f v1 v2 →
  inject f (load_result chunk v1) (load_result chunk v2) := sorry'

theorem add_inject {v1 v1' v2 v2'} :
  inject f v1 v1' → inject f v2 v2' →
  inject f (v1 + v2) (v1' + v2') := sorry'

theorem sub_inject {v1 v1' v2 v2'} :
  inject f v1 v1' → inject f v2 v2' →
  inject f (v1 - v2) (v1' - v2') := sorry'

theorem addl_inject {v1 v1' v2 v2'} :
  inject f v1 v1' → inject f v2 v2' →
  inject f (addl v1 v2) (addl v1' v2') := sorry'

theorem subl_inject {v1 v1' v2 v2'} :
  inject f v1 v1' → inject f v2 v2' →
  inject f (subl v1 v2) (subl v1' v2') := sorry'

lemma offset_ptr_inject {v v'} (ofs) : inject f v v' →
  inject f (offset_ptr v ofs) (offset_ptr v' ofs) := sorry'

lemma cmp_bool_inject {c v1 v2 v1' v2' b} :
  inject f v1 v1' → inject f v2 v2' →
  cmp_bool c v1 v2 = some b → cmp_bool c v1' v2' = some b := sorry'

parameters (valid_ptr1 valid_ptr2 : block → ℕ → bool)

def weak_valid_ptr1 := weak_valid_ptr valid_ptr1
def weak_valid_ptr2 := weak_valid_ptr valid_ptr2

parameter valid_ptr_inj : ∀ b1 ofs b2 delta, f b1 = some (b2, delta) →
  valid_ptr1 b1 (unsigned (ofs : ptrofs)) →
  valid_ptr2 b2 (unsigned (ofs + repr delta))

parameter weak_valid_ptr_inj : ∀ b1 ofs b2 delta, f b1 = some (b2, delta) →
  weak_valid_ptr1 b1 (unsigned (ofs : ptrofs)) →
  weak_valid_ptr2 b2 (unsigned (ofs + repr delta))

parameter weak_valid_ptr_no_overflow : ∀ b1 ofs b2 delta, f b1 = some (b2, delta) →
  weak_valid_ptr1 b1 (unsigned (ofs : ptrofs)) →
  unsigned ofs + unsigned (repr delta : ptrofs) ≤ @max_unsigned ptrofs.wordsize

parameter valid_different_ptrs_inj : ∀ b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 ≠ b2 →
  valid_ptr1 b1 (unsigned (ofs1 : ptrofs)) →
  valid_ptr1 b2 (unsigned (ofs2 : ptrofs)) →
  f b1 = some (b1', delta1) →
  f b2 = some (b2', delta2) →
  b1' = b2' → unsigned (ofs1 + repr delta1) ≠ unsigned (ofs2 + repr delta2)

lemma cmpu_bool_inject {c v1 v2 v1' v2' b} :
  inject f v1 v1' → inject f v2 v2' →
  cmpu_bool valid_ptr1 c v1 v2 = some b →
  cmpu_bool valid_ptr2 c v1' v2' = some b := sorry'

lemma cmplu_bool_inject {c v1 v2 v1' v2' b} :
  inject f v1 v1' → inject f v2 v2' →
  cmplu_bool valid_ptr1 c v1 v2 = some b →
  cmplu_bool valid_ptr2 c v1' v2' = some b := sorry'

lemma long_of_words_inject {v1 v2 v1' v2'} :
  inject f v1 v1' → inject f v2 v2' →
  inject f (long_of_words v1 v2) (long_of_words v1' v2') := sorry'

lemma loword_inject {v v'} : inject f v v' → inject f (loword v) (loword v') := sorry'

lemma hiword_inject {v v'} : inject f v v' → inject f (hiword v) (hiword v') := sorry'

end val_inj_ops

end val

export val (meminj)

/- Monotone evolution of a memory injection. -/

def inject_incr (f1 f2 : meminj) : Prop :=
∀ ⦃b b' delta⦄, f1 b = some (b', delta) → f2 b = some (b', delta)

lemma inject_incr.refl (f) : inject_incr f f := λ _ _ _, id

lemma inject_incr.trans {f1 f2 f3}
  (i1 : inject_incr f1 f2) (i2 : inject_incr f2 f3) : inject_incr f1 f3 :=
λ b b' d h, i2 (i1 h)

lemma val_inject_incr {f1 f2 v v'} :
  inject_incr f1 f2 → inject f1 v v' → inject f2 v v' := sorry'

lemma val_inject_list_incr {f1 f2 vl vl'}
  (i : inject_incr f1 f2) (il : list.forall2 (inject f1) vl vl') :
  list.forall2 (inject f2) vl vl' :=
il.imp (λ x y, val_inject_incr i)

/- The identity injection gives rise to the "less defined than" relation. -/

def inject_id : meminj := λ b, some (b, 0)

lemma val_inject_id {v1 v2} :
  inject inject_id v1 v2 ↔ val.lessdef v1 v2 := sorry'

lemma val_inject_id_list {vl1 vl2} :
  list.forall2 (inject inject_id) vl1 vl2 ↔ list.forall2 val.lessdef vl1 vl2 :=
list.forall2.iff @val_inject_id

/- Composing two memory injections -/

def val.meminj.comp (f f' : meminj) : meminj := λ b,
do ⟨b', delta⟩ ← f b,
   ⟨b'', delta'⟩ ← f' b',
   return (b'', delta + delta')

lemma inject.comp {f f' v1 v2 v3} :
  inject f v1 v2 → inject f' v2 v3 →
  inject (f.comp f') v1 v3 := sorry'

end values


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
namespace Std
universes u v w w'

namespace PersistentHashMap

inductive Entry (α : Type u) (β : Type v) (σ : Type w) where
  | entry (key : α) (val : β) : Entry α β σ
  | ref   (node : σ) : Entry α β σ
  | null  : Entry α β σ

instance {α β σ} : Inhabited (Entry α β σ) := ⟨Entry.null⟩

inductive Node (α : Type u) (β : Type v) : Type (max u v) where
  | entries   (es : Array (Entry α β (Node α β))) : Node α β
  | collision (ks : Array α) (vs : Array β) (h : ks.size = vs.size) : Node α β

instance {α β} : Inhabited (Node α β) := ⟨Node.entries #[]⟩

abbrev shift         : USize  := 5
abbrev branching     : USize  := USize.ofNat (2 ^ shift.toNat)
abbrev maxDepth      : USize  := 7
abbrev maxCollisions : Nat    := 4

def mkEmptyEntriesArray {α β} : Array (Entry α β (Node α β)) :=
  (Array.mkArray PersistentHashMap.branching.toNat PersistentHashMap.Entry.null)

end PersistentHashMap

structure PersistentHashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] where
  root    : PersistentHashMap.Node α β := PersistentHashMap.Node.entries PersistentHashMap.mkEmptyEntriesArray
  size    : Nat                        := 0

abbrev PHashMap (α : Type u) (β : Type v) [BEq α] [Hashable α] := PersistentHashMap α β

namespace PersistentHashMap
variable {α : Type u} {β : Type v}

def empty [BEq α] [Hashable α] : PersistentHashMap α β := {}

def isEmpty [BEq α] [Hashable α] (m : PersistentHashMap α β) : Bool :=
  m.size == 0

instance [BEq α] [Hashable α] : Inhabited (PersistentHashMap α β) := ⟨{}⟩

def mkEmptyEntries {α β} : Node α β :=
  Node.entries mkEmptyEntriesArray

abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift
abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift
abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1)

inductive IsCollisionNode : Node α β → Prop where
  | mk (keys : Array α) (vals : Array β) (h : keys.size = vals.size) : IsCollisionNode (Node.collision keys vals h)

abbrev CollisionNode (α β) := { n : Node α β // IsCollisionNode n }

inductive IsEntriesNode : Node α β → Prop where
  | mk (entries : Array (Entry α β (Node α β))) : IsEntriesNode (Node.entries entries)

abbrev EntriesNode (α β) := { n : Node α β // IsEntriesNode n }

private theorem size_set {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (i : Fin ks.size) (j : Fin vs.size) (k : α) (v : β)
                           : (ks.set i k).size = (vs.set j v).size := by
  simp [h]

private theorem size_push {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (k : α) (v : β) : (ks.push k).size = (vs.push v).size := by
  simp [h]

partial def insertAtCollisionNodeAux [BEq α] : CollisionNode α β → Nat → α → β → CollisionNode α β
  | n@⟨Node.collision keys vals heq, _⟩, i, k, v =>
    if h : i < keys.size then
      let idx : Fin keys.size := ⟨i, h⟩;
      let k' := keys.get idx;
      if k == k' then
         let j : Fin vals.size := ⟨i, by rw [←heq]; assumption⟩
         ⟨Node.collision (keys.set idx k) (vals.set j v) (size_set heq idx j k v), IsCollisionNode.mk _ _ _⟩
      else insertAtCollisionNodeAux n (i+1) k v
    else
      ⟨Node.collision (keys.push k) (vals.push v) (size_push heq k v), IsCollisionNode.mk _ _ _⟩
  | ⟨Node.entries _, h⟩, _, _, _ => False.elim (nomatch h)

def insertAtCollisionNode [BEq α] : CollisionNode α β → α → β → CollisionNode α β :=
  fun n k v => insertAtCollisionNodeAux n 0 k v

def getCollisionNodeSize : CollisionNode α β → Nat
  | ⟨Node.collision keys _ _, _⟩ => keys.size
  | ⟨Node.entries _, h⟩          => False.elim (nomatch h)

def mkCollisionNode (k₁ : α) (v₁ : β) (k₂ : α) (v₂ : β) : Node α β :=
  let ks : Array α := Array.mkEmpty maxCollisions
  let ks := (ks.push k₁).push k₂
  let vs : Array β := Array.mkEmpty maxCollisions
  let vs := (vs.push v₁).push v₂
  Node.collision ks vs rfl

partial def insertAux [BEq α] [Hashable α] : Node α β → USize → USize → α → β → Node α β
  | Node.collision keys vals heq, _, depth, k, v =>
    let newNode := insertAtCollisionNode ⟨Node.collision keys vals heq, IsCollisionNode.mk _ _ _⟩ k v
    if depth >= maxDepth || getCollisionNodeSize newNode < maxCollisions then newNode.val
    else match newNode with
      | ⟨Node.entries _, h⟩ => False.elim (nomatch h)
      | ⟨Node.collision keys vals heq, _⟩ =>
        let rec traverse (i : Nat) (entries : Node α β) : Node α β :=
          if h : i < keys.size then
            let k := keys.get ⟨i, h⟩
            let v := vals.get ⟨i, heq ▸ h⟩
            let h := hash k
            let h := div2Shift h (shift * (depth - 1))
            traverse (i+1) (insertAux entries h depth k v)
          else
            entries
        traverse 0 mkEmptyEntries
  | Node.entries entries, h, depth, k, v =>
    let j     := (mod2Shift h shift).toNat
    Node.entries $ entries.modify j fun entry =>
      match entry with
      | Entry.null        => Entry.entry k v
      | Entry.ref node    => Entry.ref $ insertAux node (div2Shift h shift) (depth+1) k v
      | Entry.entry k' v' =>
        if k == k' then Entry.entry k v
        else Entry.ref $ mkCollisionNode k' v' k v

def insert [BEq α] [Hashable α] : PersistentHashMap α β → α → β → PersistentHashMap α β
  | { root := n, size := sz }, k, v => { root := insertAux n (hash k) 1 k v, size := sz + 1 }

partial def findAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Option β :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then some (vals.get ⟨i, by rw [←heq]; assumption⟩)
    else findAtAux keys vals heq (i+1) k
  else none

partial def findAux [BEq α] : Node α β → USize → α → Option β
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => none
    | Entry.ref node   => findAux node (div2Shift h shift) k
    | Entry.entry k' v => if k == k' then some v else none
  | Node.collision keys vals heq, _, k => findAtAux keys vals heq 0 k

def find? [BEq α] [Hashable α] : PersistentHashMap α β → α → Option β
  | { root := n, .. }, k => findAux n (hash k) k

@[inline] def getOp [BEq α] [Hashable α] (self : PersistentHashMap α β) (idx : α) : Option β :=
  self.find? idx

@[inline] def findD [BEq α] [Hashable α] (m : PersistentHashMap α β) (a : α) (b₀ : β) : β :=
  (m.find? a).getD b₀

@[inline] def find! [BEq α] [Hashable α] [Inhabited β] (m : PersistentHashMap α β) (a : α) : β :=
  match m.find? a with
  | some b => b
  | none   => panic! "key is not in the map"

partial def findEntryAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Option (α × β) :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then some (k', vals.get ⟨i, by rw [←heq]; assumption⟩)
    else findEntryAtAux keys vals heq (i+1) k
  else none

partial def findEntryAux [BEq α] : Node α β → USize → α → Option (α × β)
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => none
    | Entry.ref node   => findEntryAux node (div2Shift h shift) k
    | Entry.entry k' v => if k == k' then some (k', v) else none
  | Node.collision keys vals heq, _, k => findEntryAtAux keys vals heq 0 k

def findEntry? [BEq α] [Hashable α] : PersistentHashMap α β → α → Option (α × β)
  | { root := n, .. }, k => findEntryAux n (hash k) k

partial def containsAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) : Bool :=
  if h : i < keys.size then
    let k' := keys.get ⟨i, h⟩
    if k == k' then true
    else containsAtAux keys vals heq (i+1) k
  else false

partial def containsAux [BEq α] : Node α β → USize → α → Bool
  | Node.entries entries, h, k =>
    let j     := (mod2Shift h shift).toNat
    match entries.get! j with
    | Entry.null       => false
    | Entry.ref node   => containsAux node (div2Shift h shift) k
    | Entry.entry k' v => k == k'
  | Node.collision keys vals heq, _, k => containsAtAux keys vals heq 0 k

def contains [BEq α] [Hashable α] : PersistentHashMap α β → α → Bool
  | { root := n, .. }, k => containsAux n (hash k) k

partial def isUnaryEntries (a : Array (Entry α β (Node α β))) (i : Nat) (acc : Option (α × β)) : Option (α × β) :=
  if h : i < a.size then
    match a.get ⟨i, h⟩ with
    | Entry.null      => isUnaryEntries a (i+1) acc
    | Entry.ref _     => none
    | Entry.entry k v =>
      match acc with
      | none   => isUnaryEntries a (i+1) (some (k, v))
      | some _ => none
  else acc

def isUnaryNode : Node α β → Option (α × β)
  | Node.entries entries         => isUnaryEntries entries 0 none
  | Node.collision keys vals heq =>
    if h : 1 = keys.size then
      have : 0 < keys.size := by rw [←h]; decide
      some (keys.get ⟨0, this⟩, vals.get ⟨0, by rw [←heq]; assumption⟩)
    else
      none

partial def eraseAux [BEq α] : Node α β → USize → α → Node α β × Bool
  | n@(Node.collision keys vals heq), _, k =>
    match keys.indexOf? k with
    | some idx =>
      let ⟨keys', keq⟩ := keys.eraseIdx' idx
      let ⟨vals', veq⟩ := vals.eraseIdx' (Eq.ndrec idx heq)
      have : keys.size - 1 = vals.size - 1 := by rw [heq]
      (Node.collision keys' vals' (keq.trans (this.trans veq.symm)), true)
    | none     => (n, false)
  | n@(Node.entries entries), h, k =>
    let j       := (mod2Shift h shift).toNat
    let entry   := entries.get! j
    match entry with
    | Entry.null       => (n, false)
    | Entry.entry k' v =>
      if k == k' then (Node.entries (entries.set! j Entry.null), true) else (n, false)
    | Entry.ref node   =>
      let entries := entries.set! j Entry.null
      let (newNode, deleted) := eraseAux node (div2Shift h shift) k
      if !deleted then (n, false)
      else match isUnaryNode newNode with
        | none        => (Node.entries (entries.set! j (Entry.ref newNode)), true)
        | some (k, v) => (Node.entries (entries.set! j (Entry.entry k v)), true)

def erase [BEq α] [Hashable α] : PersistentHashMap α β → α → PersistentHashMap α β
  | { root := n, size := sz }, k =>
    let h := hash k
    let (n, del) := eraseAux n h k
    { root := n, size := if del then sz - 1 else sz }

section
variable {m : Type w → Type w'} [Monad m]
variable {σ : Type w}

@[specialize] partial def foldlMAux (f : σ → α → β → m σ) : Node α β → σ → m σ
  | Node.collision keys vals heq, acc =>
    let rec traverse (i : Nat) (acc : σ) : m σ := do
      if h : i < keys.size then
        let k := keys.get ⟨i, h⟩
        let v := vals.get ⟨i, heq ▸ h⟩
        traverse (i+1) (← f acc k v)
      else
        pure acc
    traverse 0 acc
  | Node.entries entries, acc => entries.foldlM (fun acc entry =>
    match entry with
    | Entry.null      => pure acc
    | Entry.entry k v => f acc k v
    | Entry.ref node  => foldlMAux f node acc)
    acc

@[specialize] def foldlM [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : σ → α → β → m σ) (init : σ) : m σ :=
  foldlMAux f map.root init

@[specialize] def forM [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : α → β → m PUnit) : m PUnit :=
  map.foldlM (fun _ => f) ⟨⟩

@[specialize] def foldl [BEq α] [Hashable α] (map : PersistentHashMap α β) (f : σ → α → β → σ) (init : σ) : σ :=
  Id.run $ map.foldlM f init
end

def toList [BEq α] [Hashable α] (m : PersistentHashMap α β) : List (α × β) :=
  m.foldl (init := []) fun ps k v => (k, v) :: ps

structure Stats where
  numNodes      : Nat := 0
  numNull       : Nat := 0
  numCollisions : Nat := 0
  maxDepth      : Nat := 0

partial def collectStats : Node α β → Stats → Nat → Stats
  | Node.collision keys _ _, stats, depth =>
    { stats with
      numNodes      := stats.numNodes + 1,
      numCollisions := stats.numCollisions + keys.size - 1,
      maxDepth      := Nat.max stats.maxDepth depth }
  | Node.entries entries, stats, depth =>
    let stats :=
      { stats with
        numNodes      := stats.numNodes + 1,
        maxDepth      := Nat.max stats.maxDepth depth }
    entries.foldl (fun stats entry =>
      match entry with
      | Entry.null      => { stats with numNull := stats.numNull + 1 }
      | Entry.ref node  => collectStats node stats (depth + 1)
      | Entry.entry _ _ => stats)
      stats

def stats [BEq α] [Hashable α] (m : PersistentHashMap α β) : Stats :=
  collectStats m.root {} 1

def Stats.toString (s : Stats) : String :=
  s!"\{ nodes := {s.numNodes}, null := {s.numNull}, collisions := {s.numCollisions}, depth := {s.maxDepth}}"

instance : ToString Stats := ⟨Stats.toString⟩

end PersistentHashMap
end Std


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

namespace tactic.interactive

/--
`show_term { tac }` runs the tactic `tac`,
and then prints the term that was constructed.

This is useful for
* constructing term mode proofs from tactic mode proofs, and
* understanding what tactics are doing, and how metavariables are handled.

As an example, in
```
example {P Q R : Prop} (h₁ : Q → P) (h₂ : R) (h₃ : R → Q) : P ∧ R :=
by show_term { tauto }
```
the term mode proof `⟨h₁ (h₃ h₂), eq.mpr rfl h₂⟩` produced by `tauto` will be printed.

As another example, if the goal is `ℕ × ℕ`, `show_term { split, exact 0 }` will
print `refine (0, _)`, and afterwards there will be one remaining goal (of type `ℕ`).
This indicates that `split, exact 0` partially filled in the original metavariable,
but created a new metavariable for the resulting sub-goal.
-/
end Mathlib


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_graph_two_colorable (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
  {
    assume h1,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.edges), from by auto [h1],
    cases h2 with A h2,
    cases h2 with B h2,
    cases h2 with h2 h3,
    show bipartite G, from by auto [h2, h3],
  },
  {
    assume h1,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.edges), from by auto [h1],
    cases h2 with A h2,
    cases h2 with B h2,
    cases h2 with h2 h3,
    have h4 : ∀ a : G, a ∈ A ∨ a ∈ B, from by auto [h2],
    have h5 : ∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.edges, from by auto [h3],
    have h6 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h5],
    have h7 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h6],
    have h8 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, a) ∈ G.edges, from by auto [h6],
    have h9 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, b) ∈ G.edges, from by auto [h6],
    have h10 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges ∧ ¬ (a, a) ∈ G.edges ∧ ¬ (b, b) ∈ G.edges, from by auto [h6, h7, h8, h9],
    have h11 : ∀ a : G, a ∈ A → ¬ (a, a) ∈ G.edges, from by auto [h10],
    have h12 : ∀ a : G, a ∈ B → ¬ (a, a) ∈ G.edges, from by auto [h10],
    have h13 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h10],
    have h14 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h13],
    have h15 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h13],
    have h16 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h14, h15],
    have h17 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h16],
    have h18 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h16],
    have h19 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h17, h18],
    have h20 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h19],
    have h21 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h19],
    have h22 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h20, h21],
    have h23 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h22],
    have h24 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h22],
    have h25 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h23, h24],
    have h26 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h25],
    have h27 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h25],
    have h28 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h26, h27],
    have h29 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h28],
    have h30 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h28],
    have h31 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h29, h30],
    have h32 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h31],
    have h33 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h31],
    have h34 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h32, h33],
    have h35 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges, from by auto [h34],
    have h36 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (b, a) ∈ G.edges, from by auto [h34],
    have h37 : ∀ a b : G, a ∈ A ∧ b ∈ B → ¬ (a, b) ∈ G.edges ∧ ¬ (b, a) ∈ G.edges, from by auto [h35, h36],
    have h38
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bipartite_iff_two_colorable (G : Type*) [graph G] : bipartite G ↔ two_colorable G :=
begin
  split,
  {
    assume h1 : bipartite G,
    have h2 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2), from h1,
    have h3 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅), from by auto [h2],
    have h4 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V), from by auto [h3],
    have h5 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅), from by auto [h4],
    have h6 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2), from by auto [h5],
    have h7 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1), from by auto [h6],
    have h8 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2), from by auto [h7],
    have h9 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2), from by auto [h8],
    have h10 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1), from by auto [h9],
    have h11 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2), from by auto [h10],
    have h12 : ∃ V1 V2 : set G, (∀ v1 ∈ V1, ∀ v2 ∈ V2, (v1, v2) ∉ G.E) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (V1 ∩ V2 = ∅) ∧ (V1 ∪ V2 = G.V) ∧ (V1 ≠ ∅) ∧ (V2 ≠ ∅) ∧ (V1 ≠ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ V1, v ∉ V2) ∧ (∀ v ∈ V2, v ∉ V1) ∧ (∀ v ∈ G.V, v ∈ V1 ∨ v ∈ V2) ∧ (∀ v ∈ G.V
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bipartite_iff_two_colorable {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
  { assume h1 : two_colorable G,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.E), from by auto [h1],
    show bipartite G, from by auto [exists_unique.exists, exists_unique.unique, h2] using [use (h2.left), use (h2.right)],
  },
  { assume h1 : bipartite G,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.E), from by auto [h1],
    have h3 : ∀ a : G, a ∈ (h2.left) ∨ a ∈ (h2.right), from by auto [h2],
    have h4 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → (a, b) ∈ G.E, from by auto [h2],
    have h5 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → (a, b) ∈ G.E, from by auto [h2],
    have h6 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → (a, b) ∈ G.E, from by auto [h2],
    have h7 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → (a, b) ∈ G.E, from by auto [h2],
    have h8 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h4, h5],
    have h9 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h5, h4],
    have h10 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.left)), from by auto [h6, h7],
    have h11 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.right)), from by auto [h7, h6],
    have h12 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h4, h5],
    have h13 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h5, h4],
    have h14 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.right)), from by auto [h6, h7],
    have h15 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.left)), from by auto [h7, h6],
    have h16 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h4, h5],
    have h17 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h5, h4],
    have h18 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.left)), from by auto [h6, h7],
    have h19 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.right)), from by auto [h7, h6],
    have h20 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h4, h5],
    have h21 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h5, h4],
    have h22 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.right)), from by auto [h6, h7],
    have h23 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.left)), from by auto [h7, h6],
    have h24 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h4, h5],
    have h25 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h5, h4],
    have h26 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.left)), from by auto [h6, h7],
    have h27 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.right)), from by auto [h7, h6],
    have h28 : ∀ a b : G, a ∈ (h2.left) ∧ b ∈ (h2.right) → ¬(a ∈ (h2.left) ∧ b ∈ (h2.right)), from by auto [h4, h5],
    have h29 : ∀ a b : G, a ∈ (h2.right) ∧ b ∈ (h2.left) → ¬(a ∈ (h2.right) ∧ b ∈ (h2.left)), from by auto [h5, h4],
    have h30 : ∀ a b : G, a ∈ (h2.right) ∧
end --Needs more than 2000 tokens!

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

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

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

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

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

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

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

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

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

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

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

Setting $b = a$, this becomes:

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

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

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

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

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

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


mutual

inductive TreePos (α : Type u) (β : Type v) where
  | leaf (a : α)
  | node (children : List (List (TreeNeg α β)))

inductive TreeNeg (α : Type u) (β : Type v) where
  | leaf (a : β)
  | node (children : List (List (TreePos α β)))

end

theorem aux_1 [SizeOf α] [SizeOf β] (cs : List (TreePos α β)) : TreePos._sizeOf_6 cs = sizeOf cs :=
  @List.rec (TreePos α β) (fun cs => TreePos._sizeOf_6 cs = sizeOf cs)
    rfl
    (fun h t ih => by
      show 1 + TreePos._sizeOf_1 h + TreePos._sizeOf_6 t = sizeOf (h::t)
      rw ih
      rfl)
    cs

theorem aux_2 [SizeOf α] [SizeOf β] (cs : List (List (TreePos α β))) : TreePos._sizeOf_4 cs = sizeOf cs :=
  @List.rec (List (TreePos α β)) (fun cs => TreePos._sizeOf_4 cs = sizeOf cs)
    rfl
    (fun h t ih =>  by
      show 1 + TreePos._sizeOf_6 h + TreePos._sizeOf_4 t = sizeOf (h :: t)
      rw aux_1
      rw ih
      rfl)
    cs

theorem aux_3 [SizeOf α] [SizeOf β] (cs : List (TreeNeg α β)) : TreePos._sizeOf_5 cs = sizeOf cs :=
  @List.rec (TreeNeg α β) (fun cs => TreePos._sizeOf_5 cs = sizeOf cs)
    rfl
    (fun h t ih => by
      show 1 + TreePos._sizeOf_2 h + TreePos._sizeOf_5 t = sizeOf (h::t)
      rw ih
      rfl)
    cs

theorem aux_4 [SizeOf α] [SizeOf β] (cs : List (List (TreeNeg α β))) : TreePos._sizeOf_3 cs = sizeOf cs :=
  @List.rec (List (TreeNeg α β)) (fun cs => TreePos._sizeOf_3 cs = sizeOf cs)
    rfl
    (fun h t ih => by
      show 1 + TreePos._sizeOf_5 h + TreePos._sizeOf_3 t = sizeOf (h :: t)
      rw ih
      rw aux_3
      rfl)
    cs


import Mathlib.Tactic.Linarith

example (a : ℤ) (h1 : a ≥ 3) : a ≥ 1 := by
  -- linarith
  sorry


import util.data.bijection
import util.data.perm
import util.data.minimum

import unitb.logic
import unitb.scheduling.basic
import unitb.models.simple

import data.set.basic

local attribute [-simp] or.comm or.left_comm or.assoc and.comm and.left_comm and.assoc

namespace scheduling.finite

open nat simple function predicate temporal set scheduling
@[reducible]
def rrobin (lbl : Type) [pos_finite lbl] : Type :=
bijection (fin $ succ $ pos_finite.pred_count lbl) lbl

@[reducible]
def index_t (lbl : Type) [pos_finite lbl] :=
fin $ succ $ pos_finite.pred_count lbl

section

parameter {lbl : Type}
parameter [pos_finite lbl]
parameter t : scheduling.unitb.target_mch lbl

noncomputable def first (req : set lbl)
  (l : rrobin lbl)
: index_t lbl :=
(↓ x, l.f x ∈ req )

noncomputable def sch.current (r : set lbl) (queue : rrobin lbl) : lbl :=
queue.f (first r queue)

structure sch_state : Type :=
  (target : t.σ)
  (queue : rrobin lbl)
  (inv : sch.current (t.req.apply target) queue ∈ t.req.apply target)

lemma first_mem {req : set lbl}
  (l : rrobin lbl)
  (h : req ≠ ∅)
: l.f (first req l) ∈ req :=
begin
  unfold first, apply @minimum_mem _ _ { x | l.f x ∈ req },
  cases set.exists_mem_of_ne_empty h with x h,
  apply @set.ne_empty_of_mem _ _ (l.g x),
  change l.f (l.g x) ∈ req,
  rw l.g_inv, apply h
end

noncomputable def select (req : set lbl)
  (l : rrobin lbl)
: rrobin lbl :=
l ∘ (perm.rotate_right (first req l)).rev

lemma sch.select_inv
  (s : t.σ)
  (q : rrobin lbl)
: sch.current (t.req.apply s) q ∈ t.req.apply s :=
begin
  unfold select sch.current,
  apply first_mem _ (t.req_nemp s),
end

def sch.first : sch_state :=
{ target := t.s₀
, queue := bijection.rev (finite.to_nat _)
, inv := sch.select_inv _ _ }

noncomputable def sch.step : sch_state → sch_state
 | (sch_state.mk target queue P) :=
     { target := t.next (sch.current (t.req.apply target) queue) target P
     , queue := select (t.req.apply target) queue
     , inv := sch.select_inv _ _
     }

def sch.is_step : sch_state → sch_state → Prop
 | s s' := s' = sch.step s

noncomputable def scheduler : program sch_state :=
  { first := sch.first
  , step  := sch.step }

open sch_state unitb subtype has_mem classical

def req : var sch_state (set lbl) :=
t.req ∘' (sch_state.target : var sch_state t.σ)

noncomputable def current  : var sch_state lbl :=
sch.current <$> req <*> queue

def rank (l : lbl) : var (sch_state) ℕ :=
↑ λ s : sch_state, (s.queue.g l).val

open scheduling scheduling.unitb

variable (s : sch_state)
section eq_next_or_rank_eq_or_rank_lt_aux
variable {v : ℕ}
variable {l : lbl}
variable h : (rank l).apply s = v
include h

section left
variable Hlt : s.queue.g l < first (req.apply s) s.queue
include Hlt

private lemma not_requested : l ∉ req.apply s :=
begin
  cases s,
  simp [select,comp,sch.step,sch_state.queue,req,rank] at *,
  intro h₀,
  have h₁ : queue.g l ∈ { x | queue.f x ∈ t.req.apply target },
  { rw [mem_set_of,bijection.g_inv],
    apply h₀ },
  have h₂ := minimum_le h₁,
  apply not_le_of_gt Hlt h₂,
end

private lemma rank_stable : (rank l).apply (sch.step s) = v :=
begin
  cases s,
  simp [select,comp,sch.step,sch_state.queue,req,rank] at *,
  rw [comp_g], unfold comp,
  rw [rev_g ,perm.rotate_right_f_gt_eq_self _ _ Hlt,h] ,
end

end left
section right

variable Hgt : s.queue.g l > first (req.apply s) s.queue
include Hgt
private lemma rank_dec : (rank l).apply (sch.step s) < v :=
begin
  cases s,
  simp [rank,sch.step,select,req] at *,
  rw [comp_g], unfold comp,
  rw [rev_g,perm.rotate_right_f_lt_shifted _ _ Hgt,fin.pred_def,← h],
  apply pred_lt_self_of_pos,
  unfold gt at Hgt,
  rw [fin.lt_def] at Hgt,
  apply lt_of_le_of_lt _ Hgt,
  apply zero_le
end
end right

end eq_next_or_rank_eq_or_rank_lt_aux

lemma eq_next_or_rank_eq_or_rank_lt  {l : lbl} (v : ℕ)
  (h : s ⊨ rank l ≃ v)
: s ⊨ current ≃ ↑l ∨
      ( s ⊨ - (↑l ∊ req) ∧ sch.step s ⊨ rank l ≃ v ) ∨ sch.step s ⊨ rank l ≺ v :=
begin
  -- lifted_pred [temporal.init,sch.is_step] using Hstep h,
  -- rw Hstep, clear Hstep,
  -- revert h, generalize : x 0 = s, intro,
  cases classical.em (s.queue.g l = first ((req t).apply s) s.queue) with Heq Hne,
  { left, cases s,
    simp [sch.step,sch_state.queue,sch_state.target,rank,current,req,comp,sch.current] at h ⊢,
    simp [req] at Heq,
    rw bijection.inverse,
    symmetry, apply Heq, },
  cases lt_or_gt_of_ne Hne with Hlt Hgt ; clear Hne,
  { right, left, split, simp,
    apply not_requested t s ; assumption ,
    apply rank_stable t s ; assumption },
  { right, right,
    apply rank_dec t s ; assumption , },
end

lemma fair_schedule_step  (l : lbl) (v : ℕ)
:  ↑l ∊ req ⋀ rank l ≃ v ↦ rank l ≺ v ⋁ current ≃ l in scheduler :=
begin
  unfold scheduler,
  apply leads_to_step,
  intros σ Heq Hnnext,
  -- simp, simp at Heq Hnnext,
  -- unfold rank function.comp flip sch.step, -- next rank subtype.val,
  cases Heq with Hmem Heq,
  have HH := eq_next_or_rank_eq_or_rank_lt _ _ v Heq,
  rw or_iff_not_imp at HH,
  simp [not_or_iff_not_and_not] at Hnnext HH,
  have HH' := HH Hnnext.right,
  rw [or_iff_not_imp,not_and_iff_not_or_not,not_not_iff_self] at HH',
  left, apply HH', clear HH' HH,
  left, simp at Hmem, assumption
end

lemma stable_queue_ranking (l : lbl) (v : ℕ)
: unless scheduler (rank l ≃ v) (rank l ≺ v ⋁ current ≃ l) :=
begin
  unfold scheduler,
  apply unless_step,
  intros σ Heq Hnnext,
  simp,
  simp [not_or_iff_not_and_not] at Hnnext,
  have := eq_next_or_rank_eq_or_rank_lt _ _ _ Heq, revert this,
  simp, monotonicity, intro h,
  cases h with h h,
  { cases Hnnext.right h, },
  { left, rw [h.right], },
end

lemma INIT
: system.init scheduler (↑sch_state.target ≃ (t.s₀ : var sch_state t.σ)) :=
begin
  simp [system.init,program.init,scheduler],
  refl,
end

lemma STEP
: co' scheduler
    (λ (σ σ' : sch_state),
       ∃ P, σ'.target = t.next (current.apply σ) σ.target P) :=
begin
  unfold co',
  intros σ σ',
  dunfold step has_safety.step is_step,
  intros H,
  have P : (current t).apply σ ∈ (t.req).apply (σ.target),
  { simp [current,req], exact σ.inv,  },
  existsi P,
  rw H,
  unfold function.comp scheduler program.step subtype.val sch.step,
  cases σ,
  simp [sch.step,sch_state.target,current,req],
end

lemma INV
: ∀ σ, σ ⊨ current ∊ t.req ∘' sch_state.target :=
by { assume σ, simp [current,req], apply σ.inv, }

lemma PROG (l : lbl)
:     ↑l ∊ req  >~>  current ≃ l
  in scheduler :=
begin
  apply often_imp_often.induct ℕ _ _ ,
  apply stable_queue_ranking _ l,
  apply fair_schedule_step _ l,
end

end

open scheduling.unitb stream unitb

variable {lbl : Type}
variable [pos_finite lbl]
variable (r : target_mch lbl)

noncomputable def scheduler_spec
: @scheduling.unitb.scheduler lbl r :=
  { s := program $ @sch_state lbl _ r
  , sem := _
  , F := @scheduler _ _ _
  , ch := current r
  , object := _
  , INIT := INIT r
  , STEP := STEP r
  , INV  := INV r
  , PROG := PROG r }

noncomputable instance : unitb.system_sem ((scheduler_spec r).s) :=
(scheduler_spec r).sem

lemma sched' {lbl : Type} [s : finite lbl] [nonempty lbl]
  (r : target_mch lbl)
: ∃ τ : stream r.σ, fair r τ :=
begin
  have h : pos_finite lbl,
  { apply pos_of_finite ; apply_instance },
  apply unitb.scheduling r (scheduling.finite.scheduler_spec r),
end

end scheduling.finite


import .expr_base
import ...phys.time.time

namespace lang.time

universes u
variables
  (K : Type u) [field K] [inhabited K]
  {f : fm K TIME} {sp : spc K f}

/-
Duration
-/
structure duration_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

/-
Time
-/
structure time_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

mutual inductive duration_expr, time_expr {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)
with duration_expr : Type u
| lit (v : duration sp) : duration_expr
| var (v : duration_var sp) : duration_expr
| add_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| neg_dur (d : duration_expr) : duration_expr
| sub_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| sub_time_time (t1 : time_expr) (t2 : time_expr) : duration_expr
| smul_dur (k : K) (d : duration_expr) : duration_expr
with time_expr : Type u
| lit (p : time sp) : time_expr
| var (v : time_var sp) : time_expr
| add_dur_time (d : duration_expr) (t : time_expr) : time_expr

abbreviation duration_env {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) :=
  duration_var sp → duration sp

abbreviation duration_eval {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  duration_env sp → duration_expr sp → duration sp

abbreviation time_env {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  time_var sp → time sp

abbreviation time_eval {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)  :=
  time_env sp → time_expr sp → time sp

structure time_frame_var (K : Type u) [field K] [inhabited K] extends var

inductive time_frame_expr (K : Type u) [field K] [inhabited K] : Type u --{f : fm K T}
| lit (f : fm K TIME) : time_frame_expr
| var (v : time_frame_var K) : time_frame_expr
/-
I have varying opinions on what exactly the parameters to the derived constructor should be.
-/
| derived {f : fm K TIME} {sp : spc K f} (o : time_expr sp) (b : duration_expr sp) : time_frame_expr

structure time_space_var {K : Type u} [field K] [inhabited K] (f : fm K TIME) extends var

inductive time_space_expr {K : Type u} [field K] [inhabited K] (f : fm K TIME) : Type (u+1)
| lit (sp : spc K f) : time_space_expr
| var (v : time_space_var f) : time_space_expr
| mk (f : time_frame_expr K) : time_space_expr

abbreviation time_frame_env (K : Type u) [field K] [inhabited K]  :=
  time_frame_var K → fm K TIME
abbreviation time_frame_eval (K : Type u) [field K] [inhabited K]  :=
  time_frame_env K → time_frame_expr K → fm K TIME

/-You need to indicate explicitly what type of frame you think the space has, because the environment needs
a hint about the expected return type
which does trivialize the point of the environment in a way, since parameterized spc types only
have a single value per frame-/
abbreviation time_space_env {K : Type u} [field K] [inhabited K] (f : fm K TIME)  :=
  time_space_var f → spc K f
abbreviation time_space_eval {K : Type u} [field K] [inhabited K] (f : fm K TIME) :=
  time_space_env f → time_space_expr f → spc K f

--not working -- lean doesn't play nice with notation and dependent types
--notation `[`flit`]` := time_frame_expr.lit flit
--notation `[`slit`]` := time_space_expr.lit slit
--instance {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} : has_coe (time sp) (time_expr sp) := ⟨λt, time_expr.lit t⟩
--instance {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} : has_coe (duration sp) (duration_expr sp) := ⟨λt, duration_expr.lit t⟩
--instance {K : Type u} [field K] [inhabited K] : has_coe (fm K TIME) (time_frame_expr K) := ⟨λf, time_frame_expr.lit f⟩
--instance {K : Type u} [field K] [inhabited K] {f : fm K TIME} : has_coe (spc K f) (time_space_expr K) := ⟨λs, time_space_expr.lit s⟩

#check has_add

class time_has_lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) :=
  (cast : time sp → time_expr sp)
notation `[`tlit`]` := time_has_lit.cast tlit

instance time_lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} : time_has_lit  sp :=
  ⟨λt : time sp, time_expr.lit t⟩

class duration_has_lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) :=
  (cast : duration sp → duration_expr sp)
notation `[`tlit`]` := duration_has_lit.cast tlit

instance duration_lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} : duration_has_lit  sp :=
  ⟨λt : duration sp, duration_expr.lit t⟩

class time_frame_has_lit (K : Type u) [field K] [inhabited K] :=
  (cast : fm K TIME → time_frame_expr K)
notation `[`flit`]` := time_frame_has_lit.cast flit

instance time_frame_lit {K : Type u} [field K] [inhabited K] : time_frame_has_lit K :=
  ⟨λf, time_frame_expr.lit f⟩

class time_space_has_lit {K : Type u} [field K] [inhabited K] (f : fm K TIME) :=
  (cast : spc K f → time_space_expr f)
notation `[`slit`]` := time_space_has_lit.cast slit

instance time_space_lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} : time_space_has_lit f :=
  ⟨λs, time_space_expr.lit s⟩

/-
Analogous methods provided at math layer
-/
#check mk_frame
def mk_time_frame_expr {f : fm K TIME} {sp : spc K f} (o : time_expr sp) (b : duration_expr sp) : time_frame_expr K :=
  time_frame_expr.derived o b
/-
4/7
WRITE THIS FUNCTION LATER.
YOU NEED TO GET THE VALUE OUT OF THE f PARAMETER TO INCLUDE IT IN THE TYPE
AND THEN USE IT IN THE CONSTRUCTOR
-/
#check mk_space
def mk_time_space_expr (K : Type u) [field K] [inhabited K] (f : time_frame_expr K) : time_space_expr K :=
  time_space_expr.mk f

def add_dur_expr_dur_expr (v1 v2 : duration_expr sp) : duration_expr sp :=
  duration_expr.add_dur_dur v1 v2

def smul_dur_expr (k : K) (v : duration_expr sp) : duration_expr sp :=
    duration_expr.smul_dur k v

def neg_dur_expr (v : duration_expr sp) : duration_expr sp :=
    duration_expr.neg_dur v

def sub_dur_expr_dur_expr (v1 v2 : duration_expr sp) : duration_expr sp :=    -- v1-v2
    duration_expr.sub_dur_dur v1 v2

-- See unframed file for template for proving vector_space

instance has_add_dur_expr : has_add (duration_expr sp) := ⟨ add_dur_expr_dur_expr K ⟩
lemma add_assoc_dur_expr : ∀ a b c : duration_expr sp, a + b + c = a + (b + c) := sorry
instance add_semigroup_dur_expr : add_semigroup (duration_expr sp) := ⟨ add_dur_expr_dur_expr K, add_assoc_dur_expr K⟩

def dur_expr_zero  := duration_expr.lit (mk_duration sp 0)
instance has_zero_dur_expr : has_zero (duration_expr sp) := ⟨dur_expr_zero K⟩

lemma zero_add_dur_expr : ∀ a : duration_expr sp, 0 + a = a := sorry
lemma add_zero_dur_expr : ∀ a : duration_expr sp, a + 0 = a := sorry
instance add_monoid_dur_expr : add_monoid (duration_expr sp) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    -- has_zero
    dur_expr_zero K,
    -- new structure
    @zero_add_dur_expr K _ _ f sp,
    add_zero_dur_expr K
⟩

instance has_neg_dur_expr : has_neg (duration_expr sp) := ⟨neg_dur_expr K⟩
instance has_sub_dur_expr : has_sub (duration_expr sp) := ⟨ sub_dur_expr_dur_expr K⟩
lemma sub_eq_add_neg_dur_expr : ∀ a b : duration_expr sp, a - b = a + -b := sorry
instance sub_neg_monoid_dur_expr : sub_neg_monoid (duration_expr sp) := ⟨
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K,
    zero_add_dur_expr K,
    add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,                                                       -- new
⟩

lemma add_left_neg_dur_expr : ∀ a : duration_expr sp, -a + a = 0 := sorry
instance : add_group (duration_expr sp) := ⟨
    -- sub_neg_monoid
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K, zero_add_dur_expr K, add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,
    -- new
    add_left_neg_dur_expr K,
⟩

lemma add_comm_dur_expr : ∀ a b : duration_expr sp, a + b = b + a := sorry
instance add_comm_semigroup_dur_expr : add_comm_semigroup (duration_expr sp) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    add_comm_dur_expr K,
⟩

instance add_comm_monoid_dur_expr : add_comm_monoid (duration_expr sp) := ⟨
-- add_monoid
    -- add_semigroup
    add_dur_expr_dur_expr K,
    add_assoc_dur_expr K,
    -- has_zero
    dur_expr_zero K,
    -- new structure
    zero_add_dur_expr K,
    add_zero_dur_expr K,
-- add_comm_semigroup (minus repeats)
    add_comm_dur_expr K,
⟩

instance has_scalar_dur_expr : has_scalar K (duration_expr sp) := ⟨
smul_dur_expr K,
⟩

lemma one_smul_dur_expr : ∀ b : duration_expr sp, (1 : K) • b = b := sorry
lemma mul_smul_dur_expr : ∀ (x y : K) (b : duration_expr sp), (x * y) • b = x • y • b := sorry
instance mul_action_dur_expr : mul_action K (duration_expr sp) := ⟨
one_smul_dur_expr K,
mul_smul_dur_expr K,
⟩

lemma smul_add_dur_expr : ∀(r : K) (x y : duration_expr sp), r • (x + y) = r • x + r • y := sorry
lemma smul_zero_dur_expr : ∀(r : K), r • (0 : duration_expr sp) = 0 := sorry
instance distrib_mul_action_K_dur_exprKx : distrib_mul_action K (duration_expr sp) := ⟨
smul_add_dur_expr K,
smul_zero_dur_expr K,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_dur_expr : ∀ (a b : K) (x : duration_expr sp), (a + b) • x = a • x + b • x := sorry
lemma zero_smul_dur_expr : ∀ (x : duration_expr sp), (0 : K) • x = 0 := sorry
instance semimodule_K_durationK : semimodule K (duration_expr sp) := ⟨ add_smul_dur_expr K, zero_smul_dur_expr  K⟩

instance add_comm_group_dur_expr : add_comm_group (duration_expr sp) := ⟨
-- add_group
    add_dur_expr_dur_expr K, add_assoc_dur_expr K, dur_expr_zero K, zero_add_dur_expr K, add_zero_dur_expr K, -- add_monoid
    neg_dur_expr K,                                                                  -- has_neg
    sub_dur_expr_dur_expr K,                                                              -- has_sub
    sub_eq_add_neg_dur_expr K,
    add_left_neg_dur_expr K,
-- commutativity
    add_comm_dur_expr K,
⟩

instance : vector_space K (duration_expr sp) := sorry

/-
    ********************
    *** Affine space ***
    ********************
-/

/-
Affine operations
-/
instance : has_add (duration_expr sp) := ⟨add_dur_expr_dur_expr K⟩
instance : has_zero (duration_expr sp) := ⟨dur_expr_zero K⟩
instance : has_neg (duration_expr sp) := ⟨neg_dur_expr K⟩

/-
Lemmas needed to implement affine space API
-/

def sub_time_expr_time_expr {f : fm K TIME} {sp : spc K f } (p1 p2 : time_expr sp) : duration_expr sp :=
    duration_expr.sub_time_time p1 p2
def add_time_expr_dur_expr {f : fm K TIME} {sp : spc K f } (p : time_expr sp) (v : duration_expr sp) : time_expr sp :=
    time_expr.add_dur_time v p
def add_dur_expr_time_expr {f : fm K TIME} {sp : spc K f } (v : duration_expr sp) (p : time_expr sp) : time_expr sp :=
    time_expr.add_dur_time v p

def aff_dur_expr_group_action : duration_expr sp → time_expr sp → time_expr sp := add_dur_expr_time_expr K
instance : has_vadd (duration_expr sp) (time_expr sp) := ⟨aff_dur_expr_group_action K⟩

lemma zero_dur_expr_vadd'_a1 : ∀ p : time_expr sp, (0 : duration_expr sp) +ᵥ p = p := sorry
lemma dur_expr_add_assoc'_a1 : ∀ (g1 g2 : duration_expr sp) (p : time_expr sp), g1 +ᵥ (g2 +ᵥ p) = (g1 + g2) +ᵥ p := sorry
instance dur_expr_add_action: add_action (duration_expr sp) (time_expr sp) :=
⟨ aff_dur_expr_group_action K, zero_dur_expr_vadd'_a1 K, dur_expr_add_assoc'_a1  K⟩

def aff_time_expr_group_sub : time_expr sp → time_expr sp → duration_expr sp := sub_time_expr_time_expr K
instance time_expr_has_vsub : has_vsub (duration_expr sp) (time_expr sp) := ⟨ aff_time_expr_group_sub K ⟩

instance : nonempty (time_expr sp) := ⟨time_expr.lit (mk_time sp  0)⟩

lemma time_expr_vsub_vadd_a1 : ∀ (p1 p2 : (time_expr sp)), (p1 -ᵥ p2) +ᵥ p2 = p1 := sorry
lemma time_expr_vadd_vsub_a1 : ∀ (g : duration_expr sp) (p : time_expr sp), g +ᵥ p -ᵥ p = g := sorry
instance aff_time_expr_torsor : add_torsor (duration_expr sp) (time_expr sp) := --affine space!
⟨
    aff_dur_expr_group_action K,
    zero_dur_expr_vadd'_a1 K,    -- add_action
    dur_expr_add_assoc'_a1 K,   -- add_action
    aff_time_expr_group_sub K,    -- has_vsub
    time_expr_vsub_vadd_a1 K,     -- add_torsor
    time_expr_vadd_vsub_a1 K,     -- add_torsor
⟩

/-
+  : d s -> d s -> d s
•  : K -> d s -> d s
+ᵥ : d s -> t s -> t s
-ᵥ : t s -> t s -> d s

Here s is an affine coordinate
space on TIME. Otherwise we've
got time points and durations,
within, but not across, spaces.
-/

/-
Transform
-/
structure transform_var {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) extends var
/-
inductive transform_expr {K : Type u} [field K] [inhabited K]
  --{f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2:=sp1 : spc K f2)
 -- (sp1 : Σf1 : fm K TIME, spc K f1)  (sp2 : Σf2 : fm K TIME, spc K f2 := sp1)
  : Π {f1 : fm K TIME} (sp1 : spc K f1), Π {f2 : fm K TIME} (sp2 : spc K f2), Type u
| lit {f1 : fm K TIME} (sp1 : spc K f1) {f2 : fm K TIME} (sp2 : spc K f2) (p : time_transform sp1 sp2) : transform_expr sp1 sp2
| var (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_var sp1.2 sp2.2) : transform_expr sp1 sp2
| apply_duration (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_expr sp1 sp2) (d : duration_expr sp1.2) : transform_expr sp1 sp2
| compose (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2)  (v : time_transform sp1.2 sp2.2)
  (sp3 : Σf3 : fm K TIME, spc K f3)  (v : time_transform sp1 sp2) : transform_expr sp1 sp3
-/
/-
invalid occurrence of recursive arg#7 of 'lang.time.transform_expr.compose', the body of the functional type depends on it.
All Messages (28)

PROBLEM WITH TRANSFORM EXPRESSIONS
-/
/-
inductive transform_expr' {K : Type u} [field K] [inhabited K]
  --{f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2:=sp1 : spc K f2)
 -- (sp1 : Σf1 : fm K TIME, spc K f1)  (sp2 : Σf2 : fm K TIME, spc K f2 := sp1)
  : Π {f1 : fm K TIME} (sp1 : spc K f1), Π {f2 : fm K TIME} (sp2 : spc K f2), Type u
| lit {f1 : fm K TIME} (sp1 : spc K f1) {f2 : fm K TIME} (sp2 : spc K f2) (p : time_transform sp1 sp2)
    : transform_expr' sp1 sp2
| var (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_var sp1.2 sp2.2)
    : transform_expr' sp1.2 sp2.2
| apply_duration (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_expr' sp1.2 sp2.2) (d : duration_expr sp1.2)
    : transform_expr' sp1.2 sp2.2
| compose (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2)  (v : transform_expr' sp1.2 sp2.2)
  (sp3 : Σf3 : fm K TIME, spc K f3)  (v : transform_expr' sp2.2 sp3.2)
    : transform_expr' sp1.2 sp3.2
-/

inductive transform_expr {K : Type u} [field K] [inhabited K]
  --{f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2:=sp1 : spc K f2)
 -- (sp1 : Σf1 : fm K TIME, spc K f1)  (sp2 : Σf2 : fm K TIME, spc K f2 := sp1)
  : Π {f1 : fm K TIME} (sp1 : spc K f1), Π {f2 : fm K TIME} (sp2 : spc K f2), Type u
| lit {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2} (p : time_transform sp1 sp2) : transform_expr sp1 sp2
| var {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2} (v : transform_var sp1 sp2) : transform_expr sp1 sp2
| apply_duration {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2} (v : transform_expr sp1 sp2) (d : duration_expr sp1) : transform_expr sp1 sp2
| compose_lit {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2} (v : time_transform sp1 sp2)
  {f3 : fm K TIME} {sp3 : spc K f3}  (v : time_transform sp2 sp3) : transform_expr sp1 sp3

class time_transform_has_lit {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} (sp1 : spc K f1) {f2 : fm K TIME} (sp2 : spc K f2) :=
  (cast : time_transform sp1 sp2 → transform_expr sp1 sp2)
notation `[`tlit`]` := time_transform_has_lit.cast tlit

instance time_transform_lit {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2} : time_transform_has_lit sp1 sp2 :=
  ⟨λt, transform_expr.lit t⟩

/-

inductive transform_expr {K : Type u} [field K] [inhabited K]
  --{f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2:=sp1 : spc K f2)
 -- (sp1 : Σf1 : fm K TIME, spc K f1)  (sp2 : Σf2 : fm K TIME, spc K f2 := sp1)
  : Σf1 : fm K TIME, spc K f1 → Σf2 : fm K TIME, spc K f2 → Type u
| lit (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (p : time_transform sp1.1 sp1.2) : transform_expr
--| var (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_var sp1.1 sp1.2) : transform_expr sp1 sp2
--| apply_duration (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2) (v : transform_expr ) (d : duration_expr sp) : transform_expr sp1 sp2
--| compose (sp1 : Σf1 : fm K TIME, spc K f1) (sp2 : Σf2 : fm K TIME, spc K f2)  (v : transform_expr sp1 sp2)
 -- (sp3 : Σf3 : fm K TIME, spc K f3)  (v : transform_expr sp2 sp3) : transform_expr sp1 sp3

-/

abbreviation transform_env {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2)  :=
  transform_var sp1 sp2 → time_transform sp1 sp2

abbreviation transform_eval  {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) :=
  transform_env sp1 sp2 → transform_expr sp1 sp2 → time_transform sp1 sp2

variables {f2 : fm K TIME} (sp2 : spc K f2)

structure env {K : Type u} [field K] [inhabited K]
  --      {f : fm K TIME} (sp : spc K f) {f2 : fm K TIME} {sp2 : spc K f2} :=
  :=
  (duration : Π {f : fm K TIME}, Π (sp : spc K f), duration_env sp )
  (time : Π {f : fm K TIME}, Π (sp : spc K f), time_env sp )
  (transform : Π {f1 : fm K TIME}, Π (sp1 : spc K f1), Π {f2 : fm K TIME}, Π (sp2 : spc K f2), transform_env sp1 sp2)
  (frame : time_frame_env K)
  (space : Π (f : fm K TIME), time_space_env f)

def env.init (K : Type u) [field K] [inhabited K]  : env :=
  ⟨
    (λf: fm K TIME, λsp, λv, ⟨mk_vectr sp 1⟩),
    (λf: fm K TIME, λsp, λv, ⟨mk_point sp 0⟩),
    (λf: fm K TIME, λsp1, λf2, λsp2, (λv, sp1.time_tr sp2)),
    (λv, time_std_frame K),
    (λf, (λv, mk_space K f))
  ⟩

structure eval {K : Type u} [field K] [inhabited K] :=
  (duration : Π {f : fm K TIME}, Π (sp : spc K f), duration_eval sp )
  (time : Π {f : fm K TIME}, Π (sp : spc K f), time_eval sp )
  (transform : Π {f1 : fm K TIME}, Π (sp1 : spc K f1), Π {f2 : fm K TIME}, Π (sp2 : spc K f2), transform_eval sp1 sp2)
  (frame : time_frame_eval K)
  (space : Π (f : fm K TIME), time_space_eval f)

def eval.init (K : Type u) [field K] [inhabited K] : eval :=
  ⟨
    (λf: fm K TIME, λsp, λenv_,λexpr_, ⟨mk_vectr sp 1⟩),
    (λf: fm K TIME, λsp, λenv_,λexpr_, ⟨mk_point sp 0⟩),
    (λf: fm K TIME, λsp1, λf2, λsp2, (λenv_,λexpr_, sp1.time_tr sp2 : transform_eval sp1 sp2)),
    (λenv_, λexpr_, time_std_frame K),
    (λf, λenv_, λexpr_, mk_space K f)
  ⟩
end lang.time


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

/-! ## Boolean equality -/

/-- `PartialEquivBEq α` says that the `BEq` implementation is a
partial equivalence relation, that is:
* it is symmetric: `a == b → b == a`
* it is transitive: `a == b → b == c → a == c`.
-/
class PartialEquivBEq (α) [BEq α] : Prop where
  /-- Symmetry for `BEq`. If `a == b` then `b == a`. -/
  symm : (a : α) == b → b == a
  /-- Transitivity for `BEq`. If `a == b` and `b == c` then `a == c`. -/
  trans : (a : α) == b → b == c → a == c

@[simp] theorem beq_eq_false_iff_ne [BEq α] [LawfulBEq α]
    (a b : α) : (a == b) = false ↔ a ≠ b := by
  rw [ne_eq, ← beq_iff_eq a b]
  cases a == b <;> decide