[Toss-devel-svn] SF.net SVN: toss:[1730] trunk/Toss

[<luk...@us...>]

Revision: 1730
          http://toss.svn.sourceforge.net/toss/?rev=1730&view=rev
Author:   lukaszkaiser
Date:     2012-06-20 21:51:20 +0000 (Wed, 20 Jun 2012)
Log Message:
-----------
Hierarchical structures possible, used to define shapes for elements.

Modified Paths:
--------------
    trunk/Toss/Client/Drawing.ml
    trunk/Toss/Client/JsEval.ml
    trunk/Toss/Client/eval.html
    trunk/Toss/Makefile
    trunk/Toss/Server/Tests.ml
    trunk/Toss/Solver/Structure.ml
    trunk/Toss/Solver/Structure.mli

Added Paths:
-----------
    trunk/Toss/Client/Drawing.mli
    trunk/Toss/Client/DrawingTest.ml

Modified: trunk/Toss/Client/Drawing.ml
===================================================================
--- trunk/Toss/Client/Drawing.ml	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/Drawing.ml	2012-06-20 21:51:20 UTC (rev 1730)
@@ -35,48 +35,111 @@
 
 
 (* Various shapes. *)
-type shapes =
-  | Circle of point * float (* circle, given middle and radius *)
-  | Rectangle of point * point (* rectangle, given middle and width-height *)
+type shape =
+  | Circle of point * point (* circle, given middle and radiuses *)
   | Line of point * point (* line, given from and to *)
 
-(* Create an arrow from x to y assuming circle of radius [rad] *)
-let arrow rad x y =
+let shape_str = function
+  | Circle (p, r) -> Printf.sprintf "circle (%F, %F) r (%F, %F)" p.x p.y r.x r.y
+  | Line (f, t) -> Printf.sprintf "line (%F, %F) -- (%F, %F)" f.x f.y t.x t.y
+
+let shapes_str l = String.concat "; " (List.map shape_str l)
+
+(* Shift a shape by [x]. *)
+let shift_shape x = function
+  | Circle (p, r) -> Circle (p +: x, r)
+  | Line (f, t) -> Line (f +: x, t +: x)
+
+let shift_shapes x l = List.map (shift_shape x) l
+
+(* Change coordinates in a shape. *)
+let change_coords_shape c1 c2 = function
+  | Circle (p, r) -> 
+    let z = {x=0.; y=0.} in
+    Circle (change_coords c1 c2 p, change_coords (z, snd c1) (z, snd c2) r)
+  | Line (f, t) -> Line (change_coords c1 c2 f, change_coords c1 c2 t)
+
+let change_coords_shapes c1 c2 l = List.map (change_coords_shape c1 c2) l
+
+(* Helper function - solve a quadratic equation ax^2 + bx + c = 0. *)
+let quadratic a b c =
+  let d = b *. b -. 4. *. a *. c in
+  if d < 0. then [] else if d = 0. then [-1. *. b /. (2. *. a)] else
+      [(-1.*.b +. (sqrt d)) /. (2. *. a); (-1.*.b -. (sqrt d)) /. (2. *. a)]
+
+(* Calculate where the line [p] -- [q] crosses the shape. *)
+let crossing p q = function
+  | Circle (m, r) ->
+    let norm_coord pt = change_coords (m, r) ({x=0.;y=0.}, {x=1.;y=1.}) pt in
+    let back_coord pt = change_coords ({x=0.;y=0.}, {x=1.;y=1.}) (m, r) pt in
+    let p, q = norm_coord p, norm_coord q in
+    let d = q -: p in (* Now we just cross p--q with the unit circle. *)
+    let c =
+      if d.x = 0. && d.y = 0. then
+        if p.x *. p.x +. p.y *. p.y = 0. then [p] else []
+      else if d.x = 0. then (* x = p.x = q.x crosses unit circle *)
+        if p.x < -1. || p.x > 1. then [] else
+          if p.x = 1. || p.x = -1. then [{ x = p.x ; y = 0. }] else
+            let y = sqrt (1. -. p.x *. p.x) in
+            [{ x = p.x ; y = y }; { x = p.x ; y = -1. *. y }]
+      else ( (* y - p.y = d.y / d.x ( x - p.x ) and unit square *)
+        let d = d.y /. d.x in (* ( d (x - p.x) + p.y )^2 + x^2 = 1 *)
+        let c = p.y -. d *. p.x in (* (d x + c)^2 + x^2 - 1 = 0 *)
+        LOG 1 "p = (%F, %F), q = (%F, %F), d = %F, c = %F" p.x p.y q.x q.y d c;
+        let xs = quadratic (1. +. d*.d) (2.*.d*.c) (c*.c -. 1.) in
+        List.map (fun x -> { x = x ; y = d *. (x -. p.x) +. p.y }) xs ) in
+    List.map back_coord c
+  | Line (f, t) -> failwith "crossing not yet implemented for lines"
+
+let crossings p q l = Aux.concat_map (crossing p q) l
+
+(* Maximal distance of shape points from (0, 0). *)
+let radius_single = function
+  | Circle (p, r) -> dist p {x=0.;y=0.} +. (max r.x r.y) (* FIXME *)
+  | Line (f, t) -> max (dist f {x=0.;y=0.}) (dist t {x=0.;y=0.})
+
+let radius l = List.fold_left max 0. (List.rev_map radius_single l)
+
+(* Create an arrow from x to y given the shapes of x and y. *)
+let arrow (x, shapes_x) (y, shapes_y) =
   let len = dist x y in
