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