aboutsummaryrefslogtreecommitdiffstats
path: root/test/unit/evaluators
diff options
context:
space:
mode:
Diffstat (limited to 'test/unit/evaluators')
-rw-r--r--test/unit/evaluators/FOL.ml71
-rw-r--r--test/unit/evaluators/Lambda.ml142
2 files changed, 213 insertions, 0 deletions
diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml
new file mode 100644
index 0000000..32f09f5
--- /dev/null
+++ b/test/unit/evaluators/FOL.ml
@@ -0,0 +1,71 @@
+open Rnt
+
+module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
+ open Alcotest
+
+ module H = Helpers.Storage.Make (S) (C)
+ module SR = Rnt.Kernel.SubstantialRelation.Make (S)
+
+ let hash s =
+ Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob
+
+ let alaric =
+ { Concepts.Tuple.type_ = "employee";
+ attributes =
+ BatMap.String.empty
+ |> BatMap.String.add "name" (Concepts.Value.String "Alaric") }
+
+ let not_a_program () =
+ Concepts.Condition.condition "not-a-program"
+ "A handle was expected to carry the program protocol and did not" Concepts.Condition.empty
+
+ let scan_a_base_relation conn =
+ let scanned =
+ begin
+ let open Utilities.Result in
+ let* tx = S.start conn in
+ let* relation = SR.empty tx ~schematics:(hash "schema") () in
+ let* relation =
+ SR.assert_tuple tx relation (Concepts.Tuple.Representation.to_blob alaric)
+ in
+ let* () = S.commit tx in
+ let* employee = SR.wrap conn relation in
+ let root =
+ Kernel.Prototype.mixture
+ [ Kernel.Prototype.Directory.of_properties
+ ["employee", employee; "fol", Rnt.Evaluators.FOL.make ()] ]
+ in
+ let context = Runtime.Context.over ~snapshot:(hash "snapshot") ~root () in
+ let* found = Runtime.Context.resolve context "fol" in
+ let* evaluator = Option.to_result ~none:(not_a_program ()) found in
+ let* interpreter =
+ Rnt.Evaluators.FOL.Program.from evaluator
+ |> Option.to_result ~none:(not_a_program ())
+ in
+ let* cursor =
+ Rnt.Evaluators.FOL.Program.invoke interpreter
+ ~program:(Rnt.Evaluators.FOL.Base "employee") context
+ in
+ let* scan = Protocols.Cursor.require cursor in
+ let* tuples = Protocols.Cursor.drain scan () in
+ Protocols.Handle.release cursor;
+ Ok (BatFingerTree.to_list tuples)
+ end
+ |> Helpers.condition_as_failure
+ in
+ check int "one tuple scanned" 1 (List.length scanned);
+ check bool "the tuple that was asserted" true
+ (List.for_all
+ (fun tuple ->
+ Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric))
+ scanned)
+
+ let suite prefix =
+ ( "fol/" ^ prefix,
+ [test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test")]
+ )
+end
+
+module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
+
+let suites () = [LMDB.suite "lmdb"]
diff --git a/test/unit/evaluators/Lambda.ml b/test/unit/evaluators/Lambda.ml
new file mode 100644
index 0000000..c1098cf
--- /dev/null
+++ b/test/unit/evaluators/Lambda.ml
@@ -0,0 +1,142 @@
+open Rnt
+
+module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
+ open Alcotest
+
+ module H = Helpers.Storage.Make (S) (C)
+ module SR = Rnt.Kernel.SubstantialRelation.Make (S)
+
+ let hash s =
+ Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob
+
+ let datum =
+ { Concepts.Tuple.type_ = "noun";
+ attributes =
+ BatMap.String.empty
+ |> BatMap.String.add "lemma" (Concepts.Value.String "datum") }
+
+ let reticulare =
+ { Concepts.Tuple.type_ = "verb";
+ attributes =
+ BatMap.String.empty
+ |> BatMap.String.add "lemma" (Concepts.Value.String "rēticulāre") }
+
+ let not_a_program () =
+ Concepts.Condition.condition "not-a-program"
+ "A handle was expected to carry the program protocol and did not" Concepts.Condition.empty
+
+ (* Sets up the relations "noun" and "verb", each holding one Latin
+ lemma, hands [term] to the lambda evaluator, and drains the cursor
+ it returns. Change [term] in the cases below to play with the
+ calculus *)
+ let evaluate conn term =
+ let open Utilities.Result in
+ let* tx = S.start conn in
+ let singleton tuple =
+ let* relation = SR.empty tx ~schematics:(hash "schema") () in
+ SR.assert_tuple tx relation (Concepts.Tuple.Representation.to_blob tuple)
+ in
+ let* noun = singleton datum in
+ let* verb = singleton reticulare in
+ let* () = S.commit tx in
+ let* noun = SR.wrap conn noun in
+ let* verb = SR.wrap conn verb in
+ let root =
+ Kernel.Prototype.mixture
+ [ Kernel.Prototype.Directory.of_properties
+ ["noun", noun; "verb", verb; "lambda", Rnt.Evaluators.Lambda.make ()] ]
+ in
+ let context = Runtime.Context.over ~snapshot:(hash "snapshot") ~root () in
+ let* found = Runtime.Context.resolve context "lambda" in
+ let* evaluator = Option.to_result ~none:(not_a_program ()) found in
+ let* interpreter =
+ Rnt.Evaluators.Lambda.Program.from evaluator
+ |> Option.to_result ~none:(not_a_program ())
+ in
+ let* cursor = Rnt.Evaluators.Lambda.Program.invoke interpreter ~program:term context in
+ let* scan = Protocols.Cursor.require cursor in
+ let* tuples = Protocols.Cursor.drain scan () in
+ Protocols.Handle.release cursor;
+ Ok (BatFingerTree.to_list tuples)
+
+ let is lemma tuple =
+ Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash lemma)
+
+ (* A bare name resolves through the context, so the relations under
+ the snapshot are the outer environment *)
+ let a_name_is_a_relation conn =
+ let scanned =
+ evaluate conn (Rnt.Evaluators.Lambda.Name "noun") |> Helpers.condition_as_failure
+ in
+ check int "one tuple scanned" 1 (List.length scanned);
+ check bool "the tuple that was asserted" true (List.for_all (is datum) scanned)
+
+ (* (\x. x) noun *)
+ let identity_applied_to_a_relation conn =
+ let open Rnt.Evaluators.Lambda in
+ let scanned =
+ evaluate conn (Apply (Abstract ("x", Name "x"), Name "noun"))
+ |> Helpers.condition_as_failure
+ in
+ check int "one tuple scanned" 1 (List.length scanned);
+ check bool "the tuple that was asserted" true (List.for_all (is datum) scanned)
+
+ (* (\x. \y. x) noun (\z. z), so the argument that wins is the one
+ the closure kept *)
+ let a_closure_keeps_its_binding conn =
+ let open Rnt.Evaluators.Lambda in
+ let scanned =
+ evaluate conn
+ (Apply
+ ( Apply (Abstract ("x", Abstract ("y", Name "x")), Name "noun"),
+ Abstract ("z", Name "z") ))
+ |> Helpers.condition_as_failure
+ in
+ check int "one tuple scanned" 1 (List.length scanned);
+ check bool "the tuple that was asserted" true (List.for_all (is datum) scanned)
+
+ (* The classic conditional, with no conditional in the calculus. A
+ boolean is the choice it makes, so [if] is application and both
+ branches are relations *)
+ let church_conditional conn =
+ let open Rnt.Evaluators.Lambda in
+ let true_ = Abstract ("then", Abstract ("else", Name "then")) in
+ let false_ = Abstract ("then", Abstract ("else", Name "else")) in
+ let if_ condition then_ else_ = Apply (Apply (condition, then_), else_) in
+ let declining = if_ true_ (Name "noun") (Name "verb") in
+ let conjugating = if_ false_ (Name "noun") (Name "verb") in
+ let declined = evaluate conn declining |> Helpers.condition_as_failure in
+ let conjugated = evaluate conn conjugating |> Helpers.condition_as_failure in
+ check int "one tuple on the then branch" 1 (List.length declined);
+ check bool "the then branch is the noun" true (List.for_all (is datum) declined);
+ check int "one tuple on the else branch" 1 (List.length conjugated);
+ check bool "the else branch is the verb" true (List.for_all (is reticulare) conjugated)
+
+ (* A program reducing to an abstraction names nothing to
+ enumerate *)
+ let an_abstraction_is_not_a_result conn =
+ let open Rnt.Evaluators.Lambda in
+ match evaluate conn (Abstract ("x", Name "x")) with
+ | Error condition ->
+ check bool "unapplied abstraction" true
+ (String.starts_with ~prefix:"unapplied-abstraction"
+ (Concepts.Condition.to_string_hum condition))
+ | Ok _ -> fail "an abstraction was enumerated"
+
+ let suite prefix =
+ ( "lambda/" ^ prefix,
+ [ test_case "a-name-is-a-relation" `Quick
+ (H.with_connection a_name_is_a_relation "lambda-name");
+ test_case "identity-applied-to-a-relation" `Quick
+ (H.with_connection identity_applied_to_a_relation "lambda-identity");
+ test_case "a-closure-keeps-its-binding" `Quick
+ (H.with_connection a_closure_keeps_its_binding "lambda-closure");
+ test_case "church-conditional" `Quick
+ (H.with_connection church_conditional "lambda-conditional");
+ test_case "an-abstraction-is-not-a-result" `Quick
+ (H.with_connection an_abstraction_is_not_a_result "lambda-abstraction") ] )
+end
+
+module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
+
+let suites () = [LMDB.suite "lmdb"]
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:14:54 +0000