graphDrawing.ml 29.2 KB
Newer Older
Benoit Barbot's avatar
update    
Benoit Barbot committed
1
2
open Js_of_ocaml

Benoit Barbot's avatar
Benoit Barbot committed
3
type node_type = int
Benoit Barbot's avatar
Benoit Barbot committed
4

Benoit Barbot's avatar
init  
Benoit Barbot committed
5
6
module type GRAPH = sig
  type graph
Benoit Barbot's avatar
Benoit Barbot committed
7
8
9
10
11

  type node = private [> `Empty ]

  type arc = private [> `Empty ]

Benoit Barbot's avatar
Benoit Barbot committed
12
  type attribute_id
Benoit Barbot's avatar
Benoit Barbot committed
13
14
15
16
17
18
19

  type attribute =
    [ `String of string
    | `Choice of string list
    | `Check of bool
    | `ControlPoint of DrawingGeom.point
    | `Color of string ]
Benoit Barbot's avatar
Benoit Barbot committed
20

Benoit Barbot's avatar
Benoit Barbot committed
21
  val iter_node : graph -> (node -> node_type -> unit) -> unit
Benoit Barbot's avatar
Benoit Barbot committed
22

Benoit Barbot's avatar
init  
Benoit Barbot committed
23
  val shapes_of_node : graph -> node -> DrawingGeom.shape list
Benoit Barbot's avatar
Benoit Barbot committed
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

  val get_new_node_choice :
    graph -> ((float * float -> DrawingGeom.shape) * node_type) list

  val new_node : graph -> node_type -> float * float -> node

  val move_node : graph -> float * float -> node -> unit

  val update_node_attribute :
    graph -> node -> attribute_id -> attribute option -> bool

  val get_new_node_attribute :
    graph -> node -> (string * (unit -> attribute_id)) list

  val get_node_attribute :
    graph -> node -> string * (attribute_id * string * attribute) list

Benoit Barbot's avatar
init  
Benoit Barbot committed
41
  val remove_node : graph -> node -> unit
Benoit Barbot's avatar
Benoit Barbot committed
42

Benoit Barbot's avatar
init  
Benoit Barbot committed
43
  val iter_arc : graph -> (arc -> unit) -> unit
Benoit Barbot's avatar
Benoit Barbot committed
44
45
46
47
48
49
50
51

  val shapes_of_arc :
    graph ->
    DrawingGeom.shape ->
    DrawingGeom.shape ->
    arc ->
    DrawingGeom.shape list

Benoit Barbot's avatar
Benoit Barbot committed
52
  val new_arc : graph -> node -> node -> arc option
Benoit Barbot's avatar
Benoit Barbot committed
53
54
55
56
57
58
59
60
61
62

  val update_arc_attribute :
    graph -> arc -> attribute_id -> attribute option -> bool

  val get_new_arc_attribute :
    graph -> arc -> (string * (unit -> attribute_id)) list

  val get_arc_attribute :
    graph -> arc -> string * (attribute_id * string * attribute) list

Benoit Barbot's avatar
init  
Benoit Barbot committed
63
  val remove_arc : graph -> arc -> unit
Benoit Barbot's avatar
Benoit Barbot committed
64
65

  val nodes_of_arc : graph -> arc -> node * node
Benoit Barbot's avatar
init  
Benoit Barbot committed
66
67

  val new_graph : unit -> graph
Benoit Barbot's avatar
Benoit Barbot committed
68

Benoit Barbot's avatar
init  
Benoit Barbot committed
69
  val read_graph : string -> graph
Benoit Barbot's avatar
Benoit Barbot committed
70
71

  val print_graph : (string * (Format.formatter -> graph -> unit) * string) list
Benoit Barbot's avatar
init  
Benoit Barbot committed
72
73
end

Benoit Barbot's avatar
Benoit Barbot committed
74
module GraphEditor (G : GRAPH) = struct
Benoit Barbot's avatar
init  
Benoit Barbot committed
75
76
77
  open DrawingGeom
  open UtilsWeb

Benoit Barbot's avatar
Benoit Barbot committed
78
79
  let width = 4096

Benoit Barbot's avatar
init  
Benoit Barbot committed
80
  let height = 2048
Benoit Barbot's avatar
Benoit Barbot committed
81

Benoit Barbot's avatar
init  
Benoit Barbot committed
82
83
  let increment = 5

Benoit Barbot's avatar
Benoit Barbot committed
84
85
86
87
  type selectable_type =
    | Empty
    | Node of G.node
    | Arc of G.arc
Benoit Barbot's avatar
Benoit Barbot committed
88
89
    | Area of DrawingGeom.Rectangle.t

Benoit Barbot's avatar
Benoit Barbot committed
90
91
92
93
94
95
96
97
98
99
  type editor_state = {
    mutable zoom : float;
    mutable origin : float * float;
    mutable selected_obj : selectable_type;
    mutable graph : G.graph;
    callback : G.graph -> unit;
    canvas : Js_of_ocaml.Dom_html.canvasElement Js.t;
    attribute_list : Js_of_ocaml.Dom_html.divElement Js.t;
    ctx : Dom_html.canvasRenderingContext2D Js.t;
  }
Benoit Barbot's avatar
init  
Benoit Barbot committed
100

Benoit Barbot's avatar
Benoit Barbot committed
101
  let center_of_node s node =
Benoit Barbot's avatar
Benoit Barbot committed
102
    DrawingGeom.center_shapes @@ G.shapes_of_node s.graph node
Benoit Barbot's avatar
Benoit Barbot committed
103
104
105

  let node_in_rect s rect =
    let nlist = ref [] in
Benoit Barbot's avatar
Benoit Barbot committed
106
    G.iter_node s.graph (fun node _ -> nlist := node :: !nlist);
Benoit Barbot's avatar
Benoit Barbot committed
107
    !nlist
Benoit Barbot's avatar
Benoit Barbot committed
108
    |> List.map (fun node -> (center_of_node s node, node))
Benoit Barbot's avatar
Benoit Barbot committed
109
110
    |> Rectangle.contains rect

Benoit Barbot's avatar
init  
Benoit Barbot committed
111
112
113
114
  let download content name mimetype =
    let c = Js.string content
    and n = Js.string name
    and m = Js.string mimetype in
Benoit Barbot's avatar
Benoit Barbot committed
115
116
117
    Js.Unsafe.fun_call
      (Js.Unsafe.js_expr "download")
      [| Js.Unsafe.inject c; Js.Unsafe.inject n; Js.Unsafe.inject m |]
Benoit Barbot's avatar
Benoit Barbot committed
118

Benoit Barbot's avatar
Benoit Barbot committed
119
120
121
122
  let to_screen s (x, y) =
    let xo, yo = s.origin in
    let x2 = (x -. xo) *. s.zoom and y2 = (y -. yo) *. s.zoom in
    (x2, y2)
Benoit Barbot's avatar
init  
Benoit Barbot committed
123

Benoit Barbot's avatar
Benoit Barbot committed
124
125
126
  let from_screen s (x, y) =
    let xo, yo = s.origin in
    ((x /. s.zoom) +. xo, (y /. s.zoom) +. yo)
Benoit Barbot's avatar
prog    
Benoit Barbot committed
127
128

  let stick_coord s ~exact pos =
Benoit Barbot's avatar
Benoit Barbot committed
129
    let x, y = from_screen s pos in
Benoit Barbot's avatar
prog    
Benoit Barbot committed
130
    let i = if exact then 1.0 else float increment in
Benoit Barbot's avatar
Benoit Barbot committed
131
    let f z = i *. floor ((z /. i) +. 0.5) in
Benoit Barbot's avatar
prog    
Benoit Barbot committed
132
    to_screen s (f x, f y)
Benoit Barbot's avatar
Benoit Barbot committed
133

Benoit Barbot's avatar
init  
Benoit Barbot committed
134
135
  let clean s =
    let ctx = s.ctx in
Benoit Barbot's avatar
Benoit Barbot committed
136
    (*let color = CSS.Color.string_of_t (CSS.Color.rgb 220 220 220) in
Benoit Barbot's avatar
Benoit Barbot committed
137
138
139
      ctx##.fillStyle := (Js.string  color);
      ctx##(fillRect 0.0 0.0 (float width) (float height));*)
    ctx ## (clearRect 0.0 0.0 (float width) (float height));
Benoit Barbot's avatar
init  
Benoit Barbot committed
140
    let colors = CSS.Color.string_of_t (CSS.Color.rgb 0 0 0) in
Benoit Barbot's avatar
Benoit Barbot committed
141
    ctx##.strokeStyle := Js.string colors
Benoit Barbot's avatar
init  
Benoit Barbot committed
142
143

  let set_style ctx is_selected is_over =
Benoit Barbot's avatar
Benoit Barbot committed
144
145
146
147
148
149
150
    let color =
      if is_selected then (250, 10, 10)
      else if is_over then (10, 10, 250)
      else (10, 10, 10)
    in
    DrawingGeom.setFillColor ctx (255, 255, 255);
    DrawingGeom.setStrokeColor ctx (0, 0, 0);
Benoit Barbot's avatar
Benoit Barbot committed
151
    DrawingGeom.setAmbiant ctx color
Benoit Barbot's avatar
init  
Benoit Barbot committed
152

Benoit Barbot's avatar
Benoit Barbot committed
153
  let shapes_of_arc s obj =
Benoit Barbot's avatar
Benoit Barbot committed
154
155
156
    let source, target = G.nodes_of_arc s.graph obj in
    let source_sh = G.shapes_of_node s.graph source |> DrawingGeom.tangible
    and target_sh = G.shapes_of_node s.graph target |> DrawingGeom.tangible in
Benoit Barbot's avatar
Benoit Barbot committed
157
158
159
    let shapes = G.shapes_of_arc s.graph source_sh target_sh obj in
    shapes

Benoit Barbot's avatar
Benoit Barbot committed
160
161
  let shape_of_control_point p = `Rectangle (p, 1.0, 1.5, 0.78540)

Benoît Barbot's avatar
Benoît Barbot committed
162
  (*`Circle (p,1.7)*)
Benoit Barbot's avatar
Benoit Barbot committed
163
164
165
166

  let layout_graph s =
    let nodes = Hashtbl.create 10 in
    let cmp = ref 0 in
Benoit Barbot's avatar
Benoit Barbot committed
167
    G.iter_node s.graph (fun node _ ->
Benoit Barbot's avatar
Benoit Barbot committed
168
169
170
        let center =
          DrawingGeom.center_shapes @@ G.shapes_of_node s.graph node
        in
Benoit Barbot's avatar
Benoit Barbot committed
171
172
173
174
        Hashtbl.add nodes node (!cmp, center);
        incr cmp);
    let arcs = ref [] in
    G.iter_arc s.graph (fun arc ->
Benoit Barbot's avatar
Benoit Barbot committed
175
176
177
178
179
180
181
182
        let source, target = G.nodes_of_arc s.graph arc in
        arcs :=
          ( arc,
            fst @@ Hashtbl.find nodes source,
            fst @@ Hashtbl.find nodes target )
          :: !arcs);
    let nodearray = Array.make !cmp (`Empty, (0.0, 0.0)) in
    Hashtbl.iter (fun node (i, pos) -> nodearray.(i) <- (node, pos)) nodes;
Benoit Barbot's avatar
Benoit Barbot committed
183
    let new_layout = Layout.layout_graph nodearray !arcs in
Benoit Barbot's avatar
Benoit Barbot committed
184
    Array.iter (fun (node, pos) -> G.move_node s.graph pos node) new_layout
Benoit Barbot's avatar
Benoit Barbot committed
185

Benoit Barbot's avatar
init  
Benoit Barbot committed
186
  let draw s mouse_pos =
Benoit Barbot's avatar
Benoit Barbot committed
187
    clean s;
Benoit Barbot's avatar
init  
Benoit Barbot committed
188
    let found_node = ref false in
Benoit Barbot's avatar
Benoit Barbot committed
189
    G.iter_node s.graph (fun obj _ ->
Benoit Barbot's avatar
init  
Benoit Barbot committed
190
191
192
        let shapes = G.shapes_of_node s.graph obj in
        let over_node = is_over_shapes (to_screen s) mouse_pos shapes in
        found_node := !found_node || over_node;
Benoit Barbot's avatar
Benoit Barbot committed
193
194
195
196
197
198
199
200
        let node_selected =
          match s.selected_obj with
          | Node obj2 when obj = obj2 -> true
          | Area r ->
              []
              <> DrawingGeom.Rectangle.contains r [ (center_of_node s obj, ()) ]
          | _ -> false
        in
Benoit Barbot's avatar
Benoit Barbot committed
201
        set_style s.ctx node_selected over_node;
Benoit Barbot's avatar
Benoit Barbot committed
202
        List.iter (fun sh -> draw_shape (to_screen s) s.ctx sh) shapes);
Benoit Barbot's avatar
init  
Benoit Barbot committed
203
    G.iter_arc s.graph (fun obj ->
Benoit Barbot's avatar
Benoit Barbot committed
204
205
        let shapes = shapes_of_arc s obj in
        let over_arc = is_over_shapes (to_screen s) mouse_pos shapes in
Benoit Barbot's avatar
Benoit Barbot committed
206
        set_style s.ctx (s.selected_obj = Arc obj) (over_arc && not !found_node);
Benoit Barbot's avatar
Benoit Barbot committed
207
        draw_shapes (to_screen s) s.ctx ~thick:2.0 shapes;
Benoit Barbot's avatar
Benoit Barbot committed
208
        if s.selected_obj = Arc obj then
Benoit Barbot's avatar
Benoit Barbot committed
209
210
          G.get_arc_attribute s.graph obj
          |> snd
Benoit Barbot's avatar
Benoit Barbot committed
211
212
213
214
215
216
217
          |> List.iter (function
               | _, _, `ControlPoint p ->
                   let sh = shape_of_control_point p in
                   set_style s.ctx false
                     (is_over_shape (to_screen s) mouse_pos sh);
                   draw_shapes (to_screen s) s.ctx [ sh ]
               | _ -> ()))
Benoit Barbot's avatar
Benoit Barbot committed
218

Benoit Barbot's avatar
Benoit Barbot committed
219
  let get_exchange_string graph =
Benoit Barbot's avatar
Benoit Barbot committed
220
    let open GenericSerializer in
Benoit Barbot's avatar
Benoit Barbot committed
221
222
223
    let buff = Buffer.create 20 in
    Buffer.add_string buff "GEX";
    let map = Hashtbl.create 10 in
Benoit Barbot's avatar
Benoit Barbot committed
224
    let i = ref 0 in
Benoit Barbot's avatar
Benoit Barbot committed
225
226
227
228
229
    G.iter_node graph (fun node node_type ->
        Hashtbl.add map node !i;
        incr i;
        Buffer.add_char buff 'N';
        Buffer.add_char buff (b64_of_ui node_type);
Benoit Barbot's avatar
Benoit Barbot committed
230
        let f1, f2 = DrawingGeom.center_shapes (G.shapes_of_node graph node) in
Benoit Barbot's avatar
Benoit Barbot committed
231
        buff_float buff f1;
Benoit Barbot's avatar
fix    
Benoit Barbot committed
232
        buff_float buff f2;
Benoit Barbot's avatar
Benoit Barbot committed
233
        let attr = snd @@ G.get_node_attribute graph node in
Benoit Barbot's avatar
Benoit Barbot committed
234
        buff_list buff write_attribute attr);
Benoit Barbot's avatar
Benoit Barbot committed
235
    G.iter_arc graph (fun arc ->
Benoit Barbot's avatar
Benoit Barbot committed
236
        let n1, n2 = G.nodes_of_arc graph arc in
Benoit Barbot's avatar
Benoit Barbot committed
237
        Buffer.add_char buff 'A';
Benoit Barbot's avatar
Benoit Barbot committed
238
239
        buff_int buff (Hashtbl.find map n1);
        buff_int buff (Hashtbl.find map n2);
Benoit Barbot's avatar
Benoit Barbot committed
240
        let attr = snd @@ G.get_arc_attribute graph arc in
Benoit Barbot's avatar
Benoit Barbot committed
241
242
        buff_list buff write_attribute attr);
    let def_attr = snd @@ G.get_arc_attribute graph `Empty in
Benoît Barbot's avatar
add def    
Benoît Barbot committed
243
244
245
    Buffer.add_char buff 'D';
    buff_list buff write_attribute def_attr;

Benoit Barbot's avatar
Benoit Barbot committed
246
    Bytes.to_string @@ Buffer.to_bytes buff
Benoit Barbot's avatar
bug    
Benoit Barbot committed
247

Benoit Barbot's avatar
Benoit Barbot committed
248
  let rec find_and_remove x = function
Benoit Barbot's avatar
Benoit Barbot committed
249
250
251
252
253
    | [] -> (None, [])
    | (tx, ty) :: q when tx = x -> (Some ty, q)
    | t :: q ->
        let v, q2 = find_and_remove x q in
        (v, t :: q2)
Benoit Barbot's avatar
Benoit Barbot committed
254

Benoît Barbot's avatar
add def    
Benoît Barbot committed
255
  let parse_exchange_node graph str pos node =
Benoit Barbot's avatar
Benoit Barbot committed
256
    let open GenericSerializer in
Benoit Barbot's avatar
Benoit Barbot committed
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
    let npos, attrl = list_buff str read_attribute pos in
    let _, cattr = G.get_node_attribute graph node in
    let attrl2 =
      List.fold_left
        (fun _ (id, name, _) ->
          let found, nl = find_and_remove name attrl in
          ( match found with
          | Some v ->
              if not (G.update_node_attribute graph node id (Some v)) then
                print_endline ("Fail to update default attribute:" ^ str)
          | None -> () );
          nl)
        attrl cattr
    in

    List.iter
      (fun (str, attr) ->
        match List.assoc_opt str (G.get_new_node_attribute graph node) with
        | None -> print_endline ("Fail to create attribute:" ^ str)
        | Some f ->
            let nat = f () in
            if not (G.update_node_attribute graph node nat (Some attr)) then
              print_endline ("Fail to update attribute:" ^ str))
      attrl2;
    npos

  let parse_exchange_arc graph str pos n1 n2 =
    let open GenericSerializer in
    let npos, attrl = list_buff str read_attribute pos in
    ( match G.new_arc graph n1 n2 with
    | None -> print_endline "Fail to add arc"
    | Some arc ->
        let _, cattr = G.get_arc_attribute graph arc in
        let attrl2 =
          List.fold_left
            (fun _ (id, name, _) ->
              let found, nl = find_and_remove name attrl in
              ( match found with
              | Some v ->
                  if not (G.update_arc_attribute graph arc id (Some v)) then
                    print_endline ("Fail to update default attribute:" ^ str)
              | None -> () );
              nl)
            attrl cattr
        in

        List.iter
          (fun (str, attr) ->
            match List.assoc_opt str (G.get_new_arc_attribute graph arc) with
            | None -> print_endline ("Fail to create attribute:" ^ str)
            | Some f ->
                let nat = f () in
                if not (G.update_arc_attribute graph arc nat (Some attr)) then
                  print_endline ("Fail to update attribute:" ^ str))
          attrl2 );
    npos
Benoît Barbot's avatar
add def    
Benoît Barbot committed
313
314
315
316
317
318
319
320

  let parse_exchange_string str =
    let open GenericSerializer in
    let graph = G.new_graph () in
    let length = String.length str in
    assert (String.sub str 0 3 = "GEX");
    let pos = ref 3 in
    let map = Hashtbl.create 10 in
Benoit Barbot's avatar
Benoit Barbot committed
321
322
323
324
325
326
    let i = ref 0 in
    while !pos + 4 <= length && str.[!pos] = 'N' do
      let node_type = ui_of_b64 str.[!pos + 1] in
      let p1, f1 = float_buff str (!pos + 2) in
      let p2, f2 = float_buff str p1 in
      let node = G.new_node graph node_type (f1, f2) in
Benoît Barbot's avatar
add def    
Benoît Barbot committed
327
328
329
      Hashtbl.add map !i node;
      incr i;
      pos := parse_exchange_node graph str p2 node
Benoit Barbot's avatar
Benoit Barbot committed
330
    done;
Benoit Barbot's avatar
Benoit Barbot committed
331
332
333
    while !pos + 7 <= length && str.[!pos] = 'A' do
      let p1, nid1 = int_buff str (!pos + 1) in
      let p2, nid2 = int_buff str p1 in
Benoit Barbot's avatar
Benoit Barbot committed
334
335
      let n1 = Hashtbl.find map nid1 in
      let n2 = Hashtbl.find map nid2 in
Benoit Barbot's avatar
Benoit Barbot committed
336
      pos := parse_exchange_arc graph str p2 n1 n2
Benoit Barbot's avatar
Benoit Barbot committed
337
    done;
Benoit Barbot's avatar
Benoit Barbot committed
338
    pos := parse_exchange_node graph str (!pos + 1) `Empty;
Benoit Barbot's avatar
Benoit Barbot committed
339
    graph
Benoit Barbot's avatar
Benoit Barbot committed
340

Benoit Barbot's avatar
init  
Benoit Barbot committed
341
342
  let save_load_html s =
    let loadfile st =
Benoit Barbot's avatar
Benoit Barbot committed
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
      s.graph <-
        ( if String.sub st 0 3 = "GEX" then parse_exchange_string st
        else G.read_graph st );
      draw s (0.0, 0.0)
    in

    let dl =
      ( "GEX",
        fun () ->
          let string_value = get_exchange_string s.graph in
          download string_value "graph.gex" "data:application/xml" )
      :: List.map
           (fun (x, df, fn) ->
             ( x,
               fun () ->
                 let string_value = Format.asprintf "%a" df s.graph in
                 download string_value fn "data:application/xml" ))
           G.print_graph
    in
    div
      [
        p
          [
            txt "Load file: ";
Benoit Barbot's avatar
Benoit Barbot committed
367
            (*input ~a:[a_id "filein"; a_input_type `File; a_onchange (change_file loadfile)] ();*)
Benoit Barbot's avatar
add id    
Benoit Barbot committed
368
369
            text_input ~_type:"file" ~id:"filein"
              ~on_change:(change_file loadfile) "";
Benoit Barbot's avatar
Benoit Barbot committed
370
            choice_input ~init_value:(Some "Download")
Benoit Barbot's avatar
Benoit Barbot committed
371
372
              ~on_change:(fun x -> (List.assoc x dl) ())
              (List.map fst dl);
Benoit Barbot's avatar
Benoit Barbot committed
373
            (*button ~a:[a_onclick (fun _ ->
Benoit Barbot's avatar
Benoit Barbot committed
374
                           let string_value = Format.asprintf "%a" G.print_graph s.graph in                            download string_value (G.download_file_name s.graph) "data:application/xml") ]
Benoit Barbot's avatar
Benoit Barbot committed
375
376
              [pcdata "Download"];*)
            (*button ~a:[a_onclick (fun _ ->
Benoit Barbot's avatar
Benoit Barbot committed
377
378
                           let string_value = get_exchange_string s.graph in
                           download string_value "graph.gex" "data:application/xml") ]
Benoit Barbot's avatar
Benoit Barbot committed
379
              [pcdata "Get GEX"];*)
Benoit Barbot's avatar
Benoit Barbot committed
380
381
382
383
384
385
386
387
388
            button
              ~on_click:(fun _ ->
                layout_graph s;
                draw s (0.0, 0.0))
              [ txt "Layout Graph" ];
            update_link "Direct Link" (fun n ->
                n ^ "?q=" ^ get_exchange_string s.graph);
          ];
      ]