-  if len < 0.1 then [] else
-    let d = (y -: x) *! (rad /. len) in
-    let q, p = x +: d, y -: d in
-    let arr = p -: (d *! 0.5) in
-    [ Line (q, p); Line (p, rotate p 30. arr); Line (p, rotate p (-30.) arr) ]
+  if len < 0.1 then [] else (
+    let pl, ql = crossings x y shapes_x, crossings x y shapes_y in
+    let mdist x p q = 
+      let f = (dist p x) -. (dist q x) in
+      if f = 0. then 0 else if f > 0. then 1 else -1 in
+    let pl, ql = List.sort (mdist y) pl, List.sort (mdist x) ql in
+    let p = if pl = [] then x else List.hd pl in
+    let q = if ql = [] then y else List.hd ql in
+    let tip = q -: ((y -: q) *! 0.5) in
+    [ Line (p, q); Line (q, rotate q 30. tip); Line (q, rotate q (-30.) tip) ]
+  )
 
-
 (* Structure with coordinates for drawing on canvas. *)
 type structure_with_coords = {
   struc : Structure.structure ;
   coordC: point * point ;
   coordS: point * point ;
-  radius: float ;
 }
 
 let empty_struc_coords () = {
   struc = Structure.empty_structure ();
   coordC = {x=0.;y=0.}, {x=0.;y=0.};
   coordS = {x=0.;y=0.}, {x=0.;y=0.};
-  radius = 0.
 }
  
 (* Get the position of an element. *)
-let get_pos struc e = (* Canvas positions count "from up" on y, thus -1. *)
+let get_pos_pair struc e = (* Canvas positions count "from up" on y, thus -1. *)
   (Structure.fun_val struc "x" e, -1. *. Structure.fun_val struc "y" e)
 
+let get_pos struc e = let (x, y) = get_pos_pair struc e in {x=x; y=y}
+
 (* Create a structure with canvas coordinates given canvas sizes, structure.
    The first four parameters are the width, height and margins of canvas,
-   the third and fourth are (optional) min and max of structure coordinates. *)
+   the fifth and sixth are (optional) min and max of structure coordinates. *)
 let add_coords cwidth cheight cmarginx cmarginy minp maxp struc = 
   let elems = Structure.elements struc in
