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