translator for karuta subsystem

5 files changed, 184 insertions, 1 deletions

diff --git a/subsystem/dune b/subsystem/dune
new file mode 100644
index 0000000..9ff6f50
--- /dev/null
+++ b/subsystem/dune
@@ -0,0 +1,6 @@
+(include_subdirs qualified)
+
+(library
+ (name subsystem)
+ (public_name rnt.subsystem)
+ (libraries rnt batteries))
diff --git a/subsystem/karuta/Translator.ml b/subsystem/karuta/Translator.ml
new file mode 100644
index 0000000..1fbbd9d
--- /dev/null
+++ b/subsystem/karuta/Translator.ml
@@ -0,0 +1,116 @@
+(* A tuple of an ephemeral relation as an Erlang term in the external
+   term format, for binary_to_term on the BEAM: {Type, #{Name =>
+   Value}}, with the type, names and strings as binaries. And back,
+   from what term_to_binary writes for such a term. *)
+
+open Rnt
+
+module Error = struct
+  open Concepts.Condition
+  let malformed () =
+  Concepts.Condition.condition "malformed-beam-tuple"
+    "A term is not {Type, #{Name => Value}} of binaries, and integers that fit an int"
+    Concepts.Condition.empty
+end
+
+let binary buffer s =
+  Buffer.add_uint8 buffer 109;
+  Buffer.add_int32_be buffer (Int32.of_int (String.length s));
+  Buffer.add_string buffer s
+
+(* Every integer as a small big: a sign, then the bytes of the magnitude,
+   least significant first. binary_to_term gives back an ordinary
+   integer when it fits one, and lsr reads abs min_int as 2^62. *)
+let integer buffer n =
+  let rec digits m = if m = 0 then [] else (m land 0xff) :: digits (m lsr 8) in
+  let digits = digits (abs n) in
+  Buffer.add_uint8 buffer 110;
+  Buffer.add_uint8 buffer (List.length digits);
+  Buffer.add_uint8 buffer (if n < 0 then 1 else 0);
+  List.iter (Buffer.add_uint8 buffer) digits
+
+let encode {Concepts.Tuple.type_; attributes} =
+  let buffer = Buffer.create 64 in
+  Buffer.add_uint8 buffer 131;
+  Buffer.add_uint8 buffer 104;
+  Buffer.add_uint8 buffer 2;
+  binary buffer type_;
+  Buffer.add_uint8 buffer 116;
+  Buffer.add_int32_be buffer (Int32.of_int (BatMap.String.cardinal attributes));
+  BatMap.String.iter
+    (fun name value ->
+      binary buffer name;
+      match value with
+      | Concepts.Value.String s -> binary buffer s
+      | Concepts.Value.Integer n -> integer buffer n )
+    attributes;
+  Buffer.contents buffer
+
+(* Decoding raises within and answers a result at the end. *)
+exception Malformed
+
+let decode bytes =
+  let position = ref 0 in
+  let take n =
+    if !position + n > String.length bytes then raise Malformed;
+    let at = !position in
+    position := at + n;
+    at
+  in
+  let u8 () = String.get_uint8 bytes (take 1) in
+  let i32 () = Int32.to_int (String.get_int32_be bytes (take 4)) in
+  let u32 () = i32 () land 0xffff_ffff in
+  let expect byte = if u8 () <> byte then raise Malformed in
+  let binary () =
+    let n = u32 () in
+    String.sub bytes (take n) n
+  in
+  (* a sign, then at most 8 bytes of the magnitude, least significant
+     first; an int holds magnitudes up to 2^62 - 1, or 2^62 when
+     negative *)
+  let big n =
+    let negative = u8 () = 1 in
+    if n > 8 then raise Malformed;
+    let at = take n in
+    let rec magnitude i m =
+      if i < 0 then m
+      else
+        magnitude (i - 1)
+          (Int64.logor (Int64.shift_left m 8) (Int64.of_int (String.get_uint8 bytes (at + i))))
+    in
+    let m = magnitude (n - 1) 0L in
+    let limit = if negative then Int64.neg (Int64.of_int min_int) else Int64.of_int max_int in
+    if Int64.compare m 0L < 0 || Int64.compare m limit > 0 then raise Malformed;
+    Int64.to_int (if negative then Int64.neg m else m)
+  in
+  (* term_to_binary writes an integer in the least of these that holds it *)
+  let value () =
+    match u8 () with
+    | 109 -> Concepts.Value.String (binary ())
+    | 97 -> Concepts.Value.Integer (u8 ())
+    | 98 -> Concepts.Value.Integer (i32 ())
+    | 110 -> Concepts.Value.Integer (big (u8 ()))
+    | _ -> raise Malformed
+  in
+  let rec attributes n map =
+    if n = 0 then map
+    else begin
+      expect 109;
+      let name = binary () in
+      let value = value () in
+      attributes (n - 1) (BatMap.String.add name value map)
+    end
+  in
+  match
+    expect 131;
+    expect 104;
+    expect 2;
+    expect 109;
+    let type_ = binary () in
+    expect 116;
+    let attributes = attributes (u32 ()) BatMap.String.empty in
+    if !position <> String.length bytes then raise Malformed;
+    {Concepts.Tuple.type_; attributes}
+  with
+  | tuple -> Ok tuple
+  | exception Malformed -> Error (Error.malformed ())
diff --git a/test/dune b/test/dune
index d58e758..bb946a8 100644
--- a/test/dune
+++ b/test/dune
@@ -2,4 +2,4 @@
 
 (test
  (name test_rnt)
- (libraries rnt alcotest qcheck-core qcheck-alcotest batteries))
+ (libraries rnt subsystem alcotest qcheck-core qcheck-alcotest batteries))
diff --git a/test/test_rnt.ml b/test/test_rnt.ml
index c6fcfd5..299c6ca 100644
--- a/test/test_rnt.ml
+++ b/test/test_rnt.ml
@@ -7,6 +7,7 @@ let all_suites =
   @ Unit.Kernel.Session.suites ()
   @ Unit.Kernel.Branch.suites ()
   @ Unit.Evaluators.FOL.suites ()