-  let rad = (* radius for elements *)
-    min 45. (max 5. (450. /. float (List.length elems))) in 
-  let positions = List.map (get_pos struc) elems in
+  let positions = List.map (get_pos_pair struc) elems in
   let minp = match minp with Some p -> p | None ->
     let (posx, posy) = List.split positions in
     { x = List.fold_left min (List.hd posx) posx;
@@ -86,44 +149,70 @@
     { x = List.fold_left max (List.hd posx) posx;
       y = List.fold_left max (List.hd posy) posy } in
   let diffp = { x= max (maxp.x -. minp.x) 1.; y= max (maxp.y -. minp.y) 1. } in
+  let diffp = { x= max diffp.x diffp.y; y= max diffp.x diffp.y } in(*no strech*)
   let coordC = ({ x= cwidth/.2. +. cmarginx; y= cheight/.2. +. cmarginy},
                 { x= cwidth; y= cheight }) in
   let coordS = ((maxp +: minp) /: {x = 2.; y = 2.}, diffp) in
-  { struc = struc ; coordC = coordC ; coordS = coordS ; radius = rad }
+  { struc = struc ; coordC = coordC ; coordS = coordS }
 
 
+(* Read a shape encoded in a structure. *)
+let read_shapes struc = 
+  LOG 1 "reading shapes %s" (Structure.str struc);
+  let circles = Structure.rel_graph "Circle" struc in
+  let radius e =
+    {x = Structure.fun_val struc "rx" e; y = Structure.fun_val struc "ry" e} in
+  let circ e = Circle (get_pos struc e, radius e) in
+  List.map (fun e -> circ e.(0)) (Structure.Tuples.elements circles)
+    
+(* Draw an element of a structure with coordinates. *)
+let draw_elem st_c e =
+  let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
+  let shapes = read_shapes (Structure.model_val struc "shape" e) in
+  change_coords_shapes coordS coordC (shift_shapes (get_pos struc e) shapes)
+
+(* Check whether the float pair (on canvas) is inside the element radius. *)
+let in_elem_radius st_c e (x, y) =
+  let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
+  let shapes = read_shapes (Structure.model_val struc "shape" e) in
+  let p, r = get_pos struc e, radius (shapes)
+  in dist p (change_coords coordC coordS {x=x; y=y}) < r
+
 (* Draw the structure with coordinates [st_c] as a sequence of shapes. *)
 let draw_struc st_c =
   let struc, coordS, coordC = st_c.struc, st_c.coordS, st_c.coordC in
-  let positions = List.map (get_pos struc) (Structure.elements struc) in
-  let circ (x,y)= Circle (change_coords coordS coordC {x=x; y=y},st_c.radius) in
-  let elem_drawings = List.map circ positions in
+  let elems = 
+    List.rev_map (fun e -> (e, draw_elem st_c e)) (Structure.elements struc) in
+  let elem_drawings = Aux.concat_map (fun (_, d) -> d) elems in
   (* drawing relations *)
-  let pos e = 
-    let (x,y) = get_pos struc e in
-    change_coords coordS coordC {x=x; y=y} in
+  let pos e = change_coords coordS coordC (get_pos struc e) in
+  let pos_draw e = (pos e, List.assoc e elems) in
   let draw_rel (rel, arity) =
     if arity = 1 then
       let elems = Structure.Tuples.elements (Structure.rel_graph rel struc) in
-      Aux.concat_map (fun a -> [Circle (pos a.(0), st_c.radius /. 2.)]) elems
+      Aux.concat_map (fun a -> [Circle (pos a.(0), {x=10.; y=10.})]) elems
     else if arity = 2 then
       let tuples = Structure.Tuples.elements (Structure.rel_graph rel struc) in
-      Aux.concat_map (fun a -> arrow st_c.radius (pos a.(0)) (pos a.(1))) tuples
+      Aux.concat_map (fun a-> arrow (pos_draw a.(0)) (pos_draw a.(1))) tuples
     else [] in
   elem_drawings @ (Aux.concat_map draw_rel (Structure.rel_signature struc))
 
 
 (* Compile the shape to a JavaScript program drawing the shape on 'ctx'. *)
 let shape_to_canvas = function
-  | Circle (p, r) -> 
-    let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r in
-    "ctx.beginPath(); " ^ s ^ "ctx.fill(); ctx.stroke(); "
-  | Rectangle (m, wh) ->
-    Printf.sprintf "ctx.fillRect(%F,%F,%F,%F); " m.x m.y wh.x wh.y
+  | Circle (p, r) ->
+    if r.x = r.y then
+      let s = Printf.sprintf "ctx.arc(%F,%F,%F,0,2*Math.PI,false); " p.x p.y r.x
+      in "ctx.beginPath(); "^ s^"ctx.fill(); ctx.stroke(); ctx.closePath(); "
+    else
+      let sc = Printf.sprintf "ctx.scale(%F, %F); " (r.x /.100.) (r.y /.100.) in
+      let tr = Printf.sprintf "ctx.translate(%F, %F); " p.x p.y in
+      "ctx.save(); "^ tr ^sc ^"ctx.beginPath(); ctx.arc(0,0,100,0,2*Math.PI); "^
+        "ctx.stroke(); ctx.closePath(); ctx.restore(); "
   | Line (f, t) -> 
     let fs = Printf.sprintf "ctx.moveTo(%F,%F); " f.x f.y in
     let ts = Printf.sprintf "ctx.lineTo(%F,%F); " t.x t.y in
-    "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); "
+    "ctx.beginPath(); " ^ fs ^ ts ^ "ctx.stroke(); ctx.closePath(); "
 
 let shapes_to_canvas l =
   String.concat " " (List.rev (List.rev_map shape_to_canvas l))

Added: trunk/Toss/Client/Drawing.mli
===================================================================
--- trunk/Toss/Client/Drawing.mli	                        (rev 0)
+++ trunk/Toss/Client/Drawing.mli	2012-06-20 21:51:20 UTC (rev 1730)
@@ -0,0 +1,80 @@
+(** Drawing structures, with compilation to HTML5 canvas commands. *)
+
+(** Points. *)
+type point = { x : float; y : float }
+
+(** Component-wise operations on points. *)
+val ( +: ) : point -> point -> point
+val ( -: ) : point -> point -> point
+val ( *: ) : point -> point -> point
+val ( /: ) : point -> point -> point
+
+(** Scalar operations on points. *)
+val ( +! ) : point -> float -> point
+val ( -! ) : point -> float -> point
+val ( *! ) : point -> float -> point
+val ( /! ) : point -> float -> point
+
+(** Change coordinates from one system to another (given mid-point and size). *)
+val change_coords : point * point -> point * point -> point -> point
+
+(** Distance between two points. *)
+val dist : point -> point -> float
+
+(** Rotate the point [p] around [start] by [angle]. *)
+val rotate : point -> float -> point -> point 
+
+
+(** Shapes. *)
+type shape =
+  | Circle of point * point (** circle, given middle and radiuses *)
+  | Line of point * point   (** line, given from and to *)
+
+(** Print shapes. *)
+val shapes_str : shape list -> string
+
+(** Shift shapes by a vector. *)
+val shift_shapes : point -> shape list -> shape list
+
+(** Change coordinates in shapes. *)
+val change_coords_shapes : point * point -> point * point ->
+  shape list -> shape list
+
+(** Calculate where the line [p] -- [q] crosses shapes. *)
+val crossings : point -> point -> shape list -> point list
+
+(** Maximal distance of shape points from (0, 0). *)
+val radius : shape list -> float
+
+(** Structure with coordinates for drawing on canvas. *)
+type structure_with_coords = {
+  struc : Structure.structure ;
+  coordC: point * point ;
+  coordS: point * point ;
+}
+
+(** Empty structure with trivial coordinates. *)
+val empty_struc_coords : unit -> structure_with_coords
+
+(** Get the position of an element in a structure as a point. *)
+val get_pos : Structure.structure -> int -> point
+
+(** Read a shape encoded in a structure. *)
+val read_shapes : Structure.structure -> shape list
+
+
+(** Create a structure with canvas coordinates given canvas sizes, structure.
+    The first four parameters are the width, height and margins of canvas,
+    the fifth and sixth are (optional) min and max of structure coordinates. *)
+val add_coords: float -> float -> float -> float -> point option -> point option
+  -> Structure.structure -> structure_with_coords
+
+(** Draw the structure with coordinates [st_c] as a sequence of shapes. *)
+val draw_struc : structure_with_coords -> shape list
+
+(** Check whether the float pair (on canvas) is inside the element radius. *)
+val in_elem_radius : structure_with_coords -> int -> float * float -> bool
+
+(** Compile the shapes to a JavaScript program drawing the shape on 'ctx'. 
+    With [result] in JS do: var ctx = canvas.getContext("2d"); eval (result). *)
+val shapes_to_canvas : shape list -> string

Added: trunk/Toss/Client/DrawingTest.ml
===================================================================
--- trunk/Toss/Client/DrawingTest.ml	                        (rev 0)
+++ trunk/Toss/Client/DrawingTest.ml	2012-06-20 21:51:20 UTC (rev 1730)
@@ -0,0 +1,29 @@
+open OUnit
+open Drawing
+
+let eq_point p q = 
+  assert_equal ~printer:(fun p -> Printf.sprintf "(%F, %F)" p.x p.y) p q
+
+let eq_point_list pl ql = 
+  let str p = Printf.sprintf "(%F, %F)" p.x p.y in
+  assert_equal ~printer:(fun l -> String.concat ", " (List.map str l)) pl ql
+
+let tests = "Drawing" >::: [
+  "change coords" >::
+    (fun () ->
+      let z, o = {x=0.;y=0.}, {x=1.;y=1.} in
+      eq_point o (change_coords (z, o) (z, o) o);
+      eq_point (o *! 2.) (change_coords (z, o) (z, o *! 2.) o);
+      eq_point (o *! 2.) (change_coords (z, o) (o, o) o);
+    );
+
+  "crossings" >::
+    (fun () ->
+      let z, o, hsq2 = {x=0.;y=0.}, {x=1.;y=1.}, (sqrt 2.) *. 0.5 in
+      eq_point_list [o*!hsq2; o *! (-1.*.hsq2)] (crossings z o [Circle (z, o)]);
+      eq_point_list [{x=1.;y=0.}] (crossings z {x=1.;y=0.} [Circle (o, o)]);
+      eq_point_list [{x = 2. ; y = 0.}; {x = -2. ; y = 0.}]
+        (crossings z {x=1.; y=0.} [Circle (z, o *! 2.)]);
+    );
+]
+

Modified: trunk/Toss/Client/JsEval.ml
===================================================================
--- trunk/Toss/Client/JsEval.ml	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/JsEval.ml	2012-06-20 21:51:20 UTC (rev 1730)
@@ -1,5 +1,6 @@
 (* Evaluating formulas on structures for JS. *)
 
+
 (* --- Boilerplate code for calling OCaml in the worker thread. --- *)
 let js_object = Js.Unsafe.variable "Object"
 let js_handler = jsnew js_object ()
@@ -68,11 +69,7 @@
 
 let mousedown_handle x y =
   let (x, y), struc = (Js.to_float x, Js.to_float y), !cur_st.Drawing.struc in
-  let cc e = let (x, y) = Drawing.get_pos struc e in
-             let p = Drawing.change_coords !cur_st.Drawing.coordS 
-               !cur_st.Drawing.coordC {Drawing.x = x; Drawing.y = y} in
-             (p.Drawing.x, p.Drawing.y) in
-  let near e = dist (cc e) (x, y) < !cur_st.Drawing.radius in
+  let near e = Drawing.in_elem_radius !cur_st e (x, y) in
   let near_elems = List.filter near (Structure.elements struc) in
   if near_elems = [] then () else (
     moving_elem := Some (List.hd near_elems);

Modified: trunk/Toss/Client/eval.html
===================================================================
--- trunk/Toss/Client/eval.html	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Client/eval.html	2012-06-20 21:51:20 UTC (rev 1730)
@@ -121,8 +121,8 @@
   document.getElementById ("relations").value =
     "E(x, y) = &y = &x + 1;\n" +
     "S(x, y) = x != y and tc x, y E(x, y)";
-  document.getElementById ("positions").value = ":x(a) = &a; \n:y(a) = &a*&a";
-  document.getElementById ("no-elems").value = "3";
+  document.getElementById ("positions").value = ":x(a) = 10*&a;\n:y(a) = &a*&a";
+  document.getElementById ("no-elems").value = "4";
   eval_it ();
 }
 
@@ -164,7 +164,7 @@
 
 <textarea id="positions" rows="3" cols="40">
 :x(a) = &a;
-:y(a) = 10 * &a * (10 - &a)
+:y(a) = &a * (10 - &a) / 10
 </textarea> 
 
 <p>Elements: <input id="no-elems" type="text" size="4" value="15"></input>

Modified: trunk/Toss/Makefile
===================================================================
--- trunk/Toss/Makefile	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Makefile	2012-06-20 21:51:20 UTC (rev 1730)
@@ -144,7 +144,7 @@
 PlayINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
 LearnINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena
 GGPINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play
-ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn
+ServerINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Client
 ClientINC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
 
 .INC=MenhirLib,Term,Formula,Formula/Sat,Formula/Sat/dpll,Solver/RealQuantElim,Solver/Num,Solver,Arena,Play,GGP,Learn,Server
@@ -246,6 +246,14 @@
 	cp _build/Server/Server.native TossServer
 	OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -extratest Learn
 
+# Client tests
+ClientTests: Server/Server.native
+	cp _build/Server/Server.native TossServer
+	OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client
+ClientTestsVerbose: Server/Server.native
+	cp _build/Server/Server.native TossServer
+	OCAMLRUNPARAM=b; export OCAMLRUNPARAM; ./TossServer -fulltest Client -v
+
 # Server tests
 ServerTests: Server/Server.native
 	cp _build/Server/Server.native TossServer

Modified: trunk/Toss/Server/Tests.ml
===================================================================
--- trunk/Toss/Server/Tests.ml	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Server/Tests.ml	2012-06-20 21:51:20 UTC (rev 1730)
@@ -68,6 +68,10 @@
   "LearnGameTest",   [LearnGameTest.tests; LearnGameTest.bigtests];
 ]
 
