Commit 2bde48b9 authored by Benoit Barbot's avatar Benoit Barbot
Browse files

progress

parent 0200803e
......@@ -17,9 +17,7 @@
("s"^(string_of_int !state_id), ["toto"])
let draw_state (s,_) p = [
`RoundedRectangle (p,10.0,0.75,5.0);
`Colors ("black","black");
`Text(p,s);
`Colors ("black","white");
]
let draw_arc arc (source_sh,target_sh) =
let open DrawingGeom in
......@@ -30,7 +28,7 @@
let middle = mult 0.5 (pos3 +.. pos2) in
let rho = angle (pos3 -..pos2) in
let textvect = middle +.. rot rho (0.0,8.0) in
[`Line (pos1,pos3); `Arrow (pos2,pos1) ;`Colors ("black","black") ; `Text(textvect, text); `Colors ("black","white")]
[`Line (pos1,pos3); `Arrow (pos2,pos1) ; `Text(textvect, text)]
let get_state_attr (s, at) =
"Node", ((0,"content",`String s) ::
......@@ -84,7 +82,7 @@
let print f stateit arcit =
Format.fprintf f "digraph {\n";
stateit (fun _ (s,_) (x,y) -> Format.fprintf f "%s [pos=\"%f,%f\"];\n" s (x) (y));
arcit (fun _ _ ((_,(source,_)),(_,(target,_))) ->
arcit (fun _ _ ((_,(source,_),_),(_,(target,_),_)) ->
Format.fprintf f "%s -> %s;\n" source target);
Format.fprintf f "}"
......
......@@ -7,7 +7,7 @@ type attribute = [ `Choice of string list
| `ControlPoint of DrawingGeom.point
| `String of string
| `Color of string ]
let init_def () = ()
let state_id = ref 0
......@@ -29,23 +29,23 @@ let get_attribute t l =
let draw_state (s,at) p =
let draw = ref false
and shape = ref (`Rectangle (p,0.75,7.0,0.0))
and color = ref "black"
and fill = ref "black" in
and color = ref (0,0,0)
and fill = ref (0,0,0) in
List.iter (function
"draw" -> draw := true
| "circle" -> shape := `Circle (p,10.0)
| "rounded corners" -> shape := `RoundedRectangle (p,10.0,0.75,5.0)
| at ->
(match is_prefix at "color=" with Some x -> color:=x; |_ ->());
(match is_prefix at "fill=" with Some x -> fill:=x; |_ ->());
(match is_prefix at "color=" with Some x -> color:= DrawingGeom.Color.parse x; |_ ->());
(match is_prefix at "fill=" with Some x -> fill:= DrawingGeom.Color.parse x; |_ ->());
) at;
if not !draw then shape := `Circle (p,1.2);
(*`RoundedRectangle (p,10.0,0.75,5.0);*)
[ !shape;
(*`Circle (p,10.0);*)
`Colors ("black",!color);
`Colors (!color,!fill);
`Text(p,s);
`Colors ("black","white");
`Colors ((0,0,0),(255,255,255));
]
let get_state_attr (s, at) =
......@@ -78,8 +78,8 @@ let get_new_state_attr (s,at) _ = [
let init_arc n1 n2 =
if n1 <> n2 then Some (["->"],[])
else Some (["->";"loop"],[])
if n1 <> n2 then Some (["draw";"->"],[])
else Some (["draw";"->";"loop"],[])
let draw_arc (at,cn) (source_sh,target_sh) =
let open DrawingGeom in
......@@ -91,13 +91,13 @@ let draw_arc (at,cn) (source_sh,target_sh) =
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 @ [`Colors ("black","black") ; `Text(textvect, text); `Colors ("black","white")]
shape_list @ [`Text(textvect, text) ]
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 @ [`Colors ("black","black") ; `Text(textvect, text); `Colors ("black","white")]
shape_list @ [ `Text(textvect, text);]
end
......@@ -120,11 +120,22 @@ let get_arc_attr (atlist,controllist) =
)
let update_arc_attr (at,cn) attr_id = function
| Some (`String newv) ->
let _,listat = List.fold_left (fun (i,l) at ->
if attr_id = B i then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (List.rev listat,cn)
| Some (`String newv) -> (
match attr_id with
B id ->
let _,listat = List.fold_left (fun (i,l) at ->
if i=id then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (List.rev listat,cn)
| C id ->
let _,listcn = List.fold_left (fun (i,l) at ->
if i=id then (i+1, (`Text (0.5,newv))::l)
else (i+1, at::l))
(0,[]) cn in
Some (at,(List.rev listcn))
| _ -> None
)
| Some (`ControlPoint pt) ->
let _,listcn = List.fold_left (fun (i,l) at ->
begin match attr_id,at with
......@@ -162,16 +173,45 @@ let to_tikz (x,y) =
(x/.50.),(100.0 -. y/.50.)
let from_tikz (x,y) =
(x*.50.),((100.0 -.y)*.50.0)
let rec print_point a = function
[] -> ()
let format_quad p0 p1 a p2 =
let open DrawingGeom in
let x1,y1 = to_tikz ((mult 0.3333 p0) +.. (mult 0.6666 p1))
and x2,y2 = to_tikz ((mult 0.6666 p1) +.. (mult 0.3333 p2)) in
Format.fprintf a " .. controls (%f,%f) and (%f,%f) .. " x1 y1 x2 y2
let rec print_path link prev last a = function
[] -> if link then Format.fprintf a " -- "
| (`Point pos)::q ->
let x,y = to_tikz pos in
Format.fprintf a " -- (%f,%f)%a" x y print_point q
| (`ControlPoint pos)::q ->
let x,y = to_tikz pos in
Format.fprintf a " -- (%f,%f)%a" x y print_point q
| `Text (_,s)::q -> Format.fprintf a " node {%s}%a" s print_point q
Format.fprintf a " %s (%f,%f) %a" (if link then "--" else "")
x y (print_path true pos last) q
| (`ControlPoint p1)::q when not link ->
let open DrawingGeom in
let mid = mult 0.5 (prev +.. p1) in
print_path false prev last a ((`Point mid)::(`ControlPoint p1)::q)
| (`ControlPoint p1)::(`Text t)::(`ControlPoint p2)::q ->
print_path link prev last a ((`ControlPoint p1)::(`ControlPoint p2)::(`Text t)::q)
| (`ControlPoint p1)::(`ControlPoint p2)::q ->
let x1,y1 = to_tikz p1 in
let x2,y2 = to_tikz p2 in
Format.fprintf a " .. controls (%f,%f) and (%f,%f) .. %a" x1 y1 x2 y2
(print_path false p2 last) q
| (`ControlPoint p1)::(`Point p2)::q ->
Format.fprintf a " %a %a" (format_quad prev p1) p2
(print_path false p1 last) ((`Point p2)::q)
| (`ControlPoint p1)::(`Text (_,s))::(`Point p2)::q ->
Format.fprintf a " %a node {%s} %a" (format_quad prev p1) p2 s
(print_path false p1 last) ((`Point p2)::q)
| (`ControlPoint p1)::[] ->
Format.fprintf a " %a " (format_quad prev p1) last
| (`ControlPoint p1)::`Text (_,s)::[] ->
Format.fprintf a " %a node {%s} " (format_quad prev p1) last s
| (`Text t)::(`ControlPoint p)::q when link ->
print_path link prev last a ((`ControlPoint p)::`Text t::q)
| `Text (_,s)::q ->
Format.fprintf a " %s node {%s}%a" (if link then "--" else "") s (print_path false prev last) q
let download_file_name = "figure.tikz"
let print f stateit arcit =
......@@ -180,8 +220,9 @@ let print f stateit arcit =
stateit (fun i (s,at) pos->
let (x,y) = to_tikz pos in
Format.fprintf f "\t\\node at (%f,%f) [%a] (n%i) {%s};\n" x y print_string_attr at i s);
arcit (fun i (at,cp) ((source,_),(target,_)) ->
Format.fprintf f "\t\\draw[%a] (n%i) %a -- (n%i);\n" print_string_attr at source print_point cp target);
arcit (fun i (at,cp) ((source,_,poss),(target,_,post)) ->
Format.fprintf f "\t\\path[%a] (n%i) %a (n%i);\n" print_string_attr at source
(print_path true poss post) cp target);
Format.fprintf f "\\end{tikzpicture}\n"
(* Format.fprintf f "\\end{document}\n"*)
......
......@@ -31,6 +31,67 @@ let rot rho (x,y) =
x *. (sin rho) +. y *. (cos rho)
let pi = 4.0 *. atan 1.0
module Color = struct
type t = int*int*int
let mix (r1,g1,b1) (r2,g2,b2) =
max r1 r2, max g1 g2, max b1 b2
let parse = function
"black" -> (0,0,0)
| "red" -> (255,0,0)
| "green" -> (0,255,0)
| "blue" -> (0,0,255)
| "white" -> (255,255,255)
| x when x.[0]='#' -> begin try
let int_of_l = function '0'->0|'1'->1|'2'->2|'3'->3
|'4'->4|'5'->5|'6'->6|'7'->7
|'8'->8|'9'->9|'a'->10|'b'->11
|'c'->12|'d'->13|'e'->14|'f'->15
|_ ->0 in
let ios a b = (int_of_l a)*16 + int_of_l b in
(ios x.[1] x.[2],ios x.[3] x.[4],ios x.[5] x.[6])
with _ -> (0,0,0) end
| _ -> (0,0,0)
end
type canvasState = {
mutable strokeColor : Color.t;
mutable fillColor : Color.t;
mutable ambiant : Color.t;
}
let canvasState = {
strokeColor= (0,0,0);
fillColor= (0,0,0);
ambiant = (0,0,0);
}
let syncColor ctx =
let rs,gs,bs = Color.mix canvasState.strokeColor canvasState.ambiant
and rf,gf,bf = Color.mix canvasState.fillColor canvasState.ambiant in
ctx##.strokeStyle:= Js.string (Printf.sprintf "rgb(%i,%i,%i)" rs gs bs);
ctx##.fillStyle:= Js.string (Printf.sprintf "rgb(%i,%i,%i)" rf gf bf)
let setStrokeColor ctx c =
canvasState.strokeColor <- c;
syncColor ctx
let setFillColor ctx c =
canvasState.fillColor <- c;
syncColor ctx
let setAmbiant ctx c =
canvasState.ambiant <- c;
syncColor ctx
let flipColor ctx =
let sc = canvasState.strokeColor
and fc = canvasState.fillColor in
setStrokeColor ctx fc;
setFillColor ctx sc
let angle (x,y) =
if x > 0.0 then atan (y/.x)
......@@ -141,7 +202,9 @@ module Circle =
let (x4,y4) = r (-.width,+.height) in ctx##(lineTo x4 y4);
ctx##(lineTo x1 y1);
if fill then ctx##fill;
ctx##stroke
ctx##stroke;
()
let projection (center,asym,radius,angle) origin =
let (x1,y1) as v1 = rot (-.angle) (center -.. origin) in
......@@ -218,18 +281,20 @@ module Circle =
let bounding_box to_screen ctx (center,text) =
let c2 = to_screen center in
if text = "" then (c2,1.0,0.0)
if text = "" then (c2,1.0,0.0,0.0)
else let measure = ctx##measureText (Js.string text) in
let w = measure##.width *. 0.4 in
let h = 15.0 *. 0.4 in
(c2,h/.w,h)
(c2,h/.w,h,0.0)
let draw to_screen ctx ?thick:(thick=2.5) (center,text) =
let (x,y) = to_screen center in
(*Rectangle.draw (fun x -> x) ctx (bounding_box to_screen ctx (center,text));*)
flipColor ctx;
(*Rectangle.draw (fun x -> x) ctx ~fill:true (bounding_box to_screen ctx (center,text));*)
ctx##.textAlign := Js.string "center";
ctx##.textBaseline := Js.string "middle";
ctx##fillText (Js.string text) x y
ctx##fillText (Js.string text) x y;
flipColor ctx
end
......@@ -406,7 +471,7 @@ module Circle =
| `RoundedRectangle of RoundedRectangle.t
| `Text of Text.t
| `TokenSet of TokenSet.t
| `Colors of string*string
| `Colors of Color.t*Color.t
| `Line of Line.t
| `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t
......@@ -414,7 +479,7 @@ module Circle =
| `RoundArrow of RoundArrow.t]
type path = [ `Empty
| `Colors of string*string
| `Colors of Color.t*Color.t
| `Line of Line.t
| `Bezier2 of Bezier2.t
| `Bezier3 of Bezier3.t
......@@ -447,8 +512,9 @@ module Circle =
| `RoundedRectangle rr -> RoundedRectangle.draw tos ctx ~thick rr
| `Text t -> Text.draw tos ctx ~thick t
| `TokenSet ts -> TokenSet.draw tos ctx ~thick ts
| `Colors (c1,c2) -> ctx##.strokeStyle := (Js.string c1);
ctx##.fillStyle := (Js.string c2)
| `Colors (c1,c2) ->
setStrokeColor ctx c1;
setFillColor ctx c2;
| `Line l -> Line.draw tos ctx ~thick l
| `Bezier2 l -> Bezier2.draw tos ctx ~thick l
| `Bezier3 l -> Bezier3.draw tos ctx ~thick l
......
......@@ -26,7 +26,7 @@ module type PREGRAPH =
val download_file_name : string
val print: Format.formatter ->
(( int -> state -> (float*float) -> unit) -> unit) ->
((int -> arc -> ((int*state)*(int*state)) -> unit) -> unit)
((int -> arc -> ((int*state*(float*float))*(int*state*(float*float))) -> unit) -> unit)
-> unit
end
......@@ -174,10 +174,10 @@ module S (P:PREGRAPH) =
Data.iteri (fun k ((),(s,pos)) -> f (Data.unsafe_rev k) !s !pos) graph.state)
(fun f ->
Data.iteri (fun k ((),(s,source,target)) ->
let (),(sourcet,_) = Data.acca graph.state source
and (),(targett,_) = Data.acca graph.state target in
f (Data.unsafe_rev k) !s ((Data.unsafe_rev source,!sourcet),
(Data.unsafe_rev target,!targett))
let (),(sourcet,ps) = Data.acca graph.state source
and (),(targett,pt) = Data.acca graph.state target in
f (Data.unsafe_rev k) !s ((Data.unsafe_rev source,!sourcet,!ps),
(Data.unsafe_rev target,!targett,!pt))
) graph.arc)
let read_graph s =
......
......@@ -120,13 +120,12 @@ module GraphEditor (G: GRAPH ) = struct
ctx##.strokeStyle := (Js.string colors)
let set_style ctx is_selected is_over =
let color2 = CSS.Color.string_of_t (
if is_selected then CSS.Color.rgb 250 10 10
else if is_over then CSS.Color.rgb 10 10 250
else CSS.Color.rgb 10 10 10) in
let color = CSS.Color.string_of_t (CSS.Color.rgb 255 255 255) in
ctx##.fillStyle := (Js.string color);
ctx##.strokeStyle := (Js.string color2)
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);
DrawingGeom.setAmbiant ctx color
let shapes_of_arc s obj =
let (source,target) = G.nodes_of_arc s.graph obj in
......
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