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

Mapping

abbrev Mapping (Γ Δ : Ctxt Ty) : Type :=
  @AList (Σ t, Var Γ t) (fun x => Var Δ x.1)

Ctxt

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

  deriving Repr, Lean.ToExpr, DecidableEq

Var

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

Lets

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

Expr.decidableEq

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

Var

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

Valuation.nil

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

EffectKind

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

Valuation.cons

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

HVector.decidableEqReg

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

appendCases

@[elab_as_elim]
def appendCases
    {motive : (Γ ++ Δ).Var t → Sort u}
    (left : (v : Var Γ t) → motive (appendInl v))
    (right : (v : Var Δ t) → motive (appendInr v)) :
    (v : (Γ ++ Δ).Var t) → motive v
  | ⟨idx, h⟩ =>
    if hv : idx < Γ.length then
      left ⟨idx, by admit /- proof elided -/
      ⟩
    else
      let v' : Var _ _ := ⟨idx - Γ.length, by admit /- proof elided -/
      ⟩
      have eq : v'.appendInr = ⟨idx, h⟩ := by admit /- proof elided -/

last

@[match_pattern]
def last (Γ : Ctxt Ty) (t : Ty) : Ctxt.Var (Ctxt.cons t Γ) t :=
  ⟨0, by admit /- proof elided -/
  ⟩

appendInl

def appendInl (v : Γ.Var t) : (Γ ++ Δ).Var t :=
  ⟨v.val, by admit /- proof elided -/
  ⟩

TyDenote

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

map

def map (f : ∀ (a : α), A a → B a) :
    ∀ {l : List α}, HVector A l → HVector B l
  | [],   .nil        => .nil
  | t::_, .cons a as  => .cons (f t a) (map f as)

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

cons

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

f

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

sig

def sig          := Signature.sig ∘ s.signature

Signature

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

DialectSignature

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

effectKind

def effectKind   := Signature.effectKind ∘ s.signature

returnTypes

def returnTypes  := Signature.returnTypes ∘ s.signature

Expr.ty

def Expr.ty : Expr d Γ eff [t] → d.Ty := fun _ => t

Expr.op

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

DialectDenote

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

Lets.denote

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

regSig

def regSig       := Signature.regSig ∘ s.signature

RegionSignature

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

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

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

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

HVector.denote

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)

FlatCom.denote

@[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 ·)

FlatCom

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

RegionSignature.map