+let client_tests = "Client", [
+  "DrawingTest", [DrawingTest.tests];
+]
+
 let tests_l = [
   formula_tests;
   term_tests;
@@ -76,6 +80,7 @@
   play_tests;
   ggp_tests;
   learn_tests;
+  client_tests;
 ]
 
 

Modified: trunk/Toss/Solver/Structure.ml
===================================================================
--- trunk/Toss/Solver/Structure.ml	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Solver/Structure.ml	2012-06-20 21:51:20 UTC (rev 1730)
@@ -52,6 +52,7 @@
   elements     : Elems.t ;
   relations    : Tuples.t StringMap.t ;
   functions    : (float IntMap.t) StringMap.t ;
+  models       : (structure IntMap.t) StringMap.t ;
   incidence    : (TIntMap.t) StringMap.t ;
   names        : int StringMap.t ;
   inv_names    : string IntMap.t ;
@@ -103,6 +104,7 @@
   elements = Elems.empty ;
   relations = StringMap.empty ;
   functions = StringMap.empty ;
+  models    = StringMap.empty ;
   incidence = StringMap.empty ;
   names = StringMap.empty ;
   inv_names = IntMap.empty ;
@@ -136,8 +138,13 @@
 (* Return the value of function [f] on [e] in [struc]. *)
 let fun_val struc f e =
   let f_vals = StringMap.find f struc.functions in
