format and where claude on fol

1 files changed, 90 insertions, 6 deletions

diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index f337d61..1064c74 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -12,7 +12,7 @@ module Error = struct
     condition "not-a-fol-program" "The evaluator was given a program of another kind" empty
 
   let unknown_attribute name =
-    condition "unknown-attribute" "A plan projected an attribute its relation does not have"
+    condition "unknown-attribute" "A plan named an attribute its relation does not have"
       ("attribute" |=| Concepts.Value.String name)
 
   let malformed_program () =
@@ -26,7 +26,13 @@ end
 
 let name = "fol"
 
-type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t
+type binding = Concepts.Value.value BatMap.String.t
+
+type 'r term =
+  | Base of 'r
+  | Project of 'r term * string BatFingerTree.t
+  | Where of 'r term * binding
+
 type plan = Protocols.Handle.t term
 type Kernel.Program.kind += Fol of Kernel.Path.t term
 
@@ -42,6 +48,16 @@ let rec bencode_of_term =
           Bencode.Dict
             ["term", bencode_of_term term; "attributes", strings (BatFingerTree.to_list attributes)]
         )
+  | Where (term, binding) ->
+      Bencode.Tagged
+        ( 'w',
+          Bencode.Dict
+            [ "term", bencode_of_term term;
+              ( "binding",
+                Bencode.Dict
+                  ( BatMap.String.bindings binding
+                  |> List.map (fun (name, value) -> name, Concepts.Tuple.bencode_of_value value) ) )
+            ] )
 
 let rec term_of_bencode =
   let open Utilities.Result in
@@ -56,10 +72,32 @@ let rec term_of_bencode =
       let* term = Bencode.field "term" data |>> term_of_bencode in
       let* attributes = Bencode.field "attributes" data |>> strings in
       Ok (Project (term, BatFingerTree.of_list attributes))
+  | Bencode.Tagged ('w', data) ->
+      let* term = Bencode.field "term" data |>> term_of_bencode in
+      let* binding = Bencode.field "binding" data |>> Bencode.as_dict in
+      let* binding =
+        List.map
+          (fun (name, value) ->
+            Concepts.Tuple.value_of_bencode value |> Result.map (fun value -> name, value) )
+          binding
+        |> Utilities.List.sequence
+      in
+      Ok (Where (term, BatMap.String.of_list binding))
   | _ -> Error (Error.malformed_program ())
 
 let encode term = bencode_of_term term |> Bencode.to_bytes |> Bytes.to_string
 let decode source = Utilities.Result.(Bencode.of_bytes (Bytes.of_string source) |>> term_of_bencode)
+let bound binding = BatSet.String.of_enum (BatMap.String.keys binding)
+let names attributes = BatSet.String.of_list (BatFingerTree.to_list attributes)
+
+let rec push = function
+  | Base relation -> Base relation
+  | Project (term, attributes) -> Project (push term, attributes)
+  | Where (term, binding) -> (
+    match push term with
+    | Project (term, attributes) when BatSet.String.subset (bound binding) (names attributes) ->
+        Project (push (Where (term, binding)), attributes)
+    | term -> Where (term, binding) )
 
 (* TODO: To strenghten our checks for self references, we need to
    construct a graph and see raise a condition if there are self
@@ -87,8 +125,11 @@ let instantiate within =
     | Project (term, attributes) ->
         let* plan = bind expanding term in
         Ok (Project (plan, attributes))
+    | Where (term, binding) ->
+        let* plan = bind expanding term in
+        Ok (Where (plan, binding))
   in
-  bind []
+  fun term -> bind [] term |> Result.map push
 
 let restrict attributes description =
   let open Utilities.Result in
@@ -106,6 +147,18 @@ let rec describe =
   function
   | Base relation -> Protocols.Relation.heading relation
   | Project (plan, attributes) -> describe plan |>> restrict attributes
+  | Where (plan, binding) ->
+      let* heading = describe plan in
+      let* _ = restrict (BatFingerTree.of_enum (BatMap.String.keys binding)) heading in
+      Ok heading
+
+let index_for relation binding =
+  let open Utilities.Option in
+  let* indexed = Protocols.Indexed.from relation in
+  let* attribute =
+    List.find_opt (fun a -> BatMap.String.mem a binding) (Protocols.Indexed.indexes indexed)
+  in
+  Some (indexed, attribute)
 
 let rec modes =
   let open Utilities.Result in
@@ -114,9 +167,13 @@ let rec modes =
       let* relation = Protocols.Relation.require relation in
       Protocols.Relation.modes relation
   | Project (plan, attributes) ->
-      modes plan
-      |> Result.map
-           (Concepts.Mode.project (BatSet.String.of_list (BatFingerTree.to_list attributes)))
+      modes plan |> Result.map (Concepts.Mode.project (names attributes))
+  | Where (plan, binding) -> (
+      let* modes = modes plan in
+      match plan with
+      | Base relation when Option.is_some (index_for relation binding) ->
+          Ok (Concepts.Mode.given (bound binding) modes)
+      | _ -> Ok modes )
 
 let project description relation =
   let open Utilities.Result in
@@ -146,6 +203,23 @@ let project description relation =
   in
   Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce)
 
+let agrees binding {Concepts.Tuple.attributes; _} =
+  BatMap.String.for_all
+    (fun name value ->
+      Option.fold ~none:false ~some:(Concepts.Value.equal value)
+        (BatMap.String.find_opt name attributes) )
+    binding
+
+let restricted binding relation =
+  let open Utilities.Result in
+  let* cursor =
+    match index_for relation binding with
+    | Some (indexed, attribute) ->
+        Protocols.Indexed.lookup indexed attribute (BatMap.String.find attribute binding)
+    | None -> Protocols.Enumerable.cursor relation
+  in
+  Ok (Kernel.Generator.filter (agrees binding) cursor)
+
 let contains relation tuple =
   Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple)
 
@@ -167,6 +241,16 @@ let rec execute plan =
   | Project (plan, _) ->
       let* relation = execute plan in
       Ok (derive relation description modes (project description))
+  | Where (plan, binding) ->
+      let* relation =
+        match plan with
+        | Base relation -> Ok (Protocols.Handle.move relation)
+        | plan -> execute plan
+      in
+      Ok
+        (derive
+           ~decide:(fun tuple -> if agrees binding tuple then contains relation tuple else Ok false)
+           relation description modes (restricted binding) )
 
 class evaluator =
   object (self)