sicp prolog reimplemented in fsharp

prolog.fsx

type Stream<'a> = | Nil | Cons of 'a * Lazy<Stream<'a>>
module Stream =
    let cons a b = Cons(a,b) 
    let singleton a = cons a (Lazy.CreateFromValue(Nil))
    let empty = Nil
    let isEmpty = function 
        | Nil -> true
        | Cons(a,_) -> false
    let rec append s1 s2 =
        match s1 with
        | Nil -> s2
        | Cons(car,cdr) -> cons car (Lazy.Create(fun () -> append cdr.Value s2))
    let rec map f = function 
        | Nil -> Nil
        | Cons(car, cdr) -> cons (f(car)) (Lazy.Create(fun () -> map f cdr.Value))

    let rec choose (f:'a -> 'b option) (s:Stream<'a>) : Stream<'b> = 
        match s with
        | Nil -> Nil
        | Cons(car, cdr) -> match f car with
                            | None -> choose f cdr.Value
                            | Some(car) -> cons car (Lazy.Create(fun () -> choose f cdr.Value))

    let rec iter f s : unit = 
        match s with 
        | Nil -> ()
        | Cons(car, cdr) -> f(car)
                            iter f (cdr.Value)
    //let rec flatmap f = function 
    //    | Nil -> Nil
    //    | Cons(car, cdr) -> append (f(car)) (flatmap f cdr.Value)

    let rec appendDelayed s1 (delayedS2:Lazy<Stream<'a>>) =
        match s1 with
        | Nil -> delayedS2.Value
        | Cons(car, cdr) -> cons car (Lazy.Create(fun () -> appendDelayed (cdr.Value) delayedS2))

    let rec interleaveDelayed s1 (delayedS2:Lazy<Stream<'a>>) =
        match s1 with
            | Nil -> delayedS2.Value
            | Cons(car, cdr) -> cons car (Lazy.Create(fun () -> interleaveDelayed delayedS2.Value cdr))

    let rec flattenStream stream =
        match stream with
            | Nil -> empty
            | Cons(car, cdr) -> interleaveDelayed car (Lazy.Create(fun () -> flattenStream cdr.Value))

    let flatmap proc s = flattenStream <| map proc s

    let rec toSeq stream = 
        match stream with
        | Nil -> Seq.empty
        | Cons(car, cdr) -> seq { yield car; yield! toSeq cdr.Value }
        
type Expression = 
    | Var of string
    | Constant of obj
    | List of Expression list

type Either<'a> =
    | Ok of 'a
    | Error of string
module Either =
    let bind (f:'a->Either<'b>) (b:Either<'a>) =
        match b with 
        | Ok(b) -> f b
        | Error(err) -> Error(err)
    let map (f:'a->'b) (b:Either<'a>) =
        match b with 
        | Ok(b) -> Ok(f b)
        | Error(err) -> Error(err)
let rec exprToStr expr = 
    match expr with
    | Var(v) -> sprintf "?%s" v
    | Constant(o) -> sprintf "%s" (o.ToString())
    | List(lst) -> sprintf "(%s)" (System.String.Join(' ', List.map exprToStr lst))

type Frame = (string * Expression) list * int

let emptyFrame : Frame= ([],0)

let makeBinding variable value = (variable,value)
let bindingValue (_,cdr) = cdr
let rec bindingInFrame variable ((substs,c):Frame) : (string * Expression) option = 
    match substs with
    | [] -> None
    | (v,o)::_ when v = variable -> Some(v,o)
    | _::t -> bindingInFrame variable (t,c)
let extend variable value (substs,counter) = ((makeBinding variable value) :: substs, counter)

type Assertion = Expression
type Rule = Expression * Expression

type Database = {
    allRules :Stream<Rule>
    allAssertions : Stream<Assertion>
    indexedRules : Map<string, Stream<Rule>>
    indexedAssertions : Map<string, Stream<Assertion>>
    goals : Map<string, Database -> Expression -> Stream<Frame> -> Stream<Frame>>}

let getStream map key1 =
  let s = Map.tryFind key1 map
  match s with
  | None -> Stream.empty
  | Some(s) -> s

let indexKeyOf exp = 
    match exp with
    | Var(_) -> Some("?")
    | Constant(c) when (c :? string) -> Some(c.ToString())
    | _ -> None

let fetchAssertions db pattern =
    match indexKeyOf pattern with
    | Some(key) when key <> "?" -> getStream (db.indexedAssertions) key
    | _ -> db.allAssertions

let fetchRules db (pattern:Expression) =
    match indexKeyOf pattern with
    | Some(key) when key <> "?" -> Stream.append (getStream db.indexedRules key)
                                                 (getStream db.indexedRules "?")
    | _ -> db.allRules

let storeAssertionInIndex db (assertion:Expression) =
    match indexKeyOf assertion with
    | Some(key)-> let currentAssertionStream = getStream db.indexedAssertions key
                  { db with indexedAssertions = db.indexedAssertions.Add(key, Stream.cons assertion (Lazy.Create(fun () -> currentAssertionStream)))}
    | _ -> db

let getRule exp : Rule option =
    let ruleTag = box "rule"
    match exp with
    | List(Constant(tag)::conclusion::[]) when tag = ruleTag -> Some(conclusion, List([Constant("always-true")]))
    | List(Constant(tag)::conclusion::rule::[]) when tag = ruleTag -> Some(conclusion, rule)
    | _ -> None
    
let storeRuleInIndex db ((pattern,body):Rule) =
    match indexKeyOf pattern with
    | Some(key)-> let current = getStream db.indexedRules key
                  { db with indexedRules = db.indexedRules.Add(key, Stream.cons (pattern,body) (Lazy.Create(fun () -> current)))}
    | _ -> db

let addAssertion db assertion =
    let db = storeAssertionInIndex db assertion
    {db with allAssertions = Stream.cons assertion (Lazy.Create(fun () -> db.allAssertions))}
let addRule db rule =
    let db = storeRuleInIndex db rule
    {db with allRules = Stream.cons rule (Lazy.Create(fun () -> db.allRules))}

let addRuleOrAssertion db (assertion:Expression) =
    match getRule assertion with
    | Some(rule) -> addRule db rule
    | None -> addAssertion db assertion

let getType exp : Either<string*Expression> =
    match exp with
    | List(Constant(key) :: contents) when (key :? string)-> Ok((string key,List(contents)))
    | _ -> Error(sprintf "Unknown expression TYPE  or CONTENTS %A" exp)

let instantiate exp (frame:Frame) unboundVarHandler = 
    let rec copy exp = 
        match exp with
        | Var(v) -> 
            let binding = bindingInFrame v frame
            match binding with
            | Some(binding) -> copy (bindingValue binding)
            | None -> unboundVarHandler exp frame
        | List(lst) -> List(List.map copy lst)
        | _ -> exp
    copy exp


let rec parseInt (str:string) idxStart (value:int) : (Expression * int) option =
    if idxStart = str.Length then Some(Constant(value), idxStart)
    else 
        let c = str.[idxStart] 
        if System.Char.IsDigit(c) 
        then parseInt str (idxStart + 1) (value * 10 + int (System.Char.GetNumericValue(c)))
        else Some(Constant(value), idxStart)

let rec parseVar (str:string) idxStart (value:string) : (Expression * int) option =
    if idxStart = str.Length then Some(Var(value), idxStart)
    else 
        let c = str.[idxStart] 
        if System.Char.IsWhiteSpace(c) || c = ')' 
        then Some(Var(value), idxStart)
        else parseVar str (idxStart + 1) (value + c.ToString())

let rec parseString (str:string) idxStart (value:string) : (Expression * int) option =
    if idxStart = str.Length then Some(Constant(value), idxStart)
    else 
        let c = str.[idxStart] 
        if System.Char.IsWhiteSpace(c) || c = ')' 
        then Some(Constant(value), idxStart)
        else parseString str (idxStart + 1) (value + c.ToString())

let rec parseList (str:string) idxStart (value: Expression list) : (Expression * int) option =
    if idxStart = str.Length then failwithf "no list finish %d" idxStart
    else 
        let c = str.[idxStart] 
        if c = ')'  
        then Some(List(List.rev value), idxStart + 1)
        elif System.Char.IsWhiteSpace(c) then parseList str (idxStart+1) value
        else match parse str idxStart with 
             | Some(exp,idx) -> parseList str idx (exp::value)
             | None -> None

and parse str idxStart : (Expression * int) option =
    if idxStart = str.Length then None
    else match str.[idxStart] with
         | '(' -> parseList str (idxStart + 1) []
         | '?' -> parseVar str (idxStart + 1) ""
         | ' ' -> parse str (idxStart + 1)
         | c when System.Char.IsDigit c -> parseInt str idxStart 0
         | _ -> parseString str idxStart ""

let querySyntaxProcess (str:string) : Expression option = 
    match parse str 0 with
    | Some(exp,_) -> Some(exp)
    | None -> None

let contractQuestionMark variable =
  match variable with
  | Var(name) -> Constant(sprintf "?%s" name)
  | _ -> List([])//todo

let isDependsOn exp var (frame:Frame) =
    let rec treeWalk e =
        match e with
        | Var(v) -> 
               if var = e then true
               else let b = bindingInFrame v frame
                    match b with
                    | Some(b) -> treeWalk (bindingValue b)
                    | None -> false
        | List(lst) -> List.fold (fun r exp -> r || treeWalk exp) false lst
        | _ -> false
    treeWalk exp

let rec extendIfPossible (var:string) (vval:Expression) (frame:Frame) =
    match(bindingInFrame var frame, vval) with
    | (Some(binding),_) -> unifyMatch (bindingValue binding) vval frame
    | (_, Var(vvalName)) ->
           let binding = bindingInFrame vvalName frame
           match binding with
           | Some(binding) -> unifyMatch vval (bindingValue binding) frame
           | None -> Some(extend var vval frame)
    | _ when isDependsOn vval (Var(var)) frame -> None
    | _ -> Some(extend var vval frame)

and unifyMatch (p1:Expression) (p2:Expression) (frame:Frame) : Frame option =
    match(p1,p2) with
    | _ when p1 = p2 -> Some(frame)
    | (Var(p1),_) -> extendIfPossible p1 p2 frame
    | (_,Var(p2)) ->  extendIfPossible p2 p1 frame
    | (List(h::t), List(h2::t2)) -> 
                let frame = unifyMatch h h2 frame
                Option.bind (fun frame -> unifyMatch (List(t)) (List(t2)) frame) frame
    | _ -> None

let renameVariablesIn (substs,counter) (conclusion,body) : (Frame * Rule)=
    let ruleApplicationId = counter + 1
    let rec treeWalk exp =
        match exp with
        | Var(v) -> Var(sprintf "%s_%d" v ruleApplicationId)
        | List(lst) -> List(List.map treeWalk lst)
        | _ -> exp
    (substs,ruleApplicationId),(treeWalk conclusion,treeWalk body) 

let rec extendIfConsistent var dat (frame:Frame) =
    let binding = bindingInFrame var frame
    match binding with
    | Some(binding) -> patternMatch (bindingValue binding) dat frame
    | None -> Some(extend var dat frame)

and patternMatch pat dat (frame:Frame) : Frame option = 
    match(pat,dat) with
    | _ when pat = dat -> Some(frame)
    | (Var(pat),_) -> extendIfConsistent pat dat frame
    | (List(h::t), List(h2::t2)) -> 
                let frame = patternMatch h h2 frame
                Option.bind (fun frame -> patternMatch (List(t)) (List(t2)) frame) frame
    | _ -> None

let checkAnAssertion assertion queryPat (queryFrame:Frame) =
    let matchResult = patternMatch queryPat assertion queryFrame
    match matchResult with 
    | None -> Stream.empty
    | Some(frame) -> Stream.singleton frame

let findAssertions db pattern (frame:Frame) =
    Stream.flatmap (fun datum -> checkAnAssertion datum pattern frame) (fetchAssertions db pattern)

let rec qeval (db:Database) (query:Expression) (frameStream:Stream<Frame>) : Stream<Frame> =
    match (getType query) with
    | Error(err) -> printfn "ERROR: %s" err
                    Stream.empty
    | Ok(tp, contents) -> let qproc = Map.tryFind tp db.goals
                          match qproc with
                            | Some(qproc) -> qproc db contents frameStream
                            | None -> simpleQuery db query frameStream

and applyARule (db:Database) (rule:Rule) (queryPattern:Expression) (queryFrame:Frame) =
    let queryFrame, (conclusion, body) = renameVariablesIn queryFrame rule
    let unifyResult = unifyMatch queryPattern conclusion queryFrame
    match unifyResult with
    | None -> Stream.empty
    | Some(frame) -> qeval db body (Stream.singleton frame)

and applyRules db pattern frame =
    let rules = fetchRules db pattern
    Stream.flatmap (fun rule -> applyARule db rule pattern frame) rules

and simpleQuery db (queryPattern:Expression) (frameStream:Stream<Frame>) =
    Stream.flatmap 
        (fun frame ->
            let a = findAssertions db queryPattern frame
            let b = Lazy.Create(fun () -> applyRules db queryPattern frame)
            Stream.appendDelayed a b) frameStream

let alwaysTrue db exp (frameStream:Stream<Frame>) = frameStream

//optimize run all goals and after that find all compatible frames
let rec conjoin db (conjuncts:Expression) (frameStream:Stream<Frame>) : Stream<Frame> =
    match conjuncts with
    | List(h::t) -> let frameStream = qeval db h frameStream
                    conjoin db (List(t)) frameStream
    | _ -> frameStream

let rec disjoin db (disjuncts:Expression) (frameStream:Stream<Frame>) : Stream<Frame> =
    match disjuncts with
    | List(h::t) -> let s1 = qeval db h frameStream
                    let s2 = Lazy.Create(fun () -> disjoin db (List(t)) frameStream)
                    Stream.interleaveDelayed s1 s2
    | _ -> Stream.empty 

let rec eq db (args:Expression) (frameStream:Stream<Frame>) : Stream<Frame> =
    match args with
    | List(a::b::[]) -> Stream.choose (fun frame -> unifyMatch a b frame) frameStream
    | _ -> Stream.empty 

let negatedQuery exp =
    match exp with
    | List(h::_) -> h
    | _ -> exp

let negate db operands (frameStream:Stream<Frame>) =
    Stream.flatmap 
        (fun frame ->
            if Stream.isEmpty (qeval db (negatedQuery operands) (Stream.singleton frame))  
            then Stream.singleton frame
            else Stream.empty) frameStream

let exec fn args frame = 
    match(fn, args) with
    | (">", [Constant(arg1); Constant(arg2)]) -> if (arg1 :?> int) > (arg2 :?> int) then Some(frame) else None
    | ("<", [Constant(arg1); Constant(arg2)]) -> if (arg1 :?> int) < (arg2 :?> int) then Some(frame) else None
    
    | ("+", [Constant(arg1); Constant(arg2); v]) when ((arg1 :? int) && (arg2 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg1) + System.Convert.ToInt32(arg2))) frame
    | ("+", [Constant(arg1); v; Constant(arg3)]) when ((arg1 :? int) && (arg3 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg3) - System.Convert.ToInt32(arg1))) frame
    | ("+", [v; Constant(arg2); Constant(arg3)]) when ((arg3 :? int) && (arg2 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg3) - System.Convert.ToInt32(arg2))) frame

    | ("*", [Constant(arg1); Constant(arg2); v]) when ((arg1 :? int) && (arg2 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg1) * System.Convert.ToInt32(arg2))) frame
    | ("*", [Constant(arg1); v; Constant(arg3)]) when ((arg1 :? int) && (arg3 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg3) / System.Convert.ToInt32(arg1))) frame
    | ("*", [v; Constant(arg2); Constant(arg3)]) when ((arg3 :? int) && (arg2 :? int)) -> patternMatch v (Constant(System.Convert.ToInt32(arg3) / System.Convert.ToInt32(arg2))) frame

    | _ -> failwithf "Cant exec function %A %A" fn args

