Ax/test/test.ml

open Base
open OUnit2
open Helper


module Logging_graphics : Ax.React_loop.GRAPHICS_LAYER = struct
  let clear () = log "clear"
  let rect aabb color =
    logf "rect{%s;%s}"
      (Ax.Math.AABB.to_string aabb)
      (Ax.Color.to_string color)
end

;;
run_test_tt_main @@
test_list
  [
    ts (module Int)
      ["math1", 3 + 4, 7;
       "math2", 8 * 2, 16];
    ts (module IntOption)
      ["opt1", Some(3), Some(1 + 2);
       "opt2", None,    None];
    t_log "hello_world" ["hello";"world"]
      (fun () -> log "hello"; logf "w%sld" "or");
    tfails
      [ "fail_world", Failure("ello"),
        (fun () -> failwith "hello world")
      ; "math3", Division_by_zero,
        (fun () -> 3 / (2 - 4 / 2)) ];
    ts (module ListUnordered_(Int))
      ["uo1", [1;2;3], [3;2;1];
       "uo2", [1;3;4;3], [3;3;1;4];
       "uo3", [], []];

    "Draw_tree">:::begin
      let open Ax.Color in
      let open Ax.Math in
      let open Ax.Draw_tree in
      let t_render name (expected : Draw.t list) (tree : tree) =
        t name (module List_(Draw))
          expected
          (Sequence.to_list (render tree))
      in
      let rects = [ figure (Rect({w=30;h=40}, red))
                  ; figure (Rect({w=70;h=20}, blue))
                  ; figure (Rect({w=10;h=50}, black)) ] in

      [ t_render "H_rects"
          [ Rect({bx=0;by=5;bw=30;bh=40},red)
          ; Rect({bx=30;by=15;bw=70;bh=20},blue)
          ; Rect({bx=100;by=0;bw=10;bh=50},black) ]
          (arm `H rects)

      ; t_render "V_rects"
          [ Rect({bx=20;by=0;bw=30;bh=40},red)
          ; Rect({bx=0;by=40;bw=70;bh=20},blue)
          ; Rect({bx=30;by=60;bw=10;bh=50},black) ]
          (arm `V rects)

      ; t_render "H+V"
          [ Rect({bx=0;by=35;bw=20;bh=20},red)
          ; Rect({bx=25;by=0;bw=30;bh=40},blue)
          ; Rect({bx=20;by=40;bw=40;bh=50},green)
          ; Rect({bx=60;by=30;bw=10;bh=10},yellow)
          ; Rect({bx=60;by=40;bw=10;bh=20},cyan) ]
          (arm `H [ figure (Rect({w=20;h=20}, red))
                  ; arm `V [ figure (Rect({w=30;h=40}, blue))
                           ; figure (Rect({w=40;h=50}, green)) ]
                  ; arm `V [ figure (Rect({w=10;h=10}, yellow))
                           ; figure (Rect({w=10;h=20}, cyan)) ] ])

      ; t_render "ignore_captures"
          (Sequence.to_list (render (arm `H rects)))
          (capture (Ax.Event.Id.gen ()) (arm `H rects))

      ; t_render "ignore_captures'"
          (Sequence.to_list (render (arm `H rects)))
          (arm `H @@ List.map rects ~f:(fun r -> capture (Ax.Event.Id.gen ()) r))
      ]
    end;

    "Draw_tree.capture_point">:begin
      let open Ax.Color in
      let open Ax.Math in
      let open Ax.Draw_tree in
      let r10x10 = figure (Rect({w=10;h=10},red)) in
      let id1, id2 = Ax.Event.Id.gen (), Ax.Event.Id.gen () in
      let cap x y t = capture_point ~pos:{x;y} t in
      ts (module List_(Ax.Event.Id))
        [ "empty",
          [],        cap 5 5 @@ arm `H []
        ; "didnt_hit",
          [],        cap 5 5 @@ arm `H [ r10x10 ; capture id1 r10x10 ]
        ; "did_hit",
          [id1],     cap 15 5 @@ arm `H [ r10x10 ; capture id1 r10x10 ]
        ; "hit_nested",
          [id1;id2], cap 15 5 @@ capture id1 (arm `H [ r10x10 ; capture id2 r10x10 ])
        ; "hit_partial",
          [id1],     cap 5 5 @@ capture id1 (arm `H [ r10x10 ; capture id2 r10x10 ])
        ]
    end;

    "Generic_tree.Zipper">:begin
      let open Ax.Private.Generic_tree in
      let module Z = Ax.Private.Generic_tree.Zipper in
      let module Tree = struct
        type nonrec t = (char, string) t
        include Make_show_eq(Char)(String)
      end in
      let lf_x = Leaf("xx") in let lf_y = Leaf("yy") in let lf_z = Leaf("zz") in
      let build mid = Arm('P', [ lf_x ; Arm('Q', [ lf_y ; lf_z ; mid ]) ; lf_z ; lf_y ]) in
      let zip = Z.(build lf_x |> of_tree |> down_exn 1 |> down_exn 2) in
      ts (module Tree)
        [ "get_focus",
          lf_x,
          Z.get zip
        ; "set_focus",
          build lf_y,
          Z.(zip |> set lf_y |> to_tree)
        ; "set_up",
          Arm('P', [lf_x;lf_y;lf_z;lf_y]),
          Z.(zip |> up_exn |> set lf_y |> to_tree)
        ; "side_zero",
          build lf_x,
          Z.(zip |> side_exn 0 |> to_tree)
        ; "side_positive",
          Arm('P', [ lf_x ; Arm('Q', [lf_y;lf_z;lf_z]) ; lf_z ; lf_y ]),
          Z.(of_tree (build lf_x) |> down_exn 1 |> down_exn 0 |> side_exn 2 |> set lf_z |> to_tree)
        ; "side_negative",
          Arm('P', [ lf_x ; Arm('Q', [lf_x;lf_z;lf_x]) ; lf_z ; lf_y ]),
          Z.(of_tree (build lf_x) |> down_exn 1 |> down_exn 2 |> side_exn ~-2 |> set lf_x |> to_tree)
        ]
    end;

    "Draw_tree.Path">:begin
      let open Ax.Draw_tree in
      ts (module Bool) @@
      List.map ~f:(fun (n,x,y,cmp) -> (n, true, (cmp (Path.compare x y) 0)))
        [ "cmp1", [],    [],    (=)
        ; "cmp2", [1],   [],    (<)
        ; "cmp3", [],    [1],   (>)
        ; "cmp4", [2;3], [2;3], (=)
        ; "cmp5", [2;3], [2;4], (<)
        ; "cmp6", [2;7], [2;4], (>) ]
    end;

    "Draw_tree.update">:begin
      let open Ax.Color in
      let open Ax.Draw_tree in
      let f1 = Rect({w=1;h=1}, red) in
      let f2 = Rect({w=2;h=2}, blue) in
      let f3 = Rect({w=3;h=3}, white) in
      let f4 = Rect({w=4;h=4}, black) in
      let f5 = Rect({w=5;h=5}, red) in
      let r1 = figure f1 in let r2 = figure f2 in
      let r3 = figure f3 in let r4 = figure f4 in let r5 = figure f5 in
      let t0 = arm `H [ r1 ; arm `V [ r2 ; r3 ; arm `H [r4;r5] ] ] in
      let t1 = arm `H [ r4 ; arm `V [ r2 ; r3 ; arm `H [r4;r5] ] ] in
      let t2 = arm `H [ r1 ; arm `V [ r2 ; r3 ; arm `H [r1;r5] ] ] in
      let t3 = arm `H [ r1 ; arm `V [ r2 ; r5 ; arm `H [r1;r5] ] ] in
      let t4 = arm `H [ r1 ; arm `V [ r2 ; r3 ; arm `H [r1;r2] ] ] in
      ts (module Ax.Draw_tree) @@
      List.map ~f:(fun (n,t',ps) -> (n, t', apply_updates_exn (Sequence.of_list ps) t0))
        [ "root",     r1, [ [],      f1               ]
        ; "shallow",  t1, [ [0],     f4               ]
        ; "deep",     t2, [ [1;2;0], f1               ]
        ; "two",      t3, [ [1;1],   f5 ; [1;2;0], f1 ]
        ; "two'",     t3, [ [1;2;0], f1 ; [1;1], f5   ]
        ; "adjacent", t4, [ [1;2;0], f1 ; [1;2;1], f2 ] ]
    end;

    "Source">:::begin
      let open Ax.Source in
      let src1 = create () in
      let src2 = create () in
      [ tfail "empty_state" (Failure("source unset"))
          (fun () -> State.(get_exn src1 empty))
      ; t "not_equal" (module Bool)
          false
          (equal src1 src2)
      ; t "set_get" (module Int)
          5
          State.(get_exn src1 (set src1 5 empty))
      ; t "set_set_get" (module Int)
          8
          State.(get_exn src1 (set src1 8 (set src1 5 empty)))
      ; t "set_other_get" (module Int)
          5
          State.(get_exn src1 (set src2 8 (set src1 5 empty)))
      ]
    end;

    "Component.mount">:::begin
      let module T = Ax.Draw_tree in
      let module C = Ax.Component in
      let module B = Ax.Behavior in
      let module S = Ax.Source in
      let module E = Ax.Event in
      let module Sinks_ = Map_(S)(ListUnordered_(T.Path)) in
      let open Ax.Color in
      let open Ax.Math in
      let r1 = C.rect @@ B.const ({w=1;h=1}, red) in
      let r2 = C.rect @@ B.const ({w=2;h=2}, blue) in
      let r3 = C.rect @@ B.const ({w=3;h=3}, white) in
      let r_dyn b = C.rect @@ B.(b >>| fun t -> {w=t;h=t}, black) in
      let state = S.State.of_time 25 in

      [ t "static" (module Ax.Draw_tree)
          C.(let _, _, t =  mount state @@
               arm `H [ r1
                      ; arm `V [ r2
                               ; r3 ] ]
             in t)
          T.(arm `H [ figure (Rect({w=1;h=1}, red))
                    ; arm `V [ figure (Rect({w=2;h=2}, blue))
                             ; figure (Rect({w=3;h=3}, white)) ] ])

      ; "time">:::begin
          let _, callbacks, tree =
            C.(mount state @@
               arm `H
                 [ arm `V
                     [ r1
                     ; r_dyn B.time ]
                 ; r2
                 ])
          in
          [ t "init_tree" (module Ax.Draw_tree)
              T.(arm `H [ arm `V [ figure (Rect({w=1;h=1}, red))
                                 ; figure (Rect({w=25;h=25}, black)) ]
                        ; figure (Rect({w=2;h=2}, blue)) ])
              tree
          ; t "sinks" (module Sinks_)
              (Map.of_alist_exn (module S)
                 [ S.time, [ [0;1] ] ])
              (Map.map callbacks.sinks ~f:(List.map ~f:fst))
          ; t "handlers" (module ListUnordered_(E.Id))
              []
              (Map.keys callbacks.handlers) ]
        end

      ; "events">:::begin
          let src = S.Private.next_id ~diff:0 in
          let eid1 = E.Id.Private.next_id ~diff:0 in
          let eid2 = E.Id.Private.next_id ~diff:1 in
          let init_state, callbacks, tree =
            C.(mount state @@
               arm `H
                 [ arm `V
                     [ r1
                     ; fold ~init:57 ~f:(fun _ -> Int.succ)
                         r_dyn ]
                 ; callback ~f:ignore r3
                 ])
          in
          [ t "init_tree" (module Ax.Draw_tree)
              T.(arm `H [ arm `V [ figure (Rect({w=1;h=1}, red))
                                 ; capture eid1
                                     (figure (Rect({w=57;h=57}, black))) ]
                        ; capture eid2
                            (figure (Rect({w=3;h=3}, white))) ])
              tree
          ; t "init_state" (module Int)
              57 (S.State.get_exn src init_state)
          ; t "sinks" (module Sinks_)
              (Map.of_alist_exn (module S)
                 [ src, [ [0;1;0] ] ])
              (Map.map callbacks.sinks ~f:(List.map ~f:fst))
          ; t "handlers" (module ListUnordered_(E.Id))
              [eid1;eid2]
              (Map.keys callbacks.handlers)
          ]
        end;
      ]
    end;

    "React_loop">:::begin
      let open Ax.Color in
      let open Ax.Math in
      let open Ax.Component in
      let module B = Ax.Behavior in
      let current_cb = ref ignore in
      let current_time = ref 0 in
      let tick () = Int.incr current_time ; !current_cb Ax.React_loop.Tick in
      let click x y = !current_cb (Ax.React_loop.Click {x;y}) in
      let exit () = !current_cb Ax.React_loop.Exit in
      let module RL =
        Ax.React_loop.Make
          (struct
            type callback_id = unit
            let bind_callback f = current_cb := f
            let unregister () = current_cb := ignore ; logf "unreg"
            let poll_time_ms () = 1000 * !current_time
          end)
          (Logging_graphics)
      in
      [ t_log "no_callbacks"
          [ "clear" ; "rect{<0,0 4x4>;#0ff}" ; "unreg" ]
          (fun () -> RL.run (rect @@ B.const ({w=4;h=4}, cyan))
                   ; tick ()
                   ; tick ()
                   ; exit ())

      ; t_log "simple"
          [ "clear" ; "rect{<0,0 25x26>;#0ff}"
          ; "clear" ; "rect{<0,0 26x27>;#0ff}"
          ; "clear" ; "rect{<0,0 27x28>;#0ff}"
          ; "unreg" ]
          (fun () -> current_time := 25
                   ; RL.run (rect B.(time >>| fun t -> {w=t;h=t+1}, cyan))
                   ; tick ()
                   ; tick ()
                   ; exit ())

      ; t_log "click"
          [ "clear" ; "rect{<0,0 25x30>;#0ff}"
          ; "CLICK <5,5>" ; "CLICK <15,5>"
          ; "unreg" ]
          (fun () ->
             let f = function Ax.Event.Click(pos) ->
               logf "CLICK %s" (Pos.to_string pos)
             in
             RL.run (callback ~f (rect (B.const ({w=25;h=30}, cyan))))
           ; click 5 5 ; click 28 5 ; click 15 5 ; click 5 37
           ; exit ())

      ; t_log "click+state"
          [ "clear" ; "rect{<0,0 25x30>;#0ff}"
          ; "clear" ; "rect{<0,0 26x31>;#0ff}"
          ; "clear" ; "rect{<0,0 27x32>;#0ff}"
          ; "unreg" ]
          (fun () ->
             let inc _ n = n + 1 in
             let comp n = rect B.(n >>| fun n -> ({w=n;h=n+5}, cyan)) in
             RL.run (fold ~init:25 ~f:inc comp)
           ; click 5 5 ; click 28 5 ; click 15 5 ; click 5 37
           ; exit ())

      ]
    end;
  ]