Commit 972a1468 authored by Benoit Barbot's avatar Benoit Barbot
Browse files

progress

parent 4f3dcacd
Pipeline #910 passed with stage
in 23 seconds
...@@ -2,7 +2,7 @@ type def = unit ...@@ -2,7 +2,7 @@ type def = unit
type state = string * (string list) type state = string * (string list)
type arc = string list * DrawingGeom.path_elem list type arc = string list * DrawingGeom.path_elem list
type attribute_id = A | B of int | C of int type attribute_id = A | B of int | C of int | D of int
type attribute = [ `Choice of string list type attribute = [ `Choice of string list
| `ControlPoint of DrawingGeom.point | `ControlPoint of DrawingGeom.point
| `String of string | `String of string
...@@ -60,9 +60,9 @@ let get_state_attr (s, at) = ...@@ -60,9 +60,9 @@ let get_state_attr (s, at) =
"Node", ((A,"content",`String s) :: "Node", ((A,"content",`String s) ::
(List.mapi (fun i sv -> (List.mapi (fun i sv ->
(match is_prefix sv "color=" with (match is_prefix sv "color=" with
Some x -> B i,"color",`Color x Some x -> B i,"Color",`Color x
| None -> (match is_prefix sv "fill=" with | None -> (match is_prefix sv "fill=" with
| Some x -> C i, "fill", `Color x | Some x -> C i, "Fill", `Color x
| None -> | None ->
(B i),"Attribute", (`String sv )))) at)) (B i),"Attribute", (`String sv )))) at))
...@@ -70,26 +70,27 @@ let update_state_attr (s,at) attr_id = function ...@@ -70,26 +70,27 @@ let update_state_attr (s,at) attr_id = function
| None -> begin match attr_id with | None -> begin match attr_id with
A -> Some ("",at) A -> Some ("",at)
| B id -> Some (s,replace_list id None at) | B id -> Some (s,replace_list id None at)
| C _ -> None | _-> None
end end
| Some (`String newv) -> begin | Some (`String newv) -> begin
match attr_id with match attr_id with
A -> Some (newv,at) A -> Some (newv,at)
| B id -> Some (s,replace_list id (Some newv) at) | B id -> Some (s,replace_list id (Some newv) at)
| C _ -> None | _-> None
end end
| Some (`Color newv) -> begin | Some (`Color newv) -> begin
match attr_id with match attr_id with
A -> Some (newv,at) A -> Some (newv,at)
| B id -> Some (s,replace_list id (Some ("color="^newv)) at) | B id -> Some (s,replace_list id (Some ("color="^newv)) at)
| C id -> Some (s,replace_list id (Some ("fill="^newv)) at) | C id -> Some (s,replace_list id (Some ("fill="^newv)) at)
| _ -> None
end end
| _ -> None | _ -> None
let get_new_state_attr (s,at) _ = [ let get_new_state_attr (s,at) _ = [
"Attribute", (fun (s,at) -> (s, at@[""]), B (List.length at)) ; "Attribute", (fun (s,at) -> (s, at@[""]), B (List.length at)) ;
"color", (fun (s,at) -> (s, at@["color=black"]), B (List.length at)) ; "Color", (fun (s,at) -> (s, at@["color=black"]), B (List.length at)) ;
"fill", (fun (s,at) -> (s, at@["fill=black"]), C (List.length at)) ; "Fill", (fun (s,at) -> (s, at@["fill=black"]), C (List.length at)) ;
] ]
...@@ -99,22 +100,21 @@ let init_arc n1 n2 = ...@@ -99,22 +100,21 @@ let init_arc n1 n2 =
let draw_arc (at,cn) (source_sh,target_sh) = let draw_arc (at,cn) (source_sh,target_sh) =
let open DrawingGeom in let open DrawingGeom in
let text = "" in
let pos1 = center_shape source_sh let pos1 = center_shape source_sh
and pos2 = center_shape target_sh in and pos2 = center_shape target_sh in
if source_sh<>target_sh || cn<>[] then begin let lcol = at
let middle = mult 0.5 (pos1 +.. pos2) in |> List.map (fun a -> is_prefix a "color=")
let rho = angle (pos1 -..pos2) in |> List.filter (function None -> false | _ -> true)
let textvect = middle +.. rot rho (0.0,8.0) in |> List.map (function Some x -> `Colors (DrawingGeom.Color.parse x,(255,255,255))
let shape_list = shapes_of_path source_sh cn ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh in | None -> `Colors ((0,0,0),(255,255,255))) in
shape_list @ [`Text(textvect, text) ] let l = if source_sh<>target_sh || cn<>[] then begin
shapes_of_path source_sh cn ~arrow2:(Some (fun x y -> `SimpleArrow (x,y))) target_sh
end else begin end else begin
let p1 = pos1 +.. (40.0 , -.25.0) let p1 = pos1 +.. (40.0 , -.25.0)
and p2 = pos2 +.. (40.0 , 25.0) in and p2 = pos2 +.. (40.0 , 25.0) in
let textvect = pos1 +.. (120.0,0.0) in shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
let shape_list = shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh in end in
shape_list @ [ `Text(textvect, text);] lcol @ l
end
(* let _,bline = List.fold_left (fun (pi,l) pip -> (pip, `Bezier2 (pi,(0.0,0.0),pip) :: l)) (* let _,bline = List.fold_left (fun (pi,l) pip -> (pip, `Bezier2 (pi,(0.0,0.0),pip) :: l))
...@@ -124,7 +124,10 @@ let draw_arc (at,cn) (source_sh,target_sh) = ...@@ -124,7 +124,10 @@ let draw_arc (at,cn) (source_sh,target_sh) =
let get_arc_attr (atlist,controllist) = let get_arc_attr (atlist,controllist) =
"Arc", ( "Arc", (
(List.mapi (fun i sv -> (B i),"Attribute", (`String sv )) atlist) (List.mapi (fun i sv ->
(match is_prefix sv "color=" with
Some x -> D i,"Color",`Color x
| None -> (B i),"Attribute", (`String sv ))) atlist)
@ (List.mapi (fun i sv -> (match sv with @ (List.mapi (fun i sv -> (match sv with
`Text (_,s) -> C i,"Node", `Text (_,s) -> C i,"Node",
(`String s) (`String s)
...@@ -161,11 +164,17 @@ let update_arc_attr (at,cn) attr_id = function ...@@ -161,11 +164,17 @@ let update_arc_attr (at,cn) attr_id = function
end) (0,[]) cn in end) (0,[]) cn in
Some (at,(List.rev listcn)) Some (at,(List.rev listcn))
| Some (`Choice _) -> None | Some (`Choice _) -> None
| Some (`Color c) -> None | Some (`Color newv) -> begin
match attr_id with
D id -> Some ((replace_list id (Some ("color="^newv)) at),cn)
| _ -> None
end
| None -> | None ->
let _,listat = List.fold_left (fun (i,l) at -> let _,listat = List.fold_left (fun (i,l) nat ->
if attr_id = B i then match attr_id with
(i+1, l) else (i+1, at::l)) (0,[]) at in B j when i=j -> i+1,l
| D j when i=j -> i+1,l
| _ -> (i+1, nat::l)) (0,[]) at in
let _,listcn = List.fold_left (fun (i,l) at -> let _,listcn = List.fold_left (fun (i,l) at ->
if attr_id = C i then if attr_id = C i then
(i+1, l) else (i+1, at::l)) (0,[]) cn in (i+1, l) else (i+1, at::l)) (0,[]) cn in
...@@ -175,6 +184,7 @@ let get_new_arc_attr atlist (p1,p2) = ...@@ -175,6 +184,7 @@ let get_new_arc_attr atlist (p1,p2) =
let open DrawingGeom in let open DrawingGeom in
[ [
("Attribute", fun (at,cp) -> (at@[""] , cp),B (List.length at) ) ; ("Attribute", fun (at,cp) -> (at@[""] , cp),B (List.length at) ) ;
("Color", fun (at,cp) -> (at@["color=black"],cp), D (List.length at)) ;
("Point", fun (at,cp) -> (at , cp @ [`Point (mult 0.5 (p1+..p2))]),C (List.length cp) ); ("Point", fun (at,cp) -> (at , cp @ [`Point (mult 0.5 (p1+..p2))]),C (List.length cp) );
("Control", fun (at,cp) -> (at , cp @ [`ControlPoint (mult 0.5 (p1+..p2))]),C (List.length cp) ); ("Control", fun (at,cp) -> (at , cp @ [`ControlPoint (mult 0.5 (p1+..p2))]),C (List.length cp) );
("Node", fun (at,cp) -> (at , cp @ [`Text (0.5,"node")]),C (List.length cp) ) ("Node", fun (at,cp) -> (at , cp @ [`Text (0.5,"node")]),C (List.length cp) )
......
...@@ -471,6 +471,23 @@ module Circle = ...@@ -471,6 +471,23 @@ module Circle =
ctx##stroke ctx##stroke
end end
module SimpleArrow =
struct
type t = point * point
let draw to_screen ctx ~thick:thick (center, origin) =
let rho = angle (center -.. origin) in
let xo,yo = to_screen center in
let xp1,yp1 = to_screen @@ center +.. (rot rho (-4.0,4.0))
and xp2,yp2 = to_screen @@ center +.. (rot rho (-4.0,-.4.0)) in
ctx##.lineWidth := thick;
ctx##beginPath;
ctx##(moveTo xp1 yp1);
ctx##(lineTo xo yo);
ctx##(lineTo xp2 yp2);
ctx##stroke
end
module RoundArrow = module RoundArrow =
struct struct
type t = point* point type t = point* point
...@@ -498,6 +515,7 @@ module Circle = ...@@ -498,6 +515,7 @@ module Circle =
| `Bezier2 of Bezier2.t | `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t | `Bezier3 of Bezier3.t
| `Arrow of Arrow.t | `Arrow of Arrow.t
| `SimpleArrow of SimpleArrow.t
| `RoundArrow of RoundArrow.t] | `RoundArrow of RoundArrow.t]
type path = [ `Empty type path = [ `Empty
...@@ -506,6 +524,7 @@ module Circle = ...@@ -506,6 +524,7 @@ module Circle =
| `Bezier2 of Bezier2.t | `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t | `Bezier3 of Bezier3.t
| `Arrow of Arrow.t | `Arrow of Arrow.t
| `SimpleArrow of SimpleArrow.t
| `RoundArrow of RoundArrow.t | `RoundArrow of RoundArrow.t
] ]
...@@ -551,6 +570,7 @@ module Circle = ...@@ -551,6 +570,7 @@ module Circle =
| `Bezier2 l -> Bezier2.draw tos ctx ~thick l | `Bezier2 l -> Bezier2.draw tos ctx ~thick l
| `Bezier3 l -> Bezier3.draw tos ctx ~thick l | `Bezier3 l -> Bezier3.draw tos ctx ~thick l
| `Arrow a -> Arrow.draw tos ctx ~thick a | `Arrow a -> Arrow.draw tos ctx ~thick a
| `SimpleArrow a -> SimpleArrow.draw tos ctx ~thick a
| `RoundArrow a -> RoundArrow.draw tos ctx ~thick a | `RoundArrow a -> RoundArrow.draw tos ctx ~thick a
let print_point f (x,y) = let print_point f (x,y) =
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment