Skip to content
GitLab
Commit 84b6009f authored by Benoit Barbot's avatar Benoit Barbot
Browse files

prog

parent 0f78d719
Pipeline #954 failed with stage
in 9 seconds
Hide whitespace changes
Inline Side-by-side
TAEditor/TAGraph.ml
View file @ 84b6009f
type def = unit type def = unit
type state = string * (string list) type state = string * (string list)
type arc = string list * DrawingGeom.path_elem list type arc = float
type attribute_id = A | B of int | C of int | D of int type attribute_id = 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
| `Color of string ] | `Color of string ]
let init_def () = ()
let init_def () = ()
let state_id = ref 0 let init_arc _ _ = Some 1.0
let init_state () = incr state_id;
("s"^(string_of_int !state_id), ["draw"]) let state_id = ref 0
let init_state () = incr state_id;
let is_prefix s t = ((string_of_int !state_id), ["toto"])
let n = String.length t in let draw_state (s,_) p = [
if String.length s >= n then `Circle (p,10.0);
if String.sub s 0 n = t then Some (String.sub s n (String.length s-n)) `Text(p,s);
else None ]
else None let draw_arc arc (source_sh,target_sh) =
let open DrawingGeom in
let get_attribute t l = let pos1 = center_shape source_sh in
List.fold_left (fun v at -> let pos2 = center_shape target_sh in
(match is_prefix at t with Some x -> Some x | _ ->v); let text = string_of_float arc in
) None l
if source_sh<>target_sh then begin
let replace_list id v l = shapes_of_path source_sh [`Text (0.5,text)] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
let _,listat = List.fold_left (fun (i,l) at -> end else begin
if id = i then let p1 = pos1 +.. (40.0 , -.25.0)
(i+1, match v with Some v -> v::l | None -> l) and p2 = pos2 +.. (40.0 , 25.0) in
else (i+1, at::l)) (0,[]) l in shapes_of_path source_sh [`ControlPoint p1; `Text (0.5,text);`ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
List.rev listat end
let draw_state (s,at) p =
let draw = ref false let get_state_attr (s, at) =
and shape = ref (`Rectangle (p,0.75,7.0,0.0)) "Node", ((0,"content",`String s) ::
and color = ref (0,0,0) (List.mapi (fun i sv -> (i+1),"attribute "^(string_of_int (i+1)),(`String sv )) at))
and fill = ref (255,255,255) in
List.iter (function let update_state_attr (s,at) attr_id = function
"draw" -> draw := true | None ->
| "circle" -> shape := `Circle (p,10.0) if attr_id = 0 then Some ("",at)
| "rounded corners" -> shape := `RoundedRectangle (p,10.0,0.75,5.0) else
| at -> let _,listat = List.fold_left (fun (i,l) at ->
(match is_prefix at "color=" with Some x -> color:= DrawingGeom.Color.parse x; |_ ->()); if attr_id = i+1 then
(match is_prefix at "fill=" with Some x -> fill:= DrawingGeom.Color.parse x; |_ ->()); (i+1, l) else (i+1, at::l)) (0,[]) at in
) at; Some (s,listat)
if not !draw then shape := `Circle (p,1.2); | Some (`String newv) ->
(*`RoundedRectangle (p,10.0,0.75,5.0);*) if attr_id = 0 then Some (newv,at)
[ `Colors (!color,!fill); else
!shape; let _,listat = List.fold_left (fun (i,l) at ->
(*`Circle (p,10.0);*) if attr_id = i+1 then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
`Text(p,s); Some (s,listat)
`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 | _ -> 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 = let get_new_state_attr (s,at) _ = []
if n1 <> n2 then Some (["draw";"->"],[])
else Some (["draw";"->";"loop"],[]) let get_arc_attr prob =
"Arc", [(0,"Probability",`String (string_of_float prob)) ]
let draw_arc (at,cn) (source_sh,target_sh) =
let open DrawingGeom in let update_arc_attr _ _ = function
let pos1 = center_shape source_sh | None ->
and pos2 = center_shape target_sh in begin try let p = 1.0 in
let lcol = at if p>= 0.0 && p<= 1.0 then Some p else None
|> List.map (fun a -> is_prefix a "color=") with _ -> None
|> List.filter (function None -> false | _ -> true) end
|> List.map (function Some x -> `Colors (DrawingGeom.Color.parse x,(255,255,255)) | Some (`String v) ->
| None -> `Colors ((0,0,0),(255,255,255))) in begin try let p = float_of_string v in
let l = if source_sh<>target_sh || cn<>[] then begin if p>= 0.0 && p<= 1.0 then Some p else None
shapes_of_path source_sh cn ~arrow2:(Some (fun x y -> `SimpleArrow (x,y))) target_sh with _ -> None
end else begin end
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
(* 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 update_arc_attr (at,cn) attr_id = function
| 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
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)
| _ -> None | _ -> 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 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 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 rec print_path link prev last a = function let get_new_arc_attr atlist _ = []
[] -> 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 download_file_name = "figure.tikz" let string_of_attribute = function
let print f stateit arcit = | `Prob arc -> string_of_float arc
(* Format.fprintf f "\\documentclass[]{article}\n\\usepackage{tikz}\n\\begin{document}";*) | `StringExpr s -> s
Format.fprintf f "\\begin{tikzpicture}\n"; | `Choice (t::_) -> t
stateit (fun i (s,at) pos-> | `Choice [] -> ""
let (x,y) = to_tikz pos in | `ControlPoint _ -> ""
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 print_position outx lexbuf = let download_file_name = "markovChain.dot"
let open Lexing in let print f stateit arcit =
let pos = lexbuf.lex_curr_p in Format.fprintf f "digraph {\n";
Printf.fprintf outx "%s:%d:%d" pos.pos_fname stateit (fun _ (s,_) (x,y) -> Format.fprintf f "%s [pos=\"%f,%f\"];\n" s (x) (y));
pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) arcit (fun _ _ ((_,(source,_),_),(_,(target,_),_)) ->
Format.fprintf f "%s -> %s;\n" source target);
Format.fprintf f "}"
let parse_file file add_node add_arc = let parse_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"
TikzEditor/MarkovChain.ml
View file @ 84b6009f
...@@ -8,32 +8,38 @@ ...@@ -8,32 +8,38 @@
| `String of string | `String of string
| `Color of string ] | `Color of string ]
let init_def () = () let init_def () = ()
let init_arc _ _ = Some 1.0 let init_arc _ _ = Some 1.0
let state_id = ref 0 let state_id = ref 0
let init_state () = incr state_id; let init_state () = incr state_id;
("s"^(string_of_int !state_id), ["toto"]) ("s"^(string_of_int !state_id), ["toto"])
let draw_state (s,_) p = [ let draw_state (s,_) p = [
`RoundedRectangle (p,10.0,0.75,5.0); `RoundedRectangle (p,10.0,0.75,5.0);
`Text(p,s); `Text(p,s);
] ]
let draw_arc arc (source_sh,target_sh) = let draw_arc arc (source_sh,target_sh) =
let open DrawingGeom in let open DrawingGeom in
let pos1 = center_shape source_sh in let pos1 = center_shape source_sh in
let pos2 = projection_shape pos1 target_sh in let pos2 = center_shape target_sh in
let pos3 = projection_shape pos2 source_sh in
let text = string_of_float arc in let text = string_of_float arc in
let middle = mult 0.5 (pos3 +.. pos2) in
let rho = angle (pos3 -..pos2) in if source_sh<>target_sh then begin
let textvect = middle +.. rot rho (0.0,8.0) in shapes_of_path source_sh [`Text (0.5,text)] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
[`Line (pos1,pos3); `Arrow (pos2,pos1) ; `Text(textvect, text)] end else begin
let p1 = pos1 +.. (40.0 , -.25.0)
let get_state_attr (s, at) = 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) :: "Node", ((0,"content",`String s) ::
(List.mapi (fun i sv -> (i+1),"attribute "^(string_of_int (i+1)),(`String sv )) at)) (List.mapi (fun i sv -> (i+1),"attribute "^(string_of_int (i+1)),(`String sv )) at))
let update_state_attr (s,at) attr_id = function let update_state_attr (s,at) attr_id = function
| None -> | None ->
if attr_id = 0 then Some ("",at) if attr_id = 0 then Some ("",at)
...@@ -50,12 +56,12 @@ ...@@ -50,12 +56,12 @@
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in (i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (s,listat) Some (s,listat)
| _ -> None | _ -> None
let get_new_state_attr (s,at) _ = [] let get_new_state_attr (s,at) _ = []
let get_arc_attr prob = let get_arc_attr prob =
"Arc", [(0,"Probability",`String (string_of_float prob)) ] "Arc", [(0,"Probability",`String (string_of_float prob)) ]
let update_arc_attr _ _ = function let update_arc_attr _ _ = function
| None -> | None ->
begin try let p = 1.0 in begin try let p = 1.0 in
...@@ -68,9 +74,9 @@ ...@@ -68,9 +74,9 @@
with _ -> None with _ -> None
end end
| _ -> None | _ -> None
let get_new_arc_attr atlist _ = [] let get_new_arc_attr atlist _ = []
let string_of_attribute = function let string_of_attribute = function
| `Prob arc -> string_of_float arc | `Prob arc -> string_of_float arc
| `StringExpr s -> s | `StringExpr s -> s
...@@ -85,5 +91,5 @@ ...@@ -85,5 +91,5 @@
arcit (fun _ _ ((_,(source,_),_),(_,(target,_),_)) -> arcit (fun _ _ ((_,(source,_),_),(_,(target,_),_)) ->
Format.fprintf f "%s -> %s;\n" source target); Format.fprintf f "%s -> %s;\n" source target);
Format.fprintf f "}" Format.fprintf f "}"
let parse_file _ add_node add_arc = () let parse_file _ add_node add_arc = ()
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