def RegionSignature.map (f : Ty → Ty') : RegionSignature Ty → RegionSignature Ty' :=
  List.map fun ⟨Γ, ty⟩ => (Γ.map f, ty.map f)

Signature.map

def Signature.map (f : Ty → Ty') : Signature Ty → Signature Ty' :=
  fun sig => {
    sig         := sig.sig.map f
    regSig      := sig.regSig.map f
    returnTypes := sig.returnTypes.map f
  }

Com

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 β

Expr.denote

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

Com.outContext

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

Com.rec'

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

Valuation.cast

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

Expr.outContext

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

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

Com.denote

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

Com.ty

def Com.ty : Com d Γ eff [t] → d.Ty := fun _ => t

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)

Regions

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

Expr.denoteOp

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

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

TyDenote.toType

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

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

@[simp] theorem map_cons : (Γ.cons a).map f = (Γ.map f).cons (f a)

theorem eq.ty_eq {v : Γ.Var t} {w : Γ.Var u} (h : v.eq w) : t = u

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

@[simp] theorem appendCases_appendInl (v : Γ.Var t) :
    appendCases (motive := motive) left right v.appendInl = (left v)

@[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

theorem Id.bind_eq' (x : Id α) (f : α → id β) : x >>= f = f x

@[simp] theorem Expr.denoteOp_eq_denoteOp_of {e₁ : Expr d Γ eff ty} {e₂ : Expr d Δ eff ty}
    {Γv : Valuation Γ} {Δv : Valuation Δ}
    (op_eq : e₁.op = e₂.op)
    (h_args : HVector.map Γv (op_eq ▸ e₁.args)
              = HVector.map Δv e₂.args)
    (h_regArgs : HEq e₁.regArgs.denote e₂.regArgs.denote) :
    e₁.denoteOp Γv = e₂.denoteOp Δv

theorem Id.pure_eq' (a : α) : (pure a : Id α) = a

MatchVarM

abbrev MatchVarM (Δ Γ : Ctxt d.Ty) := (StateT (Mapping Δ Γ) Option)

MatchVar

abbrev MatchVar (Δ Γ : Ctxt d.Ty)  := MatchVarM Δ Γ Unit

MatchVarResult.toArgResult

@[simp]
theorem MatchVar.liftM_bind_eq_some_iff (x? : Option α)
    (f : α → MatchVarM Δ Γ β) :
    ((liftM x? >>= f) mapIn = some mapOut)
    ↔ ( ∃ h : x?.isSome,
        f (x?.get h) mapIn = some mapOut )

theorem matchVar_appendInl {w : Var ⟨te⟩ t} :
    matchVar lets v (.var matchLets matchExpr) w.appendInl ma = some ma' →
    ∃ args,
      lets.getPureExpr v
        = some ⟨_, w, matchExpr.op, matchExpr.ty_eq, matchExpr.eff_le, args, matchExpr.regArgs⟩
      ∧ matchArg lets matchLets args matchExpr.args ma = some ma'

theorem getPureExpr_eq_some
    (mapOut : MatchVarResult lets v (.var matchLets matchExpr) w.appendInl mapIn) :
    ∃ args, lets.getPureExpr v = some ⟨te, w, ⟨
        matchExpr.op,
        matchExpr.ty_eq,
        matchExpr.eff_le,
        args,
        matchExpr.regArgs
      ⟩⟩

theorem HVector.map_eq_map_of_matchArg
    {lets : Lets d Γ_in eff Γ_out}
    {matchLets : Lets d Δ_in .pure Δ_out}
    {ma : Mapping Δ_in Γ_out}
    {l : List d.Ty} {args₁ : HVector _ l} {args₂ : HVector _ l}
    (mapOut : MatchArgResult lets matchLets args₁ args₂ ma)
    (f₁ f₂ : (t : d.Ty) → Var _ t → ⟦t⟧)
    (hf : ∀ {t v₁ v₂},
      (mapOut' : MatchVarResult lets v₁ matchLets v₂ ma)
      → mapOut'.val = mapOut.val
      → f₂ t v₂ = f₁ t v₁) :
    HVector.map f₂ args₂ = HVector.map f₁ args₁

import LeanMLIR.Framework

import LeanMLIR.Transforms.Rewrite.Mapping

open Ctxt (Var VarSet Valuation Hom)

variable {d} [DialectSignature d] [DecidableEq d.Ty]

variable {Γ : Ctxt d.Ty} {ty : d.Ty}

abbrev MatchVarM (Δ Γ : Ctxt d.Ty) := (StateT (Mapping Δ Γ) Option)

abbrev MatchVar (Δ Γ : Ctxt d.Ty)  := MatchVarM Δ Γ Unit

def MatchVarM.unifyVars {Δ Γ : Ctxt d.Ty} (v : Δ.Var t) (w : Γ.Var t) : MatchVar Δ Γ :=
  fun ma =>
    match ma.lookup ⟨_, v⟩ with
    | some v =>
      if v = w then
        some ((), ma)
      else
        none
    | none =>
      some ((), AList.insert ⟨_, v⟩ w ma)

open MatchVarM

variable [DecidableEq d.Op]

def matchArg [DecidableEq d.Op]
    (lets : Lets d Γ_in eff Γ_out) (matchLets : Lets d Δ_in .pure Δ_out) :
    {l : List d.Ty} → HVector (Var Γ_out) l → HVector (Var Δ_out) l →
    MatchVar Δ_in Γ_out
  | _, .nil, .nil => return
  | t::l, .cons vₗ vsₗ, .cons vᵣ vsᵣ => do
      matchVar (t := t) lets vₗ matchLets vᵣ
      matchArg lets matchLets vsₗ vsᵣ
  termination_by l => (sizeOf matchLets, l.length + 1)

def matchVar {Γ_in Γ_out Δ_in Δ_out : Ctxt d.Ty} {t : d.Ty} [DecidableEq d.Op]
    (lets : Lets d Γ_in eff Γ_out) (v : Var Γ_out t) :
    (matchLets : Lets d Δ_in .pure Δ_out) →
    (w : Var Δ_out t) →
    MatchVar Δ_in Γ_out

  | @Lets.var _ _ _ _ Δ_out ts matchLets matchExpr, w => by admit /- proof elided -/
      | right w =>
        exact matchVar lets v matchLets w
      | left w => exact do
        let ⟨ts', w', ie⟩ ← lets.getPureExpr v
        if hs : ∃ h : ie.op = matchExpr.op, ie.regArgs = (h ▸ matchExpr.regArgs) then
          have hts : Ctxt.ofList ts' = ts := by admit /- proof elided -/

end

section MatchVar

variable [DecidableEq d.Op] {Γ_in Γ_out Δ_in Δ_out t te}
          {lets : Lets d Γ_in eff Γ_out} {v : Var Γ_out t}
          {matchLets : Lets d Δ_in .pure Δ_out}
          {matchExpr : Expr d Δ_out .pure te}

variable (lets v matchLets w) (mapIn : Mapping _ _) in

def MatchVarResult := { mapOut : Mapping _ _ //
  ∃ (mapIn' mapOut' : Mapping _ _),
    mapIn.entries ⊆ mapIn'.entries
    ∧ mapOut'.entries ⊆ mapOut.entries
    ∧ matchVar lets v matchLets w mapIn' = some ((), mapOut') }

variable (lets matchLets) {tys} (vs ws : HVector _ tys) (mapIn : Mapping _ _) in

def MatchArgResult := { mapOut : Mapping _ _ //
  ∃ (mapIn' mapOut' : Mapping _ _),
    mapIn.entries ⊆ mapIn'.entries
    ∧ mapOut'.entries ⊆ mapOut.entries
    ∧ matchArg lets matchLets vs ws mapIn' = some ((), mapOut') }

namespace MatchVarResult

variable [TyDenote d.Ty] [∀ (t : d.Ty), Inhabited ⟦t⟧] in

section Left

variable {w : Δ_out.Var t}

def eqvVarLeft  :
    MatchVarResult lets v (.var matchLets matchExpr) w.appendInr ma
    ≃ MatchVarResult lets v matchLets w ma where
  toFun := fun ⟨x, h⟩ => ⟨x, by admit /- proof elided -/
  ⟩
  invFun := fun ⟨x, h⟩ => ⟨x, by admit /- proof elided -/
  ⟩

variable {mapIn} (mapOut : MatchVarResult lets v (.var matchLets matchExpr) w.appendInr mapIn)

end Left

variable {w : Var ⟨te⟩ _} {mapIn}

noncomputable def toArgResult
    (mapOut : MatchVarResult lets v (.var matchLets matchExpr) w.appendInl mapIn) :
    let args := mapOut.getPureExpr_eq_some.choose
    MatchArgResult lets matchLets args matchExpr.args mapIn :=
  ⟨mapOut.1, by admit /- proof elided -/
  ⟩

end MatchVarResult

end MatchVar

section SubsetEntries

open MatchVar

section UnifyVars

variable {Δ Γ : Ctxt d.Ty} {t} (w : Δ.Var t) (v : Γ.Var t)

end UnifyVars

variable [DecidableEq d.Op]

end SubsetEntries

namespace MatchArgResult

variable [DecidableEq d.Op] {Γ_in Γ_out Δ_in Δ_out te}
          {lets : Lets d Γ_in eff Γ_out}
          {matchLets : Lets d Δ_in .pure Δ_out}
          {matchExpr : Expr d Δ_out .pure te}
          {u us}
          {v : Γ_out.Var u} {vs : HVector Γ_out.Var us}
          {w : Δ_out.Var u} {ws : HVector Δ_out.Var us}
          {mapIn : Mapping _ _}
          (mapOut : MatchArgResult lets matchLets (v ::ₕ vs) (w ::ₕ ws) mapIn)

end MatchArgResult

section DenoteLemmas

variable [TyDenote d.Ty] [DecidableEq d.Op]

variable [∀ (t : d.Ty), Inhabited ⟦t⟧]

variable [Monad d.m] [LawfulMonad d.m] [DialectDenote d]

section DenoteIntoSubtype

end DenoteIntoSubtype

variable {Γ_in Γ_out Δ_in Δ_out : Ctxt d.Ty}
    {lets : Lets d Γ_in eff Γ_out}
    {matchLets : Lets d Δ_in .pure Δ_out}

theorem denote_matchVar
    {v w : Var _ t}
    (mapOut : MatchVarResult lets v matchLets w mapIn)
    (V : lets.ValidDenotation) :
    (matchLets.denote (mapOut.val.mapValuation V.val) w)
    = V.val v :=

:= by
  induction matchLets generalizing v mapIn t
  case nil => simp [Id.pure_eq']
  case var t' matchLets matchExpr ih =>
    cases w using Var.appendCases with
    | right w =>
      specialize ih mapOut.eqvVarLeft
      simpa [Id.bind_eq'] using ih
    | left w =>
      let mapOut' := mapOut.toArgResult
      have h := Exists.choose_spec mapOut.getPureExpr_eq_some

      rw [← V.prop h]
      simp
      congr 1

      apply Expr.denoteOp_eq_denoteOp_of (by rfl)
      · simp only [Expr.op_mk, Expr.args_mk]
        rw [HVector.map_eq_map_of_matchArg (f₁ := V.val) (mapOut := mapOut')]
        · intro t v₁ v₂ mapOut'' mapOut_eq
          simp [← ih mapOut'', mapOut_eq, mapOut']
      · rfl


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

BitVec.ofFn

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

@[simp]
def _root_.Set.proj (f : Fin n → Fin m) (bvs : Set (BitVecs m)) : Set (BitVecs n) :=
  BitVecs.transport f '' bvs

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

NFA.proj

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

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

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

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

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

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

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

namespace NFA

structure Deterministic (M : NFA α σ) : Prop where
  start : M.start.Subsingleton
  step : ∀ q a, M.step q a |>.Subsingleton

@[simps]
def proj (M: NFA (BitVec n1) σ) (f : Fin n2 → Fin n1) : NFA (BitVec n2) σ where
  start := M.start
  accept := M.accept
  step q a := { q' | ∃ a', a'.transport f = a ∧ q' ∈ M.step q a' }

@[simp]
lemma proj_eval (M : NFA (BitVec m) σ) (f : Fin n → Fin m) :
    (M.proj f).eval w =
      ⋃ w' ∈ BitVecs'.transport f ⁻¹' {w}, M.eval w' :=

:= by
  induction w using List.reverseRecOn
  case nil => simp [proj, BitVecs'.transport]
  case append_singleton w a ih =>
    ext q; simp [BitVecs'.transport]; constructor
    · rintro ⟨a', htr, S, hrS, hqS⟩
      rcases hrS with ⟨q', rfl⟩
      simp [ih] at hqS
      rcases hqS with ⟨⟨w', htr', he⟩, hs⟩
      use w' ++ [a']; constructor
      · simp_all; exact htr'
      · simp; use M.step q' a'; constructor
        on_goal 2 => assumption
        use q'; simp_all
    · rintro ⟨wa', heq, he⟩
      by_cases hemp : wa' = []
      · simp_all
      have hdl := List.dropLast_concat_getLast hemp
      rw [←hdl] at heq he
      simp only [List.map_append, List.map_dropLast, List.map_cons, List.map_nil] at heq
      use List.getLast wa' hemp; constructor
      · apply List.append_inj_right' at heq; simp_all
      · obtain rfl := List.append_inj_left' heq (by simp)
        simp at he; rcases he with ⟨S, ⟨q', rfl⟩, hqS⟩
        simp at hqS; rcases hqS with ⟨he, hs⟩
        simp only [stepSet, mem_iUnion, exists_prop]
        use q'
        simp [ih]; constructor
        on_goal 2 => assumption
        use wa'.dropLast
        simp_all [BitVecs'.transport]


theorem nfaOfFormula_bv_language φ :
    (nfaOfFormula φ).bv_recognizes φ.language

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

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

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 liftMaxSuccSucc2 (n m : Nat) : Fin (m + 1) → Fin (max n m + 3) :=
  fun k => if _ : k = Fin.last m then max n m + 1 else k.castLE (by admit /- proof elided -/
  )

def liftMaxSuccSucc1 (n m : Nat) : Fin (n + 1) → Fin (max n m + 3) :=
  fun k => if _ : k = Fin.last n then (max n m).cast else k.castLE (by admit /- proof elided -/
  )

def liftLast3 n : Fin 3 → Fin (n + 3)
| 0 => n
| 1 => n + 1
| 2 => Fin.last (n + 2)

Unop

inductive Unop
| neg
deriving Repr

RelationOrdering

inductive RelationOrdering
| lt | le | gt | ge
deriving Repr, Fintype

Relation

inductive Relation
| eq
| signed (ord : RelationOrdering)
| unsigned (ord : RelationOrdering)
deriving Repr

WidthPredicate

inductive WidthPredicate
| eq
| neq
| lt
| le
| gt
| ge
deriving Repr, Inhabited, Lean.ToExpr

Binop

inductive Binop
| and | or | impl | equiv
deriving Repr

def liftLast2 n : Fin 2 → Fin (n + 2)
| 0 => n
| 1 => Fin.last (n + 1)

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

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

def liftMax2 (n m : Nat) : Fin m → Fin (max n m) :=
  fun k => k.castLE (by admit /- proof elided -/
  )

def liftExcept2 n : Fin n → Fin (n + 2) :=
  fun k => Fin.castLE (by admit /- proof elided -/
  ) k

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

def liftMax1 (n m : Nat) : Fin n → Fin (max n m) :=
  fun k => k.castLE (by admit /- proof elided -/
  )

Formula

inductive Formula : Type
| width : WidthPredicate → Nat → Formula
| atom : Relation → Term → Term → Formula
| msbSet : Term → Formula
| unop : Unop → Formula → Formula
| binop : Binop → Formula → Formula → Formula
deriving Repr

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

Formula.language

@[simp]
def Formula.language (φ : Formula) : Set (BitVecs φ.arity) :=
  match φ with
  | .width wp n => { bvs | wp.sat bvs.w n }
  | .atom rel t1 t2 =>
    let l1 := t1.language.lift (liftMaxSucc1 (FinEnum.card $ Fin t1.arity) (FinEnum.card $ Fin t2.arity))
    let l2 := t2.language.lift (liftMaxSucc2 (FinEnum.card $ Fin t1.arity) (FinEnum.card $ Fin t2.arity))
    let lrel := rel.language.lift $ liftLast2 (max (FinEnum.card (Fin t1.arity)) (FinEnum.card (Fin t2.arity)))
    let l := lrel ∩ l1 ∩ l2
    l.proj (liftExcept2 _)
  | .unop .neg φ => φ.languageᶜ
  | .binop op φ1 φ2 =>
    let l1 := φ1.language.lift $ liftMax1 φ1.arity φ2.arity
    let l2 := φ2.language.lift $ liftMax2 φ1.arity φ2.arity
    langBinop op l1 l2
  | .msbSet t =>
    let lmsb := langMsb.lift $ fun _ => Fin.last t.arity
    let l' := t.language ∩ lmsb
    l'.proj fun n => n.castLE (by admit /- proof elided -/
    )

WidthPredicate.sat

@[simp]
def WidthPredicate.sat (wp : WidthPredicate) (w n : Nat) : Bool :=
  match wp with
  | .eq => w = n
  | .neq => w ≠ n
  | .lt => w < n
  | .le => w ≤ n
  | .gt => w > n
  | .ge => w ≥ n

@[simp]
def _root_.Set.proj (f : Fin n → Fin m) (bvs : Set (BitVecs m)) : Set (BitVecs n) :=
  BitVecs.transport f '' bvs

BitVecs.transport

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

BitVec.transport

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

BitVecs

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

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

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 }

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

@[simp]
def _root_.Set.lift (f : Fin n → Fin m) (bvs : Set (BitVecs n)) : Set (BitVecs m) :=
  BitVecs.transport f ⁻¹' bvs

Formula.sat

@[simp]
def Formula.sat {w : Nat} (φ : Formula) (ρ : Fin φ.arity → BitVec w) : Prop :=
  match φ with
  | .width wp n => wp.sat w n
  | .atom rel t1 t2 =>
    let bv1 := t1.evalFinBV (fun n => ρ $ Fin.castLE (by admit /- proof elided -/
    ) n)
    let bv2 := t2.evalFinBV (fun n => ρ $ Fin.castLE (by admit /- proof elided -/
    ) n)
    evalRelation rel bv1 bv2
  | .unop .neg φ => ¬ φ.sat ρ
  | .binop op φ1 φ2 =>
    let b1 := φ1.sat (fun n => ρ $ Fin.castLE (by admit /- proof elided -/
    ) n)
    let b2 := φ2.sat (fun n => ρ $ Fin.castLE (by admit /- proof elided -/
    ) n)
    evalBinop op b1 b2
  | .msbSet t => (t.evalFinBV ρ).msb

evalBinop

def evalBinop (op : Binop) (b1 b2 : Prop) : Prop :=
  match op with
  | .and => b1 ∧ b2
  | .or => b1 ∨ b2
  | .impl => b1 → b2
  | .equiv => b1 ↔ b2

evalRelation

def evalRelation (rel : Relation) {w} (bv1 bv2 : BitVec w) : Prop :=
  match rel with
  | .eq => bv1 = bv2
  | .signed .lt => bv1.slt bv2
  | .signed .le => bv1.sle  bv2
  | .signed .gt => bv2.slt bv1
  | .signed .ge => bv2.sle bv1
  | .unsigned .lt => bv1.ult bv2
  | .unsigned .le => bv1.ule bv2
  | .unsigned .gt => bv2.ult bv1
  | .unsigned .ge => bv2.ule bv1

langBinop

def langBinop (op : Binop) (l1 l2 : Set (BitVecs n)) : Set (BitVecs n) :=
  match op with
  | .and => l1 ∩ l2
  | .or => l1 ∪ l2
  | .impl => l1ᶜ ∪ l2
  | .equiv => (l1ᶜ ∪ l2) ∩ (l2ᶜ ∪ l1)

Relation.language

@[simp]
def Relation.language (rel : Relation) : Set (BitVecs 2) :=
  { bvs | evalRelation rel (bvs.bvs.get 0) (bvs.bvs.get 1) }

NFA'

structure NFA' (n : Nat) where
  σ : Type
  M : NFA (BitVec 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

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 :=

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⟩

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

CNFA.neg

def CNFA.neg (m : CNFA n) : CNFA n := m.determinize.flipFinals

CNFA.flipFinals

def CNFA.flipFinals (m : CNFA n) : CNFA n := ⟨m.m.flipFinals, m.m.flipFinals_wf m.wf⟩

RawCNFA.flipFinals

def RawCNFA.flipFinals (m : RawCNFA A) : RawCNFA A :=
  let oldFinals := m.finals
  let newFinals := (List.range m.stateMax).foldl (init := ∅) fun fins s =>
    if oldFinals.contains s then fins else fins.insert s
  { m with finals := newFinals }

def bv2 : BitVec 4 := BitVec.ofNat 4 1

def bv1 : BitVec 4 := BitVec.ofNat 4 5

instFinEnumBV

instance instFinEnumBV : FinEnum (BitVec w) where
  card := 2^w
  equiv := {
    toFun := fun x => x.toFin
    invFun := fun x => BitVec.ofFin x
    left_inv := by admit /- proof elided -/

RawCNFA.WF

structure RawCNFA.WF (m : RawCNFA A) where
  initials_lt : ∀ {s}, s ∈ m.initials → s ∈ m.states
  finals_lt : ∀ {s}, s ∈ m.finals → s ∈ m.states
  trans_src_lt : ∀ s_a ∈ m.trans, s_a.1 ∈ m.states
  trans_tgt_lt : s' ∈ m.tr s a → s' ∈ m.states

def CNFA.product_spec (final? : Bool → Bool → Bool) (m1 m2 : CNFA n)
  {M1 : NFA' n} {M2 : NFA' n} :
    m1.Sim M1 →
    m2.Sim M2 →
    (product final? m1 m2).Sim (NFA'.product (to_prop final?) M1 M2) :=

noncomputable def to_prop (f : Bool → Bool → Bool) (p1 p2 : Prop) : Prop :=
  f (@Decidable.decide p1 (Classical.propDecidable _)) (@Decidable.decide p2 (Classical.propDecidable _))

CNFA.union

def CNFA.union (m1 m2 : CNFA n) : CNFA n :=
  product (fun b1 b2 => b1 || b2) m1.addSink m2.addSink

CNFA.addSink

@[inline]
def CNFA.addSink (m : CNFA n) : CNFA n := ⟨m.m.addSink, wf_createSink m.wf⟩

RawCNFA.addSink

@[inline]
def RawCNFA.addSink (m : RawCNFA A) : RawCNFA A := m.createSink.2

complete

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

RawCNFA.addTrans

def RawCNFA.addTrans (m : RawCNFA A) (a : A) (s s' : State) : RawCNFA A :=
  let ns := m.trans.getD (s, a) ∅
  let ns := ns.insert s'
  { m with trans :=  m.trans.insert (s, a) ns }

RawCNFA.newState

def RawCNFA.newState (m : RawCNFA A) : State × RawCNFA A :=
  let old := m.stateMax
  let m := { m with stateMax := old + 1 }
  (old, m)

RawCNFA.addInitial

def RawCNFA.addInitial (m : RawCNFA A) (s : State) : RawCNFA A :=
  { m with initials := m.initials.insert s }

langMsb

@[simp]
def langMsb : Set (BitVecs 1) := { bvs | bvs.bvs.get 0 |>.msb }

head

def head (x : BitStream) : Bool      := x 0

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)

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

@[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 simulFun_sim {m : CNFA n} f :
    m.m.SimulFun M.M f → m.Sim M

lemma simulFun_sim_raw [LawfulBEq A] {m : RawCNFA A} (hwf : m.WF) f :
    m.SimulFun M f → m.Sim M

RawCNFA.Simul.initial

@[simp]
lemma RawCNFA.Simul.initial {m : RawCNFA A} {M : NFA A Q} (hsim : m.Simul M R ⊤ ∅) :
    R.set_eq m.initials.toSet M.start

lemma CNFA.inter_spec (m1 m2 : CNFA n)
  {M1 : NFA' n} {M2 : NFA' n} :
    m1.Sim M1 →
    m2.Sim M2 →
    (m1.inter m2).Sim (M1.inter M2)

lemma CNFA.union_spec (m1 m2 : CNFA n)
  {M1 : NFA' n} {M2 : NFA' n} :
    m1.Sim M1 →
    m2.Sim M2 →
    (m1.union m2).Sim (M1.union M2)

lemma CNFA.addSink_spec (m : CNFA n) (M : NFA' n) :
    m.Sim M →
    m.addSink.Sim M.complete

@[grind ., simp, aesop 50% unsafe]
lemma wf_addTrans [LawfulBEq A] (m : RawCNFA A) (hwf : m.WF) s a s' (hin : s ∈ m.states) (hin' : s' ∈ m.states) :
    (m.addTrans a s s').WF

@[grind =, simp]
lemma RawCNFA.same_stateMax (m : RawCNFA A) x y (z : Std.HashMap (State × A) (Std.HashSet State)) :
    (RawCNFA.mk m.stateMax x y z).states = m.states

@[grind =, simp, aesop 50% unsafe]
lemma newState_eq (m : RawCNFA A) :
    m.newState.1 = m.stateMax

@[grind =, simp]
lemma addInitial_stateMax {m : RawCNFA A} : (m.addInitial s).stateMax = m.stateMax

@[grind =, simp]
lemma addTrans_stateMax {m : RawCNFA A} : (m.addTrans a s s').stateMax = m.stateMax

@[simp]
lemma dec_enc' : dec (enc bvs) = bvs

@[simp]
lemma dec_enc : Function.RightInverse (α := BitVecs' n) enc dec

lemma dec_enc_w (bvs : BitVecs n) : (dec (enc bvs)).w = bvs.w

@[simp]
theorem BitVec.ofFn_getElem {w : Nat} (f : Fin w → Bool) {i : Nat} (hi : i < w) :
    (BitVec.ofFn f)[i] = f ⟨i, hi⟩

@[simp]
theorem BitVec.ofFn_getLsbD {w : Nat} {f : Fin w → Bool} {i : Nat} (hi : i < w) :
    (BitVec.ofFn f).getLsbD i = f ⟨i, hi⟩

theorem BitVec.ofFn_getLsbD_fin {w : Nat} {f : Fin w → Bool} {i : Fin w} :
    (BitVec.ofFn f).getLsbD i = f i

NFA.sa

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

NFA.correct

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

BVRel

abbrev BVRel := ∀ ⦃w⦄, BitVec w → BitVec w → Prop

BVNRel

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

NFA'.sa

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

def NFA'.sa2 (M : NFA' 2) := M.σ → BVRel

langRel

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

def langRel2 (R : BVRel) : Set (BitVecs 2) :=
  { bvs | R (bvs.bvs.get 0) (bvs.bvs.get 1) }

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

@[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) :=

CNFA.ofFSM

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

RawCNFA.autEq

def RawCNFA.autEq : RawCNFA (BitVec 2) :=
  let m := RawCNFA.empty
  let (s, m) := m.newState
  let m := m.addInitial s
  let m := m.addFinal s
  let m := m.addTrans 0 s s
  let m := m.addTrans 3 s s
  m

CNFA.autEq

def CNFA.autEq : CNFA 2 :=
  ⟨RawCNFA.autEq, by admit /- proof elided -/
  ⟩

NFA.autEq

def NFA.autEq : NFA (BitVec 2) Unit :=
  { start := ⊤, accept := ⊤, step _ a := { _s' | if a = 0 ∨ a = 3 then true else false }}

NFA'.autEq

def NFA'.autEq : NFA' 2 :=
  ⟨Unit, NFA.autEq⟩

NFA'.eqRel

def NFA'.eqRel : BVRel := fun _ x y => x = y

def autEq_equiv : CNFA.autEq.m.states ≃ NFA'.autEq.σ where
  toFun := fun ⟨s, hs⟩ =>
    match s with
    | _ => ()
  invFun q :=
    match q with
    | () => ⟨0, by admit /- proof elided -/
    ⟩
  left_inv := by admit /- proof elided -/

CNFA.autUnsignedCmp

def CNFA.autUnsignedCmp (cmp: RelationOrdering) : CNFA 2 :=
  ⟨RawCNFA.autUnsignedCmp cmp, RawCNFA.autoUnsignedCmp_wf⟩

NFA.unsignedCmpState

inductive NFA.unsignedCmpState : Type where
| eq | gt | lt
deriving Fintype, DecidableEq

NFA'.autUnsignedCmp

def NFA'.autUnsignedCmp (cmp: RelationOrdering) : NFA' 2 :=
  ⟨_, NFA.autUnsignedCmp cmp⟩

NFA'.autUnsignedCmpSA

def NFA'.autUnsignedCmpSA (q : NFA.unsignedCmpState) : BVRel :=
  match q with
  | .eq => fun _ bv1 bv2 => bv1 = bv2
  | .lt => fun _ bv1 bv2 => bv1.ult bv2
  | .gt => fun _ bv1 bv2 => bv2.ult bv1

CNFA.autSignedCmp

def CNFA.autSignedCmp (cmp: RelationOrdering) : CNFA 2 :=
  ⟨RawCNFA.autSignedCmp cmp, RawCNFA.autSignedCmp_wf⟩

NFA.signedCmpState

inductive NFA.signedCmpState : Type where
| eq | gt | lt | ltfin | gtfin
deriving DecidableEq, Fintype

NFA'.autSignedCmp

def NFA'.autSignedCmp (cmp: RelationOrdering) : NFA' 2 :=
  ⟨_, NFA.autSignedCmp cmp⟩

CNFA.autMsbSet

@[inline]
def CNFA.autMsbSet : CNFA 1 :=
  ⟨RawCNFA.autMsbSet, RawCNFA.autMsbSet_wf⟩

NFA.msbState

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

NFA.msbStep

def NFA.msbStep (q : NFA.msbState) (a : BitVec 1) : List NFA.msbState :=
  match q, a with
  | .i, 0 => [.i]
  | .i, 1 => [.i, .f]
  | _, _ => []

NFA.autMsbSet

def NFA.autMsbSet : NFA (BitVec 1) msbState where
  step s a := { s' | s' ∈ msbStep s a }
  start := {.i}
  accept := {.f}

NFA'.autMsbSet

def NFA'.autMsbSet : NFA' 1 := ⟨_, NFA.autMsbSet⟩

NFA.msbLang

def NFA.msbLang : Language (BitVec 1) := { bvs  | bvs.getLast? = some 1 }

NFA.msbSA

def NFA.msbSA (q : msbState) : Language (BitVec 1) :=
  match q with
  | .i => ⊤
  | .f => msbLang

NFA.msbCorrect

def NFA.msbCorrect : NFA.autMsbSet.correct msbSA msbLang :=

WidthPredicate.final?

def WidthPredicate.final? (wp : WidthPredicate) (n : Nat) (s : State) : Bool :=
  decide (wp.sat s n)

CNFA.autWidth

def CNFA.autWidth (wp : WidthPredicate) (n : Nat) : CNFA 0 :=
  ⟨RawCNFA.autWidth wp n, RawCNFA.autWidth_wf⟩

NFA.autWidth

def NFA.autWidth (wp : WidthPredicate) (n : Nat) : NFA (BitVec 0) (Fin (n+2)) where
  start := { 0 }
  accept := { s | wp.final? n s }
  step s₁ _ := { s₂ | if s₁ = Fin.last (n+1) then s₁ = s₂ else s₂ = s₁ + 1 }

NFA'.autWidth

def NFA'.autWidth (wp : WidthPredicate) (n : Nat) : NFA' 0 := ⟨_, NFA.autWidth wp n⟩

@[simp]
def NFA'.autWidth_spec : (autWidth wp n).accepts = { bv | wp.sat bv.w n } :=

Relation.autOfRelation

def Relation.autOfRelation : Relation → CNFA 2
| .eq => CNFA.autEq
| .signed ord => CNFA.autSignedCmp ord
| .unsigned ord => CNFA.autUnsignedCmp ord

Relation.absAutOfRelation

def Relation.absAutOfRelation (rel : Relation) : NFA' 2 :=
  match rel with
  | .eq => NFA'.autEq
  | .unsigned cmp => NFA'.autUnsignedCmp cmp
  | .signed cmp => NFA'.autSignedCmp cmp

unopNfa

def unopNfa (op : Unop) (m : CNFA n) : CNFA n :=
  match op with
  | .neg => m.neg

unopAbsNfa

def unopAbsNfa (op : Unop) (M : NFA' n) : NFA' n :=
  match op with
  | .neg => M.neg

binopNfa

def binopNfa (op : Binop) (m1 m2 : CNFA n) : CNFA n :=
  match op with
  | .and => m1.inter m2
  | .or => m1.union m2
  | .impl => m1.neg.union m2
  | .equiv => (m1.neg.union m2).inter (m2.neg.union m1)

binopAbsNfa

def binopAbsNfa (op : Binop) (M1 M2: NFA' n) : NFA' n :=
  match op with
  | .and => M1.inter M2
  | .or => M1.union M2
  | .impl => M1.neg.union M2
  | .equiv => (M1.neg.union M2).inter (M2.neg.union M1)

liftOp

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

@[simp]
def liftOp_unchanged (k : Fin n) : liftOp n k.castSucc = k.castLE (by simp) :=

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

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₂

TermBinop.openTerm

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

@[simp]
def TermBinop.openTerm_arity (op : TermBinop) : op.openTerm.arity + 1 = 3 :=

swapLastTwoBlock

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

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

def TermUnop.openTerm_arity (op : TermUnop) : op.openTerm.arity = 1 :=

@[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

nfaOfFormula

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

lemma NFA'.correct2_spec {M : NFA' 2} {ζ : M.sa2} {L : BVRel} :
    M.correct2 ζ L → M.accepts = langRel2 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 NFA'.autEq_correct : autEq.correct2 (fun _ => eqRel) eqRel

lemma CNFA.autEq_spec : autEq.Sim NFA'.autEq

lemma BitVec.ule_iff_ult_or_eq {w : ℕ} (bv1 bv2 : BitVec w):
    (bv1.ule bv2) = true ↔ (bv1.ult bv2) = true ∨ bv1 = bv2

@[simp]
lemma ucmp_tricho {bv1 bv2 : BitVec w} : (bv2.ult bv1) = false → (bv1.ult bv2) = false → bv1 = bv2

lemma NFA'.autUnsignedCmp_correct cmp : autUnsignedCmp cmp |>.correct2 autUnsignedCmpSA cmp.urel

private lemma BitVec.sle_iff_slt_or_eq {w : ℕ} (bv1 bv2 : BitVec w):
    (bv1.sle bv2) = true ↔ (bv1.slt bv2) = true ∨ bv1 = bv2

lemma NFA'.autSignedCmp_correct cmp : autSignedCmp cmp |>.correct2 autSignedCmpSA cmp.srel

lemma CNFA.autUnsignedCmp_spec {cmp} : (CNFA.autUnsignedCmp cmp).Sim (NFA'.autUnsignedCmp cmp)

lemma CNFA.autSignedCmp_spec {cmp} : (CNFA.autSignedCmp cmp).Sim (NFA'.autSignedCmp cmp)

lemma CNFA.autMsbSet_spec : CNFA.autMsbSet.Sim NFA'.autMsbSet

@[simp]
lemma autMsbSet_accepts : NFA'.autMsbSet.accepts = langMsb

lemma CNFA.autMsbSet_bv_language : autMsbSet.bv_recognizes langMsb

lemma RawCNFA.autWidth_spec {wp : WidthPredicate} :
  let m := RawCNFA.autWidth wp n
  m.WF ∧ m.stateMax = n+2 ∧
  (∀ s, s ∈ m.states → (s ∈ m.initials ↔ s = 0) ∧ (s ∈ m.finals ↔ wp.final? n s)) ∧
  (∀ s s', s ∈ m.states → s' ∈ m.states → (s' ∈ m.tr s 0 ↔ if s = n+1 then s = s' else s' = s + 1))

@[simp]
lemma CNFA.autWidth_states: s ∈ (autWidth wp n).m.states ↔ s < n+2

lemma CNFA.autWidth_initials : s ∈ (autWidth wp n).m.initials ↔ s = 0

lemma CNFA.autWidth_finals (hn : s < n + 2) : s ∈ (autWidth wp n).m.finals ↔ wp.final? n s

lemma CNFA.autWidth_tr (hs : s < n + 2) (hs' : s' < n + 2) : s' ∈ (autWidth wp n).m.tr s 0 ↔ if s = n+1 then s = s' else s' = s + 1

lemma CNFA.autWidth_spec : autWidth wp n |>.Sim (NFA'.autWidth wp n)

lemma CNFA.autWidth_bv_language :
    (autWidth wp n).bv_recognizes { bv | wp.sat bv.w n }

lemma autOfRelation_spec (r : Relation) :
  r.autOfRelation.Sim r.absAutOfRelation

@[simp]
lemma autOfRelation_accepts (r : Relation) :
    r.absAutOfRelation.accepts = r.language

lemma CNFA.autOfRelation_bv_language (r : Relation) :
    (r.autOfRelation).bv_recognizes r.language

lemma unopNfa_spec (op : Unop) (m : CNFA n) (M : NFA' n) :
    m.Sim M → (unopNfa op m).Sim (unopAbsNfa op M)

lemma unopNfa_accepts (op : Unop) (M : NFA' n) :
    (unopAbsNfa op M).accepts = M.acceptsᶜ

lemma unopNfa_bv_language (op : Unop) :
    m.bv_recognizes L → (unopNfa op m).bv_recognizes Lᶜ

lemma binopNfa_bv_language (op : Binop) {m₁ m₂ : CNFA n}  :
    m₁.bv_recognizes L₁ → m₂.bv_recognizes L₂ →
    (binopNfa op m₁ m₂).bv_recognizes (langBinop op L₁ L₂)

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

lemma TermBinop.alt_lang {t₁ t₂ : Term} (op : TermBinop) :
  (op.subst_arity' ▸ (op.subst t₁ t₂).language) =
    let lop : Set (BitVecs 3) := op.openTerm_arity ▸ op.openTerm.language
    let lop' : Set (BitVecs ((t₁.arity ⊔ t₂.arity) + 3)) := lop.lift (liftLast3 (max t₁.arity t₂.arity))
    let l₁ := t₁.language.lift (liftMaxSuccSucc1 t₁.arity t₂.arity)
    let l₂ := t₂.language.lift (liftMaxSuccSucc2 t₁.arity t₂.arity)
    let l := l₁ ∩ l₂ ∩ lop'
    l.proj (liftOp _)

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

lemma autOfTermBinop_bv_language op {t₁ t₂ : Term} (m₁ : CNFA (t₁.arity + 1)) (m₂ : CNFA (t₂.arity + 1)) :
    m₁.bv_recognizes t₁.language →
    m₂.bv_recognizes t₂.language →
    (autOfTermBinop op m₁ m₂ |>.bv_recognizes (op.subst_arity' ▸ (op.subst t₁ t₂).language))

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)

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

lemma nfaOfTerm_bv_language (t : Term) :
    nfaOfTerm t |>.bv_recognizes t.language

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 BVRel := ∀ ⦃w⦄, BitVec w → BitVec w → Prop

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

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

def NFA'.sa2 (M : NFA' 2) := M.σ → BVRel

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

def langRel2 (R : BVRel) : Set (BitVecs 2) :=
  { bvs | R (bvs.bvs.get 0) (bvs.bvs.get 1) }

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

def RawCNFA.autEq : RawCNFA (BitVec 2) :=
  let m := RawCNFA.empty
  let (s, m) := m.newState
  let m := m.addInitial s
  let m := m.addFinal s
  let m := m.addTrans 0 s s
  let m := m.addTrans 3 s s
  m

def CNFA.autEq : CNFA 2 :=
  ⟨RawCNFA.autEq, by admit /- proof elided -/
  ⟩

def NFA.autEq : NFA (BitVec 2) Unit :=
  { start := ⊤, accept := ⊤, step _ a := { _s' | if a = 0 ∨ a = 3 then true else false }}

def NFA'.autEq : NFA' 2 :=
  ⟨Unit, NFA.autEq⟩

def NFA'.eqRel : BVRel := fun _ x y => x = y

def autEq_equiv : CNFA.autEq.m.states ≃ NFA'.autEq.σ where
  toFun := fun ⟨s, hs⟩ =>
    match s with
    | _ => ()
  invFun q :=
    match q with
    | () => ⟨0, by admit /- proof elided -/
    ⟩
  left_inv := by admit /- proof elided -/

def RawCNFA.autUnsignedCmp (cmp: RelationOrdering) : RawCNFA (BitVec 2) :=
  let m := RawCNFA.empty
  let (seq, m) := m.newState
  let (sgt, m) := m.newState
  let (slt, m) := m.newState
  let m := m.addInitial seq
  let m := m.addManyTrans [0#2, 3#2] seq seq
  let m := m.addTrans 1#2 seq sgt
  let m := m.addTrans 2#2 seq slt
  let m := m.addManyTrans [0#2, 1#2, 3#2] sgt sgt
  let m := m.addTrans 2#2 sgt slt
  let m := m.addManyTrans [0#2, 2#2, 3#2] slt slt
  let mf := m.addTrans 1#2 slt sgt
  match cmp with
  | .lt => mf.addFinal slt
  | .le => (mf.addFinal slt).addFinal seq
  | .gt => mf.addFinal sgt
  | .ge => (mf.addFinal sgt).addFinal seq

def CNFA.autUnsignedCmp (cmp: RelationOrdering) : CNFA 2 :=
  ⟨RawCNFA.autUnsignedCmp cmp, RawCNFA.autoUnsignedCmp_wf⟩

inductive NFA.unsignedCmpState : Type where
| eq | gt | lt
deriving Fintype, DecidableEq

def NFA.unsignedCmpStep (q : NFA.unsignedCmpState) (a : BitVec 2) : List NFA.unsignedCmpState :=
  match q, a with
  | .eq, 0 => [ .eq ] | .eq, 3 => [ .eq ] | .eq, 1 => [ .gt ] | .eq, 2 => [ .lt ]
  | .gt, 0 => [ .gt ] | .gt, 1 => [ .gt ] | .gt, 3 => [ .gt ] | .gt, 2 => [ .lt ]
  | .lt, 0 => [ .lt ] | .lt, 1 => [ .gt ] | .lt, 2 => [ .lt ] | .lt, 3 => [ .lt ]

def NFA.autUnsignedCmp (cmp: RelationOrdering) : NFA (BitVec 2) unsignedCmpState where
  step s a := { s' | s' ∈ unsignedCmpStep s a }
  start := {s | s = .eq }
  accept := { s | s ∈ match cmp with | .lt => [unsignedCmpState.lt] | .le => [.lt, .eq] | .gt => [.gt] | .ge => [.gt, .eq] }

def NFA'.autUnsignedCmp (cmp: RelationOrdering) : NFA' 2 :=
  ⟨_, NFA.autUnsignedCmp cmp⟩

def RelationOrdering.urel (cmp : RelationOrdering) : BVRel :=
  match cmp with
  | .lt => fun _ bv1 bv2 => bv1.ult bv2
  | .le => fun _ bv1 bv2 => bv1.ule bv2
  | .gt => fun _ bv1 bv2 => bv2.ult bv1
  | .ge => fun _ bv1 bv2 => bv2.ule bv1

def NFA'.autUnsignedCmpSA (q : NFA.unsignedCmpState) : BVRel :=
  match q with
  | .eq => fun _ bv1 bv2 => bv1 = bv2
  | .lt => fun _ bv1 bv2 => bv1.ult bv2
  | .gt => fun _ bv1 bv2 => bv2.ult bv1

def RawCNFA.autSignedCmp (cmp: RelationOrdering) : RawCNFA (BitVec 2) :=
  let (m, sltfin, sgtfin, seq) := m
  match cmp with
  | .lt => m.addFinal sltfin
  | .le => (m.addFinal sltfin).addFinal seq
  | .gt => m.addFinal sgtfin
  | .ge => (m.addFinal sgtfin).addFinal seq
where

def CNFA.autSignedCmp (cmp: RelationOrdering) : CNFA 2 :=
  ⟨RawCNFA.autSignedCmp cmp, RawCNFA.autSignedCmp_wf⟩

inductive NFA.signedCmpState : Type where
| eq | gt | lt | ltfin | gtfin
deriving DecidableEq, Fintype

def NFA.signedCmpStep (q : NFA.signedCmpState) (a : BitVec 2) : List NFA.signedCmpState :=
  match q, a with
  | .eq, 0 => [ .eq ] | .eq, 3 => [.eq] | .eq, 1 => [.gt, .ltfin] | .eq, 2 => [ .lt, .gtfin ]
  | .gt, 0 => [ .gt, .gtfin ] | .gt, 1 => [ .gt, .ltfin ] | .gt, 3 => [ .gt, .gtfin ] | .gt, 2 => [ .lt, .gtfin ]
  | .lt, 0 => [ .lt, .ltfin ] | .lt, 1 => [ .gt, .ltfin ] | .lt, 2 => [ .lt, .gtfin ] | .lt, 3 => [ .lt, .ltfin ]
  | .gtfin, _ => ∅
  | .ltfin, _ => ∅

def NFA.autSignedCmp (cmp: RelationOrdering) : NFA (BitVec 2) signedCmpState where
  step s a := { s' | s' ∈ signedCmpStep s a }
  start := { s | s = signedCmpState.eq }
  accept := { s | s ∈ match cmp with | .lt => [NFA.signedCmpState.ltfin] | .le => [.ltfin, .eq] | .gt => [.gtfin] | .ge => [.gtfin, .eq] }

def NFA'.autSignedCmp (cmp: RelationOrdering) : NFA' 2 :=
  ⟨_, NFA.autSignedCmp cmp⟩

def RelationOrdering.srel (cmp : RelationOrdering) : BVRel :=
  match cmp with
  | .lt => fun _ bv1 bv2 => bv1.slt bv2
  | .le => fun _ bv1 bv2 => bv1.sle bv2
  | .gt => fun _ bv1 bv2 => bv2.slt bv1
  | .ge => fun _ bv1 bv2 => bv2.sle bv1

def NFA'.autSignedCmpSA (q : NFA.signedCmpState) : BVRel :=
  match q with
  | .eq => fun _ bv1 bv2 => bv1 = bv2
  | .lt => fun _ bv1 bv2 => bv1.ult bv2
  | .gt => fun _ bv1 bv2 => bv2.ult bv1
  | .ltfin => fun _ bv1 bv2 => bv1.slt bv2
  | .gtfin => fun _ bv1 bv2 => bv2.slt bv1

def unsigned_equiv cmp : (CNFA.autUnsignedCmp cmp).m.states ≃ (NFA'.autUnsignedCmp cmp).σ where
  toFun := fun ⟨s, hs⟩ =>
    match s with
    | 0 => .eq
    | 1 => .gt
    | _ => .lt
  invFun q :=
    match q with
    | .eq => ⟨0, by admit /- proof elided -/
    ⟩
    | .gt => ⟨1, by admit /- proof elided -/
    ⟩
    | .lt => ⟨2, by admit /- proof elided -/
    ⟩
  left_inv := by admit /- proof elided -/

def signed_equiv cmp : (CNFA.autSignedCmp cmp).m.states ≃ (NFA'.autSignedCmp cmp).σ where
  toFun := fun ⟨s, hs⟩ =>
    match s with
    | 0 => .eq
    | 1 => .gt
    | 2 => .lt
    | 3 => .gtfin
    | _ => .ltfin
  invFun q :=
    match q with
    | .eq => ⟨0, by admit /- proof elided -/
    ⟩
    | .gt => ⟨1, by admit /- proof elided -/
    ⟩
    | .lt => ⟨2, by admit /- proof elided -/
    ⟩
    | .gtfin => ⟨3, by admit /- proof elided -/
    ⟩
    | .ltfin => ⟨4, by admit /- proof elided -/
    ⟩
  left_inv := by admit /- proof elided -/

def RawCNFA.autMsbSet : RawCNFA (BitVec 1) :=
  let m := RawCNFA.empty
  let (si, m) := m.newState
  let (sf, m) := m.newState
  let m := m.addInitial si
  let m := m.addFinal sf
  let m := m.addTrans 1 si sf
  let m := m.addManyTrans [0, 1] si si
  m

@[inline]
def CNFA.autMsbSet : CNFA 1 :=
  ⟨RawCNFA.autMsbSet, RawCNFA.autMsbSet_wf⟩

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

def NFA.msbStep (q : NFA.msbState) (a : BitVec 1) : List NFA.msbState :=
  match q, a with
  | .i, 0 => [.i]
  | .i, 1 => [.i, .f]
  | _, _ => []

def NFA.autMsbSet : NFA (BitVec 1) msbState where
  step s a := { s' | s' ∈ msbStep s a }
  start := {.i}
  accept := {.f}

def NFA'.autMsbSet : NFA' 1 := ⟨_, NFA.autMsbSet⟩

def NFA.msbLang : Language (BitVec 1) := { bvs  | bvs.getLast? = some 1 }

def NFA.msbSA (q : msbState) : Language (BitVec 1) :=
  match q with
  | .i => ⊤
  | .f => msbLang

def NFA.msbCorrect : NFA.autMsbSet.correct msbSA msbLang :=

def autMsb_equiv : CNFA.autMsbSet.m.states ≃ NFA'.autMsbSet.σ where
  toFun := fun ⟨s, hs⟩ =>
    match s with
    | 0 => .i
    | 1 => .f
    | _ => .i
  invFun q :=
    match q with
    | .i => ⟨0, by admit /- proof elided -/
    ⟩
    | .f => ⟨1, by admit /- proof elided -/
    ⟩
  left_inv := by admit /- proof elided -/

def WidthPredicate.final? (wp : WidthPredicate) (n : Nat) (s : State) : Bool :=
  decide (wp.sat s n)

def RawCNFA.autWidth (wp : WidthPredicate) (n : Nat) : RawCNFA (BitVec 0) :=
  let m := (n+2).iterate f empty
  let m := m.addInitial 0
  m.addTrans (BitVec.zero 0) (n + 1) (n + 1)
where
  f m :=
    let (s, m) := m.newState
    let m := if wp.final? n s then m.addFinal s else m
    if s > 0 then m.addTrans (BitVec.zero 0) (s-1) s else m

def CNFA.autWidth (wp : WidthPredicate) (n : Nat) : CNFA 0 :=
  ⟨RawCNFA.autWidth wp n, RawCNFA.autWidth_wf⟩

def NFA.autWidth (wp : WidthPredicate) (n : Nat) : NFA (BitVec 0) (Fin (n+2)) where
  start := { 0 }
  accept := { s | wp.final? n s }
  step s₁ _ := { s₂ | if s₁ = Fin.last (n+1) then s₁ = s₂ else s₂ = s₁ + 1 }

def NFA'.autWidth (wp : WidthPredicate) (n : Nat) : NFA' 0 := ⟨_, NFA.autWidth wp n⟩

@[simp]
def NFA'.autWidth_spec : (autWidth wp n).accepts = { bv | wp.sat bv.w n } :=

def autWidth_equiv : (CNFA.autWidth wp n).m.states ≃ (NFA'.autWidth wp n).σ where
  toFun := fun ⟨s, hs⟩ =>
    Fin.mk s (by admit /- proof elided -/
    )
  invFun q := ⟨q.val, by admit /- proof elided -/
  ⟩
  left_inv := by admit /- proof elided -/

end nfas_relations

def Relation.autOfRelation : Relation → CNFA 2
| .eq => CNFA.autEq
| .signed ord => CNFA.autSignedCmp ord
| .unsigned ord => CNFA.autUnsignedCmp ord

def Relation.absAutOfRelation (rel : Relation) : NFA' 2 :=
  match rel with
  | .eq => NFA'.autEq
  | .unsigned cmp => NFA'.autUnsignedCmp cmp
  | .signed cmp => NFA'.autSignedCmp cmp

def unopNfa (op : Unop) (m : CNFA n) : CNFA n :=
  match op with
  | .neg => m.neg

def unopAbsNfa (op : Unop) (M : NFA' n) : NFA' n :=
  match op with
  | .neg => M.neg

def binopNfa (op : Binop) (m1 m2 : CNFA n) : CNFA n :=
  match op with
  | .and => m1.inter m2
  | .or => m1.union m2
  | .impl => m1.neg.union m2
  | .equiv => (m1.neg.union m2).inter (m2.neg.union m1)

def binopAbsNfa (op : Binop) (M1 M2: NFA' n) : NFA' n :=
  match op with
  | .and => M1.inter M2
  | .or => M1.union M2
  | .impl => M1.neg.union M2
  | .equiv => (M1.neg.union M2).inter (M2.neg.union M1)

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

@[simp]
def liftOp_unchanged (k : Fin n) : liftOp n k.castSucc = k.castLE (by simp) :=

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)

@[simp]
def TermBinop.openTerm_arity (op : TermBinop) : op.openTerm.arity + 1 = 3 :=

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

def autOfTermBinop (op : TermBinop) (m₁ : CNFA (n + 1)) (m₂ : CNFA (m + 1)) : CNFA ((n ⊔ m) + 1 ) :=
  let mop : CNFA 3 := op.termGadget
  let f₁ := liftMaxSuccSucc1 n m
  let m1' := m₁.lift f₁
  let f₂ := liftMaxSuccSucc2 n m
  let m2' := m₂.lift f₂
  let mop := mop.lift $ liftLast3 (max (FinEnum.card (Fin n)) (FinEnum.card (Fin m)))
  let m := CNFA.inter m1' m2' |> CNFA.inter mop
  let mfinal := m.proj (liftOp _)
  mfinal.minimize

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

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

def TermUnop.openTerm_arity (op : TermUnop) : op.openTerm.arity = 1 :=

@[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 nfaOfTerm (t : Term) : CNFA (t.arity + 1) :=
  match t with
  | .var n => FSM.ofTerm (.var n) |> CNFA.ofFSM
  | .zero => FSM.ofTerm .zero |> CNFA.ofFSM
  | .negOne => FSM.ofTerm .negOne |> CNFA.ofFSM
  | .one => FSM.ofTerm .one |> CNFA.ofFSM
  | .ofNat n => FSM.ofTerm (.ofNat n) |> CNFA.ofFSM
  | .and t₁ t₂ => autOfTermBinop .and (nfaOfTerm t₁) (nfaOfTerm t₂)
  | .or t₁ t₂ => autOfTermBinop .or (nfaOfTerm t₁) (nfaOfTerm t₂)
  | .xor t₁ t₂ => autOfTermBinop .xor (nfaOfTerm t₁) (nfaOfTerm t₂)
  | .add t₁ t₂ => autOfTermBinop .add (nfaOfTerm t₁) (nfaOfTerm t₂)
  | .sub t₁ t₂ => autOfTermBinop .sub (nfaOfTerm t₁) (nfaOfTerm t₂)
  | .neg t => autOfTermUnop .neg (nfaOfTerm t)
  | .not t => autOfTermUnop .not (nfaOfTerm t)
  | .shiftL t k => autOfTermUnop (.shiftL k) (nfaOfTerm t)

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

def nfaOfFormula (φ : Formula) : CNFA φ.arity :=
  match φ with
  | .width wp n => CNFA.autWidth wp n
  | .atom rel t1 t2 =>
    let m1 := nfaOfTerm t1
    let m2 := nfaOfTerm t2
    let f1 := liftMaxSucc1 (FinEnum.card $ Fin t1.arity) (FinEnum.card $ Fin t2.arity)
    let m1' := m1.lift f1
    let f2 := liftMaxSucc2 (FinEnum.card $ Fin t1.arity) (FinEnum.card $ Fin t2.arity)
    let m2' := m2.lift f2
    let meq := rel.autOfRelation.lift $ liftLast2 (max (FinEnum.card (Fin t1.arity)) (FinEnum.card (Fin t2.arity)))
    let m := CNFA.inter m1' m2' |> CNFA.inter meq
    let mfinal := m.proj (liftExcept2 _)
    mfinal
  | .msbSet t =>
    let m := (termEvalEqFSM t).toFSM |> CNFA.ofFSM
    let mMsb := CNFA.autMsbSet.lift $ fun _ => Fin.last t.arity
    let res := m.inter mMsb
    res.proj $ fun n => n.castLE (by admit /- proof elided -/
    )
  | .unop op φ => unopNfa op (nfaOfFormula φ)
  | .binop op φ1 φ2 =>
    let m1 := (nfaOfFormula φ1).lift $ liftMax1 φ1.arity φ2.arity
    let m2 := (nfaOfFormula φ2).lift $ liftMax2 φ1.arity φ2.arity
    binopNfa op m1 m2

theorem nfaOfFormula_bv_language φ :
    (nfaOfFormula φ).bv_recognizes φ.language :=

:= by
  induction φ
  case width rel n =>
    simp only [nfaOfFormula]
    apply CNFA.autWidth_bv_language
  case atom rel t1 t2 =>
    simp only [nfaOfFormula, Formula.language]
    apply CNFA.proj_bv_language
    ac_nf
    apply CNFA.inter_bv_language
    · apply CNFA.lift_bv_language
      exact CNFA.autOfRelation_bv_language rel
    · apply CNFA.inter_bv_language
      · apply CNFA.lift_bv_language
        exact nfaOfTerm_bv_language t1
      · apply CNFA.lift_bv_language
        exact nfaOfTerm_bv_language t2
  case msbSet t =>
    simp only [nfaOfFormula, Formula.language]
    apply CNFA.proj_bv_language
    apply CNFA.inter_bv_language
    · exact CNFA.ofFSM_bv_language
    · apply CNFA.lift_bv_language
      apply CNFA.autMsbSet_bv_language
  case unop op φ ih =>
    simp only [nfaOfFormula, Formula.language]
    exact unopNfa_bv_language op ih
  case binop op φ₁ φ2 ih₁ ih₂ =>
    simp only [nfaOfFormula, Formula.language]
    apply binopNfa_bv_language op
    · apply CNFA.lift_bv_language; assumption
    · apply CNFA.lift_bv_language; assumption