Skip to content
GitLab
Commit 9c2f1932 authored by Benoit Barbot's avatar Benoit Barbot
Browse files

progress

parent 88567a35
Hide whitespace changes
Inline Side-by-side
TikzEditor/MarkovChain.ml
View file @ 9c2f1932
......@@ -2,8 +2,10 @@
type state = string * (string list)
type arc = float
type attribute = [ `Choice of string list | `ControlPoint of DrawingGeom.point
| `String of string]
type attribute_id = int
type attribute = [ `Choice of string list
| `ControlPoint of DrawingGeom.point
| `String of string]
let init_def () = ()
......@@ -30,22 +32,22 @@
[`Line (pos1,pos3); `Arrow (pos2,pos1) ;`Colors ("black","black") ; `Text(textvect, text); `Colors ("black","white")]
let get_state_attr (s, at) =
"Node", (("content",`String s) ::
(List.mapi (fun i sv -> "attribute "^(string_of_int i), (`String sv )) at))
"Node", ((0,"content",`String s) ::
(List.mapi (fun i sv -> (i+1),"attribute "^(string_of_int (i+1)),(`String sv )) at))
let update_state_attr (s,at) attr_name olv = function
let update_state_attr (s,at) attr_id = function
| None ->
if attr_name = "content" then Some ("",at)
if attr_id = 0 then Some ("",at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) 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_name = "content" then Some (newv,at)
if attr_id = 0 then Some (newv,at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) then
if attr_id = i+1 then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (s,listat)
| _ -> None
......@@ -53,9 +55,9 @@
let get_new_state_attr (s,at) _ = []
let get_arc_attr prob =
"Arc", [("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 ->
begin try let p = 1.0 in
if p>= 0.0 && p<= 1.0 then Some p else None
......
TikzEditor/TikzGraph.ml
View file @ 9c2f1932
......@@ -2,8 +2,10 @@ 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
type attribute = [ `Choice of string list |
`ControlPoint of DrawingGeom.point | `String of string ]
`ControlPoint of DrawingGeom.point
| `String of string ]
let init_def () = ()
......@@ -18,24 +20,29 @@ let draw_state (s,_) p = [
`Text(p,s);
`Colors ("black","white");
]
let get_state_attr (s, at) =
"Node", (("content",`String s) ::
(List.mapi (fun i sv -> "attribute "^(string_of_int i), (`String sv )) at))
let update_state_attr (s,at) attr_name _ = function
| None ->
if attr_name = "content" then Some ("",at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) then
(i+1, l) else (i+1, at::l)) (0,[]) at in
Some (s,List.rev listat)
| Some (`String newv) ->
if attr_name = "content" then Some (newv,at)
else
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (s,List.rev listat)
"Node", ((A,"content",`String s) ::
(List.mapi (fun i sv -> (B i),"attribute "^(string_of_int (i+1)), (`String sv )) at))
let update_state_attr (s,at) attr_id = function
| None -> begin match attr_id with
A -> Some ("",at)
| B id ->
let _,listat = List.fold_left (fun (i,l) at ->
if id = i then
(i+1, l) else (i+1, at::l)) (0,[]) at in
Some (s,List.rev listat)
| C _ -> None;
end
| Some (`String newv) -> begin
match attr_id with
A -> Some (newv,at)
| B id -> let _,listat = List.fold_left (fun (i,l) at ->
if id = i then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (s,List.rev listat)
| C _ -> None
end
| _ -> None
let get_new_state_attr (s,at) _ = [
......@@ -64,38 +71,36 @@ let draw_arc (_,cn) (source_sh,target_sh) =
let get_arc_attr (atlist,controllist) =
"Arc", (
(List.mapi (fun i sv -> "attribute "^(string_of_int i), (`String sv )) atlist)
(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 -> "point "^(string_of_int i),
`Point p -> C i,"point "^(string_of_int (i+1)),
(`ControlPoint p)
| `ControlPoint p -> "control "^(string_of_int i),
| `ControlPoint p -> C i,"control "^(string_of_int (i+1)),
(`ControlPoint p)
)) controllist)
)
let update_arc_attr (at,cn) attr_name _ = function
let update_arc_attr (at,cn) attr_id = function
Some (`String newv) ->
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) then
if attr_id = B i then
(i+1, newv::l) else (i+1, at::l)) (0,[]) at in
Some (List.rev listat,cn)
| Some (`ControlPoint pt) ->
let _,listcn = List.fold_left (fun (i,l) at ->
if attr_name = ("point "^(string_of_int i)) then
(i+1, (`Point pt)::l)
else if attr_name = ("control "^(string_of_int i)) then
(i+1, (`ControlPoint pt)::l)
else
(i+1, at::l)) (0,[]) cn in
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
| None ->
let _,listat = List.fold_left (fun (i,l) at ->
if attr_name = ("attribute "^(string_of_int i)) then
if attr_id = B i then
(i+1, l) else (i+1, at::l)) (0,[]) at in
let _,listcn = List.fold_left (fun (i,l) at ->
if attr_name = ("point "^(string_of_int i))
|| attr_name = ("control "^(string_of_int i)) then
if attr_id = C i then
(i+1, l) else (i+1, at::l)) (0,[]) cn in
Some ((List.rev listat),(List.rev listcn))
......
editor/DrawingGeom.ml
View file @ 9c2f1932
......@@ -452,7 +452,7 @@ module Circle =
let pos1 = projection_shape last first_shape in
if point_list = [] then (pos1,[first],pos2)
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
......@@ -472,6 +472,9 @@ module Circle =
[x],(`Bezier2 (p1,p2,pip)::l)
| `ControlPoint p3::`ControlPoint p2:: `Point p1::_,`Point pip ->
[x],(`Bezier3 (p1,p2,p3,pip)::l)
| `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 ))
)
([`Point pos1], (match arrow1 with None -> [] | Some f -> [ f pos1 last])
......
editor/SimpleGraph.ml
View file @ 9c2f1932
......@@ -3,20 +3,23 @@ module type PREGRAPH =
type def
type state
type arc
type attribute = [ `String of string | `Choice of string list | `ControlPoint of DrawingGeom.point ]
type attribute_id
type attribute = [ `String of string
| `Choice of string list
| `ControlPoint of DrawingGeom.point ]
val init_def: unit -> def
val init_arc: state -> state -> arc option
val init_state: unit -> state
val draw_state: state -> DrawingGeom.point -> DrawingGeom.shape list
val draw_arc : arc -> (DrawingGeom.shape*DrawingGeom.shape) -> DrawingGeom.shape list
val get_state_attr: state -> string*( (string * attribute) list)
val get_state_attr: state -> string*( (attribute_id*string * attribute) list)
val get_new_state_attr: state -> DrawingGeom.point -> (string * (state -> state)) list
val update_state_attr: state -> string -> attribute -> attribute option -> state option
val update_state_attr: state -> attribute_id -> attribute option -> state option
(* val update_state_attr: state -> string -> string -> bool*)
val get_new_arc_attr: arc -> (DrawingGeom.point*DrawingGeom.point) -> (string * (arc -> arc)) list
val get_arc_attr: arc -> string*( (string * attribute) list)
val update_arc_attr: arc -> string -> attribute -> attribute option -> arc option
val get_arc_attr: arc -> string*( (attribute_id * string * attribute) list)
val update_arc_attr: arc -> attribute_id -> attribute option -> arc option
val parse_file : string -> (state -> DrawingGeom.point -> 'nodeid) -> (arc -> 'nodeid -> 'nodeid -> unit) -> unit
val download_file_name : string
......@@ -29,7 +32,7 @@ module type PREGRAPH =
module S (P:PREGRAPH) =
struct
type attribute_id = P.attribute_id
type stateKey = unit
type arcKey = unit
type graph = {
......@@ -77,12 +80,12 @@ module S (P:PREGRAPH) =
`Empty -> "",[]
| `Arc k -> P.get_arc_attr (arc_from_key graph k)
let update_arc_attribute graph arct attr_name old_value attr_value =
let update_arc_attribute graph arct attr_id attr_value =
match arct with
`Empty -> true
| `Arc k ->
let (),(arc,_,_) = Data.acca graph.arc k in
match P.update_arc_attr !arc attr_name old_value attr_value with
match P.update_arc_attr !arc attr_id attr_value with
None -> false
| Some newarc -> arc := newarc; true
......@@ -132,12 +135,12 @@ module S (P:PREGRAPH) =
let _,(s,_) = Data.acca graph.state n in
P.get_state_attr !s
let update_node_attribute graph node attr_name oldv newv =
let update_node_attribute graph node attr_id newv =
match node with
`Empty -> false
| `State n ->
let _,(s,_) = Data.acca graph.state n in
match P.update_state_attr !s attr_name oldv newv with
match P.update_state_attr !s attr_id newv with
None -> false
| Some s2 -> s := s2; true
......
editor/graphDrawing.ml
View file @ 9c2f1932
......@@ -2,6 +2,7 @@ module type GRAPH = sig
type graph
type node = private [> `Empty]
type arc = private [> `Empty]
type attribute_id
type attribute = [ `String of string
| `Choice of string list
| `ControlPoint of DrawingGeom.point ]
......@@ -11,18 +12,18 @@ module type GRAPH = sig
val get_new_node_choice : graph -> ((float*float) -> DrawingGeom.shape) list
val new_node : graph -> int -> (float*float) -> node
val move_node : graph -> (float*float) -> node -> unit
val update_node_attribute : graph -> node -> string -> attribute -> attribute option -> bool
val update_node_attribute : graph -> node -> attribute_id -> attribute option -> bool
val get_new_node_attribute : graph -> node -> (string * (unit -> unit)) list
val get_node_attribute : graph -> node -> string*( (string *attribute) list)
val get_node_attribute : graph -> node -> string*( (attribute_id*string *attribute) list)
val remove_node : graph -> node -> unit
val iter_arc : graph -> (arc -> unit) -> unit
val shapes_of_arc : graph -> DrawingGeom.shape -> DrawingGeom.shape -> arc ->
(DrawingGeom.shape list)
val new_arc : graph -> node -> node -> bool
val update_arc_attribute : graph -> arc -> string -> attribute -> attribute option -> bool
val update_arc_attribute : graph -> arc -> attribute_id -> attribute option -> bool
val get_new_arc_attribute : graph -> arc -> (string * (unit -> unit)) list
val get_arc_attribute : graph -> arc -> string*( (string *attribute) list)
val get_arc_attribute : graph -> arc -> string*( (attribute_id*string *attribute) list)
val remove_arc : graph -> arc -> unit
val nodes_of_arc : graph -> arc -> node*node
......@@ -182,7 +183,7 @@ module GraphEditor (G: GRAPH ) = struct
if s.selected_obj= Arc obj then
G.get_arc_attribute s.graph obj
|> snd
|> List.iter (function (n,`ControlPoint p) ->
|> List.iter (function (_,n,`ControlPoint p) ->
let sh = shape_of_control_point p in
set_style s.ctx false (is_over_shape (to_screen s) mouse_pos sh);
draw_shapes (to_screen s) s.ctx [sh]
......@@ -272,31 +273,31 @@ module GraphEditor (G: GRAPH ) = struct
let shapes = shapes_of_arc s o in
if is_over_shapes (to_screen s) mouse_pos shapes then obj:= Arc o);
!obj
let rec html_of_attr s attr nattr cb =
let callback n m nv =
let nva = match m with
let rec html_of_attr s attr nattr cb =
let callback id oldv newv =
let nva = match oldv with
`ControlPoint pt -> `ControlPoint pt
| `Choice _ -> `Choice [nv]
| `String _ -> `String nv in
| `Choice _ -> `Choice [newv]
| `String _ -> `String newv in
let v = match s.selected_obj with
Node node -> G.update_node_attribute s.graph node n m (Some nva)
| Arc arc -> G.update_arc_attribute s.graph arc n m (Some nva)
| Area [] -> G.update_arc_attribute s.graph `Empty n m (Some nva)
Node node -> G.update_node_attribute s.graph node id (Some nva)
| Arc arc -> G.update_arc_attribute s.graph arc id (Some nva)
| Area [] -> G.update_arc_attribute s.graph `Empty id (Some nva)
| Area _ -> false in
draw s (0.0,0.0); v in
let callback_supr n m _ =
let callback_supr id _ =
let _ = match s.selected_obj with
Node node -> G.update_node_attribute s.graph node n m None
| Arc arc -> G.update_arc_attribute s.graph arc n m None
| Area [] -> G.update_arc_attribute s.graph `Empty n m None
Node node -> G.update_node_attribute s.graph node id None
| Arc arc -> G.update_arc_attribute s.graph arc id None
| Area [] -> G.update_arc_attribute s.graph `Empty id None
| Area _ -> false in
draw s (0.0,0.0); update_attr s; in
let attr_tr =
List.map (function
(n,v) ->
(id,n,v) ->
let delbutton =
(button ~a:[ a_onclick (callback_supr n v)] [
(button ~a:[ a_onclick (callback_supr id)] [
(*span ~a:[a_class ["glyphicon";"glyphicon-remove"]] [];*) pcdata "X"]) in
match v with
| `ControlPoint (x,y) ->
......@@ -307,13 +308,13 @@ module GraphEditor (G: GRAPH ) = struct
| `Choice ((str::_) as l) ->
tr [ td [pcdata n ;
pcdata ": "; ];
td [ choice_input ~on_change:(fun nv -> ignore @@ callback n v nv) l ];
td [ choice_input ~on_change:(fun nv -> ignore @@ callback id v nv) l ];
td [delbutton]]
| `Choice [] -> tr []
| `String str ->
tr [ td [pcdata n ;
pcdata ": "; ];
td [ text_input ~on_change:(callback n v) str ];
td [ text_input ~on_change:(callback id v) str ];
td [delbutton]]
) attr in
let new_attr = tr [td [choice_input ~init_value:(Some "New Attribute") ~on_change:(fun x ->cb x) nattr]; td [] ] in
......@@ -401,11 +402,11 @@ module GraphEditor (G: GRAPH ) = struct
let cp = match s.selected_obj with
Arc arc ->G.get_arc_attribute s.graph arc
|> snd
|> List.filter (function (_,`ControlPoint _) -> true | _ -> false)
|> List.map (function (n,`ControlPoint p) -> n,shape_of_control_point p
| _ -> "",`Empty)
|> List.filter (function (_,_,`ControlPoint _) -> true | _ -> false)
|> List.map (function (id,n,`ControlPoint p) -> id,n,shape_of_control_point p
| _ -> failwith "notpossible")
|> List.filter (function (_,sh) ->
|> List.filter (function (_,_,sh) ->
is_over_shape (to_screen s) mouse_pos sh)
| _ -> [] in
......@@ -493,12 +494,12 @@ module GraphEditor (G: GRAPH ) = struct
begin
match cp with
[] -> Lwt.return ()
| (at,sh)::_ -> Lwt.pick [
| (id,at,sh)::_ -> Lwt.pick [
mousemoves s.canvas (fun ev _ ->
let nmouse_pos = get_coord s ev in
let pt = from_screen s nmouse_pos in
ignore @@ G.update_arc_attribute s.graph arc at
(`ControlPoint pt) (Some (`ControlPoint pt));
ignore @@ G.update_arc_attribute s.graph arc id
(Some (`ControlPoint pt));
draw s nmouse_pos;
update_attr s;
Lwt.return ());
......
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