Examples/ocaml/shapes/example_prog.ml

   1 (* example_prog.ml *)
   2
   3 open Swig ;;
   4 open Example ;;
   5
   6 let side_length (ax,ay) (bx,by) =
   7   sqrt (((bx -. ax) ** 2.0) +. ((by -. ay) ** 2.0)) ;;
   8
   9 let 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
  16 let 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
  29 let 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
  40 let dist (ax,ay) (bx,by) =
  41   let dx = ax -. bx and dy = ay -. by in
  42     sqrt ((dx *. dx) +. (dy *. dy))
  43
  44 let 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
  52 let 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
  63 let 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
  69 let 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
  75 let _ = _draw_shape_coverage '(triangle, 60, 20) ;;
  76 let _ = _draw_depth_map '(waveplot, 60, 20) ;;