write

8 months ago · 5c0350570e
1 changed files with 168 additions and 81 deletions
--- a/src/figures.ml
+++ b/src/figures.ml
@ -4,26 +4,107 @@ open Box
 (* a named box intended to be used as a pointer which implies empty content *)
 let named_ptr name = box ~fill:Color.lightgreen ~name (tex " ")

-(* a named box intended to be used as a block metadata containing ptr *)
-let named_meta_ptr name = box ~name ~fill:Color.lightred (tex "")
+(* a named scalar *)
+let named_scalar ~name v = box ~fill:Color.lightcyan ~name (tex v)
+
+(* a named taggeg pointer *)
+let named_tagged_ptr name =
+  hbox ~stroke:(Some Color.black) ~fill:Color.lightgreen
+    [ box ~stroke:None (tex "") ~name; tex ~fill:Color.lightred "" ]
+
+(* a named scalar *)
+let named_tagged_scalar ~name v =
+  hbox ~stroke:(Some Color.black) ~fill:Color.lightcyan ~name
+    [ box ~stroke:None (tex v); tex ~fill:Color.lightmagenta "" ]
+
+let tagged_scalar v =
+  hbox ~stroke:(Some Color.black) ~fill:Color.lightcyan
+    [ box ~stroke:None (tex v); tex ~fill:Color.lightmagenta "" ]
+
+type scalar =
+  | Int of int
+  | Float of float
+
+let value_to_string = function
+  | Int n -> string_of_int n
+  | Float f -> string_of_float f
+
+let name_box name = tex (Format.sprintf "\\texttt{%s}:" name)
+
+module Stack = struct
+  type value =
+    | Unboxed_ptr of string
+    | Unboxed_scalar of string * scalar
+    | Tagged_ptr of string
+    | Tagged_scalar of string * scalar
+
+  type t = value list
+
+  let value_to_box = function
+    | Unboxed_ptr name -> hbox [ name_box name; named_ptr name ]
+    | Unboxed_scalar (name, v) ->
+      let scalar = value_to_string v in
+      hbox [ name_box name; named_scalar ~name scalar ]
+    | Tagged_ptr name -> hbox [ name_box name; named_tagged_ptr name ]
+    | Tagged_scalar (name, v) ->
+      let scalar = value_to_string v in
+      hbox [ name_box name; named_tagged_scalar ~name scalar ]
+
+  let to_box l =
+    let l = List.map value_to_box l in
+    vbox ~padding:(Num.em 2.) [ tex "stack:"; vbox ~pos:`Right l ]
+end

 (* a named box intended to be used as a block metadata containing scalar *)
 let named_meta_scalar name = box ~name ~fill:Color.lightmagenta (tex "")

-(* a named box intended to be used as a block metadata containing scalar *)
-let named_meta_unboxed_float name = box ~name ~fill:Color.purple (tex "")
+(* a named box intended to be used as a block metadata containing ptr *)
+let named_meta_ptr name = box ~name ~fill:Color.lightred (tex "")

-(* a named scalar *)
-let named_scalar ~name v = box ~fill:Color.lightcyan ~name (tex v)
+module Block = struct
+  type tagged =
+    | Tagged_scalar of int
+    | Tagged_ptr of string

-(* a block of pointers, all elements are named, the first one is a metadata box all others are ptr boxes *)
-let ptr_block name names =
-  hblock @@ (named_meta_ptr name :: List.map named_ptr names)
+  type t =
+    | Unboxed_ptr of string * string list
+    | Unboxed_scalar of string * scalar list
+    | Tagged of string * tagged list
+    | Untagged of string * string list

-(* a block of scalars, only the metadata is named, all other have content (the scalar value) *)
-let scalar_block name values =
-  hblock
-  @@ (named_meta_scalar name :: List.map (tex ~fill:Color.lightcyan) values)
+  let named_meta_tagged name = box ~name ~fill:Color.lightblue (tex "")
+
+  let named_meta_untagged name = box ~name ~fill:Color.lightblue (tex "")
+
+  let tagged = function
+    | Tagged_scalar n ->
+      let v = string_of_int n in
+      tagged_scalar v
+    | Tagged_ptr name -> hbox [ named_tagged_ptr name ]
+
+  let untagged v = tex v
+
+  let to_box = function
+    | Unboxed_ptr (name, v) ->
+      hblock (named_meta_ptr name :: List.map named_ptr v)
+    | Unboxed_scalar (name, v) ->
+      let v = List.map value_to_string v in
+      hblock (named_meta_scalar name :: List.map (tex ~fill:Color.lightcyan) v)
+    | Tagged (name, v) -> hblock (named_meta_tagged name :: List.map tagged v)
+    | Untagged (name, v) ->
+      hblock (named_meta_untagged name :: List.map untagged v)
+
+  let unboxed_ptr name v = to_box @@ Unboxed_ptr (name, v)
+
+  let unboxed_scalar name v = to_box @@ Unboxed_scalar (name, v)
+
+  let tagged name v = to_box @@ Tagged (name, v)
+
+  let untagged name v = to_box @@ Untagged (name, v)
+end
+
+(* a named box intended to be used as a block metadata containing scalar *)
+let named_meta_unboxed_float name = box ~name ~fill:Color.purple (tex "")

 (* a block of unboxed floats *)
 let unboxed_floats_block name values =
@ -34,41 +115,32 @@ let unboxed_floats_block name values =
 let scalar_array name values =
  hblock ~name (List.map (tex ~fill:Color.lightcyan) values)

-(* a stack ptr entry, name is the variable name and the pointer box will also be named after it *)
-let stack_ptr name =
-  hbox [ tex (Format.sprintf "\\texttt{%s}:" name); named_ptr name ]
-
-(* a stack scalar entry, s is the variable name and the pointer box will also be named after it *)
-let stack_scalar ~name v =
-  hbox [ tex (Format.sprintf "\\texttt{%s}:" name); named_scalar ~name v ]
-
-(* a stack made of stack entries *)
-let stack l = vbox ~padding:(Num.em 2.) [ tex "stack:"; vbox ~pos:`Right l ]
-
 let figure_python_layout =
  let stack =
