F# Lisp Fun

Magus

As some of you know from the Status thread, I have begun an attempt to build a very simple Lisp variant in F#, the functional language closest to me.

It currently does not work due to overflowing the stack, because I am bad at recursion. Still, it's been fun so far.

Program.fs:

  [<EntryPoint>]
  let main argv =
    let mutable continueLooping = true
    while continueLooping do
      let statement = read() |> Lisp.parse |> formTree
      let evaluation = Lisp.runEvaluation statement

      if not evaluation.IsEmpty then
        if List.last evaluation = Lisp.Empty(Lisp.Symbol(new Lisp.Symbol("exit"))) then
          continueLooping <- false

        Lisp.printTree evaluation
    0

Lisp.fs:

module Lisp
  open System

  type Symbol(symbol) =
    member this.symbol = symbol
    override this.ToString() = this.symbol

  and Token =
    | Open
    | Close
    | Symbol of Symbol

  and SExpression =
    | Empty of Token
    | Node of Token * SExpression list

    member x.isEmpty() =
      match x with
      | Empty(Close) -> true
      | _ -> false

    member x.IsSymbol() =
      match x with
      | Empty(Symbol(_)) -> true
      | _ -> false

    static member emptyNode() =
      Node(Open, [ Empty(Close) ])

  and Keyword =
    | Plus
    | Minus
    | Multiply
    | Divide
    | Equals
    | If
    | DefineFunction
    | NoMatch

  let matchKeyword input =
    match input with
    | "+" -> Plus
    | "plus" -> Plus
    | "Plus" -> Plus
    | "PLUS" -> Plus
    | "-" -> Minus
    | "minus" -> Minus
    | "Minus" -> Minus
    | "MINUS" -> Minus
    | "*" -> Multiply
    | "multiply" -> Multiply
    | "Multiply" -> Multiply
    | "MULTIPLY" -> Multiply
    | "/" -> Divide
    | "divide" -> Divide
    | "Divide" -> Divide
    | "DIVIDE" -> Divide
    | "=" -> Equals
    | "equals" -> Equals
    | "Equals" -> Equals
    | "EQUALS" -> Equals
    | "if" -> If
    | "If" -> If
    | "IF" -> If
    | "defun" -> DefineFunction
    | "Defun" -> DefineFunction
    | "DEFUN" -> DefineFunction
    | _ -> NoMatch

  let rec parseStringHelper (tokens: string list) =
    let rec getChildren stack (leftover: string list) =
      if leftover.IsEmpty then
        ([], [])
      else
        match leftover.Head with
        | "(" ->
          let newChildren = parseStringHelper leftover
          getChildren (List.concat [ [fst newChildren ]; stack ]) (snd newChildren)
        | ")" -> (List.rev ([ Empty(Close) ] @ stack), leftover.Tail)
        | _ -> getChildren ([ Empty(Symbol (new Symbol(leftover.Head))) ] @ stack) leftover.Tail

    match tokens.Head with
    | "(" ->
      let (children, leftover) = getChildren [] tokens.Tail
      (Node(Open, children), leftover)
    | ")" -> invalidOp("Closing parenthesis is invalid on top level.")
    | _ -> (Empty(Symbol(new Symbol(tokens.Head))), tokens.Tail)
    
  let rec formTree (tokens: string list) =
    if tokens.IsEmpty then
      []
    else
      let nextItem = parseStringHelper tokens
      (formTree (snd nextItem)) @ [ (fst nextItem) ]

  let replace (old: string) (replacement: string) (input: string) = input.Replace(old, replacement)

  let split (separator: string) (input: string) =
    input.Split(separator, System.StringSplitOptions.RemoveEmptyEntries)
    |> Array.toList

  let parse (input: string) =
    input
    |> replace "(" " ( "
    |> replace ")" " ) "
    |> split " "

  let control =
    [ Node(Open,
        [ Empty(Symbol(new Symbol("defun")));
          Empty(Symbol(new Symbol("doThing")));
          Node(Open,
            [ Empty(Symbol(new Symbol("x")));
              Empty(Close) ]);
          Node(Open,
            [ Node(Open,
                [ Empty(Symbol(new Symbol("+")));
                  Empty(Symbol(new Symbol("x")));
                  Empty(Symbol(new Symbol("3")));
                  Empty(Close) ]);
              Node(Open,
                [ Empty(Symbol(new Symbol("*")));
                  Empty(Symbol(new Symbol("x")));
                  Empty(Symbol(new Symbol("8")));
                  Empty(Close) ]);
              Empty(Close) ]);
          Empty(Close) ]) ]

  let combine (between: string) (items: string list) = String.Join(between, items)

  let indentBy level = String.Join("", System.Linq.Enumerable.Repeat("  ", level))

  let rec stringifyExpression indent justOpened expression =
    match expression with
    | Empty(Close) ->
      ")"
    | Empty(Token.Symbol(x)) ->
      if justOpened then
        x.symbol
      else
        sprintf "%s%s%s"
          Environment.NewLine
          (indentBy indent)
          x.symbol
    | Node(token, expressions) ->
      match (token, expressions) with
      | (Open, expressions) ->
        let result =
          sprintf "%s%s(%s%s"
            Environment.NewLine
            (indentBy indent)
            (stringifyExpression (indent + 1) true expressions.Head)
            (String.Join("", expressions.Tail |> List.map (fun expression -> stringifyExpression (indent + 1) false expression)))
        result
      | (_, _) -> ""
    | _ -> ""

  let printTree (tree: SExpression list) =
    tree
    |> List.map (fun expression -> stringifyExpression 0 false expression)
    |> combine Environment.NewLine
    |> printfn "%s"

  let symbolize x = Empty(Symbol (new Symbol(x.ToString())))

  let extractSymbol (x: SExpression) =
    match x with
    | Empty(y) ->
      match y with
      | Symbol(z) -> z.symbol
      | _ -> invalidOp "Not a symbol."
    | _ -> invalidOp "Not a symbol."

  let extractNumbers x =
    List.map (fun y -> y |> extractSymbol |> decimal) x

  let unclosed x =
    List.filter (fun y ->
      match y with
      | Empty(z) ->
        match z with
        | Close -> false
        | _ -> true
      | _ -> true) x

  let symbolEqual expressionA expressionB =
    let symbolA = extractSymbol expressionA
    let symbolB = extractSymbol expressionB
    symbolA = symbolB

  let allSame L =
    match L with
    | [] | [_] -> true
    | h::t when t |> List.forall (symbolEqual h) -> true
    | _ -> false
    
  let symbolTrue expression =
    let symbol = extractSymbol expression
    match bool.TryParse symbol with
    | true, value -> value
    | false, _ -> false

  let allTrue L =
    match L with
    | [] -> false
    | t -> t |> List.forall symbolTrue

  let tupleTriple (L: 'a list) =
    if L.Length < 3 then
      invalidOp "List must contain at least three elements."
    else
      match List.take 3 L with
      | [a; b; c] -> (a, b, c)
      | _ -> invalidOp "List must contain at least three elements."
      
  let tupleDouble (L: 'a list) =
    if L.Length < 2 then
      invalidOp "List must contain at least two elements."
    else
      match List.take 2 L with
      | [a; b] -> (a, b)
      | _ -> invalidOp "List must contain at least two elements."

  let rec applyFunction f (expressions: SExpression list) =
    let (_, parametersNode, codeNode) = 
      match f with
      | Node(Open, children) ->
        children |> unclosed |> tupleTriple
      | _ -> (SExpression.emptyNode(), SExpression.emptyNode(), SExpression.emptyNode())

    let parameters =
      match parametersNode with
      | Node(Open, children) ->
        children |> unclosed
      | _ -> []

    let arguments =
      expressions
      |> List.map (fun expression ->
        match expression with
        | Node(Open, children) ->
          match children with
          | _::args -> args |> unclosed
          | _ -> []
        | _ -> [])

    let doReplacements (argumentSet: SExpression list) =
      let replaceSymbol a =
        if argumentSet.IsEmpty then
          a
        else
          let aligned = List.zip parameters argumentSet
          try
            snd (List.find (fun b -> symbolEqual (fst b) a) aligned)
          with
            | :? System.Collections.Generic.KeyNotFoundException -> a

      let rec replaceSymbols (functionMembers: SExpression list) =
        if functionMembers.IsEmpty then
          []
        else
          match functionMembers.Head with
          | Node(Open, children) -> replaceSymbols children
          | Empty(Symbol(_)) -> [ replaceSymbol functionMembers.Head ] @ replaceSymbols functionMembers.Tail
          | _ -> []

      replaceSymbols [ codeNode ]

    if arguments.IsEmpty then
      expressions
    else
      List.collect (doReplacements) arguments

  let runEvaluation (tree: SExpression list): SExpression list =
    let mutable functions: SExpression list = []

    let matchFunction name =
      try
        List.find (fun f ->
          match f with
          | Node(Open, head::_) -> head |> extractSymbol |> ((=) name)
          | _ -> false) functions
      with
        | :? System.Collections.Generic.KeyNotFoundException -> Node(Open, [ Empty(Close) ])

    let rec evaluate (tree: SExpression list): SExpression list =
      let subEvaluate (expressions: SExpression list) =
        if expressions.IsEmpty then
          []
        else
          expressions
          |> List.collect (fun y -> evaluate [ y ])

      let apply keyword expressions =
        let applyArithmetic f = expressions |> subEvaluate |> unclosed |> extractNumbers |> List.reduce f |> symbolize
        match keyword with
        | Plus ->
          [ applyArithmetic (+) ]
        | Minus -> 
          [ applyArithmetic (-) ]
        | Multiply ->
          [ applyArithmetic (*) ]
        | Divide ->
          [ applyArithmetic (/) ]
        | Equals ->
          [ expressions |> subEvaluate |> unclosed |> allSame |> symbolize ]
        | If ->
          let validExpressions = unclosed expressions
          if validExpressions.Length < 2 then
            invalidOp "An If must contain a condition and a result."
          elif validExpressions.Length > 3 then
            invalidOp "An If may contain a condition, a result, and at most one alternative."
          elif validExpressions.Length = 2 then
            let (a, b) = tupleDouble validExpressions
            if ([ a ] |> subEvaluate |> allTrue) then
              [ b ] |> subEvaluate
            else
              []
          else
            let (a, b, c) = tupleTriple validExpressions
            if ([ a ] |> subEvaluate |> allTrue) then
              [ b ] |> subEvaluate
            else
              [ c ] |> subEvaluate
        | DefineFunction ->
          functions <- functions @ [ Node(Open, expressions) ]
          []
        | NoMatch -> []

      match tree.Head with
      | Empty(_) -> tree |> unclosed |> subEvaluate
      | Node(x, y) ->
        match x with
        | Open ->
          let descend (children: SExpression list) =
            let first = extractSymbol children.Head
            let keyword = matchKeyword first
            if keyword = NoMatch then
              let matchedFunction = matchFunction first
              if matchedFunction.isEmpty() then
                children |> unclosed
              else
                children |> unclosed |> applyFunction matchedFunction
            else
              let evaluated = apply keyword children.Tail
              evaluated

          if not (y.Head.IsSymbol()) then
            let rest = subEvaluate y
            descend rest
          else
            descend y
        | _ -> invalidOp "Nodes must be Open."
    evaluate tree

I'm putting it here because I'd like to get it working, but I'm honestly fine with unusual derailment for this category. This is all for fun.

Zecc

@Magus said in F# Lisp Fun:

I am bad at recursion

You can become better at recursion by first improving your ability to recurse.

In other news, Fira Code strikes again:

I have nothing productive to say, but I wish you all the best. I'm glad you're having fun.

Gąska

@Magus overflowing the stack where? And for what input?

General rule: if you want efficient recursion, use tail recursion - make the recursive call the very last thing that your function executes, and return its result as is. Usually it's not how algorithm works, but in many cases it can be made that way by using accumulators - instead of taking the recursive result as an operand to another operation, pass the rest of required data as a recursive call argument so the operation can be made after descending into recursion.

Consider the following function:

let rec map f = function
| [] -> []
| h :: t -> f h :: map f t

It does :: after recursive map. It forces stack frames to be created. But it can be rewritten this way:

let map f xs =
  let innerMap acc f = function
  | [] -> acc
  | h :: t -> innerMap (f h :: acc) f t
  in
  innerMap [] f xs

innerMap is tail recursive, because additions are done on the accumulator instead of the recursive call result. The only problem is that the list is now reversed. This will be a very common situation when working with accumulators - the final list is reversed. You might be tempted to reverse the final list, and that's what's often done, but in many cases it's not necessary - if you chain two tail-recursive list-reversing functions, you're reversing twice, so the final order is all good.

As of your problem. If it's parsing or evaluating that overflows, instead of building a tree you can build a Reverse Polish Notation list of symbols - basically a flat list of symbols in the order they appear, but reversed. I think it's fairly easy to figure out how to use an accumulator to make a tail-recursive parser that reverses the order of all symbols. With RPN, a tail-recursive evaluator is very easy to do. You have to maintain your own execution stack. Like, a linked list that you add new elements to the front of. Since your symbols list is reversed, operands will appear first (in reverse order), then the operation - so you just push the operands on your stack until you encounter operation - by then, your stack will have operands in the right order. Pop the operands, do the operation and push the result. Rinse and repeat. Nested expressions work the same way - if you draw the execution flow on paper, you'll quickly see why.

hungrier

@Zecc said in F# Lisp Fun:

You can become better at recursion by first improving your ability to recurse.

The first step is F#, then F#$!, and after that it's just a matter of repetition

Magus

@Zecc said in F# Lisp Fun:

@Magus said in F# Lisp Fun:

I am bad at recursion

You can become better at recursion by first improving your ability to recurse.

In other news, Fira Code strikes again:

I have nothing productive to say, but I wish you all the best. I'm glad you're having fun.

The font is a decent part of the fun here.

Magus

@Gąska Thanks, that's good advice.

The part where I get into trouble is when I evaluate something like this:

((defun doThing (x) (+ (+ x 3) (* x 8))) (doThing 5) (doThing 8))

Which, if things work as I expect, put (doThing (x) (+ (+ x 3) (* x 8))) into my stored list of functions, and then on encountering doThing in the later bits, replace it with the function with the parameter(s) replaced with the argument(s):

((+ (+ 5 3) (* 5 8)) (+ (+ 8 3) (* 8 8)))

Which should immediately evaluate to:

48
75

My printing and parsing work well: honestly the printing was the first part to work. Additionally, all the arithmetic, equality, and the If work fine. I should probably add AND and OR, but I'm not too worried about them. So my problem is most likely in applyFunction

Zecc

@Magus said in F# Lisp Fun:

@Zecc said in F# Lisp Fun:

@Magus said in F# Lisp Fun:

I am bad at recursion

You can become better at recursion by first improving your ability to recurse.

In other news, Fira Code strikes again:

I have nothing productive to say, but I wish you all the best. I'm glad you're having fun.

The font is a decent part of the fun here.

I like the fun expression.

You know, the one after List.map (

Gąska

@Magus another approach to function application is to compile functions down to a form that uses De Bruijn indexing instead of argument names. Basically - each argument is referred to with a consecutive number, and nested functions keep the bound arguments of their "parents". Partially applied function can be represented by a reference to function code and a list of already bound arguments (completely unapplied functions have empty lists). Once all arguments are bound, you evaluate the function. To illustrate (using lambda calculus):

The expression λx.λy.x+y itself has a tuple value (<fun1>, []), where <fun1> is a reference to that function.
(λx.λy.x+y) 5 has value (<fun1>, [5]).
(λx.λy.x+y) 5 4 binds all parameters so it can be evaluated to 9.
(λx.(λy.x+y, λz.x+z)) is unapplied so it returns (<fun2>, []), where <fun2> is a reference to the outer function.
(λx.(λy.x+y, λz.x+z)) 5 returns a tuple of one-argument functions, but x is already bound in them. So the value is ((<fun2a>, [5]), (<fun2b>, [5])), where <fun2a> and <fun2b> are references to each of the inner functions.

You can greatly simplify implementation at the cost of some performance by treating every function as single-argument. That way, every application is full application - it's just that the result of a function can be another function that has some variables already bound. Thanks to De Bruijn indexing, you don't have to rewrite the functions on application - you just keep the arguments on the side in a separate stack as a list of lists, and copy arguments to the stack when needed.

When you start evaluating, you copy the bound arguments of the function to the top of argument stack. When you encounter the reference to an argument, you copy that argument from top of the argument stack to the evaluation stack. They are numbered so it's easy to figure out which one you need, and you copied all of the parent bound arguments so it always works. When you exit the function, the function value is already on top of the evaluation stack, and you just need to pop the top of argument stack and you're back in the caller's context.

Just make sure during compilation that a function doesn't pop more values from evaluation stack than it pushes, and on return the evaluation stack is exactly 1 bigger than before, no more, no less.

Gąska

Goddamn now I want to implement my own Lisp. As soon as I find some time...

Mason_Wheeler

@Gąska

Magus

@Mason_Wheeler is seriously fun, dude.

error

I've never seen such depravity.

Captain

@Magus Going to use SICP?

Magus

@Captain that might have been better, but I was enjoying doing it myself.

error

@Magus said in F# Lisp Fun:

| "equals" -> Equals
| "Equals" -> Equals
| "EQUALS" -> Equals
| "if" -> If
| "If" -> If
| "IF" -> If
| "defun" -> DefineFunction
| "Defun" -> DefineFunction
| "DEFUN" -> DefineFunction

Is this really the right way to handle case insensitivity? Ew.

Captain

@error Does F# have "view patterns"? In Haskell, you could theoretically do something like

 f l@(lowerCase -> arg) 
   | l == "equals" = Equals
   | l == "if" = If
   | l == "etc" = Etc

If view patterns won't work, try pre-composition on that argument. (That's really what you need -- ViewPatterns are just syntax for it)

Captain

This post is deleted!

Gąska

Generally, since parsing is the most boring and not very insightful part of writing an interpreter, I recommend using FParsec library. It lets you easily chain recursive-descent parsers together, and provides several common parsers out of the box, including number parsers and case-insensitive constant string parsers.

Magus

@error said in F# Lisp Fun:

@Magus said in F# Lisp Fun:
| "equals" -> Equals
| "Equals" -> Equals
| "EQUALS" -> Equals
| "if" -> If
| "If" -> If
| "IF" -> If
| "defun" -> DefineFunction
| "Defun" -> DefineFunction
| "DEFUN" -> DefineFunction
Is this really the right way to handle case insensitivity? Ew.

Oh it's definitely the wrong way, but I didn't have many cases to consider so I didn't bother.

@Gąska said in F# Lisp Fun:

Generally, since parsing is the most boring and not very insightful part of writing an interpreter, I recommend using FParsec library. It lets you easily chain recursive-descent parsers together, and provides several common parsers out of the box, including number parsers and case-insensitive constant string parsers.

Yeah, the whole point was building it.