symbolic.fs

// Type definitions
type BinaryOP =
  | Add
  | Sub
  | Div
  | Mult

type Expr< ^T> =
  | Binary of BinaryOP * Expr< ^T> * Expr< ^T>
  | Value of ^T
  | Var of string
  
  // binary operations to combine expressions
  static member inline (+) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Add, lhs, rhs)
  static member inline (-) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Sub, lhs, rhs)
  static member inline (*) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Mult, lhs, rhs)
  static member inline (/) (lhs: Expr< ^T>, rhs: Expr< ^T>) = Binary (Div, lhs, rhs)

  // convinience operations describing operations between base type and expressions
  static member inline (+) (lhs: Expr< ^T>, rhs: ^T) = Binary (Add, lhs, Value rhs)
  static member inline (-) (lhs: Expr< ^T>, rhs: ^T) = Binary (Sub, lhs, Value rhs)
  static member inline (*) (lhs: Expr< ^T>, rhs: ^T) = Binary (Mult, lhs, Value rhs)
  static member inline (/) (lhs: Expr< ^T>, rhs: ^T) = Binary (Div, lhs, Value rhs)

  static member inline (+) (lhs: ^T, rhs: Expr< ^T>) = Binary (Add, Value lhs, rhs)
  static member inline (-) (lhs: ^T, rhs: Expr< ^T>) = Binary (Sub, Value lhs, rhs)
  static member inline (*) (lhs: ^T, rhs: Expr< ^T>) = Binary (Mult, Value lhs, rhs)
  static member inline (/) (lhs: ^T, rhs: Expr< ^T>) = Binary (Div, Value lhs, rhs)


// implementation

let rec toString (ast: ^T Expr) =
  match ast with // pattern match on tree elements
  | Value x -> (string x)
  | Var x -> x
  | Binary (Add, x, y) -> "(" + (toString x) + "+" + (toString y) + ")"
  | Binary (Sub, x, y) -> "(" + (toString x) + "-" + (toString y) + ")"
  | Binary (Mult, x, y) -> "(" + (toString x) + "*" + (toString y) + ")"
  | Binary (Div, x, y) -> "(" + (toString x) + "/" + (toString y) + ")"


let rec eval (ast: ^T Expr) (m: Map<string, ^T Expr>) = 
  // the expression interpreter
  // match on patterns and evaluate
  match ast with

    | Binary (Add, Value x, Value y) -> Value (x + y)
    | Binary (Sub, Value x, Value y) -> Value (x - y)
    | Binary (Mult, Value x, Value y) -> Value (x * y)
    | Binary (Div, Value x, Value y) -> Value (x / y)

    | Binary (Add, x, y) -> (eval x m) + (eval y m) 
    | Binary (Sub, x, y) -> (eval x m) - (eval y m) 
    | Binary (Mult, x, y) -> (eval x m) * (eval y m) 
    | Binary (Div, x, y) -> (eval x m) / (eval y m) 

    | Value x -> Value x 
    | Var x -> 
      match m |> Map.tryFind x with
      | Some x -> x 
      | None -> Var x


// rules to simplify
let rec simplify (ast: ^T Expr) =
  match ast with
  | Binary (Mult, Value 0, _) -> Value 0 // 0 * x = 0
  | Binary (Mult, _, Value 0) -> Value 0 // x * 0 = 0
  | Binary (Mult, Value 1, expr) -> simplify expr // simplify and recurse
  | Binary (Mult, expr, Value 1) -> simplify expr
  | Binary (Add, Value 0, expr) -> simplify expr
  | Binary (OP, Var x, Value y) -> Binary(OP, Value y, Var x)
  | Binary (Add, Var x, Var y) when x = y -> // X + X = 2X
    Binary (Mult, Value 2, Var x)
  | Binary (OP, Value x, rhs) -> // 1 * (2 * x) -> (1 * 2) * x
    match rhs with
      | Binary (OP, Value y, rhs2) ->
        let lhs = (Binary (OP, Value x, Value y))
        Binary (OP, lhs, simplify rhs2)
      | _ -> Binary (OP, Value x, simplify rhs)
  | Binary (OP, lhs, rhs) -> // (1 * x) * (2 * x) -> (1 * 2) * (x * x)
    let m1 = 
      match lhs with
      | Binary (OP, Value v, Var x) -> 
        Some (Value v, Var x)
      | _ -> None

    let m2 =
      match rhs with
      | Binary (OP, Value v, Var x) -> 
        Some (Value v, Var x)
      | _ -> None

    match m1, m2 with
    | Some (a, b), Some (c, d) -> 
      Binary (
        OP,
        Binary (OP, a, c),
        Binary (OP, b, d))
    | _ -> Binary (OP, simplify lhs, simplify rhs)
  | x -> x