-    IntMap.find e f_vals
+  IntMap.find e f_vals
 
+(* Return the model assigned by [f] to [e] in [struc]. *)
+let model_val struc f e =
+  let f_vals = StringMap.find f struc.models in
+  IntMap.find e f_vals
+
 (* Return the list of functions. *)
 let f_signature struc =
   StringMap.fold (fun f _ acc -> f :: acc) struc.functions []
@@ -356,6 +363,21 @@
 
 let change_fun struc fn elem x = change_fun_int struc fn (elem_nbr struc elem) x
 
+
+(* Add model assignment [e] -> [s] to function [fn] in structure [struc]. 
+   Assumes [e] is already an element of [struc]. *)
+let add_model struc fn (e, s) =
+  let new_models = 
+    try
+      let assgns = StringMap.find fn struc.models in
+      StringMap.add fn (IntMap.add e s assgns) struc.models
+    with Not_found ->
+      StringMap.add fn (IntMap.add e s IntMap.empty) struc.models in
+  { struc with models = new_models }
+
+let add_models st fn ms = List.fold_left (fun s a -> add_model s fn a) st ms
+
+
 (* ------------ GLOBAL FUNCTIONS TO CREATE STRUCTURES FROM LISTS ------------ *)
 
 (** Map a function over an array threading an accumulator. *)
