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 cut : int -> beam_type * beam_type =
  29         fun (cut_width : int)->
  30           ((self#sub 0 cut_width),(self#sub cut_width (self#width - cut_width)))
  31
  32       method append : beam_type -> beam_type =
  33         fun (b : beam_type) ->
  34           new beam (Array.append self#get b#get)
  35
  36       method private add_memory : int -> unit =
  37         fun (window : int) ->
  38           let signal_add_memory : int -> signal_type -> unit =
  39             fun (l : int) ->
  40               fun (s : signal) ->
  41                 s#add_memory l in
  42           let _ = Array.map (signal_add_memory window) self#get in ()
  43
  44       method matching : int -> beam_type =
  45           fun size ->
  46             if size = self#width then new beam self#get
  47
  48             else if (size > self#width) && (size mod self#width = 0) then
  49               let () = self#add_memory 1 in
  50               let split_signals =
  51                 Array.concat (Array.to_list
  52                      (Array.make (size/self#width) self#get)) in
  53               new beam split_signals
  54
  55             else if (size < self#width) && (self#width mod size = 0) then
  56               let rec merge_rec  =
  57                 fun (sa : signal_type array) ->
  58                   fun (l : int) ->
  59                     fun (i : int) ->
  60                       if i + l < Array.length sa then
  61                         (sa.(i))#add (merge_rec sa l (i + l))
  62                       else sa.(i) in
  63               let merge_signals = Array.init size (merge_rec self#get size) in
  64               new beam merge_signals
  65
  66             else raise (Beam_matching "matching size error")
  67
  68       method at : time -> value_type array =
  69         fun t ->
  70           let signal_at = fun (t : time) -> fun (s : signal_type) -> s#at t in
  71           Array.map (signal_at t) self#get
  72
  73       method output : int -> value_type array array =
  74           fun (length_max : int) ->
  75             let transpose : 'a array array -> 'a array array =
  76               fun matrix ->
  77                 let get_element = fun i -> fun array -> array.(i) in
  78                 let get_column = fun m -> fun i -> Array.map (get_element i) m in
  79                 Array.init self#width (get_column matrix) in
  80             let value_init = new value Error in
  81             let container = Array.make length_max
  82                 (Array.make self#width value_init) in
  83             let index = ref 0 in
  84
  85             try
  86               while !index < length_max do
  87                 container.(!index) <- self#at !index;
  88                 incr index;
  89               done;
  90               transpose container
  91             with x ->
  92
  93               let error_message =
  94                 match x with
  95                 | Convert_Error s -> "Convert_Error: " ^ s
  96                 | Basic_operation s -> "Basic_operation: " ^ s
  97                 | Signal_operation s -> "Signal_operation: " ^ s
  98                 | Beam_matching s -> "Beam_Matching_Error: " ^ s
  99                 | _ -> "Compute finished."
 100               in
 101               let () = print_string error_message in
 102               transpose (Array.sub container 0 !index)
 103     end