let rec evalAll (ast: ^T Expr) (m: Map<string, ^T Expr>) =
  let next = eval ast m
  if next <> ast
  then evalAll next m
  else next 

let rec simplifyAll (ast: ^T Expr) =
  let next = eval ast Map.empty |> simplify
  if next <> ast
  then simplifyAll next
  else next 

// compute derivative
let rec deriv (ast: ^T Expr) (var: string) =
  match ast with
  | Value _ -> Value 0
  | Var x when x = var -> Value 1
  | Var x when x <> var -> Value 0
  | Binary (Mult, l, r) -> (deriv l var) * r + l * (deriv r var)
  | Binary (OP, l, r) -> Binary (OP, (deriv l var), (deriv r var))


// helper function for printing
let printSimplified expr =
  let s1 = toString expr
  let s2 = toString (simplifyAll expr)
  if s1 = s2
  then System.Console.WriteLine (s1) 
  else System.Console.WriteLine (s1 + " = " + s2)


let inline f c x = c * x * x

System.Console.WriteLine (f 2 2)

let X = Var "x"
let expr = f 2 X

let sub = Value 2 * Var("X")
let params1 = Map.ofList ["x", sub]
let partial = evalAll expr params1



printSimplified expr
System.Console.WriteLine("Computing derivative:")
let derived =  (deriv expr "x")
printSimplified derived

System.Console.WriteLine("substituting x -> " + (toString sub) + " in: ")
printSimplified partial

let params2 = Map.ofList ["X", Value 2]
let result = evalAll partial params2

System.Console.WriteLine("substituting x -> 2 in partial")
printSimplified result

