bits.inc 8.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369
  1. {
  2. This file is part of the Free Component Library (FCL)
  3. Copyright (c) 1999-2000 by the Free Pascal development team
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. {****************************************************************************}
  11. {* TBits *}
  12. {****************************************************************************}
  13. Procedure BitsError (Msg : string);
  14. begin
  15. Raise EBitsError.Create(Msg) at get_caller_addr(get_frame);
  16. end;
  17. Procedure BitsErrorFmt (Msg : string; const Args : array of const);
  18. begin
  19. Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
  20. end;
  21. procedure TBits.CheckBitIndex (Bit : longint;CurrentSize : Boolean);
  22. begin
  23. if (bit<0) or (CurrentSize and (Bit>Size)) then
  24. BitsErrorFmt(SErrInvalidBitIndex,[bit]);
  25. if (bit>=MaxBitFlags) then
  26. BitsErrorFmt(SErrIndexTooLarge,[bit])
  27. end;
  28. { ************* functions to match TBits class ************* }
  29. function TBits.getSize : longint;
  30. begin
  31. result := (FSize shl BITSHIFT) - 1;
  32. end;
  33. procedure TBits.setSize(value : longint);
  34. begin
  35. if value=0 then
  36. grow(0) // truncate
  37. else
  38. grow(value - 1);
  39. end;
  40. procedure TBits.SetBit(bit : longint; value : Boolean);
  41. begin
  42. if value = True then
  43. seton(bit)
  44. else
  45. clear(bit);
  46. end;
  47. function TBits.OpenBit : longint;
  48. var
  49. loop : longint;
  50. loop2 : longint;
  51. startIndex : longint;
  52. begin
  53. result := -1; {should only occur if the whole array is set}
  54. for loop := 0 to FSize - 1 do
  55. begin
  56. if FBits^[loop] <> $FFFFFFFF then
  57. begin
  58. startIndex := loop * 32;
  59. for loop2 := startIndex to startIndex + 31 do
  60. begin
  61. if get(loop2) = False then
  62. begin
  63. result := loop2;
  64. break; { use this as the index to return }
  65. end;
  66. end;
  67. break; {stop looking for empty bit in records }
  68. end;
  69. end;
  70. if result = -1 then
  71. if FSize < MaxBitRec then
  72. result := FSize * 32; {first bit of next record}
  73. end;
  74. { ******************** TBits ***************************** }
  75. constructor TBits.Create(theSize : longint = 0 );
  76. begin
  77. FSize := 0;
  78. FBits := nil;
  79. findIndex := -1;
  80. findState := True; { no reason just setting it to something }
  81. grow(theSize);
  82. end;
  83. destructor TBits.Destroy;
  84. begin
  85. if FBits <> nil then
  86. FreeMem(FBits, FSize * SizeOf(longint));
  87. FBits := nil;
  88. inherited Destroy;
  89. end;
  90. procedure TBits.grow(nbit : longint);
  91. var
  92. newSize : longint;
  93. loop : longint;
  94. begin
  95. CheckBitindex(nbit,false);
  96. newSize := (nbit shr BITSHIFT) + 1;
  97. if newSize > FSize then
  98. begin
  99. ReAllocMem(FBits, newSize * SizeOf(longint));
  100. if FBits <> nil then
  101. begin
  102. if newSize > FSize then
  103. for loop := FSize to newSize - 1 do
  104. FBits^[loop] := 0;
  105. FSize := newSize;
  106. end
  107. else
  108. BitsError(SErrOutOfMemory);
  109. end;
  110. end;
  111. function TBits.getFSize : longint;
  112. begin
  113. result := FSize;
  114. end;
  115. procedure TBits.seton(bit : longint);
  116. var
  117. n : longint;
  118. begin
  119. n := bit shr BITSHIFT;
  120. grow(bit);
  121. FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
  122. end;
  123. procedure TBits.clear(bit : longint);
  124. var
  125. n : longint;
  126. begin
  127. CheckBitIndex(bit,false);
  128. n := bit shr BITSHIFT;
  129. grow(bit);
  130. FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
  131. end;
  132. procedure TBits.clearall;
  133. var
  134. loop : longint;
  135. begin
  136. for loop := 0 to FSize - 1 do
  137. FBits^[loop] := 0;
  138. end;
  139. function TBits.get(bit : longint) : Boolean;
  140. var
  141. n : longint;
  142. begin
  143. CheckBitIndex(bit,true);
  144. result := False;
  145. n := bit shr BITSHIFT;
  146. if (n < FSize) then
  147. result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0;
  148. end;
  149. procedure TBits.andbits(bitset : TBits);
  150. var
  151. n : longint;
  152. loop : longint;
  153. begin
  154. if FSize < bitset.getFSize then
  155. n := FSize - 1
  156. else
  157. n := bitset.getFSize - 1;
  158. for loop := 0 to n do
  159. FBits^[loop] := FBits^[loop] and bitset.FBits^[loop];
  160. for loop := n + 1 to FSize - 1 do
  161. FBits^[loop] := 0;
  162. end;
  163. procedure TBits.notbits(bitset : TBits);
  164. var
  165. n : longint;
  166. jj : longint;
  167. loop : longint;
  168. begin
  169. if FSize < bitset.getFSize then
  170. n := FSize - 1
  171. else
  172. n := bitset.getFSize - 1;
  173. for loop := 0 to n do
  174. begin
  175. jj := FBits^[loop];
  176. FBits^[loop] := FBits^[loop] and (jj xor bitset.FBits^[loop]);
  177. end;
  178. end;
  179. procedure TBits.orbits(bitset : TBits);
  180. var
  181. n : longint;
  182. loop : longint;
  183. begin
  184. if FSize < bitset.getFSize then
  185. n := bitset.getFSize - 1
  186. else
  187. n := FSize - 1;
  188. grow(n shl BITSHIFT);
  189. for loop := 0 to n do
  190. FBits^[loop] := FBits^[loop] or bitset.FBits^[loop];
  191. end;
  192. procedure TBits.xorbits(bitset : TBits);
  193. var
  194. n : longint;
  195. loop : longint;
  196. begin
  197. if FSize < bitset.getFSize then
  198. n := bitset.getFSize - 1
  199. else
  200. n := FSize - 1;
  201. grow(n shl BITSHIFT);
  202. for loop := 0 to n do
  203. FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
  204. end;
  205. function TBits.equals(bitset : TBits) : Boolean;
  206. var
  207. n : longint;
  208. loop : longint;
  209. begin
  210. result := False;
  211. if FSize < bitset.getFSize then
  212. n := FSize - 1
  213. else
  214. n := bitset.getFSize - 1;
  215. for loop := 0 to n do
  216. if FBits^[loop] <> bitset.FBits^[loop] then exit;
  217. if FSize - 1 > n then
  218. begin
  219. for loop := n to FSize - 1 do
  220. if FBits^[loop] <> 0 then exit;
  221. end
  222. else if bitset.getFSize - 1 > n then
  223. for loop := n to bitset.getFSize - 1 do
  224. if bitset.FBits^[loop] <> 0 then exit;
  225. result := True; {passed all tests}
  226. end;
  227. { us this in place of calling FindFirstBit. It sets the current }
  228. { index used by FindNextBit and FindPrevBit }
  229. procedure TBits.SetIndex(index : longint);
  230. begin
  231. findIndex := index;
  232. end;
  233. { When state is set to True it looks for bits that are turned On (1) }
  234. { and when it is set to False it looks for bits that are turned }
  235. { off (0). }
  236. function TBits.FindFirstBit(state : boolean) : longint;
  237. var
  238. loop : longint;
  239. loop2 : longint;
  240. startIndex : longint;
  241. compareVal : cardinal;
  242. begin
  243. result := -1; {should only occur if none are set}
  244. findState := state;
  245. if state = False then
  246. compareVal := $FFFFFFFF { looking for off bits }
  247. else
  248. compareVal := $00000000; { looking for on bits }
  249. for loop := 0 to FSize - 1 do
  250. begin
  251. if FBits^[loop] <> compareVal then
  252. begin
  253. startIndex := loop * 32;
  254. for loop2 := startIndex to startIndex + 31 do
  255. begin
  256. if get(loop2) = state then
  257. begin
  258. result := loop2;
  259. break; { use this as the index to return }
  260. end;
  261. end;
  262. break; {stop looking for bit in records }
  263. end;
  264. end;
  265. findIndex := result;
  266. end;
  267. function TBits.FindNextBit : longint;
  268. var
  269. loop : longint;
  270. maxVal : longint;
  271. begin
  272. result := -1; { will occur only if no other bits set to }
  273. { current findState }
  274. if findIndex > -1 then { must have called FindFirstBit first }
  275. begin { or set the start index }
  276. maxVal := (FSize * 32) - 1;
  277. for loop := findIndex + 1 to maxVal do
  278. begin
  279. if get(loop) = findState then
  280. begin
  281. result := loop;
  282. break;
  283. end;
  284. end;
  285. findIndex := result;
  286. end;
  287. end;
  288. function TBits.FindPrevBit : longint;
  289. var
  290. loop : longint;
  291. begin
  292. result := -1; { will occur only if no other bits set to }
  293. { current findState }
  294. if findIndex > -1 then { must have called FindFirstBit first }
  295. begin { or set the start index }
  296. for loop := findIndex - 1 downto 0 do
  297. begin
  298. if get(loop) = findState then
  299. begin
  300. result := loop;
  301. break;
  302. end;
  303. end;
  304. findIndex := result;
  305. end;
  306. end;