@@ -401,10 +423,18 @@
     | None -> empty_structure ()
     | Some s -> s in
   add_from_lists struc els rels funs
-    
+
+let circle_structure rx ry = 
+  create_from_lists ["e"] [("Circle", None, [[|"e"|]])]
+    [("rx", [("e", rx)]); ("ry", [("e", ry)]);
+     ("x", [("e", 0.)]); ("y", [("e", 0.)])]
+
 let create_from_lists_position ?struc els rels =
   let s = create_from_lists ?struc els rels [] in
   let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
+  let circ = circle_structure (cBOARD_DX /. 3.) (cBOARD_DX /. 3.) in
+  let shapes = List.map (fun e -> (e, circ)) elems in
+  let s = add_models s "shape" shapes in
   let zero = List.map (fun e -> (e, 0.)) elems in
   let (_, next) = List.fold_left (fun (cur, acc) e -> 
     (cur +. cBOARD_DX, (e, cur) :: acc)) (0., []) elems in
@@ -414,6 +444,9 @@
 let create_from_lists_range start ?struc els rels =
   let s = create_from_lists ?struc els rels [] in
   let elems = List.sort (fun x y -> x - y) (Elems.elements s.elements) in
+  let circ = circle_structure (1. /. 3.) (1. /. 3.) in
+  let shapes = List.map (fun e -> (e, circ)) elems in
+  let s = add_models s "shape" shapes in
   let zero = List.map (fun e -> (e, 0.)) elems in
   let (_, nextnbr) = List.fold_left (fun (cur, acc) e -> 
     (cur +. 1., (e, cur) :: acc)) (start, []) elems in
