syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

syntax "false" : imp

syntax "false" : term

syntax "true" : imp

syntax "true" : term

syntax "<{" imp "}>" : term

syntax:30 "{*" term "*}" term "{*" term "*}" : term

syntax "<[" term "]>" : imp

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

macro_rules
  | `(term|$p <<->> $q) => `($p ->> $q ∧ $q ->> $p)

macro_rules
  | `(term|{*$p*} $c {*$q*}) => `(valid_hoare_triple $p $c $q)

x

abbrev x := "x"

beval

def beval (st : State) (b : BExp) : Bool :=
  match b with
  | b_true => true
  | b_false => false
  | b_eq a₁ a₂ => (aeval st a₁) == (aeval st a₂)
  | b_neq a₁ a₂ => (aeval st a₁) != (aeval st a₂)
  | b_le a₁ a₂ => (aeval st a₁) <= (aeval st a₂)
  | b_not b₁ => not (beval st b₁)
  | b_and b₁ b₂ => and (beval st b₁) (beval st b₂)
  | b_or b₁ b₂ => or (beval st b₁) (beval st b₂)

example : aeval (update empty x 5)
    <{3 + x * 2}>

    = 13 := by admit /- proof elided -/

empty

def empty : State := fun _ => 0

State

abbrev State := String → Nat

y

abbrev y := "y"

z

abbrev z := "z"

aeval

def aeval (st : State) (a : AExp) : Nat :=
  match a with
  | a_num n => n
  | a_id x => st x
  | a_plus a₁ a₂ => (aeval st a₁) + (aeval st a₂)
  | a_minus a₁ a₂ => (aeval st a₁) - (aeval st a₂)
  | a_mult a₁ a₂ => (aeval st a₁) * (aeval st a₂)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

Com

inductive Com :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com

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

Imp.Hoare.Assertion

abbrev Assertion := State → Prop

theorem hoare_asgn Q x a :
    {* fun st => Q (st[x ↦ aeval st a]) *} c_asgn x a {* Q *}

theorem hoare_consequence_pre P P' Q c :
    {* P' *} c {* Q *}
    → P ->> P'
    → {* P *} c {* Q *}

import Frap.Trans

namespace Imp

open AExp

open BExp

open Com

open CEval

namespace Hoare

abbrev Assertion := State → Prop

def assert_implies (P Q : Assertion) : Prop :=
  ∀ st, P st → Q st

infix:36 " ->> " => assert_implies

def valid_hoare_triple (P : Assertion) (c : Com) (Q : Assertion) : Prop :=
  ∀ st st', P st → (st =[<[c]>]=> st') → Q st'

theorem hoare_if P Q b c₁ c₂ :
    {* fun st => P st ∧ beval st b *} c₁ {* Q *}
    → {* fun st => P st ∧ ¬(beval st b) *} c₂ {* Q *}
    → {* P *} c_if b c₁ c₂ {* Q *} :=

:= by
  intro hTrue hFalse st st' hPre hEval
  cases hEval
  . -- e_ifTrue
    rename_i hb hc₁
    apply hTrue
    . constructor
      . exact hPre
      . exact hb
    . exact hc₁
  . -- e_ifFalse
    rename_i hb hc₂
    apply hFalse
    . constructor
      . exact hPre
      . simp [hb]
    . exact hc₂

example :
    -- { True }
    {* fun _ => True *}
      <{if x = 0 then y := 2 else y := x + 1 end}>
    -- { x ≤ y }
    {* fun st => st x <= st y *} := by
  apply hoare_if
  . apply hoare_consequence_pre
    . apply hoare_asgn
    . intro st _
      simp [update] at *
      split <;> simp [*]
  . apply hoare_consequence_pre
    . apply hoare_asgn
    . intro st _
      simp [update]
      split
      . simp [*]
      . unfold x
        omega


/-- Construct a `BitVec w` from a number less than `2^w`.

O(1), because we use `Fin` as the internal representation of a bitvector. -/

/-- Interpret a bitvector as a number less than `2^w`.

Hidden.List.reverse

theorem nil_append (as : List α) : nil ++ as = as

theorem cons_append (a : α) (as bs : List α)
        : (cons a as) ++ bs = cons a (as ++ bs)

theorem append_nil (as : List α) : as ++ nil = as

theorem append_assoc (as bs cs : List α)
        : (as ++ bs) ++ cs = as ++ (bs ++ cs)

namespace Hidden

inductive List (α : Type u) where
  | nil  : List α
  | cons : α → List α → List α

namespace List

def reverse {α : Type u} (as : List α) : List α :=
  match as with
  | nil        => nil
  | cons a as' => reverse as' ++ cons a nil

theorem reverse_append {α : Type u} (as bs : List α)
    : reverse (as ++ bs) = reverse bs ++ reverse as :=

:= by
  induction as with
  | nil =>
      rw [nil_append, reverse, append_nil]
  | cons a as' ih =>
      rw [cons_append, reverse, reverse, ih, append_assoc]


Iff

inductive Iff : Prop → Prop → Prop where
  | intro : (a → b) → (b → a) → Iff a b

theorem and_commutative (p q : Prop) : p ∧ q ↔ q ∧ p

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

-- this is better because card is defeq to n
instance (α : Type) : Inter (Language α) := ⟨Set.inter⟩
instance (α : Type) : Union (Language α) := ⟨Set.union⟩

/--
The set of `n`-tuples of bit vectors of an arbitrary width.
-/
structure BitVecs (n : Nat) where
  w : Nat
  bvs : List.Vector (BitVec w) n

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

abbrev BitVecs.empty : BitVecs n := ⟨0, List.Vector.replicate n .nil⟩
abbrev BitVecs.singleton {w : Nat} (bv : BitVec w) : BitVecs 1 := ⟨w, bv ::ᵥ .nil⟩
abbrev BitVecs.pair {w : Nat} (bv1 bv2 : BitVec w) : BitVecs 2 := ⟨w, bv1 ::ᵥ bv2 ::ᵥ .nil⟩

/--
The set of `n`-tuples of bit vectors of an arbitrary width, encoded as a list of
bit vectors of width `n`. The width of the encoded bit vectors is the length of
the list.
-/
abbrev BitVecs' (n : Nat) := List (BitVec n)

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

@[simp]

theorem and_associative (p q r : Prop) : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=

:= by
  constructor
  . intro h
    cases h with
    | intro hpq hr =>
      cases hpq with
      | intro hp hq =>
        apply And.intro
        . exact hp
        . apply And.intro
          . exact hq
          . exact hr
  . intro h
    cases h with
    | intro hp hqr =>
      cases hqr with
      | intro hq hr =>
        apply And.intro
        . apply And.intro
          . exact hp
          . exact hq
        . exact hr

/-
## Rewriting proof terms using previously proven results

Often in our proof, we'll need to use the same tactic sequence as in a prior proof.
Like in software development, duplicating the sequence results in duplicate code and can lead to maintenance problems.
We can refer to an earlier propeosition by simply writing the name of the theorem or lemma of interest.
This is similar to breaking down a large program into functions.

First, if we have a previously proven result, we can apply that result directly in the `apply` tactic.
-/
example (p q : Prop) : p ∧ q ↔ q ∧ p := by
  apply and_commutative

/-
We can even refer to asserted but unproven propositions.
-/
example (p q r : Prop) : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := by
  apply and_associative

/-
For nested proof terms, we can use the `rewrite` tactic, along with a list of identities (equivalences) to apply to the proof goal or a hypothesis.

The syntax here is a bit complicated.
We need to pass a configuration stating which occurrence(s) of the proof term we want to rewrite.
An occurrence is a preorder position within the AST of the proof term, with 1 as the root (the entire proof term).
You might need to do some trial-and-error to get the desired occurrence.
Refer to the pop-up contextual guide for more information.
-/
example (p q r : Prop) : (p ∧ q) ∧ r ↔ (q ∧ p) ∧ r := by
  apply Iff.intro
  . intro h
    rewrite (config := {occs := .pos [2]}) [and_commutative] at h
    assumption
  . intro h
    rewrite (config := {occs := .pos [2]}) [and_commutative] at h
    assumption


syntax num : nexpr

syntax num : nexpr

syntax "if " bexpr " then " com " else " com " fi" : com

