import MLIR.Doc
import MLIR.Dialects
open Lean PrettyPrinter

open MLIR.Doc
open Pretty -- open typeclass for `doc`

namespace MLIR.AST

-- Affine expressions [TODO: find some way to separate this out]
-- ==================
inductive AffineExpr
| Var: String -> AffineExpr

instance : Pretty AffineExpr where
  doc e := match e with
  | AffineExpr.Var v => doc v

deriving instance DecidableEq for AffineExpr

inductive AffineTuple
| mk: List AffineExpr -> AffineTuple

instance : Pretty AffineTuple where
  doc t := match t with
  | AffineTuple.mk es => [doc| "(" (es),*  ")"]

deriving instance DecidableEq for AffineTuple

inductive AffineMap
| mk: AffineTuple -> AffineTuple -> AffineMap

 instance : Pretty AffineMap where
  doc t := match t with
  | AffineMap.mk xs ys => doc xs ++ " -> " ++ doc ys

deriving instance DecidableEq for AffineMap

-- EMBEDDING
-- ==========

inductive BBName
| mk: String -> BBName

instance : Pretty BBName where
  doc name := match name with
              | BBName.mk s => [doc| "^" s]

deriving instance DecidableEq for BBName

inductive Dimension
| Known: Nat -> Dimension
| Unknown: Dimension

deriving instance DecidableEq for Dimension

inductive SSAVal : Type where
  | SSAVal : String -> SSAVal
deriving DecidableEq

def SSAValToString (s: SSAVal): String :=
  match s with
  | SSAVal.SSAVal str => str

instance : ToString SSAVal where
  toString := SSAValToString

inductive TensorElem :=
| int: Int -> TensorElem
| float: Float -> TensorElem
| bool: Bool -> TensorElem
| nested: List TensorElem -> TensorElem
| empty: TensorElem

inductive Signedness :=
| Signless -- i*
| Unsigned -- u*
| Signed   -- si*
deriving DecidableEq

inductive MLIRType (δ: Dialect α σ ε) :=
| int: Signedness -> Nat -> MLIRType δ
| float: Nat -> MLIRType δ
| tensor1d: MLIRType δ -- tensor of int values.
| tensor2d: MLIRType δ -- tensor of int values.
| tensor4d: MLIRType δ -- tensor of int values.
| index:  MLIRType δ
| undefined: String → MLIRType δ
| extended: σ → MLIRType δ
| erased: MLIRType δ -- A type that is erased by dialect retraction.

-- We define "MLIRTy" to be just the basic types outside of any dialect
abbrev MLIRTy := @MLIRType _ _ _ Dialect.empty
-- Other useful abbreviations
abbrev MLIRType.i1: MLIRType δ := MLIRType.int .Signless 1
abbrev MLIRType.i32: MLIRType δ := MLIRType.int .Signless 32

-- An SSA value with a type
abbrev TypedSSAVal (δ: Dialect α σ ε) := SSAVal × MLIRType δ

mutual
-- | TODO: factor Symbol out from AttrValue
inductive AttrValue (δ: Dialect α σ ε) :=
| symbol: String -> AttrValue δ -- symbol ref attr
| str : String -> AttrValue δ
| int : Int -> MLIRType δ -> AttrValue δ
| nat: Nat -> AttrValue δ
| bool : Bool -> AttrValue δ
| float : Float -> MLIRType δ -> AttrValue δ
| type : MLIRType δ -> AttrValue δ
| affine: AffineMap -> AttrValue δ
| permutation: List Nat -> AttrValue δ -- a permutation
| list: List (AttrValue δ) -> AttrValue δ
-- | guaranteee: both components will be AttrValue δ.Symbol.
-- | TODO: factor symbols out.
| nestedsymbol: AttrValue δ -> AttrValue δ -> AttrValue δ
| alias: String -> AttrValue δ
| dict: AttrDict δ -> AttrValue δ
| opaque_: (dialect: String) -> (value: String) -> AttrValue δ
| opaqueElements: (dialect: String) -> (value: String) -> (type: MLIRType δ) -> AttrValue δ
| unit: AttrValue δ
| extended: α → AttrValue δ
| erased: AttrValue δ

-- https://mlir.llvm.org/docs/LangRef/#attributes
-- | TODO: add support for mutually inductive records / structures
inductive AttrEntry (δ: Dialect α σ ε) :=
  | mk: (key: String)
      -> (value: AttrValue δ)
      -> AttrEntry δ

inductive AttrDict (δ: Dialect α σ ε) :=
| mk: List (AttrEntry δ) -> AttrDict δ

end

-- We define "AttrVal" to be just the basic attributes outside of any dialect
abbrev AttrVal := @AttrValue _ _ _ Dialect.empty

mutual
-- | TODO: make this `record` when mutual records are allowed?
-- | TODO: make these arguments optional?
inductive Op (δ: Dialect α σ ε) where
 | mk: (name: String)
      -> (res: List (TypedSSAVal δ))
      -> (args: List (TypedSSAVal δ))
      -> (regions: List (Region δ))
      -> (attrs: AttrDict δ)
      -> Op δ

inductive Region (δ: Dialect α σ ε) where
| mk: (name: String)
      -> (args: List (TypedSSAVal δ))
      -> (ops: List (Op δ)) -> Region δ

end

-- Attribute definition on the form #<name> = <val>
inductive AttrDefn (δ: Dialect α σ ε) where
| mk: (name: String) -> (val: AttrValue δ) -> AttrDefn δ

-- | TODO: this seems like a weird exception. Is this really true?
inductive Module (δ: Dialect α σ ε) where
| mk: (functions: List (Op δ))
      -> (attrs: List (AttrDefn δ))
      ->  Module δ

def Op.name: Op δ -> String
| Op.mk name .. => name

def Op.res: Op δ -> List (TypedSSAVal δ)
| Op.mk _ res .. => res

def Op.resNames: Op δ → List SSAVal
| Op.mk _ res .. => res.map Prod.fst

def Op.resTypes: Op δ → List (MLIRType δ)
| Op.mk _ res .. => res.map Prod.snd

def Op.args: Op δ -> List (TypedSSAVal δ)
| Op.mk _ _ args .. => args

def Op.argNames: Op δ → List SSAVal
| Op.mk _ _ args .. => args.map Prod.fst

def Op.argTypes: Op δ → List (MLIRType δ)
| Op.mk _ _ args .. => args.map Prod.snd

def Op.regions: Op δ -> List (Region δ)
| Op.mk _ _ _ regions _ => regions

def Op.attrs: Op δ -> AttrDict δ
| Op.mk _ _ _ _ attrs => attrs

instance: Coe String SSAVal where
  coe (s: String) := SSAVal.SSAVal s

instance : Coe Int TensorElem where
  coe (i: Int) := TensorElem.int i

instance : Coe  (List Int) TensorElem where
  coe (xs: List Int) := TensorElem.nested (xs.map TensorElem.int)

instance : Coe String (AttrValue δ) where
  coe (s: String) := AttrValue.str s

instance : Coe Int (AttrValue δ) where
  coe (i: Int) := AttrValue.int i (MLIRType.int .Signless 64)

instance : Coe (MLIRType δ) (AttrValue δ) where
  coe (t: MLIRType δ) := AttrValue.type t

instance : Coe (String × AttrValue δ) (AttrEntry δ) where
  coe (v: String × AttrValue δ) := AttrEntry.mk v.fst v.snd

instance : Coe (String × MLIRType δ) (AttrEntry δ) where
  coe (v: String × MLIRType δ) := AttrEntry.mk v.fst (AttrValue.type v.snd)

instance : Coe  (AttrEntry δ) (String × AttrValue δ) where
  coe (v: AttrEntry δ) :=
  match v with
  | AttrEntry.mk key val => (key, val)

instance : Coe (List (AttrEntry δ)) (AttrDict δ) where
  coe (v: List (AttrEntry δ)) := AttrDict.mk v

 instance : Coe (AttrDict δ) (List (AttrEntry δ)) where
  coe (v: AttrDict δ) := match v with | AttrDict.mk as => as

-- Coercions across dialects

mutual
variable [δ₁: Dialect α₁ σ₁ ε₁] [δ₂: Dialect α₂ σ₂ ε₂] [c: CoeDialect δ₁ δ₂]

def coeMLIRType: MLIRType δ₁ → MLIRType δ₂
  | .int sgn n   => .int sgn n
  | .float n     => .float n
  | .index       => .index
  | .undefined n => .undefined n
  | .tensor1d => .tensor1d
  | .tensor2d => .tensor2d
  | .tensor4d => .tensor4d
  | .erased => .erased
  | .extended s  => .extended (c.coe_σ s)

def coeMLIRTypeList: List (MLIRType δ₁) → List (MLIRType δ₂)
  | []    => []
  | τ::τs => coeMLIRType τ :: coeMLIRTypeList τs
end

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (MLIRType δ₁) (MLIRType δ₂) where
  coe := coeMLIRType

-- Useful locally when dealing with tuple types
instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (List (MLIRType δ₁)) (List (MLIRType δ₂)) where
  coe := coeMLIRTypeList

-- Useful locally when dealing with basic block arguments
instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (List (SSAVal × MLIRType δ₁)) (List (SSAVal × MLIRType δ₂)) where
  coe := List.map (fun (v, τ) => (v, Coe.coe τ))

def Region.name (region: Region δ): BBName :=
  match region with
  | Region.mk name args ops => BBName.mk name

def Region.ops (region: Region δ): List (Op δ) :=
  match region with
  | Region.mk name args ops => ops

