import Clean.Circuit.Theorems
import Clean.Utils.Field
import Clean.Circuit
import Mathlib.Data.Nat.Bitwise
import Clean.Gadgets.Boolean
import Clean.Utils.Bitwise
import Clean.Utils.BinaryOps
import Clean.Utils.Vector

syntax "infer_constant_length" : tactic

syntax "infer_constant_length" : tactic

syntax "let " ident " <== " term : doElem

syntax "let " ident " : " term " <== " term : doElem

macro_rules
  | `(doElem| let $x <== $e) => `(doElem| let $x ← HasAssignEq.assignEq $e)
  | `(doElem| let $x : $t <== $e) => `(doElem| let $x : $t ← HasAssignEq.assignEq $e)

macro_rules
  | `(tactic|infer_constant_length) => `(tactic|(
    apply ConstantLength.fromConstantLength
    try simp only [circuit_norm]
    try intros
    try ac_rfl))

example :
  let add (x : Expression F) := do
    let y : Expression F ← witness fun _ => 1
    let z ← witness fun eval => eval (x + y)
    assertZero (x + y - z)
    pure z
  ConstantLength add := by admit /- proof elided -/

F

def F p := ZMod p

fields

@[reducible]
def fields (n : ℕ) := fun F => Vector F n

IsBool

def IsBool {α : Type*} [Zero α] [One α] (x : α) : Prop := x = 0 ∨ x = 1

map

def map {m : ℕ} (xs : Vector α m) (body : α → Circuit F β)
    (_constant : ConstantLength body := by admit /- proof elided -/
    ) : Circuit F (Vector β m) :=
  xs.mapM body

Circuit

def Circuit (F : Type) [Field F] (α : Type) := ℕ → α × List (Operation F)

Operation

inductive Operation (F : Type) [Field F] where
  | witness : (m : ℕ) → (compute : Environment F → Vector F m) → Operation F
  | assert : Expression F → Operation F
  | lookup : Lookup F → Operation F
  | subcircuit : {n : ℕ} → Subcircuit F n → Operation F

Condition

structure Condition (F : Type) [Field F] where
  witness (offset : ℕ) : (m : ℕ) → (Environment F → Vector F m) → Prop := fun _ _ => True
  assert (offset : ℕ) (_ : Expression F) : Prop := True
  lookup (offset : ℕ) (_ : Lookup F) : Prop := True
  subcircuit (offset : ℕ) {m : ℕ} (_ : Subcircuit F m) : Prop := True

FlatOperation

inductive FlatOperation (F : Type) where
  | witness : (m : ℕ) → (Environment F → Vector F m) → FlatOperation F
  | assert : Expression F → FlatOperation F
  | lookup : Lookup F → FlatOperation F

Subcircuit

structure Subcircuit (F : Type) [Field F] (offset : ℕ) where
  ops : List (FlatOperation F)

  Soundness : Environment F → Prop
  Completeness : Environment F → Prop
  UsesLocalWitnesses : Environment F → Prop

  localLength : ℕ

  imply_soundness : ∀ env,
    ConstraintsHoldFlat env ops → Soundness env

  implied_by_completeness : ∀ env, env.ExtendsVector (localWitnesses env ops) offset →
    Completeness env → ConstraintsHoldFlat env ops

  imply_usesLocalWitnesses : ∀ env, env.ExtendsVector (localWitnesses env ops) offset →
    UsesLocalWitnesses env

  localLength_eq : localLength = FlatOperation.localLength ops

localWitnesses

@[circuit_norm]
def localWitnesses (env : Environment F) : (l : List (FlatOperation F)) → Vector F (localLength l)
  | [] => #v[]
  | witness _ compute :: ops => compute env ++ localWitnesses env ops
  | assert _ :: ops | lookup _ :: ops => localWitnesses env ops

lookup

@[circuit_norm]
def lookup {Row : TypeMap} [ProvableType Row] (table : Table F Row)  (entry : Row (Expression F)) : Circuit F Unit := fun _ =>
  ((), [.lookup { table := table.toRaw, entry := toElements entry }])

Table.toRaw

@[circuit_norm]
def Table.toRaw (table : Table F Row) : RawTable F where
  name := table.name
  arity := size Row
  Contains row := table.Contains (fromElements row)
  Soundness row := table.Soundness (fromElements row)
  Completeness row := table.Completeness (fromElements row)
  imply_soundness row := table.imply_soundness (fromElements row)
  implied_by_completeness row := table.implied_by_completeness (fromElements row)

RawTable

structure RawTable (F : Type) where
  name : String
  arity : ℕ
  Contains : Vector F arity → Prop
  Soundness : Vector F arity → Prop
  Completeness : Vector F arity → Prop
  imply_soundness : ∀ row, Contains row → Soundness row
  implied_by_completeness : ∀ row, Completeness row → Contains row

StaticTable

structure StaticTable (F : Type) (Row : TypeMap) [ProvableType Row] where
  name : String
  length : ℕ
  row : Fin length → Row F

  index : Row F → ℕ
  Spec : Row F → Prop
  contains_iff : ∀ t, (∃ i, t = row i) ↔ Spec t

Contains

def Contains (table : StaticTable F Row) (row : Row F) :=
  ∃ i : Fin table.length, row = table.row i

ProvableType.fromStruct

instance ProvableType.fromStruct {α : TypeMap} [ProvableStruct α] : ProvableType α where
  size := combinedSize α
  toElements x :=
    toComponents x |> componentsToElements (components α) |>.cast combinedSize_eq.symm
  fromElements v :=
    v.cast combinedSize_eq |> componentsFromElements (components α) |> fromComponents
  fromElements_toElements x := by admit /- proof elided -/

TypeMap

@[reducible]
def TypeMap := Type → Type

Table

structure Table (F : Type) (Row : TypeMap) [ProvableType Row] where
  name : String

  Contains : Row F → Prop

  Soundness : Row F → Prop
  Completeness : Row F → Prop

  imply_soundness : ∀ row, Contains row → Soundness row
  implied_by_completeness : ∀ row, Completeness row → Contains row

Expression

inductive Expression (F : Type) where
  | var : Variable F -> Expression F
  | const : F -> Expression F
  | add : Expression F -> Expression F -> Expression F
  | mul : Expression F -> Expression F -> Expression F

Variable

structure Variable (F : Type) where
  index : ℕ

const

def const (x : α F) : Var α F :=
  let values : Vector F _ := toElements x
  fromVars (values.map .const)

Var

@[reducible] def Var (M : TypeMap) (F : Type) := M (Expression F)

fromVars

@[circuit_norm]
def fromVars (vars : Vector (Expression F) (size M)) := fromElements vars

Lookup

structure Lookup (F : Type) where
  table : RawTable F
  entry : Vector (Expression F) table.arity

Witnessable

class Witnessable (F : Type) [Field F] (value : outParam TypeMap) (var : TypeMap) [ProvableType value] where
  witness : ((Environment F) → value F) → Circuit F (var F)
  var_eq : var F = value (Expression F) := by admit /- proof elided -/

Environment

structure Environment (F : Type) where
  get : ℕ → F

localLength

@[circuit_norm]
def localLength : List (FlatOperation F) → ℕ
  | [] => 0
  | witness m _ :: ops => m + localLength ops
  | assert _ :: ops | lookup _ :: ops => localLength ops

ConstraintsHoldFlat

def ConstraintsHoldFlat (eval : Environment F) : List (FlatOperation F) → Prop
  | [] => True
  | op :: ops => match op with
    | assert e => (eval e = 0) ∧ ConstraintsHoldFlat eval ops
    | lookup { table, entry } =>
      table.Contains (entry.map eval) ∧ ConstraintsHoldFlat eval ops
    | _ => ConstraintsHoldFlat eval ops

ConstantLength

class ConstantLength (circuit : α → Circuit F β) where
  localLength : ℕ
  localLength_eq : ∀ (a : α) (n : ℕ), (circuit a).localLength n = localLength

ConstantLength.fromConstantLength

def ConstantLength.fromConstantLength {circuit : α → Circuit F β} [Inhabited α]
    (h : ∀ (a : α) n, (circuit a).localLength n = (circuit default).localLength 0) : ConstantLength circuit where
  localLength := (circuit default).localLength 0
  localLength_eq a n := h a n

HasAssignEq

class HasAssignEq (β : Type) (F : outParam Type) [Field F] where
  assignEq : β → Circuit F β

FormalCircuit

structure FormalCircuit (F : Type) [Field F] (Input Output : TypeMap) [ProvableType Input] [ProvableType Output]
    extends elaborated : ElaboratedCircuit F Input Output where
  Assumptions (_ : Input F) : Prop := True
  Spec : Input F → Output F → Prop
  soundness : Soundness F elaborated Assumptions Spec
  completeness : Completeness F elaborated Assumptions

ElaboratedCircuit

class ElaboratedCircuit (F : Type) (Input Output : TypeMap) [Field F] [ProvableType Input] [ProvableType Output] where
  main : Var Input F → Circuit F (Var Output F)

  localLength : Var Input F → ℕ

  localLength_eq : ∀ input offset, (main input).localLength offset = localLength input
    := by admit /- proof elided -/

GeneralFormalCircuit

structure GeneralFormalCircuit (F : Type) (Input Output : TypeMap) [Field F] [ProvableType Input] [ProvableType Output]
    extends elaborated : ElaboratedCircuit F Input Output where
  Assumptions : Input F → Prop
  Spec : Input F → Output F → Prop
  soundness : GeneralFormalCircuit.Soundness F elaborated Spec
  completeness : GeneralFormalCircuit.Completeness F elaborated Assumptions

Soundness

@[circuit_norm]
def Soundness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input Output)
    (Assumptions : Input F → Prop) (Spec : Input F → Output F → Prop) :=

  ∀ offset : ℕ, ∀ env,

  ∀ input_var : Var Input F, ∀ input : Input F, eval env input_var = input →
  Assumptions input →

  ConstraintsHold.Soundness env (circuit.main input_var |>.operations offset) →

  let output := eval env (circuit.output input_var offset)
  Spec input output

operations

@[reducible, circuit_norm]
def operations (circuit : Circuit F α) (offset : ℕ) : Operations F :=
  (circuit offset).2

Operations

@[reducible, circuit_norm]
def Operations (F : Type) [Field F] := List (Operation F)

output

@[reducible, circuit_norm]
def output (circuit : Circuit F α) (offset : ℕ) : α :=
  (circuit offset).1

ConstraintsHold.Soundness

@[circuit_norm]
def ConstraintsHold.Soundness (eval : Environment F) : List (Operation F) → Prop
  | [] => True
  | .witness _ _ :: ops => ConstraintsHold.Soundness eval ops
  | .assert e :: ops => eval e = 0 ∧ ConstraintsHold.Soundness eval ops
  | .lookup { table, entry } :: ops =>
    table.Soundness (entry.map eval) ∧ ConstraintsHold.Soundness eval ops
  | .subcircuit s :: ops =>
    s.Soundness eval ∧ ConstraintsHold.Soundness eval ops

GeneralFormalCircuit.Soundness

