1230479Snetchild(* -------------------------------------------------------------------------
2230479Snetchild   Bitstring
3230479Snetchild   ------------------------------------------------------------------------- *)
4230479Snetchild
5230479Snetchildstructure Bitstring :> Bitstring =
6230479Snetchildstruct
7230479Snetchild
8230479Snetchild   infix 8 >>+
9230479Snetchild
10230479Snetchild   type bitstring = bool list
11230479Snetchild
12230479Snetchild   val boolCompare =
13230479Snetchild      fn (false, true) => General.LESS
14230479Snetchild       | (true, false) => General.GREATER
15230479Snetchild       | _ => General.EQUAL
16230479Snetchild
17230479Snetchild   val compare = L3.listCompare boolCompare
18230479Snetchild
19230479Snetchild   fun zero n = List.tabulate (Nat.toNativeInt n, fn _ => false)
20230479Snetchild   fun one n = if n < 1 then [] else zero (n - 1) @ [true]
21230479Snetchild
22   val size: bitstring -> Nat.nat = Nat.fromNativeInt o List.length
23
24   local
25      fun iter a i =
26         if i <= 0 then a
27         else let
28                  val (q, r) = IntInf.quotRem (i, 2)
29              in
30                  iter ((r = 1) :: a) q
31              end
32   in
33      fun fromInt i =
34         if i < 0
35            then raise Domain
36         else if i = 0
37            then [false]
38         else iter [] i
39   end
40
41   val fromNativeInt = fromInt o IntInf.fromInt
42
43   val fromNat = fromInt o Nat.toInt
44
45   val toInt = List.foldl (fn (true, v) => 2 * v + 1 | (false, v) => 2 * v) 0
46
47   val toNat = Nat.fromInt o toInt
48   val toNativeInt = IntInf.toInt o toInt
49
50   val fromBool = fn x => [x]
51
52   fun fromBinString s =
53      (SOME o List.map (fn #"0" => false | #"1" => true | _ => raise Domain) o
54       String.explode) s
55      handle Domain => NONE
56
57   fun fromDecString s =
58      Option.map fromNat (Nat.fromString s) handle Domain => NONE
59
60   val hexBits =
61      fn #"0" => [false, false, false, false]
62       | #"1" => [false, false, false, true]
63       | #"2" => [false, false, true, false]
64       | #"3" => [false, false, true, true]
65       | #"4" => [false, true, false, false]
66       | #"5" => [false, true, false, true]
67       | #"6" => [false, true, true, false]
68       | #"7" => [false, true, true, true]
69       | #"8" => [true, false, false, false]
70       | #"9" => [true, false, false, true]
71       | #"a" => [true, false, true, false]
72       | #"b" => [true, false, true, true]
73       | #"c" => [true, true, false, false]
74       | #"d" => [true, true, false, true]
75       | #"e" => [true, true, true, false]
76       | #"f" => [true, true, true, true]
77       | _ => raise Domain
78
79   fun fromHexString s =
80      (SOME o List.concat o List.map (hexBits o Char.toLower) o
81       String.explode) s
82      handle Domain => NONE
83
84   fun fromLit s =
85      let
86         val v = String.extract (s, 1, NONE)
87      in
88         case String.sub (s, 0) of
89            #"d" => fromDecString v
90          | #"b" => fromBinString v
91          | #"x" => fromHexString v
92          | _ => NONE
93      end
94
95   val toBinString = String.implode o List.map (fn false => #"0" | true => #"1")
96
97   val toDecString = Nat.toString o toNat
98
99   val hexBits =
100      fn [false, false, false, false] => #"0"
101       | [false, false, false, true]  => #"1"
102       | [false, false, true, false]  => #"2"
103       | [false, false, true, true]   => #"3"
104       | [false, true, false, false]  => #"4"
105       | [false, true, false, true]   => #"5"
106       | [false, true, true, false]   => #"6"
107       | [false, true, true, true]    => #"7"
108       | [true, false, false, false]  => #"8"
109       | [true, false, false, true]   => #"9"
110       | [true, false, true, false]   => #"a"
111       | [true, false, true, true]    => #"b"
112       | [true, true, false, false]   => #"c"
113       | [true, true, false, true]    => #"d"
114       | [true, true, true, false]    => #"e"
115       | [true, true, true, true]     => #"f"
116       | _ => raise Domain
117
118   val toHexString =
119      let
120         fun iter a =
121            fn [] => String.implode (List.rev a)
122             | l => iter (hexBits (List.take (l, 4)) :: a) (List.drop (l, 4))
123      in
124         fn l =>
125           let
126              val n = 4 - List.length l mod 4
127              val p = if n = 4 then [] else List.tabulate (n, fn _ => false)
128           in
129              iter [] (p @ l)
130           end
131      end
132
133   fun toList l = l
134   fun fromList l = l
135
136   fun op << (l, s) = l @ zero s
137
138   fun op >>+ (l, s) = List.take (l, List.length l - Nat.toNativeInt s)
139                       handle General.Subscript => []
140
141   fun op #>> (l, s) =
142      let
143         val n = List.length l
144         val x = n - (IntInf.toInt s) mod n
145      in
146         List.drop (l, x) @ List.take (l, x)
147      end
148
149   fun setSize s l =
150      let
151         val n = List.length l
152      in
153         if n < s
154           then zero (Nat.fromNativeInt (s - n)) @ l
155         else List.drop (l, n - s)
156      end
157
158   fun bits (h, l) =
159      let
160         val s = Nat.- (Nat.suc h, l)
161      in
162         fn b =>
163           if s = Nat.zero then [false]
164           else setSize (Nat.toNativeInt s) (b >>+ l)
165      end
166
167   fun bit (a, n) = bits (n, n) a = [true]
168
169   fun modify (f: Nat.nat * bool -> bool) a =
170      #1 (List.foldr (fn (b, (l, i)) => (f (i, b) :: l, i + 1)) ([], 0) a)
171
172   fun bitFieldInsert (h,l) (x, y) =
173      modify (fn (i, b) => if Nat.<= (l, i) andalso Nat.<= (i, h)
174                              then bit (y, Nat.- (i, l))
175                           else b) x
176
177   fun maxLength (l1, l2) = Int.max (List.length l1, List.length l2)
178
179   fun log2plus1 i = if i = 0 then 1 else IntInf.log2 i + 1
180
181   fun op + (l1, l2) =
182      let
183         val r = IntInf.+ (toInt l1, toInt l2)
184      in
185         setSize (Int.max (log2plus1 r, maxLength (l1, l2))) (fromInt r)
186      end
187
188   fun bitwise f =
189      let
190         val mapf = List.map f
191      in
192         fn (l1, l2) =>
193            let
194               val m = maxLength (l1, l2)
195            in
196               mapf (ListPair.zip (setSize m l1, setSize m l2))
197            end
198      end
199
200   val op || = bitwise (fn (a, b) => a orelse b)
201   val op && = bitwise (fn (a, b) => a andalso b)
202   val op ?? = bitwise (fn (a, b) => a = b)
203
204   val op @@ = op @
205
206   fun replicate (a, n) =
207      if n = Nat.zero
208         then zero n
209      else List.foldl (op @@) a
210             (List.tabulate (Nat.toNativeInt n - 1, fn _ => a))
211
212end (* structure Bitstring *)
213