Commit 0200803e authored by Benoît Barbot's avatar Benoît Barbot
Browse files

node

parent 2dc66985
......@@ -12,7 +12,7 @@ let init_def () = ()
let state_id = ref 0
let init_state () = incr state_id;
("s"^(string_of_int !state_id), [])
("s"^(string_of_int !state_id), ["draw"])
let is_prefix s t =
let n = String.length t in
......@@ -73,7 +73,7 @@ let update_state_attr (s,at) attr_id = function
| _ -> None
let get_new_state_attr (s,at) _ = [
"node attribute", fun (s,at) -> s, "" :: at
"node attribute", fun (s,at) -> s, "" :: at
]
......@@ -93,8 +93,8 @@ let draw_arc (at,cn) (source_sh,target_sh) =
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")]
end else begin
let p1 = pos1 +.. (-.25.0, 40.0)
and p2 = pos2 +.. (25.0, 40.0) in
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")]
......@@ -110,7 +110,9 @@ let get_arc_attr (atlist,controllist) =
"Arc", (
(List.mapi (fun i sv -> (B i),"attribute "^(string_of_int (i+1)), (`String sv )) atlist)
@ (List.mapi (fun i sv -> (match sv with
`Point p -> C i,"point "^(string_of_int (i+1)),
`Text (_,s) -> C i,"node "^(string_of_int (i+1)),
(`String s)
| `Point p -> C i,"point "^(string_of_int (i+1)),
(`ControlPoint p)
| `ControlPoint p -> C i,"control "^(string_of_int (i+1)),
(`ControlPoint p)
......@@ -132,7 +134,7 @@ let update_arc_attr (at,cn) attr_id = function
end) (0,[]) cn in
Some (at,(List.rev listcn))
| Some (`Choice _) -> None
| Some (`Color c) -> print_endline c;None
| Some (`Color c) -> None
| None ->
let _,listat = List.fold_left (fun (i,l) at ->
if attr_id = B i then
......@@ -147,7 +149,8 @@ let get_new_arc_attr atlist (p1,p2) =
[
("Attribute", fun (at,cp) -> ("" :: at , cp) ) ;
("Point", fun (at,cp) -> (at , cp @ [`Point (mult 0.5 (p1+..p2))]) );
("Control", fun (at,cp) -> (at , cp @ [`ControlPoint (mult 0.5 (p1+..p2))]) )
("Control", fun (at,cp) -> (at , cp @ [`ControlPoint (mult 0.5 (p1+..p2))]) );
("Node", fun (at,cp) -> (at , cp @ [`Text (0.5,"node")]) )
]
let rec print_string_attr a = function
......@@ -168,6 +171,7 @@ let rec print_point a = function
| (`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
let download_file_name = "figure.tikz"
let print f stateit arcit =
......
......@@ -36,8 +36,44 @@ let angle (x,y) =
if x > 0.0 then atan (y/.x)
else if x < 0.0 then pi +. atan (y/.x)
else if y > 0.0 then pi/.2.0 else -.pi/.2.0
let solve_linear a b =
if a=0.0 then []
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
if d > 0.0 then
let t1 = ((sqrt d) -. b) /. (2.0*.a)
and t2 = (-.(sqrt d) -. b) /. (2.0*.a) in
[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
let a = b1/.a1
and b = c1/.a1
and c = d1/.a1 in
let qQ = (a*.a -. 3.0*.b)/.9.0
and rR = (2.0*.a*.a*.a -. 9.0*.a*.b +. 27.0*.c)/. 54.0 in
let delta = qQ*.qQ*.qQ -. rR*.rR in
if delta >=0.0 then
let theta = acos (rR /. (sqrt (qQ*.qQ*.qQ))) in
let tk k = -.a/.3.0 -. 2.0*.(sqrt qQ)*.(cos (theta/.3.0 +. 2.0*.pi*.k/.3.0)) in
let t0 = tk 0.0
and t1 = tk (-.1.0)
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 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
......@@ -241,6 +277,12 @@ module Circle =
let scal = line *.. (mouse_pos -.. sspos)/.(norm line) in
let yv = mouse_v -.. mult scal line in
(norm yv) < thick && scal> 0.0 && scal<1.0
let point_at t (spos,epos) =
let p0 = spos
and p1 = epos in
p0 +.. (mult t (p1 -..p0))
end
module Bezier2 =
......@@ -257,22 +299,26 @@ module Circle =
ctx##(quadraticCurveTo xc yc x2 y2);
ctx##stroke
let is_over tos mouse_pos ~thick (spos,control,epos) =
let poly_of tos (spos,control,epos) =
let p0 = tos spos
and p1 = tos control
and p2 = tos epos in
let xA,yA = p2 -.. (mult 2.0 p1) +.. p0 in
let xB,yB = (mult 2.0 p1) -.. (mult 2.0 p0) in
let xC,yC = p0 -..mouse_pos in
let dx = xB *. xB -. (4.0 *. xA *. xC) in
if dx >= 0.0 then
let t1 = ((sqrt dx) -. xB) /. (2.0 *. xA)
and t2 = (-.(sqrt dx) -. xB) /. (2.0 *. xA) in
let y1 = yA*.t1*.t1 +. yB*.t1 +. yC
and y2 = yA*.t2*.t2 +. yB*.t2 +. yC in
let eps t x = t>=0.0 && t<=1.0 && abs_float x <= 1.5 *. thick in
eps t1 y1 || eps t2 y2
else false
( 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
let ts = solve_quadratic xA xB xC in
let eps t =
let y1 = yA*.t*.t +. yB*.t +. yC in
t>=0.0 && t<=1.0 && abs_float y1 <= 1.5 *. thick in
List.exists eps ts
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
......@@ -291,37 +337,32 @@ module Circle =
ctx##(bezierCurveTo xc1 yc1 xc2 yc2 x2 y2);
ctx##stroke
let is_over tos mouse_pos ~thick (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 xdiv,ydiv = p3 -.. (mult 3.0 p2) +.. (mult 3.0 p1) -.. p0 in
if xdiv=0.0 then (print_endline "not cubic"; false)
else
let xa,ya = vect_div ((mult 3.0 p2) -.. (mult 6.0 p1) +.. (mult 3.0 p0)) (xdiv,1.0)
and xb,yb = vect_div ((mult 3.0 p1) -.. (mult 3.0 p0)) (xdiv,1.0)
and xc,yc = vect_div (p0 -.. mouse_pos ) (xdiv,1.0) in
let qQ = (xa*.xa -. 3.0*.xb)/.9.0
and rR = (2.0*.xa*.xa*.xa -. 9.0*.xa*.xb +. 27.0*.xc)/. 54.0 in
let delta = qQ*.qQ*.qQ -. rR*.rR in
let eps t =
let y = ydiv*.t*.t*.t +. ya*.t*.t +. yb*.t +. yc in
t>=0.0 && t<=1.0 && abs_float y <= 1.5 *. thick in
if delta >=0.0 then
let theta = acos (rR /. (sqrt (qQ*.qQ*.qQ))) in
let tk k = -.xa/.3.0 -. 2.0*.(sqrt qQ)*.(cos (theta/.3.0 +. 2.0*.pi*.k/.3.0)) in
let t0 = tk 0.0
and t1 = tk (-.1.0)
and t2 = tk 1.0 in
eps t0 || eps t1 || eps t2
else
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
eps t
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
let epsy t =
let y = ya*.t*.t*.t +. yb*.t*.t +. yc*.t +. yd in
t>=0.0 && t<=1.0 && abs_float y <= 1.5 *. thick in
let epsx t =
let x = xa*.t*.t*.t +. xb*.t*.t +. xc*.t +. xd in
t>=0.0 && t<=1.0 && abs_float x <= 1.5 *. thick in
List.exists epsy (solve_cubic xa xb xc xd)
|| List.exists epsx (solve_cubic ya yb yc yd)
let point_at t bez =
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 =
......@@ -440,7 +481,9 @@ module Circle =
List.fold_left (fun b sh -> b || is_over_shape tos mouse_pos sh)
false ls
type path_elem = [ `Point of point | `ControlPoint of point ]
type path_elem = [ `Point of point
| `ControlPoint of point
| `Text of float*string]
let point_of_path_elem = function
`Point p -> p
......@@ -459,9 +502,12 @@ module Circle =
else (pos1,point_list,pos2)
let shapes_of_path shape1 ?arrow1:(arrow1=None) (point_list:path_elem list) ?arrow2:(arrow2=None) shape2 =
let first,last = begin match List.map (function
`Point(p) ->p
| `ControlPoint(p) -> p) point_list with
let first,last = begin match List.fold_right (fun elem l -> (
match elem with
`Point(p) ->p::l
| `ControlPoint(p) -> p::l
| `Text(_) -> l))
point_list [] with
[] -> (center_shape shape1),(center_shape shape2)
| t::[] -> t,t
| t::q -> List.hd (List.rev q),t
......@@ -469,21 +515,42 @@ module Circle =
in
let pos2 = projection_shape first shape2 in
let pos1 = projection_shape last shape1 in
let _,sl = List.fold_left (fun (pp,l) x ->
let _,sl,_ = List.fold_left (fun (pp,l,ltext) x ->
(match (pp,x) with
| [], `Point pip -> [x],l
| `Point pi::_ ,`Point pip -> [x],(`Line (pi,pip)::l)
| _,`Text(t,m) -> pp,l, (t,m)::ltext
| `Text _::q,_ -> q,l,ltext
| `Point pi::_ ,`Point pip ->
let line = (pi,pip) in
let l3 = List.fold_left (fun l2 (t,m) ->
let post = Line.point_at t line in
(`Text (post,m))::l2) l ltext in
[x], ((`Line (pi,pip)::l3)),[]
| `ControlPoint p2::`Point p1::_ ,`Point pip ->
[x],(`Bezier2 (p1,p2,pip)::l)
let bez = (p1,p2,pip) in
let l3 = List.fold_left (fun l2 (t,m) ->
let post = Bezier2.point_at t bez in
(`Text (post,m))::l2) l ltext in
[x],(`Bezier2 bez::l3),[]
| `ControlPoint p3::`ControlPoint p2:: `Point p1::_,`Point pip ->
[x],(`Bezier3 (p1,p2,p3,pip)::l)
let bez = (p1,p2,p3,pip) in
let l3 = List.fold_left (fun l2 (t,m) ->
let post = Bezier3.point_at t bez in
(`Text (post,m))::l2) l ltext in
[x],(`Bezier3 bez::l3),[]
| `ControlPoint p3::`ControlPoint p2:: `Point p1::_,`ControlPoint p4 ->
let m = mult 0.5 (p4+..p3) in
[`ControlPoint p4;`Point m],(`Bezier3 (p1,p2,p3,m)::l)
| hist,`ControlPoint pip -> x::hist , ( l ))
let bez = (p1,p2,p3,m) in
let l3 = List.fold_left (fun l2 (t,m) ->
let post = Bezier3.point_at t bez in
(`Text (post,m))::l2) l ltext in
[`ControlPoint p4;`Point m],(`Bezier3 bez::l3),[]
| hist,`ControlPoint pip -> x::hist , ( l ),ltext)
)
([`Point pos1], (match arrow1 with None -> [] | Some f -> [ f pos1 last])
@ (match arrow2 with None -> [] | Some f -> [ f pos2 first])
@ (match arrow2 with None -> [] | Some f -> [ f pos2 first]), []
)
(point_list@[`Point pos2]) in
(sl: shape list)
......
......@@ -364,7 +364,7 @@ let rec html_of_attr s attr nattr cb =
let new_attr_callback so =
let v = List.assoc so nattr in
v ();
ignore @@ v ();
draw s (0.0,0.0);
update_attr s 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