@[circuit_norm]
def GeneralFormalCircuit.Soundness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input Output) (Spec : Input F → Output F → Prop) :=

  ∀ offset : ℕ, ∀ env,

  ∀ input_var : Var Input F, ∀ input : Input F, eval env input_var = input →

  ConstraintsHold.Soundness env (circuit.main input_var |>.operations offset) →

  let output := eval env (circuit.output input_var offset)
  Spec input output

eval

@[explicit_provable_type]
def eval (env : Environment F) (x : Var α F) : α F :=
  let vars := toVars x
  let values := vars.map (Expression.eval env)
  fromElements values

toVars

@[circuit_norm]
def toVars (var : M (Expression F)) := toElements var

eval

@[circuit_norm]
def eval (env : Environment F) : Expression F → F
  | var v => env.get v.index
  | const c => c
  | add x y => eval env x + eval env y
  | mul x y => eval env x * eval env y

FormalAssertion.Soundness

@[circuit_norm]
def FormalAssertion.Soundness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input unit)
    (Assumptions : Input F → Prop) (Spec : Input F → Prop) :=

  ∀ offset : ℕ, ∀ env,

  ∀ input_var : Var Input F, ∀ input : Input F, eval env input_var = input →
  Assumptions input →

  ConstraintsHold.Soundness env (circuit.main input_var |>.operations offset) →

  Spec input

unit

@[reducible]
def unit (_ : Type) := Unit

subcircuit

@[circuit_norm]
def subcircuit (circuit : FormalCircuit F β α) (b : Var β F) : Circuit F (Var α F) :=
  fun offset =>
    let a := circuit.output b offset
    let subcircuit := circuit.toSubcircuit offset b
    (a, [.subcircuit subcircuit])

FormalAssertion.toSubcircuit

def FormalAssertion.toSubcircuit (circuit : FormalAssertion F β)
    (n : ℕ) (input_var : Var β F) : Subcircuit F n :=
  let ops := circuit.main input_var |>.operations n
  have h_consistent : ops.SubcircuitsConsistent n := circuit.subcircuitsConsistent input_var n

  {
    ops := ops.toFlat,
    Soundness env := circuit.Assumptions (eval env input_var) → circuit.Spec (eval env input_var),
    Completeness env := circuit.Assumptions (eval env input_var) ∧ circuit.Spec (eval env input_var),
    UsesLocalWitnesses _ := True,
    localLength := circuit.localLength input_var

    imply_soundness := by admit /- proof elided -/

localLength

@[circuit_norm]
def localLength : Operation F → ℕ
  | .witness m _ => m
  | .assert _ => 0
  | .lookup _ => 0
  | .subcircuit s => s.localLength

@[circuit_norm]
def localLength : Operations F → ℕ
  | [] => 0
  | .witness m _ :: ops => m + localLength ops
  | .assert _ :: ops => localLength ops
  | .lookup _ :: ops => localLength ops
  | .subcircuit s :: ops => s.localLength + localLength ops

FormalAssertion

structure FormalAssertion (F : Type) (Input : TypeMap) [Field F] [ProvableType Input]
    extends elaborated : ElaboratedCircuit F Input unit where
  Assumptions : Input F → Prop
  Spec : Input F → Prop
  soundness : FormalAssertion.Soundness F elaborated Assumptions Spec
  completeness : FormalAssertion.Completeness F elaborated Assumptions Spec

  localLength _ := 0

  output _ _ := ()

SubcircuitsConsistent

@[circuit_norm]
def SubcircuitsConsistent (offset : ℕ) (ops : Operations F) := ops.forAll offset {
  subcircuit offset {n} _ := n = offset
}

 @[circuit_norm]
def forAll (offset : ℕ) (condition : Condition F) : Operations F → Prop
  | [] => True
  | .witness m c :: ops => condition.witness offset m c ∧ forAll (m + offset) condition ops
  | .assert e :: ops => condition.assert offset e ∧ forAll offset condition ops
  | .lookup l :: ops => condition.lookup offset l ∧ forAll offset condition ops
  | .subcircuit s :: ops => condition.subcircuit offset s ∧ forAll (s.localLength + offset) condition ops

FlatOperation.forAll

def FlatOperation.forAll (offset : ℕ) (condition : Condition F) : List (FlatOperation F) → Prop
  | [] => True
  | .witness m c :: ops => condition.witness offset m c ∧ forAll (m + offset) condition ops
  | .assert e :: ops => condition.assert offset e ∧ forAll offset condition ops
  | .lookup l :: ops => condition.lookup offset l ∧ forAll offset condition ops

localLength

@[reducible, circuit_norm]
def localLength (circuit : Circuit F α) (offset := 0) : ℕ :=
  Operations.localLength (circuit offset).2

FormalAssertion.Completeness

@[circuit_norm]
def FormalAssertion.Completeness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input unit)
    (Assumptions : Input F → Prop) (Spec : Input F → Prop) :=

  ∀ offset, ∀ env, ∀ input_var : Var Input F,
  env.UsesLocalWitnessesCompleteness offset (circuit.main input_var |>.operations offset) →

  ∀ input : Input F, eval env input_var = input →
  Assumptions input → Spec input →

  ConstraintsHold.Completeness env (circuit.main input_var |>.operations offset)

ConstraintsHold.Completeness

@[circuit_norm]
def ConstraintsHold.Completeness (eval : Environment F) : List (Operation F) → Prop
  | [] => True
  | .witness _ _ :: ops => ConstraintsHold.Completeness eval ops
  | .assert e :: ops => eval e = 0 ∧ ConstraintsHold.Completeness eval ops
  | .lookup { table, entry } :: ops =>
    table.Completeness (entry.map eval) ∧ ConstraintsHold.Completeness eval ops
  | .subcircuit s :: ops =>
    s.Completeness eval ∧ ConstraintsHold.Completeness eval ops

Completeness

@[circuit_norm]
def Completeness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input Output)
    (Assumptions : Input F → Prop) :=

  ∀ offset : ℕ, ∀ env, ∀ input_var : Var Input F,
  env.UsesLocalWitnessesCompleteness offset (circuit.main input_var |>.operations offset) →

  ∀ input : Input F, eval env input_var = input →
  Assumptions input →

  ConstraintsHold.Completeness env (circuit.main input_var |>.operations offset)

GeneralFormalCircuit.Completeness

@[circuit_norm]
def GeneralFormalCircuit.Completeness (F : Type) [Field F] (circuit : ElaboratedCircuit F Input Output) (Assumptions : Input F → Prop) :=

  ∀ offset : ℕ, ∀ env, ∀ input_var : Var Input F,
  env.UsesLocalWitnessesCompleteness offset (circuit.main input_var |>.operations offset) →

  ∀ input : Input F, eval env input_var = input →
  Assumptions input →

  ConstraintsHold.Completeness env (circuit.main input_var |>.operations offset)

toFlat

def toFlat : Operations F → List (FlatOperation F)
  | [] => []
  | .witness m c :: ops => .witness m c :: toFlat ops
  | .assert e :: ops => .assert e :: toFlat ops
  | .lookup l :: ops => .lookup l :: toFlat ops
  | .subcircuit s :: ops => s.ops ++ toFlat ops

Environment.UsesLocalWitnesses

def Environment.UsesLocalWitnesses (env : Environment F) (offset : ℕ) (ops : Operations F) : Prop :=
  ops.forAllFlat offset { witness n _ compute := env.ExtendsVector (compute env) n }

Environment.ExtendsVector

@[circuit_norm]
def Environment.ExtendsVector (env : Environment F) (wit : Vector F n) (offset : ℕ) : Prop :=
  ∀ i : Fin n, env.get (offset + i.val) = wit[i.val]

Operations.forAllFlat

def Operations.forAllFlat (n : ℕ) (condition : Condition F) (ops : Operations F) : Prop :=
  forAll n { condition with subcircuit n _ s := FlatOperation.forAll n condition s.ops } ops

GeneralFormalCircuit.toSubcircuit

def GeneralFormalCircuit.toSubcircuit (circuit : GeneralFormalCircuit F β α)
    (n : ℕ) (input_var : Var β F) : Subcircuit F n :=
  let ops := circuit.main input_var |>.operations n
  have h_consistent : ops.SubcircuitsConsistent n := circuit.subcircuitsConsistent input_var n

  have imply_soundness : ∀ env : Environment F,
      let input := eval env input_var
      let output := eval env (circuit.output input_var n)
      ConstraintsHoldFlat env ops.toFlat → circuit.Spec input output :=

FormalCircuit.toSubcircuit

def FormalCircuit.toSubcircuit (circuit : FormalCircuit F β α)
    (n : ℕ) (input_var : Var β F) : Subcircuit F n :=
  let ops := circuit.main input_var |>.operations n
  have h_consistent : ops.SubcircuitsConsistent n := circuit.subcircuitsConsistent input_var n

  have imply_soundness : ∀ env : Environment F,
    let input := eval env input_var
    let output := eval env (circuit.output input_var n)
    ConstraintsHoldFlat env ops.toFlat → circuit.Assumptions input → circuit.Spec input output :=

fieldPair

@[reducible]
def fieldPair : TypeMap := fun F => F × F

field

@[reducible] def field : TypeMap := id

ConstraintsHold

@[circuit_norm]
def ConstraintsHold (eval : Environment F) : List (Operation F) → Prop
  | [] => True
  | .witness _ _ :: ops => ConstraintsHold eval ops
  | .assert e :: ops => eval e = 0 ∧ ConstraintsHold eval ops
  | .lookup { table, entry, .. } :: ops =>
    table.Contains (entry.map eval) ∧ ConstraintsHold eval ops
  | .subcircuit s :: ops =>
    ConstraintsHoldFlat eval s.ops ∧ ConstraintsHold eval ops

@[circuit_norm]
def Environment.UsesLocalWitnessesCompleteness (env : Environment F) (offset : ℕ) : List (Operation F) → Prop
  | [] => True
  | .witness m c :: ops => env.ExtendsVector (c env) offset ∧ env.UsesLocalWitnessesCompleteness (offset + m) ops
  | .assert _ :: ops => env.UsesLocalWitnessesCompleteness offset ops
  | .lookup _ :: ops => env.UsesLocalWitnessesCompleteness offset ops
  | .subcircuit s :: ops => s.UsesLocalWitnesses env ∧ env.UsesLocalWitnessesCompleteness (offset + s.localLength) ops

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

Circomlib.MultiAND.Spec

import Clean.Circuit

import Clean.Utils.Field

import Clean.Gadgets.Boolean

import Clean.Utils.Bitwise

import Clean.Utils.Vector

import Clean.Utils.BinaryOps

import Clean.Circuit.Theorems

import Mathlib.Data.Nat.Bitwise

open IsBool

namespace Circomlib

variable {p : ℕ} [Fact p.Prime]

open Circuit (bind_output_eq bind_localLength_eq bind_forAll)

open Operations (append_localLength)

open BinaryOps (List.foldl_and_IsBool List.and_foldl_eq_foldl)

namespace XOR

end XOR

namespace AND

def main (input : Expression (F p) × Expression (F p)) := do
  let a := input.1
  let b := input.2
  let out <== a*b
  return out

