src/shared/idpool.pas

   1 (* Copyright (C)  DooM 2D:Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, either version 3 of the License, or
   6  * (at your option) any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15  *)
  16 {$INCLUDE a_modes.inc}
  17 {.$DEFINE IDPOOL_CHECKS}
  18 unit idpool;
  19
  20 interface
  21
  22 // ////////////////////////////////////////////////////////////////////////// //
  23 type
  24   //TODO: implement getting n sequential ids
  25   TIdPool = class(TObject)
  26   public
  27     const InvalidId = $ffffffff;
  28
  29   private
  30     type
  31       TRange = packed record
  32         first, last: LongWord;
  33       end;
  34
  35   private
  36     mRanges: array of TRange; // available ids; sorted
  37     mRangeUsed: Integer; // used elements in `mRanges`
  38     mMaxId: LongWord;
  39     mUsedIds: Integer;
  40
  41   private
  42     function findRangeWithId (aid: LongWord): Integer;
  43
  44     function getHasFreeId (aid: LongWord): Boolean;
  45     function getHasAllocedId (aid: LongWord): Boolean;
  46
  47     function getFreeIds (): Integer; inline;
  48     function getCapacity (): Integer; inline;
  49
  50   public
  51     constructor Create (amax: LongWord=$7fffffff);
  52     destructor Destroy (); override;
  53
  54     procedure clear ();
  55
  56     // returns InvalidId if there are no more free ids (or throws)
  57     function alloc (dothrow: Boolean=true): LongWord;
  58
  59     // returns InvalidId if there are no more free ids (or throws)
  60     function alloc (aid: LongWord; dothrow: Boolean=true): LongWord;
  61
  62     // it is NOT ok to release already released id
  63     procedure release (aid: LongWord);
  64
  65     procedure dump ();
  66     procedure check ();
  67
  68   public
  69     property hasFree[aid: LongWord]: Boolean read getHasFreeId;
  70     property hasAlloced[aid: LongWord]: Boolean read getHasAllocedId;
  71     property maxId: LongWord read mMaxId;
  72
  73     property usedIds: Integer read mUsedIds;
  74     property freeIds: Integer read getFreeIds;
  75
  76     property usedRanges: Integer read mRangeUsed;
  77     property capacity: Integer read getCapacity;
  78   end;
  79
  80 implementation
  81
  82 uses
  83   SysUtils;
  84
  85
  86 // ////////////////////////////////////////////////////////////////////////// //
  87 constructor TIdPool.Create (amax: LongWord=$7fffffff);
  88 begin
  89   if (amax = InvalidId) then amax := InvalidId-1;
  90   mMaxId := amax;
  91   clear();
  92 end;
  93
  94
  95 destructor TIdPool.Destroy ();
  96 begin
  97   mRanges := nil;
  98   inherited;
  99 end;
 100
 101
 102 procedure TIdPool.dump ();
 103 var
 104   f: Integer;
 105 begin
 106   writeln('=== idpool: ', mRangeUsed, ' ranges ===');
 107   for f := 0 to mRangeUsed-1 do
 108   begin
 109     writeln('  #', f, ': [', mRanges[f].first, '-', mRanges[f].last, ']');
 110     if (mRanges[f].last+1 = mRanges[f].first) then raise Exception.Create('unmerged ranges');
 111     if (f > 0) and (mRanges[f-1].last >= mRanges[f].first) then raise Exception.Create('invalid range order');
 112     if (f > 0) and (mRanges[f-1].last+1 = mRanges[f].first) then raise Exception.Create('unmerged ranges');
 113   end;
 114   writeln('-----------');
 115 end;
 116
 117
 118 procedure TIdPool.check ();
 119 var
 120   f: Integer;
 121 begin
 122   for f := 0 to mRangeUsed-1 do
 123   begin
 124     if (mRanges[f].first > mRanges[f].last) then begin dump(); raise Exception.Create('invalid range'); end;
 125     if (mRanges[f].first > mMaxId) then begin dump(); raise Exception.Create('invalid range'); end;
 126     if (mRanges[f].last > mMaxId) then begin dump(); raise Exception.Create('invalid range'); end;
 127     if (f > 0) and (mRanges[f-1].last >= mRanges[f].first) then begin dump(); raise Exception.Create('invalid range order'); end;
 128     if (f > 0) and (mRanges[f-1].last+1 = mRanges[f].first) then begin dump(); raise Exception.Create('unmerged ranges'); end;
 129   end;
 130 end;
 131
 132
 133 procedure TIdPool.clear ();
 134 begin
 135   SetLength(mRanges, 64);
 136   mRanges[0].first := 0;
 137   mRanges[0].last := mMaxId;
 138   mRangeUsed := 1;
 139   mUsedIds := 0;
 140 end;
 141
 142
 143 function TIdPool.getFreeIds (): Integer; inline; begin result := Integer(mMaxId+1-mUsedIds); end;
 144 function TIdPool.getCapacity (): Integer; inline; begin result := Length(mRanges); end;
 145
 146
 147 function TIdPool.findRangeWithId (aid: LongWord): Integer;
 148 var
 149   len, bot, mid, i: Integer;
 150   ls, le: LongWord;
 151 begin
 152   result := -1;
 153   if (aid > mMaxId) then exit;
 154   // -1: not found
 155   len := mRangeUsed;
 156   if (len <= 0) then exit;
 157   if (len = 1) then begin result := 0; exit; end;
 158   // yay! use binary search to find the range
 159   bot := 0;
 160   i := len-1;
 161   while (bot <> i) do
 162   begin
 163     mid := i-(i-bot) div 2;
 164     //!assert((mid >= 0) and (mid < len));
 165     ls := mRanges[mid].first;
 166     le := mRanges[mid+1].first;
 167     if (aid >= ls) and (aid < le) then begin result := mid; exit; end; // i found her!
 168     if (aid < ls) then i := mid-1 else bot := mid;
 169   end;
 170   result := i;
 171 end;
 172
 173
 174 function TIdPool.getHasFreeId (aid: LongWord): Boolean; inline;
 175 var
 176   ii: Integer;
 177 begin
 178   result := false;
 179   if (aid > mMaxId) then exit;
 180   ii := findRangeWithId(aid);
 181   if (ii < 0) then exit;
 182   result := (aid >= mRanges[ii].first) and (aid <= mRanges[ii].last);
 183 end;
 184
 185
 186 function TIdPool.getHasAllocedId (aid: LongWord): Boolean; inline;
 187 var
 188   ii: Integer;
 189 begin
 190   result := false;
 191   if (aid > mMaxId) then exit;
 192   ii := findRangeWithId(aid);
 193   if (ii >= 0) then result := not ((aid >= mRanges[ii].first) and (aid <= mRanges[ii].last)) else result := true;
 194 end;
 195
 196
 197 // returns InvalidId if there are no more free ids (or throws)
 198 function TIdPool.alloc (dothrow: Boolean=true): LongWord;
 199 var
 200   c: Integer;
 201 begin
 202   if (mRangeUsed = 0) then
 203   begin
 204     // no more ids
 205     if dothrow then raise Exception.Create('TIdPool: no more free ids');
 206     result := InvalidId;
 207     exit;
 208   end;
 209   result := mRanges[0].first;
 210   // delete first range?
 211   if (mRanges[0].last = result) then
 212   begin
 213     for c := 1 to mRangeUsed-1 do mRanges[c-1] := mRanges[c];
 214     Dec(mRangeUsed);
 215   end
 216   else
 217   begin
 218     Inc(mRanges[0].first);
 219   end;
 220   Inc(mUsedIds);
 221   {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 222 end;
 223
 224
 225 // returns InvalidId if there are no more free ids (or throws)
 226 function TIdPool.alloc (aid: LongWord; dothrow: Boolean=true): LongWord;
 227 var
 228   ii, c: Integer;
 229 begin
 230   if (mRangeUsed = 0) then
 231   begin
 232     // no more ids
 233     if dothrow then raise Exception.Create('TIdPool: no more free ids');
 234     result := InvalidId;
 235     exit;
 236   end;
 237   // invalid?
 238   if (aid > mMaxId) then
 239   begin
 240     if dothrow then raise Exception.Create('TIdPool: cannot allocate invalid id');
 241     result := InvalidId;
 242     exit;
 243   end;
 244   // find range with this id
 245   ii := findRangeWithId(aid);
 246   if (ii < 0) or (aid < mRanges[ii].first) or (aid > mRanges[ii].last) then
 247   begin
 248     if dothrow then raise Exception.Create('TIdPool: cannot allocate already allocated id');
 249     result := InvalidId;
 250     exit;
 251   end;
 252   // always return requested id
 253   result := aid;
 254   // can we shrink range head?
 255   if (aid = mRanges[ii].first) then
 256   begin
 257     // yep; range with the only id?
 258     if (aid = mRanges[ii].last) then
 259     begin
 260       // delete this range
 261       for c := ii+1 to mRangeUsed-1 do mRanges[c-1] := mRanges[c];
 262       Dec(mRangeUsed);
 263     end
 264     else
 265     begin
 266       mRanges[ii].first := aid+1;
 267     end;
 268     Inc(mUsedIds);
 269     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 270     exit;
 271   end;
 272   // can we shrink range tail?
 273   if (aid = mRanges[ii].last) then
 274   begin
 275     // yep; simply shrink, 'cause range with one id was processed in the previous `if`
 276     mRanges[ii].last := aid-1;
 277     Inc(mUsedIds);
 278     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 279     exit;
 280   end;
 281   // split this range to two
 282   if (mRangeUsed+1 > Length(mRanges)) then SetLength(mRanges, Length(mRanges)+1024);
 283   for c := mRangeUsed downto ii+1 do mRanges[c] := mRanges[c-1];
 284   Inc(mRangeUsed);
 285   mRanges[ii].last := aid-1;
 286   mRanges[ii+1].first := aid+1;
 287   Inc(mUsedIds);
 288   {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 289 end;
 290
 291
 292 // it is NOT ok to release already released id
 293 procedure TIdPool.release (aid: LongWord);
 294 var
 295   ii, c: Integer;
 296 begin
 297   if (aid > mMaxId) then raise Exception.Create(Format('TIdPool: cannot release invalid id %u', [aid]));
 298   // no available ids?
 299   if (mRangeUsed = 0) then
 300   begin
 301     // just create new range
 302     if (Length(mRanges) = 0) then SetLength(mRanges, 64);
 303     mRanges[0].first := aid;
 304     mRanges[0].last := aid;
 305     mRangeUsed := 1;
 306     Dec(mUsedIds);
 307     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 308     exit;
 309   end;
 310   // before first available id?
 311   if (aid < mRanges[0].first) then
 312   begin
 313     // can we grow first range?
 314     if (aid+1 = mRanges[0].first) then
 315     begin
 316       // yep
 317       mRanges[0].first := aid;
 318     end
 319     else
 320     begin
 321       // nope, insert new first range
 322       if (mRangeUsed+1 > Length(mRanges)) then SetLength(mRanges, Length(mRanges)+1024);
 323       assert(mRangeUsed < Length(mRanges));
 324       for c := mRangeUsed downto 1 do mRanges[c] := mRanges[c-1];
 325       Inc(mRangeUsed);
 326       mRanges[0].first := aid;
 327       mRanges[0].last := aid;
 328     end;
 329     Dec(mUsedIds);
 330     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 331     exit;
 332   end;
 333   // after last available id?
 334   if (aid > mRanges[mRangeUsed-1].last) then
 335   begin
 336     // can we grow last range?
 337     if (aid-1 = mRanges[mRangeUsed-1].last) then
 338     begin
 339       // yep
 340       mRanges[mRangeUsed-1].last := aid;
 341     end
 342     else
 343     begin
 344       // nope, insert new last range
 345       if (mRangeUsed+1 > Length(mRanges)) then SetLength(mRanges, Length(mRanges)+1024);
 346       assert(mRangeUsed < Length(mRanges));
 347       mRanges[mRangeUsed].first := aid;
 348       mRanges[mRangeUsed].last := aid;
 349       Inc(mRangeUsed);
 350     end;
 351     Dec(mUsedIds);
 352     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 353     exit;
 354   end;
 355   // alas, no more easy cases; find the nearest range
 356   ii := findRangeWithId(aid);
 357   if (ii < 0) then raise Exception.Create(Format('TIdPool: cannot release invalid id %u', [aid]));
 358   if (aid >= mRanges[ii].first) and (aid <= mRanges[ii].last) then raise Exception.Create(Format('TIdPool: cannot release unallocated id %u', [aid]));
 359   // ii should contain range where `first` is less than `aid`
 360   assert(mRanges[ii].first < aid);
 361   assert(mRanges[ii].last < aid);
 362   {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('aid=', aid, '; ii=', ii, ': [', mRanges[ii].first, '-', mRanges[ii].last, ']');{$ENDIF}
 363   // can grow this range at the end?
 364   if (mRanges[ii].last+1 = aid) then
 365   begin
 366     {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln(' endgrow');{$ENDIF}
 367     // yep; can merge ranges?
 368     if (ii+1 < mRangeUsed) and (aid+1 = mRanges[ii+1].first) then
 369     begin
 370       // merge
 371       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('  endmerge');{$ENDIF}
 372       mRanges[ii].last := mRanges[ii+1].last;
 373       for c := ii+2 to mRangeUsed do mRanges[c-1] := mRanges[c];
 374       Dec(mRangeUsed);
 375     end
 376     else
 377     begin
 378       // change
 379       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('  endchange');{$ENDIF}
 380       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}if (ii+1 < mRangeUsed) then writeln('   ii+1=', ii+1, ': [', mRanges[ii+1].first, '-', mRanges[ii+1].last, ']');{$ENDIF}
 381       mRanges[ii].last := aid;
 382     end;
 383     Dec(mUsedIds);
 384     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 385     exit;
 386   end;
 387   // can grow next range at the start?
 388   if (ii+1 < mRangeUsed) and (aid+1 = mRanges[ii+1].first) then
 389   begin
 390     // yep; can merge ranges?
 391     if (mRanges[ii].last+1 = mRanges[ii+1].first) then
 392     begin
 393       // merge
 394       mRanges[ii].last := mRanges[ii+1].last;
 395       for c := ii+2 to mRangeUsed do mRanges[c-1] := mRanges[c];
 396       Dec(mRangeUsed);
 397     end
 398     else
 399     begin
 400       // change
 401       mRanges[ii+1].first := aid;
 402     end;
 403     Dec(mUsedIds);
 404     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 405     exit;
 406   end;
 407   // cannot grow anything, insert empty range after ii
 408   if (mRangeUsed = Length(mRanges)) then SetLength(mRanges, Length(mRanges)+1024);
 409   for c := mRangeUsed downto ii do mRanges[c+1] := mRanges[c];
 410   Inc(ii);
 411   mRanges[ii].first := aid;
 412   mRanges[ii].last := aid;
 413   Inc(mRangeUsed);
 414   Dec(mUsedIds);
 415   {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 416 end;
 417
 418
 419 end.