patrick/FicroKanSharp
1
0
Fork 0
mirror of https://github.com/Smaug123/FicroKanSharp synced 2025-10-09 05:28:40 +00:00
Code Issues Packages Projects Releases Wiki Activity

Add a reifier

Browse Source
This commit is contained in:
Smaug123
2021-12-26 16:54:19 +00:00
parent b407409584
commit d6b6ad915e
4 changed files with 70 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

91
FicroKanSharp.Test/Arithmetic.fs
View File

@@ -123,43 +123,16 @@ module Arithmetic =
// By the power of microKanren, let some numerals be manifested!
Goal.evaluate (TypedTerm.Goal.callFresh numeralo)
|> Stream.take 4
|> Reify.withRespectToFirst
|> Seq.truncate 4
|> Seq.toList
|> List.map Option.get
|> shouldEqual
[
Map.ofList
[
VariableCount 0, TypedTerm.literal Nat.Zero |> TypedTerm.compile
]
Map.ofList
[
VariableCount 0,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 1)))
|> TypedTerm.compile
VariableCount 1, TypedTerm.literal Nat.Zero |> TypedTerm.compile
]
Map.ofList
[
VariableCount 0,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 1)))
|> TypedTerm.compile
VariableCount 1,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 3)))
|> TypedTerm.compile
VariableCount 3, TypedTerm.literal Nat.Zero |> TypedTerm.compile
]
Map.ofList
[
VariableCount 0,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 1)))
|> TypedTerm.compile
VariableCount 1,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 3)))
|> TypedTerm.compile
VariableCount 3,
TypedTerm.literal (Nat.Succ (TypedTerm.variable (VariableCount 5)))
|> TypedTerm.compile
VariableCount 5, TypedTerm.literal Nat.Zero |> TypedTerm.compile
]
TypedTerm.compile (ofInt 0)
TypedTerm.compile (ofInt 1)
TypedTerm.compile (ofInt 2)
TypedTerm.compile (ofInt 3)
]
// "pluso x y z" is "x + y == z".
@@ -201,43 +174,21 @@ module Arithmetic =
// Evaluate 1 + 1
Goal.evaluate (Goal.callFresh (fun z -> pluso (ofInt 1) (ofInt 1) (TypedTerm.variable z)))
|> Stream.toList
|> List.exactlyOne
|> shouldEqual (
Map.ofList
[
VariableCount 0, TypedTerm.compile (succ (TypedTerm.variable (VariableCount 2)))
VariableCount 1, TypedTerm.compile (ofInt 0)
VariableCount 2, TypedTerm.compile (ofInt 1)
]
)
|> Reify.withRespectToFirst
|> Seq.exactlyOne
|> Option.get
|> shouldEqual (TypedTerm.compile (ofInt 2))
// Evaluate 2 + 2
Goal.evaluate (Goal.callFresh (fun z -> pluso (ofInt 2) (ofInt 2) (TypedTerm.variable z)))
|> Stream.toList
|> List.exactlyOne
|> shouldEqual (
Map.ofList
[
VariableCount 0, TypedTerm.compile (succ (TypedTerm.variable (VariableCount 2)))
VariableCount 1, TypedTerm.compile (ofInt 1)
VariableCount 2, TypedTerm.compile (succ (TypedTerm.variable (VariableCount 5)))
VariableCount 4, TypedTerm.compile zero
VariableCount 5, TypedTerm.compile (ofInt 2)
]
)
|> Reify.withRespectToFirst
|> Seq.exactlyOne
|> Option.get
|> shouldEqual (TypedTerm.compile (ofInt 4))
// Find n such that n + n = 4
// Find all n such that n + n = 4
Goal.evaluate (Goal.callFresh (fun z -> pluso (TypedTerm.variable z) (TypedTerm.variable z) (ofInt 4)))
|> Stream.toList
|> List.exactlyOne
|> shouldEqual (
Map.ofList
[
VariableCount 0, TypedTerm.compile (succ (TypedTerm.variable (VariableCount 1)))
VariableCount 1, TypedTerm.compile (succ (TypedTerm.variable (VariableCount 4)))
VariableCount 2, TypedTerm.compile (ofInt 3)
VariableCount 4, TypedTerm.compile zero
VariableCount 5, TypedTerm.compile (ofInt 2)
]
)
|> Reify.withRespectToFirst
|> Seq.exactlyOne
|> Option.get
|> shouldEqual (TypedTerm.compile (ofInt 2))

14
FicroKanSharp.Test/Geometry.fs
View File

@@ -43,16 +43,10 @@ module Geometry =
|> TypedTerm.Literal
|> verticalo
|> Goal.evaluate
|> Stream.toList
|> List.exactlyOne
|> shouldEqual (
Map.ofList
[
VariableCount 0, TypedTerm.compile (TypedTerm.Literal 1)
VariableCount 1, TypedTerm.compile (TypedTerm.Literal 1)
VariableCount 2, TypedTerm.compile (TypedTerm.Literal 3)
]
)
|> Reify.withRespectToFirst
|> Seq.exactlyOne
|> Option.get
|> shouldEqual (TypedTerm.compile (TypedTerm.literal 1))
(Line (
TypedTerm.Literal (Point (TypedTerm.Literal 1, TypedTerm.Literal 1)),

1
FicroKanSharp/FicroKanSharp.fsproj
View File

@@ -12,6 +12,7 @@
<Compile Include="Stream.fs" />
<Compile Include="Goal.fs" />
<Compile Include="Typed.fs" />
<Compile Include="Reify.fs" />
</ItemGroup>
<ItemGroup>

44
FicroKanSharp/Reify.fs Normal file
View File

@@ -0,0 +1,44 @@
namespace FicroKanSharp
[<RequireQualifiedAccess>]
module Reify =
let private collectList<'a> (l : 'a option list) : 'a list option =
let rec go (acc : 'a list) (xs : 'a option list) =
match xs with
| [] -> Some (List.rev acc)
| None :: _ -> None
| Some x :: rest -> go (x :: acc) rest
go [] l
let rec reify (state : Map<Variable, Term>) (term : Term) : Term option =
match term with
| Term.Variable v -> Map.tryFind v state |> Option.bind (reify state)
| Term.Symbol (name, args) ->
let args =
args |> List.map (reify state) |> collectList
match args with
| None -> None
| Some args ->
Term.Symbol (name, args) |> Some
let rec withRespectToFirst (s : Stream) : seq<Term option> =
seq {
match Stream.peel s with
| None -> ()
| Some (first, other) ->
yield
reify
first
(first
|> Map.toSeq
|> Seq.head
|> fst
|> Term.Variable)
yield! withRespectToFirst other
}