@@ -1336,6 +1369,7 @@
     let col_index =
       "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in
 
+    let shape = circle_structure (cBOARD_DX /. 3.) (cBOARD_DX /. 3.) in
     for r = 1 to r_max do
       for c = 1 to c_max do
         if List.hd !fields = [] then
@@ -1361,6 +1395,7 @@
         if r > 1 && elem <> -1 && board_els.(c-1).(r-2) <> -1 then
           struc := add_rel !struc col [|board_els.(c-1).(r-2); elem|];
         if elem <> -1 then begin
+          struc := add_model !struc "shape" (elem, shape);
           struc := add_fun !struc "x"
             (elem, x0 +. dx *. float_of_int (c-1));
           struc := add_fun !struc "y"

Modified: trunk/Toss/Solver/Structure.mli
===================================================================
--- trunk/Toss/Solver/Structure.mli	2012-06-19 21:22:16 UTC (rev 1729)
+++ trunk/Toss/Solver/Structure.mli	2012-06-20 21:51:20 UTC (rev 1730)
@@ -98,6 +98,9 @@
 (** Return the value of function [f] on [e] in [struc]. *)
 val fun_val : structure -> string -> int -> float
 
+(** Return the model assigned by [f] to [e] in [struc]. *)
+val model_val : structure -> string -> int -> structure
+
 (** Return the list of functions. *)
 val f_signature : structure -> string list
 

This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.