-- TODO: delete CoeDialect
mutual
variable [δ₁: Dialect α₁ σ₁ ε₁] [δ₂: Dialect α₂ σ₂ ε₂] [c: CoeDialect δ₁ δ₂]

private def coeAttrValue: AttrValue δ₁ → AttrValue δ₂
  | .nat n => .nat n
  | .symbol s => .symbol s
  | .permutation p => .permutation p
  | .str s => .str s
  | .int i τ => .int i τ
  | .bool b => .bool b
  | .float f τ => .float f τ
  | .type τ => .type τ
  | .affine map => .affine map
  | .list l => .list (coeAttrValueList l)
  | .nestedsymbol a₁ a₂ => .nestedsymbol (coeAttrValue a₁) (coeAttrValue a₂)
  | .alias s => .alias s
  | .dict d => .dict (coeAttrDict d)
  | .opaque_ d v => .opaque_ d v
  | .opaqueElements d v τ => .opaqueElements d v τ
  | .unit => .unit
  | .extended a => .extended (c.coe_α a)
  | .erased => .erased

private def coeAttrValueList: List (AttrValue δ₁) → List (AttrValue δ₂)
  | [] => []
  | v :: values => coeAttrValue v :: coeAttrValueList values

private def coeAttrEntry: AttrEntry δ₁ → AttrEntry δ₂
  | .mk key value => .mk key (coeAttrValue value)

private def coeAttrEntryList: List (AttrEntry δ₁) → List (AttrEntry δ₂)
  | [] => []
  | e :: entries => coeAttrEntry e :: coeAttrEntryList entries

private def coeAttrDict: AttrDict δ₁ → AttrDict δ₂
  | .mk entries => .mk <| coeAttrEntryList entries
end

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (AttrValue δ₁) (AttrValue δ₂) where
  coe := coeAttrValue

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (AttrEntry δ₁) (AttrEntry δ₂) where
  coe := coeAttrEntry

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (AttrDict δ₁) (AttrDict δ₂) where
  coe := coeAttrDict

mutual
variable [δ₁: Dialect α₁ σ₁ ε₁] [δ₂: Dialect α₂ σ₂ ε₂] [c: CoeDialect δ₁ δ₂]

def coeOp: Op δ₁ → Op δ₂
  | .mk name res args  regions attrs =>
      .mk name res args  (coeRegionList regions) (Coe.coe attrs)

def coeOpList:
    List (Op δ₁) → List (Op δ₂)
  | [] => []
  | s :: ops => coeOp s :: coeOpList ops

def coeRegion: Region δ₁ → Region δ₂
  | .mk name args ops => .mk name args (coeOpList ops)

def coeRegionList: List (Region δ₁) → List (Region δ₂)
  | [] => []
  | r :: rs => coeRegion r :: coeRegionList rs

end

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (Op δ₁) (Op δ₂) where
  coe := coeOp

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (List (Op δ₁)) (List (Op δ₂)) where
  coe := coeOpList

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (Region δ₁) (Region δ₂) where
  coe := coeRegion

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (List (Region δ₁)) (List (Region δ₂)) where
  coe := coeRegionList

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (Region δ₁) (Region δ₂) where
  coe := coeRegion

instance {δ₁: Dialect α₁ σ₁ ε₁} {δ₂: Dialect α₂ σ₂ ε₂} [CoeDialect δ₁ δ₂]:
    Coe (List (Region δ₁)) (List (Region δ₂)) where
  coe := coeRegionList

instance : Pretty Signedness where
  doc sgn :=
    match sgn with
    | .Signless => "Signless"
    | .Unsigned => "Unsigned"
    | .Signed => "Signed"

instance : Pretty Dimension where
  doc dim :=
  match dim with
  | Dimension.Unknown => "?"
  | Dimension.Known i => doc i

partial instance : Pretty TensorElem where
  doc (t: TensorElem) :=
    let rec go (t: TensorElem) :=
      match t with
       | TensorElem.int i => doc i
       | TensorElem.bool b => doc b
       | TensorElem.float f => doc f
       | TensorElem.nested ts => [doc| "["  (ts.map go),* "]" ]
       | TensorElem.empty => ""
    go t

-- | TODO: allow typeclass instances inside mutual blocks
mutual
variable {α σ ε} [δ: Dialect α σ ε]

partial def docMLIRType: MLIRType δ → Doc
  | .int .Signless k => [doc| "i"k]
  | .int .Unsigned k => [doc| "u"k]
  | .int .Signed k => [doc| "si"k]
  | .float k => [doc| "f"k]
  | .tensor1d => [doc| "tensor1d"]
  | .tensor2d => [doc| "tensor2d"]
  | .tensor4d => [doc| "tensor4d"]
  | .index => [doc| "index"]
  | .undefined name => [doc| "!" name]
  | .erased => [doc| "erased"]
  | .extended sig => DialectTypeIntf.typeStr ε sig

partial def docAttrVal: AttrValue δ → Doc
  | .symbol s => "@" ++ doc_surround_dbl_quot s
  | .permutation ps => [doc| "[permutation " (ps),* "]"]
  | .nestedsymbol s t => (docAttrVal s) ++ "::" ++ (docAttrVal t)
  | .str str => doc_surround_dbl_quot str
  | .type ty => docMLIRType ty
  | .int i ty => doc i ++ " : " ++ docMLIRType ty
  | .nat i => doc i ++ " : " ++ "index"
  | .bool b => if b then "true" else "false"
  | .float f ty => doc f ++ " : " ++ docMLIRType ty
  | .affine aff => "affine_map<" ++ doc aff ++ ">"
  | .list xs => "[" ++ Doc.Nest (vintercalate_doc (xs.map docAttrVal) ", ") ++ "]"
  | .alias a => "#" ++ a
  | .dict d => docAttrDict d
  | .opaque_ dialect val => [doc| "#" (dialect) "<"  (val) ">"]
  | .opaqueElements dialect val ty => [doc| "#opaque<" (dialect) ","  (val) ">" ":" (docMLIRType ty)]
  | .unit => "()"
  | .extended a => DialectAttrIntf.str a
  | .erased => "<erased>"

partial def docAttrEntry: AttrEntry δ → Doc
  | .mk k v => k ++ " = " ++ (docAttrVal v)

partial def docAttrDict: AttrDict δ → Doc
  | .mk attrs =>
      if List.isEmpty attrs
      then Doc.Text ""
      else "{" ++ Doc.Nest (vintercalate_doc (attrs.map docAttrEntry)  ", ")  ++ "}"
end

instance : Pretty (MLIRType δ) where
 doc := docMLIRType

instance : Pretty (AttrValue δ) where
 doc := docAttrVal

instance : Pretty (AttrEntry δ) where
  doc := docAttrEntry

instance : Pretty (AttrDict δ) where
   doc := docAttrDict

instance : Pretty (AttrDefn δ) where
  doc (v: AttrDefn δ) :=
  match v with
  | AttrDefn.mk name val => "#" ++ name ++ " := " ++ (doc val)

instance : Pretty SSAVal where
   doc (val: SSAVal) :=
     match val with
     | SSAVal.SSAVal name => Doc.Text ("%" ++ name)

instance : ToFormat SSAVal where
    format (x: SSAVal) := layout80col (doc x)

-- | TODO: allow mutual definition of typeclass instances. This code
-- | would be so much nicer if I could pretend that these had real instances.
mutual

def op_to_doc (op: Op δ): Doc :=
    match op with
    | (Op.mk name res args rgns attrs) =>
        /- v3: macros + if stuff-/
        [doc|
          "\"" name "\""
          "(" (op.argNames),* ")"
          (ifdoc rgns.isEmpty then "" else "(" (nest (list_rgn_to_doc rgns);*) ")")
          attrs]

        /- v2: macros, but no if stuff
        [doc|
          "\"" name "\""
          "(" (args),* ")"
          (if bbs.isEmpty then [doc| ""] else [doc| "[" (bbs),* "]"])
          (if rgns.isEmpty then [doc| ""] else[doc| "(" (nest rgns.map rgn_to_doc);* ")"])
          attrs ":" ty] -/

        /- v1: no macros
        let doc_name := doc_surround_dbl_quot name
        let doc_bbs := if bbs.isEmpty
                       then doc ""
                       else "[" ++ intercalate_doc bbs ", " ++ "]"
        let doc_rgns :=
            if rgns.isEmpty
            then Doc.Text ""
            else " (" ++ nest_vgroup (rgns.map rgn_to_doc) ++ ")"
        let doc_args := "(" ++ intercalate_doc args ", " ++ ")"

        doc_name ++ doc_args ++  doc_bbs ++ doc_rgns ++ doc attrs ++ " : " ++ doc ty -/

def list_op_to_doc: List (Op δ) → List Doc
  | [] => []
  | op :: ops => op_to_doc op :: list_op_to_doc ops

-- | TODO: fix the dugly syntax
def rgn_to_doc: Region δ → Doc
  | (Region.mk name args ops) =>
    [doc| {
        (ifdoc args.isEmpty
         then  "^" name ":"
         else  "^" name "(" (args.map $ fun (v, t) => [doc| v ":" t]),* ")" ":");
        (nest list_op_to_doc ops);* ; } ]

def list_rgn_to_doc: List (Region δ) → List Doc
  | [] => []
  | r :: rs => rgn_to_doc r :: list_rgn_to_doc rs
end

instance : Pretty (Op δ) where
  doc := op_to_doc

instance : Pretty (Region δ) where
  doc := rgn_to_doc

instance : Pretty (Region δ) where
  doc := rgn_to_doc

def AttrEntry.key (a: AttrEntry δ): String :=
match a with
| AttrEntry.mk k v => k