https://fable.io/repl/#?code=PTAEBUE8AcFNQCawGYEsB2qAuqD26BnAWACgsZ4AhDAQwCdIB5ABVAF5TRQAfUAQQQJOPUAGUArgCNhvACKoAbjNABZcQBsspUuTigAogA9odADygAeuAB87ZdXT1IoXMlAOnLUACoDxs5Y2Pn4m5lbWygBqNOri8K6BUfQubgRYdBgA5sLCIKCStAwucHQ0OPgEoFi4oADGuAC2BejwsP6wBAR4hMJpZai1oA2wTbB0oBjqGPAAFADUAJSgM+oAFgQAXCEB4QA0oHTrW0ahgdZLbO6FzjMCCPtrBPuHBAu9WP2Dw6Pjk9PLAFolisjtswjZnqCTjsbBcro4ijMJJIHutIa93p8hiNJGMJugpi1lt5gY9jv5wdZ0eTTuE4R5EWpNKingd1m8SFw+jgvji8X8iTNgKSoRSztSwWd6ddlvIFCz0RzcmB6ugFBhULB0LV4iV+hVEB1ahlmplimN9YR8rAsAB3WBa-I0AjwXTwGjoBCgNomDpdCqYnnYn74wmzRbLMmSvZszaBaUIm53BWgaKxeAvDlcj5B76434E-4zIGR0W0iGxrZWBNOZbIlNpuKxrOgbkDYP50NFkmluPQykS6vseG1mZMrANmJNzOB9t5-mFwXC3s0mFUyvx4cMm5yyfp5vaTmtnNzvkFsPLCMguNWCX9qVbmW3QT7RvwR6K2e8kMC2Yl69VuAd5inSj6JnWUivlO75ogeR5tt+na-sSIo3kBG73qBlzbss45QfuH5wdmWLzueRbLgBgTAeW5xgaOu6ptBoCETOJCHnkqANNA6gjFqJ74IePFYAcsCDNUojpFkyzOlggHbBcwgNGUtSrKAMmgLa2CqXk0BlFgYzoEMymqfgVR0A63o8cM6BYMQR68G+oCGKAAK2DMaQZOgZqGC2DnJM5rlOfYT7Jk5+yQEsgUAEQzFFoBzMs4mSV5TlLAlUVzHFCUzElnlmhF8WgFFCxRcF4FIpBYWgAV0WxYVOW4BJeWpYVUUAlliWNcl+VpUVJVlaOeFVTVtgxR1DVNVJPmtd4425VJBXpf19kjoiDGGOFkWjXV2XzSl03pcAc1dc1i19aVbGXUJImDLACgxNJaRydCwINFsKg0NApgeVk+xWNstGXMqVSrK07SdN0+L6XQvrQ8DSlYCpLiGbpWDQ1aHpendU5lLAinGWpaQaVph5cFwvA4c+9yMfuG0002I307MzkJRFwjk6tNz1kzVWOYzjkzAF1UthzlNDY5dN81tPOC8EbNHqLT4MRL+EM9LAvOWA8vsyIlOhXTjMzNj6hOUMvVG-dJvOA0Sw6xTT7cwb0sWw9zk2y5yzG9VZugHbnO4RoE7Dc7Xtu0svgu1bPt+5T62bS5bmhz7YCR977uk2Tfm0wnPPOX70TjAFtg61wCNIw0PC2B90AAHTpJAABiGBes5mlYKsJciKIjTwEXpud7wABy+DwIFBdBZdpB5HQGgdFUNRdFxUzIJApDXeZgyL9xqAr49smBPJdhHmXqnqW3HcrWLgeq-AAAM+wAPrq0xt+gHkr++M5ly3wNjLX6AD8b6gFvs-fcr88jOV8K-b+v8bjiyYgARn2D6Og0st7L2cCgt+YB0E72cJjG64g6AulgQHZk3p-BAIQWgzi29d4oNIVTIB98KEmBoUvPBrC6CMJYFBQuQDGbbhmLwnmkA+GpUYaFcektkgFVtKDQyX9vaBTyAADUKuoy4AAmVROsr7kMclo8RPkeHMCAXTTMOc8gIOCDMLRwRpqBRmDY3wWjw4TzJkZRGqkXjE3bgPf2wizGiPRG4hOncuDXUeMOGYlMREq1EQsEWnjAkiMIrg3eLw3EBIfjnOJwSEkZOcKxRW5U0mwUsSolOLiWoR3sZ-Z2NSwkR0gRIhWzEbRDBsUDdppcCbRPPgE-JQD5SMULtLCJYge7LEcqM6RySOa5MCsPFoGdImdIaPYjgvSvFI18YMnZ9sykFKYnM-yEydlcG7sMGZpzjELJEEs2wKy8aXU8SfLp+xNl+Ivp43g1zZg0H2JIBY+wAXLFqPsBAFyUmBMmbwyZwy1L7FqKCxFT4REokQEkv2TzUnBKKcxWChKSkiD7oYQ8a9Okb29JbPg6gTYzBks9fwr13qfW+t1P64AAYKSPNdFohhhKXC9upBowgd6gEFcJUwtgZLCHbo6Y29KTbSqGMIWA6gXRSraMJQS1LRKtloRglVe8WVsKPus4SaqRWW0JsJauNcRjQHIJXI1HCV4SrcGq2V9qFUKPdXQyAprpUaq1fANV7EVSNGgOIfShoMj3RwAoV569DVIETWag+L1lj3ToFsH6Xk+V9O8fan5SR9x4scj-Fa0iNIBqUXmnOjkEFJELvWx0zlfVNrHi-RhQ11DPGdhmxQzFQB5vceMBKJsI4joUAccd9BfL4oeEOvJGLgkzDnWOid+wt1jFHeMCdSpLp5FBuoEooBkDiG1OUQyyBcDjBMBgHAXkqXCWfTZUQxqd6aixv4S1HThIEG6fPSaKUGH8s6QQLZYHurLCKaalBLZJUgeHDB-1jpRCQDSCMGuABhCouAeI1wAOoZH0gAGSLCB22R5NXauw7hhoBGiMkfI9gWA1HBRofSsODqMGT3vq7ESNwgwlGDE-g4w8TH9IscI4QYjsAyMUa40WNw9jslXU6ZosZRVDAXWulgy4GnQC6O08BqQw5DHBALrFVRxVhO6VKA0NDlxHWuGo0TAA2lFAz+wCBSAALpOfoDgB6tqYhIYA85mgrnW2T0up+rA36PV-q4aQWTeGFMECUypzj3HYCxUI1xONUk539BTRsRzJBrpztgF6S4yxt1YL8zV5LqW6Hpfq0IS6WX5NseUxxqj0xYqBckGkbAZX9o52OuBs043epxQwFsdrnkUs-rQA10AznwvqH1R++gcWYPDg88gLzwlfMOaAVokLtWDWBc0MOZVDKdthdQA9WLrmtEyZw3J1jin2OqcK2NqQk2sDTe8jnexGA3t0D22tl9nXl7pfMo9rAQA&html=Q&css=Q