PageRenderTime 26ms CodeModel.GetById 13ms app.highlight 9ms RepoModel.GetById 2ms app.codeStats 0ms

/trunk/Examples/ocaml/shapes/example_prog.ml

#
OCaml | 76 lines | 64 code | 11 blank | 1 comment | 0 complexity | 9664221e673510e46e9e5fca08bb8de4 MD5 | raw file
 1(* example_prog.ml *)
 2
 3open Swig ;;
 4open Example ;;
 5
 6let side_length (ax,ay) (bx,by) =
 7  sqrt (((bx -. ax) ** 2.0) +. ((by -. ay) ** 2.0)) ;;
 8
 9let triangle_area a_pt b_pt c_pt =
10  let a = (side_length a_pt b_pt) 
11  and b = (side_length b_pt c_pt)
12  and c = (side_length c_pt a_pt) in
13  let s = (a +. b +. c) /. 2.0 in
14    sqrt (s *. (s -. a) *. (s -. b) *. (s -. c)) ;;
15
16let point_in_triangle (pta,ptb,ptc) x y =
17  let delta = 0.0000001 in (* Error *)
18  let ptx = (x,y) in
19    begin
20      let a_area = triangle_area pta ptb ptx
21      and b_area = triangle_area ptb ptc ptx
22      and c_area = triangle_area ptc pta ptx
23      and x_area = triangle_area pta ptb ptc in
24      let result = (abs_float (a_area +. b_area +. c_area -. x_area)) < delta
25      in
26	result
27    end ;;
28
29let triangle_class pts ob meth args =
30  match meth with
31      "cover" ->
32	(match args with
33	     C_list [ x_arg ; y_arg ] ->
34	       let xa = x_arg as float 
35	       and ya = y_arg as float in
36		 (point_in_triangle pts xa ya) to bool
37	   | _ -> raise (Failure "cover needs two double arguments."))
38    | _ -> (invoke ob) meth args ;;
39
40let dist (ax,ay) (bx,by) = 
41  let dx = ax -. bx and dy = ay -. by in
42    sqrt ((dx *. dx) +. (dy *. dy))
43
44let waveplot_depth events distance pt =
45  (List.fold_left (+.) 0.0 
46     (List.map 
47	(fun (x,y,d) -> 
48	   let t = dist pt (x,y) in
49	     ((sin t) /. t) *. d)
50	events)) +. distance
51
52let waveplot_class events distance ob meth args =
53  match meth with
54      "depth" ->
55	(match args with
56	     C_list [ x_arg ; y_arg ] ->
57	       let xa = x_arg as float 
58	       and ya = y_arg as float in
59		 (waveplot_depth events distance (xa,ya)) to float
60	   | _ -> raise (Failure "cover needs two double arguments."))
61    | _ -> (invoke ob) meth args ;;
62
63let triangle =
64  new_derived_object 
65    new_shape
66    (triangle_class ((0.0,0.0),(0.5,1.0),(1.0,0.6)))
67    '() ;;
68
69let waveplot = 
70  new_derived_object
71    new_volume
72    (waveplot_class [ 0.01,0.01,3.0 ; 1.01,-2.01,1.5 ] 5.0)
73    '() ;;
74
75let _ = _draw_shape_coverage '(triangle, 60, 20) ;;
76let _ = _draw_depth_map '(waveplot, 60, 20) ;;