macro_rules
| `([nexpr| $n:num]) => `(Expr.num $n)
| `([nexpr| $x:ident]) => `(Expr.var $(Lean.quote x.getId.toString))
| `([bexpr| true]) => `(Expr.bool «true»)
| `([bexpr| false]) => `(Expr.bool «false»)
| `([nexpr| $e1 + $e2]) => `(Expr.add [nexpr| $e1] [nexpr| $e2])
| `([nexpr| $e1 - $e2]) => `(Expr.sub [nexpr| $e1] [nexpr| $e2])
| `([nexpr| $e1 * $e2]) => `(Expr.mul [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:nexpr == $e2]) => `(Expr.eq [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:nexpr < $e2]) => `(Expr.lt [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:nexpr > $e2]) => `(Expr.gt [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:nexpr <= $e2]) => `(Expr.le [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:nexpr >= $e2]) => `(Expr.ge [nexpr| $e1] [nexpr| $e2])
| `([bexpr| $e1:bexpr && $e2]) => `(Expr.and [bexpr| $e1] [bexpr| $e2])
| `([bexpr| $e1:bexpr || $e2]) => `(Expr.or [bexpr| $e1] [bexpr| $e2])
| `([bexpr| ($e)]) => `([bexpr| $e])
| `([nexpr| ($e)]) => `([nexpr| $e])
| `([com| skip]) => `(Com.skip)
| `([com| let $x:ident := $e]) => `(Com.assign $(Lean.quote x.getId.toString) [nexpr| $e])
| `([com| $x:ident := $e]) => `(Com.assign $(Lean.quote x.getId.toString) [nexpr| $e])
| `([com| $c1; $c2]) => `(Com.seq [com| $c1] [com| $c2])
| `([com| if $e then $c1 else $c2 fi]) => `(Com.cond [bexpr| $e] [com| $c1] [com| $c2])
| `([com| while $e do $c od]) => `(Com.while [bexpr| $e] [com| $c])

macro_rules
| `([bexpr| $($t:term)]) => `($t)
| `([nexpr| $($t:term)]) => `($t)
| `([com| $($t:term)]) => `($t)

Com

inductive Com
| assign : String → Expr → Com
| seq : Com → Com → Com
| cond : Expr → Com → Com → Com
| while : Expr → Com → Com
| skip : Com

Expr

inductive Expr
| num : Nat → Expr
| bool : Bool → Expr
| var : String → Expr
| add : Expr → Expr → Expr
| sub : Expr → Expr → Expr
| mul : Expr → Expr → Expr
| eq : Expr → Expr → Expr
| lt : Expr → Expr → Expr
| gt : Expr → Expr → Expr
| le : Expr → Expr → Expr
| ge : Expr → Expr → Expr
| and : Expr → Expr → Expr
| or : Expr → Expr → Expr
deriving Repr, DecidableEq

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

While.WellTyped

theorem WellTyped.ty_some {e ty} : WellTyped e ty → e.ty = some ty

import Hoare.While.Syntax

namespace While

inductive Ty
| num : Ty
| bool : Ty
deriving Repr, DecidableEq

inductive WellTyped : Expr → Ty → Prop
| num : WellTyped (Expr.num _) Ty.num
| bool : WellTyped (Expr.bool _) Ty.bool
| add : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.add e1 e2) Ty.num
| sub : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.sub e1 e2) Ty.num
| mul : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.mul e1 e2) Ty.num
| eq : ∀ e1 e2 t, WellTyped e1 t → WellTyped e2 t →
    WellTyped (Expr.eq e1 e2) Ty.bool
| lt : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.lt e1 e2) Ty.bool
| gt : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.gt e1 e2) Ty.bool
| le : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.le e1 e2) Ty.bool
| ge : ∀ e1 e2, WellTyped e1 Ty.num → WellTyped e2 Ty.num →
    WellTyped (Expr.ge e1 e2) Ty.bool
| and : ∀ e1 e2, WellTyped e1 Ty.bool → WellTyped e2 Ty.bool →
    WellTyped (Expr.and e1 e2) Ty.bool
| or : ∀ e1 e2, WellTyped e1 Ty.bool → WellTyped e2 Ty.bool →
    WellTyped (Expr.or e1 e2) Ty.bool

def Expr.ty : Expr → Option Ty
  | Expr.num _ => Ty.num
  | Expr.bool _ => Ty.bool
  | Expr.add e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .num else none
  | Expr.sub e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .num else none
  | Expr.mul e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .num else none
  | Expr.eq e1 e2 => if e1.ty = e2.ty ∧ e1.ty.isSome then some .bool else none
  | Expr.lt e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .bool else none
  | Expr.gt e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .bool else none
  | Expr.le e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .bool else none
  | Expr.ge e1 e2 => if e1.ty = some .num ∧ e2.ty = some .num then some .bool else none
  | Expr.and e1 e2 => if e1.ty = some .bool ∧ e2.ty = some .bool then some .bool else none
  | Expr.or e1 e2 => if e1.ty = some .bool ∧ e2.ty = some .bool then some .bool else none
  | Expr.var _ => none

theorem WellTyped.some_ty {e ty} : e.ty = some ty → WellTyped e ty :=

:= by
  intro h
  induction e generalizing ty <;> simp_all [Expr.ty]
  case num _ => rw [← h]; exact WellTyped.num
  case bool _ => rw [← h]; exact WellTyped.bool
  case add e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.add e1 e2 ih_e1 ih_e2
  case sub e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.sub e1 e2 ih_e1 ih_e2
  case mul e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.mul e1 e2 ih_e1 ih_e2
  case eq e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'
    match hty : e1.ty with
    | some .num => have hty' := h.1.1.symm; rw [hty] at hty'; exact WellTyped.eq e1 e2 .num (ih_e1 hty') (ih_e2 hty')
    | some .bool => have hty' := h.1.1.symm; rw [hty] at hty'; exact WellTyped.eq e1 e2 .bool (ih_e1 hty') (ih_e2 hty')
    | none => rw [hty] at h; have hc := h.1.2; simp [Option.isSome] at hc
  case lt e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.lt e1 e2 ih_e1 ih_e2
  case gt e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.gt e1 e2 ih_e1 ih_e2
  case le e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.le e1 e2 ih_e1 ih_e2
  case ge e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.ge e1 e2 ih_e1 ih_e2
  case and e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.and e1 e2 ih_e1 ih_e2
  case or e1 e2 ih_e1 ih_e2 =>
    have h' := h.2.symm; subst h'; exact WellTyped.or e1 e2 ih_e1 ih_e2


theorem WellTyped.ty_some {e ty} : WellTyped e ty → e.ty = some ty :=

:=
  by
    intro h
    induction h
    case num => rfl
    case bool => rfl
    case add _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case sub _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case mul _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case eq e1 _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case lt _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case gt _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case le _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case ge _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case and _ _ h1 h2 => simp [Expr.ty, h1, h2]
    case or _ _ h1 h2 => simp [Expr.ty, h1, h2]


While.WellTyped.unique

theorem WellTyped.unique : ∀ {e t1 t2}, WellTyped e t1 → WellTyped e t2 → t1 = t2

import Hoare.While.Syntax

namespace While

inductive Ty
| num : Ty
| bool : Ty
deriving Repr, DecidableEq

theorem WellTyped.not_eq_not_eq_ty {e1 e2 : Expr} {t1 t2 : Ty} :
  WellTyped e1 t1 → WellTyped e2 t2 → t1 ≠ t2 → ∀ t, ¬ (WellTyped (Expr.eq e1 e2) t) :=

:= by
  intro h1 h2 h3 t h4
  cases h4
  · case eq t h1' h2' =>
      have ht1 : t1 = t := WellTyped.unique h1 h1'
      have ht2 : t2 = t := WellTyped.unique h2 h2'
      rw [ht1, ht2] at h3
      contradiction


theorem WellTyped.not_welltyped_not_eq_ty {e1 e2 : Expr} {t : Ty} :
  WellTyped e1 t → ¬ WellTyped e2 t → ∀ t', ¬ (WellTyped (Expr.eq e1 e2) t') :=

:= by
  intro h1 h2 t' h3
  cases h3
  · case eq t' h1' h2' =>
      have ht : t = t' := WellTyped.unique h1 h1'
      apply h2
      rw [ht]
      exact h2'


import Blase.Blase.AutoStructs.Basic
import Blase.Blase.AutoStructs.ForLean
import Blase.AutoStructs.Basic

RawCNFA.statesFinset

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

State

abbrev State := Nat

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

RawCNFA.tr

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

RawCNFA.states

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

RawCNFA.addFinal

def RawCNFA.addFinal (m : RawCNFA A) (s : State) : RawCNFA A :=
  { m with finals := m.finals.insert s }

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

@[aesop 50% unsafe]
theorem Std.HashMap.get?_none_not_mem [BEq K] [LawfulBEq K] [Hashable K] [LawfulHashable K] {m : Std.HashMap K V} {k : K} : m.get? k = none → k ∉ m

@[aesop 50% unsafe]
theorem Std.HashMap.mem_of_getElem? [BEq K] [LawfulBEq K] [Hashable K] [LawfulHashable K] {m : Std.HashMap K V} {k : K} :
    m[k]? = some v → k ∈ m

theorem Std.HashMap.mem_iff_getElem? [BEq K] [LawfulBEq K] [Hashable K] [LawfulHashable K] [Inhabited V] {m : Std.HashMap K V} {k : K} :
     k ∈ m ↔ ∃ v, m[k]? = some v

@[grind =, simp]
lemma addTrans_tr_eq (m : RawCNFA A) [LawfulBEq A] (a : A) (s₁ s₂ : State) :
    (m.addTrans a s₁ s₂).tr s₁ a = (m.tr s₁ a).insert s₂

@[grind =] -- TODO: should I?

@[grind =] -- TODO: should I?
lemma addTrans_tr (m : RawCNFA A) [LawfulBEq A] {a b : A} {s₁ s₁' s₂ : State} :
    (m.addTrans a s₁ s₂).tr s₁' b = if s₁ = s₁' ∧ a = b then (m.tr s₁ a).insert s₂ else m.tr s₁' b

@[grind ., simp, aesop 50% unsafe]
lemma RawCNFA.WF.trans_src_lt'' [LawfulBEq A] {m : RawCNFA A} (hwf : m.WF) :
    ∀ {s a s'}, s' ∈ m.tr s a → s ∈ m.states

@[grind ., simp, aesop 50% unsafe]
lemma RawCNFA.WF.trans_src_lt' {m : RawCNFA A} (hwf : m.WF) :
    ∀ {s a}, (s, a) ∈ m.trans → s ∈ m.states

@[aesop 50% unsafe]
theorem Std.HashMap.getElem?_none_not_mem [BEq K] [LawfulBEq K] [Hashable K] [LawfulHashable K] {m : Std.HashMap K V} {k : K} :
    m[k]? = none → k ∉ m

worklist.St.sim

omit [Fintype S] [LawfulBEq A] in
lemma addOrCreate_preserves_map (st : worklist.St A S) (final? : Bool) (sa sa' : S) :
    let (_, st') := st.addOrCreateState _ _  final? sa'
    st.map[sa]? = some s →
    st'.map[sa]? = some s

omit [Fintype S] [LawfulBEq A] in
lemma processOneElem_preserves_map (st : worklist.St A S) (final : S → Bool) (a : A) (sa sa' : S) (s s' : State) :
    let st' := processOneElem _ _  final s st (a, sa')
    st.map[sa]? = some s' →
    st'.map[sa]? = some s'

omit [LawfulBEq A] [Fintype S] [DecidableEq S] in
lemma addOrCreateElem_visited final? (st : worklist.St A S) sa :
    st.addOrCreateState _ _ final? sa |>.2.visited = st.visited

omit [LawfulBEq A] [Fintype S] [DecidableEq S] in
lemma processOneElem_visited (st : worklist.St A S) :
    let st' := processOneElem _ _  final s st (a, sa')
    st'.visited = st.visited

omit [LawfulBEq A] [Fintype S] in
lemma processOneElem_map (st : worklist.St A S) (final : S → Bool) (a : A) (sa sa' : S) (s : State) :
  (processOneElem A S final s st (a, sa)).map[sa']? =
    match st.map[sa']? with
    | some s => some s
    | none => if sa = sa' then some st.m.stateMax else none

omit [LawfulBEq A] [Fintype S] [DecidableEq S] in
@[simp]
lemma processOneElem_initials (st : worklist.St A S) (final : S → Bool) (a : A) (sa : S) (s : State) :
    (processOneElem A S final s st (a, sa)).m.initials = st.m.initials

omit [LawfulBEq A] [Fintype S] [DecidableEq S] in
lemma processOneElem_finals (st : worklist.St A S) (final : S → Bool) (a : A) (sa : S) (s : State) :
    (processOneElem A S final s st (a, sa)).m.finals =
      if sa ∉ st.map ∧ final sa then st.m.finals.insert st.m.stateMax else st.m.finals

omit [Fintype S] [DecidableEq S] in
lemma processOneElem_tr (st : worklist.St A S) (final : S → Bool) (a b : A) (sa : S) (s s' : State) :
    if a = b ∧ s = s' then
      ∃ ssa, (processOneElem A S final s st (a, sa)).map[sa]? = some ssa ∧
        (processOneElem A S final s st (a, sa)).m.tr s' b =
        (st.m.tr s a |>.insert ssa)
    else
      (processOneElem A S final s st (a, sa)).m.tr s' b = st.m.tr s' b

omit [LawfulBEq A] [Fintype S] in
lemma processOneElem_rel {s₁ s₂ : State} :
    s₂ ~[(processOneElem A S final s₁ st (a, sa)).rel] sa' ↔
      (s₂ ~[st.rel] sa' ∨ (s₂ = st.m.stateMax ∧ sa' = sa ∧ st.map[sa']? = none))

omit [LawfulBEq A] [Fintype S] [LawfulBEq S] [DecidableEq S] in
lemma rel_in_states {st : worklist.St A S} (hinv : StInv A S st.m st.map) :
    s ~[st.rel] sa → s ∈ st.m.states

omit [LawfulBEq A] [Fintype S] in
lemma processOneElem_rel_preserve :
    s₂ ~[st.rel] sa' →
    s₂ ~[(processOneElem A S final s₁ st (a, sa)).rel] sa'

omit [LawfulBEq A] [Fintype S] in
lemma processOneElem_rel_preserve_olds :
    s₂ ~[(processOneElem A S final s₁ st (a, sa)).rel] sa' →
    s₂ ∈ st.m.states → s₂ ~[st.rel] sa'

import Blase.AutoStructs.Basic

open SetRel

section nfa

variable {A : Type} [BEq A] [LawfulBEq A] [Hashable A] [DecidableEq A] [FinEnum A]

variable {S : Type} [Fintype S] [BEq S] [LawfulBEq S] [Hashable S] [DecidableEq S]

variable (inits : Array S) (final : S → Bool) (f : S → Array (A × S))

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

end nfa

section nfa'

variable {S : Type} [Fintype S] [BEq S] [LawfulBEq S] [Hashable S] [DecidableEq S]

variable (inits : Array S) (final : S → Bool) (f : S → Array (BitVec n × S))

end nfa'

section worklist

variable (A : Type) [BEq A] [LawfulBEq A] [Hashable A] [DecidableEq A] [FinEnum A]

variable (S : Type) [Fintype S] [BEq S] [LawfulBEq S] [Hashable S] [DecidableEq S]

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

open List in

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

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 }

      open List in
      have hgrow : ∃ sas, st2.map.keys ~ (sas ++ st1.map.keys) ∧ st2.worklist.toList = st1.worklist.toList ++ sas := by
        rcases a with ⟨al⟩
        unfold st2
        generalize hst1 : st1 = x; clear hst1; revert x
        induction al with
        | nil => simp
        | cons asa al ih =>
          simp; simp at ih; intros st
          let wl' := processOneElem A S final s st asa
          rcases ih wl' with ⟨sas', h1', h2'⟩; clear ih
          rcases processOneElem_grow _ _ st final asa.1 asa.2 s with ⟨sas, h1, h2⟩
          use (sas ++ sas')
          constructor
          { simp [wl'] at h1'; apply list_perm_trick; exact h1'; exact h1 }
          { simp [wl', h2] at h2'; aesop }
      have hincl : ∀ k, k ∈ st1.map → k ∈ st2.map := by
        intros k; rcases hgrow with ⟨sas, hkeys, -⟩;
        have := @(List.perm_subset_iff_right hkeys st1.map.keys).mpr (by aesop) k; aesop
      have : st1.meas < st0.meas := by
        rcases heq' : sa? with ⟨⟩ | ⟨sa⟩
        { simp_all }
        apply Finset.card_lt_card
        simp [Finset.ssubset_iff, Finset.subset_iff]
        use sa
        simp [sa?] at heq'
        constructor
        { constructor
          { apply Array.mem_of_back? at heq'; apply st0.worklist_incl; assumption }
          { apply Array.not_elem_back_pop at heq' <;> simp_all +zetaDelta [Array.pop] } }
        constructor
        { right; apply Array.mem_of_back? at heq'; assumption }
        rintro sa hh; rcases hh with hnin | hin
        { simp +zetaDelta [hnin] }
        right
        exact Array.mem_of_mem_pop st0.worklist sa hin
      have : st2.meas ≤ st1.meas := by
        apply Finset.card_le_card
        simp +zetaDelta [Finset.subset_iff]
        intros sa' h
        rcases h with hnin | hin
        { left; simp [st1] at hincl; intros hc; apply hnin; apply hincl; assumption }
        by_cases hnew : sa' ∈ st0.map
        all_goals try (left; trivial)
        right
        simp [st1] at hgrow
        rcases hgrow with ⟨sas, hkeys2, hwl2⟩
        have hnin : sa'∉ sas := by
          intros hc
          have hdisj : st0.map.keys.Disjoint sas := by
            have : (sas ++ st0.map.keys).Nodup := by
              apply List.Perm.nodup
              assumption
              apply st2.map.keys_nodup
            simp [List.nodup_append_comm, List.disjoint_of_nodup_append, this]
          apply hdisj
          { simp_all [Std.HashMap.mem_keys]; apply hnew }
          { apply hc }
        rcases hin with ⟨hin⟩; simp_all +zetaDelta
      have : st2.meas < st0.meas := by omega
      go st2
    else
      st0.m -- never happens
  | none => st0.m -- never happens
  termination_by st0.meas

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

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'

end worklist

section worklist_correct

variable {A : Type} [BEq A] [LawfulBEq A] [Hashable A] [DecidableEq A] [FinEnum A]

variable {S : Type} [Fintype S] [BEq S] [LawfulBEq S] [Hashable S] [DecidableEq S]

variable (inits : Array S) (final : S → Bool) (f : S → Array (A × S))

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

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

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

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

def processOneElem_inv {st : worklist.St A S} (s : State) (sa : S) (k : ℕ) :
    ∀ a sa', (f sa)[k]? = some (a, sa') →
    processOneElem_mot inits final f s sa k st →
    let st' := processOneElem A S final s st (a, sa')
    StInv A S st'.m st'.map :=

omit [Fintype S] in
lemma processOneElem_spec {st : worklist.St A S} (s : State) (sa : S) (k : ℕ) :
    ∀ a sa', (f sa)[k]? = some (a, sa') →
    processOneElem_mot inits final f s sa k st →
    processOneElem_mot inits final f s sa (k+1) (processOneElem A S final s st (a, sa')) :=

:= by
  intro a sa' hf ⟨hmap, hvisited, inv, hsim⟩
  have hmem : ∀ s (sa : S), st.map[sa]? = some s → s ∈ st.m.states := by intros; apply inv.map_states; assumption
  have hwf : st.m.WF := by apply inv.wf
  have inv' := processOneElem_inv inits final f s sa k a sa' hf ⟨hmap, hvisited, inv, hsim⟩
  unfold processOneElem_mot
  constructor
  (rw [processOneElem_preserves_map]; assumption)
  constructor
  (rw [processOneElem_visited]; exact hvisited)
  use inv'; constructor
  { rw [processOneElem_finals]
    rintro s' q hR
    have hs' : s ∈ st.m.states := by apply hmem <;> assumption
    rw [processOneElem_rel] at hR
    rcases hR with hR | ⟨rfl, rfl, heq⟩
    · have heq := rel_in_states inv hR
      split_ifs with hcond
      · have hneq : st.m.stateMax ≠ s' := by rintro rfl; simp [RawCNFA.states] at heq
        simp [hneq]
        apply hsim.accept; assumption
      · apply hsim.accept; assumption
    · split_ifs with h
      · rcases h with ⟨_, hfin⟩
        simp [nfa, hfin]
      · simp [nfa]
        suffices hnin : q ∉ st.map by
          push_neg at h; specialize h hnin; simp_all
          rintro hc; apply hwf.finals_lt at hc; simp at hc
        exact Std.HashMap.getElem?_none_not_mem heq }
  { rintro s₁ hs₁; rw [processOneElem_initials] at hs₁
    obtain ⟨q, hq, hR⟩ := hsim.initial₁ hs₁
    use q, hq, processOneElem_rel_preserve final hR }
  { intros q hq; obtain ⟨s, hs, hR⟩ := hsim.initial₂ hq
    simp only [processOneElem_initials]
    use s, hs, (by exact processOneElem_rel_preserve final hR) }
  { rintro s₁ s₂ b q₁ hR htr
    have h := processOneElem_tr st final a b sa' s s₁
    split_ifs at h with hcond
    on_goal 2 => {
      rw [h] at htr
      apply processOneElem_rel_preserve_olds at hR
      specialize hR (RawCNFA.WF.trans_src_lt'' hwf htr)
      obtain ⟨q₂, hst, hrel⟩ := hsim.trans_match₁ hR htr
      use q₂; simp only [hst, true_and]
      exact processOneElem_rel_preserve final hrel }
    rcases hcond with ⟨rfl, rfl⟩
    rcases h with ⟨sₙ, hmap', htr'⟩
    rw [htr'] at htr; clear htr'
    simp only [Std.HashSet.mem_insert, beq_iff_eq] at htr
    rcases htr with rfl | htr
    on_goal 2 =>
      have hold := RawCNFA.WF.trans_src_lt'' hwf htr
      obtain ⟨q₂, hst, hrel⟩ := hsim.trans_match₁
        (by apply processOneElem_rel_preserve_olds final hR hold) htr
      use q₂, hst, processOneElem_rel_preserve final hrel
    use sa'; constructor
    · suffices heq : q₁ = sa by
        subst heq; apply Array.mem_of_getElem? hf
      apply processOneElem_preserves_map at hmap
      unfold worklist.St.rel at hR
      apply inv'.map_inj hR hmap
    · exact hmap' }
  { rintro s₁ b q₁ q₂ hR hs hD hnT
    simp only [ge_iff_le, Prod.mk.eta, Set.mem_setOf_eq, not_and, not_exists] at hnT
    have h := processOneElem_tr st final a b sa' s s₁
    split_ifs at h with hcond
    on_goal 2 =>
      have hR' : s₁ ~[st.rel] q₁ := by
        rw [processOneElem_rel] at hR; rcases hR with hR' | ⟨_, _, hnone⟩; exact hR'
        unfold worklist.St.D at hD; rw [processOneElem_visited] at hD
        rcases hD with ⟨hnin, -⟩
        apply Std.HashMap.getElem?_none_not_mem at hnone
        contradiction
      obtain ⟨s₂, hs', hR⟩ := hsim.trans_match₂ hR' hs
        (by simp_all [worklist.St.D, processOneElem_visited])
        (by simp; rintro rfl i hi hc
            by_cases heq: k = i
            · subst heq; apply hcond; constructor
              · simp [hc] at hf; simp [hf]
              · rw [hR'] at hmap; simp at hmap; exact hmap.symm
            · apply hnT rfl _ (by omega) hc)
      use s₂; simp only [h, hs', true_and]
      apply processOneElem_rel_preserve; assumption
    rcases hcond with ⟨rfl, rfl⟩
    rcases h with ⟨sₙ, hmap', htr'⟩
    obtain rfl : sa = q₁ := by
      apply processOneElem_preserves_map at hmap
      apply inv'.map_inj hmap hR
    simp only [htr', Std.HashSet.mem_insert, beq_iff_eq]
    by_cases heq : sa' = q₂
    · subst heq; use sₙ; simp only [true_or, true_and]; exact hmap'
    · have hold := hmem _ _ hmap
      apply processOneElem_rel_preserve_olds at hR
      obtain ⟨s₂, hs', hR⟩ := hsim.trans_match₂ (hR hold) hs
        (by simp_all [worklist.St.D, processOneElem_visited])
        (by simp; rintro i hi hc
            have _ : i ≠ k := by rintro rfl; simp_all
            apply hnT rfl i (by omega) hc)
      use s₂; simp only [hs', or_true, true_and]
      apply processOneElem_rel_preserve; assumption }


lemma formula_language_case_atom :
    let φ := Formula.atom rel t1 t2
    φ.language = λ (bvs : BitVecs φ.arity) => φ.sat (fun k => bvs.bvs.get k)

syntax "max" : MLIR.Pretty.uniform_op

syntax "max" : 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) )

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

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

BitVecs

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

WidthPredicate

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

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)

BitVec.ofFn

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

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

Valuation.cons

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

BitVecs.cast

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

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

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

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

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

Unop

inductive Unop
| neg
deriving Repr

Formula.language

lemma evalFin_eq {t : Term} {vars1 : Fin t.arity → BitVec w1} {vars2 : Fin t.arity → BitVec w2} :
    ∀ (heq : w1 = w2),
    (∀ n, vars1 n = heq ▸ vars2 n) →
    t.evalFinBV vars1 = heq ▸ t.evalFinBV vars2

@[simp]
lemma evalRelation_coe (rel : Relation) (bv1 bv2 : BitVec w1) (heq : w1 = w2) :
    evalRelation rel (heq ▸ bv1) (heq ▸ bv2) = evalRelation rel bv1 bv2

lemma helper1 : (k = 0) → (x ::ᵥ vs).get k = x

lemma helper2 : (k = 1) → (x ::ᵥ y ::ᵥ vs).get k = y

import Blase.AutoStructs.ForMathlib

import Blase.SingleWidth.Defs

open Fin.NatCast

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 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 liftLast2 n : Fin 2 → Fin (n + 2)
| 0 => n
| 1 => Fin.last (n + 1)

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

def liftMax1 (n m : Nat) : Fin n → Fin (max n m) :=
  fun k => 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 -/
  )

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

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 }

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

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

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

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

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

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

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)

inductive Unop
| neg
deriving Repr

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

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

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

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

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

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

:= Formula.atom rel t1 t2
    φ.language = λ (bvs : BitVecs φ.arity) => φ.sat (fun k => bvs.bvs.get k) := by
  unfold Formula.language
  rintro φ
  let n := φ.arity
  unfold φ
  dsimp (config := { zeta := false })
  lift_lets
  intros l1 l2 lrel l
  ext bvs
  constructor
  · intros h; simp at h
    obtain ⟨bvsb, h, heqb⟩ := h
    unfold l at h
    simp at h
    unfold lrel l1 l2 at h
    obtain ⟨⟨hrel, h1⟩, h2⟩ := h
    have _ : n+1 < bvsb.bvs.length := by simp +zetaDelta
    have _ : n < bvsb.bvs.length := by simp +zetaDelta
    have hrel : evalRelation rel (bvsb.bvs.get n) (bvsb.bvs.get (Fin.last (n + 1))) := by
      simp at hrel
      apply hrel
    have ht1 : bvsb.bvs.get n = t1.evalFinBV fun n => bvsb.bvs.get n := by
      unfold Term.language at h1
      simp [liftMaxSucc1] at h1
      unfold n; simp +zetaDelta; rw [←h1]
      congr; ext1 k
      congr; ext; simp; rw [Nat.mod_eq_of_lt]; omega
    have ht2 : bvsb.bvs.get (Fin.last (n+1)) = t2.evalFinBV fun n => bvsb.bvs.get n := by
      unfold Term.language at h2
      simp [liftMaxSucc2] at h2
      unfold n; simp +zetaDelta only [Formula.arity]; rw [←h2]
      congr; ext1 k
      congr; ext; simp; rw [Nat.mod_eq_of_lt]; omega
    have hw : bvsb.w = bvs.w := by rw [←heqb]; simp
    have heq1 : (t1.evalFinBV fun n => bvsb.bvs.get n) =
        hw ▸ t1.evalFinBV fun n => bvs.bvs.get $ n.castLE (by simp) := by
      apply evalFin_eq hw; intros k
      rcases bvs with ⟨w, bvs⟩; rcases hw
      injection heqb with _ heqb; rw [←heqb]
      simp [List.Vector.transport, liftExcept2]
      congr; ext; simp; omega
    have heq2 : (t2.evalFinBV fun n => bvsb.bvs.get n) =
        hw ▸ t2.evalFinBV fun n => bvs.bvs.get $ n.castLE (by simp) := by
      apply evalFin_eq hw; intros k
      rcases bvs with ⟨w, bvs⟩; rcases hw
      injection heqb with _ heqb; rw [←heqb]
      simp [List.Vector.transport, liftExcept2]
      congr; ext; simp; omega
    rw [ht1, ht2, heq1, heq2, evalRelation_coe] at hrel
    dsimp only [Set.instMembership, Set.Mem]
    simp_all
  · intros h
    simp
    let bv1 := t1.evalFinBV fun k => bvs.bvs.get $ k.castLE (by simp)
    let bv2 := t2.evalFinBV fun k => bvs.bvs.get $ k.castLE (by simp)
    use ⟨bvs.w, bvs.bvs ++ bv1 ::ᵥ bv2 ::ᵥ List.Vector.nil⟩
    rcases bvs with ⟨w, bvs⟩
    simp
    constructor
    · unfold l; simp; split_ands
      · unfold lrel; simp only [Fin.isValue, BitVecs.transport_getElem,
          liftLast2, Set.mem_setOf_eq, Fin.val_last, le_add_iff_nonneg_right, zero_le,
          List.Vector.append_get_ge]
        rw [List.Vector.append_get_ge (by dsimp; rw [Nat.mod_eq_of_lt]; omega)]
        simp [Set.instMembership, Set.Mem] at h
        convert h using 2
        · apply helper1; ext; simp; rw [Nat.mod_eq_of_lt] <;> omega
        · apply helper2; ext; simp
      · unfold l1 Term.language; simp [liftMaxSucc1]
        rw [List.Vector.append_get_ge (by dsimp; rw [Nat.mod_eq_of_lt]; omega)]
        rw [helper1 (by ext; simp; rw [Nat.mod_eq_of_lt] <;> omega)]
        unfold bv1
        congr;
      · unfold l2 Term.language; simp [liftMaxSucc2]
        rw [helper2 (by ext; simp)]
        unfold bv2
        congr
    · ext1; simp
      next i =>
        simp [liftExcept2]
        rw [List.Vector.append_get_lt i.isLt]
        congr 1


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

syntax "xor" : MLIR.Pretty.uniform_op

syntax "xor" : MLIR.Pretty.uniform_op

syntax "max" : 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) )

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

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)

BitStream

def BitStream : Type := Nat → Bool

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

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)

BitVecs

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

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)

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

Term.language

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

Formula.arity

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

Term.evalFinBV

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

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

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

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

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

ext

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

swapLastTwoBlock

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

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

section fsm

variable {arity : Type} [FinEnum arity]

open BitStream in

end fsm

section nfas_relations

end nfas_relations

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

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

:= 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 _)
    := by
  simp [Term.language]
  ext bvs
  simp
  constructor
  · rintro heq
    let bvs' := bvs.bvs ++
                  (t₁.evalFinBV (λ n ↦ bvs.bvs.get n) ::ᵥ t₂.evalFinBV (λ n ↦ bvs.bvs.get n) ::ᵥ List.Vector.nil)
                |>.transport swapLastTwoBlock
    use ⟨_, bvs'⟩
    simp [bvs']
    split_ands
    · rw [liftMaxSuccSucc1]; simp
      conv =>
        enter [1, 2, n]
        rw [List.Vector.append_get_lt (by rcases n with ⟨n, hn⟩; simp_all; rw [Nat.mod_eq_of_lt (by omega)]; omega)]
        rfl

      rw [List.Vector.append_get_ge]
      on_goal 2 => apply Nat.le_of_eq; simp [Fin.add_def]; rw [Nat.mod_eq_of_lt (by omega)]

      generalize_proofs h₁ h₂ h₃ h₄
      have heq h : Fin.subNat (t₁.arity ⊔ t₂.arity + 1) (Fin.cast h₄ (↑(t₁.arity ⊔ t₂.arity) + 1)) h = 0 := by
         ext; simp [Fin.add_def]; rw [Nat.mod_eq_of_lt (by omega)]; omega
      simp [heq]
      congr; ext1 i; congr 1
      rcases i with ⟨i, hi⟩; simp [Fin.castLT]; ext; simp; repeat rw [Nat.mod_eq_of_lt (by omega)]
    · rw [liftMaxSuccSucc2]; simp
      conv =>
        enter [1, 2, n]
        rw [List.Vector.append_get_lt (by rcases n with ⟨n, hn⟩; simp_all; rw [Nat.mod_eq_of_lt (by omega)]; omega)]
        rfl
      generalize_proofs h₁ h₂ h₃ h₄
      have heq h : Fin.subNat (t₁.arity ⊔ t₂.arity + 1) (Fin.last (2 + t₁.arity ⊔ t₂.arity)) h = 1 := by
         ext; simp; omega
      simp [heq]
      congr; ext1 i; congr 1
      rcases i with ⟨i, hi⟩; simp [Fin.castLT]; ext; simp; repeat rw [Nat.mod_eq_of_lt (by omega)]
    · rw [BitVecs.cast_eq] at *
      simp [BitVecs.cast] at *
      rw [liftLast3]
      simp
      rw [List.Vector.append_get_lt (by simp; rw [Nat.mod_eq_of_lt (by omega)]; omega)]
      convert heq using 1
      have h n : n + 1 < n + 3 := by omega
      have h' n m k : n < m → n < (k ⊔ m) + 1 := by omega
      · cases op <;>
        · simp [openTerm, subst, liftLast3]; congr
          · rw [List.Vector.append_get_ge]
            · simp [Fin.subNat, Fin.add_def]; simp [Nat.mod_eq_of_lt, h]; congr! with ⟨n, hn⟩; ext; simp; omega
            · rw [Fin.add_def]; simp; rw [Nat.mod_eq_of_lt (by omega)]
          · have heq h : (Fin.subNat (t₁.arity ⊔ t₂.arity + 1) (Fin.last (2 + t₁.arity ⊔ t₂.arity)) h) = 1 := by
              simp [Fin.subNat]; omega
            simp [heq, List.Vector.get]; congr; ext1 ⟨i, hi⟩; simp; simp [Nat.mod_eq_of_lt (h' _ _ t₁.arity hi)]
      · congr!; simp [Fin.castLT, Fin.last]; omega
    · ext1
      · simp
      next i =>
        simp [liftOp]
        split_ifs with h
        · subst h
          simp
          rw [List.Vector.append_get_lt]
          on_goal 2 =>
            simp +arith
            repeat (rw [Nat.mod_eq_of_lt (by omega)])
            omega
          congr; ext; simp +arith
          omega
        · simp [h]
          rw [List.Vector.append_get_lt (by rcases i; simp_all [Fin.last]; rw [Nat.mod_eq_of_lt (by omega)]; omega)]
          rcases i with ⟨i, hi⟩; congr!; simp_all; omega
  · rintro ⟨bvs', ⟨⟨⟨heq₁, heq₂⟩, heq₃⟩, heq₄⟩⟩
    rw [BitVecs.cast_eq] at *
    simp [BitVecs.cast] at *
    rw [←heq₄]
    conv_rhs =>
      simp
      simp [liftOp]
      rfl
    simp [liftMaxSuccSucc1, liftMaxSuccSucc2] at heq₁ heq₂
    rw [liftLast3] at heq₃
    convert heq₃ using 1
    have h₁ : (t₁.evalFinBV fun i => bvs'.bvs.get (liftOp (t₁.arity ⊔ t₂.arity) (Fin.castLE (by omega) i).castSucc)) =
                  bvs'.bvs.get (liftLast3 (t₁.arity ⊔ t₂.arity) 0) := by
      simp only [liftOp_unchanged, Fin.castLE_castLE, liftLast3]; convert heq₁ using 1
    have h₂ : (t₂.evalFinBV fun i => bvs'.bvs.get (liftOp (t₁.arity ⊔ t₂.arity) (Fin.castLE (by omega) i).castSucc)) =
                  bvs'.bvs.get (liftLast3 (t₁.arity ⊔ t₂.arity) 1) := by
      simp only [liftOp_unchanged, Fin.castLE_castLE, liftLast3]; convert heq₂
    rcases op with _ | _ | _ <;>
    . simp [subst, openTerm] at *; congr


import Blase.SingleWidth.Defs
import Mathlib.Data.Fin.Basic
import Mathlib.Data.Bool.Basic
import Blase.Fast.BitStream
import Blase.Blase.Fast.BitStream

syntax "slt" : MLIR.Pretty.uniform_op

syntax "slt" : 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) )

BitStream

def BitStream : Type := Nat → Bool

borrow

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

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

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

scanOr

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

falseIffNeq

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

falseIffLt

abbrev falseIffLt (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

falseIffLe

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

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

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

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)

map

abbrev map (f : Bool → Bool) : BitStream → BitStream :=
  fun x i => f (x i)

ofBitVecSext

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

Term.denote

def Term.denote (w : Nat) (t : Term) (vars : List (BitVec w)) : BitVec w :=
  match t with
  | ofNat n => BitVec.ofNat w n
  | var n => vars.getD n default
  | zero => 0#w
  | negOne => -1#w
  | one  => 1#w
  | and a b => (a.denote w vars) &&& (b.denote w vars)
  | or a b => (a.denote w vars) ||| (b.denote w vars)
  | xor a b => (a.denote w vars) ^^^ (b.denote w vars)
  | not a => ~~~ (a.denote w vars)
  | add a b => (a.denote w vars) + (b.denote w vars)
  | sub a b => (a.denote w vars) - (b.denote w vars)
  | neg a => - (a.denote w vars)

  | shiftL a n => (a.denote w vars) <<< n

Predicate.denote

def Predicate.denote (p : Predicate) (w : Nat) (vars : List (BitVec w)) : Prop :=
  match p with
  | .width .ge k => k ≤ w
  | .width .gt k => k < w
  | .width .le k => w ≤ k
  | .width .lt k => w < k
  | .width .neq k => w ≠ k
  | .width .eq k => w = k
  | .binary .eq t₁ t₂ => t₁.denote w vars = t₂.denote w vars
  | .binary .neq t₁ t₂ => t₁.denote w vars ≠ t₂.denote w vars
  | .binary .sle  t₁ t₂ => ((t₁.denote w vars).sle (t₂.denote w vars)) = true
  | .binary .slt  t₁ t₂ => ((t₁.denote w vars).slt (t₂.denote w vars)) = true
  | .binary .ule  t₁ t₂ => ((t₁.denote w vars).ule (t₂.denote w vars)) = true
  | .binary .ult  t₁ t₂ => (t₁.denote w vars).ult (t₂.denote w vars) = true
  | .land  p q => p.denote w vars ∧ q.denote w vars
  | .lor  p q => p.denote w vars ∨ q.denote w vars

WidthPredicate

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

toBitVec

def toBitVec (w : Nat) (x : BitStream) : BitVec w :=
  match w with
  | 0   => 0#0
  | w+1 => (x.toBitVec w).cons (x w)

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

concat

def concat (b : Bool) (x : BitStream) : BitStream
  | 0   => b
  | i+1 => x i

sub

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

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)

@[simp] theorem subAux_eq_BitVec_carry (a b : BitStream) (w i : Nat) (hi : i < w) :
    (a.subAux b i).2 = !(BitVec.carry (i + 1) (a.toBitVec w) ((~~~b).toBitVec w) true)

theorem scanOr_true_iff (s : BitStream) (n : Nat)
    : s.scanOr n = true ↔ ∃ (i : Nat), (i ≤ n) ∧ s i = true

theorem scanOr_false_iff (s : BitStream) (n : Nat) : s.scanOr n = false ↔ ∀ (i : Nat), (hi : i ≤ n) → s i = false

@[simp]
theorem scanOr_succ (s : BitStream) : scanOr s (n+1) = ((s.scanOr n) || s (n + 1))

theorem scanAnd_true_iff (s : BitStream) (n : Nat) :
    s.scanAnd n = true ↔ ∀ (i : Nat), (hi : i ≤ n) → s i = true

@[simp] theorem scanAnd_succ (s : BitStream) : scanAnd s (n+1) = ((s.scanAnd n) && s (n + 1))

theorem scanAnd_false_iff (s : BitStream) (n : Nat)
    : s.scanAnd n = false ↔ ∃ (i : Nat), (i ≤ n) ∧ s i = false

@[simp] theorem and_eq : (x &&& y) i = (x i && y i)

@[simp] theorem getLsbD_toBitVec (w : Nat) (x : BitStream) :
    (x.toBitVec w).getLsbD i = ((decide (i < w)) && x i)

@[simp] theorem xor_eq : (x ^^^ y) i = (xor (x i) (y i))

Predicate.eval

@[simp] theorem Term.eval_eq_denote (t : Term) (w : Nat) (vars : List (BitVec w)) :
    (t.eval (vars.map BitStream.ofBitVecSext)).toBitVec w = t.denote w vars

theorem Term.eval_eq_denote_apply (t : Term) {w : Nat} {vars : List (BitVec w)}
    {i : Nat} (hi : i < w) :
    (t.eval (vars.map BitStream.ofBitVecSext)) i = (t.denote w vars).getLsbD i

theorem Predicate.evalEq_denote_false_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalEq (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = false ↔
    Term.denote w a vars = Term.denote w b vars

theorem Predicate.evalEq_iff_not_evalNeq (a b : BitStream) :
    ∀ (w : Nat), evalEq a b w ↔ ¬ (evalNeq a b w)

theorem Predicate.evalNeq_denote {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalNeq (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = false ↔
    Term.denote w a vars ≠ Term.denote w b vars

theorem Predicate.evalEq_denote_true_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalEq (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = true ↔
    Term.denote w a vars ≠ Term.denote w b vars

private theorem BitVec.lt_eq_decide_ult {x y : BitVec w} : (x < y) = decide (x.ult y)

theorem Predicate.evalUlt_denote_false_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalUlt (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = false ↔
    (Term.denote w a vars < Term.denote w b vars)

theorem Predicate.evalUlt_denote_true_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalUlt (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = true ↔
      (Term.denote w b vars) ≤ (Term.denote w a vars)

private theorem evalMsbEq_denote_false_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    Predicate.evalMsbEq (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = false ↔
   ((Term.denote w a vars).msb = (Term.denote w b vars).msb)

private theorem evalMsbEq_denote_true_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    Predicate.evalMsbEq (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = true ↔
   ((Term.denote w a vars).msb ≠ (Term.denote w b vars).msb)

theorem eq_true_iff_of_eq_false_iff (b : Bool) (rhs : Prop) (h : (b = false) ↔ rhs) :
    (b = true) ↔ ¬ rhs

private theorem Predicate.evalSlt_denote_false_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalSlt (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = false ↔
    (Term.denote w a vars).slt (Term.denote w b vars)

private theorem Predicate.evalSlt_denote_true_iff {w : Nat} (a b : Term) (vars : List (BitVec w)) :
    evalSlt (a.eval (List.map .ofBitVecSext vars)) (b.eval (List.map .ofBitVecSext vars)) w = true ↔
    ¬ (Term.denote w a vars).slt (Term.denote w b vars)

private theorem BitVec.ForLean.ule_iff_ult_or_eq' (x y : BitVec w) : (x.ule y) = (decide (x = y ∨ x < y))

private theorem BitVec.sle_iff_slt_or_eq (x y : BitVec w) : x.sle y ↔ (decide (x = y) ∨ x.slt y)

theorem BitVec.ult_notation_eq_decide_ult (x y : BitVec w) : (x.ult y) = decide (x < y)

import Mathlib.Data.Bool.Basic

import Mathlib.Data.Fin.Basic

import Blase.Fast.BitStream

import Blase.SingleWidth.Defs

open Term

open BitStream in

def Term.eval (t : Term) (vars : List BitStream) : BitStream :=
  match t with
  | var n       => vars.getD n default
  | zero        => BitStream.zero
  | one         => BitStream.one
  | negOne      => BitStream.negOne
  | ofNat n     => BitStream.ofNat n
  | and t₁ t₂   => (t₁.eval vars) &&& (t₂.eval vars)
  | or t₁ t₂    => (t₁.eval vars) ||| (t₂.eval vars)
  | xor t₁ t₂   => (t₁.eval vars) ^^^ (t₂.eval vars)
  | not t       => ~~~(t.eval vars)
  | add t₁ t₂   => (Term.eval t₁ vars) + (Term.eval t₂ vars)
  | sub t₁ t₂   => (Term.eval t₁ vars) - (Term.eval t₂ vars)
  | neg t       => -(Term.eval t vars)

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

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

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

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

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

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

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

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

open BitStream in

def Predicate.eval (p : Predicate) (vars : List 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
  | lor p q => Predicate.evalLor (p.eval vars) (q.eval vars)
  | land p q => Predicate.evalLand (p.eval vars) (q.eval vars)
  | binary .eq t₁ t₂ => Predicate.evalEq (t₁.eval vars) (t₂.eval vars)

  | binary .neq t1 t2 => Predicate.evalNeq (t1.eval vars) (t2.eval vars)
  | binary .ult t₁ t₂ => Predicate.evalUlt (t₁.eval vars) (t₂.eval vars)
  | binary .ule t₁ t₂ =>
     Predicate.evalLor
       (Predicate.evalEq (t₁.eval vars) (t₂.eval vars))
       (Predicate.evalUlt (t₁.eval vars) (t₂.eval vars))
  | binary .slt t₁ t₂ => Predicate.evalSlt (t₁.eval vars) (t₂.eval vars)
  | binary .sle t₁ t₂ => Predicate.evalLor
       (Predicate.evalEq (t₁.eval vars) (t₂.eval vars))
       (Predicate.evalSlt (t₁.eval vars) (t₂.eval vars))

section Predicate

end Predicate

theorem Predicate.eval_eq_denote (w : Nat) (p : Predicate) (vars : List (BitVec w)) :
    (p.eval (vars.map .ofBitVecSext) w = false) ↔ p.denote w vars :=

:= by
  induction p generalizing vars w
  case width wp n => cases wp <;> simp [eval, denote]
  case binary p a b =>
    cases p with
    | eq => simp [eval, denote]; apply evalEq_denote_false_iff
    | neq => simp [eval, denote]; apply evalNeq_denote
    | ult =>
      simp [eval, denote]
      rw [BitVec.ult_notation_eq_decide_ult]
      by_cases h: Term.denote w a vars < Term.denote w b vars
      case pos => simp only [h, decide_true, Bool.not_true]; rw [evalUlt_denote_false_iff]; exact h
      case neg => simp only [h, decide_false, Bool.not_false]; rw [evalUlt_denote_true_iff]; simpa using h
    | slt =>
      simp [eval, denote];
      by_cases h : (Term.denote w a vars).slt (Term.denote w b vars)
      · rw [h]
        simp [Predicate.evalSlt_denote_false_iff, h]
      · simp at h
        rw [h]
        simp only [Bool.not_false]
        by_contra h'
        simp only [Bool.not_eq_true] at h'
        rw [Predicate.evalSlt_denote_false_iff] at h'
        simp only [h, Bool.false_eq_true] at h'
    | ule =>
      simp [eval, denote];
      simp only [evalLor, BitStream.and_eq]
      rw [BitVec.ForLean.ule_iff_ult_or_eq' (Term.denote w a vars) (Term.denote w b vars)]
      by_cases heq : Term.denote w a vars = Term.denote w b vars
      · rw [heq]
        simp [evalEq_denote_false_iff a b vars |>.mpr heq]
      · simp [heq]
        by_cases hlt : Term.denote w a vars < Term.denote w b vars
        · simp [hlt]
          simp [evalUlt_denote_false_iff a b vars |>.mpr hlt]
        · simp [hlt]
          have := evalEq_denote_false_iff a b vars |>.not |>.mpr heq
          simp only [this, true_and]
          have := evalUlt_denote_false_iff a b vars |>.not |>.mpr hlt
          simp only [this]
    | sle =>
      simp [eval, denote]
      simp only [evalLor, BitStream.and_eq]
      have h := BitVec.sle_iff_slt_or_eq (Term.denote w a vars) (Term.denote w b vars) |>.eq
      rcases hSle : (Term.denote w a vars).sle (Term.denote w b vars)
      · simp [hSle] at h ⊢
        obtain ⟨h₁, h₂⟩ := h
        simp [evalEq_denote_true_iff .. |>.mpr h₁]
        rw [evalSlt_denote_true_iff .. |>.mpr]
        simp [h₂]
      · simp [hSle] at h ⊢
        intros hEq
        simp [evalEq_denote_true_iff .. |>.mp hEq] at h
        apply evalSlt_denote_false_iff .. |>.mpr h
  case land p q hp hq => simp [eval, denote, hp, hq, evalLand]
  case lor p q hp hq =>
    simp [eval, denote]
    simp only [evalLor, BitStream.and_eq]
    constructor
    · intros heval
      by_cases hp' : p.denote w vars
      · simp [hp']
      · by_cases hq' : q.denote w vars
        · simp [hq']
        · have := hp .. |>.not |>.mpr hp'
          simp [this] at heval
          have := hq .. |>.not |>.mpr hq'
          simp [this] at heval
    · intros hdenote
      rcases hdenote with hp' | hq'
      · have := hp .. |>.mpr hp'
        simp [this]
      · have := hq .. |>.mpr hq'
        simp [this]


import Blase.SingleWidth.Defs
import Mathlib.Data.Fin.Basic
import Blase.Fast.BitStream
import Mathlib.Data.Bool.Basic

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

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

import Mathlib.Data.Bool.Basic

import Mathlib.Data.Fin.Basic

import Blase.Fast.BitStream

import Blase.SingleWidth.Defs

open Term

open BitStream in

open BitStream in

section Predicate

end Predicate

theorem eq_true_iff_of_eq_false_iff (b : Bool) (rhs : Prop) (h : (b = false) ↔ rhs) :
    (b = true) ↔ ¬ rhs :=

:= by
constructor
· intros h'
  apply h.not.mp
  simp [h']
· intros h'
  by_contra hcontra
  simp at hcontra
  have := h.mp hcontra
  exact h' this


syntax "llvm.and"     : MLIR.Pretty.uniform_op

syntax "llvm.ashr"    : MLIR.Pretty.exact_op

syntax "llvm.add"     : MLIR.Pretty.overflow_op

syntax "llvm.return"  : MLIR.Pretty.uniform_op

syntax "return" : MLIR.Pretty.uniform_op

macro_rules

  | `(mlir_op| $v:mlir_op_operand = mod_arith.constant $x:neg_num : $t) =>
    `(mlir_op| $v:mlir_op_operand = "mod_arith.constant" () {value = $x:neg_num} : () -> ($t))

  | `(mlir_op| $v:mlir_op_operand = mod_arith.constant ${ $x:term } : $t) => do
      let ctor := mkIdent ``MLIR.AST.AttrValue.int
      let x ← `($ctor $x [mlir_type| i64])
      `(mlir_op| $v:mlir_op_operand = "mod_arith.constant" () {value = $$($x)} : () -> ($t))