-    stack
-      [ stack_ptr "array1"
-      ; stack_ptr "array2"
-      ; stack_ptr "pair"
-      ; stack_ptr "x"
+    let open Stack in
+    to_box
+      [ Unboxed_ptr "array1"
+      ; Unboxed_ptr "array2"
+      ; Unboxed_ptr "pair"
+      ; Unboxed_ptr "x"
      ]
  in
  let heap =
+    let open Block in
    vbox ~padding:(Num.em 2.)
      [ tex "heap:"
      ; hbox ~padding:(Num.em 1.)
-          [ scalar_block "1_meta" [ "1" ]
-          ; scalar_block "2_meta" [ "2" ]
-          ; scalar_block "3_meta" [ "3" ]
+          [ unboxed_scalar "1_meta" [ Int 1 ]
+          ; unboxed_scalar "2_meta" [ Int 2 ]
+          ; unboxed_scalar "3_meta" [ Int 3 ]
          ]
-      ; ptr_block "array1_meta" [ "array1_1"; "array1_2"; "array1_3" ]
-      ; ptr_block "pair_meta" [ "pair_1"; "pair_2" ]
-      ; ptr_block "array2_meta" [ "array2_1"; "array2_2"; "array2_3" ]
+      ; unboxed_ptr "array1_meta" [ "array1_1"; "array1_2"; "array1_3" ]
+      ; unboxed_ptr "pair_meta" [ "pair_1"; "pair_2" ]
+      ; unboxed_ptr "array2_meta" [ "array2_1"; "array2_2"; "array2_3" ]
      ; hbox ~padding:(Num.em 1.)
-          [ scalar_block "42_meta" [ "42" ]
-          ; scalar_block "99_meta" [ "99" ]
-          ; scalar_block "666_meta" [ "666" ]
+          [ unboxed_scalar "42_meta" [ Int 42 ]
+          ; unboxed_scalar "99_meta" [ Int 99 ]
+          ; unboxed_scalar "666_meta" [ Int 666 ]
          ]
      ]
  in
@ -92,20 +164,22 @@ let figure_python_layout =

 let figure_python_layout2 =
  let stack =
-    stack
-      [ stack_ptr "array1"
-      ; stack_ptr "array2"
-      ; stack_ptr "pair"
-      ; stack_ptr "x"
+    let open Stack in
+    to_box
+      [ Unboxed_ptr "array1"
+      ; Unboxed_ptr "array2"
+      ; Unboxed_ptr "pair"
+      ; Unboxed_ptr "x"
      ]
  in
  let heap =
+    let open Block in
    vbox ~padding:(Num.em 2.)
      [ tex "heap:"
-      ; scalar_block "array1_meta" [ "1"; "2"; "3" ]
-      ; ptr_block "pair_meta" [ "pair_1"; "pair_2" ]
-      ; scalar_block "array2_meta" [ "42"; "99"; "666" ]
-      ; scalar_block "42_meta" [ "42" ]
+      ; unboxed_scalar "array1_meta" [ Int 1; Int 2; Int 3 ]
+      ; unboxed_ptr "pair_meta" [ "pair_1"; "pair_2" ]
+      ; unboxed_scalar "array2_meta" [ Int 42; Int 99; Int 666 ]
+      ; unboxed_scalar "42_meta" [ Int 42 ]
      ]
  in
  let figure = hbox ~padding:(Num.em 2.) [ stack; heap ] in
@ -122,19 +196,23 @@ let figure_python_layout2 =

 let figure_ocaml_layout =
  let stack =
-    stack
-      [ stack_ptr "array1"
-      ; stack_ptr "array2"
-      ; stack_ptr "pair"
-      ; stack_scalar ~name:"x" "42"
+    let open Stack in
+    to_box
+      [ Tagged_ptr "array1"
+      ; Tagged_ptr "array2"
+      ; Tagged_ptr "pair"
+      ; Tagged_scalar ("x", Int 42)
      ]
  in
  let heap =
+    let open Block in
    vbox ~padding:(Num.em 2.)
      [ tex "heap:"
-      ; scalar_block "array1_meta" [ "1"; "2"; "3" ]
-      ; ptr_block "pair_meta" [ "pair_1"; "pair_2" ]
-      ; scalar_block "array2_meta" [ "42"; "99"; "666" ]
+      ; tagged "array1_meta"
+          [ Tagged_scalar 1; Tagged_scalar 2; Tagged_scalar 3 ]
+      ; tagged "pair_meta" [ Tagged_ptr "pair_1"; Tagged_ptr "pair_2" ]
+      ; tagged "array2_meta"
+          [ Tagged_scalar 42; Tagged_scalar 99; Tagged_scalar 666 ]
      ]
  in
  let figure = hbox ~padding:(Num.em 2.) [ stack; heap ] in
@ -150,29 +228,31 @@ let figure_ocaml_layout =

 let figure_java_layout =
  let stack =
-    stack
-      [ stack_ptr "array1"
-      ; stack_ptr "array2"
-      ; stack_ptr "pair"
-      ; stack_scalar ~name:"x" "42"
+    let open Stack in
+    to_box
+      [ Unboxed_ptr "array1"
+      ; Unboxed_ptr "array2"
+      ; Unboxed_ptr "pair"
+      ; Unboxed_scalar ("x", Int 42)
      ]
  in
  let heap =
+    let open Block in
    vbox ~padding:(Num.em 2.)
      [ tex "heap:"
      ; scalar_array "array1_array" [ "1"; "2"; "3" ]
      ; hbox ~padding:(Num.em 1.)
-          [ scalar_block "1_meta" [ "1" ]
-          ; scalar_block "2_meta" [ "2" ]
-          ; scalar_block "3_meta" [ "3" ]
+          [ unboxed_scalar "1_meta" [ Int 1 ]
+          ; unboxed_scalar "2_meta" [ Int 2 ]
+          ; unboxed_scalar "3_meta" [ Int 3 ]
          ]
-      ; ptr_block "array1_meta" [ "array1_1"; "array1_2"; "array1_3" ]
-      ; ptr_block "pair_meta" [ "pair_1"; "pair_2" ]
-      ; ptr_block "array2_meta" [ "array2_1"; "array2_2"; "array2_3" ]
+      ; unboxed_ptr "array1_meta" [ "array1_1"; "array1_2"; "array1_3" ]
+      ; unboxed_ptr "pair_meta" [ "pair_1"; "pair_2" ]
+      ; unboxed_ptr "array2_meta" [ "array2_1"; "array2_2"; "array2_3" ]
      ; hbox ~padding:(Num.em 1.)
-          [ scalar_block "42_meta" [ "42" ]
-          ; scalar_block "99_meta" [ "99" ]
-          ; scalar_block "666_meta" [ "666" ]
+          [ unboxed_scalar "42_meta" [ Int 42 ]
+          ; unboxed_scalar "99_meta" [ Int 99 ]
+          ; unboxed_scalar "666_meta" [ Int 666 ]
          ]
      ]
  in
@ -279,13 +359,18 @@ let figure_python_block2 =

 let figure_ocaml_float1 =
  let figure =
+    let open Block in
    vbox ~padding:(Num.em 2.)
-      [ scalar_block "meta_abc" [ "$12.13$" ]
+      [ untagged "meta_abc" [ "$12.13$" ]
      ; hbox ~padding:(Num.em 1.)
-          [ ptr_block "array" [ "array_1"; "array_2"; "array_3" ]
-          ; scalar_block "meta_pi" [ "$6.28318530717958623$" ]
+          [ tagged "array"
+              [ Tagged_ptr "array_1"
+              ; Tagged_ptr "array_2"
+              ; Tagged_ptr "array_3"
+              ]
+          ; untagged "meta_pi" [ "$6.28318530717958623$" ]
          ]
-      ; scalar_block "meta_42" [ "$42.0$" ]
+      ; untagged "meta_42" [ "$42.0$" ]
      ]
  in
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
@ -305,19 +390,21 @@ let figure_ocaml_float2 =

 let figure_wasm_layout =
  let stack =
-    stack
-      [ stack_ptr "array1"
-      ; stack_ptr "array2"
-      ; stack_ptr "pair"
-      ; stack_scalar ~name:"x" "42"
+    let open Stack in
+    to_box
+      [ Unboxed_ptr "array1"
+      ; Unboxed_ptr "array2"
+      ; Unboxed_ptr "pair"
+      ; Unboxed_scalar ("x", Int 42)
      ]
  in
  let heap =
+    let open Block in
    vbox ~padding:(Num.em 2.)
      [ tex "heap:"
-      ; scalar_block "array1_meta" [ "1"; "2"; "3" ]
-      ; ptr_block "pair_meta" [ "pair_1"; "pair_2" ]
-      ; scalar_block "array2_meta" [ "42"; "99"; "666" ]
+      ; unboxed_scalar "array1_meta" [ Int 1; Int 2; Int 3 ]
+      ; unboxed_ptr "pair_meta" [ "pair_1"; "pair_2" ]
+      ; unboxed_scalar "array2_meta" [ Int 42; Int 99; Int 666 ]
      ]
  in
  let figure = hbox ~padding:(Num.em 2.) [ stack; heap ] in