Benoit Barbot's avatar
Benoit Barbot committed
389

Benoit Barbot's avatar
Benoit Barbot committed
390
  let init ?saveload ?slider ?callback canvas attribute_list =
Benoit Barbot's avatar
Benoit Barbot committed
391
392
393
394
395
396
    (*let init canvas_elt attr_list_div saveload_elt slider_elt =
      let canvas = Eliom_content.Html.To_dom.of_canvas canvas_elt in
      let attribute_list = Eliom_content.Html.To_dom.of_div attr_list_div in
      let saveload = Eliom_content.Html.To_dom.of_div saveload_elt in
      let slider = Eliom_content.Html.To_dom.of_input slider_elt in*)
    let ctx = canvas ## (getContext Dom_html._2d_) in
Benoit Barbot's avatar
init  
Benoit Barbot committed
397
398
    ctx##.lineCap := Js.string "round";
    ctx##.font := Js.string "15px Arial";
Benoit Barbot's avatar
Benoit Barbot committed
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
    let s =
      {
        zoom = 1.5;
        origin = (-50.0, -50.0);
        selected_obj = Empty;
        graph = G.new_graph ();
        callback = (match callback with None -> ignore | Some s -> s);
        canvas;
        ctx;
        attribute_list;
      }
    in
    ( try
        match getURL "q" with
        | Some str ->
            if String.sub str 0 3 = "GEX" then
              s.graph <- parse_exchange_string str
        | None -> ()
      with _ -> () );
    ( match slider with
    | Some sl ->
        sl##.value := Js.string @@ string_of_float @@ ((s.zoom -. 0.2) *. 50.);
        sl##.oninput :=
          Dom.handler (fun _ ->
              s.zoom <-
                0.2 +. ((float_of_string @@ Js.to_string sl##.value) /. 50.0);
              draw s (0.0, 0.0);
              Js._true)
    | None -> () );
    ( match saveload with
    | Some div ->
        Dom.appendChild div
          ((*Eliom_content.Html.To_dom.of_div*) save_load_html s)
    | None -> () );
Benoit Barbot's avatar
init  
Benoit Barbot committed
433
434
    s

Benoit Barbot's avatar
Benoit Barbot committed
435
  let draw_choice s (x, y) =
Benoit Barbot's avatar
init  
Benoit Barbot committed
436
437
438
    let color = CSS.Color.string_of_t (CSS.Color.rgb 50 255 50) in
    let l = G.get_new_node_choice s.graph in
    let n = List.length l in
Benoit Barbot's avatar
Benoit Barbot committed
439
440
441
442
443
444
445
446
447
448
    let rad = match n with 1 -> 0.0 | 2 -> 20.0 | 3 -> 26.0 | _ -> 30.0 in
    List.iteri
      (fun i (fd, _) ->
        let x2, y2 =
          (x, y) +.. rot (float i /. float n *. 2.0 *. pi) (rad, 0.0)
        in
        let pos3 =
          (x, y) +.. rot ((0.5 +. float i) /. float n *. 2.0 *. pi) (rad, 0.0)
        in
        s.ctx##.strokeStyle := Js.string color;
Benoit Barbot's avatar
init  
Benoit Barbot committed
449
450
        s.ctx##.lineWidth := 2.0;
        s.ctx##beginPath;
Benoit Barbot's avatar
Benoit Barbot committed
451
452
        s.ctx ## (moveTo x y);
        s.ctx ## (lineTo x2 y2);
Benoit Barbot's avatar
init  
Benoit Barbot committed
453
454
        s.ctx##stroke;
        let shape = fd (from_screen s pos3) in
Benoit Barbot's avatar
Benoit Barbot committed
455
456
457
        draw_shape (to_screen s) s.ctx shape)
      l;
    List.map (fun (_, id) -> id) l
Benoit Barbot's avatar
init  
Benoit Barbot committed
458

Benoit Barbot's avatar
Benoit Barbot committed
459
460
  let which_choice clist pos =
    let n = List.length clist in
Benoit Barbot's avatar
Benoit Barbot committed
461
462
    let rho = mod_float ((1.0 *. pi) +. angle pos) (2.0 *. pi) in
    let base = 2.0 *. pi /. float n in
Benoit Barbot's avatar
Benoit Barbot committed
463
    List.nth clist (int_of_float (rho /. base))
Benoit Barbot's avatar
Benoit Barbot committed
464

Benoit Barbot's avatar
Benoit Barbot committed
465
466
  let get_coord ?(exact = false) s ev =
    let x0, y0 = Dom_html.elementClientPosition s.canvas in
Benoit Barbot's avatar
prog    
Benoit Barbot committed
467
    stick_coord s ~exact (float (ev##.clientX - x0), float (ev##.clientY - y0))
Benoit Barbot's avatar
Benoit Barbot committed
468

Benoit Barbot's avatar
init  
Benoit Barbot committed
469
  let is_over_object s mouse_pos =
Benoit Barbot's avatar
Benoit Barbot committed
470
    let obj = ref Empty in
Benoit Barbot's avatar
init  
Benoit Barbot committed
471

Benoit Barbot's avatar
Benoit Barbot committed
472
    G.iter_node s.graph (fun o _ ->
Benoit Barbot's avatar
init  
Benoit Barbot committed
473
        let shapes = G.shapes_of_node s.graph o in
Benoit Barbot's avatar
Benoit Barbot committed
474
        if is_over_shapes (to_screen s) mouse_pos shapes then obj := Node o);
Benoit Barbot's avatar
Benoit Barbot committed
475
    if !obj = Empty then
Benoit Barbot's avatar
init  
Benoit Barbot committed
476
      G.iter_arc s.graph (fun o ->
Benoit Barbot's avatar
Benoit Barbot committed
477
          let shapes = shapes_of_arc s o in
Benoit Barbot's avatar
Benoit Barbot committed
478
          if is_over_shapes (to_screen s) mouse_pos shapes then obj := Arc o);
Benoit Barbot's avatar
Benoit Barbot committed
479
    !obj
Benoit Barbot's avatar
Benoit Barbot committed
480

Benoit Barbot's avatar
Benoit Barbot committed
481
  let rec html_of_attr s attr nattr cb =
Benoit Barbot's avatar
Benoit Barbot committed
482
    let callback id oldv newv =
Benoit Barbot's avatar
Benoit Barbot committed
483
484
485
486
      let nva =
        match oldv with
        | `ControlPoint pt -> `ControlPoint pt
        | `Choice _ -> `Choice [ newv ]
Benoit Barbot's avatar
prog    
Benoit Barbot committed
487
        | `Color _ -> `Color newv
Benoit Barbot's avatar
Benoit Barbot committed
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
        | `String _ -> `String newv
        | `Check _ -> `Check (bool_of_string newv)
      in
      let v =
        match s.selected_obj with
        | Node node ->
            let v2 = G.update_node_attribute s.graph node id (Some nva) in
            if v2 then (
              try ignore @@ G.get_node_attribute s.graph node
              with _ ->
                s.selected_obj <- Empty;
                update_attr s );
            v2
        | Arc arc ->
            let v2 = G.update_arc_attribute s.graph arc id (Some nva) in
            if v2 then (
              try ignore @@ G.get_arc_attribute s.graph arc
              with _ ->
                s.selected_obj <- Empty;
                update_attr s );
            v2
Benoit Barbot's avatar
Benoit Barbot committed
509
        | Empty -> G.update_arc_attribute s.graph `Empty id (Some nva)
Benoit Barbot's avatar
Benoit Barbot committed
510
511
        | Area _ -> false
      in
Benoit Barbot's avatar
Benoit Barbot committed
512
      s.callback s.graph;
Benoit Barbot's avatar
Benoit Barbot committed
513
514
515
      draw s (0.0, 0.0);
      v
    in
Benoit Barbot's avatar
Benoit Barbot committed
516
    let callback_supr id _ =
Benoit Barbot's avatar
Benoit Barbot committed
517
518
519
      let _ =
        match s.selected_obj with
        | Node node -> G.update_node_attribute s.graph node id None
Benoit Barbot's avatar
Benoit Barbot committed
520
        | Arc arc -> G.update_arc_attribute s.graph arc id None
Benoit Barbot's avatar
Benoit Barbot committed
521
        | Empty -> G.update_arc_attribute s.graph `Empty id None
Benoit Barbot's avatar
Benoit Barbot committed
522
523
524
525
526
        | Area _ -> false
      in
      draw s (0.0, 0.0);
      update_attr s
    in
Benoit Barbot's avatar
init  
Benoit Barbot committed
527
    let attr_tr =
Benoit Barbot's avatar
Benoit Barbot committed
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
      List.map
        (function
          | id, n, v -> (
              let delbutton =
                button ~on_click:(callback_supr id)
                  [
                    (*span ~a:[a_class ["glyphicon";"glyphicon-remove"]] [];*)
                    txt "X";
                  ]
              in
              match v with
              | `ControlPoint (x, y) ->
                  tr
                    [
                      td [ txt n; txt (Printf.sprintf ": (%g,%g)" x y) ];
                      td [];
                      td [ delbutton ];
                    ]
              | `Check b ->
                  tr
                    [
                      td [ txt n; txt ": " ];
                      td [ check_input ~on_change:(callback id v) b ];
                      td [ delbutton ];
                    ]
              | `Choice (_ :: _ as l) ->
                  tr
                    [
                      td [ txt n; txt ": " ];
                      td
                        [
                          choice_input
                            ~on_change:(fun nv -> ignore @@ callback id v nv)
                            l;
                        ];
                      td [ delbutton ];
                    ]
              | `Choice [] -> tr []
              | `String str ->
                  tr
                    [
                      td [ txt n; txt ": " ];
                      td [ text_input ~on_change:(callback id v) str ];
                      td [ delbutton ];
                    ]
              | `Color str ->
                  tr
                    [
                      td [ txt n; txt ": " ];
                      td [ color_input ~on_change:(callback id v) str ];
                      td [ delbutton ];
                    ] ))
        attr
    in
    let new_attr =
      tr
        [
          td
            [
              choice_input ~init_value:(Some "New Attribute")
                ~on_change:(fun x -> cb x)
                nattr;
            ];
          td [];
        ]
    in
    attr_tr @ if nattr <> [] then [ new_attr ] else []

  and set_selected s sobj mouse_pos =
Benoit Barbot's avatar
Benoit Barbot committed
597
    s.selected_obj <- sobj;
Benoit Barbot's avatar
init  
Benoit Barbot committed
598
    draw s mouse_pos;
Benoit Barbot's avatar
Benoit Barbot committed
599
    update_attr s
Benoit Barbot's avatar
Benoit Barbot committed
600

Benoit Barbot's avatar
Benoit Barbot committed
601
  and update_attr s =
Benoit Barbot's avatar
Benoit Barbot committed
602
    let name, attr =
Benoit Barbot's avatar
Benoit Barbot committed
603
      match s.selected_obj with
Benoit Barbot's avatar
Benoit Barbot committed
604
      | Node node -> G.get_node_attribute s.graph node
Benoit Barbot's avatar
Benoit Barbot committed
605
      | Arc arc -> G.get_arc_attribute s.graph arc
Benoit Barbot's avatar
Benoit Barbot committed
606
      | Empty -> G.get_arc_attribute s.graph `Empty
Benoit Barbot's avatar
Benoit Barbot committed
607
      | Area _ -> ("Selection", [])
Benoit Barbot's avatar
Benoit Barbot committed
608
    in
Benoit Barbot's avatar
init  
Benoit Barbot committed
609
610
611

    let a = Dom.list_of_nodeList s.attribute_list##.childNodes in
    List.iter (fun x -> Dom.removeChild s.attribute_list x) a;
Benoit Barbot's avatar
Benoit Barbot committed
612

Benoit Barbot's avatar
Benoit Barbot committed
613
614
    let divat = div [ txt name ] in
    Dom.appendChild s.attribute_list divat;
Benoit Barbot's avatar
init  
Benoit Barbot committed
615

Benoit Barbot's avatar
Benoit Barbot committed
616
617
618
    let nattr =
      match s.selected_obj with
      | Node node -> G.get_new_node_attribute s.graph node
Benoit Barbot's avatar
Benoit Barbot committed
619
      | Arc arc -> G.get_new_arc_attribute s.graph arc
Benoit Barbot's avatar
Benoit Barbot committed
620
      | Empty -> G.get_new_arc_attribute s.graph `Empty
Benoit Barbot's avatar
Benoit Barbot committed
621
622
623
      | Area _ -> []
    in
    let nsattr, _ = List.split nattr in
Benoit Barbot's avatar
Benoit Barbot committed
624

Benoit Barbot's avatar
init  
Benoit Barbot committed
625
626
    let new_attr_callback so =
      let v = List.assoc so nattr in
Benoît Barbot's avatar
node    
Benoît Barbot committed
627
      ignore @@ v ();
Benoit Barbot's avatar
Benoit Barbot committed
628
629
630
      draw s (0.0, 0.0);
      update_attr s
    in
Benoit Barbot's avatar
Benoit Barbot committed
631

Benoit Barbot's avatar
init  
Benoit Barbot committed
632
    let slHTML = table (html_of_attr s attr nsattr new_attr_callback) in
Benoit Barbot's avatar
Benoit Barbot committed
633

Benoit Barbot's avatar
Benoit Barbot committed
634
635
    Dom.appendChild s.attribute_list slHTML;
    Dom.appendChild s.attribute_list (br ());
Benoit Barbot's avatar
init  
Benoit Barbot committed
636

Benoit Barbot's avatar
Benoit Barbot committed
637
    if match s.selected_obj with Empty -> false | _ -> true then
Benoit Barbot's avatar
init  
Benoit Barbot committed
638
      let suprcb _ =
Benoit Barbot's avatar
Benoit Barbot committed
639
        ( match s.selected_obj with
Benoit Barbot's avatar
Benoit Barbot committed
640
641
        | Empty -> ()
        | Node node -> G.remove_node s.graph node
Benoit Barbot's avatar
Benoit Barbot committed
642
643
644
645
        | Arc arc -> G.remove_arc s.graph arc
        | Area r ->
            let l = node_in_rect s r in
            List.iter (fun node -> G.remove_node s.graph node) l );
Benoit Barbot's avatar
Benoit Barbot committed
646
        s.callback s.graph;
Benoit Barbot's avatar
Benoit Barbot committed
647
648
649
650
        set_selected s Empty (0.0, 0.0)
      in
      Dom.appendChild s.attribute_list
        (button ~on_click:suprcb [ txt "Delete" ])
Benoit Barbot's avatar
Benoit Barbot committed
651

Benoit Barbot's avatar
init  
Benoit Barbot committed
652
653
  let init_client s =
    s.ctx##.lineCap := Js.string "round";
Benoit Barbot's avatar
Benoit Barbot committed
654
    draw s (0.0, 0.0);
Benoit Barbot's avatar
init  
Benoit Barbot committed
655

Benoit Barbot's avatar
Benoit Barbot committed
656
    let open Lwt in
Benoit Barbot's avatar
update    
Benoit Barbot committed
657
    let open Js_of_ocaml_lwt.Lwt_js_events in
Benoit Barbot's avatar
Benoit Barbot committed
658
    let osobj = ref Empty in
Benoit Barbot's avatar
init  
Benoit Barbot committed
659
    Lwt.async (fun () ->
Benoit Barbot's avatar
Benoit Barbot committed
660
661
        Lwt.pick
          [
Benoit Barbot's avatar
init  
Benoit Barbot committed
662
663
            (* highlight element *)
            mousemoves s.canvas (fun ev _ ->
Benoit Barbot's avatar
Benoit Barbot committed
664
                let mouse_pos = get_coord ~exact:true s ev in
Benoit Barbot's avatar
Benoit Barbot committed
665
                let sobj = is_over_object s mouse_pos in
Benoit Barbot's avatar
Benoit Barbot committed
666
667
668
                if sobj <> !osobj then (
                  draw s mouse_pos;
                  osobj := sobj );
Benoit Barbot's avatar
init  
Benoit Barbot committed
669
670
671
                Lwt.return ());
            (* mouse down *)
            mousedowns s.canvas (fun ev _ ->
Benoit Barbot's avatar
Benoit Barbot committed
672
                let mouse_pos = get_coord ~exact:true s ev in
Benoit Barbot's avatar
Benoit Barbot committed
673
                let sobj = is_over_object s mouse_pos in
Benoit Barbot's avatar
Benoit Barbot committed
674

Benoit Barbot's avatar
Benoit Barbot committed
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
                let cp =
                  match s.selected_obj with
                  | Arc arc ->
                      G.get_arc_attribute s.graph arc
                      |> snd
                      |> List.filter (function
                           | _, _, `ControlPoint _ -> true
                           | _ -> false)
                      |> List.map (function
                           | id, n, `ControlPoint p ->
                               (id, n, shape_of_control_point p)
                           | _ -> failwith "notpossible")
                      |> List.filter (function _, _, sh ->
                             is_over_shape (to_screen s) mouse_pos sh)
                  | _ -> []
                in

                ( match (s.selected_obj, sobj) with
                | Area r, Node n
                  when List.mem n (node_in_rect s r)
                       && ev##.shiftKey = Js._false ->
                    ()
                | Arc _, _ when cp <> [] -> ()
                | _ -> set_selected s sobj mouse_pos );
                match (s.selected_obj, ev##.shiftKey) with
                (* New node *)
                | Empty, b when b = Js._true ->
                    let nchoice = draw_choice s mouse_pos in
                    mouseup s.canvas >>= fun ev2 ->
                    let vect = mouse_pos -.. get_coord ~exact:true s ev2 in
                    let nn =
                      G.new_node s.graph
                        (which_choice nchoice vect)
                        (from_screen s (get_coord s ev))
                    in
                    s.callback s.graph;
                    set_selected s (Node nn) (get_coord s ev);
                    Lwt.return ()
Benoit Barbot's avatar
Benoit Barbot committed
713
                (* Select area *)
Benoit Barbot's avatar
Benoit Barbot committed
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
                | Empty, _ ->
                    Lwt.pick
                      [
                        ( mouseup s.canvas >>= fun ev ->
                          let mouse_pos = get_coord ~exact:true s ev in
                          draw s mouse_pos;
                          Lwt.return () );
                        mousemoves s.canvas (fun ev _ ->
                            let mouse_pos2 = get_coord ~exact:true s ev in
                            let pos1 = from_screen s mouse_pos in
                            let pos2 = from_screen s mouse_pos2 in
                            let rect = Rectangle.of_border pos1 pos2 in
                            s.selected_obj <- Area rect;
                            draw s mouse_pos2;
                            set_style s.ctx false true;
                            s.ctx##.fillStyle :=
                              Js.string "rgba(0, 0, 255, 0.3)";
                            draw_shapes (to_screen s) s.ctx [ `Rectangle rect ];
                            Lwt.return ());
                      ]
Benoit Barbot's avatar
init  
Benoit Barbot committed
734
                (* new Arc *)
Benoit Barbot's avatar
Benoit Barbot committed
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
                | Node node1, b when b = Js._true ->
                    Lwt.pick
                      [
                        ( mouseup s.canvas >>= fun ev ->
                          let mouse_pos = get_coord ~exact:true s ev in
                          let nsobj = is_over_object s mouse_pos in
                          ( match nsobj with
                          | Node node2 ->
                              ignore @@ G.new_arc s.graph node1 node2
                          | _ -> () );
                          s.callback s.graph;
                          draw s mouse_pos;
                          Lwt.return () );
                        mousemoves s.canvas (fun ev _ ->
                            let mouse_pos2 = get_coord ~exact:true s ev in
                            draw s mouse_pos2;
                            set_style s.ctx true false;
                            let pos1 = from_screen s mouse_pos2 in
                            let shape =
                              G.shapes_of_node s.graph node1
                              |> DrawingGeom.tangible
                            in
                            let pos2 = projection_shape pos1 shape in
                            draw_shapes (to_screen s) s.ctx ~thick:2.0
                              [ `Line (pos2, pos1); `Arrow (pos1, pos2) ];
                            Lwt.return ());
                      ]
Benoit Barbot's avatar
Benoit Barbot committed
762
                (* Move on node *)
Benoit Barbot's avatar
Benoit Barbot committed
763
764
765
766
767
768
769
770
771
772
                | Node node, _ ->
                    Lwt.pick
                      [
                        (mouseup s.canvas >>= fun _ -> Lwt.return ());
                        mousemoves s.canvas (fun ev _ ->
                            let mouse_pos = get_coord s ev in
                            G.move_node s.graph (from_screen s mouse_pos) node;
                            draw s mouse_pos;
                            Lwt.return ());
                      ]
Benoit Barbot's avatar
Benoit Barbot committed
773
                (* Move control point *)
Benoit Barbot's avatar
Benoit Barbot committed
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
                | Arc arc, _ -> (
                    match cp with
                    | [] -> Lwt.return ()
                    | (id, _, _) :: _ ->
                        Lwt.pick
                          [
                            mousemoves s.canvas (fun ev _ ->
                                let nmouse_pos = get_coord s ev in
                                let pt = from_screen s nmouse_pos in
                                ignore
                                @@ G.update_arc_attribute s.graph arc id
                                     (Some (`ControlPoint pt));
                                draw s nmouse_pos;
                                update_attr s;
                                Lwt.return ());
                            (mouseup s.canvas >>= fun _ -> Lwt.return ());
                          ] )
Benoit Barbot's avatar
Benoit Barbot committed
791
                (* Move several node*)
Benoit Barbot's avatar
Benoit Barbot committed
792
                | Area r, _ ->
Benoit Barbot's avatar
Benoit Barbot committed
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
                    let ls = node_in_rect s r in
                    let base_node =
                      match sobj with Node n -> n | _ -> List.hd ls
                    in
                    let cpointlistref = ref [] in
                    let init_mouse = from_screen s mouse_pos in
                    G.iter_arc s.graph (fun arc ->
                        G.get_arc_attribute s.graph arc
                        |> snd
                        |> List.iter (function
                             | id, _, `ControlPoint p
                               when DrawingGeom.Rectangle.contain r p ->
                                 cpointlistref :=
                                   (id, p -.. init_mouse, arc) :: !cpointlistref
                             | _ -> ()));

                    Lwt.pick
                      [
                        (mouseup s.canvas >>= fun _ -> Lwt.return ());
                        mousemoves s.canvas (fun ev _ ->
                            let mouse_pos = get_coord s ev in
                            let pos1 = from_screen s mouse_pos in
                            let vect = pos1 -.. center_of_node s base_node in
                            List.iter
                              (fun node ->
                                let pos2 = center_of_node s node in
                                G.move_node s.graph (pos2 +.. vect) node)
                              ls;
                            List.iter
                              (fun (id, p, arc) ->
                                ignore
                                @@ G.update_arc_attribute s.graph arc id
                                     (Some (`ControlPoint (p +.. pos1))))
                              !cpointlistref;
                            draw s mouse_pos;
                            Lwt.return ());
                      ]);
          ])
Benoit Barbot's avatar
init  
Benoit Barbot committed
831
end