macro_rules
  | `(mlir_op| $resName:mlir_op_operand = $name:InstCombine.cmp_op_name $x, $y $[: $t]?) => do
    let some opName := extractOpName name.raw
      | Macro.throwUnsupported
    let t ← t.getDM `(mlir_type| _)
    `(mlir_op| $resName:mlir_op_operand = $opName ($x, $y) : ($t, $t) -> (i1) )

macro_rules
  | `(mlir_op| $resName:mlir_op_operand = $name:InstCombine.int_cast_op $x : $t to $t') => do
    let some opName := extractOpName name.raw
      | Macro.throwUnsupported
    `(mlir_op| $resName:mlir_op_operand = $opName ($x) : ($t) -> $t')

macro_rules
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant( $x $[: $inner_type]?)
      $[: $outer_type]? ) => do

      let outer_type ← outer_type.getDM `(mlir_type| _)
      let inner_type := inner_type.getD outer_type
      `(mlir_op| $res:mlir_op_operand = "llvm.mlir.constant"()
          {value = $x:neg_num : $inner_type} : () -> ($outer_type) )
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant( ${ $x:term }) $[: $t]?) => do
      let t ← t.getDM `(mlir_type| _)
      let x ← `(MLIR.AST.AttrValue.int $x [mlir_type| $t])
      `(mlir_op| $res:mlir_op_operand = "llvm.mlir.constant"() {value = $$($x) } : () -> ($t) )

macro_rules
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant (true) $[: $t]?) =>
      `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant (1 : i1) : i1)
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant (false) $[: $t]?) =>
      `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant (0 : i1) : i1)
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant $x $[: $t]?) =>
      `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant($x $[: $t]?) $[: $t]?)
  | `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant ${ $x:term } $[: $t]?) =>
      `(mlir_op| $res:mlir_op_operand = llvm.mlir.constant($$($x) $[: $t]?) $[: $t]?)

macro_rules
  | `(mlir_op| $res:mlir_op_operand = llvm.icmp $p $x, $y $[: $t]?) => do
    let t ← t.getDM `(mlir_type| _)
    match p.getString with
      | "eq" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.eq" ($x, $y) : ($t, $t) -> (i1))
      | "ne" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.ne" ($x, $y) : ($t, $t) -> (i1))
      | "slt" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.slt" ($x, $y) : ($t, $t) -> (i1))
      | "sle" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.sle" ($x, $y) : ($t, $t) -> (i1))
      | "sgt" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.sgt" ($x, $y) : ($t, $t) -> (i1))
      | "sge" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.sge" ($x, $y) : ($t, $t) -> (i1))
      | "ult" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.ult" ($x, $y) : ($t, $t) -> (i1))
      | "ule" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.ule" ($x, $y) : ($t, $t) -> (i1))
      | "ugt" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.ugt" ($x, $y) : ($t, $t) -> (i1))
      | "uge" => `(mlir_op| $res:mlir_op_operand = "llvm.icmp.uge" ($x, $y) : ($t, $t) -> (i1))
      | _ => Macro.throwErrorAt p s!"unexpected predicate {p.getString}"