let execute exp frame = 
    match exp with
    | List(Constant(fn)::args) when (fn :? string) -> 
        //printfn "executing %s %s" (fn.ToString()) (exprToStr (List(args))) 
        exec (fn.ToString()) args frame
    | _ -> None

let lispValue db call (frameStream:Stream<Frame>) =
    Stream.flatmap 
        (fun frame ->
            let expression = instantiate call frame (fun v f -> v)//failwithf "Unknown pat var: LISP-VALUE %A" v)
            match execute expression frame with
            | Some(frame) -> Stream.singleton frame
            | None -> Stream.empty) frameStream

let emptyDatabase : Database = {
    allRules = Stream.empty
    allAssertions = Stream.empty
    indexedRules = Map.empty
    indexedAssertions = Map.empty
    goals = Map.empty.Add("lisp-value", lispValue)
                     .Add("always-true", alwaysTrue)
                     .Add("and", conjoin)
                     .Add("or", disjoin)
                     .Add("not", negate)
                     .Add("===", eq)
}
let inputPrompt = ";;; Enter query:"
let outputPrompt = ";;; Query results:"

let proccess (db:Database) (input: string) : Database * string seq =
    match querySyntaxProcess input with
    | None -> db, ([sprintf "Unable to parse string \"%s\"" input]|> Seq.ofList)
    | Some(q) ->
        match (getType q) with
        | Ok("assert!",q) ->
            let db = addRuleOrAssertion db q
            db, Seq.empty//Seq.singleton (sprintf "parsed %A" q)
        | _ ->
            let result = qeval db q (Stream.singleton emptyFrame)
            let result = Stream.map (fun frame -> instantiate q frame (fun v f -> contractQuestionMark v)) result
            db, Stream.toSeq result |> Seq.map exprToStr