+  @ Unit.Karuta.Translator.suites ()
   @ Integration.Registration.suites ()
 
 let () = Alcotest.run "RNT" all_suites
diff --git a/test/unit/karuta/Translator.ml b/test/unit/karuta/Translator.ml
new file mode 100644
index 0000000..92bd57f
--- /dev/null
+++ b/test/unit/karuta/Translator.ml
@@ -0,0 +1,60 @@
+open Rnt
+module Translator = Subsystem.Karuta.Translator
+module Gen = QCheck2.Gen
+
+let value =
+  Gen.oneof
+    [ Gen.map (fun s -> Concepts.Value.String s) Gen.string_small;
+      Gen.map
+        (fun n -> Concepts.Value.Integer n)
+        (Gen.oneof [Gen.int; Gen.oneofl [min_int; max_int]]) ]
+
+let tuple =
+  Gen.map2
+    (fun type_ attributes -> {Concepts.Tuple.type_; attributes= BatMap.String.of_list attributes})
+    Gen.string_small
+    (Gen.small_list (Gen.pair Gen.string_small value))
+
+let print tuple = tuple.Concepts.Tuple.type_ ^ " " ^ Concepts.Tuple.to_string tuple
+
+let same (a : Concepts.Tuple.t) (b : Concepts.Tuple.t) =
+  a.type_ = b.type_ && BatMap.String.equal Concepts.Value.equal a.attributes b.attributes
+
+let decodes_to_itself =
+  QCheck2.Test.make ~name:"a tuple decodes to itself" ~print tuple (fun tuple ->
+      match Translator.decode (Translator.encode tuple) with
+      | Ok decoded -> same tuple decoded
+      | Error _ -> false )
+
+let a_cut_term_is_refused =
+  QCheck2.Test.make ~name:"a cut term is refused" ~print tuple (fun tuple ->
+      let bytes = Translator.encode tuple in
+      List.init (String.length bytes) (fun n -> Translator.decode (String.sub bytes 0 n))
+      |> List.for_all Result.is_error )
+
+(* term_to_binary writes an integer that fits a byte as 97, and one that
+   fits 32 bits as 98, which encode never does *)
+let erlang_integers_decode =
+  QCheck2.Test.make ~name:"an integer as term_to_binary writes it decodes to itself"
+    ~print:string_of_int
+    (Gen.oneof [Gen.int_range 0 255; Gen.int_range (-0x8000_0000) 0x7fff_ffff])
+    (fun n ->
+      let term = Buffer.create 32 in
+      (* {<<"t">>, #{<<"n">> => n}} *)
+      Buffer.add_string term
+        "\131\104\002\109\000\000\000\001t\116\000\000\000\001\109\000\000\000\001n";
+      if n >= 0 && n < 256 then begin
+        Buffer.add_uint8 term 97; Buffer.add_uint8 term n
+      end
+      else begin
+        Buffer.add_uint8 term 98;
+        Buffer.add_int32_be term (Int32.of_int n)
+      end;
+      match Translator.decode (Buffer.contents term) with
+      | Ok {attributes; _} -> BatMap.String.bindings attributes = ["n", Concepts.Value.Integer n]
+      | Error _ -> false )
+
+let suites () =
+  [ ( "karuta/translator",
+      List.map QCheck_alcotest.to_alcotest
+        [decodes_to_itself; a_cut_term_is_refused; erlang_integers_decode] ) ]