type LispValue =
    Int of int
    | Str of string
    | Lst of (LispValue list)
    | Lam of (string list) * LispValue
    | Def of string * LispValue

let expr = Lst [Str "+"; Int 1; Lst [Str "*"; Lst[Str "if"; Lst [Str "-"; Int 2; Int 2]; Int 2; Int 3]; Int 3]]

let getFunc = function
    | "+" -> Some (+)
    | "*" -> Some (*)
    | "-" -> Some (-)
    | _ -> None

let nativeFunc = function
    | "=" -> Some (=)
    | _ -> None

let rec findUserFunc f = function
    | [] -> None
    | (name, value)::rest -> if name = f then Some value else findUserFunc f rest

let substitute args = function
    | Int i -> if List.length args = 0 then Int i else failwith "Incorrect substitute"
    | Str s -> failwith "Incorrect substitute"
    | Lst l -> Lst l
    | Lam (argnames, body) ->
        let rec replaceOne name value = function
            | Str s -> if name = s then value else Str s
            | Lst l -> Lst <| List.map (replaceOne name value) l
            | Lam (argnames, body) ->
                if List.exists ((=) name) argnames
                then Lam (argnames, body)
                else Lam (argnames, replaceOne name value body)
            | body -> body
        let rec replace body argnamesAndArgs =
            if List.length argnames <> List.length args
            then failwith "Incorrect argument count"
            else match argnamesAndArgs with
                | [] -> body
                | (name, value)::rest -> replace (replaceOne name value body) rest
        in replace body (List.zip argnames args)

let rec eval userFuncs = function
    | Str s -> failwith "Incorrect expression"
    | Int i -> Int i
    | Lst [] -> Lst []
    | Lst ((Str "define")::(Str name)::value::[]) -> Def (name, eval userFuncs value)
    | Lst ((Str "if")::p::a::b::[]) ->
        match (eval userFuncs p) with
            | Int 0 -> eval userFuncs b
            | _ -> eval userFuncs a
    | Lst ((Str "lambda")::(Lst args)::body::[]) ->
        let extractStr = function
            | Str s -> s
        in Lam (List.map extractStr args, body)
    | Lst (Str f::args) ->
        let extractInt = function
            | Int i -> i
        in match getFunc f with
            | Some f -> Int <| List.reduce f (List.map (extractInt << eval userFuncs) args)
            | None -> match nativeFunc f with
                | Some f -> Int <| if f (extractInt <| (eval userFuncs <| List.nth args 0)) (extractInt <| (eval userFuncs <| List.nth args 1)) then 1 else 0
                | None -> match findUserFunc f userFuncs with
                    | Some value -> eval userFuncs <| substitute args value
                    | None -> failwith "Unknown function"

let evalExprs =
    let rec eval' acc userFuncs = function
    | [] -> acc
    | expr::rest -> match eval userFuncs expr with
        | Def (name, value) -> eval' acc ((name, value)::userFuncs) rest
        | value -> eval' (value::acc) userFuncs rest
    in eval' [] []

let parse str =
    let rec parse' = function
        | [] -> (Lst [], [])
        | (' '::rest) -> parse' rest
        | (')'::_) -> failwith "Incorrect bracket"
        | ('('::rest) ->
            let rec parseList acc = function
                | [] -> failwith "No bracket"
                | (' '::rest) -> parseList acc rest
                | (')'::rest) -> (acc, rest)
                | str ->
                    let expr = parse' str
                    in parseList (fst expr::acc) (snd expr)
            let subExpr = parseList [] rest
            in (Lst <| List.rev (fst subExpr), snd subExpr)
        | str ->
            let rec parseToken acc = function
                | [] -> (List.rev acc, [])
                | (head::rest) ->
                    if System.Char.IsWhiteSpace head or head = '(' or head = ')' then (List.rev acc, head::rest)
                    else parseToken (head::acc) rest
            let subExpr = parseToken [] str
            let token str = match System.Int32.TryParse str with
                | (true, i) -> Int i
                | (false, _) -> Str str
            in (token <| (System.String.Concat (Array.ofList (fst subExpr))), snd subExpr)
    in parse' (Seq.toList str)

let parseExprs str =
    let rec parseExprs' str =
        match parse str with
            | (expr, []) -> [expr]
            | (expr, rest) -> expr::(parseExprs' rest)
    in parseExprs' (Seq.toList str)

let evalProgram str = evalExprs (parseExprs str)

evalProgram "(define fact (lambda (n) (if (= n 0) 1 (* n (fact (- n 1)))))) (fact 5)"