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