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     // it is NOT ok to release already released id
  60     procedure release (aid: LongWord);
  61
  62     procedure dump ();
  63     procedure check ();
  64
  65   public
  66     property hasFree[aid: LongWord]: Boolean read getHasFreeId;
  67     property hasAlloced[aid: LongWord]: Boolean read getHasAllocedId;
  68     property maxId: LongWord read mMaxId;
  69
  70     property usedIds: Integer read mUsedIds;
  71     property freeIds: Integer read getFreeIds;
  72
  73     property usedRanges: Integer read mRangeUsed;
  74     property capacity: Integer read getCapacity;
  75   end;
  76
  77
  78 implementation
  79
  80 uses
  81   SysUtils;
  82
  83
  84 // ////////////////////////////////////////////////////////////////////////// //
  85 constructor TIdPool.Create (amax: LongWord=$7fffffff);
  86 begin
  87   if (amax = InvalidId) then amax := InvalidId-1;
  88   mMaxId := amax;
  89   clear();
  90 end;
  91
  92
  93 destructor TIdPool.Destroy ();
  94 begin
  95   mRanges := nil;
  96   inherited;
  97 end;
  98
  99
 100 procedure TIdPool.dump ();
 101 var
 102   f: Integer;
 103 begin
 104   writeln('=== idpool: ', mRangeUsed, ' ranges ===');
 105   for f := 0 to mRangeUsed-1 do
 106   begin
 107     writeln('  #', f, ': [', mRanges[f].first, '-', mRanges[f].last, ']');
 108     if (mRanges[f].last+1 = mRanges[f].first) then raise Exception.Create('unmerged ranges');
 109     if (f > 0) and (mRanges[f-1].last >= mRanges[f].first) then raise Exception.Create('invalid range order');
 110     if (f > 0) and (mRanges[f-1].last+1 = mRanges[f].first) then raise Exception.Create('unmerged ranges');
 111   end;
 112   writeln('-----------');
 113 end;
 114
 115
 116 procedure TIdPool.check ();
 117 var
 118   f: Integer;
 119 begin
 120   for f := 0 to mRangeUsed-1 do
 121   begin
 122     if (mRanges[f].first > mRanges[f].last) then raise Exception.Create('invalid range');
 123     if (mRanges[f].first > mMaxId) then raise Exception.Create('invalid range');
 124     if (mRanges[f].last > mMaxId) then raise Exception.Create('invalid range');
 125     if (f > 0) and (mRanges[f-1].last >= mRanges[f].first) then raise Exception.Create('invalid range order');
 126     if (f > 0) and (mRanges[f-1].last+1 = mRanges[f].first) then raise Exception.Create('unmerged ranges');
 127   end;
 128 end;
 129
 130
 131 procedure TIdPool.clear ();
 132 begin
 133   SetLength(mRanges, 64);
 134   mRanges[0].first := 0;
 135   mRanges[0].last := mMaxId;
 136   mRangeUsed := 1;
 137   mUsedIds := 0;
 138 end;
 139
 140
 141 function TIdPool.getFreeIds (): Integer; inline; begin result := Integer(mMaxId+1-mUsedIds); end;
 142 function TIdPool.getCapacity (): Integer; inline; begin result := Length(mRanges); end;
 143
 144
 145 function TIdPool.findRangeWithId (aid: LongWord): Integer;
 146 var
 147   len, bot, mid, i: Integer;
 148   ls, le: LongWord;
 149 begin
 150   result := -1;
 151   if (aid > mMaxId) then exit;
 152   // -1: not found
 153   len := mRangeUsed;
 154   if (len <= 0) then exit;
 155   if (len = 1) then begin result := 0; exit; end;
 156   // yay! use binary search to find the range
 157   bot := 0;
 158   i := len-1;
 159   while (bot <> i) do
 160   begin
 161     mid := i-(i-bot) div 2;
 162     //!assert((mid >= 0) and (mid < len));
 163     ls := mRanges[mid].first;
 164     le := mRanges[mid+1].first;
 165     if (aid >= ls) and (aid < le) then begin result := mid; exit; end; // i found her!
 166     if (aid < ls) then i := mid-1 else bot := mid;
 167   end;
 168   result := i;
 169 end;
 170
 171
 172 function TIdPool.getHasFreeId (aid: LongWord): Boolean; inline;
 173 var
 174   ii: Integer;
 175 begin
 176   result := false;
 177   if (aid > mMaxId) then exit;
 178   ii := findRangeWithId(aid);
 179   if (ii < 0) then exit;
 180   result := (aid >= mRanges[ii].first) and (aid <= mRanges[ii].last);
 181 end;
 182
 183
 184 function TIdPool.getHasAllocedId (aid: LongWord): Boolean; inline;
 185 var
 186   ii: Integer;
 187 begin
 188   result := false;
 189   if (aid > mMaxId) then exit;
 190   ii := findRangeWithId(aid);
 191   if (ii >= 0) then result := not ((aid >= mRanges[ii].first) and (aid <= mRanges[ii].last)) else result := true;
 192 end;
 193
 194
 195 // returns InvalidId if there are no more free ids (or throws)
 196 function TIdPool.alloc (dothrow: Boolean=true): LongWord;
 197 var
 198   c: Integer;
 199 begin
 200   if (mRangeUsed = 0) then
 201   begin
 202     // no more ids
 203     if dothrow then raise Exception.Create('TIdPool: no more free ids');
 204     result := InvalidId;
 205     exit;
 206   end;
 207   result := mRanges[0].first;
 208   // delete first range?
 209   if (mRanges[0].last = result) then
 210   begin
 211     for c := 1 to mRangeUsed-1 do mRanges[c-1] := mRanges[c];
 212     Dec(mRangeUsed);
 213   end
 214   else
 215   begin
 216     Inc(mRanges[0].first);
 217   end;
 218   Inc(mUsedIds);
 219   {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 220 end;
 221
 222
 223 // it is NOT ok to release already released id
 224 procedure TIdPool.release (aid: LongWord);
 225 var
 226   ii, c: Integer;
 227 begin
 228   if (aid > mMaxId) then raise Exception.Create(Format('TIdPool: cannot release invalid id %u', [aid]));
 229   // no available ids?
 230   if (mRangeUsed = 0) then
 231   begin
 232     // just create new range
 233     if (Length(mRanges) = 0) then SetLength(mRanges, 64);
 234     mRanges[0].first := aid;
 235     mRanges[0].last := aid;
 236     mRangeUsed := 1;
 237     Dec(mUsedIds);
 238     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 239     exit;
 240   end;
 241   // before first available id?
 242   if (aid < mRanges[0].first) then
 243   begin
 244     // can we grow first range?
 245     if (aid+1 = mRanges[0].first) then
 246     begin
 247       // yep
 248       mRanges[0].first := aid;
 249     end
 250     else
 251     begin
 252       // nope, insert new first range
 253       if (mRangeUsed+1 > Length(mRanges)) then SetLength(mRanges, Length(mRanges)*2);
 254       assert(mRangeUsed < Length(mRanges));
 255       for c := mRangeUsed downto 1 do mRanges[c] := mRanges[c-1];
 256       Inc(mRangeUsed);
 257       mRanges[0].first := aid;
 258       mRanges[0].last := aid;
 259     end;
 260     Dec(mUsedIds);
 261     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 262     exit;
 263   end;
 264   // after last available id?
 265   if (aid > mRanges[mRangeUsed-1].last) then
 266   begin
 267     // can we grow last range?
 268     if (aid-1 = mRanges[mRangeUsed-1].last) then
 269     begin
 270       // yep
 271       mRanges[mRangeUsed-1].last := aid;
 272     end
 273     else
 274     begin
 275       // nope, insert new last range
 276       if (mRangeUsed+1 > Length(mRanges)) then SetLength(mRanges, Length(mRanges)*2);
 277       assert(mRangeUsed < Length(mRanges));
 278       mRanges[mRangeUsed].first := aid;
 279       mRanges[mRangeUsed].last := aid;
 280       Inc(mRangeUsed);
 281     end;
 282     Dec(mUsedIds);
 283     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 284     exit;
 285   end;
 286   // alas, no more easy cases; find the nearest range
 287   ii := findRangeWithId(aid);
 288   if (ii < 0) then raise Exception.Create(Format('TIdPool: cannot release invalid id %u', [aid]));
 289   if (aid >= mRanges[ii].first) and (aid <= mRanges[ii].last) then raise Exception.Create(Format('TIdPool: cannot release unallocated id %u', [aid]));
 290   // ii should contain range where `first` is less than `aid`
 291   assert(mRanges[ii].first < aid);
 292   assert(mRanges[ii].last < aid);
 293   {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('aid=', aid, '; ii=', ii, ': [', mRanges[ii].first, '-', mRanges[ii].last, ']');{$ENDIF}
 294   // can grow this range at the end?
 295   if (mRanges[ii].last+1 = aid) then
 296   begin
 297     {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln(' endgrow');{$ENDIF}
 298     // yep; can merge ranges?
 299     if (ii+1 < mRangeUsed) and (aid+1 = mRanges[ii+1].first) then
 300     begin
 301       // merge
 302       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('  endmerge');{$ENDIF}
 303       mRanges[ii].last := mRanges[ii+1].last;
 304       for c := ii+2 to mRangeUsed do mRanges[c-1] := mRanges[c];
 305       Dec(mRangeUsed);
 306     end
 307     else
 308     begin
 309       // change
 310       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}writeln('  endchange');{$ENDIF}
 311       {$IF DEFINED(IDPOOL_DEBUG_DUMPS)}if (ii+1 < mRangeUsed) then writeln('   ii+1=', ii+1, ': [', mRanges[ii+1].first, '-', mRanges[ii+1].last, ']');{$ENDIF}
 312       mRanges[ii].last := aid;
 313     end;
 314     Dec(mUsedIds);
 315     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 316     exit;
 317   end;
 318   // can grow next range at the start?
 319   if (ii+1 < mRangeUsed) and (aid+1 = mRanges[ii+1].first) then
 320   begin
 321     // yep; can merge ranges?
 322     if (mRanges[ii].last+1 = mRanges[ii+1].first) then
 323     begin
 324       // merge
 325       mRanges[ii].last := mRanges[ii+1].last;
 326       for c := ii+2 to mRangeUsed do mRanges[c-1] := mRanges[c];
 327       Dec(mRangeUsed);
 328     end
 329     else
 330     begin
 331       // change
 332       mRanges[ii+1].first := aid;
 333     end;
 334     Dec(mUsedIds);
 335     {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 336     exit;
 337   end;
 338   // cannot grow anything, insert empty range after ii
 339   if (mRangeUsed = Length(mRanges)) then SetLength(mRanges, Length(mRanges)*2);
 340   for c := mRangeUsed downto ii do mRanges[c+1] := mRanges[c];
 341   Inc(ii);
 342   mRanges[ii].first := aid;
 343   mRanges[ii].last := aid;
 344   Inc(mRangeUsed);
 345   Dec(mUsedIds);
 346   {$IF DEFINED(IDPOOL_CHECKS)}check();{$ENDIF}
 347 end;
 348
 349
 350 end.