swflib/swfBaseOut.ml

   1 open Base
   2 open StdLabels
   3 open SwfBaseType
   4 open ExtString
   5
   6 type bit =
   7     SB of int * int
   8   | UB of int * int
   9   | FB of int * float
  10
  11 type byte = [
  12   `Si8     of int
  13 | `Si16    of int
  14 | `Si24    of int
  15 | `Si32    of int32
  16 | `Ui8     of int
  17 | `Ui16    of int
  18 | `Ui24    of int
  19 | `Ui32    of int32
  20 | `Ui64    of int64
  21 | `EUi32   of int32
  22 | `Bits    of bit list
  23 ]
  24
  25 type compose = [
  26   `Fixed   of float
  27 | `Fixed8  of float
  28 | `Float32 of float
  29 | `Float64 of float
  30 | `Rect    of int * int * int * int
  31 | `RGB     of int * int * int
  32 | `RGBA    of int * int * int * int
  33 | `ARGB    of int * int * int * int
  34 | `Matrix  of matrix
  35 | `Str     of string
  36 | `Lang    of int
  37 ]
  38
  39 type s = [ byte | compose ]
  40
  41 type backpatch = [
  42   `Ui32Size
  43 | `Size    of (int -> s list) * s list
  44 ]
  45
  46 type t = [ s | backpatch ]
  47
  48 let rec g_si mask shift n value =
  49   unfold begin fun (n,value) ->
  50     if n = 0 then
  51       None
  52     else
  53       Some (mask value,(n-1,shift value))
  54   end (n,value)
  55
  56 let si n value =
  57   g_si ((land) 0xff) (fun x -> x lsr 8) n value
  58
  59 let mask n =
  60   (1 lsl n) - 1
  61
  62 let bits s = function
  63     UB(width, bits) ->
  64       BitsOut.put s ~width ~bits
  65   | SB(width, bits) ->
  66       if bits < - mask (width - 1) - 1 ||  mask (width - 1) < bits then
  67         raise (Invalid_argument "SB");
  68       BitsOut.put s ~width ~bits:(bits land mask width)
  69   | FB(width, bits) ->
  70       let int =
  71         floor bits in
  72       let decimal =
  73         (bits -. int) *. float 0x1_00_00 in
  74       let t =
  75         BitsOut.put s ~width:16 ~bits:(int_of_float decimal) in
  76         BitsOut.put t ~width:(width-16) ~bits:(int_of_float int)
  77
  78 let to_int : byte -> int list = function
  79     `Si8 n  | `Ui8  n ->
  80       si 1 n
  81   | `Si16 n | `Ui16 n ->
  82       si 2 n
  83   | `Si24 n | `Ui24 n ->
  84       si 3 n
  85   | `Si32 n | `Ui32 n ->
  86       g_si
  87         (fun n -> Int32.to_int @@ Int32.logand 0xFFl n)
  88         (fun n -> Int32.shift_right n 8)
  89         4 n
  90   | `Ui64 n ->
  91       g_si
  92         (fun n -> Int64.to_int @@ Int64.logand 0xffL n)
  93         (fun n -> Int64.shift_right n 8)
  94         8 n
  95   | `EUi32 x ->
  96       if x = 0l then
  97         [0]
  98       else
  99         unfold begin fun x ->
 100           if x = 0l then
 101             None
 102           else if 0l < x && x <= 0x7Fl then
 103             Some (Int32.to_int (Int32.logand x 0x7Fl),0l)
 104           else
 105             let next =
 106               Int32.shift_right x 7 in
 107             let current =
 108               Int32.to_int @@ Int32.logor 0x80l @@ Int32.logand x 0x7Fl in
 109               Some (current,next)
 110         end x
 111   | `Bits xs ->
 112       List.fold_left ~f:bits ~init:BitsOut.empty xs
 113       +> BitsOut.to_list
 114
 115 let char c =
 116   `Ui8 (Char.code c)
 117
 118 let bit_width xs =
 119   let bits =
 120     float @@ 1 + HList.maximum xs in
 121     int_of_float @@ 1. +. ceil (log bits /. log 2.)
 122
 123 let to_byte : compose -> byte list = function
 124     `Fixed x ->
 125       let int =
 126         floor x in
 127       let decimal =
 128         (x -. int) *. float 0x1_00_00 in
 129          [`Ui16 (int_of_float decimal);
 130           `Ui16 (int_of_float int)]
 131   | `Fixed8 x ->
 132       let int =
 133         floor x in
 134       let decimal =
 135         (x -. int) *. float 0x1_00 in
 136         [`Ui8 (int_of_float decimal);
 137          `Ui8 (int_of_float int)]
 138   | `Float32 x ->
 139       [`Ui32 (Int32.bits_of_float x)]
 140   | `Float64 x ->
 141       [`Ui64 (Int64.bits_of_float x)]
 142   | `Rect (x_min,x_max,y_min,y_max) ->
 143       let w =
 144         bit_width [x_min; x_max; y_min; y_max] in
 145         [`Bits [UB(5, w);
 146                 SB(w, x_min); SB(w, x_max);
 147                 SB(w, y_min); SB(w, y_max)]]
 148   | `RGB(r,g,b) ->
 149       [`Ui8 r; `Ui8 g; `Ui8 b]
 150   | `RGBA(r,g,b,a) ->
 151       [`Ui8 r; `Ui8 g; `Ui8 b; `Ui8 a]
 152   | `ARGB(a, r, g, b) ->
 153       [`Ui8 a; `Ui8 r; `Ui8 g; `Ui8 b]
 154   | `Str s ->
 155       List.map ~f:char (String.explode s) @ [`Ui8 0]
 156   | `Lang n ->
 157       [`Ui8 n]
 158   | `Matrix {scale; rotate; translate=(x,y) } ->
 159       let t_w =
 160         bit_width [x; y] in
 161       let bits =
 162         List.concat [ begin match scale with
 163                           None ->
 164                             [UB(1,0)]
 165                         | Some (x,y) ->
 166                             let w =
 167                               16 + bit_width [int_of_float @@ ceil x; int_of_float @@ ceil y] in
 168                               [UB(1,1); UB(5,w); FB(w,x); FB(w,y)]
 169                       end;
 170                       begin match rotate with
 171                           None ->
 172                             [UB(1,0)]
 173                         | Some (skew0, skew1) ->
 174                             let w =
 175                               16 + bit_width [int_of_float @@ ceil skew0; int_of_float @@ ceil skew1] in
 176                               [UB(1,1); UB(5,w); FB(w,skew0); FB(w,skew1)]
 177                       end;
 178                       (* translate *)
 179                       [ UB(5,t_w); SB(t_w,x); SB(t_w,y) ] ] in
 180         [`Bits bits]
 181
 182 let int_of_compose x =
 183   match x with
 184       #compose as c -> HList.concat_map to_int @@ to_byte c
 185     | #byte    as b -> to_int b
 186
 187 let backpatch (xs : [byte | backpatch] list) : int list =
 188   let (f,size) =
 189     List.fold_right xs ~init:(const [],0) ~f:begin fun x (f,size) ->
 190       match x with
 191           #byte as b ->
 192             let ints =
 193               to_int b in
 194             let size' =
 195               size + List.length ints in
 196               ((fun ctx -> ints @ f ctx), size')
 197         | `Ui32Size ->
 198             let size' =
 199               (* same as Ui30 *)
 200               size + 4 in
 201               ((fun size -> to_int (`Ui32 (Int32.of_int size)) @ f size), size')
 202         | `Size(g, xs) ->
 203             let ints =
 204               HList.concat_map int_of_compose xs in
 205             let size' =
 206               List.length ints in
 207             let i =
 208               HList.concat_map int_of_compose @@ g size' in
 209               ((fun ctx -> i @ ints @ f ctx), List.length i + size'+size)
 210     end in
 211     f size
 212
 213 let rec to_list xs =
 214   xs
 215   +> HList.concat_map begin function
 216       #byte      as b  -> [b]
 217     | #compose   as c  -> (to_byte c :> [ byte | backpatch] list )
 218     | #backpatch as bp -> [bp]
 219   end
 220   +> backpatch
 221