end AND

namespace OR

end OR

namespace NOT

end NOT

namespace NAND

end NAND

namespace NOR

end NOR

namespace MultiAND

def main : {n : ℕ} → Vector (Expression (F p)) n → Circuit (F p) (Expression (F p))
  | 0, _ =>
    return (1 : F p)
  | 1, input =>
    return input[0]
  | 2, input =>
    AND.circuit.main (input[0], input[1])
  | n + 3, input => do
    let n1 := (n + 3) / 2
    let n2 := (n + 3) - n1

    let input1 : Vector (Expression (F p)) n1 := input.take n1 |>.cast (by admit /- proof elided -/
    )
    let input2 : Vector (Expression (F p)) n2 := input.drop n1 |>.cast (by admit /- proof elided -/
    )

    let out1 ← main input1
    let out2 ← main input2

    AND.circuit.main (out1, out2)

def Assumptions (n : ℕ) (input : fields n (F p)) : Prop :=
  ∀ (i : ℕ) (h : i < n), IsBool input[i]

def Spec (n : ℕ) (input : fields n (F p)) (output : F p) : Prop :=
  output.val = (input.map (·.val)).foldl (· &&& ·) 1 ∧ IsBool output

lemma completeness_two {p : ℕ} [Fact p.Prime]
    (offset : ℕ) (env : Environment (F p)) (input_var : Var (fields 2) (F p))
    (input : fields 2 (F p))
    (h_local_witnesses : env.UsesLocalWitnessesCompleteness offset ((main input_var).operations offset))
    (h_env : input = eval env input_var)
    (h_assumptions : Assumptions 2 input) :
    Circuit.ConstraintsHold.Completeness env ((main input_var).operations offset) :=

:= by
  simp only [main, circuit_norm] at h_local_witnesses ⊢

  have h_binary0 : IsBool input[0] := h_assumptions 0 (by norm_num)
  have h_binary1 : IsBool input[1] := h_assumptions 1 (by norm_num)

  apply AND.circuit.completeness
  · exact h_local_witnesses
  · subst h_env
    rfl
  · simp only [Assumptions] at h_assumptions
    constructor
    · have h_eval0 : env input_var[0] = input[0] :=
        by simp[h_env, circuit_norm]
      change IsBool (env input_var[0])
      rw [h_eval0]
      exact h_binary0
    · have h_eval1 : env input_var[1] = input[1] :=
        by simp[h_env, circuit_norm]
      change IsBool (env input_var[1])
      rw [h_eval1]
      exact h_binary1


import SPLean.Theories.XChange
import Mathlib.Data.List.Indexes
import SPLean.Theories.XSimp
import SPLean.Theories.SepLog
import Mathlib.Data.Finmap
import SPLean.Common.State
import SPLean.Theories.HProp
import SPLean.Common.Util
import Lean
import SPLean.Theories.WPUtil

macro "∃ʰ" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hexists xs b

syntax "fun" ident+ " => " lang : lang

notation:max "emp" => hempty

syntax " := " : bop

syntax "if " lang "then " lang "end " : lang

macro "h∀" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hforall xs b

notation:max "⌜" P "⌝" => hpure P

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

macro "xsimp" : tactic =>

macro "xsimp" : tactic =>
  `(tactic| (
    xsimp_start
    repeat xsimp_step
    try rev_pure
    try hide_mvars
    try hsimp
    rotate_left

  ))

syntax " <= " : bop

macro "xval" : tactic => do

macro "xval" : tactic => do
  `(tactic| (xstruct_if_needed; apply xval_lemma))

macro "xval" : tactic => `(tactic| (xwp; xval))

macro "xseq" : tactic => do

macro "xseq" : tactic => do
  `(tactic| (xstruct_if_needed; apply xseq_lemma))

macro "xchange" l:term : tactic =>

