paper-polymorphism-value-representation/src/figures.ml

open Mlpost
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 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 ptr *)
let named_meta_ptr name = box ~name ~fill:Color.lightred (tex "")

module Block = struct
  type tagged =
    | Tagged_scalar of int
    | Tagged_ptr of string

  type t =
    | Unboxed_ptr of string * string list
    | Unboxed_scalar of string * scalar list
    | Tagged of string * tagged list
    | Untagged of string * string list

  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 =
  hblock
  @@ named_meta_unboxed_float name
     :: List.map (tex ~fill:Color.lightcyan) values

let scalar_array name values =
  hblock ~name (List.map (tex ~fill:Color.lightcyan) values)

let figure_python_layout =
  let stack =
    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.)
          [ unboxed_scalar "1_meta" [ Int 1 ]
          ; unboxed_scalar "2_meta" [ Int 2 ]
          ; unboxed_scalar "3_meta" [ Int 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.)
          [ unboxed_scalar "42_meta" [ Int 42 ]
          ; unboxed_scalar "99_meta" [ Int 99 ]
          ; unboxed_scalar "666_meta" [ Int 666 ]
          ]
      ]
  in
  let figure = hbox ~padding:(Num.em 2.) [ stack; heap ] in
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array1" "array1_meta"
    ; ptr "array1_1" "1_meta"
    ; ptr "array1_2" "2_meta"
    ; ptr "array1_3" "3_meta"
    ; ptr "array2" "array2_meta"
    ; ptr "array2_1" "42_meta"
    ; ptr "array2_2" "99_meta"
    ; ptr "array2_3" "666_meta"
    ; ptr "pair" "pair_meta"
    ; ptr "pair_1" "array1_meta"
    ; ptr "pair_2" "array2_meta"
    ; ptr "x" "42_meta"
    ]

let figure_python_layout2 =
  let stack =
    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:"
      ; 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
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array1" "array1_meta"
    ; ptr "array2" "array2_meta"
    ; ptr "pair" "pair_meta"
    ; ptr "pair_1" "array1_meta"
    ; ptr "pair_2" "array2_meta"
    ; ptr "x" "42_meta"
    ]

let figure_ocaml_layout =
  let stack =
    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:"
      ; 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
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array1" "array1_meta"
    ; ptr "array2" "array2_meta"
    ; ptr "pair" "pair_meta"
    ; ptr "pair_1" "array1_meta"
    ; ptr "pair_2" "array2_meta"
    ]

let figure_java_layout =
  let stack =
    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.)
          [ unboxed_scalar "1_meta" [ Int 1 ]
          ; unboxed_scalar "2_meta" [ Int 2 ]
          ; unboxed_scalar "3_meta" [ Int 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.)
          [ unboxed_scalar "42_meta" [ Int 42 ]
          ; unboxed_scalar "99_meta" [ Int 99 ]
          ; unboxed_scalar "666_meta" [ Int 666 ]
          ]
      ]
  in
  let figure = hbox ~padding:(Num.em 2.) [ stack; heap ] in
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array1" "array1_array"
    ; ptr "array1_1" "1_meta"
    ; ptr "array1_2" "2_meta"
    ; ptr "array1_3" "3_meta"
    ; ptr "array2" "array2_meta"
    ; ptr "array2_1" "42_meta"
    ; ptr "array2_2" "99_meta"
    ; ptr "array2_3" "666_meta"
    ; ptr "pair" "pair_meta"
    ; ptr "pair_1" "array1_meta"
    ; ptr "pair_2" "array2_meta"
    ]

let figure_ocaml_bit1 =
  let figure =
    hblock
      [ tex "$b_{n - 1}$"
      ; tex "$b_{n - 2}$"
      ; tex "\\ldots"
      ; tex "$b_{1}$"
      ; tex ~fill:Color.lightblue "$b_{0}$"
      ]
  in
  Command.seq [ draw figure ]

let figure_ocaml_bit2 =
  let figure =
    hbox ~padding:(Num.em 2.)
      [ hblock
          [ tex "$b_{n - 1}$"
          ; tex "$b_{n - 2}$"
          ; tex "\\ldots"
          ; tex "$b_{1}$"
          ; tex ~fill:Color.lightred "$0$"
          ]
      ; hblock
          [ tex ~fill:Color.lightgreen "$b_{n - 1}$"
          ; tex ~fill:Color.lightgreen "$b_{n - 2}$"
          ; tex ~fill:Color.lightgreen "\\ldots"
          ; tex ~fill:Color.lightgreen "$b_{1}$"
          ; tex ~fill:Color.lightgreen "$0$"
          ]
      ]
  in
  Command.seq [ draw figure ]

