Skip to content

GitLab

Commit c1b2e712 authored by Benoit Barbot's avatar Benoit Barbot
Browse files

progress

parent 84b6009f
Pipeline #959 failed with stage
in 9 seconds
Hide whitespace changes
Inline Side-by-side
TikzEditor/MarkovChain.ml
View file @ c1b2e712
......@@ -84,12 +84,12 @@
| `Choice [] -> ""
| `ControlPoint _ -> ""
let download_file_name = "markovChain.dot"
let print f stateit arcit =
let print = [
"dot", (fun 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 "}"
Format.fprintf f "}"), "markovChain.dot" ]
let parse_file _ add_node add_arc = ()
TikzEditor/TikzGraph.ml
View file @ c1b2e712
......@@ -32,12 +32,12 @@ let replace_list id v l =
(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))
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
and fill = ref (255,255,255) in
List.iter (function
"draw" -> draw := true
| "circle" -> shape := `Circle (p,10.0)
......@@ -51,11 +51,11 @@ let draw_state (s,at) p =
[ `Colors (!color,!fill);
!shape;
(*`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 ->
......@@ -65,7 +65,7 @@ let get_state_attr (s, at) =
| 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)
......@@ -73,20 +73,20 @@ let update_state_attr (s,at) attr_id = function
| _-> None
end
| Some (`String newv) -> begin
match attr_id with
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
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)) ;
......@@ -108,15 +108,15 @@ let draw_arc (at,cn) (source_sh,target_sh) =
|> 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
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
shapes_of_path source_sh [`ControlPoint p1; `ControlPoint p2] ~arrow2:(Some (fun x y -> `Arrow (x,y))) target_sh
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
......@@ -124,7 +124,7 @@ let draw_arc (at,cn) (source_sh,target_sh) =
let get_arc_attr (atlist,controllist) =
"Arc", (
(List.mapi (fun i sv ->
(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)
......@@ -137,7 +137,7 @@ let get_arc_attr (atlist,controllist) =
(`ControlPoint p)
)) controllist)
)
let update_arc_attr (at,cn) attr_id = function
| Some (`String newv) -> (
match attr_id with
......@@ -146,15 +146,15 @@ let update_arc_attr (at,cn) attr_id = function
if i=id then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (List.rev listat,cn)
| C id ->
| 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
| _ -> None
)
| Some (`ControlPoint pt) ->
let _,listcn = List.fold_left (fun (i,l) at ->
begin match attr_id,at with
......@@ -198,7 +198,7 @@ let print_single_attr f a=
| 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
......@@ -207,7 +207,7 @@ let rec print_string_attr a = function
let to_tikz (x,y) =
(x/.50.),(100.0 -. y/.50.)
let from_tikz (x,y) =
(x*.50.),((100.0 -.y)*.50.0)
(x*.50.),((100.0 -.y)*.50.0)
let format_quad p0 p1 a p2 =
......@@ -215,11 +215,11 @@ let format_quad p0 p1 a p2 =
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
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 ->
......@@ -247,9 +247,9 @@ let rec print_path link prev last a = function
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 =
let print =
[ "tikz", (fun 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->
......@@ -259,17 +259,18 @@ let print f stateit arcit =
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"*)
(* Format.fprintf f "\\end{document}\n"*)
), "figure.tikz" ]
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 parse_file file add_node add_arc =
let lexbuf = Lexing.from_string file in
try
try
let nodelist,arclist = TikzParser.main TikzLexer.token lexbuf in
let nl = Hashtbl.create 10 in
List.iter (fun (pos,at,name,content) ->
......@@ -283,11 +284,9 @@ let parse_file file add_node add_arc =
| `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"
editor/DrawingGeom.ml
View file @ c1b2e712
type point = float*float
let (+..) (x1,y1) (x2,y2)=
(x2+.x1),(y2+.y1)
let (-..) (x2,y2) (x1,y1) =
(x2-.x1),(y2-.y1)
let (~-..) (x,y) = (-.x,-.y)
let ( *..) (x1,y1) (x2,y2)=
(x1*.x2) +. (y1*.y2)
(x1*.x2) +. (y1*.y2)
let mult s (x1,y1) = (s*.x1,s*.y1)
let vect_prod (x1,y1) (x2,y2) = (x1*.x2, y1*.y2)
let vect_div (x1,y1) (x2,y2) = (x1 /. x2, y1/. y2)
let vect_sqrt (x,y) = sqrt x, sqrt y
let norm (x,y) = x*.x +. y*.y
let dist p = sqrt (norm p)
let abs_point (x,y) = (abs_float x, abs_float y)
let gaussian k (x,y) =
exp ( -. ( x*.x +. y*.y)/. (k*.k) )
exp ( -. ( x*.x +. y*.y)/. (k*.k) )
let proj x y =
(mult (y *.. x/.(norm y)) y)
let rot rho (x,y) =
x *. (cos rho) -. y *. (sin rho),
x *. (sin rho) +. y *. (cos rho)
......@@ -34,6 +34,7 @@ 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
......@@ -57,12 +58,12 @@ module Color = struct
|'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
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
| x when String.length x>=4 && x.[0]='r' && x.[1]='g' && x.[2]='b' ->
Scanf.sscanf x "rgb,255:red,%i;green,%i;blue,%i" (fun r g b -> (r,g,b))
| _ -> (0,0,0)
let to_string (r,g,b) =
......@@ -73,12 +74,12 @@ module Color = struct
|_ ->'0' in
Printf.sprintf "#%c%c%c%c%c%c" (loi (r/16)) (loi (r mod 16))
(loi (g/16)) (loi (g mod 16)) (loi (b/16)) (loi (b mod 16))
let to_tikz_string (r,g,b) =
Printf.sprintf "rgb,255:red,%i;green,%i;blue,%i" r g b
Printf.sprintf "rgb,255:red,%i;green,%i;blue,%i" r g b
end
type canvasState = {
mutable strokeColor : Color.t;
mutable fillColor : Color.t;
......@@ -90,13 +91,13 @@ let canvasState = {
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
......@@ -114,7 +115,7 @@ let flipColor ctx =
and fc = canvasState.fillColor in
setStrokeColor ctx fc;
setFillColor ctx sc
let angle (x,y) =
if x > 0.0 then atan (y/.x)
else if x < 0.0 then pi +. atan (y/.x)
......@@ -122,8 +123,8 @@ let angle (x,y) =
let solve_linear a b =
if a=0.0 then []
else [b/.a]
else [b/.a]
let solve_quadratic a b c =
if a=0.0 then solve_linear b c
else let d = b*.b -. (4.0*.a*.c) in
......@@ -133,7 +134,7 @@ let solve_quadratic a b c =
[t1;t2]
else if d=0.0 then [ -.b/. (2.0*.a)]
else []
let solve_cubic a1 b1 c1 d1 =
if a1 =0.0 then solve_quadratic b1 c1 d1
else
......@@ -151,24 +152,24 @@ let solve_cubic a1 b1 c1 d1 =
and t2 = tk 1.0 in
[ t0; t1; t2]
else
let sr = if rR<0.0 then -.1.0 else if rR=0.0 then 0.0 else 1.0 in
let sr = if rR<0.0 then -.1.0 else if rR=0.0 then 0.0 else 1.0 in
let aA = sr*.(sqrt ((abs_float rR)+.(sqrt (-.delta)))) in
let bB = if aA=0.0 then 0.0 else qQ/.aA in
let t = aA +. bB -. aA/.3.0 in
[ t]
module Circle =
struct
type t = point*float
let is_over to_screen mouse_pos (center,radius) =
let (x,y) = to_screen center
and r,_ = to_screen (center +.. (radius,0.0)) in
let (x,y) = to_screen center
and r,_ = to_screen (center +.. (radius,0.0)) in
dist (mouse_pos -.. (x,y)) <= r-.x
let draw to_screen ctx ?thick:(thick=3.0) (center,radius) =
let (x,y) = to_screen center
and r,_ = to_screen (center +.. (radius,0.0)) in
and r,_ = to_screen (center +.. (radius,0.0)) in
let width = r-.x in
ctx##.lineWidth := thick;
ctx##beginPath;
......@@ -179,7 +180,7 @@ module Circle =
let projection (center,radius) origin =
let v1 = center -.. origin in
let nd = dist v1 in
origin +.. mult ((nd -. radius) /. nd) v1
origin +.. mult ((nd -. radius) /. nd) v1
end
module Rectangle =
......@@ -190,19 +191,19 @@ module Circle =
let center = mult 0.5 (pos2+..pos1) in
let diagx,diagy = match pos2 -.. pos1 with (x,y) -> abs_float x, abs_float y in
center,(diagy/.diagx),diagy/.2.0,0.0
let is_over to_screen mouse_pos (center,asym,radius,angle) =
let (x,y) = to_screen center
and w,h = to_screen (center +.. (radius/.asym,radius)) in
let width =w-.x and height = h-.y in
let (dmx,dmy) = rot (-.angle) (mouse_pos -.. (x,y)) in
(abs_float dmx) <= width && (abs_float dmy) <= height
(abs_float dmx) <= width && (abs_float dmy) <= height
let contain ((x,y),asym,radius,angle) (x2,y2) =
let w,h = (radius/.asym,radius) in
x2 >= x-.w && x2 <= x +.w
&& y2 >= y-.h && y2 <= y+.h
let contains ((x,y),asym,radius,angle) ptlist =
let w,h = (radius/.asym,radius) in
List.filter (fun ((x2,y2),_) ->
......@@ -210,7 +211,7 @@ module Circle =
&& y2 >= y-.h && y2 <= y+.h) ptlist
|> List.split
|> snd
let draw to_screen ctx ?thick:(thick=3.0) ?fill:(fill=true) (center,asym,radius,angle) =
let (x,y) = to_screen center
and w,h = to_screen (center +.. (radius/.asym,radius)) in
......@@ -226,8 +227,8 @@ module Circle =
if fill then ctx##fill;
ctx##stroke;
()
let projection (center,asym,radius,angle) origin =
let (x1,y1) as v1 = rot (-.angle) (center -.. origin) in
let intersect = mult ((abs_float x1 -. (radius/.asym)) /. (abs_float x1)) v1 in
......@@ -235,12 +236,12 @@ module Circle =
if abs_float y2 < radius then origin +.. (rot (angle) intersect)
else let intersect2 = mult ((abs_float y1 -. radius) /. (abs_float y1)) v1 in
origin +.. (rot (angle) intersect2)
end
module RoundedRectangle =
struct
type t = (point)*float*float*float
let draw to_screen ctx ?thick:(thick=3.0) (center,radius,asym,rad) =
let (x,y) = to_screen center in
let w,h = to_screen (center +.. (radius/.asym,radius))
......@@ -259,12 +260,12 @@ module Circle =
ctx##lineTo (x-.width) (y-.height+.r);
ctx##fill;
ctx##stroke
let is_over to_screen mouse_pos (center,radius,asym,rad) =
let (x,y) = to_screen center in
let w,h = to_screen (center +.. (radius/.asym,radius)) -.. (x,y)
and r,_ = to_screen (center +.. (rad,0.0)) -.. (x,y) in
let (dmx,dmy) = mouse_pos -.. (x,y) in
let (dmx,dmy) = mouse_pos -.. (x,y) in
let dmx2,dmy2 = abs_float dmx , abs_float dmy in
(dmx2 <= w -.r && dmy2 <= h)
|| ( dmx2 <= w && dmy2 <= h -.r )
......@@ -273,7 +274,7 @@ module Circle =
let projection (center,radius,asym,rad) origin =
let (x1,y1) as v1 = center -.. origin in
let intersect = mult (((abs_float x1) -. (radius/.asym)) /. (abs_float x1)) v1
let intersect = mult (((abs_float x1) -. (radius/.asym)) /. (abs_float x1)) v1
and intersect2 = mult (((abs_float y1) -. radius) /. (abs_float y1)) v1 in
let _,y2 = v1 -.. intersect in
let x2,_ = v1 -.. intersect2 in
......@@ -289,14 +290,14 @@ module Circle =
let alpha = (angle v4) -. (angle (origin -..center)) in
let rR = dist v4 in
let nd2 = rR *. (cos alpha +. sqrt ( rad*.rad /. (rR*.rR) -. (sin alpha)*.(sin alpha))) in
let nd = dist v1 in
origin +.. mult ((nd -. nd2) /. nd) v1
in vect
end
module Text =
struct
type t = (point)*string
......@@ -308,7 +309,7 @@ module Circle =
let w = measure##.width *. 0.4 in
let h = 15.0 *. 0.4 in
(c2,h/.w,h,0.0)
let draw to_screen ctx ?thick:(thick=2.5) (center,text) =
let (x,y) = to_screen center in
flipColor ctx;
......@@ -355,7 +356,7 @@ module Circle =
ctx##(moveTo x1 y1);
ctx##(lineTo x2 y2);
ctx##stroke
let is_over tos mouse_pos ~thick (spos,epos) =
let sspos = tos spos
and sepos = tos epos in
......@@ -368,8 +369,8 @@ module Circle =
let point_at t (spos,epos) =
let p0 = spos
and p1 = epos in
p0 +.. (mult t (p1 -..p0))
p0 +.. (mult t (p1 -..p0))
end
module Bezier2 =
......@@ -393,7 +394,7 @@ module Circle =
( p2 -.. (mult 2.0 p1) +.. p0,
(mult 2.0 p1) -.. (mult 2.0 p0),
p0)
let is_over tos mouse_pos ~thick bez =
let (xA,yA),(xB,yB),c = poly_of tos bez in
let (xC,yC) = c -.. mouse_pos in
......@@ -406,7 +407,7 @@ module Circle =
let point_at t bez =
let a,b,c = poly_of (fun x->x) bez in
(mult (t*.t) a) +.. (mult t b) +.. c
end
module Bezier3 =
......@@ -424,17 +425,17 @@ module Circle =
ctx##(bezierCurveTo xc1 yc1 xc2 yc2 x2 y2);
ctx##stroke
let poly_of tos (spos,control1,control2,epos) =
let poly_of tos (spos,control1,control2,epos) =
let p0 = tos spos
and p1 = tos control1
and p2 = tos control2
and p3 = tos epos in
let a = p3 -.. (mult 3.0 p2) +.. (mult 3.0 p1) -.. p0 in
let b = (mult 3.0 p2) -.. (mult 6.0 p1) +.. (mult 3.0 p0)
let a = p3 -.. (mult 3.0 p2) +.. (mult 3.0 p1) -.. p0 in
let b = (mult 3.0 p2) -.. (mult 6.0 p1) +.. (mult 3.0 p0)
and c = (mult 3.0 p1) -.. (mult 3.0 p0)
and d = p0 in
(a,b,c,d)
let is_over tos mouse_pos ~thick bez =
let (xa,ya),(xb,yb),(xc,yc),d = poly_of tos bez in
let xd,yd = d -.. mouse_pos in
......@@ -451,11 +452,11 @@ module Circle =
let a,b,c,d = poly_of (fun x->x) bez in
(mult (t*.t*.t) a) +.. (mult (t*.t) b) +.. (mult t c) +.. d
end
module Arrow =
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
......@@ -474,7 +475,7 @@ module Circle =
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
......@@ -490,8 +491,8 @@ module Circle =
module RoundArrow =
struct
type t = point* point
type t = point* point
let draw to_screen ctx ~thick:thick (center, origin) =
let rho = angle (center -.. origin) in
let xp1,yp1 = to_screen @@ center +.. (rot rho (-4.0,0.0)) in
......@@ -502,8 +503,8 @@ module Circle =
ctx##stroke
end
type shape = [ `Empty
| `Circle of Circle.t
| `Rectangle of Rectangle.t
......@@ -527,7 +528,7 @@ module Circle =
| `SimpleArrow of SimpleArrow.t
| `RoundArrow of RoundArrow.t
]
let center_shape = function
`Empty -> (0.0,0.0)
| `Circle (pos,_) -> pos
......@@ -542,25 +543,25 @@ module Circle =
let rec tangible = function
[] -> `Empty
| `Circle c::_ -> `Circle c
| `Circle c::_ -> `Circle c
| `Rectangle r::_ -> `Rectangle r
| `RoundedRectangle r::_ -> `RoundedRectangle r
| `Text t::_ -> `Text t
| _::q -> tangible q
let rec center_shapes sl = center_shape @@ tangible sl
let rec center_shapes sl = center_shape @@ tangible sl
let projection_shape origin = function
`Circle c