interpretor/beam.ml

   1 (**
   2         Module: Beam
   3         Description: beam definition and operations
   4         @author WANG Haisheng
   5         Created: 21/07/2013     Modified: 21/07/2013
   6 *)
   7
   8 exception Beam_matching of string;;
   9
  10 open Types;;
  11 open Basic;;
  12 open Value;;
  13 open Signal;;
  14
  15 class beam : signal_type array -> beam_type =
  16   fun (signals_init : signal_type array) ->
  17     object (self)
  18       val signals = signals_init
  19
  20       method get = signals
  21       method width = Array.length signals
  22
  23       method sub : int -> int -> beam_type =
  24         fun start ->
  25           fun len ->
  26             new beam (Array.sub self#get start len)
  27
  28       method append : beam_type -> beam_type =
  29         fun (b : beam_type) ->
  30           new beam (Array.append self#get b#get)
  31
  32       method private add_memory : int -> unit =
  33         fun (window : int) ->
  34           let signal_add_memory : int -> signal_type -> unit =
  35             fun (l : int) ->
  36               fun (s : signal) ->
  37                 s#add_memory l in
  38           let _ = Array.map (signal_add_memory window) self#get in ()
  39
  40       method matching : int -> beam_type =
  41           fun size ->
  42             if size = self#width then new beam self#get
  43
  44             else if (size > self#width) && (size mod self#width = 0) then
  45               let () = self#add_memory 1 in
  46               let split_signals =
  47                 Array.concat (Array.to_list
  48                      (Array.make (size/self#width) self#get)) in
  49               new beam split_signals
  50
  51             else if (size < self#width) && (self#width mod size = 0) then
  52               let rec merge_rec  =
  53                 fun (sa : signal_type array) ->
  54                   fun (l : int) ->
  55                     fun (i : int) ->
  56                       if i + l < Array.length sa then
  57                         (sa.(i))#add (merge_rec sa l (i + l))
  58                       else sa.(i) in
  59               let merge_signals = Array.init size (merge_rec self#get size) in
  60               new beam merge_signals
  61
  62             else raise (Beam_matching "matching size error")
  63
  64       method at : time -> value_type array =
  65         fun t ->
  66           let signal_at = fun (t : time) -> fun (s : signal_type) -> s#at t in
  67           Array.map (signal_at t) self#get
  68
  69       method output : int -> value_type array array =
  70           fun (length_max : int) ->
  71             let transpose : 'a array array -> 'a array array =
  72               fun matrix ->
  73                 let get_element = fun i -> fun array -> array.(i) in
  74                 let get_column = fun m -> fun i -> Array.map (get_element i) m in
  75                 Array.init self#width (get_column matrix) in
  76             let value_init = new value Error in
  77             let container = Array.make length_max
  78                 (Array.make self#width value_init) in
  79             let index = ref 0 in
  80
  81             try
  82               while !index < length_max do
  83                 container.(!index) <- self#at !index;
  84                 incr index;
  85               done;
  86               transpose container
  87             with x ->
  88
  89               let error_message =
  90                 match x with
  91                 | Convert_Error s -> "Convert_Error: " ^ s
  92                 | Basic_operation s -> "Basic_operation: " ^ s
  93                 | Signal_operation s -> "Signal_operation: " ^ s
  94                 | Beam_matching s -> "Beam_Matching_Error: " ^ s
  95                 | _ -> "Compute finished."
  96               in
  97               let () = print_string error_message in
  98               transpose (Array.sub container 0 !index)
  99     end