def AttrEntry.value (a: AttrEntry δ): AttrValue δ :=
match a with
| AttrEntry.mk k v => v

def AttrDict.empty : AttrDict δ := AttrDict.mk []

def Op.empty (name: String) : Op δ := Op.mk name [] [] [] AttrDict.empty

-- | TODO: needs to happen in a monad to ensure that ty has the right type!
def Op.addArg (o: Op δ) (arg: TypedSSAVal δ): Op δ :=
  match o with
  | Op.mk name res args regions attrs =>
    Op.mk name res (args ++ [arg])  regions attrs

def Op.addResult (o: Op δ) (new_res: TypedSSAVal δ): Op δ :=
 match o with
 | Op.mk name res args  regions attrs =>
    Op.mk name (res ++ [new_res]) args  regions attrs

def Op.appendRegion (o: Op δ) (r: Region δ): Op δ :=
  match o with
  | Op.mk name res args regions attrs =>
      Op.mk name res args (regions ++ [r]) attrs

-- | Note: AttrEntry can be given as String × AttrValue
def AttrDict.add (attrs: AttrDict δ) (entry: AttrEntry δ): AttrDict δ :=
    Coe.coe $ (entry :: Coe.coe attrs)

def AttrDict.find (attrs: AttrDict δ) (name: String): Option (AttrValue δ) :=
  match attrs with
  | AttrDict.mk entries =>
      match entries.find? (fun entry => entry.key == name) with
      | some v => v.value
      | none => none

def AttrDict.find_nat (attrs: AttrDict δ)
  (name: String): Option Nat :=
  match attrs.find name with
  | .some (AttrValue.nat i) =>  .some i
  | _ => .none

def AttrDict.find_int (attrs: AttrDict δ)
  (name: String): Option (Int × MLIRType δ) :=
  match attrs.find name with
  | .some (AttrValue.int i ty) =>  .some (i, ty)
  | _ => .none

def AttrDict.find_int' (attrs: AttrDict δ) (name: String): Option Int :=
  match attrs.find name with
  | .some (AttrValue.int i _) =>  .some i
  | _ => .none

@[simp] theorem AttrDict.find_none {δ: Dialect α σ ε}:
    AttrDict.find (δ := δ) (AttrDict.mk []) n' = none := by
  simp [AttrDict.find, List.find?]

@[simp] theorem AttrDict.find_next {δ: Dialect α σ ε} (v: AttrValue δ)
  (l: List (AttrEntry δ)):
    AttrDict.find (AttrDict.mk (AttrEntry.mk n v :: l)) n' =
    if n == n' then some v else AttrDict.find (AttrDict.mk l) n' := by
  cases H: n == n' <;>
  simp [AttrDict.find, List.find?, AttrEntry.key, AttrEntry.value, H]

def AttrDict.addString (attrs: AttrDict δ) (k: String) (v: String): AttrDict δ :=
    AttrEntry.mk k (v: AttrValue δ) :: attrs

def AttrDict.addType (attrs: AttrDict δ) (k: String) (v: MLIRType δ): AttrDict δ :=
    AttrEntry.mk k (v: AttrValue δ) :: attrs

def Op.addAttr (o: Op δ) (k: String) (v: AttrValue δ): Op δ :=
 match o with
 | Op.mk name res args regions attrs =>
    Op.mk name res args regions (attrs.add (k, v))

def Region.empty (name: String): Region δ := Region.mk name [] []
def Region.appendOp (bb: Region δ) (op: Op δ): Region δ :=
  match bb with
  | Region.mk name args bbs => Region.mk name args (bbs ++ [op])

def Region.appendOps (bb: Region δ) (ops: List (Op δ)): Region δ :=
  match bb with
  | Region.mk name args bbs => Region.mk name args (bbs ++ ops)

instance : Pretty (Op δ) where
  doc := op_to_doc

instance : Pretty (Region δ) where
  doc := rgn_to_doc

instance [Pretty a] : ToString a where
  toString (v: a) := layout80col (doc v)

instance : ToFormat (Op δ) where
    format (x: Op δ) := layout80col (doc x)

instance : Inhabited (MLIRType δ) where
  default := MLIRType.undefined "INHABITANT"

instance : Inhabited (AttrValue δ) where
  default := AttrValue.str "INHABITANT"

instance : Inhabited (Op δ) where
  default := Op.empty "INHABITANT"

instance : Inhabited (Region δ) where
  default := Region.empty "INHABITANT"

instance : Pretty (Module δ) where
  doc (m: Module δ) :=
    match m with
    | Module.mk fs attrs =>
      Doc.VGroup (attrs.map doc ++ fs.map doc)

def Region.fromOps (os: List (Op δ)) (name: String := "entry"): Region δ :=
  Region.mk name [] os

def Region.setArgs (bb: Region δ) (args: List (SSAVal × MLIRType δ)) : Region δ :=
match bb with
  | (Region.mk name _ ops) => (Region.mk name args ops)

end MLIR.AST


theorem modifySize {A : Type u} (as : Array A) (f : A → A) (n : Nat) : (as.modify n f).size = as.size := by
  simp [Array.modify, Array.modifyM, Id.run]; split <;> simp [Id.run]

structure Idx (p : Array String) where
  n : Fin p.size

structure Store where
  arr : Array String
  -- integer pointers into `arr`, type-indexed by `arr`
  ids : Array (Idx arr)

instance {arr : Array String} {f : String → String} {n : Nat} : Coe (Array (Idx arr)) (Array (Idx (arr.modify n f))) where
  coe xs :=
    xs.map (fun x => Idx.mk ((modifySize arr f n) ▸ x.n))

def store1 : Store := {
  arr := #["a", "b", "c", "d", "e"]
  ids := #[⟨2, by simp⟩]
}

def tryCoeStore := {
  store1 with
  -- using a lambda here hangs
  arr := store1.arr.modify 2 (fun _ => "Z")
}


/-
File: signature_recover_public_key_reduce_soundness.lean

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

open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.bigint

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

/- starkware.cairo.common.cairo_secp.field.reduce autogenerated soundness theorem -/

