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
type state = string * (string 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
| `ControlPoint of DrawingGeom.point
| `String of string
......@@ -60,9 +60,9 @@ let get_state_attr (s, at) =
"Node", ((A,"content",`String s) ::
(List.mapi (fun i sv ->
(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
| Some x -> C i, "fill", `Color x
| Some x -> C i, "Fill", `Color x
| None ->
(B i),"Attribute", (`String sv )))) at))
......@@ -70,26 +70,27 @@ let update_state_attr (s,at) attr_id = function
| None -> begin match attr_id with
A -> Some ("",at)
| B id -> Some (s,replace_list id None at)
| C _ -> None
| _-> None
end
| Some (`String newv) -> begin
match attr_id with
A -> Some (newv,at)
| B id -> Some (s,replace_list id (Some newv) at)
| C _ -> None
| _-> None
end
| Some (`Color newv) -> begin
match attr_id with
A -> Some (newv,at)
| B id -> Some (s,replace_list id (Some ("color="^newv)) at)
| C id -> Some (s,replace_list id (Some ("fill="^newv)) at)
| _ -> None
end
| _ -> None
let get_new_state_attr (s,at) _ = [
"Attribute", (fun (s,at) -> (s, at@[""]), 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)) ;
"Color", (fun (s,at) -> (s, at@["color=black"]), B (List.length at)) ;
"Fill", (fun (s,at) -> (s, at@["fill=black"]), C (List.length at)) ;
]
......@@ -99,22 +100,21 @@ let init_arc n1 n2 =
let draw_arc (at,cn) (source_sh,target_sh) =
let open DrawingGeom in
let text = "" in
let pos1 = center_shape source_sh
and pos2 = center_shape target_sh in
if source_sh<>target_sh || cn<>[] then begin
let middle = mult 0.5 (pos1 +.. pos2) in
let rho = angle (pos1 -..pos2) in
let textvect = middle +.. rot rho (0.0,8.0) in
let shape_list = shapes_of_path source_sh cn ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh in
shape_list @ [`Text(textvect, text) ]
let lcol = at
|> List.map (fun a -> is_prefix a "color=")
|> List.filter (function None -> false | _ -> true)
|> List.map (function Some x -> `Colors (DrawingGeom.Color.parse x,(255,255,255))
| None -> `Colors ((0,0,0),(255,255,255))) in
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
let p1 = pos1 +.. (40.0 , -.25.0)
and p2 = pos2 +.. (40.0 , 25.0) in
let textvect = pos1 +.. (120.0,0.0) in
let shape_list = shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh in
shape_list @ [ `Text(textvect, text);]
end
shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end in
lcol @ 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) =
let get_arc_attr (atlist,controllist) =
"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
`Text (_,s) -> C i,"Node",
(`String s)
......@@ -161,11 +164,17 @@ let update_arc_attr (at,cn) attr_id = function
end) (0,[]) cn in
Some (at,(List.rev listcn))
| 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 ->
let _,listat = List.fold_left (fun (i,l) at ->
if attr_id = B i then
(i+1, l) else (i+1, at::l)) (0,[]) at in
let _,listat = List.fold_left (fun (i,l) nat ->
match attr_id with
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 ->
if attr_id = C i then
(i+1, l) else (i+1, at::l)) (0,[]) cn in
......@@ -175,6 +184,7 @@ let get_new_arc_attr atlist (p1,p2) =
let open DrawingGeom in
[
("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) );
("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) )
......
......@@ -471,6 +471,23 @@ module Circle =
ctx##stroke
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 =
struct
type t = point* point
......@@ -498,6 +515,7 @@ module Circle =
| `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t
| `Arrow of Arrow.t
| `SimpleArrow of SimpleArrow.t
| `RoundArrow of RoundArrow.t]
type path = [ `Empty
......@@ -506,6 +524,7 @@ module Circle =
| `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t
| `Arrow of Arrow.t
| `SimpleArrow of SimpleArrow.t
| `RoundArrow of RoundArrow.t
]
......@@ -551,6 +570,7 @@ module Circle =
| `Bezier2 l -> Bezier2.draw tos ctx ~thick l
| `Bezier3 l -> Bezier3.draw tos ctx ~thick l
| `Arrow a -> Arrow.draw tos ctx ~thick a
| `SimpleArrow a -> SimpleArrow.draw tos ctx ~thick a
| `RoundArrow a -> RoundArrow.draw tos ctx ~thick a
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