@[simp] theorem Expr.denote_castPureToEff {e : Expr d Γ .pure t} :
    denote (e.castPureToEff eff) = fun V => pure (e.denote V)

Ctxt

structure Ctxt (Ty : Type) : Type where
  ofList :: toList : List Ty

  deriving Repr, Lean.ToExpr, DecidableEq

EffectKind

inductive EffectKind
| pure
| impure
deriving Repr, DecidableEq, Lean.ToExpr

Valuation.cast

def Valuation.cast {Γ Δ : Ctxt Ty} (h : Γ = Δ) (V : Valuation Γ) : Valuation Δ :=
  fun _ v => V <| v.castCtxt h.symm

Valuation.instAppendHVector

@[simp]
instance Valuation.instAppendHVector (Γ : Ctxt Ty) (ts : List Ty) :
    HAppend (HVector toType ts) (Valuation Γ) (Valuation <| ⟨ts⟩ ++ Γ) where
  hAppend vals V :=
    (Valuation.ofHVector vals) ++ V

TyDenote

class TyDenote (β : Type) : Type 1 where
  toType : β → Type

Var

def Var (Γ : Ctxt Ty) (t : Ty) : Type :=
  { i : Nat // Γ[i]? = some t }

liftEffect

def liftEffect [Pure m] {e1 e2 : EffectKind} {α : Type}
    (hle : e1 ≤ e2) (v1 : e1.toMonad m α) : e2.toMonad m α :=
  match e1, e2, hle with
    | .pure, .pure, _ | .impure, .impure, _ => v1
    | .pure, .impure, _ => Pure.pure v1

toMonad

def toMonad (e : EffectKind) (m : Type → Type) : Type → Type :=
  match e with
  | pure => Id
  | impure => m

Ty

inductive Ty (q : Nat) (n : Nat)
  | index : Ty q n
  | integer : Ty q n
  | tensor : Ty q n
  | polynomialLike : Ty q n
  deriving DecidableEq, Repr

Valuation.nil

def Valuation.nil : Ctxt.Valuation (∅ : Ctxt Ty) := fun _ v => v.emptyElim

Valuation.cons

def Valuation.cons {Γ : Ctxt Ty} {t : Ty} (x : toType t) (V : Γ.Valuation) :
    (Γ.cons t).Valuation :=

Dialect

structure Dialect where
  (Op : Type)
  (Ty : Type)
  (m : Type → Type := Id)

Op

inductive Op (q : Nat) (n : Nat)
  | add : Op q n
  | sub : Op q n
  | mul : Op q n
  | mul_constant : Op q n

  | leading_term : Op q n
  | monomial : Op q n
  | monomial_mul : Op q n
  | from_tensor : Op q n
  | to_tensor : Op q n
  | const (c : R q n) : Op q n
  | const_int (c : Int) : Op q n
  | const_idx (i : Nat) : Op q n

map

def map (f : Ty₁ → Ty₂) : Ctxt Ty₁ → Ctxt Ty₂ :=
  ofList ∘ (List.map f) ∘ toList

    @[simp_denote]
    instance : DialectDenote $dialect where
      denote := fun op => match op with $matchAlts:matchAlts
  )

(q

noncomputable instance (q : ℕ) [Fact (q > 1)] : DialectDenote (ModArith q) where
denote
  | .add, arg, _ =>

      (fun args : R q × R q => args.1 + args.2) arg.toPair
  | .sub, arg, _ =>

      (fun args : R q × R q => args.1 - args.2) arg.toPair
  | .mul, arg, _ =>

      (fun args : R q × R q => args.1 * args.2) arg.toPair
  | .const _ c, _, _ =>

      c

@[reducible]
instance : DialectDenote Ex where
  denote
    | .cst n, _, _ => n ::ₕ .nil
    | .add, .cons (a : Nat) (.cons b .nil), _ => a + b ::ₕ .nil
    | .beq, .cons (a : Nat) (.cons b .nil), _ => (a == b) ::ₕ .nil

ExOp

inductive ExOp :  Type
  | add : ExOp
  | beq : ExOp
  | cst : ℕ → ExOp
  deriving DecidableEq

add

def add {Γ : Ctxt _} (e₁ e₂ : Ctxt.Var Γ .nat) : Expr Ex Γ .pure [.nat] :=
  Expr.mk
    (op := .add)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

Ex

abbrev Ex : Dialect where
  Op := ExOp
  Ty := ExTy

ExTy

inductive ExTy
  | nat
  | bool
  deriving DecidableEq

cst

def cst {Γ : Ctxt _} (n : ℕ) : Expr Ex Γ .pure [.nat]  :=
  Expr.mk
    (op := .cst n)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .nil)
    (regArgs := .nil)

cons

@[match_pattern]
def cons (hd : Ty) : Ctxt Ty → Ctxt Ty
| ⟨tl⟩ => ⟨hd :: tl⟩

@[simp, reducible]
instance : DialectDenote RV64 where
  denote o args _ := [o.denote args]ₕ

Op.denote

@[simp, simp_denote]
abbrev Op.denote : (o : RV64.Op) → HVector toType o.sig → ⟦o.outTy⟧
  | .li imm, _  => imm
  | .addiw imm, regs => RV64.addiw imm (regs.getN 0)
  | .lui imm, regs  => RV64.lui imm
  | .auipc imm, regs => RV64.auipc imm (regs.getN 0)
  | .slliw shamt, regs => RV64.slliw shamt (regs.getN 0)
  | .srliw shamt, regs => RV64.srliw shamt (regs.getN 0)
  | .sraiw shamt, regs => RV64.sraiw shamt (regs.getN 0)
  | .slli shamt, regs => RV64.slli shamt (regs.getN 0)
  | .srli shamt, regs => RV64.srli shamt (regs.getN 0)
  | .srai shamt, regs => RV64.srai shamt (regs.getN 0)
  | .addw, regs => RV64.addw (regs.getN 1) (regs.getN 0)
  | .subw, regs => RV64.subw (regs.getN 1) (regs.getN 0)
  | .sllw, regs => RV64.sllw (regs.getN 1) (regs.getN 0)
  | .srlw, regs => RV64.srlw (regs.getN 1) (regs.getN 0)
  | .sraw, regs => RV64.sraw (regs.getN 1) (regs.getN 0)
  | .add, regs => RV64.add (regs.getN 1) (regs.getN 0)
  | .slt, regs => RV64.slt (regs.getN 1) (regs.getN 0)
  | .sltu, regs => RV64.sltu (regs.getN 1) (regs.getN 0)
  | .and, regs => RV64.and (regs.getN 1) (regs.getN 0)
  | .or, regs => RV64.or (regs.getN 1) (regs.getN 0)
  | .xor, regs => RV64.xor (regs.getN 1) (regs.getN 0)
  | .sll, regs => RV64.sll (regs.getN 1) (regs.getN 0)
  | .srl, regs => RV64.srl (regs.getN 1) (regs.getN 0)
  | .sub, regs => RV64.sub (regs.getN 1) (regs.getN 0)
  | .sra, regs => RV64.sra (regs.getN 1) (regs.getN 0)
  | .remw, regs => RV64.remw (regs.getN 1) (regs.getN 0)
  | .remuw, regs => RV64.remuw (regs.getN 1) (regs.getN 0)
  | .rem, regs => RV64.rem (regs.getN 1) (regs.getN 0)
  | .remu, regs => RV64.remu (regs.getN 1) (regs.getN 0)
  | .mulhu,regs => RV64.mulhu (regs.getN 1) (regs.getN 0)
  | .mul ,regs => RV64.mul (regs.getN 1) (regs.getN 0)
  | .mulhsu ,regs => RV64.mulhsu (regs.getN 1) (regs.getN 0)
  | .mulh,regs => RV64.mulh (regs.getN 1) (regs.getN 0)
  | .mulw,  regs => RV64.mulw (regs.getN 1) (regs.getN 0)
  | .div, regs => RV64.div (regs.getN 1) (regs.getN 0)
  | .divu, regs => RV64.divu (regs.getN 1) (regs.getN 0)
  | .divw, regs => RV64.divw (regs.getN 1) (regs.getN 0)
  | .divuw, regs => RV64.divuw (regs.getN 1) (regs.getN 0)
  | .addi imm, reg => RV64.addi imm (reg.getN 0)
  | .slti imm, reg => RV64.slti imm (reg.getN 0)
  | .sltiu imm, reg => RV64.sltiu imm (reg.getN 0)
  | .andi imm, reg => RV64.andi imm (reg.getN 0)
  | .ori imm, reg => RV64.ori imm (reg.getN 0)
  | .xori imm, reg => RV64.xori imm (reg.getN 0)
  | .bclr, regs => RV64.bclr (regs.getN 1) (regs.getN 0)
  | .bext, regs => RV64.bext (regs.getN 1) (regs.getN 0)
  | .binv, regs => RV64.binv (regs.getN 1) (regs.getN 0)
  | .bset, regs => RV64.bset (regs.getN 1) (regs.getN 0)
  | .bclri shamt , reg => RV64.bclri shamt (reg.getN 0)
  | .bexti shamt, reg => RV64.bexti shamt (reg.getN 0)
  | .binvi shamt, reg => RV64.binvi shamt (reg.getN 0)
  | .bseti shamt, reg => RV64.bseti shamt (reg.getN 0)
  | .adduw, regs => RV64.adduw (regs.getN 1) (regs.getN 0)
  | .sh1adduw , regs => RV64.sh1adduw (regs.getN 1) (regs.getN 0)
  | .sh2adduw, regs => RV64.sh2adduw (regs.getN 1) (regs.getN 0)
  | .sh3adduw, regs => RV64.sh3adduw (regs.getN 1) (regs.getN 0)
  | .sh1add, regs => RV64.sh1add (regs.getN 1) (regs.getN 0)
  | .sh2add, regs => RV64.sh2add (regs.getN 1) (regs.getN 0)
  | .sh3add, regs => RV64.sh3add (regs.getN 1) (regs.getN 0)
  | .slliuw shamt, regs => RV64.slliuw shamt (regs.getN 0)
  | .andn, regs => RV64.andn (regs.getN 1) (regs.getN 0)
  | .orn, regs => RV64.orn (regs.getN 1) (regs.getN 0)
  | .xnor, regs => RV64.xnor (regs.getN 1) (regs.getN 0)
  | .clz, regs => RV64.clz (regs.getN 1)
  | .clzw, regs => RV64.clzw (regs.getN 1)
  | .ctz, regs => RV64.ctz (regs.getN 1)
  | .ctzw, regs => RV64.ctzw (regs.getN 1)
  | .max, regs => RV64.max (regs.getN 1) (regs.getN 0)
  | .maxu, regs => RV64.maxu (regs.getN 1) (regs.getN 0)
  | .min, regs => RV64.min (regs.getN 1) (regs.getN 0)
  | .minu, regs => RV64.minu (regs.getN 1) (regs.getN 0)
  | .sextb, reg => RV64.sextb (reg.getN 0)
  | .sexth, reg => RV64.sexth (reg.getN 0)
  | .zexth, reg => RV64.zexth (reg.getN 0)
  | .rol, regs => RV64.rol (regs.getN 1) (regs.getN 0)
  | .rolw, regs => RV64.rolw (regs.getN 1) (regs.getN 0)
  | .ror, regs => RV64.ror (regs.getN 1) (regs.getN 0)
  | .rori shamt, regs => RV64.rori shamt (regs.getN 0)
  | .roriw shamt, regs => RV64.roriw shamt (regs.getN 0)
  | .rorw, regs => RV64.rorw (regs.getN 1) (regs.getN 0)
  | .pack, regs => RV64.pack (regs.getN 1) (regs.getN 0)
  | .packh, regs => RV64.packh (regs.getN 1) (regs.getN 0)
  | .packw, regs => RV64.packw (regs.getN 1) (regs.getN 0)

  | .mv, regs  => RV64.mv_pseudo (regs.getN 0)
  | .not, regs => RV64.not_pseudo (regs.getN 0)
  | .neg, regs => RV64.neg_pseudo (regs.getN 0)
  | .negw, regs => RV64.negw_pseudo (regs.getN 0)
  | .sextw, regs => RV64.sextw_pseudo (regs.getN 0)
  | .zextb, regs => RV64.zextb_pseudo (regs.getN 0)
  | .zextw, regs => RV64.zextw_pseudo (regs.getN 0)
  | .seqz, regs => RV64.seqz_pseudo (regs.getN 0)
  | .snez, regs => RV64.snez_pseudo (regs.getN 0)
  | .sltz, regs => RV64.sltz_pseudo (regs.getN 0)
  | .sgtz, regs => RV64.sgtz_pseudo (regs.getN 0)

Op

inductive Op

  | li : (val : BitVec 64) → Op
  | lui (imm : BitVec 20)
  | auipc (imm : BitVec 20)
  | addi (imm : BitVec 12)
  | andi (imm : BitVec 12)
  | ori (imm : BitVec 12)
  | xori (imm : BitVec 12)
  | addiw (imm : BitVec 12)
  | add
  | slli (shamt : BitVec 6)
  | sub
  | and
  | or
  | xor
  | sll
  | srl
  | sra
  | addw
  | subw
  | sllw
  | srlw
  | sraw
  | slti (imm : BitVec 12)
  | sltiu (imm : BitVec 12)
  | srli (shamt : BitVec 6)
  | srai (shamt : BitVec 6)
  | slliw (shamt : BitVec 5)
  | srliw (shamt : BitVec 5)
  | sraiw (shamt : BitVec 5)
  | slt
  | sltu

  | mul
  | mulw
  | mulh
  | mulhu
  | mulhsu
  | divw
  | divuw
  | div
  | divu
  | remw
  | rem
  | remuw
  | remu

  | adduw
  | sh1adduw
  | sh2adduw
  | sh3adduw
  | sh1add
  | sh2add
  | sh3add
  | slliuw (shamt : BitVec 6)

  | andn
  | orn
  | xnor
  | clz
  | clzw
  | ctz
  | ctzw
  | max
  | maxu
  | min
  | minu
  | sextb
  | sexth
  | zexth
  | rol
  | rolw
  | ror
  | rori (_shamt : BitVec 6)
  | roriw (_shamt : BitVec 5)
  | rorw

  | bclr
  | bclri (shamt : BitVec 6)
  | bext
  | bexti (shamt : BitVec 6)
  | binv
  | binvi (shamt : BitVec 6)
  | bset
  | bseti (shamt : BitVec 6)

  | pack
  | packh
  | packw

  | mv
  | not
  | neg
  | negw
  | sextw
  | zextb
  | zextw
  | seqz
  | snez
  | sltz
  | sgtz
  deriving DecidableEq, Repr, Lean.ToExpr

@[simp]
abbrev RV64 : Dialect where
  Op := Op
  Ty := Ty

Ty

inductive Ty
  | bv : Ty
  deriving DecidableEq, Repr, Inhabited, Lean.ToExpr

@[simp_riscv]
def neg_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.sub rs1_val 0

@[simp_riscv]
def seqz_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.sltiu 1 rs1_val

@[simp_riscv]
def sgtz_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.slt rs1_val 0

@[simp_riscv]
def zextb_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.andi 255 rs1_val

@[simp_riscv]
def snez_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.sltu rs1_val 0

@[simp_riscv]
def sltz_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.slt 0 rs1_val

@[simp_riscv]
def zextw_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.adduw 0 rs1_val

@[simp_riscv]
def sextw_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.addiw 0 rs1_val

@[simp_riscv]
def not_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.xori (-1) rs1_val

@[simp_riscv]
def mv_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.addi 0 rs1_val

@[simp_riscv]
def negw_pseudo (rs1_val : BitVec 64) : BitVec 64 :=
  RV64.subw rs1_val 0

@[simp]
noncomputable instance : DialectDenote (FHE q n) where
    denote
    | Op.add, arg, _ => [(fun args : R q n × R q n => args.1 + args.2) arg.toPair]ₕ
    | Op.sub, arg, _ => [(fun args : R q n × R q n => args.1 - args.2) arg.toPair]ₕ
    | Op.mul, arg, _ => [(fun args : R q n × R q n => args.1 * args.2) arg.toPair]ₕ
    | Op.mul_constant, arg, _ => [(fun args : R q n × Int => args.1 * ↑(args.2)) arg.toPair]ₕ
    | Op.leading_term, arg, _ => [R.leadingTerm arg.toSingle]ₕ
    | Op.monomial, arg, _ => [(fun args => R.monomial ↑(args.1) args.2) arg.toPair]ₕ
    | Op.monomial_mul, arg, _ => [(fun args : R q n × Nat => args.1 * R.monomial 1 args.2) arg.toPair]ₕ
    | Op.from_tensor, arg, _ => [R.fromTensor arg.toSingle]ₕ
    | Op.to_tensor, arg, _ => [R.toTensor' arg.toSingle]ₕ
    | Op.const c, _arg, _
    | Op.const_int c, _, _
    | Op.const_idx c, _, _ => [c]ₕ

R.fromTensor

noncomputable def R.fromTensor {q n} (coeffs : List Int) : R q n :=
  coeffs.zipIdx.foldl (init := 0) fun res (c, i) =>
    res + R.monomial ↑c i

R.monomial

noncomputable def R.monomial {q n : Nat} (c : ZMod q) (i : Nat): R q n :=
  R.fromPoly (Polynomial.monomial i c)

R.fromPoly

abbrev R.fromPoly {q n : Nat} : (ZMod q)[X] →+* R q n := Ideal.Quotient.mk (Ideal.span {f q n})

f

noncomputable def f : (ZMod q)[X] := X^(2^n) + 1

R.leadingTerm

noncomputable def R.leadingTerm {q n} (a : R q n) : R q n :=
  let deg? := Polynomial.degree a.representative
  match deg? with
    | .none => 0
    | .some deg =>  R.monomial (a.coeff deg) deg

R.representative

noncomputable def R.representative :
    R q n → (ZMod q)[X] := fun x => R.representative' q n x %ₘ (f q n)

R.representative'

private noncomputable def R.representative' :
    R q n → (ZMod q)[X] := Function.surjInv (R.surjective_fromPoly q n)

R.coeff

noncomputable def R.coeff {q n} (a : R q n) (i : Nat) : ZMod q :=
  Polynomial.coeff a.representative i

R.toTensor'

noncomputable def R.toTensor' {q n} (a : R q n) : List Int :=
  let t := a.toTensor
  t ++ List.replicate (2^n - t.length + 1) 0

R.toTensor

noncomputable def R.toTensor {q n} (a : R q n) : List Int :=
  List.range a.repLength |>.map fun i =>
        a.coeff i |>.toInt

R.repLength

noncomputable def R.repLength {q n} (a : R q n) : Nat := match
  Polynomial.degree a.representative with
    | none => 0
    | some d => d + 1

instance : DialectDenote LLVM := ⟨
  fun o args _ => [Op.denote o args]ₕ
⟩

@[reducible]
instance : DialectDenote SimpleReg where
  denote
    | .const n, _, _ => BitVec.ofInt 32 n ::ₕ .nil
    | .add, [(a : BitVec 32), (b : BitVec 32)]ₕ , _ => a + b ::ₕ .nil
    | .iterate k, [(x : BitVec 32)]ₕ, [(f : _ → _)]ₕ =>
      let f := fun y => (f y).getN 0
      let f' (v :  BitVec 32) : BitVec 32 := f (Ctxt.Valuation.nil.cons v)
      let y := k.iterate f' x
      [y]ₕ

Op

inductive Op :  Type
  | add : Op
  | const : (val : ℤ) → Op
  | iterate (k : ℕ) : Op
  deriving DecidableEq

add

@[simp_denote]
def add {Γ : Ctxt _} (e₁ e₂ : Var Γ int) : Expr SimpleReg Γ .pure [int] :=
  Expr.mk
    (op := .add)
    (eff_le := by admit /- proof elided -/
    )
    (ty_eq := rfl)
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

SimpleReg.int

abbrev SimpleReg.int : SimpleReg.Ty := .int

SimpleReg

abbrev SimpleReg : Dialect where
  Op := Op
  Ty := Ty

iterate

@[simp_denote]
def iterate {Γ : Ctxt _} (k : Nat) (input : Var Γ int) (body : Com SimpleReg ⟨[int]⟩ .impure [int]) :
    Expr SimpleReg Γ .pure [int] :=
  Expr.mk
    (op := Op.iterate k)
    (eff_le := by admit /- proof elided -/
    )
    (ty_eq := rfl)
    (args := .cons input .nil)
    (regArgs := HVector.cons body HVector.nil)

Ty

inductive Ty
  | int
  deriving DecidableEq

[SIG

instance [SIG : DialectSignature d] [DENOTE : DialectDenote d] {Γ : Ctxt d.Ty} {t}
    (com : Com d Γ .pure t) : Inhabited (DCEType com) where
  default :=
    ⟨Γ, Hom.id, com, by admit /- proof elided -/
    ⟩

Hom.id

@[simp] abbrev Hom.id {Γ : Ctxt Ty} : Γ.Hom Γ :=
  fun _ v => v

@[reducible]
instance : DialectDenote Ex where
  denote
    | .cst n, _, _ => n ::ₕ .nil
    | .add, (a : Nat) ::ₕ b ::ₕ .nil, _ => a + b    ::ₕ .nil
    | .beq, (a : Nat) ::ₕ b ::ₕ .nil, _ => (a == b) ::ₕ .nil

cst

def cst {Γ : Ctxt _} (n : ℕ) : Expr Ex Γ .pure [.nat] :=
  Expr.mk
    (op := .cst n)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .nil)
    (regArgs := .nil)

ExTy

inductive ExTy
  | nat
  | bool
  deriving DecidableEq, Repr

@[simp, reducible]
instance : DialectDenote (LLVMPlusRiscV) where
  denote
  | .llvm llvmOp, args, .nil => do
      let xs ← DialectDenote.denote llvmOp (llvmArgsFromHybrid args) .nil
      return xs.map' Ty.llvm (fun t x => x)
  | .riscv (riscvOp), args, .nil => do
      let xs ← DialectDenote.denote riscvOp (riscvArgsFromHybrid args) .nil
      return xs.map' Ty.riscv (fun t x => x)
  | .castRiscv _ , elemToCast, _ =>
    let toCast : BitVec 64 :=
      elemToCast.getN 0 (by admit /- proof elided -/
      )
    [castriscvToLLVM toCast]ₕ
  | .castLLVM _,
    (elemToCast : HVector TyDenote.toType [Ty.llvm (.bitvec _)]), _ =>
    let toCast : PoisonOr (BitVec _) :=
      elemToCast.getN 0 (by admit /- proof elided -/
      )
    [castLLVMToriscv toCast]ₕ

Op

inductive Op where
  | llvm : LLVM.Op -> Op
  | riscv : RISCV64.RV64.Op -> Op
  | castRiscv : Nat → Op
  | castLLVM : Nat → Op
  deriving DecidableEq, Repr, Lean.ToExpr

castLLVMToriscv

@[simp_riscv]
def castLLVMToriscv (toCast : PoisonOr (BitVec w)) : BitVec 64 :=
  BitVec.signExtend 64 (toCast.toOption.getD 0#w)

PoisonOr

structure PoisonOr (α : Type) where
  ofOption :: toOption : Option α
  deriving DecidableEq

castriscvToLLVM

@[simp_riscv]
def castriscvToLLVM (toCast : BitVec 64) : PoisonOr (BitVec w) :=
  .value (BitVec.signExtend w toCast)

llvmArgsFromHybrid

@[simp_denote]
def llvmArgsFromHybrid : {tys : List LLVM.Ty} →
  HVector TyDenote.toType (tys.map LLVMRiscV.Ty.llvm) → HVector TyDenote.toType tys
  | [], .nil => .nil
  | _ :: _, .cons x xs => .cons x (llvmArgsFromHybrid xs)

Ty

inductive Ty where
  | llvm : LLVM.Ty -> Ty
  | riscv : RISCV64.RV64.Ty -> Ty
  deriving DecidableEq, Repr, Lean.ToExpr

riscvArgsFromHybrid

@[simp_denote]
def riscvArgsFromHybrid : {tys : List RISCV64.RV64.Ty} →
  HVector TyDenote.toType (tys.map LLVMRiscV.Ty.riscv) → HVector TyDenote.toType tys
  | [], .nil => .nil
  | _ :: _, .cons x xs => .cons x (riscvArgsFromHybrid xs)

@[reducible]
instance : DialectDenote ExOp ExTy where
  denote
    | .cst n, _, _ => n
    | .add, .cons (a : Nat) (.cons b .nil), _ => a + b
    | .beq, .cons (a : Nat) (.cons b .nil), _ => a == b

ExOp

inductive ExOp :  Type
  | add : ExOp
  | beq : ExOp
  | cst : ℕ → ExOp
  deriving DecidableEq, Repr

add

def add {Γ : Ctxt _} (e₁ e₂ : Var Γ .nat) : Expr Γ .nat :=
  Expr.mk
    (op := .add)
    (ty_eq := rfl)
    (eff_le := EffectKind.le_refl _)
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

ExTy

inductive ExTy
  | nat
  deriving DecidableEq, Repr

Expr

abbrev Expr (Γ) (ty) := _root_.Expr ExOp Γ .pure ty

cst

def cst {Γ : Ctxt _} (n : ℕ) : Expr Γ .nat  :=
  Expr.mk
    (op := .cst n)
    (ty_eq := rfl)
    (eff_le := EffectKind.le_refl _)
    (args := .nil)
    (regArgs := .nil)

@[reducible]
instance : DialectDenote ExOp ExTy where
  denote
    | .add, .cons (a : Nat) (.cons b .nil), _ => a + b
    | .runK (k : Nat), (.cons (v : Nat) .nil), (.cons rgn _nil) =>
      k.iterate (fun val => rgn (fun _ty _var => val)) v

ExOp

inductive ExOp :  Type
  | add : ExOp
  | runK : ℕ → ExOp
  deriving DecidableEq, Repr

add

def add {Γ : Ctxt _} (e₁ e₂ : Var Γ .nat) : Expr Γ .nat :=
  Expr.mk
    (op := .add)
    (ty_eq := rfl)
    (eff_le := EffectKind.pure_le _)
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

[Monad

@[reducible]
instance [Monad d.m] : DialectDenote (Scf d) where
  denote
    | .coe o', args', regArgs' =>
        let denote' := DialectDenote.denote o'
        by
         exact denote' args' regArgs'
    | .if t t', (.cons (cond ) (.cons v .nil)),
         (.cons (f : Ctxt.Valuation ⟨[t]⟩ → d.m (HVector toType [t'])) (.cons (g : _ → _) .nil)) =>
         let body := if B.denote_eq ▸ cond then f else g
      body (Ctxt.Valuation.nil.cons v)
    | .run _t, (.cons v .nil), (.cons (f : _ → _) .nil) =>
        f (Ctxt.Valuation.nil.cons v)
    | .for ty, (.cons istart (.cons istep (.cons niter (.cons vstart .nil)))),
        (.cons (f : _  → _) .nil) => do
        let istart : ℤ := Z.denote_eq ▸ istart
        let istep : ℤ := Z.denote_eq ▸ istep
        let niter : ℕ := N.denote_eq ▸ niter
        let f' : LoopBody (d.m ⟦ty⟧) := fun i v => do
          let v ← v
          let i := Z.denote_eq.symm ▸ i
          let xs ← f (Valuation.ofPair i v)
          return xs.get (0 : Fin 1)
        let to_iterate := f'.counterDecorator (α := d.m ⟦ty⟧) (δ := istep)
        let loop_fn := niter.iterate (op := to_iterate)
        let x ← (loop_fn (istart, pure vstart)).2
        return [x]ₕ

    | .iterate k, (.cons (x) .nil), (.cons (f : _ → _) .nil) => do
      let x : ℤ := Z.denote_eq ▸ x
      let coe : ℤ = toType Z.ty := Z.denote_eq.symm
      let f' (v : d.m ℤ) : d.m ℤ := do
        let v ← v
        let xs ← f (Ctxt.Valuation.nil.cons (cast coe v))
        let x := xs.getN 0
        return coe ▸ x
      let y ← (k.iterate f' (pure x))
      return [cast Z.denote_eq.symm y]ₕ

counterDecorator

def counterDecorator (δ : Int) (f : LoopBody α) : Int × α → Int × α :=
  fun (i, v) => (i + δ, f i v)

Scf.Op

inductive Scf.Op (Op' Ty' : Type) (m') [TyDenote Ty'] [DialectSignature ⟨Op', Ty', m'⟩]
    [DialectDenote ⟨Op', Ty', m'⟩] : Type _
  | coe (o : Op')
  | iterate (k : ℕ)
  | run (inputty : Ty')
  | if (inputty retty' : Ty')
  | for (ty : Ty')
  deriving DecidableEq, Repr

HasTy

class HasTy (d : Dialect) (DenotedTy : Type) [TyDenote d.Ty] [DialectSignature d] where
    ty : d.Ty
    denote_eq : toType ty = DenotedTy := by admit /- proof elided -/

LoopBody

abbrev LoopBody (t : Type) : Type := Int → t → t

iterate

@[simp_denote] def iterate {Γ : Ctxt _} (k : Nat) (input : Var Γ Arith.Ty.int)
    (body : Com ScfArith ⟨[.int]⟩ .impure .int) : Expr ScfArith Γ .impure .int :=
  Expr.mk
    (op := .iterate k)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons input .nil)
    (regArgs := HVector.cons body HVector.nil)

ScfArith

abbrev ScfArith := Scf Arith

Scf

def Scf (d : Dialect) [TyDenote d.Ty] [DialectSignature d] [DialectDenote d] : Dialect where
  Op := Scf.Op d.Op d.Ty d.m
  Ty := d.Ty
  m  := d.m

Op

inductive Op
  | add : Op
  | add_nat : Op
  | axpy : Op
  | neg : Op
  | const : (val : ℤ) → Op
  | const_nat : (val : ℕ) → Op

run

@[simp_denote]
def run {Γ : Ctxt _} {t : Arith.Ty} (v : Var Γ t) (body : Com ScfArith ⟨[t]⟩ .impure t) :
    Expr ScfArith Γ .impure t :=
  Expr.mk
    (op := .run t)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons v .nil)
    (regArgs := HVector.cons body <| HVector.nil)

Ty

inductive Ty
| int
| bool
| nat
 deriving DecidableEq, Repr

neg

@[simp_denote] def neg {Γ : Ctxt _} (a : Var Γ .int) : Expr ScfArith Γ .pure .int :=
  Expr.mk
    (op := .coe <| .neg)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons a <| .nil)
    (regArgs := .nil)

axpy

@[simp_denote] def axpy {Γ : Ctxt _} (a : Var Γ .int) (x : Var Γ .nat) (b: Var Γ .int) :
    Expr ScfArith Γ .pure .int :=
  Expr.mk
    (op := .coe <| .axpy)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons a <| .cons x <| .cons b .nil)
    (regArgs := .nil)

@[simp_denote] def add_nat (e₁ e₂ : Var Γ .nat) : Expr ScfArith Γ .pure .nat :=
  Expr.mk
    (op := .coe <| .add_nat)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

Ty

inductive Ty
  | int

  | int2
  deriving DecidableEq, Lean.ToExpr

Op

inductive Op
  | noop
  | mkPair
  | unPair
  deriving Lean.ToExpr

Arith

abbrev Arith : Dialect := {Op, Ty}

Valuation.ofPair

def Valuation.ofPair  {t₁ t₂ : Ty} (v₁: ⟦t₁⟧) (v₂ : ⟦t₂⟧) :
    Valuation (Ctxt.ofList [t₁, t₂]) :=
  Valuation.ofHVector (.cons v₁ <| .cons v₂ <| .nil )

@[reducible]
instance : DialectDenote Arith where
  denote
    | .const n, _, _ => [n]ₕ
    | .const_nat n, _, _ => [n]ₕ
    | .neg, .cons (a : ℤ ) .nil, _ => [-a]ₕ
    | .axpy, .cons (a : ℤ) (.cons (x : ℕ) (.cons (b : ℤ) .nil)), _ => [a * (x : ℤ) + b]ₕ
    | .add, .cons (a : ℤ) (.cons (b : ℤ) .nil), _ => [a + b]ₕ
    | .add_nat, .cons (a : ℕ) (.cons (b : ℕ) .nil), _ => [a + b]ₕ

add

@[simp_denote] def add {Γ : Ctxt _} (e₁ e₂ : Var Γ .int) : Expr ScfArith Γ .pure .int :=
  Expr.mk
    (op := .coe <| .add)
    (ty_eq := rfl)
    (eff_le := by admit /- proof elided -/
    )
    (args := .cons e₁ <| .cons e₂ .nil)
    (regArgs := .nil)

      instance : DialectSignature $dialect where
        signature := fun op => match op with $matchAlts:matchAlts
    )

Op.signature

@[simp, reducible]
def Op.signature : Op q n → Signature (Ty q n) :=
  fun o => {sig := Op.sig o, returnTypes := [Op.outTy o], regSig := []}

Op.sig

@[simp, reducible]
def Op.sig : Op q n → List (Ty q n)
| Op.add => [Ty.polynomialLike, Ty.polynomialLike]
| Op.sub => [Ty.polynomialLike, Ty.polynomialLike]
| Op.mul => [Ty.polynomialLike, Ty.polynomialLike]
| Op.mul_constant => [Ty.polynomialLike, Ty.integer]
| Op.leading_term => [Ty.polynomialLike]
| Op.monomial => [Ty.integer, Ty.index]
| Op.monomial_mul => [Ty.polynomialLike, Ty.index]
| Op.from_tensor => [Ty.tensor]
| Op.to_tensor => [Ty.polynomialLike]
| Op.const _ => []
| Op.const_int _ => []
| Op.const_idx _ => []

Op.outTy

@[simp, reducible]
def Op.outTy : Op q n → Ty q n
| Op.add | Op.sub | Op.mul | Op.mul_constant | Op.leading_term | Op.monomial
| Op.monomial_mul | Op.from_tensor | Op.const _  => Ty.polynomialLike
| Op.to_tensor => Ty.tensor
| Op.const_int _ => Ty.integer
| Op.const_idx _ => Ty.index

Op.regSig

@[reducible, simp]
def Op.regSig : Op → RegionSignature Ty
  | .map2d => [([Ty.int], [.int])]
  | _ => []

instance : DialectSignature Ex where
  signature
    | .add    => ⟨[.nat, .nat], [], [.nat], .pure⟩
    | .beq    => ⟨[.nat, .nat], [], [.bool], .pure⟩
    | .cst _  => ⟨[], [], [.nat], .pure⟩

@[reducible]
instance : DialectSignature Tensor2D where
  signature op := { sig := op.sig, regSig := op.regSig, returnTypes := [op.outTy] }

instance : DialectSignature Tensor1D where
  signature op := { sig := op.sig, regSig := op.regSig, returnTypes := [op.outTy], effectKind := .pure }

instance : DialectSignature RV64 where
  signature o := {sig := Op.sig o, returnTypes := [Op.outTy o], regSig := []}

Op.sig

@[simp, reducible]
def Op.sig : Op → List Ty
  | .li _ => []
  | .mulh  => [Ty.bv, Ty.bv]
  | .mulhu  => [Ty.bv, Ty.bv]
  | .mulhsu  => [Ty.bv, Ty.bv]
  | .divu =>  [Ty.bv, Ty.bv]
  | .remuw  => [Ty.bv, Ty.bv]
  | .remu  =>  [Ty.bv, Ty.bv]
  | .addiw (_imm : BitVec 12) => [Ty.bv]
  | .lui (_imm : BitVec 20) => [Ty.bv]
  | .auipc (_imm : BitVec 20)  => [Ty.bv]
  | .slliw (_shamt : BitVec 5)  => [Ty.bv]
  | .srliw (_shamt : BitVec 5) => [Ty.bv]
  | .sraiw (_shamt : BitVec 5) => [Ty.bv]
  | .slli (_shamt : BitVec 6) => [Ty.bv]
  | .srli (_shamt : BitVec 6) => [Ty.bv]
  | .srai (_shamt : BitVec 6) => [Ty.bv]
  | .addw => [Ty.bv, Ty.bv]
  | .subw => [Ty.bv, Ty.bv]
  | .sllw => [Ty.bv, Ty.bv]
  | .srlw => [Ty.bv, Ty.bv]
  | .sraw => [Ty.bv, Ty.bv]
  | .add => [Ty.bv, Ty.bv]
  | .slt => [Ty.bv, Ty.bv]
  | .sltu => [Ty.bv, Ty.bv]
  | .and => [Ty.bv, Ty.bv]
  | .or => [Ty.bv, Ty.bv]
  | .xor => [Ty.bv, Ty.bv]
  | .sll => [Ty.bv, Ty.bv]
  | .srl => [Ty.bv, Ty.bv]
  | .sub => [Ty.bv, Ty.bv]
  | .sra => [Ty.bv, Ty.bv]
  | .remw  => [Ty.bv, Ty.bv]
  | .rem  =>  [Ty.bv, Ty.bv]
  | .mul => [Ty.bv, Ty.bv]
  | .mulw => [Ty.bv, Ty.bv]
  | .div  =>  [Ty.bv, Ty.bv]
  | .divw  =>  [Ty.bv, Ty.bv]
  | .divuw  =>  [Ty.bv, Ty.bv]
  | .addi (_imm : BitVec 12) => [Ty.bv]
  | .slti (_imm : BitVec 12) => [Ty.bv]
  | .sltiu (_imm : BitVec 12) => [Ty.bv]
  | .andi (_imm : BitVec 12) => [Ty.bv]
  | .ori (_imm : BitVec 12) => [Ty.bv]
  | .xori (_imm : BitVec 12) => [Ty.bv]
  | .bclr => [Ty.bv, Ty.bv]
  | .bext => [Ty.bv, Ty.bv]
  | .binv => [Ty.bv, Ty.bv]
  | .bset  => [Ty.bv, Ty.bv]
  | .bclri (_shamt : BitVec 6) => [Ty.bv]
  | .bexti (_shamt : BitVec 6) => [Ty.bv]
  | .binvi (_shamt : BitVec 6) => [Ty.bv]
  | .bseti (_shamt : BitVec 6) => [Ty.bv]
  | .adduw => [Ty.bv, Ty.bv]
  | .sh1adduw => [Ty.bv, Ty.bv]
  | .sh2adduw => [Ty.bv, Ty.bv]
  | .sh3adduw => [Ty.bv, Ty.bv]
  | .sh1add => [Ty.bv, Ty.bv]
  | .sh2add => [Ty.bv, Ty.bv]
  | .sh3add => [Ty.bv, Ty.bv]
  | .slliuw (_shamt : BitVec 6) => [Ty.bv]
  | .andn => [Ty.bv, Ty.bv]
  | .orn => [Ty.bv, Ty.bv]
  | .xnor => [Ty.bv, Ty.bv]
  | .clz
  | .clzw
  | .ctz
  | .ctzw
  | .max => [Ty.bv, Ty.bv]
  | .maxu => [Ty.bv, Ty.bv]
  | .min  => [Ty.bv, Ty.bv]
  | .minu  => [Ty.bv, Ty.bv]
  | .sextb => [Ty.bv]
  | .sexth => [Ty.bv]
  | .zexth => [Ty.bv]
  | .rol => [Ty.bv, Ty.bv]
  | .rolw => [Ty.bv, Ty.bv]
  | .ror => [Ty.bv, Ty.bv]
  | .rori (_shamt : BitVec 6) =>[Ty.bv]
  | .roriw (_shamt : BitVec 5) =>[Ty.bv]
  | .rorw => [Ty.bv, Ty.bv]
  | .pack => [Ty.bv, Ty.bv]
  | .packh => [Ty.bv, Ty.bv]
  | .packw => [Ty.bv, Ty.bv]
  | .mv => [Ty.bv]
  | .not => [Ty.bv]
  | .neg => [Ty.bv]
  | .negw => [Ty.bv]
  | .sextw => [Ty.bv]
  | .zextb => [Ty.bv]
  | .zextw => [Ty.bv]
  | .seqz => [Ty.bv]
  | .snez => [Ty.bv]
  | .sltz => [Ty.bv]
  | .sgtz => [Ty.bv]

instance : DialectSignature (FHE q n) := ⟨Op.signature⟩

instance : DialectSignature LLVM where
  signature op := ⟨op.sig, [], [op.outTy], .pure⟩

instance : DialectSignature HSxComb where
  signature := fun op =>
    match op with
    | .comb o => liftSig (signature o)

    | .hs o => MLIR2Handshake.instDialectSignatureHandshake.signature o

Op

inductive Op : Type _
  | comb (o : MLIR2Comb.Comb.Op)
  | hs (o : MLIR2Handshake.Handshake.Op)
  deriving Inhabited, DecidableEq, Repr, Lean.ToExpr

liftSig

def liftSig (sig : Signature MLIR2Comb.Ty) : Signature MLIR2Handshake.Ty :=
  Signature.mk (sig.sig.map liftTy) [] (liftTy sig.outTy)

liftTy

def liftTy : MLIR2Comb.Ty → MLIR2Handshake.Ty
| .bitvec w => .stream (.bitvec w)

Ty

inductive Ty
| stream (ty2 : Ty2) : Ty
| stream2 (ty2 : Ty2) : Ty
| stream2token (ty2 : Ty2) : Ty
deriving Inhabited, DecidableEq, Repr, Lean.ToExpr

inductive Ty
| bitvec (w : Nat) : Ty
deriving DecidableEq, Repr, ToExpr

inductive Ty2
  | bitvec (w : Nat) : Ty2
deriving Inhabited, DecidableEq, Repr, Lean.ToExpr

map

def map {α β : Type} (s : Stream α) (f : α → β) : Stream β :=
  fun i => (s i).map f

Stream

def Stream (β : Type) := Stream' (Option β)

instance : DialectSignature DCxComb where
  signature := fun op =>
    match op with
    | .comb o => liftSig (signature o)

    | .dc o => MLIR2DC.instDialectSignatureDC.signature o

Op

inductive Op : Type _
  | comb (o : MLIR2Comb.Comb.Op)
  | dc (o : MLIR2DC.DC.Op)
  deriving Inhabited, DecidableEq, Repr, Lean.ToExpr

liftSig

def liftSig (sig : Signature MLIR2Comb.Ty) : Signature MLIR2DC.Ty :=
  Signature.mk (sig.sig.map liftTy) [] (liftTy sig.outTy)

liftTy

def liftTy : MLIR2Comb.Ty → MLIR2DC.Ty
| .bitvec w => .valuestream w

Ty

inductive Ty
| tokenstream : Ty
| tokenstream2 : Ty
| valuestream (w : Nat) : Ty
| valuestream2 (w : Nat) : Ty
| valuetokenstream (w : Nat) : Ty
| variadicvaluetokenstream (w : Nat) : Ty
deriving Inhabited, DecidableEq, Repr, Lean.ToExpr

LLVMPlusRiscVSignature

@[simp]
instance LLVMPlusRiscVSignature : DialectSignature LLVMPlusRiscV where
  signature
  | .llvm llvmOp => .llvm <$> DialectSignature.signature llvmOp
  | .riscv riscvOp => .riscv <$> DialectSignature.signature riscvOp
  | .castRiscv w =>
      {sig := [Ty.riscv .bv], returnTypes := [Ty.llvm (.bitvec w)], regSig := []}
  | .castLLVM w =>
      {sig := [Ty.llvm (.bitvec w)], returnTypes := [Ty.riscv .bv], regSig := []}

instance : DialectSignature ExOp ExTy where
  signature
    | .add    => ⟨[.nat, .nat], [], .nat, .pure⟩
    | .beq    => ⟨[.nat, .nat], [], .bool, .pure⟩
    | .cst _  => ⟨[], [], .nat, .pure⟩

instance : DialectSignature ExOp ExTy where
  signature
  | .add    => ⟨[.nat, .nat], [], .nat, .pure⟩
  | .runK _ => ⟨[.nat], [([.nat], .nat)], .nat, .pure⟩

[TyDenote

@[reducible]
instance [TyDenote d.Ty] [DialectSignature d] [DialectDenote d]
    [B : HasBool d] [N : HasNat d] [I : HasInt d] : DialectSignature (Scf d) where
   signature
   | .coe o => signature (d:=d) o
    | .if t t' => ⟨[B.ty, t], [(⟨[t]⟩, [t']), (⟨[t]⟩, [t'])], [t'], .impure⟩

    | .for t => ⟨[ I.ty,  I.ty,  N.ty, t], [(⟨[I.ty, t]⟩, [t])], [t], .impure⟩
    | .run t => ⟨[t], [(⟨[t]⟩, [t])], [t], .impure⟩
    | .iterate _k => ⟨[I.ty], [(⟨[I.ty]⟩, [I.ty])], [I.ty], .impure⟩

@[reducible]
instance : DialectSignature Arith where
  signature
    | .axpy => ⟨[.int, .nat, .int], [], [.int], .pure⟩
    | .neg => ⟨[.int], [], [.int], .pure⟩
    | .const _ => ⟨[], [], [.int], .pure⟩
    | .const_nat _ => ⟨[], [], [.nat], .pure⟩
    | .add   => ⟨[.int, .int], [], [.int], .pure⟩
    | .add_nat   => ⟨[.nat, .nat], [], [.nat], .pure⟩

infixr:50 "::ₕ" => HVector.cons

TyDenote.toType

notation "⟦" x "⟧" => TyDenote.toType x

infixr:67 "::ᵥ" => Valuation.cons

@[simp]
theorem pure_liftEffect {eff₁ eff₂ : EffectKind}
    (hle : eff₁ ≤ .pure) [Monad m] (x : eff₁.toMonad m α) :
    (Pure.pure (liftEffect hle x) : eff₂.toMonad m α)
    = liftEffect (by cases hle; constructor) x

@[simp]
theorem eq_of_le_pure {e : EffectKind}
    (he : e ≤ pure) : e = pure

theorem pure_map (f : α → β) (x : pure.toMonad m α) (eff : EffectKind) :
    (Pure.pure (f <$> x : pure.toMonad m _) : eff.toMonad m _) = f <$> (Pure.pure x)

RegionSignature

abbrev RegionSignature Ty := List (Ctxt Ty × List Ty)

Signature

structure Signature (Ty : Type) where
  mkEffectful ::
  sig         : List Ty
  regSig      : RegionSignature Ty
  returnTypes : List Ty
  effectKind  : EffectKind := .pure

Signature.mk

abbrev Signature.mk (sig : List Ty) (regSig : RegionSignature Ty) (returnTypes : List Ty) : Signature Ty :=
 { sig, regSig, returnTypes }

DialectSignature

class DialectSignature (d : Dialect) where
  signature : d.Op → Signature d.Ty

DialectSignature.sig

def sig          := Signature.sig ∘ s.signature

DialectSignature.regSig

def regSig       := Signature.regSig ∘ s.signature

DialectSignature.returnTypes

def returnTypes  := Signature.returnTypes ∘ s.signature

DialectSignature.effectKind

def effectKind   := Signature.effectKind ∘ s.signature

Expr.outContext

abbrev Expr.outContext (_ : Expr d Γ eff ts) : Ctxt d.Ty :=
  ts ++ Γ

Regions

abbrev Regions (regSig : RegionSignature d.Ty) : Type :=
  HVector (fun t => Com d t.1 .impure t.2) regSig

Expr.op

def Expr.op {Γ : Ctxt d.Ty} {eff : EffectKind} {ty} (e : Expr d Γ eff ty) : d.Op :=
  Expr.casesOn e (fun op _ _ _ _ => op)

Expr.args

def Expr.args {Γ ts} (e : Expr d Γ eff ts) :
    HVector (Var Γ) (DialectSignature.sig e.op) :=
  Expr.casesOn e (fun _ _ _ args _ => args)

Expr.regArgs

def Expr.regArgs {Γ ts} (e : Expr d Γ eff ts) :
    Regions d (DialectSignature.regSig e.op) :=
  Expr.casesOn e (fun _ _ _ _ regArgs => regArgs)

Com.outContext

def Com.outContext {Γ} : Com d Γ eff ts → Ctxt d.Ty :=
  Com.rec' (motive := fun _ => Ctxt d.Ty)
    (@fun Γ _ => Γ)
    (fun _ _ r => r)

Expr.castPureToEff

def Expr.castPureToEff (eff : EffectKind) : Expr d Γ .pure t → Expr d Γ eff t :=
  changeEffect (EffectKind.pure_le eff)

@[simp]
theorem Expr.op_mk {Γ : Ctxt d.Ty} {ty} {eff : EffectKind} (op : d.Op)
    (ty_eq : ty = DialectSignature.returnTypes op)
    (eff_le : DialectSignature.effectKind op ≤ eff)
    (args : HVector (Var Γ) (DialectSignature.sig op))
    (regArgs) :
    (Expr.mk op ty_eq eff_le args regArgs).op = op

@[simp]
theorem Expr.args_mk {Γ : Ctxt d.Ty} {ty eff op}
    (ty_eq : ty = DialectSignature.returnTypes op)
    (eff_le : DialectSignature.effectKind op ≤ eff)
    (args : HVector (Var Γ) (DialectSignature.sig op)) (regArgs) :
    (Expr.mk op ty_eq eff_le args regArgs).args = args

@[simp]
theorem Expr.regArgs_mk {Γ : Ctxt d.Ty} {ty eff op}
    (ty_eq : ty = DialectSignature.returnTypes op)
    (eff_le : DialectSignature.effectKind op ≤ eff)
    (args : HVector (Var Γ) (DialectSignature.sig op)) (regArgs) :
    (Expr.mk op ty_eq eff_le args regArgs).regArgs = regArgs

theorem Expr.denote_unfold (e : Expr d Γ eff ty) :
    e.denote = fun V => (· ++ V) <$> (e.denoteOp V)

import LeanMLIR.ErasedContext

import LeanMLIR.HVector

import LeanMLIR.EffectKind

import LeanMLIR.Framework.Dialect

import Mathlib.Data.Finset.Union

open Ctxt (Var VarSet Valuation Hom)

open TyDenote (toType)

abbrev RegionSignature Ty := List (Ctxt Ty × List Ty)

structure Signature (Ty : Type) where
  mkEffectful ::
  sig         : List Ty
  regSig      : RegionSignature Ty
  returnTypes : List Ty
  effectKind  : EffectKind := .pure

abbrev Signature.mk (sig : List Ty) (regSig : RegionSignature Ty) (returnTypes : List Ty) : Signature Ty :=
 { sig, regSig, returnTypes }

class DialectSignature (d : Dialect) where
  signature : d.Op → Signature d.Ty

namespace DialectSignature

variable {d} [s : DialectSignature d]

def sig          := Signature.sig ∘ s.signature

def regSig       := Signature.regSig ∘ s.signature

def returnTypes  := Signature.returnTypes ∘ s.signature

def effectKind   := Signature.effectKind ∘ s.signature

end DialectSignature

class DialectDenote (d : Dialect) [TyDenote d.Ty] [DialectSignature d] where
  denote : (op : d.Op) → HVector toType (DialectSignature.sig op) →
    (HVector (fun t : Ctxt d.Ty × List d.Ty =>
      t.1.Valuation
      → EffectKind.impure.toMonad d.m (HVector toType t.2))
            (DialectSignature.regSig op)) →
    ((DialectSignature.effectKind op).toMonad d.m
      (HVector toType <| DialectSignature.returnTypes op))

section DataStructures

variable (d : Dialect) [DialectSignature d]

inductive Expr : (Γ : Ctxt d.Ty) → (eff : EffectKind) → (ty : List d.Ty) → Type where
  | mk {Γ} {ty} (op : d.Op)
    (ty_eq : ty = DialectSignature.returnTypes op)
    (eff_le : DialectSignature.effectKind op ≤ eff)
    (args : HVector (Var Γ) <| DialectSignature.sig op)

    (regArgs : HVector (fun t : Ctxt d.Ty × List d.Ty => Com t.1 .impure t.2)
      (DialectSignature.regSig op)) : Expr Γ eff ty

inductive Com : Ctxt d.Ty → EffectKind → List d.Ty → Type where
  | rets {Γ} {tys} {eff : EffectKind} (vs : HVector Γ.Var tys) : Com Γ eff tys
  | var (e : Expr Γ eff ty) (body : Com (ty ++ Γ) eff β) : Com Γ eff β

end

abbrev Expr.outContext (_ : Expr d Γ eff ts) : Ctxt d.Ty :=
  ts ++ Γ

abbrev Regions (regSig : RegionSignature d.Ty) : Type :=
  HVector (fun t => Com d t.1 .impure t.2) regSig

inductive Lets (Γ_in : Ctxt d.Ty) (eff : EffectKind) :
    (Γ_out : Ctxt d.Ty) → Type where
  | nil : Lets Γ_in eff Γ_in
  | var (body : Lets Γ_in eff Γ_out) (e : Expr d Γ_out eff t) : Lets Γ_in eff e.outContext

variable {d} [DialectSignature d]

protected instance HVector.decidableEqReg [DecidableEq d.Op] [DecidableEq d.Ty] :
    ∀ {l : RegionSignature d.Ty}, DecidableEq (HVector (fun t => Com d t.1 .impure t.2) l)
  | _, .nil, .nil => isTrue rfl
  | _, .cons x₁ v₁, .cons x₂ v₂ =>
    letI := HVector.decidableEqReg v₁ v₂
    letI := Com.decidableEq x₁ x₂
    decidable_of_iff (x₁ = x₂ ∧ v₁ = v₂) (by admit /- proof elided -/
    )

protected instance Expr.decidableEq [DecidableEq d.Op] [DecidableEq d.Ty] :
    {Γ : Ctxt d.Ty} → {ty : List d.Ty} → DecidableEq (Expr d Γ eff ty)
  | Γ, _, .mk op₁ rfl eff_le₁ arg₁ regArgs₁, .mk op₂ eq eff_le₂ arg₂ regArgs₂ =>
    if ho : op₁ = op₂ then by
      subst ho
      letI := HVector.decidableEq arg₁ arg₂
      letI := HVector.decidableEqReg regArgs₁ regArgs₂
      exact decidable_of_iff (arg₁ = arg₂ ∧ regArgs₁ = regArgs₂) (by admit /- proof elided -/
      )
    else isFalse (by admit /- proof elided -/
    )

protected instance Com.decidableEq [DecidableEq d.Op] [DecidableEq d.Ty]
    {Γ : Ctxt d.Ty} {eff : EffectKind} {tys : List d.Ty} : DecidableEq (Com d Γ eff tys)
  | .rets v₁, .rets v₂ => decidable_of_iff (v₁ = v₂) (by admit /- proof elided -/
  )
  | .var (ty := ty₁) e₁ body₁, .var (ty := ty₂) e₂ body₂ =>
    if hα : ty₁ = ty₂
    then by
      subst hα
      letI := Expr.decidableEq e₁ e₂
      letI := Com.decidableEq body₁ body₂
      exact decidable_of_iff (e₁ = e₂ ∧ body₁ = body₂) (by admit /- proof elided -/
      )
    else isFalse (by admit /- proof elided -/
    )
  | .rets _, .var _ _ => isFalse (fun h => Com.noConfusion h)
  | .var _ _, .rets _ => isFalse (fun h => Com.noConfusion h)

end -- decEq

end DataStructures

variable {d : Dialect} [DialectSignature d]

section Rec

variable {eff t} {motive : ∀ {Γ}, Com d Γ eff t → Sort u}
          (rets : ∀ {Γ : Ctxt _} , (v : HVector Γ.Var t) → motive (Com.rets v))
          (var : ∀ {Γ} {u},
            (e : Expr d Γ eff u) → (body : Com d e.outContext eff t) →
              motive body → motive (Com.var e body))

def Com.rec' {Γ} (com : Com d Γ eff t) : motive com :=

  Com.rec
    (motive_1 := fun _ _ _ _ => PUnit)
    (motive_2 := fun _ eff' t' c =>
      (h₁ : eff = eff') → (h₂ : t = t') → motive (h₁ ▸ h₂ ▸ c))
    (motive_3 := fun _ _ => PUnit)
    (fun _ _ _ _ _ _ => ⟨⟩)
    (fun v h₁ h₂ =>
      cast (by admit /- proof elided -/
      ) <| rets (h₂ ▸ v))
    (fun e' body' _ r' h₁ h₂ =>
      let e := h₁ ▸ e'
      let body : Com _ _ eff t := cast (by admit /- proof elided -/
      ) body'
      let r : motive body := cast (by admit /- proof elided -/
      ) (r' h₁ h₂)
      cast (by admit /- proof elided -/
      ) <| var e body r)
    ⟨⟩
    (fun _ _ _ _ => ⟨⟩)
    com
    rfl
    rfl

variable {rets} {var} {Γ : Ctxt _}

end Rec

def Expr.op {Γ : Ctxt d.Ty} {eff : EffectKind} {ty} (e : Expr d Γ eff ty) : d.Op :=
  Expr.casesOn e (fun op _ _ _ _ => op)

def Expr.args {Γ ts} (e : Expr d Γ eff ts) :
    HVector (Var Γ) (DialectSignature.sig e.op) :=
  Expr.casesOn e (fun _ _ _ args _ => args)

def Expr.regArgs {Γ ts} (e : Expr d Γ eff ts) :
    Regions d (DialectSignature.regSig e.op) :=
  Expr.casesOn e (fun _ _ _ _ regArgs => regArgs)

section Lemmas

namespace Com

end Com

end Lemmas

def Com.outContext {Γ} : Com d Γ eff ts → Ctxt d.Ty :=
  Com.rec' (motive := fun _ => Ctxt d.Ty)
    (@fun Γ _ => Γ)
    (fun _ _ r => r)

section Lemmas

end Lemmas

variable [TyDenote d.Ty] [DialectDenote d] [DecidableEq d.Ty] [Monad d.m] [LawfulMonad d.m]

def HVector.denote :
    {l : RegionSignature d.Ty} → (T : HVector (fun t => Com d t.1 .impure t.2) l) →
    HVector (fun t => t.1.Valuation → EffectKind.impure.toMonad d.m (HVector toType t.2)) l
  | _, .nil => HVector.nil
  | _, .cons v vs => HVector.cons (v.denote) (HVector.denote vs)

def Expr.denote {ty} (e : Expr d Γ eff ty) (V : Valuation Γ) :
    eff.toMonad d.m (e.outContext.Valuation) :=
  match e with
  | ⟨op, ty_eq, heff, args, regArgs⟩ => do
      let argsDenote := args.map V
      let val ← EffectKind.liftEffect heff <| DialectDenote.denote op argsDenote regArgs.denote
      return (val ++ V).cast (by admit /- proof elided -/
      )

def Com.denote : Com d Γ eff ty → (Γv : Valuation Γ) →
    eff.toMonad d.m (HVector toType ty)
  | .rets vs, Γv     => pure (vs.map Γv)
  | .var e body, V => e.denote V >>= body.denote

end

def Lets.denote [DialectSignature d] [DialectDenote d] {Γ₂}
    (lets : Lets d Γ₁ eff Γ₂) (V : Valuation Γ₁) : (eff.toMonad d.m <| Valuation Γ₂) :=
  match lets with
  | .nil          => return V
  | .var lets' e  => lets'.denote V >>= e.denote

section Unfoldings

open EffectKind (liftEffect)

def Expr.denoteOp (e : Expr d Γ eff ty) (V : Γ.Valuation) :
    eff.toMonad d.m (HVector toType ty) :=
  EffectKind.liftEffect e.eff_le <| cast (by admit /- proof elided -/
  ) <|
    DialectDenote.denote e.op (e.args.map V) e.regArgs.denote

end Unfoldings

section Lemmas

end Lemmas

section Lemmas

variable {Γ Γ' : Ctxt d.Ty} {t} (f : Γ.Hom Γ') (e : Expr d Γ eff t) (V : Γ'.Valuation)

end Lemmas

structure FlatCom (d : Dialect) [DialectSignature d]  (Γ_in : Ctxt d.Ty) (eff : EffectKind)
    (Γ_out : Ctxt d.Ty) (ts : List d.Ty) where
  lets : Lets d Γ_in eff Γ_out
  rets : HVector Γ_out.Var ts

@[simp] abbrev FlatCom.denote [DialectDenote d]
    (flatCom : FlatCom d Γ eff Γ_out ts)
    (V : Γ.Valuation) : eff.toMonad d.m (HVector toType ts) :=
  flatCom.lets.denote V >>= (return flatCom.rets.map ·)

def Expr.changeEffect {eff₁ eff₂ : EffectKind} (h : eff₁ ≤ eff₂) :
    Expr d Γ eff₁ t → Expr d Γ eff₂ t
  | Expr.mk op ty_eq eff_le args regArgs =>
    have heff : DialectSignature.effectKind op ≤ eff₂ := by admit /- proof elided -/

def Expr.castPureToEff (eff : EffectKind) : Expr d Γ .pure t → Expr d Γ eff t :=
  changeEffect (EffectKind.pure_le eff)

section Lemmas

@[simp] theorem Expr.denote_castPureToEff {e : Expr d Γ .pure t} :
    denote (e.castPureToEff eff) = fun V => pure (e.denote V) :=

:= by
  rcases e with ⟨op, rfl, eff_le, _, _⟩
  cases eff
  case pure => rfl
  case impure =>
    funext V
    simp only [castPureToEff, changeEffect, denote_unfold, denoteOp, op_mk, args_mk, regArgs_mk,
      EffectKind.pure_map, EffectKind.pure_liftEffect]


import SSA.Projects.CIRCT.Stream.Stream
import Mathlib.Data.Stream.Init
import Mathlib.Logic.Function.Iterate

syntax "neg" : MLIR.Pretty.uniform_op

syntax "neg" : MLIR.Pretty.uniform_op

macro_rules
  | `(mlir_op| $res:mlir_op_operand = const ($x)
      $[: $outer_type]? ) => do
      let outer_type ← outer_type.getDM `(mlir_type| _)
      `(mlir_op| $res:mlir_op_operand = "const"()
          {val = $x:num : $outer_type} : ($outer_type) -> ($outer_type) )

macro_rules
  | `(mlir_op| $res:mlir_op_operand = li ($x)
     $[: $outer_type]?  ) => do
      let outer_type ← outer_type.getDM `(mlir_type| _ )
      `(mlir_op| $res:mlir_op_operand = "li"()
          {imm = $x:num : $outer_type } : ($outer_type) -> ($outer_type))

macro_rules
| `(mlir_op| $res:mlir_op_operand = $op1:MLIR.Pretty.RV.opWithImmediate $reg1 , $x : $t)  => do
    let some opName := MLIR.EDSL.Pretty.extractOpName op1.raw
      | Macro.throwUnsupported
    `(mlir_op| $res:mlir_op_operand = $opName ($reg1) {imm = $x:num : $t} : ($t) -> ($t) )

macro_rules
| `(mlir_op| $res:mlir_op_operand = $op1:MLIR.Pretty.RV.opWithShamt $reg1 , $x  : $t )  => do
    let some opName := MLIR.EDSL.Pretty.extractOpName op1.raw
      | Macro.throwUnsupported
    `(mlir_op| $res:mlir_op_operand = $opName ($reg1) {shamt = $x:num : $t}  : ($t) -> ($t) )

Stream

def Stream (β : Type) := Stream' (Option β)

head

def head : Stream α → Option α := Stream'.head

tail

def tail : Stream α → Stream α := Stream'.tail

corec

def corec {α} {β} (s0 : β) (f : β → (Option α × β)) : Stream α :=
  Stream'.corec (f · |>.fst) (f · |>.snd) s0

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

CIRCTStream.Stream.removeNone

theorem nonesUntilSome_spec (x : Stream α) (not_stuck : x ≠ stuck α) :
    (dropLeadingNones x not_stuck).head.isSome
    ∧ ∀ j < nonesUntilSome x not_stuck, x.get j = none

@[simp] theorem head_removeNone (x : Stream α) :
    x.removeNone.head =
      if h : x ≠ stuck α then
        (x.dropLeadingNones h).head
      else
        none

import SSA.Projects.CIRCT.Stream.Stream

import Mathlib.Logic.Function.Iterate

import Mathlib.Data.Stream.Init

namespace CIRCTStream

namespace Stream

namespace Bisim

scoped infix:50 " ~ " => Bisim

end Bisim

open Bisim

def stuck (α : Type) : Stream α := Stream'.const none

noncomputable def nonesUntilSome (x : Stream α) (not_stuck : x ≠ stuck α) : Nat :=
  prop.choose
where
  prop : ∃ i, (x.drop i).head.isSome ∧ ∀ j < i, x.get j = none := by admit /- proof elided -/

noncomputable def dropLeadingNones (x : Stream α) (not_stuck : x ≠ stuck α) : Stream α:=
  x.drop (nonesUntilSome x not_stuck)

open Classical in

noncomputable def removeNone (x : Stream α) : Stream α :=
  Stream.corec x fun x =>
    if h : x ≠ stuck α then
      let x := x.dropLeadingNones h
      (x.head, x.tail)
    else
      (none, x)

open Classical in

open Classical in

open Classical in

theorem removeNone_equiv (x : Stream α) :
    x.removeNone ~ x :=

:= by
  apply Bisim.coinduct (· = ·.removeNone)
  · rintro _ x rfl
    · use 0
      simp only [Nat.zero_add, Nat.not_lt_zero, false_implies, implies_true, true_and]
      by_cases x_eq_stuck : x = stuck α
      case pos =>
        subst x_eq_stuck
        refine ⟨0, ?_, ?_, by intros; contradiction⟩
        · show tail _ = removeNone (stuck α).tail; simp
        · show head _ = none; simp
      case neg =>
        have ⟨_, h2⟩ := nonesUntilSome_spec x x_eq_stuck
        refine ⟨nonesUntilSome x x_eq_stuck, ?_, ?_, h2⟩
        · show x.removeNone.tail = removeNone (Stream'.drop _ x)
          have (w : Nat) : x.drop (w + 1) = tail (x.drop w) := by simp [tail]
          rw [this]
          simp [x_eq_stuck]
          rfl
        · show x.removeNone.head = _
          simp only [head_removeNone, ne_eq, x_eq_stuck, dropLeadingNones]
          simp [head]
  · rfl


import Mathlib.Data.Nat.Size -- TODO: remove and get rid of shiftLeft_eq_mul_pow use

syntax "max" : MLIR.Pretty.uniform_op

syntax "max" : MLIR.Pretty.uniform_op

syntax "slt" : MLIR.Pretty.uniform_op

syntax "xor" : MLIR.Pretty.uniform_op

carry

def carry (initCarry : Bool) (x y : BitStream) : BitStream :=
  fun n => (addAux' initCarry x y n).2

BitStream

def BitStream : Type := Nat → Bool

addAux'

def addAux' (carryIn : Bool) (x y : BitStream) (i : Nat) :  Bool × Bool :=
  let carryIn : Bool := match i with
    | 0 => carryIn
    | i + 1 => (addAux' carryIn x y i).2
  Prod.swap (BitVec.adcb (x i) (y i) carryIn)

BitVec.ofFn

def BitVec.ofFn {w : Nat} (f : Fin w → Bool) : BitVec w :=
  BitVec.iunfoldr (fun i _ => ((), f i)) () |>.2

f

noncomputable def f : (ZMod q)[X] := X^(2^n) + 1

worklistRun

def worklistRun (final : S → Bool) (inits : Array S)
    (hinits : inits.toList.Nodup) (f : S → Array (BitVec n × S)) : CNFA n :=
  ⟨worklistRun' _ S final inits hinits f, worklistRun'_wf (BitVec n) S⟩

worklistRun'

def worklistRun' (final : S → Bool) (inits : Array S) (hinits : inits.toList.Nodup) (f : S → Array (A × S)) : RawCNFA A :=
  let st0 := worklist.initState _ _ inits hinits final
  go st0
where go (st0 : worklist.St A S) : RawCNFA A :=
  if hemp : st0.worklist.isEmpty then st0.m else
  let sa? := st0.worklist.back?
  match heq : sa? with
  | some sa =>
    let wl := st0.worklist.pop
    let st1 := { st0 with worklist := wl,
                          worklist_nodup := by admit /- proof elided -/

worklist.St

structure worklist.St where
  m : RawCNFA A
  map : Std.HashMap S State := ∅
  worklist : Array S := ∅
  worklist_nodup : worklist.toList.Nodup
  worklist_incl : ∀ sa ∈ worklist, sa ∈ map

worklist.initState

def worklist.initState (inits : Array S) (hinits : inits.toList.Nodup) (final? : S → Bool) : worklist.St A S :=
  let m := RawCNFA.empty (A := A)
  let mapm := inits.foldl (init := (Std.HashMap.emptyWithCapacity, m)) fun (map, m) sa =>
    let (s, m) := m.newState
    let m := m.addInitial s
    let m := if final? sa then m.addFinal s else m
    (map.insert sa s, m)
  let map := mapm.1
  let m := mapm.2
  let worklist_incl : ∀ sa ∈ inits, sa ∈ map :=

RawCNFA.statesFinset

instance RawCNFA.statesFinset (m : RawCNFA A) : Fintype m.states := (Finset.range m.stateMax).fintypeCoeSort

State

abbrev State := Nat

RawCNFA.empty

def RawCNFA.empty : RawCNFA A := {
  stateMax := 0
  initials := ∅
  finals := ∅
  trans := ∅
}

processOneElem

def processOneElem (final : S → Bool) (s : State) (st : worklist.St A S) : A × S → worklist.St A S :=
  fun (a', sa') =>
    let (s', st') := st.addOrCreateState _ _ (final sa') sa'
    let m := st'.m.addTrans a' s s'
    { st' with m }

worklist.St.addOrCreateState

def worklist.St.addOrCreateState (st : worklist.St A S) (final? : Bool) (sa : S) : State × worklist.St A S :=
  match heq : st.map[sa]? with
  | some s => (s, st)
  | none =>
    let (s, m) := st.m.newState
    let m := if final? then m.addFinal s else m
    let map := st.map.insert sa s
    let worklist := st.worklist.push sa
    have worklist_nodup : worklist.toList.Nodup := by admit /- proof elided -/

CNFA

structure CNFA (n : Nat) where
  m : RawCNFA (BitVec n)
  wf : m.WF

FSM

structure FSM (arity : Type) : Type 1 where

  ( α  : Type )
  [ i : FinEnum α ]
  [ h : Hashable α ]
  [ dec_eq : DecidableEq α ]

  ( initCarry : α → Bool )

  outputCirc : Circuit (α ⊕ arity)
  nextStateCirc : α → Circuit (α ⊕ arity)

Circuit

inductive Circuit (α : Type u) : Type u
  | tru : Circuit α
  | fals : Circuit α

  | var : (positive: Bool) → α → Circuit α
  | and : Circuit α → Circuit α → Circuit α
  | or : Circuit α → Circuit α → Circuit α
  | xor : Circuit α → Circuit α → Circuit α
deriving Repr, DecidableEq

Var

def Var (Γ : Context Ty) (ty : Ty) : Type := { v : VarName // Γ.hasType v ty }

sub

def sub (x y : BitStream) : BitStream :=
  fun n => (subAux x y n).1

subAux

def subAux (x y : BitStream) : Nat → Bool × Bool
  | 0 => (xor (x 0) (y 0), !(x 0) && y 0)
  | n+1 =>
    let borrow := (subAux x y n).2
    let a := x (n + 1)
    let b := y (n + 1)
    (xor a (xor b borrow), !a && b || ((!(xor a b)) && borrow))

ofTerm

abbrev ofTerm (t : Term) : FSM (Fin t.arity) := termEvalEqFSM t |>.toFSM

Term

inductive Term : Type
| var : Nat → Term

| zero : Term

| negOne : Term

| one : Term

| ofNat (n : Nat) : Term

| and : Term → Term → Term

| or : Term → Term → Term

| xor : Term → Term → Term

| not : Term → Term

| add : Term → Term → Term

| sub : Term → Term → Term

| neg : Term → Term

| shiftL : Term → Nat → Term

deriving Repr, Inhabited, Lean.ToExpr

termEvalEqFSM

def termEvalEqFSM : ∀ (t : Term), FSMTermSolution t
  | ofNat n =>
    { toFSM := FSM.ofNat n,
      good := by admit /- proof elided -/

or

def or : FSM Bool :=
  { α := Empty,
    initCarry := Empty.elim,
    outputCirc := Circuit.var true (inr true) ||| Circuit.var true (inr false),
    nextStateCirc := fun a => a.elim
  }

shiftLeft

def shiftLeft (n : Nat) : FSM Unit :=
  match n with
  | 0 => FSM.id
  | n + 1 => composeUnaryAux (FSM.ls false) (shiftLeft n)

id

def id : FSM Unit := {
 α := Empty,
 initCarry := Empty.elim,
 outputCirc := Circuit.var true (inr ()),
 nextStateCirc := Empty.elim
}

ls

def ls (b : Bool) : FSM Unit :=
  { α := Unit,
    initCarry := fun _ => b,
    nextStateCirc := fun () => Circuit.var true (inr ()),
    outputCirc := Circuit.var true (inl ())
  }

composeUnaryAux

def composeUnaryAux
    (p : FSM Unit)
    (q : FSM arity) :
    FSM arity :=
  p.compose
    arity
    _
    (λ _ => id)
    (λ _ => q)

compose

def compose [FinEnum arity] [DecidableEq arity] [Hashable arity]
    (new_arity : Type)
    (q_arity : arity → Type)
    (vars : ∀ (a : arity), q_arity a → new_arity)

    (q : ∀ (a : arity), FSM (q_arity a)) :
    FSM new_arity :=
  { α := p.α ⊕ (Σ a, (q a).α),
    i := by admit /- proof elided -/

and

def and : FSM Bool :=
  { α := Empty,
    initCarry := Empty.elim,
    nextStateCirc := fun a => a.elim,
    outputCirc := Circuit.var true (inr true) &&& Circuit.var true (inr false),
  }

xor

def xor : FSM Bool :=
  { α := Empty,
    initCarry := Empty.elim,
    outputCirc := Circuit.var true (inr true) ^^^ Circuit.var true (inr false),
    nextStateCirc := Empty.elim
  }

neg

def neg : FSM Unit :=
  { α := Unit,
    i := by admit /- proof elided -/

composeBinary

def composeBinary
    (p : FSM Bool)
    {t₁ t₂ : Term}
    (q₁ : FSMTermSolution t₁)
    (q₂ : FSMTermSolution t₂) :
    FSM (Fin (max t₁.arity t₂.arity)) := composeBinaryAux p q₁.toFSM q₂.toFSM

composeBinaryAux

def composeBinaryAux
    (p : FSM Bool)
    (q₁ : FSM (Fin a₁))
    (q₂ : FSM (Fin a₂)) :
    FSM (Fin (max a₁ a₂)) :=
  p.compose (Fin (max a₁ a₂))
    (λ b => Fin (cond b a₁ a₂))
    (λ b i => Fin.castLE (by admit /- proof elided -/
    ) i)
    (λ b => match b with
      | true => q₁
      | false => q₂)

FSMTermSolution

structure FSMTermSolution (t : Term) extends FSM (Fin t.arity) where
  ( good : t.evalFin = toFSM.eval )

Term.evalFin

@[simp] def Term.evalFin (t : Term) (vars : Fin (arity t) → BitStream) : BitStream :=
  match t with
  | var n => vars (Fin.last n)
  | zero    => BitStream.zero
  | one     => BitStream.one
  | negOne  => BitStream.negOne
  | ofNat n => BitStream.ofNat n
  | and t₁ t₂ =>
      let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ &&& x₂
  | or t₁ t₂ =>
      let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ ||| x₂
  | xor t₁ t₂ =>
      let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ ^^^ x₂
  | not t     => ~~~(t.evalFin vars)
  | add t₁ t₂ =>
      let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ + x₂
  | sub t₁ t₂ =>
      let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ - x₂
  | neg t       => -(Term.evalFin t vars)

  | shiftL t n  => BitStream.shiftLeft (Term.evalFin t vars) n

Predicate.evalFin

@[simp] def Predicate.evalFin (p : Predicate) (vars : Fin (arity p) → BitStream) : BitStream :=
match p with
| .width .eq n => BitStream.falseIffEq n
| .width .neq n => BitStream.falseIffNeq n
| .width .lt n => BitStream.falseIffLt n
| .width .le n => BitStream.falseIffLe n
| .width .gt n => BitStream.falseIffGt n
| .width .ge n => BitStream.falseIffGe n
| .binary .eq t₁ t₂ =>
    let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
    ) i))
    let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
    ) i))
    Predicate.evalEq x₁ x₂
| .binary .neq t₁ t₂  =>
    let x₁ := t₁.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
    ) i))
    let x₂ := t₂.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
    ) i))
    Predicate.evalNeq x₁ x₂
| .land p q =>

  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  Predicate.evalLand x₁ x₂
| .lor p q =>

  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  Predicate.evalLor x₁ x₂
| .binary .slt p q =>
  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  Predicate.evalSlt x₁ x₂
| .binary .sle p q =>
  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  Predicate.evalLor (Predicate.evalSlt x₁ x₂) (Predicate.evalEq x₁ x₂)
| .binary .ult p q =>
  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  (Predicate.evalUlt x₁ x₂)
| .binary .ule p q =>
  let x₁ := p.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  let x₂ := q.evalFin (fun i => vars (Fin.castLE (by admit /- proof elided -/
  ) i))
  Predicate.evalLor (Predicate.evalUlt x₁ x₂) (Predicate.evalEq x₁ x₂)

Predicate.evalUlt

def Predicate.evalUlt (t₁ t₂ : BitStream) : BitStream := (~~~ (t₁.borrow t₂)).concat true

borrow

def borrow (x y : BitStream) : BitStream :=
  fun n => (subAux x y n).2

Predicate.evalLor

def Predicate.evalLor (t₁ t₂ : BitStream) : BitStream := (t₁ &&& t₂)

Predicate.evalSlt

def Predicate.evalSlt (t₁ t₂ : BitStream) : BitStream :=
    (((Predicate.evalUlt t₁ t₂)) ^^^ (Predicate.evalMsbEq t₁ t₂))

Predicate.evalMsbEq

def Predicate.evalMsbEq (t₁ t₂ : BitStream) : BitStream :=
  (t₁ ^^^ t₂).concat false

Predicate.evalLand

def Predicate.evalLand (t₁ t₂ : BitStream) : BitStream := (t₁ ||| t₂)

Predicate.evalNeq

def Predicate.evalNeq (t₁ t₂ : BitStream) : BitStream := (t₁.nxor t₂).concat true |>.scanAnd

nxor

def nxor (a b : BitStream) : BitStream := fun i => a i == b i

scanAnd

def scanAnd (s : BitStream) : BitStream := scanl true Bool.and s

scanl

abbrev scanl (init : Bool) (f : Bool → Bool → Bool) (s : BitStream) : BitStream :=
  fun n => match n with
    | 0 => f init (s 0)
    | n+1 => f (scanl init f s n) (s (n + 1))

Predicate.evalEq

def Predicate.evalEq (t₁ t₂ : BitStream) : BitStream := (t₁ ^^^ t₂).concat false |>.scanOr

scanOr

def scanOr (s : BitStream) : BitStream := scanl false Bool.or s

Predicate

inductive Predicate : Type where

| width (wp : WidthPredicate) (n : Nat) : Predicate
| binary (p : BinaryPredicate) (t₁ t₂ : Term)
| land  (p q : Predicate) : Predicate
| lor (p q : Predicate) : Predicate
deriving Repr, Inhabited, Lean.ToExpr

falseIffNeq

abbrev falseIffNeq (n : Nat) : BitStream := fun i => decide (i == n)

falseIffLt

abbrev falseIffLt (n : Nat) : BitStream := fun i => decide (i ≥ n)

falseIffLe

abbrev falseIffLe (n : Nat) : BitStream := fun i => decide (i > n)

falseIffGe

abbrev falseIffGe (n : Nat) : BitStream := fun i => decide (i < n)

falseIffEq

abbrev falseIffEq (n : Nat) : BitStream := fun i => decide (i != n)

falseIffGt

abbrev falseIffGt (n : Nat) : BitStream := fun i => decide (i ≤ n)

Term.width

def Term.width (t : Term) : WidthExpr :=
  match t with

  | .ofNat w _n => w
  | .var _v w => w
  | .add w _a _b => w
  | .zext _a wnew => wnew
  | .setWidth _a wnew => wnew
  | .sext _a wnew => wnew
  | .bor w _a _b => w
  | .band w _a _b => w
  | .bxor w _a _b => w
  | .bnot w _a => w
  | .boolVar _v => WidthExpr.const 1
  | .boolConst _b => WidthExpr.const 1
  | .shiftl w _a _k => w
  | .bvOfBool _b => WidthExpr.const 1
  | binWidthRel _k wa wb => WidthExpr.const 0
  | binRel _k w _a _b => w
  | or _p1 _p2 => WidthExpr.const 0
  | and _p1 _p2 => WidthExpr.const 0
  | pvar _v => WidthExpr.const 0
  | boolBinRel _k _a _b => WidthExpr.const 0

Term.arity

@[simp] def Term.arity : Term → Nat
| (var n) => n+1
| zero => 0
| one => 0
| negOne => 0
| ofNat _ => 0
| Term.and t₁ t₂ => max (arity t₁) (arity t₂)
| Term.or t₁ t₂ => max (arity t₁) (arity t₂)
| Term.xor t₁ t₂ => max (arity t₁) (arity t₂)
| Term.not t => arity t
| add t₁ t₂ => max (arity t₁) (arity t₂)
| sub t₁ t₂ => max (arity t₁) (arity t₂)
| neg t => arity t

| shiftL t .. => arity t

negOne

abbrev negOne : BitStream := fun _ => true

shiftLeft

def shiftLeft (x : BitStream) (k : Nat) : BitStream :=
  fun i => if i < k then false else x (i - k)

ofNat

def ofNat (x : Nat) : BitStream :=
  Nat.testBit x

one

abbrev one    : BitStream := (· == 0)

zero

abbrev zero   : BitStream := fun _ => false

ofNat

def ofNat (n : Nat)  : FSM (Fin 0) :=
  match hn : n with
  | 0 => FSM.zero

  | n' + 1 =>
    let bit := n.testBit 0
    let m := n / 2
    have h : m < n := by admit /- proof elided -/

zero

def zero : FSM (Fin 0) :=
  { α := Empty,
    initCarry := Empty.elim,
    nextStateCirc := Empty.elim,
    outputCirc := Circuit.fals
  }

composeUnary

def composeUnary
    (p : FSM Unit)
    {t : Term}
    (q : FSMTermSolution t) :
    FSM (Fin t.arity) := composeUnaryAux p q.toFSM

one

def one : FSM (Fin 0) :=
  { α := Unit,
    i := by admit /- proof elided -/

var

def var (n : ℕ) : FSM (Fin (n+1)) :=
  { α := Empty,
    i := by admit /- proof elided -/

add

def add : FSM Bool :=
  { α := Unit,
    initCarry := λ _ => false,
    nextStateCirc := fun () =>
      Circuit.var true (inr true) &&& Circuit.var true (inr false) |||
      Circuit.var true (inr true) &&& Circuit.var true (inl ()) |||
      Circuit.var true (inr false) &&& Circuit.var true (inl ()),
    outputCirc := Circuit.var true (inr true) ^^^
                  Circuit.var true (inr false) ^^^
                  Circuit.var true (inl ()),
  }

negOne

def negOne : FSM (Fin 0) :=
  { α := Empty,
    i := by admit /- proof elided -/

sub

def sub : FSM Bool :=
  { α := Unit,
    initCarry := fun _ => false,
    outputCirc := Circuit.var true (inr true) ^^^
                  Circuit.var true (inr false) ^^^
                  Circuit.var true (inl ()),
    nextStateCirc := fun _ =>
      (Circuit.var false (inr true) &&& Circuit.var true (inr false)) |||
      (Circuit.var false (inr true) ^^^ Circuit.var true (inr false)) &&&
      (Circuit.var true (inl ()))
  }

not

def not : FSM Unit :=
  { α := Empty,
    initCarry := Empty.elim,
    nextStateCirc := Empty.elim,
    outputCirc := Circuit.var false (inr ())
  }

add

def add (x y : BitStream) : BitStream :=
  fun n => (addAux x y n).1

addAux

def addAux (x y : BitStream) (i : Nat) :  Bool × Bool :=
  let carryIn : Bool := match i with
    | 0 => false
    | i + 1 => (addAux x y i).2
  Prod.swap (BitVec.adcb (x i) (y i) carryIn)

neg

def neg (x : BitStream) : BitStream :=
  fun n => (negAux x n).1

negAux

def negAux (x : BitStream) : Nat → Bool × Bool
  | 0 => (x 0, !(x 0))
  | n+1 =>
    let borrow := (negAux x n).2
    let a := x (n + 1)
    (xor (!a) borrow, !a && borrow)

CNFA.inter

def CNFA.inter (m1 m2 : CNFA n) : CNFA n := product (fun b1 b2 => b1 && b2) m1 m2

product

def product (final? : Bool → Bool → Bool) (m₁ m₂ : CNFA n) : CNFA n :=
  worklistRun (m₁.m.states × m₂.m.states) final (product.inits m₁ m₂)
    (by admit /- proof elided -/
    ) f
where final (ss : m₁.m.states × m₂.m.states) := final? (ss.1 ∈ m₁.m.finals) (ss.2 ∈ m₂.m.finals)
      f (ss : m₁.m.states × m₂.m.states) :=
        let (s1, s2) := ss
        (FinEnum.toList (α := BitVec n)).foldl (init := Array.empty) fun as a =>
          product.prodArray' (λ s₁ s₂ ↦ (a, (s₁, s₂)))
            (fun s' => m₁.wf.trans_tgt_lt (s := s1) (a := a)) (fun s' => m₂.wf.trans_tgt_lt (s := s2) (a := a)) as

product.prodArray'

@[inline]
def product.prodArray' (a : Array γ) :=
  m₁.attachWith _ hm₁ |>.fold (init := a) fun is s1 =>
    m₂.attachWith _ hm₂ |>.fold (init := is) fun is s2 =>
      is.push (f s1 s2)

def product.inits_nodup : inits m₁ m₂ |>.toList.Nodup :=

product.inits

def product.inits (m₁ m₂ : CNFA n) :=
  product.prodArray Prod.mk @m₁.wf.initials_lt @m₂.wf.initials_lt

product.prodArray

@[inline]
def product.prodArray := prodArray' f hm₁ hm₂ (Array.emptyWithCapacity <| m₁.size * m₂.size)

def CNFA.inter_bv_language (m₁ m₂ : CNFA n) :
    m₁.bv_recognizes L₁ →
    m₂.bv_recognizes L₂ →
    (m₁.inter m₂).bv_recognizes (L₁ ∩ L₂) :=

HashSet.inter

def HashSet.inter [BEq A] [Hashable A] (m1 m2 : Std.HashSet A) : Std.HashSet A :=
  m1.fold (init := ∅) fun mi x => if m2.contains x then mi.insert x else mi

NFA'

structure NFA' (n : Nat) where
  σ : Type
  M : NFA (BitVec n) σ

BitVecs

structure BitVecs (n : Nat) where
  w : Nat
  bvs : List.Vector (BitVec w) n

eval

def eval (x : arity → BitStream) : BitStream :=
  fun n => (p.nextBit (p.carry x n) (fun i => x i n)).2

nextBit

def nextBit : p.State → (arity → Bool) → p.State × Bool :=
  fun carry inputBits =>
    let input := Sum.elim carry inputBits
    let newState : p.State  := fun (a : p.α) => (p.nextStateCirc a).eval input
    let outBit : Bool       := (p.outputCirc).eval input
    (newState, outBit)

State

abbrev State : Type := p.α → Bool

carry

def carry (x : arity → BitStream) : ℕ → p.State
  | 0 => p.initCarry
  | n+1 => (p.nextBit (carry x n) (fun i => x i n)).1

carryBV

def carryBV (x : ar → BitVec w) : p.State :=
  p.carry (fun ar => .ofBitVecSext (x ar)) w

evalBV

def evalBV {w} (x : ar → BitVec w) : BitVec w :=
  BitVec.ofFn fun k => p.eval (fun ar => .ofBitVecSext (x ar)) k

ofBitVecSext

abbrev ofBitVecSext {w} (x : BitVec w) : BitStream :=
  fun i => if i < w then x.getLsbD i else x.msb

Term.language

def Term.language (t : Term) : Set (BitVecs (t.arity + 1)) :=
  { bvs : BitVecs (t.arity + 1) | t.evalFinBV (fun n => bvs.bvs.get n) = bvs.bvs.get t.arity }

Formula.arity

@[simp]
def Formula.arity : Formula → Nat
| width _ _ => 0
| atom _ t1 t2 => max t1.arity t2.arity
| msbSet t => t.arity
| unop _ φ => φ.arity
| binop _ φ1 φ2 => max φ1.arity φ2.arity

Term.evalFinBV

@[simp] def Term.evalFinBV (t : Term) (vars : Fin (arity t) → BitVec w) : BitVec w :=
  match t with
  | .var n => vars (Fin.last n)
  | .zero    => BitVec.zero w
  | .one     => 1
  | .negOne  => -1
  | .ofNat n => BitVec.ofNat _ n
  | .and t₁ t₂ =>
      let x₁ := t₁.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ &&& x₂
  | .or t₁ t₂ =>
      let x₁ := t₁.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ ||| x₂
  | .xor t₁ t₂ =>
      let x₁ := t₁.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ ^^^ x₂
  | .not t     => ~~~(t.evalFinBV vars)

  | .add t₁ t₂ =>
      let x₁ := t₁.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ + x₂
  | .sub t₁ t₂ =>
      let x₁ := t₁.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      let x₂ := t₂.evalFinBV (fun i => vars (Fin.castLE (by admit /- proof elided -/
      ) i))
      x₁ - x₂
  | .neg t       => -(t.evalFinBV vars)
  | .shiftL a n => (a.evalFinBV vars) <<< n

enc

def enc (bvs : BitVecs n) : BitVecs' n :=
  (List.finRange bvs.w).map (fun i =>
    BitVec.ofFn (fun (k : Fin n) => (bvs.bvs.get k)[i]))

BitVecs'

abbrev BitVecs' (n : Nat) := List (BitVec n)

dec

@[simps]
def dec (bvs' : BitVecs' n) : BitVecs n where
  w := bvs'.length
  bvs := List.Vector.ofFn fun k => BitVec.ofFn fun i => bvs'[i].getLsbD k

accepts

def accepts (M : NFA' n) : Set (BitVecs n) := dec '' M.accepts'

accepts'

def accepts' (M : NFA' n) : Set (BitVecs' n) := M.M.accepts

def worklistRun_spec : (worklistRun S final inits hinits f |>.Sim $ nfa' inits final f) :=
  worklistRun'_spec inits final f

nfa'

def nfa' : NFA' n :=
  { σ := _, M := nfa inits final f }

nfa

def nfa : NFA A S where
  start := { sa | sa ∈ inits }
  accept := { sa | final sa }
  step sa a := { sa' | (a, sa') ∈ f sa }

def worklistRun'_spec :
    (worklistRun' A S final inits hinits f |>.Sim $ nfa inits final f) :=

StInv

structure StInv (m : RawCNFA A) (map : Std.HashMap S State) where
  wf : m.WF
  map_states : ∀ (sa : S) s, map[sa]? = some s → s ∈ m.states
  map_surj : ∀ s : m.states, ∃ (sa : S), map[sa]? = some s.val
  map_inj : ∀ {s} {sa sa' : S}, map[sa]? = some s → map[sa']? = some s → sa = sa'

worklist.St.D

def worklist.St.D (st : worklist.St A S) : Set S := st.visited

worklist.St.visited

def worklist.St.visited (st : worklist.St A S) : Set S := { s : S | s ∈ st.map ∧ s ∉ st.worklist }

def worklistGo_spec {st : worklist.St A S} (inv : StInv A S st.m st.map) :
    st.sim inits final f ∅ →
    (worklistRun'.go A S final f st |>.Sim $ nfa inits final f) :=

worklist.St.rel

def worklist.St.rel (st : worklist.St A S) : SetRel State S := {(s, sa) | st.map[sa]? = some s }

def processOneElem_mot (s : State) (sa : S) (n : ℕ) (st : worklist.St A S) : Prop :=
  st.map[sa]? = some s ∧
  sa ∈ st.visited ∧
  StInv A S st.m st.map ∧
  st.sim inits final f  {(sa1, a, sa') | sa1 = sa ∧ ∃ k ≥ n, (f sa)[k]? = some (a, sa') }

worklist.St.sim

abbrev worklist.St.sim {st : worklist.St A S} (T : Set (S × A × S)) :=
  st.m.Simul (nfa inits final f) st.rel st.D T

RawCNFA.Sim

def RawCNFA.Sim (m : RawCNFA A) (A : NFA A S) := ∃ R, RawCNFA.Simul m A R ⊤ ∅

RawCNFA.Simul

structure RawCNFA.Simul (m : RawCNFA A) (M : NFA A Q) (R : SetRel State Q) (D : Set Q) (T : Set (Q × A × Q)) where
  accept {s q} : s ~[R] q → (s ∈ m.finals ↔ q ∈ M.accept)
  initial₁ {s} : s ∈ m.initials → ∃ q ∈ M.start, s ~[R] q
  initial₂ {q} : q ∈ M.start → ∃ s ∈ m.initials, s ~[R] q
  trans_match₁ {s s' a q} : s ~[R] q → s' ∈ m.tr s a → ∃ q', q' ∈ M.step q a ∧ s' ~[R] q'
  trans_match₂ {s a q q'} : s ~[R] q → q' ∈ M.step q a → q ∈ D → (q, a, q') ∉ T → ∃ s', s' ∈ m.tr s a ∧ s' ~[R] q'

RawCNFA.SimulFun

structure RawCNFA.SimulFun (m : RawCNFA A) (M : NFA A Q) (f : m.states ≃ Q)  where
  accept {q} : ((f.invFun q).val ∈ m.finals ↔ q ∈ M.accept)
  initial {q} : q ∈ M.start ↔ (f.invFun q).val ∈ m.initials
  trans_match {a q q'} : q' ∈ M.step q a ↔ (f.invFun q').val ∈ m.tr (f.invFun q) a

RawCNFA.tr

@[inline]
def RawCNFA.tr (m : RawCNFA A) s a := m.trans.getD (s, a) ∅

R

abbrev R := (ZMod q)[X] ⧸ (Ideal.span {f q n})

CNFA.Sim

def CNFA.Sim (m : CNFA n) (M : NFA' n) :=
  m.m.Sim M.M

def CNFA.bv_recognizes (m : CNFA n) (L : Set (BitVecs n)) :=
  ∃ L', m.recognizes L' ∧ L = dec '' L'

RawCNFA.recognizes

def RawCNFA.recognizes (m : RawCNFA A) (L : Language A) :=
  ∃ (σ : Type) (M : NFA A σ), m.Sim M ∧ M.accepts = L

CNFA.recognizes

def CNFA.recognizes (m : CNFA n) (L : Language (BitVec n)) :=
  ∃ (M : NFA' n), m.Sim M ∧ M.M.accepts = L

BitVecs.cast

def BitVecs.cast (bvs : BitVecs n) (h : n = n') : BitVecs n' :=
  { w := bvs.w, bvs := h ▸ bvs.bvs }

Valuation.cons

def Valuation.cons {Γ : Ctxt Ty} {t : Ty} (x : toType t) (V : Γ.Valuation) :
    (Γ.cons t).Valuation :=

BitVec.transport

def BitVec.transport (f : Fin n2 → Fin n1) (bv : BitVec n1) : BitVec n2 :=
  BitVec.ofFn fun i => bv.getLsbD (f i)

List.Vector.transport

def List.Vector.transport (v : Vector α m) (f : Fin n → Fin m) : Vector α n :=
  Vector.ofFn fun i => v.get (f i)

BitVecs'.transport

def BitVecs'.transport (f : Fin n → Fin m) (bvs' : BitVecs' m): BitVecs' n :=
  bvs'.map fun bv => bv.transport f

BitVecs.transport

def BitVecs.transport (f : Fin n → Fin m) (bvs : BitVecs m) : BitVecs n :=
  { w := bvs.w, bvs := bvs.bvs.transport f }

CNFA.minimize

def CNFA.minimize (m : CNFA n) : CNFA n :=
  let mᵣ := m.reverse.determinize
  mᵣ.reverse.determinize

CNFA.determinize

def CNFA.determinize (m : CNFA n) : CNFA n :=
  worklistRun (BitVec m.m.stateMax)
    (fun ss => ss.any fun n b => b == true && n ∈ m.m.finals)
    (determinize.inits m)
    (by admit /- proof elided -/
    )
    f
where
  f := fun (ss : BitVec m.m.stateMax) =>
        (FinEnum.toList (BitVec n)).foldl (init := Array.empty) fun ts a =>
          let ss' := m.m.transSetBV ss a
          ts.push (a, ss')

CNFA.determinize.inits

def CNFA.determinize.inits (m : CNFA n) : Array (BitVec m.m.stateMax) :=
  #[BitVec.ofFn (fun n => n ∈ m.m.initials)]

CNFA.reverse

def CNFA.reverse (m : CNFA n) : CNFA n :=
  ⟨m.m.reverse, RawCNFA.reverse_spec m.wf |>.1⟩

RawCNFA.reverse

def RawCNFA.reverse (m : RawCNFA A) : RawCNFA A :=
  let m' := { stateMax := m.stateMax, trans := Std.HashMap.emptyWithCapacity m.trans.size, initials := m.finals, finals := m.initials}
  m.trans.fold (init := m') processState
where
  processState := fun m' (s, a) ss' =>
    ss'.fold (init := m') fun m' s' => m'.addTrans a s' s

CNFA.toNFA'

def CNFA.toNFA' (m : CNFA n) : NFA' n := ⟨_, m.toNFA⟩

CNFA.toNFA

def CNFA.toNFA (m : CNFA n) : NFA (BitVec n) m.m.states where
  start := { s | s.val ∈ m.m.initials }
  accept := { s | s.val ∈ m.m.finals }
  step s₁ a := { s₂ | s₂.val ∈ m.m.tr s₁.val a }

RawCNFA.states

def RawCNFA.states (m : RawCNFA A) : Finset State := Finset.range m.stateMax

reverse

def reverse (M : NFA' n) : NFA' n where
  σ := _
  M := M.M.reverse

def CNFA.determinize_spec (m : CNFA n)
  {M : NFA' n} (hsim : m.Sim M) :
    m.determinize.Sim M.determinize :=

private def bv_to_set (bv : BitVec w) : Set State :=
  { s | bv.getLsbD s }

structure _root_.SetRel.set_eq (R : SetRel α β) (A : Set α) (B : Set β) where
  fwd : a ∈ A → ∃ b ∈ B, a ~[R] b
  bwd : b ∈ B → ∃ a ∈ A, a ~[R] b

RawCNFA.lift

@[inline]
def RawCNFA.lift (m₁: RawCNFA (BitVec n1)) (f : Fin n1 → Fin n2) : RawCNFA (BitVec n2) :=
  let trans := (List.range m₁.stateMax).foldl (init := ∅) fun m2 s => processState m2 s
  { m₁ with trans }
where

CNFA.lift

@[inline]
def CNFA.lift (m: CNFA n1) (f : Fin n1 → Fin n2) : CNFA n2 :=
  ⟨m.m.lift f, m.m.lift_wf m.wf⟩

RawCNFA.proj

@[inline]
def RawCNFA.proj (m1: RawCNFA (BitVec n1)) (f : Fin n2 → Fin n1) : RawCNFA (BitVec n2) :=
  let trans := m1.trans.keysArray.foldl (init := Std.HashMap.emptyWithCapacity) process
  { m1 with trans }
where

def CNFA.proj_spec (m : CNFA n2) (f : Fin n1 → Fin n2) {M : NFA' n2} :
    m.Sim M → (m.proj f |>.Sim (M.proj f)) :=

CNFA.proj

@[inline]
def CNFA.proj (m: CNFA n2) (f : Fin n1 → Fin n2) : CNFA n1 :=
  ⟨m.m.proj f, m.m.proj_wf m.wf⟩

infixr:67 "::ᵥ" => Valuation.cons

ext

@[ext]
theorem ext {x y : BitStream} (h : ∀ i, x i = y i) : x = y

lemma bisim_comp (m : RawCNFA A) :
    m.Sim M₁ → M₁.Bisim M₂ → m.Sim M₂

lemma bisimul_comp {m : RawCNFA A} :
    m.Simul M₁ R₁ ⊤ ∅ → M₁.Bisimul R₂ M₂ →
    m.Simul M₂ (R₁.comp R₂) ⊤ ∅

lemma CNFA.bv_recognizes_equiv {m : CNFA n} :
    m.bv_recognizes L ↔ ∃ (M : NFA' n), m.Sim M ∧ M.accepts = L

@[simp]
lemma List.Vector.append_get_ge {x : List.Vector α n} {y : List.Vector α m} {i : Fin (n+m)} (hlt: n ≤ i) :
    (x ++ y).get i = y.get ((i.cast (Nat.add_comm n m) |>.subNat n hlt))

@[simp]
lemma List.Vector.append_get_lt {x : List.Vector α n} {y : List.Vector α m} {i : Fin (n+m)} (hlt: i < n) :
    (x ++ y).get i = x.get (i.castLT hlt)

@[simp]
lemma BitVecs.transport_getElem {bvs : BitVecs m} (f : Fin n → Fin m) (i : Fin n) :
    (bvs.transport f).bvs.get i = bvs.bvs.get (f i)

lemma CNFA.minimize_bv_language {m : CNFA n} :
    m.bv_recognizes L → m.minimize.bv_recognizes L

lemma CNFA.minimize_language {m : CNFA n} :
    m.recognizes L → m.minimize.recognizes L

lemma CNFA.reverse_language {m : CNFA n} (hl : m.recognizes L) : m.reverse.recognizes L.reverse

lemma CNFA.reverse_spec {m : CNFA n} : m.reverse.Sim m.toNFA'.reverse

lemma RawCNFA.reverse_spec {m : RawCNFA A} (hwf : m.WF) :
    let m'

lemma RawCNFA.reverse_spec_procesState {m : RawCNFA A} (hwf : m.WF) s₀ a₀ ss' (hs₀ : s₀ ∈ m.states) :
    let motive m' ss'

lemma CNFA.determinize_language {m : CNFA n} :
    m.recognizes L → m.determinize.recognizes L

@[simp]
lemma CNFA.lift_bv_language {m : CNFA n1} {f : Fin n1 → Fin n2} :
    m.bv_recognizes L → (m.lift f |>.bv_recognizes (BitVecs.transport f ⁻¹' L))

lemma CNFA.lift_spec (m : CNFA n1) (f : Fin n1 → Fin n2) {M : NFA' n1} :
    m.Sim M → (m.lift f |>.Sim (M.lift f))

lemma CNFA.proj_bv_language {m : CNFA n2} {f : Fin n1 → Fin n2} :
    m.bv_recognizes L → (m.proj f |>.bv_recognizes (BitVecs.transport f '' L))

NFA.sa

def NFA.sa (_ : NFA α σ) := σ → Language α

BVNRel

abbrev BVNRel n := ∀ ⦃w⦄, List.Vector (BitVec w) n → Prop

NFA'.sa

def NFA'.sa (M : NFA' n) := M.σ → BVNRel n

langRel

def langRel (R : BVNRel n) : Set (BitVecs n) :=
  { bvs | R bvs.bvs }

Alphabet

abbrev Alphabet (arity: Type) [FinEnum arity] := BitVec (FinEnum.card arity + 1)

finFunToBitVec

def finFunToBitVec [fe : FinEnum carry] (c : carry → Bool) : BitVec (FinEnum.card carry) :=
  BitVec.ofFn fun i => c (fe.equiv.invFun i)

bitVecToFinFun

def bitVecToFinFun [FinEnum ar] (bv : BitVec $ FinEnum.card ar) : ar → Bool :=
  fun c => bv[FinEnum.equiv.toFun c]

inFSMRel

def NFA'.ofFSM_sa (p : FSM arity) : (NFA'.ofFSM' p).sa := fun q _ bvn =>
    inFSMRel p bvn ∧ q = p.carryBV (fun ar => bvn.get (FinEnum.equiv.toFun ar))

def NFA'.ofFSM_correct (p : FSM arity) :
    (NFA'.ofFSM' p).correct (ofFSM_sa p) (fun _ bvn => inFSMRel p bvn) :=

NFA.msbState

inductive NFA.msbState : Type where
| i | f
deriving DecidableEq, Fintype

liftUnop

def liftUnop n : Fin (n + 1) → Fin (n + 2) :=
  fun k =>
    if k = n then Fin.last (n+1) else k.castLE (by admit /- proof elided -/
    )

TermBinop

inductive TermBinop where
| and | or | xor | add | sub

TermBinop.openTerm

def TermBinop.openTerm (op : TermBinop) : Term := op.subst (.var 0) (.var 1)

TermUnop

inductive TermUnop where
| neg | not | shiftL (k : Nat)

TermUnop.openTerm

def TermUnop.openTerm (op : TermUnop) : Term :=
  match op with
  | .neg => .neg (.var 0)
  | .not => .not (.var 0)
  | .shiftL k => .shiftL (.var 0) k

@[simp]
def TermUnop.openTerm_arity' (op : TermUnop) : op.openTerm.arity + 1 = 2 :=

TermUnop.subst

def TermUnop.subst (op : TermUnop) (t : Term) : Term :=
  match op with
  | .neg => .neg t
  | .not => .not t
  | .shiftL k => .shiftL t k

swapLastTwo

def swapLastTwo (x : Fin (n + 2)) : Fin (n + 2) :=
  if x = Fin.last (n + 1) then n else if x = n then Fin.last (n + 1) else x

lemma NFA.correct_spec {M : NFA α σ} {ζ : M.sa} {L : Language α} :
    M.correct ζ L → M.accepts = L

@[simp]
lemma in_enc : x ∈ enc '' S ↔ dec x ∈ S

@[simp]
lemma dec_snoc_in_langRel {n} {R : BVNRel n} {w : BitVecs' n} {a : BitVec n} :
    dec (w ++ [a]) ∈ langRel R ↔
      R (List.Vector.ofFn fun k => .cons (a.getLsbD k) ((dec w).bvs.get k))

lemma NFA'.correct_spec {M : NFA' n} {ζ : M.sa} {L : BVNRel n} :
    M.correct ζ L → M.accepts = langRel L

@[simp]
lemma NFA'.ofFSM_spec (t : Term) :
    (ofFSM (FSM.ofTerm t)).accepts = t.language

lemma CNFA.ofFSM_spec (p : FSM arity) :
    (CNFA.ofFSM p).Sim (NFA'.ofFSM p)

lemma CNFA.ofFSM_bv_language :
    (CNFA.ofFSM (FSM.ofTerm t)).bv_recognizes t.language

lemma TermBinop.subst_arity' {op : TermBinop} : (op.subst t₁ t₂).arity + 1= t₁.arity ⊔ t₂.arity + 1

@[simp]
lemma BitVecs.cast_eq  (x : BitVecs n) (h : n = n') : h ▸ x = x.cast h

lemma Fin.natAdd_zero' [h : NeZero m] : Fin.natAdd (m := m) n 0 = n

@[simp]
lemma TermUnop.subst_arity' {op : TermUnop} : (op.subst t).arity + 1 = t.arity + 1

lemma TermUnop.alt_lang {t : Term} (op : TermUnop) :
  (op.subst_arity' ▸ (op.subst t).language) =
    let lop : Set (BitVecs 2) := op.openTerm_arity' ▸ op.openTerm.language
    let lop' : Set (BitVecs (t.arity + 2)) := lop.lift (λ i ↦ i.natAdd t.arity)
    let lt : Set (BitVecs (t.arity + 2)) := t.language.lift (λ i ↦ i.castLE (by omega))
    let l := lt ∩ lop'
    l.proj (liftUnop t.arity)

import Batteries.Data.Fin.Basic

import Batteries.Data.Fin.Lemmas

import Blase.SingleWidth.Defs

import Blase.AutoStructs.Constructions

import Blase.AutoStructs.Defs

import Blase.AutoStructs.FiniteStateMachine

import Mathlib.Tactic.Ring

import Mathlib.Data.Nat.Size -- TODO: remove and get rid of shiftLeft_eq_mul_pow use

import Mathlib.Data.BitVec

import Mathlib.Tactic.FinCases

open Fin.NatCast

open Mathlib

def NFA.sa (_ : NFA α σ) := σ → Language α

structure NFA.correct (M : NFA α σ) (ζ : M.sa) (L : Language α) where
  cond1 : ∀ w, (w ∈ L ↔ ∃ q ∈ M.accept, w ∈ ζ q)
  cond2 : ∀ w q, q ∈ M.eval w ↔ w ∈ ζ q

abbrev BVNRel n := ∀ ⦃w⦄, List.Vector (BitVec w) n → Prop

def NFA'.sa (M : NFA' n) := M.σ → BVNRel n

def langRel (R : BVNRel n) : Set (BitVecs n) :=
  { bvs | R bvs.bvs }

structure NFA'.correct (M : NFA' n) (ζ : M.sa) (L : BVNRel n) where
  cond1 : ∀ ⦃w⦄ (bvn : List.Vector (BitVec w) n), (L bvn ↔ ∃ q ∈ M.M.accept, ζ q bvn)
  cond2 q : q ∈ M.M.start ↔ ζ q (List.Vector.replicate n .nil)
  cond3 q a {w} (bvn : List.Vector (BitVec w) n) : q ∈ M.M.stepSet { q | ζ q bvn } a ↔
              ζ q (List.Vector.ofFn fun k => BitVec.cons (a.getLsbD k) (bvn.get k))

structure NFA'.correct2 (M : NFA' 2) (ζ : M.sa2) (L : BVRel) where
  cond1 : ∀ (bv1 bv2 : BitVec w), (L bv1 bv2 ↔ ∃ q ∈ M.M.accept, ζ q bv1 bv2)
  cond2 q : q ∈ M.M.start ↔ ζ q .nil .nil
  cond3 q a w (bv1 bv2 : BitVec w) : q ∈ M.M.stepSet { q | ζ q bv1 bv2 } a ↔
              ζ q (BitVec.cons (a.getLsbD 0) bv1) (BitVec.cons (a.getLsbD 1) bv2)

section fsm

abbrev Alphabet (arity: Type) [FinEnum arity] := BitVec (FinEnum.card arity + 1)

variable {arity : Type} [FinEnum arity]

def finFunToBitVec [fe : FinEnum carry] (c : carry → Bool) : BitVec (FinEnum.card carry) :=
  BitVec.ofFn fun i => c (fe.equiv.invFun i)

def bitVecToFinFun [FinEnum ar] (bv : BitVec $ FinEnum.card ar) : ar → Bool :=
  fun c => bv[FinEnum.equiv.toFun c]

def NFA.ofFSM (p : FSM arity) : NFA (Alphabet arity) (p.α → Bool) where
  start := { q | q = p.initCarry }
  accept := ⊤
  step s a := {s' |
    let (s'', b) := p.nextBit s (bitVecToFinFun (a.truncate $ FinEnum.card arity))
    s' = s'' ∧ a.msb = b }

@[simp]
abbrev inFSMRel (p : FSM arity) {w} (bvn : List.Vector (BitVec w) _) :=
  bvn.get (Fin.last (FinEnum.card arity)) = p.evalBV (fun ar => bvn.get (FinEnum.equiv.toFun ar))

def NFA'.ofFSM_sa (p : FSM arity) : (NFA'.ofFSM' p).sa := fun q _ bvn =>
    inFSMRel p bvn ∧ q = p.carryBV (fun ar => bvn.get (FinEnum.equiv.toFun ar))

def NFA'.ofFSM_correct (p : FSM arity) :
    (NFA'.ofFSM' p).correct (ofFSM_sa p) (fun _ bvn => inFSMRel p bvn) :=

open BitStream in

def CNFA.ofFSM (p : FSM arity) : CNFA (FinEnum.card arity + 1) :=
  worklistRun (BitVec (FinEnum.card p.α))
    (fun _ => true)
    #[finFunToBitVec p.initCarry]
    (by admit /- proof elided -/
    )
    f
  where

end fsm

section nfas_relations

inductive NFA.msbState : Type where
| i | f
deriving DecidableEq, Fintype

end nfas_relations

def liftUnop n : Fin (n + 1) → Fin (n + 2) :=
  fun k =>
    if k = n then Fin.last (n+1) else k.castLE (by admit /- proof elided -/
    )

inductive TermBinop where
| and | or | xor | add | sub

def TermBinop.subst (op : TermBinop) (t₁ t₂ : Term) : Term :=
  match op with
  | .and => .and t₁ t₂
  | .or => .or t₁ t₂
  | .xor => .xor t₁ t₂
  | .add => .add t₁ t₂
  | .sub => .sub t₁ t₂

def TermBinop.openTerm (op : TermBinop) : Term := op.subst (.var 0) (.var 1)

def TermBinop.termGadget (t : TermBinop) : CNFA 3 :=
  match t with
  | .and => FSM.ofTerm (.and (.var 0) (.var 1)) |> CNFA.ofFSM
  | .or => FSM.ofTerm (.or (.var 0) (.var 1)) |> CNFA.ofFSM
  | .xor => FSM.ofTerm (.xor (.var 0) (.var 1)) |> CNFA.ofFSM
  | .add => FSM.ofTerm (.add (.var 0) (.var 1)) |> CNFA.ofFSM
  | .sub => FSM.ofTerm (.sub (.var 0) (.var 1)) |> CNFA.ofFSM

inductive TermUnop where
| neg | not | shiftL (k : Nat)

def TermUnop.openTerm (op : TermUnop) : Term :=
  match op with
  | .neg => .neg (.var 0)
  | .not => .not (.var 0)
  | .shiftL k => .shiftL (.var 0) k

@[simp]
def TermUnop.openTerm_arity' (op : TermUnop) : op.openTerm.arity + 1 = 2 :=

def TermUnop.subst (op : TermUnop) (t : Term) : Term :=
  match op with
  | .neg => .neg t
  | .not => .not t
  | .shiftL k => .shiftL t k

def TermUnop.termGadget (t : TermUnop) : CNFA 2 :=
  match t with
  | .neg => FSM.ofTerm (.neg (.var 0)) |> CNFA.ofFSM
  | .not => FSM.ofTerm (.not (.var 0)) |> CNFA.ofFSM
  | .shiftL k => FSM.ofTerm (.shiftL (.var 0) k) |> CNFA.ofFSM

def autOfTermUnop (op : TermUnop) (m : CNFA (n + 1)) : CNFA (n + 1) :=
  let mop : CNFA 2 := op.termGadget
  let mop : CNFA (n + 2) := mop.lift (λ i ↦ i.natAdd n)
  let m : CNFA (n + 2) := m.lift (λ i ↦ i.castLE (by admit /- proof elided -/
  ))
  let m := CNFA.inter m mop
  let mfinal := m.proj (liftUnop n)
  mfinal.minimize

def swapLastTwo (x : Fin (n + 2)) : Fin (n + 2) :=
  if x = Fin.last (n + 1) then n else if x = n then Fin.last (n + 1) else x

lemma autOfTermUnop_bv_language op {t : Term} (m : CNFA (t.arity + 1)) :
    m.bv_recognizes t.language →
    (autOfTermUnop op m |>.bv_recognizes (op.subst_arity' ▸ (op.subst t).language)) :=

:= by
  rintro hrec
  rw [TermUnop.alt_lang]
  simp only [autOfTermUnop]
  simp
  apply CNFA.minimize_bv_language
  apply CNFA.proj_bv_language
  apply CNFA.inter_bv_language
  · apply CNFA.lift_bv_language; assumption
  · apply CNFA.lift_bv_language
    simp [TermUnop.openTerm, TermUnop.termGadget]
    rcases op <;> apply CNFA.ofFSM_bv_language


import Mathlib.Data.Rel
import Mathlib.Data.FinEnum
import Mathlib.Data.Vector.Basic
import Blase.AutoStructs.ForLean
import Mathlib.Computability.NFA

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Std.HashMap.toPFun

theorem Std.HashMap.toPFun_toList[BEq α] [LawfulBEq α] [Hashable α] (m : HashMap α β) :
    m.toPFun = λ k ↦ m.toList.find? (λ x ↦ x.1 == k) |>.map Prod.snd

import Mathlib.Computability.NFA

import Mathlib.Data.FinEnum

import Mathlib.Data.Rel

import Mathlib.Data.Vector.Basic

import Blase.AutoStructs.ForLean

open Set

open Mathlib

open SetRel

namespace NFA

end NFA

def Std.HashMap.toPFun [BEq α] [Hashable α] (m : HashMap α β) (x : α) : Option β := m[x]?

theorem Std.HashMap.fold_induction [BEq α] [LawfulBEq α] [DecidableEq α] [Hashable α]
  {f : γ → α → β → γ} {m : HashMap α β} {motive : γ → (α → Option β) → Prop} :
    motive b (λ _ ↦ none) →
    (∀ b x y m, m x = none → motive b m → motive (f b x y) (Function.update m x y)) →
    motive (m.fold f b) m.toPFun :=

:= by
  rintro hemp hind
  rw [Std.HashMap.fold_eq_foldl_toList, toPFun_toList]
  have := m.distinct_keys_toList
  revert this
  induction m.toList using List.reverseRecOn
  case nil =>
    simp_all
  case append_singleton xs xy ih =>
    rcases xy with ⟨x, y⟩
    rintro hd
    simp_all
    simp [List.pairwise_append] at hd
    rcases hd with ⟨hd, hnew⟩
    let f := fun k => Option.map Prod.snd (List.find? (fun x => x.1 == k) xs)
    specialize ih (by simp [hd])
    have hnewf : f x = none := by
      simp [f]; grind
    specialize hind _ x y _ hnewf ih
    convert hind using 1
    ext a b; simp
    rw [Function.update_apply]
    split_ifs with hcond
    · subst hcond; constructor
      · rintro ⟨a', hf | hf⟩
        · obtain h := List.find?_some hf
          simp at h; subst h
          grind [List.mem_of_find?_eq_some]
        · grind
      · simp only [Option.some.injEq, true_and]
        rintro rfl
        aesop
    · simp [f]; grind