theorem auto_sound_reduce
    -- arguments
    (range_check_ptr : F) (x : UnreducedBigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_reduce σ.pc)
    -- all dependencies are in memory
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 107))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 59))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 6))
    (hin_x : x = cast_UnreducedBigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 31 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 6)) (mem $ τ.ap - 4)
        (spec_reduce mem κ range_check_ptr x (mem (τ.ap - 4)) (cast_BigInt3 mem (τ.ap - 3)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_reduce at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_sub hpc1 (auto_sound_nondet_bigint3 mem _ range_check_ptr _ _),
  { rw hpc2, norm_num2, exact h_mem_4 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [arg0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call3 ap3 h_call3,
  rcases h_call3 with ⟨h_call3_ap_offset, h_call3⟩,
  rcases h_call3 with ⟨rc_m3, rc_mle3, hl_range_check_ptr₁, h_call3⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap3 - 4) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  generalize' hr_rev_reduced_x: cast_BigInt3 mem (ap3 - 3) = reduced_x,
  simp only [hr_rev_reduced_x] at h_call3,
  have htv_reduced_x := hr_rev_reduced_x.symm, clear hr_rev_reduced_x,
  try { simp only [arg0] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0] at h_call3 },
  rw [hin_range_check_ptr] at h_call3,
  clear arg0,
  -- function call
  step_assert_eq hpc3 with arg0,
  step_assert_eq hpc4 with arg1,
  step_assert_eq hpc5 with arg2,
  step_assert_eq hpc6 with arg3,
  step_sub hpc7 (auto_sound_verify_zero mem _ range_check_ptr₁ {
    d0 := x.d0 - reduced_x.d0,
    d1 := x.d1 - reduced_x.d1,
    d2 := x.d2 - reduced_x.d2
  } _ _ _),
  { rw hpc8, norm_num2, exact h_mem_7 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, htv_range_check_ptr₁, htv_reduced_x] },
    try { dsimp [cast_UnreducedBigInt3, cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), (eq_sub_of_eq_add arg3)] },
    try { simp only [h_call3_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, htv_range_check_ptr₁, htv_reduced_x] },
      try { dsimp [cast_UnreducedBigInt3, cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), (eq_sub_of_eq_add arg3)] },
      try { simp only [h_call3_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call9 ap9 h_call9,
  rcases h_call9 with ⟨h_call9_ap_offset, h_call9⟩,
  rcases h_call9 with ⟨rc_m9, rc_mle9, hl_range_check_ptr₂, h_call9⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap9 - 1) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3] at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3] at h_call9 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call9,
  clear arg0 arg1 arg2 arg3,
  -- return
  step_assert_eq hpc9 with hret0,
  step_assert_eq hpc10 with hret1,
  step_assert_eq hpc11 with hret2,
  step_ret hpc12,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call3_ap_offset ,h_call9_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m3+rc_m9+0+0), split,
  linarith [rc_mle3, rc_mle9],
  split,
  { arith_simps, try { simp only [hret0 ,hret1 ,hret2] },
    rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_reduce mem _ range_check_ptr x _ _,
  { apply sound_reduce, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_reduce],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call3],
  use_only [range_check_ptr₁],
  use_only [reduced_x],
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
  have spec3 := h_call3 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec3,
  try { dsimp at spec3, arith_simps at spec3 },
  use_only [spec3],
  use_only [κ_call9],
  use_only [range_check_ptr₂],
  have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
  have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
  have spec9 := h_call9 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec9,
  try { dsimp at spec9, arith_simps at spec9 },
  use_only [spec9],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_x, htv_range_check_ptr₁, htv_reduced_x, htv_range_check_ptr₂] }, },
  try { dsimp [cast_UnreducedBigInt3, cast_BigInt3] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2] },
  try { simp only [h_call3_ap_offset, h_call9_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import Init.Classical
import AssertCmd

namespace EVM

deriving instance Repr for ByteArray
deriving instance DecidableEq for ByteArray

structure PushArg where
  bytes : ByteArray
  pf : bytes.size > 0 ∧ bytes.size <= 32

instance : BEq PushArg := { beq := fun a b => a.bytes == b.bytes }

instance : Repr PushArg where
  reprPrec x n := reprPrec x.bytes n

-- instance

inductive InstrExpr where
| IAdd
| IMul
| ISub
| IDiv
| ISdiv
| IMod
| ISmod
| IAddmod
| IMulmod
| IExp
| ISignextend
| ILt
| IGt
| ISlt
| ISgt
| IEq
| IIszero
| IAnd
| IOr
| IXor
| INot
| IByte
| IShl
| IShr
| ISar
| ISha3
deriving Repr, BEq

inductive InstrCtxt where
| IAddress
| IBalance
| IOrigin
| ICaller
| ICallvalue
| ICalldataload
| ICalldatasize
| ICalldatacopy
| ICodesize
| ICodecopy
| IGasprice
| IExtcodesize
| IExtcodecopy
| IReturndatasize
| IReturndatacopy
| IExtcodehash
| IBlockhash
| ICoinbase
| ITimestamp
| INumber
| IDifficulty
| IGaslimit
| IChainid
| ISelfbalance
| IBasefee
deriving Repr, BEq

inductive InstrMem where
| IPop
| IMload
| IMstore
| IMstore8
| ISload
| ISstore
deriving Repr, BEq

inductive InstrOther where
| IStop
| IJump
| IJumpi
| IPc
| IMsize
| IGas
| IJumpdest
| IPush (arg: PushArg)
| IDup (idx: Fin 16)
| ISwap (idx: Fin 16)
| ILog (idx: Fin 5)
| ICreate
| ICall
| ICallcode
| IReturn
| IDelegatecall
| ICreate2
| IStaticcall
| IRevert
| IInvalid
| ISelfdestruct
deriving Repr, BEq

inductive Instruction where
| expr (i : InstrExpr)
| ctxt (i : InstrCtxt)
| mem (i : InstrMem)
| other (i : InstrOther)
deriving Repr, BEq

#print Coe

instance : Coe InstrExpr Instruction := ⟨Instruction.expr⟩
instance : Coe InstrCtxt Instruction := ⟨Instruction.ctxt⟩
instance : Coe InstrMem Instruction := ⟨Instruction.mem⟩
instance : Coe InstrOther Instruction := ⟨Instruction.other⟩

open InstrExpr
open InstrCtxt
open InstrMem
open InstrOther

private def ofOne (u: UInt8) := ByteArray.mk #[u]

open Instruction
def encode (i: Instruction) : ByteArray := match i with
| Instruction.expr e => match e with
  | InstrExpr.IAdd => ofOne 0x01
  | InstrExpr.IMul => ofOne 0x02
  | InstrExpr.ISub => ofOne 0x03
  | InstrExpr.IDiv => ofOne 0x04
  | InstrExpr.ISdiv => ofOne 0x05
  | InstrExpr.IMod => ofOne 0x06
  | InstrExpr.ISmod => ofOne 0x07
  | InstrExpr.IAddmod => ofOne 0x08
  | InstrExpr.IMulmod => ofOne 0x09
  | InstrExpr.IExp => ofOne 0x0a
  | InstrExpr.ISignextend => ofOne 0x0b
  | InstrExpr.ILt => ofOne 0x10
  | InstrExpr.IGt => ofOne 0x11
  | InstrExpr.ISlt => ofOne 0x12
  | InstrExpr.ISgt => ofOne 0x13
  | InstrExpr.IEq => ofOne 0x14
  | InstrExpr.IIszero => ofOne 0x15
  | InstrExpr.IAnd => ofOne 0x16
  | InstrExpr.IOr => ofOne 0x17
  | InstrExpr.IXor => ofOne 0x18
  | InstrExpr.INot => ofOne 0x19
  | InstrExpr.IByte => ofOne 0x1a
  | InstrExpr.IShl => ofOne 0x1b
  | InstrExpr.IShr => ofOne 0x1c
  | InstrExpr.ISar => ofOne 0x1d
  | InstrExpr.ISha3 => ofOne 0x20
| Instruction.ctxt e => match e with
  | InstrCtxt.IAddress => ofOne 0x30
  | InstrCtxt.IBalance => ofOne 0x31
  | InstrCtxt.IOrigin => ofOne 0x32
  | InstrCtxt.ICaller => ofOne 0x33
  | InstrCtxt.ICallvalue => ofOne 0x34
  | InstrCtxt.ICalldataload => ofOne 0x35
  | InstrCtxt.ICalldatasize => ofOne 0x36
  | InstrCtxt.ICalldatacopy => ofOne 0x37
  | InstrCtxt.ICodesize => ofOne 0x38
  | InstrCtxt.ICodecopy => ofOne 0x39
  | InstrCtxt.IGasprice => ofOne 0x3a
  | InstrCtxt.IExtcodesize => ofOne 0x3b
  | InstrCtxt.IExtcodecopy => ofOne 0x3c
  | InstrCtxt.IReturndatasize => ofOne 0x3d
  | InstrCtxt.IReturndatacopy => ofOne 0x3e
  | InstrCtxt.IExtcodehash => ofOne 0x3f
  | InstrCtxt.IBlockhash => ofOne 0x40
  | InstrCtxt.ICoinbase => ofOne 0x41
  | InstrCtxt.ITimestamp => ofOne 0x42
  | InstrCtxt.INumber => ofOne 0x43
  | InstrCtxt.IDifficulty => ofOne 0x44
  | InstrCtxt.IGaslimit => ofOne 0x45
  | InstrCtxt.IChainid => ofOne 0x46
  | InstrCtxt.ISelfbalance => ofOne 0x47
  | InstrCtxt.IBasefee => ofOne 0x48
| Instruction.mem e => match e with
  | InstrMem.IPop => ofOne 0x50
  | InstrMem.IMload => ofOne 0x51
  | InstrMem.IMstore => ofOne 0x52
  | InstrMem.IMstore8 => ofOne 0x53
  | InstrMem.ISload => ofOne 0x54
  | InstrMem.ISstore => ofOne 0x55
| Instruction.other e => match e with
  | InstrOther.IStop => ofOne 0x00
  | InstrOther.IJump => ofOne 0x56
  | InstrOther.IJumpi => ofOne 0x57
  | InstrOther.IPc => ofOne 0x58
  | InstrOther.IMsize => ofOne 0x59
  | InstrOther.IGas => ofOne 0x5a
  | InstrOther.IJumpdest => ofOne 0x5b
  | InstrOther.IPush arg => (ofOne (0x60 + arg.bytes.size.toUInt8 - 1)) ++ arg.bytes
  | InstrOther.IDup n => ofOne (0x80 + n.val.toUInt8)
  | InstrOther.ISwap n => ofOne (0x90 + n.val.toUInt8)
  | InstrOther.ILog 0 => ofOne 0xa0
  | InstrOther.ILog 1 => ofOne 0xa1
  | InstrOther.ILog 2 => ofOne 0xa2
  | InstrOther.ILog 3 => ofOne 0xa3
  | InstrOther.ILog 4 => ofOne 0xa4
  | InstrOther.ICreate => ofOne 0xf0
  | InstrOther.ICall => ofOne 0xf1
  | InstrOther.ICallcode => ofOne 0xf2
  | InstrOther.IReturn => ofOne 0xf3
  | InstrOther.IDelegatecall => ofOne 0xf4
  | InstrOther.ICreate2 => ofOne 0xf5
  | InstrOther.IStaticcall => ofOne 0xfa
  | InstrOther.IRevert => ofOne 0xfd
  | InstrOther.IInvalid => ofOne 0xfe
  | InstrOther.ISelfdestruct => ofOne 0xff

private def get? (b: ByteArray) (i: Nat) : Option UInt8 := dite (i < b.size) (fun p => b.get ⟨ i, p ⟩ ) (fun _ => none)

@[simp] private theorem Array.ofToSubarray (a: Array α) : Array.ofSubarray a.toSubarray = a := sorry

@[simp] private theorem extractSize (b: ByteArray) (n: Nat) (h: b.size >= n) a : (b.extract a n).size = n - a := by
  admit

@[simp] private theorem pff (b: ByteArray) n (h1: n <= 32) (h3: b.size >= n): (b.extract 1 (n+1)).size > 0 ∧ (b.extract 1 (n+1)).size <= 32 := by
  -- rw [extractSize b n h3 1]
  -- simp
  admit

private def btailn (b: ByteArray) n := b.extract n b.size

-- #eval btailn (ByteArray.mk #[0x00, 0x01]) 1

private def taken? (b: ByteArray) n (h: n <= 32) : Option Instruction × ByteArray :=
  dite (b.size >= n)
    (fun pf => (Instruction.other $ InstrOther.IPush { bytes := b.extract 1 (n+1), pf := pff b n h pf}, btailn b (n+1) ))
    (fun _ => (none, b))

private theorem t0lt32 : 0 <= 32 := by simp
private theorem t1lt32 : 1 <= 32 := by simp
private theorem t2lt32 : 2 <= 32 := by simp
private theorem t3lt32 : 3 <= 32 := by simp
private theorem t4lt32 : 4 <= 32 := by simp
private theorem t5lt32 : 5 <= 32 := by simp
private theorem t6lt32 : 6 <= 32 := by simp
private theorem t7lt32 : 7 <= 32 := by simp
private theorem t8lt32 : 8 <= 32 := by simp
private theorem t9lt32 : 9 <= 32 := by simp
private theorem t10lt32 : 10 <= 32 := by simp
private theorem t11lt32 : 11 <= 32 := by simp
private theorem t12lt32 : 12 <= 32 := by simp
private theorem t13lt32 : 13 <= 32 := by simp
private theorem t14lt32 : 14 <= 32 := by simp
private theorem t15lt32 : 15 <= 32 := by simp
private theorem t16lt32 : 16 <= 32 := by simp
private theorem t17lt32 : 17 <= 32 := by simp
private theorem t18lt32 : 18 <= 32 := by simp
private theorem t19lt32 : 19 <= 32 := by simp
private theorem t20lt32 : 20 <= 32 := by simp
private theorem t21lt32 : 21 <= 32 := by simp
private theorem t22lt32 : 22 <= 32 := by simp
private theorem t23lt32 : 23 <= 32 := by simp
private theorem t24lt32 : 24 <= 32 := by simp
private theorem t25lt32 : 25 <= 32 := by simp
private theorem t26lt32 : 26 <= 32 := by simp
private theorem t27lt32 : 27 <= 32 := by simp
private theorem t28lt32 : 28 <= 32 := by simp
private theorem t29lt32 : 29 <= 32 := by simp
private theorem t30lt32 : 30 <= 32 := by simp
private theorem t31lt32 : 31 <= 32 := by simp
private theorem t32lt32 : 32 <= 32 := by simp

set_option maxHeartbeats 200000
def decode (b: ByteArray) : Option Instruction × ByteArray :=
  let btail := btailn b 1
  match get? b 0 with
  | none => (none, b)
  | some v => match v.val.val with
    | 0x00 => (some IStop, btail)
    | 0x01 => (some IAdd, btail)
    | 0x02 => (some IMul, btail)
    | 0x03 => (some ISub, btail)
    | 0x04 => (some IDiv, btail)
    | 0x05 => (some ISdiv, btail)
    | 0x06 => (some IMod, btail)
    | 0x07 => (some ISmod, btail)
    | 0x08 => (some IAddmod, btail)
    | 0x09 => (some IMulmod, btail)
    | 0x0a => (some IExp, btail)
    | 0x0b => (some ISignextend, btail)

    | 0x10 => (some ILt, btail)
    | 0x11 => (some IGt, btail)
    | 0x12 => (some ISlt, btail)
    | 0x13 => (some ISgt, btail)
    | 0x14 => (some IEq, btail)
    | 0x15 => (some IIszero, btail)
    | 0x16 => (some IAnd, btail)
    | 0x17 => (some IOr, btail)
    | 0x18 => (some IXor, btail)
    | 0x19 => (some INot, btail)
    | 0x1a => (some IByte, btail)
    | 0x1b => (some IShl, btail)
    | 0x1c => (some IShr, btail)
    | 0x1d => (some ISar, btail)

    | 0x20 => (some ISha3, btail)

    | 0x30 => (some IAddress, btail)
    | 0x31 => (some IBalance, btail)
    | 0x32 => (some IOrigin, btail)
    | 0x33 => (some ICaller, btail)
    | 0x34 => (some ICallvalue, btail)
    | 0x35 => (some ICalldataload, btail)
    | 0x36 => (some ICalldatasize, btail)
    | 0x37 => (some ICalldatacopy, btail)
    | 0x38 => (some ICodesize, btail)
    | 0x39 => (some ICodecopy, btail)
    | 0x3a => (some IGasprice, btail)
    | 0x3b => (some IExtcodesize, btail)
    | 0x3c => (some IExtcodecopy, btail)
    | 0x3d => (some IReturndatasize, btail)
    | 0x3e => (some IReturndatacopy, btail)
    | 0x3f => (some IExtcodehash, btail)

    | 0x40 => (some IBlockhash, btail)
    | 0x41 => (some ICoinbase, btail)
    | 0x42 => (some ITimestamp, btail)
    | 0x43 => (some INumber, btail)
    | 0x44 => (some IDifficulty, btail)
    | 0x45 => (some IGaslimit, btail)
    | 0x46 => (some IChainid, btail)
    | 0x47 => (some ISelfbalance, btail)
    | 0x48 => (some IBasefee, btail)

    | 0x50 => (some IPop, btail)
    | 0x51 => (some IMload, btail)
    | 0x52 => (some IMstore, btail)
    | 0x53 => (some IMstore8, btail)
    | 0x54 => (some ISload, btail)
    | 0x55 => (some ISstore, btail)
    | 0x56 => (some IJump, btail)
    | 0x57 => (some IJumpi, btail)
    | 0x58 => (some IPc, btail)
    | 0x59 => (some IMsize, btail)
    | 0x5a => (some IGas, btail)
    | 0x5b => (some IJumpdest, btail)

    | 0x60 => taken? b 1 t1lt32
    | 0x61 => taken? b 2 t2lt32
    | 0x62 => taken? b 3 t3lt32
    | 0x63 => taken? b 4 t4lt32
    | 0x64 => taken? b 5 t5lt32
    | 0x65 => taken? b 6 t6lt32
    | 0x66 => taken? b 7 t7lt32
    | 0x67 => taken? b 8 t8lt32
    | 0x68 => taken? b 9 t9lt32
    | 0x69 => taken? b 10 t10lt32
    | 0x6a => taken? b 11 t11lt32
    | 0x6b => taken? b 12 t12lt32
    | 0x6c => taken? b 13 t13lt32
    | 0x6d => taken? b 14 t14lt32
    | 0x6e => taken? b 15 t15lt32
    | 0x6f => taken? b 16 t16lt32
    | 0x70 => taken? b 17 t17lt32
    | 0x71 => taken? b 18 t18lt32
    | 0x72 => taken? b 19 t19lt32
    | 0x73 => taken? b 20 t20lt32
    | 0x74 => taken? b 21 t21lt32
    | 0x75 => taken? b 22 t22lt32
    | 0x76 => taken? b 23 t23lt32
    | 0x77 => taken? b 24 t24lt32
    | 0x78 => taken? b 25 t25lt32
    | 0x79 => taken? b 26 t26lt32
    | 0x7a => taken? b 27 t27lt32
    | 0x7b => taken? b 28 t28lt32
    | 0x7c => taken? b 29 t29lt32
    | 0x7d => taken? b 30 t30lt32
    | 0x7e => taken? b 31 t31lt32
    | 0x7f => taken? b 32 t32lt32

    | 0x80 => (some $ IDup 0, btail)
    | 0x81 => (some $ IDup 1, btail)
    | 0x82 => (some $ IDup 2, btail)
    | 0x83 => (some $ IDup 3, btail)
    | 0x84 => (some $ IDup 4, btail)
    | 0x85 => (some $ IDup 5, btail)
    | 0x86 => (some $ IDup 6, btail)
    | 0x87 => (some $ IDup 7, btail)
    | 0x88 => (some $ IDup 8, btail)
    | 0x89 => (some $ IDup 9, btail)
    | 0x8a => (some $ IDup 10, btail)
    | 0x8b => (some $ IDup 11, btail)
    | 0x8c => (some $ IDup 12, btail)
    | 0x8d => (some $ IDup 13, btail)
    | 0x8e => (some $ IDup 14, btail)
    | 0x8f => (some $ IDup 15, btail)

    | 0x90 => (some $ ISwap 0, btail)
    | 0x91 => (some $ ISwap 1, btail)
    | 0x92 => (some $ ISwap 2, btail)
    | 0x93 => (some $ ISwap 3, btail)
    | 0x94 => (some $ ISwap 4, btail)
    | 0x95 => (some $ ISwap 5, btail)
    | 0x96 => (some $ ISwap 6, btail)
    | 0x97 => (some $ ISwap 7, btail)
    | 0x98 => (some $ ISwap 8, btail)
    | 0x99 => (some $ ISwap 9, btail)
    | 0x9a => (some $ ISwap 10, btail)
    | 0x9b => (some $ ISwap 11, btail)
    | 0x9c => (some $ ISwap 12, btail)
    | 0x9d => (some $ ISwap 13, btail)
    | 0x9e => (some $ ISwap 14, btail)
    | 0x9f => (some $ ISwap 15, btail)

    | 0xa0 => (some $ ILog 0, btail)
    | 0xa1 => (some $ ILog 1, btail)
    | 0xa2 => (some $ ILog 2, btail)
    | 0xa3 => (some $ ILog 3, btail)
    | 0xa4 => (some $ ILog 4, btail)

    | 0xf0 => (some ICreate, btail)
    | 0xf1 => (some ICall, btail)
    | 0xf2 => (some ICallcode, btail)
    | 0xf3 => (some IReturn, btail)
    | 0xf4 => (some IDelegatecall, btail)
    | 0xf5 => (some ICreate2, btail)
    | 0xfa => (some IStaticcall, btail)
    | 0xfd => (some IRevert, btail)
    | 0xfe => (some IInvalid, btail)
    | 0xff => (some ISelfdestruct, btail)

    | _ => (none, b)

@[simp] private def getFirstElem : (get? (ByteArray.mk #[a]) 0) = some a := rfl
@[simp] private def extractEmpty (b: ByteArray) n : ByteArray.extract b n n = ByteArray.empty := sorry
@[simp] private def btailnSizeOne : btailn {data := #[a]} 1 = ByteArray.empty := by
  simp [btailn, ByteArray.size, Array.size, List.length]

private theorem finCases' (n : Fin 16) :
  (((n = 15 ∨ n = 14) ∨ (n = 13 ∨ n = 12)) ∨
  ((n = 11 ∨ n = 10) ∨ (n = 9 ∨ n = 8))) ∨
  (((n = 7 ∨ n = 6) ∨ (n = 5 ∨ n = 4)) ∨
  ((n = 3 ∨ n = 2) ∨ (n = 1 ∨ n = 0))) := match n with
  | Fin.mk n pf => by
  by_cases h : n = 15; subst h; exact Or.inl $ Or.inl $ Or.inl $ Or.inl rfl
  have pf : n < 15 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 14; subst h; exact Or.inl $ Or.inl $ Or.inl $ Or.inr rfl
  have pf : n < 14 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 13; subst h; exact Or.inl $ Or.inl $ Or.inr $ Or.inl rfl
  have pf : n < 13 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 12; subst h; exact Or.inl $ Or.inl $ Or.inr $ Or.inr rfl
  have pf : n < 12 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 11; subst h; exact Or.inl $ Or.inr $ Or.inl $ Or.inl rfl
  have pf : n < 11 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 10; subst h; exact Or.inl $ Or.inr $ Or.inl $ Or.inr rfl
  have pf : n < 10 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 9; subst h; exact Or.inl $ Or.inr $ Or.inr $ Or.inl rfl
  have pf : n < 9 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 8; subst h; exact Or.inl $ Or.inr $ Or.inr $ Or.inr rfl
  have pf : n < 8 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 7; subst h; exact Or.inr $ Or.inl $ Or.inl $ Or.inl rfl
  have pf : n < 7 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 6; subst h; exact Or.inr $ Or.inl $ Or.inl $ Or.inr rfl
  have pf : n < 6 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 5; subst h; exact Or.inr $ Or.inl $ Or.inr $ Or.inl rfl
  have pf : n < 5 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 4; subst h; exact Or.inr $ Or.inl $ Or.inr $ Or.inr rfl
  have pf : n < 4 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 3; subst h; exact Or.inr $ Or.inr $ Or.inl $ Or.inl rfl
  have pf : n < 3 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 2; subst h; exact Or.inr $ Or.inr $ Or.inl $ Or.inr rfl
  have pf : n < 2 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 1; subst h; exact Or.inr $ Or.inr $ Or.inr $ Or.inl rfl
  have pf : n < 1 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  by_cases h : n = 0; subst h; exact Or.inr $ Or.inr $ Or.inr $ Or.inr rfl
  have pf : n < 0 := by apply Nat.lt_of_le_and_ne (Nat.le_of_lt_succ pf) h
  cases pf

private theorem finCases5 (motive: Fin 5 -> Prop) (n : Fin 5)
  (f0 : motive 0) (f1 : motive 1) (f2 : motive 2) (f3 : motive 3)
  (f4 : motive 4) : motive n := match n with | Fin.mk n pf => match n with
  | 0 => f0
  | 1 => f1
  | 2 => f2
  | 3 => f3
  | 4 => f4
  | Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ n' => by
    repeat (have pf := Nat.lt_of_succ_lt_succ pf)
    cases pf

private theorem finCases16 (motive: Fin 16 -> Prop) (n : Fin 16)
  (f0 : motive 0) (f1 : motive 1) (f2 : motive 2) (f3 : motive 3)
  (f4 : motive 4) (f5 : motive 5) (f6 : motive 6) (f7 : motive 7)
  (f8 : motive 8) (f9 : motive 9) (f10 : motive 10) (f11 : motive 11)
  (f12 : motive 12) (f13 : motive 13) (f14 : motive 14) (f15 : motive 15) : motive n := match n with | Fin.mk n pf => match n with
  | 0 => f0 | 1 => f1 | 2 => f2 | 3 => f3
  | 4 => f4 | 5 => f5 | 6 => f6 | 7 => f7
  | 8 => f8 | 9 => f9 | 10 => f10 | 11 => f11
  | 12 => f12 | 13 => f13 | 14 => f14 | 15 => f15
  | Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $
    Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $
    Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $
    Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ Nat.succ $ n' => by
    repeat (have pf := Nat.lt_of_succ_lt_succ pf)
    cases pf

@[simp] private theorem t1 : get? { data := #[a] } 0 = some a := by simp
@[simp] private theorem t2 : btailn { data := #[a] } 1 = ByteArray.empty := by simp

private theorem encDecIPush (n: PushArg) : decode (encode (IPush n)) = (some (Instruction.other $ IPush n), ByteArray.empty) := by
  simp [encode, ofOne]
  admit

#assert (encode (IPush { bytes := ByteArray.mk #[0x01, 0x02, 0x02], pf := sorry } )).data == (ByteArray.mk #[0x62, 0x01, 0x02, 0x02]).data
-- #assert (decode (encode (IPush { bytes := ByteArray.mk #[0x01, 0x02, 0x02], pf := sorry } ))).fst == (some $ Instruction.other $ IPush { bytes := ByteArray.mk #[0x01, 0x02, 0x02], pf := sorry })

private theorem encDecIDup (n: Fin 16) : decode (encode (IDup n)) = (some (Instruction.other $ IDup n), ByteArray.empty) := by
  simp [encode, ofOne]
  have h0 : 128 + (0: Fin 16).val.toUInt8 = 128 := by rfl
  have h1 : 128 + (1: Fin 16).val.toUInt8 = 129 := by rfl
  have h2 : 128 + (2: Fin 16).val.toUInt8 = 130 := by rfl
  have h3 : 128 + (3: Fin 16).val.toUInt8 = 131 := by rfl
  have h4 : 128 + (4: Fin 16).val.toUInt8 = 132 := by rfl
  have h5 : 128 + (5: Fin 16).val.toUInt8 = 133 := by rfl
  have h6 : 128 + (6: Fin 16).val.toUInt8 = 134 := by rfl
  have h7 : 128 + (7: Fin 16).val.toUInt8 = 135 := by rfl
  have h8 : 128 + (8: Fin 16).val.toUInt8 = 136 := by rfl
  have h9 : 128 + (9: Fin 16).val.toUInt8 = 137 := by rfl
  have h10 : 128 + (10: Fin 16).val.toUInt8 = 138 := by rfl
  have h11 : 128 + (11: Fin 16).val.toUInt8 = 139 := by rfl
  have h12 : 128 + (12: Fin 16).val.toUInt8 = 140 := by rfl
  have h13 : 128 + (13: Fin 16).val.toUInt8 = 141 := by rfl
  have h14 : 128 + (14: Fin 16).val.toUInt8 = 142 := by rfl
  have h15 : 128 + (15: Fin 16).val.toUInt8 = 143 := by rfl

  cases n using finCases16 <;> simp only [h0, h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15] <;> (unfold decode ; rw [t1, t2])

private theorem encDecISwap (n: Fin 16) : decode (encode (ISwap n)) = (some (Instruction.other $ ISwap n), ByteArray.empty) := by
  simp [encode, ofOne]
  have h0 : 144 + (0: Fin 16).val.toUInt8 = 144 := by rfl
  have h1 : 144 + (1: Fin 16).val.toUInt8 = 145 := by rfl
  have h2 : 144 + (2: Fin 16).val.toUInt8 = 146 := by rfl
  have h3 : 144 + (3: Fin 16).val.toUInt8 = 147 := by rfl
  have h4 : 144 + (4: Fin 16).val.toUInt8 = 148 := by rfl
  have h5 : 144 + (5: Fin 16).val.toUInt8 = 149 := by rfl
  have h6 : 144 + (6: Fin 16).val.toUInt8 = 150 := by rfl
  have h7 : 144 + (7: Fin 16).val.toUInt8 = 151 := by rfl
  have h8 : 144 + (8: Fin 16).val.toUInt8 = 152 := by rfl
  have h9 : 144 + (9: Fin 16).val.toUInt8 = 153 := by rfl
  have h10 : 144 + (10: Fin 16).val.toUInt8 = 154 := by rfl
  have h11 : 144 + (11: Fin 16).val.toUInt8 = 155 := by rfl
  have h12 : 144 + (12: Fin 16).val.toUInt8 = 156 := by rfl
  have h13 : 144 + (13: Fin 16).val.toUInt8 = 157 := by rfl
  have h14 : 144 + (14: Fin 16).val.toUInt8 = 158 := by rfl
  have h15 : 144 + (15: Fin 16).val.toUInt8 = 159 := by rfl

  cases n using finCases16 <;> simp only [h0, h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15] <;> (unfold decode ; rw [t1, t2])

private theorem encDecILog (n: Fin 5) : decode (encode (ILog n)) = (some (Instruction.other $ ILog n), ByteArray.empty) := by
  simp [encode, ofOne]
  have h0 : 144 + (0: Fin 16).val.toUInt8 = 144 := by rfl
  have h1 : 144 + (1: Fin 16).val.toUInt8 = 145 := by rfl
  have h2 : 144 + (2: Fin 16).val.toUInt8 = 146 := by rfl
  have h3 : 144 + (3: Fin 16).val.toUInt8 = 147 := by rfl
  have h4 : 144 + (4: Fin 16).val.toUInt8 = 148 := by rfl
  have h5 : 144 + (5: Fin 16).val.toUInt8 = 149 := by rfl
  have h6 : 144 + (6: Fin 16).val.toUInt8 = 150 := by rfl
  have h7 : 144 + (7: Fin 16).val.toUInt8 = 151 := by rfl
  have h8 : 144 + (8: Fin 16).val.toUInt8 = 152 := by rfl
  have h9 : 144 + (9: Fin 16).val.toUInt8 = 153 := by rfl
  have h10 : 144 + (10: Fin 16).val.toUInt8 = 154 := by rfl
  have h11 : 144 + (11: Fin 16).val.toUInt8 = 155 := by rfl
  have h12 : 144 + (12: Fin 16).val.toUInt8 = 156 := by rfl
  have h13 : 144 + (13: Fin 16).val.toUInt8 = 157 := by rfl
  have h14 : 144 + (14: Fin 16).val.toUInt8 = 158 := by rfl
  have h15 : 144 + (15: Fin 16).val.toUInt8 = 159 := by rfl

  cases n using finCases5 <;> simp only [h0, h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15] <;> (unfold decode ; rw [t1, t2])

#eval 0

macro "solvefast" : tactic => `(simp [encode, ofOne]; unfold decode; rw [t1, t2])

private theorem encodeDecodeIStop : decode (encode IStop) = (some $ Instruction.other $ IStop, ByteArray.empty) := by solvefast
private theorem encodeDecodeIAdd : decode (encode IAdd) = (some $ Instruction.expr $ IAdd, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMul : decode (encode IMul) = (some $ Instruction.expr $ IMul, ByteArray.empty) := by solvefast
private theorem encodeDecodeISub : decode (encode ISub) = (some $ Instruction.expr $ ISub, ByteArray.empty) := by solvefast
private theorem encodeDecodeIDiv : decode (encode IDiv) = (some $ Instruction.expr $ IDiv, ByteArray.empty) := by solvefast
private theorem encodeDecodeISdiv : decode (encode ISdiv) = (some $ Instruction.expr $ ISdiv, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMod : decode (encode IMod) = (some $ Instruction.expr $ IMod, ByteArray.empty) := by solvefast
private theorem encodeDecodeISmod : decode (encode ISmod) = (some $ Instruction.expr $ ISmod, ByteArray.empty) := by solvefast
private theorem encodeDecodeIAddmod : decode (encode IAddmod) = (some $ Instruction.expr $ IAddmod, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMulmod : decode (encode IMulmod) = (some $ Instruction.expr $ IMulmod, ByteArray.empty) := by solvefast
private theorem encodeDecodeIExp : decode (encode IExp) = (some $ Instruction.expr $ IExp, ByteArray.empty) := by solvefast
private theorem encodeDecodeISignextend : decode (encode ISignextend) = (some $ Instruction.expr $ ISignextend, ByteArray.empty) := by solvefast
private theorem encodeDecodeILt : decode (encode ILt) = (some $ Instruction.expr $ ILt, ByteArray.empty) := by solvefast
private theorem encodeDecodeIGt : decode (encode IGt) = (some $ Instruction.expr $ IGt, ByteArray.empty) := by solvefast
private theorem encodeDecodeISlt : decode (encode ISlt) = (some $ Instruction.expr $ ISlt, ByteArray.empty) := by solvefast
private theorem encodeDecodeISgt : decode (encode ISgt) = (some $ Instruction.expr $ ISgt, ByteArray.empty) := by solvefast
private theorem encodeDecodeIEq : decode (encode IEq) = (some $ Instruction.expr $ IEq, ByteArray.empty) := by solvefast
private theorem encodeDecodeIIszero : decode (encode IIszero) = (some $ Instruction.expr $ IIszero, ByteArray.empty) := by solvefast
private theorem encodeDecodeIAnd : decode (encode IAnd) = (some $ Instruction.expr $ IAnd, ByteArray.empty) := by solvefast
private theorem encodeDecodeIOr : decode (encode IOr) = (some $ Instruction.expr $ IOr, ByteArray.empty) := by solvefast
private theorem encodeDecodeIXor : decode (encode IXor) = (some $ Instruction.expr $ IXor, ByteArray.empty) := by solvefast
private theorem encodeDecodeINot : decode (encode INot) = (some $ Instruction.expr $ INot, ByteArray.empty) := by solvefast
private theorem encodeDecodeIByte : decode (encode IByte) = (some $ Instruction.expr $ IByte, ByteArray.empty) := by solvefast
private theorem encodeDecodeIShl : decode (encode IShl) = (some $ Instruction.expr $ IShl, ByteArray.empty) := by solvefast
private theorem encodeDecodeIShr : decode (encode IShr) = (some $ Instruction.expr $ IShr, ByteArray.empty) := by solvefast
private theorem encodeDecodeISar : decode (encode ISar) = (some $ Instruction.expr $ ISar, ByteArray.empty) := by solvefast
private theorem encodeDecodeISha3 : decode (encode ISha3) = (some $ Instruction.expr $ ISha3, ByteArray.empty) := by solvefast
private theorem encodeDecodeIAddress : decode (encode IAddress) = (some $ Instruction.ctxt $ IAddress, ByteArray.empty) := by solvefast
private theorem encodeDecodeIBalance : decode (encode IBalance) = (some $ Instruction.ctxt $ IBalance, ByteArray.empty) := by solvefast
private theorem encodeDecodeIOrigin : decode (encode IOrigin) = (some $ Instruction.ctxt $ IOrigin, ByteArray.empty) := by solvefast
private theorem encodeDecodeICaller : decode (encode ICaller) = (some $ Instruction.ctxt $ ICaller, ByteArray.empty) := by solvefast
private theorem encodeDecodeICallvalue : decode (encode ICallvalue) = (some $ Instruction.ctxt $ ICallvalue, ByteArray.empty) := by solvefast
private theorem encodeDecodeICalldataload : decode (encode ICalldataload) = (some $ Instruction.ctxt $ ICalldataload, ByteArray.empty) := by solvefast
private theorem encodeDecodeICalldatasize : decode (encode ICalldatasize) = (some $ Instruction.ctxt $ ICalldatasize, ByteArray.empty) := by solvefast
private theorem encodeDecodeICalldatacopy : decode (encode ICalldatacopy) = (some $ Instruction.ctxt $ ICalldatacopy, ByteArray.empty) := by solvefast
private theorem encodeDecodeICodesize : decode (encode ICodesize) = (some $ Instruction.ctxt $ ICodesize, ByteArray.empty) := by solvefast
private theorem encodeDecodeICodecopy : decode (encode ICodecopy) = (some $ Instruction.ctxt $ ICodecopy, ByteArray.empty) := by solvefast
private theorem encodeDecodeIGasprice : decode (encode IGasprice) = (some $ Instruction.ctxt $ IGasprice, ByteArray.empty) := by solvefast
private theorem encodeDecodeIExtcodesize : decode (encode IExtcodesize) = (some $ Instruction.ctxt $ IExtcodesize, ByteArray.empty) := by solvefast
private theorem encodeDecodeIExtcodecopy : decode (encode IExtcodecopy) = (some $ Instruction.ctxt $ IExtcodecopy, ByteArray.empty) := by solvefast
private theorem encodeDecodeIReturndatasize : decode (encode IReturndatasize) = (some $ Instruction.ctxt $ IReturndatasize, ByteArray.empty) := by solvefast
private theorem encodeDecodeIReturndatacopy : decode (encode IReturndatacopy) = (some $ Instruction.ctxt $ IReturndatacopy, ByteArray.empty) := by solvefast
private theorem encodeDecodeIExtcodehash : decode (encode IExtcodehash) = (some $ Instruction.ctxt $ IExtcodehash, ByteArray.empty) := by solvefast
private theorem encodeDecodeIBlockhash : decode (encode IBlockhash) = (some $ Instruction.ctxt $ IBlockhash, ByteArray.empty) := by solvefast
private theorem encodeDecodeICoinbase : decode (encode ICoinbase) = (some $ Instruction.ctxt $ ICoinbase, ByteArray.empty) := by solvefast
private theorem encodeDecodeITimestamp : decode (encode ITimestamp) = (some $ Instruction.ctxt $ ITimestamp, ByteArray.empty) := by solvefast
private theorem encodeDecodeINumber : decode (encode INumber) = (some $ Instruction.ctxt $ INumber, ByteArray.empty) := by solvefast
private theorem encodeDecodeIDifficulty : decode (encode IDifficulty) = (some $ Instruction.ctxt $ IDifficulty, ByteArray.empty) := by solvefast
private theorem encodeDecodeIGaslimit : decode (encode IGaslimit) = (some $ Instruction.ctxt $ IGaslimit, ByteArray.empty) := by solvefast
private theorem encodeDecodeIChainid : decode (encode IChainid) = (some $ Instruction.ctxt $ IChainid, ByteArray.empty) := by solvefast
private theorem encodeDecodeISelfbalance : decode (encode ISelfbalance) = (some $ Instruction.ctxt $ ISelfbalance, ByteArray.empty) := by solvefast
private theorem encodeDecodeIBasefee : decode (encode IBasefee) = (some $ Instruction.ctxt $ IBasefee, ByteArray.empty) := by solvefast
private theorem encodeDecodeIPop : decode (encode IPop) = (some $ Instruction.mem $ IPop, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMload : decode (encode IMload) = (some $ Instruction.mem $ IMload, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMstore : decode (encode IMstore) = (some $ Instruction.mem $ IMstore, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMstore8 : decode (encode IMstore8) = (some $ Instruction.mem $ IMstore8, ByteArray.empty) := by solvefast
private theorem encodeDecodeISload : decode (encode ISload) = (some $ Instruction.mem $ ISload, ByteArray.empty) := by solvefast
private theorem encodeDecodeISstore : decode (encode ISstore) = (some $ Instruction.mem $ ISstore, ByteArray.empty) := by solvefast
private theorem encodeDecodeIJump : decode (encode IJump) = (some $ Instruction.other $ IJump, ByteArray.empty) := by solvefast
private theorem encodeDecodeIJumpi : decode (encode IJumpi) = (some $ Instruction.other $ IJumpi, ByteArray.empty) := by solvefast
private theorem encodeDecodeIPc : decode (encode IPc) = (some $ Instruction.other $ IPc, ByteArray.empty) := by solvefast
private theorem encodeDecodeIMsize : decode (encode IMsize) = (some $ Instruction.other $ IMsize, ByteArray.empty) := by solvefast
private theorem encodeDecodeIGas : decode (encode IGas) = (some $ Instruction.other $ IGas, ByteArray.empty) := by solvefast
private theorem encodeDecodeIJumpdest : decode (encode IJumpdest) = (some $ Instruction.other $ IJumpdest, ByteArray.empty) := by solvefast
private theorem encodeDecodeICreate : decode (encode ICreate) = (some $ Instruction.other $ ICreate, ByteArray.empty) := by solvefast
private theorem encodeDecodeICall : decode (encode ICall) = (some $ Instruction.other $ ICall, ByteArray.empty) := by solvefast
private theorem encodeDecodeICallcode : decode (encode ICallcode) = (some $ Instruction.other $ ICallcode, ByteArray.empty) := by solvefast
private theorem encodeDecodeIReturn : decode (encode IReturn) = (some $ Instruction.other $ IReturn, ByteArray.empty) := by solvefast
private theorem encodeDecodeIDelegatecall : decode (encode IDelegatecall) = (some $ Instruction.other $ IDelegatecall, ByteArray.empty) := by solvefast
private theorem encodeDecodeICreate2 : decode (encode ICreate2) = (some $ Instruction.other $ ICreate2, ByteArray.empty) := by solvefast
private theorem encodeDecodeIStaticcall : decode (encode IStaticcall) = (some $ Instruction.other $ IStaticcall, ByteArray.empty) := by solvefast
private theorem encodeDecodeIRevert : decode (encode IRevert) = (some $ Instruction.other $ IRevert, ByteArray.empty) := by solvefast
private theorem encodeDecodeIInvalid : decode (encode IInvalid) = (some $ Instruction.other $ IInvalid, ByteArray.empty) := by solvefast
private theorem encodeDecodeISelfdestruct : decode (encode ISelfdestruct) = (some $ Instruction.other $ ISelfdestruct, ByteArray.empty) := by solvefast

theorem encodeDecode (i: Instruction) : decode (encode i) = (some i, ByteArray.empty) :=
match i with
| IStop => encodeDecodeIStop
| IAdd => encodeDecodeIAdd
| IMul => encodeDecodeIMul
| ISub => encodeDecodeISub
| IDiv => encodeDecodeIDiv
| ISdiv => encodeDecodeISdiv
| IMod => encodeDecodeIMod
| ISmod => encodeDecodeISmod
| IAddmod => encodeDecodeIAddmod
| IMulmod => encodeDecodeIMulmod
| IExp => encodeDecodeIExp
| ISignextend => encodeDecodeISignextend

| ILt => encodeDecodeILt
| IGt => encodeDecodeIGt
| ISlt => encodeDecodeISlt
| ISgt => encodeDecodeISgt
| IEq => encodeDecodeIEq
| IIszero => encodeDecodeIIszero
| IAnd => encodeDecodeIAnd
| IOr => encodeDecodeIOr
| IXor => encodeDecodeIXor
| INot => encodeDecodeINot
| IByte => encodeDecodeIByte
| IShl => encodeDecodeIShl
| IShr => encodeDecodeIShr
| ISar => encodeDecodeISar

| ISha3 => encodeDecodeISha3

| IAddress => encodeDecodeIAddress
| IBalance => encodeDecodeIBalance
| IOrigin => encodeDecodeIOrigin
| ICaller => encodeDecodeICaller
| ICallvalue => encodeDecodeICallvalue
| ICalldataload => encodeDecodeICalldataload
| ICalldatasize => encodeDecodeICalldatasize
| ICalldatacopy => encodeDecodeICalldatacopy
| ICodesize => encodeDecodeICodesize
| ICodecopy => encodeDecodeICodecopy
| IGasprice => encodeDecodeIGasprice
| IExtcodesize => encodeDecodeIExtcodesize
| IExtcodecopy => encodeDecodeIExtcodecopy
| IReturndatasize => encodeDecodeIReturndatasize
| IReturndatacopy => encodeDecodeIReturndatacopy
| IExtcodehash => encodeDecodeIExtcodehash

| IBlockhash => encodeDecodeIBlockhash
| ICoinbase => encodeDecodeICoinbase
| ITimestamp => encodeDecodeITimestamp
| INumber => encodeDecodeINumber
| IDifficulty => encodeDecodeIDifficulty
| IGaslimit => encodeDecodeIGaslimit
| IChainid => encodeDecodeIChainid
| ISelfbalance => encodeDecodeISelfbalance
| IBasefee => encodeDecodeIBasefee

| IPop => encodeDecodeIPop
| IMload => encodeDecodeIMload
| IMstore => encodeDecodeIMstore
| IMstore8 => encodeDecodeIMstore8
| ISload => encodeDecodeISload
| ISstore => encodeDecodeISstore
| IJump => encodeDecodeIJump
| IJumpi => encodeDecodeIJumpi
| IPc => encodeDecodeIPc
| IMsize => encodeDecodeIMsize
| IGas => encodeDecodeIGas
| IJumpdest => encodeDecodeIJumpdest

| IPush arg => encDecIPush arg

| IDup n => encDecIDup n

| ISwap n => encDecISwap n

| ILog n => encDecILog n

| ICreate => encodeDecodeICreate
| ICall => encodeDecodeICall
| ICallcode => encodeDecodeICallcode
| IReturn => encodeDecodeIReturn
| IDelegatecall => encodeDecodeIDelegatecall
| ICreate2 => encodeDecodeICreate2
| IStaticcall => encodeDecodeIStaticcall
| IRevert => encodeDecodeIRevert
| IInvalid => encodeDecodeIInvalid
| ISelfdestruct => encodeDecodeISelfdestruct

end EVM


import Duper.Simp
import Duper.Util.ProofReconstruction
import Lean.Meta.Basic

namespace Duper
open RuleM
open SimpResult
open Lean
open Meta

initialize Lean.registerTraceClass `Rule.identPropFalseElim

/-- Determines whether a literal has exactly the form `False = True` or `True = False`-/
def isFalsePropLiteral (lit : Lit) : MetaM Bool := do
  match lit.ty with
  | Expr.sort lvl =>
    if Level.isEquiv (← Lean.instantiateLevelMVars lvl) levelZero then
      return lit.sign &&
        ((lit.lhs == mkConst ``True && lit.rhs == mkConst ``False) ||
        (lit.lhs == mkConst ``False && lit.rhs == mkConst ``True))
    else return false
  | _ => return false

theorem prop_false_ne_true (h : False = True) : False := by rw [h]; exact ⟨⟩

theorem prop_true_ne_false (h : True = False) : False := by rw [← h]; exact ⟨⟩

def mkIdentPropFalseElimProof (refs : List (Option Nat)) (premises : List Expr) (parents : List ProofParent) (transferExprs : Array Expr)
  (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let mut proofCases : Array Expr := Array.mkEmpty parentLits.size
    for i in [:parentLits.size] do
      let lit := parentLits[i]!
      if (← isFalsePropLiteral lit) then -- lit has the form `False = True` or `True = False`
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          if (lit.lhs == mkConst ``False) then
            let proofCase := mkApp (mkConst ``prop_false_ne_true) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          else if(lit.lhs == mkConst ``True) then
            let proofCase := mkApp (mkConst ``prop_true_ne_false) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          else
            throwError "mkIdentPropFalseElimProof failed to match {lit.lhs} to an expected expression"
        proofCases := proofCases.push proofCase
      else -- refs[i] should have the value (some j) where parentLits[i] == c[j]
        match refs[i]! with
        | none => throwError "Refs invariant is not satisfied in identPropFalseElim"
        | some j =>
          let proofCase ← Meta.withLocalDeclD `h parentLits[i]!.toExpr fun h => do
            Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) j h
          proofCases := proofCases.push proofCase
    let proof ← orCases (parentLits.map Lit.toExpr) proofCases
    Meta.mkLambdaFVars xs $ mkApp proof appliedPremise

/-- Eliminate literals that are exactly of the form `False = True` or `True = False`.
    This is a special case of the propFalseElim inference rule in which σ is the identity. -/
def identPropFalseElim : MSimpRule := fun c => do
  let c ← loadClause c
  /-
    Spec for newLits and refs:
    If c.lits[i] is `False = True` or `True = False`, then refs[i] = none
    If c.lits[i] isn't `False = True` or `True = False`,then refs[i] = some j where newLits[j] = c.lits[i]
  -/
  let mut newLits : List Lit := []
  let mut refs : List (Option Nat) := []
  for lit in c.lits do
    if (← isFalsePropLiteral lit) then
      refs := none :: refs
    else
      refs := (some newLits.length) :: refs
      newLits := lit :: newLits
  -- To achieve the desired spec for newLits and refs, I must reverse them
  newLits := newLits.reverse
  refs := refs.reverse
  if (newLits.length = c.lits.size) then
    trace[Rule.identPropFalseElim] "Returning Unapplicable on {c.lits}"
    return none
  else
    trace[Rule.identPropFalseElim] "Succeeded on {c.lits}, yielding {newLits}"
    let resultClause ← yieldClause (MClause.mk newLits.toArray) "identity prop false elimination"
      (some (mkIdentPropFalseElimProof refs))
    return some #[resultClause]

end Duper