macro "xchange" l:term : tactic =>
  `(tactic| (xchange_core $l; xsimp))

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules
  | `({ $P }[$t:lang]{$v, $Q}) => `(triple [lang| $t] $P (fun $v => $Q))
  | `({ $P }[$t:lang]{$Q})     => `(triple [lang| $t] $P (fun _ => $Q))
  | `(WP[$t:lang]{$v, $Q})     => `(wp [lang| $t] (fun $v => $Q))
  | `(WP[$t:lang]{$Q})         => `(wp [lang| $t] (fun _ => $Q))

macro_rules
  | `(tactic| xstep $(t)? ) => `(tactic| (xwp; xapp $(t)?))

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

var

abbrev var := String

loc

abbrev loc := Nat

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

HWand

class HWand (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hWand : α → β → γ

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

himpl

abbrev himpl (H1 H2 : hProp) : Prop :=
  forall h, H1 h -> H2 h

qimpl

def qimpl {A} (Q1 Q2 : A → hProp) : Prop :=
  forall (v:A), Q1 v ==> Q2 v

hpure

def hpure (P : Prop) : hProp :=
  hexists (fun (_ : P) => emp)

hexists

def hexists {A} (J : A → hProp) : hProp :=
  fun h => exists x, J x h

hempty

def hempty : hProp :=
  fun h => (h = ∅)

infixr:51 " ==> " => himpl

infixr:51 " ===> " => qimpl

notation:max "emp" => hempty

infixr:55 " ∗ " => HStar.hStar

notation:max "⌜" P "⌝" => hpure P

infixr:55 " -∗ " => HWand.hWand

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

lemma himpl_trans H2 H1 H3 :
  (H1 ==> H2) → (H2 ==> H3) → (H1 ==> H3)

Theories.formula

abbrev formula := (val → hProp) → hProp

Theories.structural

lemma mkstruct_erase Q F :
  F Q ==> mkstruct F Q

import Lean

import Mathlib.Data.Finmap

import Mathlib.Data.List.Indexes

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Theories.SepLog

import SPLean.Theories.WPUtil

open trm val prim

namespace Theories

abbrev formula := (val → hProp) → hProp

def mkstruct (F : formula) :=
  fun (Q : val -> hProp) ↦ ∃ʰ Q', F Q' ∗ (Q' -∗ Q)

def structural (F : formula) :=
  forall Q, mkstruct F Q ==> F Q

def structural_pred (S : α -> formula) :=
  ∀ x, structural $ S x

def wpgen_val (v : val) : formula :=
  fun Q ↦ Q v

def wpgen_seq (F1 F2 : formula) : formula :=
  fun Q ↦ F1 (fun _ ↦ F2 Q)

def wpgen_for (v₁ v₂ : trm) (F1 : val -> formula) : formula :=
  mkstruct fun Q =>
    ∃ʰ n₁ n₂ : Int, ⌜v₁ = n₁⌝ ∗ ⌜v₂ = n₂⌝ ∗
      h∀ (S : Int -> formula),
        (let F i :=
          if i < n₂ then
            wpgen_seq (F1 (val_int i)) (S (i + 1))
          else wpgen_val val_unit
        ⌜structural_pred S /\ ∀ i, F i ===> S i⌝ -∗ S n₁ Q )

section tactics

open Lean Elab Tactic

section xapp

end xapp

end tactics

open AList

section funs_fixs_eval_like

variable (xs : List var) (vs : List val) (t : trm) (v0 : trm)
  (heqt : t = trm_apps v0 ts)
  (hconv : trms_to_vals ts = vs)
  (hform : var_funs xs vs.length)   -- NOTE: can be relaxed to `vs.length ≤ xs.length`

variable (f : var) (hf : f ∉ xs)

end funs_fixs_eval_like

end Theories

open Theories

lemma xfor_inv_lemma (I : Int -> hProp) (a b : Int)
  (F : val -> formula)
  (Q : val -> hProp) :
  structural_pred F ->
  a <= b ->
    (∃ H',
      H ==> I a ∗ H' ∧
      (∀ i, a <= i ∧ i < b -> I i ==> F i fun _ => I (i + 1)) ∧
      (fun _ => I b ∗ H') ===> Q) ->
    H ==> wpgen_for a b F Q :=

:= by
  move=> sF L ![H' Ma Mb Mc]
  unfold wpgen_for
  apply himpl_trans; rotate_left; apply mkstruct_erase
  unfold_let
  xsimp[a,b]=> //== ls
  srw OfNat.ofNat instOfNat instOfNatNat /== => hs
  -- shave-> ls hs: i + (OfNat.ofNat 1) = i + 1; sdone
  shave P: ∀ i, a <= i ∧ i <= b -> I i ==> S i fun _ => I b
  { move=> i [/[swap] iLb]
    apply (Int.le_induction_down _ _ _ iLb)
    { move=> ?
      xchange (hs b)=> /==
      sby xval }
    move=> i ? ih ?
    xchange hs
    scase_if=> // ?; rotate_left; omega
    xseq
    xchange Mb;
    srw OfNat.ofNat instOfNat instOfNatNat /==
    omega
    apply himpl_trans; rotate_left; apply sF
    unfold mkstruct; xsimp; apply ih; omega }
  xchange Ma; xchange P; omega
  apply himpl_trans; rotate_left; apply ls
  unfold mkstruct; xsimp; apply Mc


PosDef.Invertible

noncomputable instance PosDef.Invertible [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.PosDef) :
    Invertible M :=
  invertibleOfIsUnitDet M (isUnit_iff_ne_zero.2 hM.det_ne_zero)

det

def det {n : ℕ} (A : Matrix (Fin n) (Fin n) Float) : Float :=
  if h : 0 < n then
    if n == 1 then A ⟨0, h⟩ ⟨0, h⟩ else
      (List.finRange n).foldl (fun s i =>
        s + (-1) ^ (Float.ofNat i.val) * A i ⟨0, h⟩ * det (minor A i ⟨0, h⟩)) 0
  else 0

minor

def minor (A : Matrix (Fin n) (Fin n) Float) (a b : Fin n) :
    Matrix (Fin n.pred) (Fin n.pred) Float :=
  match n with
  | 0 => fun _ => Fin.elim0
  | _ + 1 => minorAux A a b

minorAux

private def minorAux (A : Matrix (Fin n.succ) (Fin n.succ) Float) (a b : Fin n.succ) :
    Matrix (Fin n) (Fin n) Float :=
  fun i j =>
    let i' : Fin n.succ := if i.val < a.val then i else i.succ;
    let j' : Fin n.succ := if j.val < b.val then j else j.succ;
    A i' j'

lemma PosSemidef_diagonal [DecidableEq n] {f : n → ℝ} (hf : ∀ i, 0 ≤ f i) :
    (diagonal f).PosSemidef

lemma PosSemidef.conjTranspose_mul_mul (M N : Matrix n n 𝕜) (hM : M.PosSemidef) :
    (Nᴴ * M * N).PosSemidef

theorem spectral_theorem (xs : OrthonormalBasis n 𝕜 (EuclideanSpace 𝕜 n)) (as : n → ℝ)
    (hxs : ∀ j, Module.End.HasEigenvector (Matrix.toLin' A) (as j) (xs j)) :
    xs.toBasis.toMatrix (Pi.basisFun 𝕜 n) * A =
    diagonal (RCLike.ofReal ∘ as) * xs.toBasis.toMatrix (Pi.basisFun 𝕜 n)

lemma PosDef.det_ne_zero [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.PosDef) : M.det ≠ 0

Matrix.IsHermitian.sqrt

lemma eigenvectorMatrix_inv_mul : hA.eigenvectorMatrixInv * hA.eigenvectorMatrix = 1

theorem spectral_theorem'' :
    hA.eigenvectorMatrix * diagonal (RCLike.ofReal ∘ hA.eigenvalues) * hA.eigenvectorMatrixᴴ =
    A

lemma conjTranspose_eq_transpose {m n : Type _} {A : Matrix m n ℝ} : Aᴴ = Aᵀ

@[simp]
lemma PosSemidef.sqrt_mul_sqrt {A : Matrix n n ℝ} (hA : A.PosSemidef) :
    hA.1.sqrt * hA.1.sqrt = A

lemma PosSemidef.PosSemidef_sqrt {A : Matrix n n ℝ} (hA : A.PosSemidef) :
    hA.1.sqrt.PosSemidef

import Mathlib.LinearAlgebra.Matrix.PosDef

import Mathlib.LinearAlgebra.Matrix.Spectrum

import Mathlib.LinearAlgebra.Eigenspace.Basic

import Mathlib.LinearAlgebra.Matrix.LDL

import Mathlib.LinearAlgebra.Matrix.DotProduct

import CvxLean.Lib.Math.LinearAlgebra.Matrix.PosDef

import CvxLean.Lib.Math.LinearAlgebra.Matrix.Spectrum

import CvxLean.Lib.Math.LinearAlgebra.Eigenspace

namespace Finset

open BigOperators

end Finset

namespace Matrix

variable {n : Type _} [Fintype n] [DecidableEq n] [LinearOrder n] [LocallyFiniteOrderBot n]

open BigOperators Matrix

namespace IsHermitian

variable {𝕜 : Type _} [DecidableEq 𝕜] [RCLike 𝕜] {A : Matrix n n 𝕜} (hA : A.IsHermitian)

end IsHermitian

noncomputable def IsHermitian.sqrt {A : Matrix n n ℝ} (hA : A.IsHermitian) : Matrix n n ℝ :=
  hA.eigenvectorMatrix * Matrix.diagonal (fun i => (hA.eigenvalues i).sqrt) * hA.eigenvectorMatrixᵀ

lemma PosSemidef.PosDef_iff_det_ne_zero [DecidableEq n] {M : Matrix n n ℝ} (hM : M.PosSemidef) :
    M.PosDef ↔ M.det ≠ 0 :=

:= by
  refine' ⟨PosDef.det_ne_zero, _⟩; intro hdet; refine' ⟨hM.1, _⟩
  intros x hx
  apply lt_of_le_of_ne' (hM.2 x)
  rw [← hM.sqrt_mul_sqrt, ← mulVec_mulVec, dotProduct_mulVec, ← transpose_transpose hM.1.sqrt,
    vecMul_transpose, transpose_transpose, ← conjTranspose_eq_transpose,
    hM.PosSemidef_sqrt.1.eq]
  simp only [RCLike.re_to_real, star, id]
  change @inner ℝ (EuclideanSpace ℝ _) _ (hM.1.sqrt.mulVec x) (hM.1.sqrt.mulVec x) ≠ 0
  intro hinner
  have sqrtMdet0 : hM.1.sqrt.det = 0 := by
    refine' exists_mulVec_eq_zero_iff.1 ⟨x, hx, _⟩
    rw [inner_self_eq_zero.1 hinner]
  rw [← hM.sqrt_mul_sqrt, det_mul, sqrtMdet0, mul_zero] at hdet
  apply hdet rfl


syntax "if " lang "then " lang "end " : lang

syntax " := " : bop

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "fun" ident+ " => " lang : lang

macro "h∀" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hforall xs b

macro "∃ʰ" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hexists xs b

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

var

abbrev var := String

loc

abbrev loc := Nat

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

eval

inductive eval : state → trm → (val → state → Prop) -> Prop where
  | eval_val : forall s v Q,
      Q v s ->
      eval s (trm_val v) Q
  | eval_fun : forall s x t1 Q,
      Q (val_fun x t1) s ->
      eval s (trm_fun x t1) Q
  | eval_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      eval s (trm_fix f x t1) Q
  | eval_app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      eval s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
      eval s1 (trm_app t1 t2) Q
  | eval_app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      eval s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> eval s2 (trm_app v1 v2) Q) ->
      eval s1 (trm_app v1 t2) Q
  | eval_app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) Q ->
      eval s1 (trm_app v1 v2) Q
  | eval_app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      eval s (subst x v2 (subst f v1 t1)) Q ->
      eval s (trm_app v1 v2) Q
  | eval_seq : forall Q1 s t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 t2 Q) ->
      eval s (trm_seq t1 t2) Q
  | eval_let : forall Q1 s x t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (subst x v1 t2) Q) ->
      eval s (trm_let x t1 t2) Q
  | eval_if : forall s (b : Bool) t1 t2 Q,
      eval s (if b then t1 else t2) Q ->
      eval s (trm_if (val_bool b) t1 t2) Q
  | eval_unop : forall op s v1 P Q,
      evalunop op v1 P ->
      purepostin s P Q ->
      eval s (trm_app op v1) Q
  | eval_binop : forall op s (v1 v2 : val) P Q,
      evalbinop op v1 v2 P ->
      purepostin s P Q ->
      eval s (trm_app (trm_app op v1) v2) Q
  | eval_ref : forall s x t1 t2 (Q Q₁ : val → state → Prop),
    eval s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     eval (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
    eval s (trm_ref x t1 t2) Q
  | eval_get : forall s p Q,
      p ∈ s ->
      Q (read_state p s) s ->
      eval s (trm_app val_get (val_loc p)) Q
  | eval_set : forall s p v Q,
      v = trm_val v' ->
      p ∈ s ->
      Q val_unit (Finmap.insert p v' s) ->
      eval s (trm_app (trm_app val_set (val_loc p)) v) Q
  | eval_alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    eval s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → eval s' (trm_alloc x v' t2) Q) →
    eval s (trm_alloc x t1 t2) Q
  | eval_alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      eval (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    eval sa (trm_alloc x n t2) Q

  | eval_for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    eval s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    eval s (trm_for x n₁ n₂ t₁) Q
  | eval_while (t₁ t₂ : trm) (Q : val -> state -> Prop) :
    eval s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> eval s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    eval s (trm_while t₁ t₂) Q

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

hsingle

def hsingle (p : loc) (v : val) : hProp :=
  fun h => (h = Finmap.singleton p v)

evalExact

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

subst

def subst (y : var) (v' : val) (t : trm) : trm :=

  let if_y_eq x t1 t2 := if x = y then t1 else t2
  match t with
  | trm_val v          => trm_val v
  | trm_var x          => if_y_eq x (trm_val v') t
  | trm_fun x t1       => trm_fun x (if_y_eq x t1 (subst y v' t1))
  | trm_fix f x t1     => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y v' t1)))
  | trm_app t1 t2      => trm_app (subst y v' t1) (subst y v' t2)
  | trm_seq t1 t2      => trm_seq (subst y v' t1) (subst y v' t2)
  | trm_let x t1 t2    => trm_let x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_if t0 t1 t2    => trm_if (subst y v' t0) (subst y v' t1) (subst y v' t2)
  | trm_for x t1 t2 t3 => trm_for x (subst y v' t1) (subst y v' t2) (if_y_eq x t3 (subst y v' t3))
  | trm_while t1 t2    => trm_while (subst y v' t1) (subst y v' t2)
  | trm_ref x t1 t2    => trm_ref x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_alloc x t1 t2  => trm_alloc x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))

HWand

class HWand (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hWand : α → β → γ

himpl

abbrev himpl (H1 H2 : hProp) : Prop :=
  forall h, H1 h -> H2 h

purepostin

def purepostin (s : state) (P : val → Prop) (Q : val → state → Prop) : Prop :=

  forall v, P v → Q v s

state

abbrev state := Finmap (λ _ : loc ↦ val)

qimpl

def qimpl {A} (Q1 Q2 : A → hProp) : Prop :=
  forall (v:A), Q1 v ==> Q2 v

hempty

def hempty : hProp :=
  fun h => (h = ∅)

hforall

def hforall {A} (J : A → hProp) : hProp :=
  fun h => forall x, J x h

infixr:51 " ==> " => himpl

infixr:51 " ===> " => qimpl

notation:max "emp" => hempty

infixr:60 " ~~> " => hsingle

infixr:55 " ∗ " => HStar.hStar

infixr:55 " -∗ " => HWand.hWand

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

lemma eval_conseq s t Q1 Q2 :
  eval s t Q1 →
  Q1 ===> Q2 →
  eval s t Q2

lemma hwand_inv h1 h2 H1 H2 :
  (H1 -∗ H2) h2 →
  H1 h1 →
  Finmap.Disjoint h1 h2 →
  H2 (h1 ∪ h2)

lemma hsingl_inv p v h :
  (p ~~> v) h →
  h = Finmap.singleton p v

lemma hforall_inv A (J : A → hProp) h :
  (hforall J) h → forall x, J x h

lemma union_singleton_eq_insert (h : state) :
  Finmap.singleton p v ∪ h = h.insert p v

lemma insert_delete_id (h : state) (p : loc) :
  p ∉ h →
  h = (h.insert p v).erase p

Theories.wp

import Lean

import Mathlib.Data.Finmap

import Mathlib.Data.List.Indexes

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Theories.SepLog

import SPLean.Theories.WPUtil

open trm val prim

namespace Theories

def wp (t : trm) (Q : val → hProp) : hProp :=
  fun s ↦ eval s t Q

lemma wp_ref x v t Q :
  (h∀ p, (p ~~> v) -∗ wp (subst x p t) (Q ∗ ∃ʰ v', (p ~~> v'))) ==>
  wp (trm_ref x v t) Q :=

:=
by
  move=> > /hforall_inv hwp
  apply (eval.eval_ref _ _ _ _ _ (fun v' s' ↦ v' = v ∧ s' = h))=> //== > ?
  apply (eval_conseq _ _ (Q ∗ ∃ʰ v', p ~~> v' ))
  { move: (hwp p)=> {hwp} /(hwand_inv (Finmap.singleton p v))
    srw union_singleton_eq_insert=> wp
    apply wp=> //
    sby unfold Finmap.Disjoint=> > /== -> }
  move=> > s ![>] ? [v'] /= /hsingl_inv -> hdis ->
  srw Finmap.union_comm_of_disjoint=> //
  srw union_singleton_eq_insert -insert_delete_id=> //
  move: hdis=> /Finmap.Disjoint.symm
  sby unfold Finmap.Disjoint


import Mathlib.Data.Finmap
import SPLean.Common.Heap
import Mathlib.Data.Real.Basic
import SPLean.Common.Util

syntax "fun" ident+ " => " lang : lang

syntax "fun" ident+ " => " lang : lang

syntax "if " lang "then " lang "end " : lang

syntax " <= " : bop

syntax " >= " : bop

syntax "not" : uop

syntax " := " : bop

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "ref" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "fix" ident ident+ " => " lang : lang

syntax "for" ident " in " "[" lang " : " lang "]" " {"  (ppLine lang) ( " }") : lang

syntax "while" lang  " {"  (ppLine lang) ( " }") : lang

syntax "alloc" lang " as " ident " in" ppDedent(ppLine lang) : lang

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

var

abbrev var := String

loc

abbrev loc := Nat

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

prim

def null : loc := 0

evalExact

import Mathlib.Data.Finmap

import Mathlib.Data.Real.Basic

import SPLean.Common.Util

import SPLean.Common.Heap

open Classical

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

def null : loc := 0

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

end

abbrev state := Finmap (λ _ : loc ↦ val)

section

open trm

abbrev trm_is_val : trm → Prop
  | trm_val _ => true
  | _         => false

def subst (y : var) (v' : val) (t : trm) : trm :=

  let if_y_eq x t1 t2 := if x = y then t1 else t2
  match t with
  | trm_val v          => trm_val v
  | trm_var x          => if_y_eq x (trm_val v') t
  | trm_fun x t1       => trm_fun x (if_y_eq x t1 (subst y v' t1))
  | trm_fix f x t1     => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y v' t1)))
  | trm_app t1 t2      => trm_app (subst y v' t1) (subst y v' t2)
  | trm_seq t1 t2      => trm_seq (subst y v' t1) (subst y v' t2)
  | trm_let x t1 t2    => trm_let x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_if t0 t1 t2    => trm_if (subst y v' t0) (subst y v' t1) (subst y v' t2)
  | trm_for x t1 t2 t3 => trm_for x (subst y v' t1) (subst y v' t2) (if_y_eq x t3 (subst y v' t3))
  | trm_while t1 t2    => trm_while (subst y v' t1) (subst y v' t2)
  | trm_ref x t1 t2    => trm_ref x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_alloc x t1 t2  => trm_alloc x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))

noncomputable def is_true (P : Prop) : Bool :=
  if P then true else false

open val

open prim

def read_state (p : loc) (h : state) :=
  match Finmap.lookup p h with
  | some v => v
  | none   => default

inductive evalunop : prim → val → (val → Prop) → Prop where
  | evalunop_neg : forall b1,
      evalunop val_neg (val_bool b1) (fun v => v = val_bool (¬ b1))
  | evalunop_opp : forall n1,
      evalunop val_opp (val_int n1) (fun v => v = val_int (- n1))
  | evalunop_oppr : forall r1,
      evalunop val_opp (val_real r1) (fun v => v = val_real (- r1))

inductive evalbinop : val → val → val → (val->Prop) → Prop where
  | evalbinop_eq : forall v1 v2,
      evalbinop val_eq v1 v2 (fun v => v = val_bool (is_true (v1 = v2)))
  | evalbinop_neq : forall v1 v2,
      evalbinop val_neq v1 v2 (fun v => v = val_bool (is_true (v1 ≠ v2)))
  | evalbinop_add : forall n1 n2,
      evalbinop val_add (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 + n2))
  | evalbinop_addr : forall r₁ r₂,
      evalbinop val_add (val_real r₁) (val_real r₂)
        (fun v => v = val_real (r₁ + r₂))
  | evalbinop_sub : forall n1 n2,
      evalbinop val_sub (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 - n2))
  | evalbinop_subr : forall r1 r2,
      evalbinop val_sub (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 - r2))
  | evalbinop_mul : forall n1 n2,
      evalbinop val_mul (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 * n2))
  | evalbinop_mulr : forall r1 r2,
      evalbinop val_mul (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 * r2))
  | evalbinop_div : forall n1 n2,
      ¬(n2 = 0) →
      evalbinop val_div (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 / n2))
  | evalbinop_divr : forall r1 r2,
      ¬(r2 = 0) →
      evalbinop val_div (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 / r2))
  | evalbinop_mod : forall n1 n2,
      ¬(n2 = 0) →
      evalbinop val_mod (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 % n2))
  | evalbinop_le : forall n1 n2,
      evalbinop val_le (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 <= n2))
  | evalbinop_ler : forall r1 r2,
      evalbinop val_le (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 <= r2))
  | evalbinop_lt : forall n1 n2,
      evalbinop val_lt (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 < n2))
  | evalbinop_ltr : forall r1 r2,
      evalbinop val_lt (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 < r2))
  | evalbinop_ge : forall n1 n2,
      evalbinop val_ge (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 >= n2))
  | evalbinop_ger : forall r1 r2,
      evalbinop val_ge (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 >= r2))
  | evalbinop_gt : forall n1 n2,
      evalbinop val_gt (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 > n2))
  | evalbinop_gtr : forall r1 r2,
      evalbinop val_gt (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 > r2))

  | evalbinop_ptr_add : forall (p1 : loc) (p2 : Int) n,
      p2 = p1 + n ->
      evalbinop val_ptr_add (val_loc p1) (val_int n)
        (fun v => v = val_loc (Int.natAbs p2))

section eval

def purepost (s : state) (P : val → Prop) : val → state → Prop :=
  fun v s' => P v ∧ s' = s

def purepostin (s : state) (P : val → Prop) (Q : val → state → Prop) : Prop :=

  forall v, P v → Q v s

variable (Q : val → state → Prop)

def conseq {B : Type} (vs : List B) (l : Nat) : Finmap (fun _ : Nat ↦ B) :=
  match vs with
  | [] => ∅
  | v :: vs' => (Finmap.singleton l v) ∪ (conseq vs' (l + 1))

def make_list {A} (n : Nat) (v : A) : List A :=
  match n with
  | 0      => []
  | n' + 1 => v :: make_list n' v

inductive eval : state → trm → (val → state → Prop) -> Prop where
  | eval_val : forall s v Q,
      Q v s ->
      eval s (trm_val v) Q
  | eval_fun : forall s x t1 Q,
      Q (val_fun x t1) s ->
      eval s (trm_fun x t1) Q
  | eval_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      eval s (trm_fix f x t1) Q
  | eval_app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      eval s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
      eval s1 (trm_app t1 t2) Q
  | eval_app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      eval s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> eval s2 (trm_app v1 v2) Q) ->
      eval s1 (trm_app v1 t2) Q
  | eval_app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) Q ->
      eval s1 (trm_app v1 v2) Q
  | eval_app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      eval s (subst x v2 (subst f v1 t1)) Q ->
      eval s (trm_app v1 v2) Q
  | eval_seq : forall Q1 s t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 t2 Q) ->
      eval s (trm_seq t1 t2) Q
  | eval_let : forall Q1 s x t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (subst x v1 t2) Q) ->
      eval s (trm_let x t1 t2) Q
  | eval_if : forall s (b : Bool) t1 t2 Q,
      eval s (if b then t1 else t2) Q ->
      eval s (trm_if (val_bool b) t1 t2) Q
  | eval_unop : forall op s v1 P Q,
      evalunop op v1 P ->
      purepostin s P Q ->
      eval s (trm_app op v1) Q
  | eval_binop : forall op s (v1 v2 : val) P Q,
      evalbinop op v1 v2 P ->
      purepostin s P Q ->
      eval s (trm_app (trm_app op v1) v2) Q
  | eval_ref : forall s x t1 t2 (Q Q₁ : val → state → Prop),
    eval s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     eval (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
    eval s (trm_ref x t1 t2) Q
  | eval_get : forall s p Q,
      p ∈ s ->
      Q (read_state p s) s ->
      eval s (trm_app val_get (val_loc p)) Q
  | eval_set : forall s p v Q,
      v = trm_val v' ->
      p ∈ s ->
      Q val_unit (Finmap.insert p v' s) ->
      eval s (trm_app (trm_app val_set (val_loc p)) v) Q
  | eval_alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    eval s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → eval s' (trm_alloc x v' t2) Q) →
    eval s (trm_alloc x t1 t2) Q
  | eval_alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      eval (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    eval sa (trm_alloc x n t2) Q

  | eval_for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    eval s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    eval s (trm_for x n₁ n₂ t₁) Q
  | eval_while (t₁ t₂ : trm) (Q : val -> state -> Prop) :
    eval s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> eval s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    eval s (trm_while t₁ t₂) Q

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

lemma exact_imp_eval :
  evalExact s t Q → eval s t Q :=

:= by
  elim=> >
  { sby constructor }
  { sby constructor }
  { sby constructor }
  { move=> * ; sby constructor }
  { move=> * ; sby apply eval.eval_app_arg2 }
  { move=> * ; sby apply eval.eval_app_fun }
  { move=> * ; sby apply eval.eval_app_fix }
  { move=> ??? h ; apply (eval.eval_seq Q1)=>// ; exact h }
  { move=> * ; sby constructor }
  { move=> * ; sby constructor }
  { move=> * ; apply eval.eval_unop=> //
    sby unfold purepostin purepost }
  { move=> * ; apply eval.eval_binop=> //
    sby unfold purepostin purepost }
  { move=> * ; sby apply eval.eval_ref }
  { move=> * ; sby apply eval.eval_get }
  { move=> * ; sby apply eval.eval_set }
  { move=> * ; sby apply eval.eval_alloc_arg }
  { move=> * ; sby apply eval.eval_alloc }
  { move=> ?ih ; sby constructor }
  move=> * ; sby constructor


toUpperTri

def toUpperTri (A : Matrix (Fin n) (Fin n) Float) : Matrix (Fin n) (Fin n) Float :=
  fun i j => if i ≤ j then A i j else 0

PosDef.Invertible

noncomputable instance PosDef.Invertible [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.PosDef) :
    Invertible M :=
  invertibleOfIsUnitDet M (isUnit_iff_ne_zero.2 hM.det_ne_zero)

diag

def diag {n} {α} (M : Matrix n n α) : n → α :=
  fun i => M i i

det

def det {n : ℕ} (A : Matrix (Fin n) (Fin n) Float) : Float :=
  if h : 0 < n then
    if n == 1 then A ⟨0, h⟩ ⟨0, h⟩ else
      (List.finRange n).foldl (fun s i =>
        s + (-1) ^ (Float.ofNat i.val) * A i ⟨0, h⟩ * det (minor A i ⟨0, h⟩)) 0
  else 0

minor

def minor (A : Matrix (Fin n) (Fin n) Float) (a b : Fin n) :
    Matrix (Fin n.pred) (Fin n.pred) Float :=
  match n with
  | 0 => fun _ => Fin.elim0
  | _ + 1 => minorAux A a b

minorAux

private def minorAux (A : Matrix (Fin n.succ) (Fin n.succ) Float) (a b : Fin n.succ) :
    Matrix (Fin n) (Fin n) Float :=
  fun i j =>
    let i' : Fin n.succ := if i.val < a.val then i else i.succ;
    let j' : Fin n.succ := if j.val < b.val then j else j.succ;
    A i' j'

toUpperTri

def toUpperTri {m α : Type _} [LinearOrder m] [Zero α] (A : Matrix m m α) :
    Matrix m m α :=
  fun i j => if i ≤ j then A i j else 0

IsHermitian.sqrt

noncomputable def IsHermitian.sqrt {A : Matrix n n ℝ} (hA : A.IsHermitian) : Matrix n n ℝ :=
  hA.eigenvectorMatrix * Matrix.diagonal (fun i => (hA.eigenvalues i).sqrt) * hA.eigenvectorMatrixᵀ

SymmMatrixVariable

structure SymmMatrixVariable where
  index  : Nat
  name   : String
  I      : Nat
  J      : Nat
  primal : Option Float
  dual   : Option Float

instance : ToString SymmMatrixVariable where
  toString smv :=
    s!"{smv.index} | " ++
    s!"{smv.name} | " ++
    s!"{smv.I} | " ++
    s!"{smv.J} | " ++
    s!"{smv.primal} | " ++
    s!"{smv.dual}"

Result

structure Result where
  summary        : Summary
  constraints    : List Constraint
  vars           : List Variable
  symmMatrixVars : List SymmMatrixVariable

instance : ToString Result where
  toString res :=
    (toString res.summary) ++ "\n" ++
    "CONSTRAINTS \n" ++
    "INDEX | NAME | AT | ACTIVITY | LOWER LIMIT | UPPER LIMIT | DUAL LOWER | DUAL UPPER \n" ++
    (res.constraints.foldl (fun acc s => acc ++ (toString s) ++ "\n") "") ++ "\n" ++
    "VARIABLES \n" ++
    "INDEX | NAME | AT | ACTIVITY | LOWER LIMIT | UPPER LIMIT | DUAL LOWER | DUAL UPPER | " ++
    "CONIC DUAL \n" ++
    (res.vars.foldl (fun acc s => acc ++ (toString s) ++ "\n") "") ++ "\n" ++
    "SYMMETRIC MATRIX VARIABLES \n" ++
    "INDEX | NAME | I | J | PRIMAL | DUAL \n" ++
    (res.symmMatrixVars.foldl (fun acc s => acc ++ (toString s) ++ "\n") "") ++ "\n"

symmMatrixVarsTitle

private def symmMatrixVarsTitle : Parsec Unit :=
  skipString "SYMMETRIC MATRIX VARIABLES" <* endOfLine

symmMatrixVarsHeaders

private def symmMatrixVarsHeaders : Parsec Unit :=
  skipString "INDEX"  <* ws' <*
  skipString "NAME"   <* ws' <*
  skipString "I"      <* ws' <*
  skipString "J"      <* ws' <*
  skipString "PRIMAL" <* ws' <*
  skipString "DUAL"   <* ws' <* endOfLine

symmMatrixVar

private def symmMatrixVar : Parsec SymmMatrixVariable :=
  SymmMatrixVariable.mk <$>
  constraintElem nat         <*>
  constraintElem string      <*>
  constraintElem nat         <*>
  constraintElem nat         <*>
  constraintElem optionFloat <*>
  constraintElem optionFloat <* ws' <* endOfLine

symmMatrixVars

private def symmMatrixVars : Parsec (List SymmMatrixVariable) :=
  (symmMatrixVarsTitle  *>
  symmMatrixVarsHeaders *>
  Array.data <$> many symmMatrixVar) <|> pure []

result

def result : Parsec Result :=
  Result.mk <$>
  summary        <* ws <*>
  constraints    <* ws <*>
  vars           <* ws <*>
  symmMatrixVars <* ws

inferDimension

unsafe def inferDimension (ty : Expr) : MetaM (List (Nat × Nat)) :=
  match ty.consumeMData with
  | .const ``Real _ =>
      return [(1, 1)]
  | .forallE _ (.app (.const ``Fin _) nExpr) e _ =>
    match e with
    | .const ``Real _  => do
      let n : Nat ← evalExpr Nat (mkConst ``Nat) nExpr
      return [(n, 1)]
    | .forallE _ (.app (.const ``Fin _) mExpr) (.const ``Real _) _ => do
      let n : Nat ← evalExpr Nat (mkConst ``Nat) nExpr
      let m : Nat ← evalExpr Nat (mkConst ``Nat) mExpr
      return [(n, m)]
    | _ => throwSolveError "could not infer dimension of {ty}."
  | .app (.app (.app M FinN) FinM) R => do
    match (M, FinN, FinM, R) with
    | (.const ``Matrix _, .app (.const ``Fin _) nExpr, .app (.const ``Fin _) mExpr,
        .const ``Real _) =>
      let n : Nat ← evalExpr Nat (mkConst ``Nat) nExpr
      let m : Nat ← evalExpr Nat (mkConst ``Nat) mExpr
      return [(n, m)]
    | _ => throwSolveError "could not infer dimension of {ty}."
  | .app (.app (.const ``Prod _) tyl) tyr => do
    let l ← inferDimension tyl
    let r ← inferDimension tyr
    return (l ++ r)
  | _ => throwSolveError "could not infer dimension of {ty}."

ofProblemData

unsafe def ofProblemData (minExpr : MinimizationExpr) (data : ProblemData)
    (sections : ScalarAffineSections) : MetaM CBF.Problem := do
  let totalDim ← getTotalDim minExpr

  let mut cbf := CBF.Problem.empty
  cbf := cbf.addScalarVariable (CBF.Cone.mk CBF.ConeType.F totalDim)

  if h : data.objective.isSome then
    let sa := data.objective.get h
    let AEnc := CBF.EncodedMatrixList.fromArray #[sa.A]
    let aEnc := CBF.EncodedVector.fromArray sa.a
    let bEnc := CBF.EncodedValue.mk (some sa.b)
    cbf := cbf.setObjectivePSDVariablesCoord AEnc
    cbf := cbf.setObjectiveScalarVariablesCoord aEnc
    cbf := cbf.setObjectiveShiftCoord bEnc

  for (sa, sct) in data.scalarAffineConstraints do
    let coneType := translateCone sct
    let cone := CBF.Cone.mk coneType 1
    let AEnc := CBF.EncodedMatrixList.fromArray #[sa.A]
    let aEnc := CBF.EncodedVector.fromArray sa.a
    let bEnc := sa.b
    cbf := cbf.addScalarValuedAffineConstraint cone AEnc aEnc bEnc

  for ma in data.matrixAffineConstraints do
    let HEnc := CBF.EncodedMatrixList.fromArray ma.H
    let DEnc := CBF.EncodedMatrix.fromArray ma.D
    cbf := cbf.addMatrixValuedAffineConstraint ma.n HEnc DEnc

  let n := cbf.scalarConstraints.n
  let cones := cbf.scalarConstraints.cones
  let groupedCones ← groupCones sections cones
  cbf := cbf.setScalarConstraints (CBF.ConeProduct.mk n groupedCones.length groupedCones)

  return cbf

SimpleMatrixVarSol

structure SimpleMatrixVarSol where
  name  : String
  I     : Nat
  J     : Nat
  value : Option Float

instance : ToString SimpleMatrixVarSol where
  toString v :=
    match v.value with
    | some x => v.name ++ "[" ++ toString v.I ++ ", " ++ toString v.J ++ "]* = " ++ toString x
    | none   => "none"

SolutionData

structure SolutionData where
  status         : String
  varsSols       : List SimpleVarSol
  matrixVarsSols : List SimpleMatrixVarSol

instance : ToString SolutionData where
  toString s :=
    "Status: " ++ s.status ++ "\n" ++
    "Variables: (" ++ ", ".intercalate (s.varsSols.map toString) ++ ")\n" ++
    "Matrix variables: (" ++ ", ".intercalate (s.matrixVarsSols.map toString) ++ ")"

p

def p :=
  optimization (x y : ℝ)
    minimize -2 * x
    subject to
      c₁ : 0 ≤ x
      c₂ : 1 < y
      c₃ : log (y - 1) ≤ 2 * sqrt x + 1
      c₄ : 3 * x + 5 * y ≤ 10

-- Transform (proving `p ≡ q`).

equivalence* eqv/q : p :=

const

def const (k : α) : Matrix m n α :=
  fun _ _ => k

[Preorder

instance [Preorder α] : Preorder (Matrix m n α) where
  le := fun A B => ∀ i j, A i j ≤ B i j
  le_refl := fun _ _ _ => le_refl _
  le_trans := fun _ _ _ hAB hBC i j => le_trans (hAB i j) (hBC i j)
  lt_iff_le_not_le := fun _ _ => refl _

abs

def abs (A : Matrix m n ℝ) : Matrix m n ℝ :=
  fun i j => |A i j|

sum

def sum [Fintype m] [AddCommMonoid α] (X : Matrix m m α) : α :=
  ∑ i, (∑ j, X i j)

toArray

def toArray (A : Matrix (Fin n) (Fin n) Float) : Array (Array Float) :=
  (Array.range n).map <| fun i =>
    if h : i < n then Vec.Computable.toArray (A ⟨i, h⟩) else Array.mk <| List.replicate n 0

dotProduct

def dotProduct (v w : Fin n → Float) : Float :=
  (Array.zipWith (Vec.Computable.toArray v) (Vec.Computable.toArray w) Float.mul).foldl Float.add 0

mulVec

def mulVec (M : Matrix (Fin n) (Fin m) Float) (v : (Fin m) → Float) : Fin n → Float :=
  fun i => (fun j => M i j) ⬝ᵥᶜ v

vecMul

def vecMul (x : Fin n → Float) (M : Matrix (Fin n) (Fin m) Float) : Fin m → Float :=
  fun j => x ⬝ᵥᶜ fun i => M i j

transpose

def transpose {m n} {α} (M : Matrix m n α) : Matrix n m α :=
  fun i j => M j i

diag

def diag {n} {α} (M : Matrix n n α) : n → α :=
  fun i => M i i

mul

def mul (M : Matrix (Fin l) (Fin m) Float) (N : Matrix (Fin m) (Fin n) Float) :
    Matrix (Fin l) (Fin n) Float :=
  fun i k => (fun j => M i j) ⬝ᵥᶜ (fun j => N j k)

sum

def sum (A : Matrix (Fin n) (Fin n) Float) : Float :=
  Vec.Computable.sum (fun i => Vec.Computable.sum (A i))

trace

def trace (A : Matrix (Fin n) (Fin n) Float) : Float :=
  (Vec.Computable.toArray (fun i => A i i)).foldl (· + ·) 0

covarianceMatrix

def covarianceMatrix {N n : ℕ} (Y : Matrix (Fin N) (Fin n) Float) (i j : Fin n) : Float :=
  Vec.Computable.sum (fun k => (Y k i) * (Y k j)) / (OfNat.ofNat N)

diagonal

def diagonal (x : Fin n → Float) : Matrix (Fin n) (Fin n) Float :=
  fun i j => (if i = j then x i else 0)

fromBlocks

def fromBlocks {l : Type} {m : Type} {n : Type} {o : Type} {α : Type} :
    Matrix n l α → Matrix n m α → Matrix o l α → Matrix o m α → Matrix (n ⊕ o) (l ⊕ m) α :=
  fun A B C D i j =>
    match i with
    | Sum.inl i =>
      match j with
      | Sum.inl j => A i j
      | Sum.inr j => B i j
    | Sum.inr i =>
      match j with
      | Sum.inl j => C i j
      | Sum.inr j => D i j

inv

def inv (A : Matrix (Fin n) (Fin n) Float) : Matrix (Fin n) (Fin n) Float :=
  (1 / det A) • adjugate A

adjugate

def adjugate (A : Matrix (Fin n) (Fin n) Float) : Matrix (Fin n) (Fin n) Float :=
  transpose (cofactor A)

cofactor

def cofactor (A : Matrix (Fin n) (Fin n) Float) : Matrix (Fin n) (Fin n) Float :=
  fun i j => (-1) ^ (Float.ofNat (i.val + j.val)) * (A i j)

upperTriangular

def upperTriangular [LT m] (M : Matrix m m R) :=
  M.BlockTriangular id

zeroCone

def zeroCone (x : ℝ) : Prop :=
  x = 0

Vec.zeroCone

def Vec.zeroCone {n} [Fintype n] (x : n → ℝ) : Prop :=
  ∀ i, Real.zeroCone (x i)

Matrix.zeroCone

def Matrix.zeroCone {n m} [Fintype n] [Fintype m] (M : Matrix n m ℝ) : Prop :=
  ∀ i j, Real.zeroCone (M i j)

addMatrixAffineConstraint

def addMatrixAffineConstraint (data : ProblemData) (H : Array (Array (Array Float)))
    (D : Array (Array Float)) : ProblemData :=
  let constraint := MatrixAffine.mk D.size H D
  { data with matrixAffineConstraints := data.matrixAffineConstraints.push constraint }

lowerTriangular

def lowerTriangular [LT m] (M : Matrix m m R) :=
  M.BlockTriangular OrderDual.toDual

Matrix.PSDCone

def Matrix.PSDCone {n} [Fintype n] (A : Matrix n n ℝ) : Prop :=
  Matrix.PosSemidef A

lemma Real.one_sub_div_exp_pos_of_pos {x : ℝ} : 0 < x → 0 < 1 - 1 / Real.exp x

evalOneSubDivExp

@[positivity (1 - (1 / (Real.exp (_ : ℝ))))]
def evalOneSubDivExp : PositivityExt where eval {_ _α} zα pα e := do
  let (.app (.app _sub _one) (.app (.app _div _one') (.app _exp (x : Q(ℝ))))) ←
    withReducible (whnf e) | throwError "not (1 - 1 / Real.exp x)"
  match ← core zα pα x with
  | .positive pa =>
      let pa' ← mkAppM ``Real.one_sub_div_exp_pos_of_pos #[pa]
      pure (.positive pa')
  | _ =>
      pure .none

lemma PosSemidef.PosDef_iff_det_ne_zero [DecidableEq n] {M : Matrix n n ℝ} (hM : M.PosSemidef) :
    M.PosDef ↔ M.det ≠ 0

lemma PosSemidef.PosSemidef_sqrt {A : Matrix n n ℝ} (hA : A.PosSemidef) :
    hA.1.sqrt.PosSemidef

PosSemidef.add

lemma PosSemidef.add {M N : Matrix n n 𝕜} (hM : M.PosSemidef) (hN : N.PosSemidef) :
    (M + N).PosSemidef

@[simp]
lemma PosSemidef.sqrt_mul_sqrt {A : Matrix n n ℝ} (hA : A.PosSemidef) :
    hA.1.sqrt * hA.1.sqrt = A

lemma PosSemidef.conjTranspose_mul_mul (M N : Matrix n n 𝕜) (hM : M.PosSemidef) :
    (Nᴴ * M * N).PosSemidef

lemma eigenvectorMatrix_inv_mul : hA.eigenvectorMatrixInv * hA.eigenvectorMatrix = 1

theorem spectral_theorem'' :
    hA.eigenvectorMatrix * diagonal (RCLike.ofReal ∘ hA.eigenvalues) * hA.eigenvectorMatrixᴴ =
    A

lemma conjTranspose_eq_transpose {m n : Type _} {A : Matrix m n ℝ} : Aᴴ = Aᵀ

lemma IsHermitian.fromBlocks₁₁ [Fintype m] [DecidableEq m] {A : Matrix m m 𝕜} (B : Matrix m n 𝕜)
    (D : Matrix n n 𝕜) (hA : A.IsHermitian) :
    (Matrix.fromBlocks A B Bᴴ D).IsHermitian ↔ (D - Bᴴ * A⁻¹ * B).IsHermitian

lemma IsHermitian.fromBlocks₂₂ [Fintype n] [DecidableEq n] (A : Matrix m m 𝕜) (B : Matrix m n 𝕜)
    {D : Matrix n n 𝕜} (hD : D.IsHermitian) :
    (Matrix.fromBlocks A B Bᴴ D).IsHermitian ↔ (A - B * D⁻¹ * Bᴴ).IsHermitian

lemma PosSemidef.fromBlocks₁₁ [Fintype m] [DecidableEq m] [Fintype n] {A : Matrix m m 𝕜}
    (B : Matrix m n 𝕜) (D : Matrix n n 𝕜) (hA : A.PosDef) [Invertible A] :
    (fromBlocks A B Bᴴ D).PosSemidef ↔ (D - Bᴴ * A⁻¹ * B).PosSemidef

lemma PosSemidef.fromBlocks₂₂ [Fintype m] [Fintype n] [DecidableEq n] (A : Matrix m m 𝕜)
    (B : Matrix m n 𝕜) {D : Matrix n n 𝕜} (hD : D.PosDef) [Invertible D] :
    (fromBlocks A B Bᴴ D).PosSemidef ↔ (A - B * D⁻¹ * Bᴴ).PosSemidef

lemma schur_complement_eq₁₁ [Fintype m] [DecidableEq m] [Fintype n] {A : Matrix m m 𝕜}
    (B : Matrix m n 𝕜) (D : Matrix n n 𝕜) (x : m → 𝕜) (y : n → 𝕜) [Invertible A]
    (hA : A.IsHermitian) :
    vecMul (star (x ⊕ᵥ y)) (fromBlocks A B Bᴴ D) ⬝ᵥ (x ⊕ᵥ y) =
      vecMul (star (x + (A⁻¹ * B).mulVec y)) A ⬝ᵥ (x + (A⁻¹ * B).mulVec y) +
        vecMul (star y) (D - Bᴴ * A⁻¹ * B) ⬝ᵥ y

lemma schur_complement_eq₂₂ [Fintype m] [Fintype n] [DecidableEq n] (A : Matrix m m 𝕜)
    (B : Matrix m n 𝕜) {D : Matrix n n 𝕜} (x : m → 𝕜) (y : n → 𝕜) [Invertible D]
    (hD : D.IsHermitian) :
    vecMul (star (x ⊕ᵥ y)) (fromBlocks A B Bᴴ D) ⬝ᵥ (x ⊕ᵥ y) =
      vecMul (star ((D⁻¹ * Bᴴ).mulVec x + y)) D ⬝ᵥ ((D⁻¹ * Bᴴ).mulVec x + y) +
        vecMul (star x) (A - B * D⁻¹ * Bᴴ) ⬝ᵥ x

lemma IsHermitian.nonsingular_inv [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.IsHermitian)
    (hMdet : IsUnit M.det) : M⁻¹.IsHermitian

lemma PosDef.isUnit_det [DecidableEq n] {M : Matrix n n ℝ} (hM : M.PosDef) : IsUnit M.det

lemma PosDef.nonsingular_inv [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.PosDef) : M⁻¹.PosDef

lemma PosDef.det_ne_zero [DecidableEq n] {M : Matrix n n 𝕜} (hM : M.PosDef) : M.det ≠ 0

lemma PosDef.PosDef_sqrt {A : Matrix n n ℝ} (hA : A.PosDef) : hA.1.sqrt.PosDef

lemma PosDef.conjTranspose_mul_mul [DecidableEq n] (M N : Matrix n n 𝕜) (hM : M.PosDef)
    (hN : N.det ≠ 0) : (Nᴴ * M * N).PosDef

PosSemiDef.IsSymm

lemma PosSemiDef.IsSymm {n} {A : Matrix (Fin n) (Fin n) ℝ} (hA : PosSemidef A) : IsSymm A

lemma PosSemidef.det_nonneg {M : Matrix n n ℝ} (hM : M.PosSemidef) [DecidableEq n] : 0 ≤ det M

lemma isUnit_det_of_PosDef_inv [DecidableEq n] {M : Matrix n n ℝ} (h : M⁻¹.PosDef) :
    IsUnit M.det

lemma PosDef_inv_iff_PosDef [DecidableEq n] (M : Matrix n n ℝ) : M⁻¹.PosDef ↔ M.PosDef

lemma conj_symm {x : n → 𝕜} {M : Matrix n n 𝕜} (hM : M.IsHermitian) :
    star (star x ⬝ᵥ mulVec M x) = star x ⬝ᵥ mulVec M x

lemma det_add_det_le_det_add [Nonempty n] (A B : Matrix n n ℝ) (hA : A.PosSemidef)
    (hB : B.PosSemidef) : A.det + B.det ≤ (A + B).det

lemma det_add_det_le_det_add' [Nonempty n] (A B : Matrix n n ℝ) (hA : A.PosDef)
    (hB : B.PosSemidef) : A.det + B.det ≤ (A + B).det

lemma sum_exp_eq_sum_div {n} (x : Fin n → ℝ) (t : ℝ) :
    Vec.sum (Vec.exp (x - Vec.const n t)) = (Vec.sum (Vec.exp x)) / (Real.exp t)

lemma sum_exp_pos {n} (hn : 0 < n) (x : Fin n → ℝ) :
    0 < Vec.sum (Vec.exp x)

lemma eigenspace_add {f g : End R M} {a b : R} :
    eigenspace f a ⊓ eigenspace g b ≤ eigenspace (f + g) (a + b)

lemma eigenspace_one : eigenspace (1 : End R M) 1 = ⊤

lemma has_eigenvector_add {f g : End R M} {a b : R} {x : M} (hf : HasEigenvector f a x)
    (hg : HasEigenvector g b x) : HasEigenvector (f + g) (a + b) x

lemma has_eigenvector_one {x : M} (hx : x ≠ 0) : HasEigenvector (1 : End R M) 1 x

lemma IsHermitian.has_eigenvector_one_add {A : Matrix n n ℝ} (hA : A.IsHermitian) (i : n) :
    Module.End.HasEigenvector
      (1 + Matrix.toLin' A) (1 + (hA.eigenvalues i)) ((hA.eigenvectorBasis) i)

lemma one_add_prod_le_prod_one_add {n : Type _} [Fintype n] [Nonempty n]
    (f : n → ℝ) (hf : ∀ i, 0 ≤ f i) : 1 + (∏ i, f i) ≤ ∏ i, (1 + f i)

BlockTriangular.zero

lemma BlockTriangular.zero : BlockTriangular (0 : Matrix m m R) b

lemma BlockTriangular_diagonal [DecidableEq m] (d : m → R) :
    BlockTriangular (diagonal d) b

lemma BlockTriangular_blockDiagonal' [DecidableEq α]
    (d : ∀ (i : α), Matrix (m' i) (m' i) R) :
    BlockTriangular (blockDiagonal'  d) Sigma.fst

lemma BlockTriangular_blockDiagonal [DecidableEq α] (d : α → Matrix m m R) :
    BlockTriangular (blockDiagonal d) Prod.snd

lemma toBlock_inverse_mul_toBlock_eq_one_of_BlockTriangular [LinearOrder α]
    [Invertible M] (hM : BlockTriangular M b) (k : α) :
    M⁻¹.toBlock (fun i => b i < k) (fun i => b i < k) *
  M.toBlock (fun i => b i < k) (fun i => b i < k) = 1

lemma inv_toBlock_of_BlockTriangular [LinearOrder α]
    [Invertible M] (hM : BlockTriangular M b) (k : α) :
    (M.toBlock (fun i => b i < k) (fun i => b i < k))⁻¹ =
    M⁻¹.toBlock (fun i => b i < k) (fun i => b i < k)

lemma toSquareBlock_inv_mul_toSquareBlock_eq_one [LinearOrder α]
    [Invertible M] (hM : BlockTriangular M b) (k : α) :
    M⁻¹.toSquareBlock b k * M.toSquareBlock b k = 1

theorem toUpperTri_zero {m : Type _} [LinearOrder m] :
    Matrix.toUpperTri (0 : Matrix m m ℝ) = 0

theorem toUpperTri_smul {m : Type _} [LinearOrder m]
    (A : Matrix m m ℝ) (κ : ℝ) :
    κ • Matrix.toUpperTri A = Matrix.toUpperTri (κ • A)

theorem toUpperTri_add {m : Type _} [LinearOrder m]
    (A B : Matrix m m ℝ) :
    Matrix.toUpperTri (A + B) = Matrix.toUpperTri A + Matrix.toUpperTri B

lemma upperTriangular_toUpperTri {m : Type _} [LinearOrder m]
    (A : Matrix m m ℝ) : A.toUpperTri.upperTriangular

lemma upperTriangular.toUpperTri_eq {A : Matrix n n ℝ}
    (hA : upperTriangular A) : A.toUpperTri = A

lemma Real.log_nonneg_of_ge_one {x : ℝ} : 0 ≤ x - 1 → 0 ≤ log x

lemma Real.log_pos_of_gt_one {x : ℝ} : 0 < x - 1 → 0 < log x

lemma Real.one_sub_one_div_sq_nonneg_of_le_one {x : ℝ} :
    0 < x → 0 ≤ 1 - x → 0 ≤ (1 / x ^ (2 : ℝ)) - 1

lemma Real.one_sub_sq_nonneg_of_le_one {x : ℝ} : 0 ≤ x → 0 ≤ 1 - x → 0 ≤ 1 - x ^ (2 : ℝ)

lemma Real.exp_sub_one_pos_of_pos {x : ℝ} : 0 < x → 0 < Real.exp x - 1

lemma Real.one_sub_div_exp_pos_of_pos {x : ℝ} : 0 < x → 0 < 1 - 1 / Real.exp x

lemma Real.scaled_sq_diff_pos_of_pos {a x : ℝ} :
    0 < a - 1 → 0 < x → 0 < (a * x) ^ (2 : ℝ) - x ^ (2 : ℝ)

lemma det_eq_prod_eigenvalues (xs : OrthonormalBasis n 𝕜 (EuclideanSpace 𝕜 n)) (as : n → ℝ)
    (hxs : ∀ j, Module.End.HasEigenvector (Matrix.toLin' A) (as j) (xs j)) : det A = ∏ i, as i

lemma IsHermitian.hasEigenvector_eigenvectorBasis (hA : A.IsHermitian) (i : n) :
    Module.End.HasEigenvector (Matrix.toLin' A) (hA.eigenvalues i) (hA.eigenvectorBasis i)

lemma log_eq_log {x y : ℝ} (hx : 0 < x) (hy : 0 < y) : x = y ↔ log x = log y

theorem exp_iff_expCone (t x : ℝ) : exp x ≤ t ↔ expCone x 1 t

@[simp]
lemma PosSemidef_zero : PosSemidef (0 : Matrix n n 𝕜)

lemma LogDetAtom.feasibility_PosDef {D Z : Matrix n n ℝ} (hD : D = LDL.diag hA)
    (hZ : Z = LDL.diag hA * (LDL.lower hA)ᵀ) : (fromBlocks D Z Zᵀ A).PosSemidef

lemma LogDetAtom.feasibility_PosDef' {D Z Y : Matrix n n ℝ} (hY : Y = LDL.diag hA * (LDL.lower hA)ᵀ)
    (hD : D = diagonal Y.diag) (hZ : Z = Y.toUpperTri) : (fromBlocks D Z Zᵀ A).PosSemidef

lemma LDL.diagEntries_pos {A : Matrix n n ℝ} (hA: A.PosDef) (i : n) :
    0 < LDL.diagEntries hA i

lemma LogDetAtom.solution_eq_atom {A : Matrix n n ℝ} (hA: A.PosDef) :
    ∑ i, Real.log (LDL.diagEntries hA i) = Real.log (A.det)

lemma LogDetAtom.feasibility_exp {A : Matrix n n ℝ} (hA: A.PosDef) (i : n) :
    LDL.diagEntries hA i ≤ ((LDL.diag hA) * ((LDL.lower hA)ᵀ)).diag i

lemma Real.inverse_eq_inv (a : ℝ) : Ring.inverse a = a⁻¹

lemma PosSemidef_diagonal [DecidableEq n] {f : n → ℝ} (hf : ∀ i, 0 ≤ f i) :
    (diagonal f).PosSemidef
lemma PosDef_diagonal [DecidableEq n] {f : n → ℝ} (hf : ∀ i, 0 < f i) : (diagonal f).PosDef

lemma upperTriangular_inv_of_upperTriangular [Fintype m] [LinearOrder m]
    [Invertible M] (hM : upperTriangular M) : upperTriangular M⁻¹

lemma lowerTriangular_inv_of_lowerTriangular [Fintype m] [LinearOrder m]
    [Invertible M] (hM : lowerTriangular M) : lowerTriangular M⁻¹

upperTriangular.mul

lemma upperTriangular.mul [Fintype m] [LinearOrder m] (hM : upperTriangular M)
    (hN : upperTriangular N) : upperTriangular (M * N)

lowerTriangular.mul

lemma lowerTriangular.mul [Fintype m] [LinearOrder m] (hM : lowerTriangular M)
    (hN : lowerTriangular N) : lowerTriangular (M * N)

lowerTriangular.transpose

lemma lowerTriangular.transpose [Fintype m] [LinearOrder m]
    (hM : lowerTriangular M) : upperTriangular Mᵀ

upperTriangular.transpose

lemma upperTriangular.transpose [Fintype m] [LinearOrder m]
    (hM : upperTriangular M) : lowerTriangular Mᵀ

lemma diag_inv_mul_diag_eq_one_of_upperTriangular [Fintype m] [LinearOrder m]
    [Invertible M] (hM : upperTriangular M) (k : m) :
    M⁻¹ k k * M k k = 1

lemma diag_inv_mul_diag_eq_one_of_lowerTriangular [Fintype m] [LinearOrder m]
    [Invertible M] (hM : lowerTriangular M) (k : m) : M⁻¹ k k * M k k = 1

@[simp]
lemma det_lowerInv : (lowerInv hS).det = 1

@[simp]
lemma det_lower : (lower hS).det = 1

lemma lower_eq_to_matrix :
    lower hS =
      ((@gramSchmidtBasis 𝕜 (n → 𝕜) _
        (NormedAddCommGroup.ofMatrix hS.transpose)
        (InnerProductSpace.ofMatrix hS.transpose)
  n _ _ _ (Pi.basisFun 𝕜 n)).toMatrix (Pi.basisFun 𝕜 n))ᵀ

lemma IsHermitian₁₁_of_IsHermitian_toBlock {A B C D : Matrix n n ℝ}
    (h : (fromBlocks A B C D).IsHermitian) : IsHermitian A

lemma IsHermitian₂₂_of_IsHermitian_toBlock {A B C D : Matrix n n ℝ}
    (h : (fromBlocks A B C D).IsHermitian) : IsHermitian D

lemma PosSemidef₁₁_of_PosSemidef_toBlock {A B C D : Matrix n n ℝ}
    (h : (fromBlocks A B C D).PosSemidef) : PosSemidef A

lemma PosSemidef₂₂_of_PosSemidef_toBlock {A B C D : Matrix n n ℝ}
    (h : (fromBlocks A B C D).PosSemidef) :
    PosSemidef D

lemma LogDetAtom.optimality_D_posdef {t : n → ℝ} {Y Z D : Matrix n n ℝ}
    (ht : ∀ i, (t i).exp ≤ Y.diag i) (hD : D = Matrix.diagonal (Y.diag)) (_hZ : Z = Y.toUpperTri)
    (hPSD : (fromBlocks D Z Zᵀ A).PosSemidef) : D.PosDef

lemma LogDetAtom.optimality_Ddet_le_Adet {t : n → ℝ} {Y Z D : Matrix n n ℝ}
    (ht : ∀ i, (t i).exp ≤ Y.diag i) (hD : D = Matrix.diagonal (Y.diag)) (hZ : Z = Y.toUpperTri)
    (hPSD : (fromBlocks D Z Zᵀ A).PosSemidef) : D.det ≤ A.det

import Mathlib.LinearAlgebra.Matrix.LDL

import CvxLean.Lib.Math.SchurComplement

import CvxLean.Lib.Math.Subadditivity

import CvxLean.Lib.Math.LinearAlgebra.Matrix.Triangular

import CvxLean.Lib.Math.LinearAlgebra.Matrix.ToUpperTri

import CvxLean.Lib.Math.LinearAlgebra.Matrix.LDL

namespace Matrix

open Matrix BigOperators

variable {n : Type} [Fintype n] [LinearOrder n] [LocallyFiniteOrderBot n]

variable {𝕜 : Type} [RCLike 𝕜]

variable {A : Matrix n n ℝ} (hA : A.PosDef)

open scoped Matrix ComplexOrder

lemma LogDetAtom.cond_elim {t : n → ℝ} {Y Z D : Matrix n n ℝ} (ht : ∀ i, (t i).exp ≤ Y.diag i)
    (hD : D = Matrix.diagonal (Y.diag)) (hZ : Z = Y.toUpperTri)
    (hPSD : (fromBlocks D Z Zᵀ A).PosSemidef) : A.PosDef :=

:= by
  have h_D_pd : D.PosDef := LogDetAtom.optimality_D_posdef ht hD hZ hPSD
  have h_A_psd : A.PosSemidef := PosSemidef₂₂_of_PosSemidef_toBlock hPSD
  have h_Ddet_le_Adet : D.det ≤ A.det := LogDetAtom.optimality_Ddet_le_Adet ht hD hZ hPSD
  have h_Adet_pos : 0 < A.det := lt_of_lt_of_le h_D_pd.det_pos h_Ddet_le_Adet
  rw [h_A_psd.PosDef_iff_det_ne_zero]
  apply ne_of_gt h_Adet_pos