let figure_ocaml_bit3 =
  let figure =
    hbox ~padding:(Num.em 2.)
      [ hblock
          [ tex "$b_{n - 1}$"
          ; tex "$b_{n - 2}$"
          ; tex "\\ldots"
          ; tex "$b_{1}$"
          ; tex ~fill:Color.lightmagenta "$1$"
          ]
      ; hblock
          [ tex ~fill:Color.lightcyan "$b_{n - 1}$"
          ; tex ~fill:Color.lightcyan "$b_{n - 2}$"
          ; tex ~fill:Color.lightcyan "\\ldots"
          ; tex ~fill:Color.lightcyan "$b_{1}$"
          ; tex ~fill:Color.lightmagenta "$1$"
          ]
      ]
  in
  Command.seq [ draw figure ]

let figure_python_block1 =
  let figure =
    hblock
      [ tex ~fill:Color.lightblue "$tag$"
      ; tex "$n$"
      ; tex ~fill:Color.lightyellow "$data_{0}$"
      ; tex ~fill:Color.lightyellow "\\ldots"
      ; tex ~fill:Color.lightyellow "$data_{n - 1}$"
      ]
  in
  Command.seq [ draw figure ]

let figure_python_block2 =
  let figure =
    hbox ~padding:(Num.em 2.)
      [ hblock
          [ tex ~fill:Color.lightred "pointer"
          ; tex "$2$"
          ; tex ~fill:Color.lightgreen "0x\\ldots"
          ; tex ~fill:Color.lightgreen "0x\\ldots"
          ]
      ; hblock
          [ tex ~fill:Color.lightmagenta "scalar"
          ; tex "$1$"
          ; tex ~fill:Color.lightcyan "$42$"
          ]
      ]
  in
  Command.seq [ draw figure ]

let figure_ocaml_float1 =
  let figure =
    let open Block in
    vbox ~padding:(Num.em 2.)
      [ untagged "meta_abc" [ "$12.13$" ]
      ; hbox ~padding:(Num.em 1.)
          [ tagged "array"
              [ Tagged_ptr "array_1"
              ; Tagged_ptr "array_2"
              ; Tagged_ptr "array_3"
              ]
          ; untagged "meta_pi" [ "$6.28318530717958623$" ]
          ]
      ; untagged "meta_42" [ "$42.0$" ]
      ]
  in
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array_1" "meta_abc"
    ; ptr "array_2" "meta_42"
    ; ptr "array_3" "meta_pi"
    ]

let figure_ocaml_float2 =
  let figure =
    unboxed_floats_block "meta_abc"
      [ "$12.13$"; "$42.0$"; "$6.28318530717958623$" ]
  in
  Command.seq [ draw figure ]

let figure_wasm_layout =
  let stack =
    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:"
      ; 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
  let ptr a b = Helpers.box_pointer_arrow (get a figure) (get b figure) in
  Command.seq
    [ draw figure
    ; ptr "array1" "array1_meta"
    ; ptr "array2" "array2_meta"
    ; ptr "pair" "pair_meta"
    ; ptr "pair_1" "array1_meta"
    ; ptr "pair_2" "array2_meta"
    ]

let () =
  Array.iter
    (fun (name, figure) -> Metapost.emit name (Picture.scale (Num.em 1.) figure))
    [| ("figure_python_layout", figure_python_layout)
     ; ("figure_python_layout2", figure_python_layout2)
     ; ("figure_ocaml_layout", figure_ocaml_layout)
     ; ("figure_java_layout", figure_java_layout)
     ; ("figure_ocaml_bit1", figure_ocaml_bit1)
     ; ("figure_ocaml_bit2", figure_ocaml_bit2)
     ; ("figure_ocaml_bit3", figure_ocaml_bit3)
     ; ("figure_python_block1", figure_python_block1)
     ; ("figure_python_block2", figure_python_block2)
     ; ("figure_ocaml_float1", figure_ocaml_float1)
     ; ("figure_ocaml_float2", figure_ocaml_float2)
     ; ("figure_wasm_layout", figure_wasm_layout)
    |]