Commit 84b6009f authored by Benoit Barbot's avatar Benoit Barbot
Browse files

prog

parent 0f78d719
Pipeline #954 failed with stage
in 9 seconds
type def = unit
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 | D of int
type attribute = [ `Choice of string list
type state = string * (string list)
type arc = float
type attribute_id = int
type attribute = [ `Choice of string list
| `ControlPoint of DrawingGeom.point
| `String of string
| `Color of string ]
let init_def () = ()
let state_id = ref 0
let init_state () = incr state_id;
("s"^(string_of_int !state_id), ["draw"])
let is_prefix s t =
let n = String.length t in
if String.length s >= n then
if String.sub s 0 n = t then Some (String.sub s n (String.length s-n))
else None
else None
let get_attribute t l =
List.fold_left (fun v at ->
(match is_prefix at t with Some x -> Some x | _ ->v);
) None l
let replace_list id v l =
let _,listat = List.fold_left (fun (i,l) at ->
if id = i then
(i+1, match v with Some v -> v::l | None -> l)
else (i+1, at::l)) (0,[]) l in
List.rev listat
let draw_state (s,at) p =
let draw = ref false
and shape = ref (`Rectangle (p,0.75,7.0,0.0))
and color = ref (0,0,0)
and fill = ref (255,255,255) 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:= 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);*)
[ `Colors (!color,!fill);
!shape;
(*`Circle (p,10.0);*)
let init_def () = ()
let init_arc _ _ = Some 1.0
let state_id = ref 0
let init_state () = incr state_id;
((string_of_int !state_id), ["toto"])
let draw_state (s,_) p = [
`Circle (p,10.0);
`Text(p,s);
`Colors ((0,0,0),(255,255,255));
]
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
| None -> (match is_prefix sv "fill=" with
| Some x -> C i, "Fill", `Color x
| None ->
(B i),"Attribute", (`String sv )))) at))
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)
| _-> None
end
| Some (`String newv) -> begin
match attr_id with
A -> Some (newv,at)
| B id -> Some (s,replace_list id (Some newv) at)
| _-> 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)) ;
]
let init_arc n1 n2 =
if n1 <> n2 then Some (["draw";"->"],[])
else Some (["draw";"->";"loop"],[])
let draw_arc (at,cn) (source_sh,target_sh) =
let draw_arc arc (source_sh,target_sh) =
let open DrawingGeom in
let pos1 = center_shape source_sh
and pos2 = center_shape target_sh in
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
let pos1 = center_shape source_sh in
let pos2 = center_shape target_sh in
let text = string_of_float arc in
if source_sh<>target_sh then begin
shapes_of_path source_sh [`Text (0.5,text)] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end else begin
let p1 = pos1 +.. (40.0 , -.25.0)
and p2 = pos2 +.. (40.0 , 25.0) in
shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end in
lcol @ l
shapes_of_path source_sh [`ControlPoint p1; `Text (0.5,text);`ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end
(* let _,bline = List.fold_left (fun (pi,l) pip -> (pip, `Bezier2 (pi,(0.0,0.0),pip) :: l))
(pos1,[`Arrow (pos2,List.hd (List.rev point_list)) ;`Colors ("black","black") ; `Text(textvect, text); `Colors ("black","white")] )
(point_list@[pos2]) in
bline*)
let get_arc_attr (atlist,controllist) =
"Arc", (
(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)
| `Point p -> C i,"Point",
(`ControlPoint p)
| `ControlPoint p -> C i,"Control",
(`ControlPoint p)
)) controllist)
)
let get_state_attr (s, at) =
"Node", ((0,"content",`String s) ::
(List.mapi (fun i sv -> (i+1),"attribute "^(string_of_int (i+1)),(`String sv )) at))
let update_arc_attr (at,cn) attr_id = function
| Some (`String newv) -> (
match attr_id with
B id ->
let update_state_attr (s,at) attr_id = function
| None ->
if attr_id = 0 then Some ("",at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if i=id then
if attr_id = i+1 then
(i+1, l) else (i+1, at::l)) (0,[]) at in
Some (s,listat)
| Some (`String newv) ->
if attr_id = 0 then Some (newv,at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if attr_id = i+1 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
C j,`Point _ when i=j -> (i+1, (`Point pt)::l)
| C j,`ControlPoint _ when i=j -> (i+1, (`ControlPoint pt)::l)
| _ -> (i+1, at::l)
end) (0,[]) cn in
Some (at,(List.rev listcn))
| Some (`Choice _) -> None
| Some (`Color newv) -> begin
match attr_id with
D id -> Some ((replace_list id (Some ("color="^newv)) at),cn)
Some (s,listat)
| _ -> None
end
| None ->
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
Some ((List.rev listat),(List.rev listcn))
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) )
]
let get_new_state_attr (s,at) _ = []
let print_single_attr f a=
let open DrawingGeom.Color in
match is_prefix a "fill=" with
| Some x -> Format.fprintf f "fill={%s}" (to_tikz_string @@ parse x)
| None -> (match is_prefix a "color=" with
| Some x -> Format.fprintf f "color={%s}" (to_tikz_string @@ parse x)
| None -> Format.fprintf f "%s" a
)
let get_arc_attr prob =
"Arc", [(0,"Probability",`String (string_of_float prob)) ]
let rec print_string_attr a = function
[] -> ()
| t::[] -> Format.fprintf a "%a" print_single_attr t
| t::q -> Format.fprintf a "%a,%a" print_single_attr t print_string_attr q
let to_tikz (x,y) =
(x/.50.),(100.0 -. y/.50.)
let from_tikz (x,y) =
(x*.50.),((100.0 -.y)*.50.0)
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 update_arc_attr _ _ = function
| None ->
begin try let p = 1.0 in
if p>= 0.0 && p<= 1.0 then Some p else None
with _ -> None
end
| Some (`String v) ->
begin try let p = float_of_string v in
if p>= 0.0 && p<= 1.0 then Some p else None
with _ -> None
end
| _ -> None
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 " %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 get_new_arc_attr atlist _ = []
let download_file_name = "figure.tikz"
let print f stateit arcit =
(* Format.fprintf f "\\documentclass[]{article}\n\\usepackage{tikz}\n\\begin{document}";*)
Format.fprintf f "\\begin{tikzpicture}\n";
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,_,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"*)
let string_of_attribute = function
| `Prob arc -> string_of_float arc
| `StringExpr s -> s
| `Choice (t::_) -> t
| `Choice [] -> ""
| `ControlPoint _ -> ""
let print_position outx lexbuf =
let open Lexing in
let pos = lexbuf.lex_curr_p in
Printf.fprintf outx "%s:%d:%d" pos.pos_fname
pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
let download_file_name = "markovChain.dot"
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,_),_)) ->
Format.fprintf f "%s -> %s;\n" source target);
Format.fprintf f "}"
let parse_file file add_node add_arc =
let lexbuf = Lexing.from_string file in
try
()
(*
let nodelist,arclist = TikzParser.main TikzLexer.token lexbuf in
let nl = Hashtbl.create 10 in
List.iter (fun (pos,at,name,content) ->
let k = add_node (content,at) (from_tikz pos) in
Hashtbl.add nl name k
) nodelist;
List.iter (fun (al,start,fin,pl) ->
let s2 = Hashtbl.find nl start
and fin2 = Hashtbl.find nl fin in
let pl2 = List.map (function `Point pos -> `Point (from_tikz pos)
| `ControlPoint pos -> `ControlPoint (from_tikz pos)
| `Text t -> `Text t) pl in
add_arc (al,pl2) s2 fin2) arclist
*)
with
| Parsing.Parse_error ->
Printf.fprintf stderr "%a: Parsing error: unexpected token:'%s'\n"
print_position lexbuf (Lexing.lexeme lexbuf);
failwith "Fail to parse Tikz file format"
let parse_file _ add_node add_arc = ()
......@@ -19,16 +19,22 @@
`RoundedRectangle (p,10.0,0.75,5.0);
`Text(p,s);
]
let draw_arc arc (source_sh,target_sh) =
let open DrawingGeom in
let pos1 = center_shape source_sh in
let pos2 = projection_shape pos1 target_sh in
let pos3 = projection_shape pos2 source_sh in
let pos2 = center_shape target_sh in
let text = string_of_float arc in
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) ; `Text(textvect, text)]
if source_sh<>target_sh then begin
shapes_of_path source_sh [`Text (0.5,text)] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end else begin
let p1 = pos1 +.. (40.0 , -.25.0)
and p2 = pos2 +.. (40.0 , 25.0) in
shapes_of_path source_sh [`ControlPoint p1; `Text (0.5,text);`ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
end
let get_state_attr (s, at) =
"Node", ((0,"content",`String s) ::
......
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