let rec consoleQueryDriverLoop (db:Database) : unit =
    printfn "%s" inputPrompt
    let input = System.Console.ReadLine()
    let db, res = proccess db input
    if Seq.isEmpty res |> not 
    then
        printfn "%s" outputPrompt
        for r in res do
            printfn "%s" r
    consoleQueryDriverLoop db

let rec listQueryDriverLoop (db:Database) commands result : Database * string seq =
    match commands with
    | [] -> db,result
    | input :: t -> let db, res = proccess db input
                    listQueryDriverLoop db t (Seq.append result res)

let run lst =
    System.Console.WriteLine("Input:")
    lst |> List.iter  (fun (x:string) -> System.Console.WriteLine(x))
    System.Console.WriteLine("Results:")
    listQueryDriverLoop emptyDatabase lst Seq.empty |> fun (db,list) -> list |> Seq.truncate 10 |> Seq.iter (fun (x:string) -> System.Console.WriteLine(x)) 

run [
    "(assert! parent anton mark)"
    "(assert! parent anton lia)"
    "(assert! parent valera anton)"
    "(assert! rule (grandparent ?x ?z) (and (parent ?x ?y) (parent ?y ?z)))"
    "(grandparent ?x ?y)"
]

run [
    "(assert! number 8)"
    "(assert! number 1)"
    "(assert! number 4)"
    "(assert! number 7)"
    "(assert! number 3)"
    "(and (number ?x) (number ?y) (number ?oneDigit) (lisp-value * ?x 10 ?w) (lisp-value + ?w ?y ?twoDigit) (lisp-value * ?twoDigit ?oneDigit 284))"
]

run [
    "(lisp-value + ?x 4 8)"
]
//(assert! rule (power ?x ?y ?z) (or (and (=== ?y 1) (=== ?x ?z)) (and (=== ?y 0) (=== 1 ?z)) (and (lisp-value + ?yDec 1 ?y) (power ?x ?yDec ?zp) (lisp-value * ?x ?zp ?z) )))
run [
    "(assert! rule (power ?x ?y ?z) (or (and (=== ?y 0) (=== 1 ?z)) (and (lisp-value > ?y 0) (lisp-value + ?yDec 1 ?y) (power ?x ?yDec ?zp) (lisp-value * ?x ?zp ?z))))"
    "(power 2 ?z 2)"
]
run [
    "(and (=== ?x 2) (=== ?y 8) )"
]  
//consoleQueryDriverLoop emptyDatabase;;
parse "(assert! rule (power ?x ?y ?z) (or (and (=== ?y 1) (=== ?x ?z)) (and (=== ?y 0) (=== 1 ?z)) (and (lisp-value + ?yDec 1 ?y) (power ?x ?yDec ?zp) (lisp-value * ?x ?zp ?z) )))" 0 |> Option.map (fst >> exprToStr)