macro_rules
  | `(mlir_op| $res:mlir_op_operand = llvm.select $c, $x, $y $[: $t]?) => do
    let t ← t.getDM `(mlir_type| _)
    `(mlir_op| $res:mlir_op_operand = "llvm.select" ($c, $x, $y) : (i1, $t, $t) -> ($t))

macro_rules
  | `(mlir_op| $v:mlir_op_operand = arith.const $x:neg_num : $t) =>
      `(mlir_op| $v:mlir_op_operand = "arith.const" () {value = $x:neg_num } : () -> ($t))
  | `(mlir_op| $v:mlir_op_operand = arith.const ${ $x:term } : $t) => do
      let ctor := mkIdent ``MLIR.AST.AttrValue.int
      let x ← `($ctor $x [mlir_type| i64])

      `(mlir_op| $v:mlir_op_operand = "arith.const" () {value = $$($x) } : () -> ($t))

macro_rules
  | `(mlir_op| $v:mlir_op_operand = poly.const $x:neg_num : $t) =>
      `(mlir_op| $v:mlir_op_operand = "poly.const" () {value = $x:neg_num } : () -> ($t))
  | `(mlir_op| $v:mlir_op_operand = poly.const ${ $x:term } : $t) => do
      let ctor := mkIdent ``MLIR.AST.AttrValue.int
      let x ← `($ctor $x [mlir_type| i64])

      `(mlir_op| $v:mlir_op_operand = "poly.const" () {value = $$($x) } : () -> ($t))

macro_rules
  | `(mlir_op| $v:mlir_op_operand = poly.monomial $xs,* : ($ts,*) -> $t) =>
      `(mlir_op| $v:mlir_op_operand = "poly.monomial" ($xs,*) : ($ts,*) -> $t)

BitStream

def BitStream : Type := Nat → Bool

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 }

carryWith

def carryWith (p : FSM arity) (carryState : p.α → Bool) (x : arity → BitStream) (n : Nat) : p.α → Bool := fun a =>
  (p.changeInitCarry carryState).carry x n a

changeInitCarry

def changeInitCarry (p : FSM arity) (c : p.α → Bool) : FSM arity :=
  { p with initCarry := c }

zero

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

carry

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

State

abbrev State : Type := p.α → Bool

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)

rhs

def rhs := [poly q, n, hq | {
^bb0(%a : !R):
  return %a : !R

}]

AttrValue

inductive AttrValue where
  | symbol: String -> AttrValue
  | str : String -> AttrValue
  | int : Int -> MLIRType φ -> AttrValue
  | nat: Nat -> AttrValue
  | bool : Bool -> AttrValue
  | float : Float -> MLIRType φ -> AttrValue
  | type : MLIRType φ -> AttrValue
  | affine: AffineMap -> AttrValue
  | permutation: List Nat -> AttrValue
  | list: List AttrValue -> AttrValue
  | nestedsymbol: AttrValue -> AttrValue -> AttrValue
  | alias: String -> AttrValue
  | dict: AttrDict -> AttrValue
  | opaque_: (dialect: String) -> (value: String) -> AttrValue
  | opaqueElements: (dialect: String) -> (value: String) -> (type: MLIRType φ) -> AttrValue
  | unit: AttrValue

R

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

def bb0 : Region 0 := [mlir_region|
{
  ^bb0(%arg0: i32):
    %0 = llvm.mlir.constant(8) : i32
    %1 = llvm.mlir.constant(31) : i32
    %2 = llvm.ashr %arg0, %1 : i32
    %3 = llvm.and %2, %0 : i32
    %4 = llvm.add %3, %2 : i32
    llvm.return %4 : i32
  }]

Region

structure Region where
  (name: String)
  (args: List <| TypedSSAVal φ)
  (ops: List Op)

theorem carryWith_congrEnv {p : FSM arity}
    {carryState : p.α → Bool} {x y : arity → BitStream} {n : Nat}
    (h : ∀ a i, i < n → x a i = y a i) :
    p.carryWith carryState x n = p.carryWith carryState y n

theorem carry_congrEnv {p : FSM arity}
    {x y : arity → BitStream} {n : Nat} (h : ∀ a i, i < n → x a i = y a i) :
    p.carry x n = p.carry y n

import Mathlib.Data.Bool.Basic

import Mathlib.Data.Fin.Basic

import Mathlib.Data.Finset.Basic

import Mathlib.Data.Finset.Defs

import Mathlib.Data.Multiset.FinsetOps

import Blase.Fast.BitStream

import Blase.Fast.Defs

import Blase.Fast.FiniteStateMachine

import Blase.Fast.Decide

import Blase.SingleWidth.Syntax

import Lean.Meta.ForEachExpr

import Lean.Meta.Tactic.Simp.BuiltinSimprocs.BitVec

import Blase.Fast.ForLean

import Blase.Vars

import Blase.EnvBitstream

import Lean

open Fin.NatCast

namespace ReflectVerif

open Lean Meta Elab Tactic

namespace BvDecide

open Std Sat AIG

structure KInductionCircuits {arity : Type _}
  [DecidableEq arity] [Fintype arity] [Hashable arity] (fsm : FSM arity) (n : Nat) where

  cInitCarryAssignCirc : Circuit (Vars fsm.α arity 0)

  cSuccCarryAssignCirc : Circuit (Vars fsm.α arity (n+2))

  cOutAssignCirc : Circuit (Vars fsm.α arity (n + 2))

  cStatesUniqueCirc : Circuit (Vars fsm.α arity n)

namespace KInductionCircuits

variable {arity : Type _}
  {fsm : FSM arity}

variable [DecidableEq arity] [Fintype arity] [Hashable arity]

def envBitstream_set (x : arity → BitStream) (n : Nat) (v : arity → Bool) :
    arity → BitStream :=
  fun a j => if j = n then v a else x a j

theorem FSM.carryWith_congrEnv_envBitstream_set_of_le (fsm : FSM arity)
    (s0 : fsm.α → Bool) (env : arity → BitStream) (n : Nat) (v : arity → Bool)
    (k : Nat) (hk : k ≤ n) :
  fsm.carryWith s0 (envBitstream_set env n v) k =
  fsm.carryWith s0 env k :=

:= by
  apply FSM.carryWith_congrEnv
  intros a l hl
  simp [envBitstream_set]
  intros hcontra; omega


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)

syntax "xor" : MLIR.Pretty.uniform_op

syntax "xor" : MLIR.Pretty.uniform_op

syntax "max" : 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) )

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

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

BitStream

def BitStream : Type := Nat → Bool

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)

BitVecs

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

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

Term.language

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

Formula.arity

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

Term.evalFinBV

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

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

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

BitVec.transport

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

BitVec.ofFn

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

List.Vector.transport

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

BitVecs'.transport

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

BitVecs.transport

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

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

ext

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

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

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

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

swapLastTwo

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

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

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

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

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

section fsm

variable {arity : Type} [FinEnum arity]

open BitStream in

end fsm

section nfas_relations

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

end nfas_relations

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

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

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

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

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

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

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

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

def 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

:= 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)
    := by
  simp [Term.language]
  ext bvs
  simp

  generalize_proofs h₁ h₂ h₃ h₄ h₅
  constructor
  · rintro heq
    let bvs' := bvs.bvs ++ (t.evalFinBV (λ n ↦ bvs.bvs.get n) ::ᵥ List.Vector.nil) |>.transport swapLastTwo
    use ⟨_, bvs'⟩
    split_ands
    · simp [bvs']
      have heq : (swapLastTwo (Fin.castLE h₃ (Fin.last t.arity))) = Fin.last (t.arity + 1) := by
        simp [swapLastTwo]
        split_ifs with h₁ h₂
        · exfalso; rw [Fin.ext_iff] at h₁
          simp at h₁
        · rfl
        · exfalso; apply h₂; ext; simp; exact Eq.symm (Nat.mod_eq_of_lt h₃)
      rw [heq]
      rw [List.Vector.append_get_ge]
      on_goal 2 => simp
      simp
      congr
      ext1 x
      rw [List.Vector.append_get_lt]
      on_goal 2 => simp +arith
      congr!
    · rw [BitVecs.cast_eq] at heq ⊢
      unfold BitVecs.cast
      simp
      simp [BitVecs.cast] at heq
      have hget : bvs'.get (Fin.natAdd t.arity 1) = bvs.bvs.get t.arity := by
        simp [bvs']
        rw [List.Vector.append_get_lt]
        on_goal 2 => simp +arith; exact Nat.mod_le t.arity (t.arity + 2)
        · congr
          ext
          simp +arith
      rw [hget]
      convert heq using 1
      · have hbvs' : bvs'.get t.arity = t.evalFinBV fun n => bvs.bvs.get n := by
          simp [bvs']
        simp [openTerm]
        rcases op <;> simp [hbvs', Fin.natAdd_zero'] <;> rfl
      · congr!;  ext; simp
    · ext1
      · simp
      next i =>
        simp [bvs', liftUnop]
        split_ifs with h
        · subst h
          simp
          rw [List.Vector.append_get_lt]
          on_goal 2 => simp +arith; exact Nat.mod_le t.arity (t.arity + 2)
          congr
          ext; simp +arith
        · simp [h]
          congr!
  · rintro ⟨bvs', ⟨⟨heq₁, heq₂⟩, heq₃⟩⟩
    rw [BitVecs.cast_eq] at *
    simp [BitVecs.cast] at *
    rw [←heq₃]
    conv_rhs =>
      simp only [BitVecs.transport_getElem]
      simp [liftUnop]
      rw [ite_cond_eq_true]
      rfl
      tactic => simp only [eq_iff_iff, iff_true]; ext1; simp
    convert heq₂ using 1
    rcases op with _ | _ | _ <;>
    . simp [subst, openTerm] at *; congr