home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / w3_prog / tpbind.arj / BIND.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-22  |  34.7 KB  |  1,505 lines
  1. unit bind;
  2.  
  3. {
  4.  
  5.     bind
  6.     5-19-91
  7.     loose data binder
  8.  
  9.     Copyright 1991
  10.     John W. Small
  11.     All rights reserved
  12.  
  13.     PSW / Power SoftWare
  14.     P.O. Box 10072
  15.     McLean, Virginia 22102 8072
  16.     USA (703) 759-3838
  17.  
  18. }
  19.  
  20. interface
  21.  
  22.  
  23. const
  24.  
  25.     {  Binder default constants  }
  26.  
  27.     BMAXNODES    =    65520 div sizeof(pointer);
  28.     BLIMIT        =    20;
  29.     BDELTA        =    10;
  30.     BNOTFOUND    =    BMAXNODES;
  31.  
  32.         {  Binder result flags }
  33.  
  34.     BdrOkay        =    $00;
  35.     BdrIndexError    =    $01;
  36.     BdrNoMemory    =    $02;
  37.     BdrNoVacancy    =    $04;
  38.     BdrNoLinks    =    $08;
  39.     BdrNoData    =    $10;
  40.     BdrOtherError    =    $20;
  41.  
  42.  
  43.  
  44.  
  45. type
  46.  
  47.     {  Binder search/sort compare procedure type  }
  48.  
  49.     BcomparE    =    function(D1,  D2: pointer)
  50.                     : integer;
  51.  
  52.  
  53.     {  Binder iterator procedure types }
  54.  
  55.     BforEachBlocK    =    procedure(D, M, A : pointer);
  56.     BdetectBlocK    =    function(D, M : pointer)
  57.                     : boolean;
  58.     BindPtR         =       ^Binder;
  59.     BcollectBlocK    =    procedure(D, M : pointer;
  60.                     R : BindPtR);
  61.  
  62.  
  63.         {  Binder elastic array of pointers type  }
  64.  
  65.     PointerArray    =       array[0..BMAXNODES-1]
  66.                     of pointer;
  67.     LinksVector     =       ^PointerArray;
  68.  
  69.  
  70.         {  Default Binder element  }
  71.  
  72.         BinderN        =    ^BinderNode;
  73.         BinderNode    =    object
  74.             constructor Init;
  75.                 destructor Done; virtual;
  76.     end;
  77.  
  78.  
  79.  
  80.  
  81.  
  82.     Binder          =       object
  83.  
  84.             ok        : boolean;
  85.  
  86.         constructor Init;
  87.                 destructor  Done; virtual;
  88.         function    getLimit : word;
  89.         procedure   setLimit(newLimit : word);
  90.         procedure   pack;
  91.         function    getDelta : word;
  92.         procedure   setDelta(newDelta : word);
  93.         function    getNodes : word;
  94.         function    getMaxNodes : word;
  95.         procedure   setMaxNodes(newMaxNodes : word);
  96.         procedure   atIns(n : word; D : pointer);
  97.                 function    atExt(n : word) : pointer;
  98.         procedure   atDel(n : word);
  99.         procedure   allDel;
  100.         procedure   atFree(n : word);
  101.         procedure   allFree;
  102.         procedure   atPut(n : word; D : pointer);
  103.         function    atGet(n : word) : pointer;
  104.         function    index(D : pointer) : word;
  105.         procedure   add(D : pointer);
  106.         procedure   subtract(D : pointer);
  107.         procedure   forEach  (B : BforEachBlocK;
  108.                 M, A : pointer);
  109.         function    firstThat(B : BdetectBlocK;
  110.                 M : pointer) : word;
  111.         function    lastThat (B : BdetectBlocK;
  112.                 M : pointer) : word;
  113.         procedure   collect  (B : BcollectBlocK;
  114.                 M : pointer; R : BindPtR);
  115.  
  116. {  FlexList like primitives:  }
  117.  
  118.         function    top : pointer;
  119.         function    current : pointer;
  120.         function    bottom : pointer;
  121.         function    curNodeSet : boolean;
  122.         function    getCurNode : word;
  123.         procedure   setCurNode(n : word);
  124.         function    getSorted : boolean;
  125.         procedure   unSort;
  126.         procedure   getComparE(var C : BcomparE);
  127.         procedure   setComparE(C : BcomparE);
  128.         procedure   push(D : pointer);
  129.         function    popExt : pointer;
  130.                 procedure   popDel;
  131.         procedure   popFree;
  132.         procedure   insq(D : pointer);
  133.         function    unqExt : pointer;
  134.         procedure   unqDel;
  135.         procedure   unqFree;
  136.         procedure   ins(D : pointer);
  137.         procedure   insSort(D : pointer);
  138.         function    delExt : pointer;
  139.         procedure   deldel;
  140.         procedure   delFree;
  141.         function    next : boolean;
  142.                 function    prev : boolean;
  143.         function    findFirst(K : pointer) : word;
  144.         function    findNext(K : pointer) : word;
  145.         function    findLast(K : pointer) : word;
  146.         function    findPrev(K : pointer) : word;
  147.         procedure   sort;
  148.  
  149.     private
  150.  
  151.         lowLimit  : word;
  152.         lowThreshold : word;
  153.         first     : word;
  154.         linkS     : LinkSVector;
  155.         limit     : word;
  156.         delta     : word;
  157.         nodes     : word;
  158.         maxNodes  : word;
  159.         curNode   : word;
  160.         sorted    : boolean;
  161.         comparE   : BcomparE;
  162.         procedure   Dfree(D: pointer); virtual;
  163.                 procedure   error(flags, info : word);
  164.                 virtual;
  165.  
  166.         end;   { Binder }
  167.  
  168.  
  169. const
  170.  
  171.     CSTRING        =    0;
  172.  
  173. type
  174.  
  175.         CopyBindPtr    =    ^CopyBinder;
  176.  
  177.  
  178.     CopyBinder    =    Object(Binder)
  179.  
  180.         sizeofData : word;
  181.  
  182.         constructor Init(dataSize : word);
  183.         destructor  Done; virtual;
  184.         procedure   atInsC(n : word; D : pointer);
  185.         procedure   atFreeC(n : word; D : pointer);
  186.         procedure   atFreePutC(n : word;
  187.                 D : pointer);
  188.         procedure   atGetC(n : word; D : pointer);
  189.         procedure   topC(D : pointer);
  190.         procedure   currentC(D : pointer);
  191.                 procedure   bottomC(D : pointer);
  192.         procedure   pushC(D : pointer);
  193.         procedure   popFreeC(D : pointer);
  194.         procedure   insqC(D : pointer);
  195.         procedure   unqFreeC(D : pointer);
  196.         procedure   insC(D : pointer);
  197.         procedure   insSortC(D : pointer);
  198.         procedure   delFreeC(D : pointer);
  199.         function    nextC(D : pointer) : boolean;
  200.         function    prevC(D : pointer) : boolean;
  201.  
  202.     private
  203.  
  204.         procedure   Dfree(D: pointer); virtual;
  205.         function    Dclone(D : pointer)
  206.                 : pointer; virtual;
  207.         procedure   Dcopy(D, S : pointer); virtual;
  208.     end;
  209.  
  210.  
  211.  
  212.  
  213. implementation
  214.  
  215.  
  216. function BnoComp(D1, D2 : pointer) : integer; far;
  217. begin
  218.     BnoComp := -1;
  219. end;
  220.  
  221. {  Binder Methods }
  222.  
  223. constructor Binder.Init;
  224. var sizeofNewLinks : longint;
  225. begin
  226.     curNode := 0;
  227.     first := 0;
  228.     nodes := 0;
  229.     comparE := BnoComp;
  230.  
  231. {
  232.     The following relationships are maintained
  233.     during operation of a binder:
  234.  
  235.     1 <= delta <= lowLimit <= limit <= maxNodes
  236.         <= BMAXNODES
  237.     lowThreshold = lowLimit - delta;
  238. }
  239.     sizeofNewLinks := sizeof(pointer)*BLIMIT;
  240.         if (MaxAvail < sizeofNewLinks) then begin
  241.             delta := 0;
  242.             limit := 0;
  243.             maxNodes := 0;
  244.             lowLimit := 0;
  245.             lowThreshold := 0;
  246.             sorted := false;
  247.             ok := false;
  248.                 error(BdrNoMemory,word(sizeofNewLinks));
  249.             fail
  250.             end;
  251.         getmem(linkS,sizeofNewLinks);
  252.     delta := BDELTA;
  253.     limit := BLIMIT;
  254.     maxNodes := BMAXNODES;
  255.         lowLimit := limit;
  256.         lowThreshold := lowLimit - delta;
  257.         sorted := true;
  258.         ok := true
  259. end;
  260.  
  261. destructor  Binder.Done;
  262. begin
  263.         allDel;
  264.         if (linkS <> nil) then
  265.                 freemem(linkS,sizeof(pointer)*limit);
  266.         linkS := nil;
  267.         curNode := 0;
  268.         first := 0;
  269.     delta := 0;
  270.         limit := 0;
  271.     maxNodes := 0;
  272.         lowLimit := 0;
  273.     lowThreshold := 0;
  274.         sorted := false;
  275.     ok := false;
  276.  
  277. end;
  278.  
  279.  
  280. function Binder.getLimit : word;
  281. begin
  282.     ok := true;
  283.     getLimit := limit
  284. end;
  285.  
  286. procedure Binder.setLimit(newLimit : word);
  287. var
  288.     newLinkS : LinksVector;
  289.         sizeofNewLinks : longint;
  290.     flags, i : word;
  291. begin
  292.     if (newLimit < nodes) then
  293.         newLimit := nodes
  294.     else if (newLimit > maxNodes) then
  295.         newLimit := maxNodes;
  296.     if (newLimit < delta) then
  297.         newLimit := delta;
  298.     if (linkS = nil) or (newLimit = 0)
  299.         or (newLimit = limit) then begin
  300.                 flags := BdrOkay;
  301.                 if (linkS = nil) then
  302.                     flags := flags or BdrNoLinkS;
  303.                 if (newLimit = 0) then
  304.                     flags := flags or BdrOtherError;
  305.                 if (newLimit = limit) then
  306.                     flags := flags or BdrOtherError;
  307.                 ok := false;
  308.                 error(flags,0);
  309.                 exit
  310.                 end;
  311.     sizeofNewLinks := sizeof(pointer) * newLimit;
  312.         if (MaxAvail < sizeofNewLinks) then begin
  313.             ok := false;
  314.                 error(BdrNoMemory,word(sizeofNewLinks));
  315.             exit
  316.             end;
  317.         getmem(newLinkS,sizeofNewLinks);
  318.         i := limit - first;
  319.     if (i > nodes) then
  320.         i := nodes;
  321.     move(linkS^[first],newLinkS^[0],
  322.         sizeof(linkS^[0])*i);
  323.     { copy wrap around }
  324.     if (i < nodes) then
  325.         move(linkS^[0],newLinkS^[i],
  326.             sizeof(linkS^[0])*(nodes-i));
  327.     if (newLimit > limit) then
  328.         if ((newLimit - delta) > limit) then
  329.             lowLimit := newLimit - delta
  330.         else
  331.             lowLimit := limit
  332.     else
  333.         if ((newLimit - delta) > delta) then
  334.             lowLimit := newLimit - delta
  335.         else
  336.             lowLimit := delta;
  337.     lowThreshold := lowLimit - delta;
  338.     freemem(linkS,sizeof(pointer)*limit);
  339.     linkS := newLinkS;
  340.     limit := newLimit;
  341.     first := 0;
  342.         ok := true
  343. end;
  344.  
  345. procedure Binder.pack;
  346. begin
  347.     setLimit(nodes)
  348. end;
  349.  
  350. function Binder.getDelta : word;
  351. begin
  352.     ok := true;
  353.     getDelta := delta
  354. end;
  355.  
  356. procedure Binder.setDelta(newDelta : word);
  357. begin
  358.     if (newDelta = 0) or (newDelta > lowLimit)
  359.         then begin
  360.             ok := false;
  361.                 error(BdrOtherError,0)
  362.                 end
  363.         else  begin
  364.         delta := newDelta;
  365.                 ok := true
  366.                 end
  367. end;
  368.  
  369. function Binder.getNodes : word;
  370. begin
  371.     ok := true;
  372.     getNodes := nodes
  373. end;
  374.  
  375. function Binder.getMaxNodes : word;
  376. begin
  377.     ok := true;
  378.     getMaxNodes := maxNodes
  379. end;
  380.  
  381. procedure Binder.setMaxNodes(newMaxNodes : word);
  382. begin
  383.     if newMaxNodes >= limit then begin
  384.             if newMaxNodes < BMAXNODES then
  385.                     maxNodes := newMaxNodes
  386.             else
  387.                 maxNodes := BMAXNODES;
  388.                 ok := true
  389.                 end
  390.         else  begin
  391.             ok := false;
  392.                 error(BdrOtherError,0)
  393.         end
  394. end;
  395.  
  396. procedure Binder.atIns(n : word; D : pointer);
  397. var newLinks : LinksVector;
  398.         sizeofNewLinks : longint;
  399.     i, flags, newLimit : word;
  400. begin
  401.     if (linkS = nil) or (D = nil) then begin
  402.                 flags := BdrOkay;
  403.                 if (linkS = nil) then
  404.                     flags := flags or BdrNoLinks;
  405.                 if (D = nil) then
  406.                     flags := flags or BdrNoData;
  407.                 ok := false;
  408.                 error(flags,0);
  409.                 exit
  410.             end;
  411.     if (nodes = limit) then begin
  412.         if (limit = maxNodes) then begin
  413.                     ok := false;
  414.                         error(BdrNoVacancy,maxNodes);
  415.                         exit
  416.                         end;
  417.                 if ((maxNodes - delta) > limit) then
  418.                     newLimit := limit + delta
  419.                 else
  420.                     newLimit := maxNodes;
  421.         sizeofNewLinks := sizeof(pointer)*newLimit;
  422.                 if (MaxAvail < sizeofNewLinks) then begin
  423.                     ok := false;
  424.                         error(BdrNoMemory,
  425.                 word(sizeofNewLinks));
  426.                         exit
  427.                         end;
  428.                 getmem(newLinkS,sizeofNewLinks);
  429.                 i := limit - first;
  430.                 if (i > nodes) then
  431.                     i := nodes;
  432.         move(linkS^[first],newLinkS^[0],
  433.             sizeof(linkS^[0])*i);
  434.         { copy wrap around }
  435.         if (i < nodes) then
  436.             move(linkS^[0],newLinkS^[i],
  437.                 sizeof(linkS^[0])*(nodes-i));
  438.         {
  439.             Compute next smaller linkS size
  440.             and threshold for shrinking.
  441.         }
  442.         lowLimit := limit;
  443.         lowThreshold := lowLimit - delta;
  444.         { swap new for old }
  445.         freemem(linkS,sizeof(pointer)*limit);
  446.         linkS := newLinkS;
  447.         limit := newLimit;
  448.         first := 0;
  449.         end;
  450.     if (n = 0) then begin  { push }
  451.             if (first = 0) then
  452.                     first := limit - 1
  453.                 else
  454.                     dec(first);
  455.                 linkS^[first] := D
  456.                 end
  457.     else if (n >= nodes) then begin  { insq }
  458.             n := nodes;
  459.         linkS^[(first+n) mod limit] := D
  460.                 end
  461.     else begin   { insert interior }
  462.         i := (first + n) mod limit;
  463.         if (i < first) or (first = 0) then
  464.             { move rear rightward }
  465.             move(linkS^[i],linkS^[i+1],
  466.                 sizeof(linkS^[0])
  467.                 * (nodes-n))
  468.         else begin { move front leftward }
  469.                     dec(i); dec(first);
  470.             move(linkS^[i],linkS^[first],
  471.                 sizeof(linkS^[0])*(n+1))
  472.                     end;
  473.         linkS^[i] := D
  474.         end;
  475.     inc(nodes);
  476.     if (n <= curNode) then
  477.         inc(curNode);
  478.     sorted := false;
  479.     ok := true
  480. end;
  481.  
  482. function Binder.atExt(n : word) : pointer;
  483. var newLinkS : LinksVector;
  484.     sizeofNewLinks : longint;
  485.         i, flags, newLimit : word;
  486. begin
  487.     if (linkS = nil) or (n >= nodes) then begin
  488.             flags := BdrOkay;
  489.                 if (linkS = nil) then
  490.                     flags := flags or BdrNoLinks;
  491.                 if (n >= nodes) then
  492.                     flags := flags or BdrIndexError;
  493.                 ok := false;
  494.                 error(flags,0);
  495.                 atExt := nil;
  496.                 exit
  497.                 end;
  498.     atExt := linkS^[(first+n) mod limit];
  499.         ok := true;
  500.     if (n = 0)  then begin  { pop }
  501.             inc(first);
  502.                 if (first >= limit) then
  503.                     first := 0
  504.                 end
  505.     else if (n <> (nodes-1)) then begin { del interior }
  506.         { move front rightward }
  507.         move(linkS^[first],linkS^[first+1],
  508.             sizeof(linkS^[0])*n);
  509.         inc(first)
  510.             end;
  511.     dec(nodes);
  512.     if (nodes = 0) then
  513.         sorted := true;
  514.     if (n < curNode) then
  515.         dec(curNode)
  516.     else if (n = curNode) then
  517.         curNode := nodes;
  518.     if (nodes < lowThreshold) then begin
  519.         newLimit := lowLimit;
  520.         sizeofNewLinks := sizeof(pointer)*newLimit;
  521.                 if (MaxAvail < sizeofNewLinks) then
  522.                         exit;
  523.                 getmem(newLinkS,sizeofNewLinks);
  524.                 i := limit - first;
  525.                 if (i > nodes) then
  526.                     i := nodes;
  527.         move(linkS^[first],newLinkS^[0],
  528.             sizeof(linkS^[0])*i);
  529.         { copy wrap around }
  530.         if (i < nodes) then
  531.             move(linkS^[0],newLinkS^[i],
  532.                 sizeof(linkS^[0])*(nodes-i));
  533.         {
  534.             Compute next smaller linkS size
  535.             and threshold for shrinking.
  536.         }
  537.         if ((lowLimit - delta) > delta) then
  538.             dec(lowLimit,delta)
  539.         else
  540.             lowLimit := delta;
  541.         lowThreshold := lowLimit - delta;
  542.         { swap new for old }
  543.                 freemem(linkS,sizeof(pointer)*limit);
  544.         linkS := newLinkS;
  545.         limit := newLimit;
  546.         first := 0
  547.             end
  548. end;
  549.  
  550. procedure Binder.atDel(n : word);
  551. var D : pointer;
  552. begin
  553.          D := atExt(n)
  554. end;
  555.  
  556. procedure Binder.allDel;
  557. begin
  558.     if (linkS = nil) then begin
  559.             ok := false;
  560.                 error(BdrNoLinks,0);
  561.                 exit
  562.                 end;
  563.     while (nodes > 0) do
  564.         atDel(0);
  565.         ok := true
  566. end;
  567.  
  568. procedure Binder.atFree(n : word);
  569. begin
  570.     Dfree(atExt(n))
  571. end;
  572.  
  573. procedure Binder.allFree;
  574. begin
  575.     if (links = nil) then begin
  576.             ok := false;
  577.         error(BdrNoLinks,0);
  578.         exit
  579.         end;
  580.     while (nodes > 0) do
  581.         atFree(0);
  582.         ok := true
  583. end;
  584.  
  585. procedure Binder.atPut(n : word; D : pointer);
  586. var flags : word;
  587. begin
  588.     if (linkS = nil) or (D = nil) or (n >= nodes)
  589.         then begin
  590.                 flags := BdrOkay;
  591.                 if (linkS = nil) then
  592.                     flags := flags or BdrNoLinks;
  593.                 if (D = nil) then
  594.                     flags := flags or BdrNoData;
  595.                 if (n >= nodes) then
  596.                     flags := flags or BdrIndexError;
  597.                 ok := false;
  598.                 error(flags,0)
  599.                 end
  600.     else  begin
  601.             sorted := false;
  602.                 linkS^[(first+n) mod limit] := D;
  603.                 ok := true
  604.                 end
  605. end;
  606.  
  607. function Binder.atGet(n : word) : pointer;
  608. var flags : word;
  609. begin
  610.     if (linkS = nil) or (n >= nodes) then begin
  611.                 flags := BdrOkay;
  612.                 if (linkS = nil) then
  613.                     flags := flags or BdrNoLinks;
  614.                 if (n >= nodes) then
  615.                     flags := flags or BdrIndexError;
  616.                 ok := false;
  617.                 error(flags,0);
  618.                 atGet := nil
  619.                 end
  620.     else  begin
  621.                 ok := true;
  622.                 atGet := linkS^[(first+n) mod limit]
  623.                 end
  624.  
  625. end;
  626.  
  627. function Binder.index(D : pointer) : word;
  628. var i, flags : word;
  629. begin
  630.     if (linkS = nil) or (D = nil) then begin
  631.             flags := BdrOkay;
  632.                 if (linkS = nil) then
  633.                     flags := flags or BdrNoLinks;
  634.                 if (D = nil) then
  635.                     flags := flags or BdrNoData;
  636.                 ok := false;
  637.                 error(flags,0);
  638.                 end
  639.         else begin
  640.         for i := 0 to (nodes - 1) do
  641.                     if (D = linkS^[(first+i) mod limit])
  642.                 then begin
  643.                                 ok := true;
  644.                                 index := i;
  645.                                 exit
  646.                                 end;
  647.                 ok := false
  648.                 end;
  649.         index := BNOTFOUND
  650. end;
  651.  
  652. procedure Binder.add(D : pointer);
  653. begin
  654.     atIns(nodes,D)
  655. end;
  656.  
  657. procedure Binder.subtract(D : pointer);
  658. begin
  659.         atDel(index(D))
  660. end;
  661.  
  662.  
  663. procedure Binder.forEach(B : BforEachBlocK; M, A : pointer);
  664. var i : word;
  665. begin
  666.     if (linkS = nil) then begin
  667.             ok := false;
  668.                 error(BdrNoLinks,0)
  669.                 end
  670.         else begin
  671.             for i := 0 to (nodes - 1) do
  672.                     B(linkS^[(first+i) mod limit],M,A);
  673.                 ok := true
  674.                 end
  675. end;
  676.  
  677. function Binder.firstThat(B : BdetectBlocK;
  678.     M : pointer) : word;
  679. var i : word;
  680. begin
  681.  
  682.     if (linkS = nil) then begin
  683.             ok := false;
  684.                 error(BdrNoLinks,0)
  685.                 end
  686.         else begin
  687.             ok := true;
  688.                 for i := 0 to (nodes - 1) do
  689.             if (B(linkS^[(first+i)
  690.                 mod limit],M)) then begin
  691.                 firstThat := i;
  692.                                 exit
  693.                                 end
  694.  
  695.                 end;
  696.     firstThat := BNOTFOUND
  697. end;
  698.  
  699. function Binder.lastThat(B : BdetectBlocK;
  700.     M : pointer) : word;
  701. var i : word;
  702. begin
  703.  
  704.     if (linkS = nil) then begin
  705.                 ok := false;
  706.                 error(BdrNoLinks,0)
  707.                 end
  708.         else begin
  709.             ok := true;
  710.                 for i := (nodes - 1) downto 0  do
  711.             if (B(linkS^[(first+i)
  712.                 mod limit],M)) then begin
  713.                 lastThat := i;
  714.                                 exit
  715.                                 end
  716.  
  717.                 end;
  718.     lastThat := BNOTFOUND
  719. end;
  720.  
  721.  
  722. procedure Binder.collect(B : BcollectBlocK; M : pointer;
  723.         R : BindPtR);
  724. var i, flags : word;
  725. begin
  726.     if (linkS = nil) or (R = nil)
  727.         then begin
  728.                 flags := BdrOkay;
  729.                 if (linkS = nil) then
  730.                     flags := flags or BdrNoLinks;
  731.                 if (R = nil) then
  732.                     flags := flags or BdrOtherError;
  733.                 ok := false;
  734.                 error(flags,0)
  735.                 end
  736.         else begin
  737.         for i := 0 to (nodes - 1) do
  738.                     B(linkS^[(first+i) mod limit],M,R);
  739.                 ok := true
  740.                 end
  741. end;
  742.  
  743. function Binder.top : pointer;
  744. begin
  745.     top := atGet(0)
  746. end;
  747.  
  748. function Binder.current : pointer;
  749. begin
  750.     current := atGet(curNode)
  751. end;
  752.  
  753. function Binder.bottom : pointer;
  754. begin
  755.     bottom := atGet(nodes-1)
  756. end;
  757.  
  758. function Binder.curNodeSet : boolean;
  759. begin
  760.     ok := true;
  761.     curNodeSet := (curNode < nodes)
  762. end;
  763.  
  764. function Binder.getCurNode : word;
  765. begin
  766.     ok := true;
  767.     getCurNode := curNode
  768. end;
  769.  
  770. procedure Binder.setCurNode(n : word);
  771. begin
  772.     ok := true;
  773.     if (n > nodes) then
  774.         n := nodes;
  775.     curNode := n
  776. end;
  777.  
  778. function Binder.getSorted : boolean;
  779. begin
  780.         ok := true;
  781.     getSorted := sorted
  782. end;
  783.  
  784. procedure Binder.unSort;
  785. begin
  786.         ok := true;
  787.         sorted := false
  788. end;
  789.  
  790. procedure Binder.getComparE(var C : BcomparE);
  791. begin
  792.     ok := true;
  793.     C := comparE
  794. end;
  795.  
  796. procedure Binder.setComparE(C : BcomparE);
  797. begin
  798.         ok := true;
  799.         sorted := false;
  800.         comparE := C
  801. end;
  802.  
  803. procedure Binder.push(D : pointer);
  804. begin
  805.     atIns(0,D)
  806. end;
  807.  
  808. function Binder.popExt : pointer;
  809. begin
  810.     popExt := atExt(0)
  811. end;
  812.  
  813. procedure Binder.popDel;
  814. begin
  815.         atDel(0)
  816. end;
  817.  
  818. procedure Binder.popFree;
  819. begin
  820.     atFree(0)
  821. end;
  822.  
  823. procedure Binder.insq(D : pointer);
  824. begin
  825.         atIns(nodes,D)
  826. end;
  827.  
  828. function Binder.unqExt : pointer;
  829. begin
  830.         unqExt := atExt(nodes-1)
  831. end;
  832.  
  833. procedure Binder.unqDel;
  834. begin
  835.     atDel(nodes-1)
  836. end;
  837.  
  838. procedure Binder.unqFree;
  839. begin
  840.     atFree(nodes-1)
  841. end;
  842.  
  843. procedure Binder.ins(D : pointer);
  844. begin
  845.     atIns(curNode+1,D);
  846.     if ok then begin
  847.         inc(curNode);
  848.         if (curNode >= nodes) then
  849.             curNode := nodes - 1
  850.         end
  851. end;
  852.  
  853. procedure Binder.insSort(D : pointer);
  854. var flags, low, mid, high : word;
  855. begin
  856.  
  857. {
  858.     The current node is left undefined if
  859.     anything fails, otherwise it is set to the
  860.     newly inserted node.
  861. }
  862.  
  863.     curNode := nodes;
  864.     if (linkS = nil) or (D = nil) or (nodes >= maxNodes)
  865.         or (@comparE = @BnoComp) then begin
  866.                 flags := BdrOkay;
  867.                 if (linkS = nil) then
  868.                     flags := flags or BdrNoLinks;
  869.                 if (D = nil) then
  870.                     flags := flags or BdrNoData;
  871.                 if (nodes >= maxNodes) then
  872.                     flags := flags or BdrNoVacancy;
  873.                 if (@comparE = @BnoComp) then
  874.                     flags := flags or BdrOtherError;
  875.                 ok := false;
  876.                 error(flags,0);
  877.                 exit
  878.                 end;
  879.     if (not sorted) then begin
  880.             sort;
  881.                 if (not ok) then
  882.                     exit
  883.                 end;
  884.     low := 0;
  885.     high := nodes;
  886.     while (low < high) do begin
  887.         mid := low + ((high - low) shr 1);
  888.         if (comparE(D,linkS^[(first+mid) mod limit])
  889.             <= 0) then
  890.             high := mid
  891.         else
  892.             low := mid + 1
  893.         end;
  894.         atIns(high,D);
  895.         if ok then
  896.             curNode := high;
  897.     { atIns() resets sorted to zero }
  898.     sorted := true
  899. end;
  900.  
  901. function Binder.delExt : pointer;
  902. var n : word;
  903. begin
  904.     n := curNode;
  905.     delExt := atExt(n);
  906.         if ok then if (n > 0) then
  907.             curNode := n - 1
  908. end;
  909.  
  910. procedure Binder.deldel;
  911. var n : word;
  912. begin
  913.     n := curNode;
  914.     atDel(n);
  915.         if ok then if (n > 0) then
  916.             curNode := n - 1
  917. end;
  918.  
  919. procedure Binder.delFree;
  920. var n : word;
  921. begin
  922.     n := curNode;
  923.     atFree(n);
  924.         if ok then if (n > 0) then
  925.             curNode := n - 1
  926. end;
  927.  
  928. function Binder.next : boolean;
  929. begin
  930.     if (linkS = nil) then begin
  931.             ok := false;
  932.                 error(BdrNoLinks,0);
  933.                 end
  934.         else begin
  935.         if (curNode >= nodes) then
  936.             curNode := 0
  937.         else
  938.             inc(curNode);
  939.         if (curNode < nodes) then
  940.                 ok := true
  941.             else
  942.                 ok := false
  943.                 end;
  944.         next := ok
  945. end;
  946.  
  947. function Binder.prev : boolean;
  948. begin
  949.     if (linkS = nil) then begin
  950.             ok := false;
  951.                 error(BdrNoLinks,0);
  952.                 end
  953.         else
  954.         if (curNode > 0) then begin
  955.             if (curNode > nodes) then
  956.                 curNode := nodes;
  957.             dec(curNode);
  958.                         ok := true
  959.                         end
  960.         else begin
  961.             curNode := nodes;
  962.                         ok := false
  963.                         end;
  964.         prev := ok
  965. end;
  966.  
  967. function Binder.findFirst(K : pointer) : word;
  968. var flags, low, mid, high : word;
  969. begin
  970.  
  971. {
  972.     The current node is left undefined if
  973.     anything fails, otherwise it is set to the
  974.     newly found node.
  975. }
  976.  
  977.     curNode := nodes;
  978.     if (linkS = nil) or (K = nil)
  979.         or (@comparE = @BnoComp) then begin
  980.                 flags := BdrOkay;
  981.                 if (linkS = nil) then
  982.                     flags := flags or BdrNoLinks;
  983.                 if (K = nil) or (@comparE = @BnoComp) then
  984.                     flags := flags or BdrOtherError;
  985.                 ok := false;
  986.                 error(flags,0);
  987.                 findFirst := BNOTFOUND;
  988.                 exit
  989.                 end;
  990.     if (sorted) then begin
  991.         low := 0;
  992.         high := nodes;
  993.         while (low < high) do begin
  994.             mid := low + ((high - low) shr 1);
  995.             if (comparE(K,linkS^[(first+mid)
  996.                 mod limit]) <= 0) then
  997.                 high := mid
  998.             else
  999.                 low := mid + 1
  1000.             end;
  1001.         if (high < nodes) then
  1002.             if (comparE(K,linkS^[(first+
  1003.                 high) mod limit]) = 0)
  1004.                 then begin
  1005.                                 ok := true;
  1006.                                 curNode := high;
  1007.                                 findFirst := curNode;
  1008.                                 exit
  1009.                                 end
  1010.         end
  1011.     else { linear search! }
  1012.         while (next) do
  1013.             if (comparE(K,current) = 0) then begin
  1014.                             ok := true;
  1015.                                 findFirst := curNode;
  1016.                                 exit
  1017.                                 end;
  1018.         ok := false;
  1019.     findFirst := BNOTFOUND
  1020. end;
  1021.  
  1022. function Binder.findNext(K : pointer) : word;
  1023. var flags : word;
  1024. begin
  1025.  
  1026. {
  1027.     For sorted binders you must first call findFirst()
  1028.     to insure consistent results!
  1029.  
  1030.     The current node is left undefined if
  1031.     anything fails, otherwise it is set to the
  1032.     newly found node.
  1033. }
  1034.  
  1035.     if (linkS = nil) or (K = nil)
  1036.         or (@comparE = @BnoComp) then begin
  1037.         curNode := nodes;
  1038.                 flags := BdrOkay;
  1039.                 if (linkS = nil) then
  1040.                     flags := flags or BdrNoLinks;
  1041.                 if (K = nil) or (@comparE = @BnoComp) then
  1042.                     flags := flags or BdrOtherError;
  1043.                 ok := false;
  1044.                 error(flags,0);
  1045.                 findNext := BNOTFOUND;
  1046.                 exit
  1047.                 end;
  1048.         while (next) do
  1049.         if (comparE(K,current) = 0) then begin
  1050.                     ok := true;
  1051.                         findNext := curNode;
  1052.                         exit
  1053.                         end
  1054.         else if (sorted) then begin
  1055.             curNode := nodes;
  1056.                         ok := false;
  1057.                         findNext := BNOTFOUND;
  1058.                         exit
  1059.                         end;
  1060.         ok := false;
  1061.         findNext := BNOTFOUND
  1062. end;
  1063.  
  1064.  
  1065. function Binder.findLast(K : pointer) : word;
  1066. var flags, low, mid, high : word;
  1067. begin
  1068.  
  1069. {
  1070.     The current node is left undefined if
  1071.     anything fails, otherwise it is set to the
  1072.     newly found node.
  1073. }
  1074.  
  1075.     curNode := nodes;
  1076.         if (linkS = nil) or (K = nil)
  1077.         or (@comparE = @BnoComp) then begin
  1078.                 flags := BdrOkay;
  1079.                 if (linkS = nil) then
  1080.                     flags := flags or BdrNoLinks;
  1081.                 if (K = nil) or (@comparE = @BnoComp) then
  1082.                     flags := flags or BdrOtherError;
  1083.                 ok := false;
  1084.                 error(flags,0);
  1085.                 findLast := BNOTFOUND;
  1086.                 exit
  1087.                 end;
  1088.     if (sorted) then begin
  1089.         low := 0;
  1090.         high := nodes;
  1091.         while (low < high) do begin
  1092.             mid := low + ((high - low) shr 1);
  1093.             if (comparE(K,linkS^[(first+mid)
  1094.                 mod limit]) < 0) then
  1095.                 high := mid
  1096.             else
  1097.                 low := mid + 1
  1098.             end;
  1099.         if (high < nodes) then
  1100.             if (comparE(K,linkS^[(first+
  1101.                 high) mod limit]) = 0)
  1102.                 then begin
  1103.                                 ok := true;
  1104.                                 curNode := high;
  1105.                                 findLast := curNode;
  1106.                                 exit
  1107.                                 end
  1108.         end
  1109.     else { linear search! }
  1110.         while (prev) do
  1111.             if (comparE(K,current) = 0) then begin
  1112.                             ok := true;
  1113.                                 findLast := curNode;
  1114.                                 exit
  1115.                                 end;
  1116.         ok := false;
  1117.     findLast := BNOTFOUND
  1118. end;
  1119.  
  1120. function Binder.findPrev(K : pointer) : word;
  1121. var flags : word;
  1122. begin
  1123.  
  1124. {
  1125.     For sorted binders you must first call findLast()
  1126.     to insure consistent results!
  1127.  
  1128.     The current node is left undefined if
  1129.     anything fails, otherwise it is set to the
  1130.     newly found node.
  1131. }
  1132.  
  1133.     if (linkS = nil) or (K = nil)
  1134.         or (@comparE = @BnoComp) then begin
  1135.         curNode := nodes;
  1136.                 flags := BdrOkay;
  1137.                 if (linkS = nil) then
  1138.                     flags := flags or BdrNoLinks;
  1139.                 if (K = nil) or (@comparE = @BnoComp) then
  1140.                     flags := flags or BdrOtherError;
  1141.                 ok := false;
  1142.                 error(flags,0);
  1143.                 findPrev := BNOTFOUND;
  1144.                 exit
  1145.                 end;
  1146.         while (prev) do
  1147.         if (comparE(K,current) = 0) then begin
  1148.                     ok := true;
  1149.                         findPrev := curNode;
  1150.                         exit
  1151.                         end
  1152.         else if (sorted) then begin
  1153.             curNode := nodes;
  1154.                         ok := false;
  1155.                         findPrev := BNOTFOUND;
  1156.                         exit
  1157.                         end;
  1158.         ok := false;
  1159.         findPrev := BNOTFOUND
  1160. end;
  1161.  
  1162.  
  1163.  
  1164. procedure Binder.sort;
  1165. var i, flags, low, mid, high : word;
  1166.     D : pointer;
  1167. begin
  1168.  
  1169. {
  1170.     The current node is always reset to undefined
  1171.     regardless of the outcome of sort.
  1172. }
  1173.  
  1174.     curNode := nodes;
  1175.     if (sorted) then begin
  1176.         ok := true;
  1177.         exit
  1178.         end;
  1179.     if (nodes = 0) then begin
  1180.         ok := true;
  1181.         sorted := true;
  1182.         exit
  1183.         end;
  1184.     if (linkS = nil) or (@comparE = @BnoComp)
  1185.         then begin
  1186.                 flags := BdrOkay;
  1187.                 if (linkS = nil) then
  1188.                     flags := flags or BdrNoLinks;
  1189.                 if (@comparE = @BnoComp) then
  1190.                     flags := flags or BdrOtherError;
  1191.             ok := false;
  1192.                 error(flags,0);
  1193.                 exit
  1194.                 end;
  1195.     if (first > 0) then begin
  1196.         { form contiguous block at front }
  1197.         i := (first + nodes) mod limit;
  1198.         if (i > first) then
  1199.             move(linkS^[first],linkS^[0],
  1200.                 sizeof(linkS^[0])*nodes)
  1201.         else if (i < first) then
  1202.             move(linkS^[first],linkS^[i],
  1203.                 sizeof(linkS^[0])
  1204.                 *(limit-first));
  1205.         { else array is full/contiguous }
  1206.         first := 0;
  1207.                 end;
  1208.         high := 1;
  1209.         i := 1;
  1210.         while (i < nodes) do begin
  1211.         low := 0;
  1212.         D := linkS^[i];
  1213.         while (low < high) do begin
  1214.             mid := low + ((high - low) shr 1);
  1215.             if (comparE(D,linkS^[mid]) <= 0)
  1216.                 then high := mid
  1217.             else
  1218.                 low := mid + 1
  1219.                         end;
  1220.         if (high < i)  then begin
  1221.             move(linkS^[high],linkS^[high+1],
  1222.                 sizeof(linkS^[0])*(i-high));
  1223.             linkS^[high] := D
  1224.                     end;
  1225.             inc(i);
  1226.                 high := i
  1227.             end;
  1228.         sorted := true;
  1229.         ok := true
  1230. end;
  1231.  
  1232.  
  1233. { Private Binder methods }
  1234.  
  1235. procedure Binder.Dfree(D: pointer);
  1236. begin
  1237.     if D = nil then begin
  1238.             ok := false;
  1239.                 error(BdrNoData,0)
  1240.                 end
  1241.         else begin
  1242.                    dispose(BinderN(D));
  1243.                    ok := true
  1244.         end;
  1245. end;
  1246.  
  1247. procedure Binder.error(flags, info : word);
  1248. begin
  1249.     write('Binder error: ');
  1250.     if ((flags and BdrIndexError) = BdrIndexError) then
  1251.             write('| index invalid ');
  1252.         if ((flags and BdrNoMemory) = BdrNoMemory) then
  1253.             write('| no memory ');
  1254.         if ((flags and BdrNoVacancy) = BdrNoVacancy) then
  1255.             write('| no vacancy ');
  1256.         if ((flags and BdrNoLinks) = BdrNoLinks) then
  1257.             write('| no links ');
  1258.         if ((flags and BdrNoData) = BdrNoData) then
  1259.             write('| no data ');
  1260.         if ((flags and BdrOtherError) = BdrOtherError) then
  1261.             write('| other ');
  1262.         writeln('| info: ',info)
  1263. end;
  1264.  
  1265.  
  1266.  
  1267. {  Copy Binder Methods }
  1268.  
  1269.  
  1270. constructor CopyBinder.Init(dataSize : word);
  1271. begin
  1272.         if not Binder.Init then begin
  1273.             sizeofData := 0;
  1274.                 fail
  1275.                 end;
  1276.         sizeofData := dataSize
  1277. end;
  1278.  
  1279. destructor CopyBinder.Done;
  1280. begin
  1281.     allFree;
  1282.         Binder.Done
  1283. end;
  1284.  
  1285. procedure CopyBinder.atInsC(n : word; D : pointer);
  1286. var cD : pointer;
  1287. begin
  1288.     cD := Dclone(D);
  1289.         if ok then begin
  1290.             atIns(n,cD);
  1291.             if not ok then begin
  1292.                     Dfree(cD);
  1293.                         ok := false
  1294.                         end
  1295.                 end
  1296. end;
  1297.  
  1298. procedure CopyBinder.atFreeC(n : word; D : pointer);
  1299. begin
  1300.         Dcopy(D,atGet(n));
  1301.     if ok then
  1302.                 atFree(n)
  1303. end;
  1304.  
  1305. procedure CopyBinder.atFreePutC(n : word; D : pointer);
  1306. var oldD, cD : pointer;
  1307. begin
  1308.     oldD := atGet(n);
  1309.         if ok then begin
  1310.             cD := Dclone(D);
  1311.                 if ok then begin
  1312.                     atPut(n,cD);
  1313.                         Dfree(oldD)
  1314.                         end
  1315.                 end
  1316. end;
  1317.  
  1318. procedure CopyBinder.atGetC(n : word; D : pointer);
  1319. begin
  1320.         Dcopy(D,atGet(n))
  1321. end;
  1322.  
  1323. procedure CopyBinder.topC(D : pointer);
  1324. begin
  1325.     Dcopy(D,atGet(0))
  1326. end;
  1327.  
  1328. procedure CopyBinder.currentC(D : pointer);
  1329. begin
  1330.         Dcopy(D,atGet(getCurNode))
  1331. end;
  1332.  
  1333. procedure CopyBinder.bottomC(D : pointer);
  1334. begin
  1335.         Dcopy(D,atGet(getNodes-1))
  1336. end;
  1337.  
  1338. procedure CopyBinder.pushC(D : pointer);
  1339. var cD : pointer;
  1340. begin
  1341.     cD := Dclone(D);
  1342.         if ok then begin
  1343.             push(cD);
  1344.                 if not ok then begin
  1345.                     Dfree(cD);
  1346.                         ok := false
  1347.                         end
  1348.                 end
  1349. end;
  1350.  
  1351. procedure CopyBinder.popFreeC(D : pointer);
  1352. begin
  1353.         Dcopy(D,atGet(0));
  1354.         if ok then
  1355.                 atFree(0)
  1356. end;
  1357.  
  1358. procedure CopyBinder.insqC(D : pointer);
  1359. var cD : pointer;
  1360. begin
  1361.     cD := Dclone(D);
  1362.         if ok then begin
  1363.             insq(cD);
  1364.                 if not ok then begin
  1365.                     Dfree(cD);
  1366.                         ok := false
  1367.                         end
  1368.                 end
  1369. end;
  1370.  
  1371. procedure CopyBinder.unqFreeC(D : pointer);
  1372. begin
  1373.         Dcopy(D,bottom);
  1374.         if ok then
  1375.                 unqFree
  1376. end;
  1377.  
  1378. procedure CopyBinder.insC(D : pointer);
  1379. var cD : pointer;
  1380. begin
  1381.     cD := Dclone(D);
  1382.         if ok then begin
  1383.             ins(cD);
  1384.                 if not ok then begin
  1385.                     Dfree(cD);
  1386.                         ok := false
  1387.                         end
  1388.                 end
  1389. end;
  1390.  
  1391. procedure CopyBinder.insSortC(D : pointer);
  1392. var cD : pointer;
  1393. begin
  1394.     cD := Dclone(D);
  1395.         if ok then begin
  1396.             insSort(cD);
  1397.                 if not ok then begin
  1398.                     Dfree(cD);
  1399.                         ok := false
  1400.                         end
  1401.                 end
  1402. end;
  1403.  
  1404. procedure CopyBinder.delFreeC(D : pointer);
  1405. begin
  1406.         Dcopy(D,current);
  1407.         if ok then
  1408.                 delFree
  1409. end;
  1410.  
  1411. function CopyBinder.nextC(D : pointer) : boolean;
  1412. begin
  1413.         if (D = nil) then begin
  1414.                 ok := false;
  1415.                 error(BdrNoData,0)
  1416.                 end
  1417.         else if next then
  1418.                 currentC(D);
  1419.         nextC := ok
  1420. end;
  1421.  
  1422. function CopyBinder.prevC(D : pointer) : boolean;
  1423. begin
  1424.         if (D = nil) then begin
  1425.                 ok := false;
  1426.                 error(BdrNoData,0)
  1427.                 end
  1428.         else if prev then
  1429.             currentC(D);
  1430.         prevC := ok
  1431. end;
  1432.  
  1433.  
  1434. { Private CopyBinder methods }
  1435.  
  1436. procedure CopyBinder.Dfree(D: pointer);
  1437. begin
  1438.     if D = nil then begin
  1439.             ok := false;
  1440.                 error(BdrNoData,0)
  1441.                 end
  1442.         else begin
  1443.             if (sizeofData = 0) then
  1444.                        dispose(BinderN(D))
  1445.                 else
  1446.                     freemem(D,sizeofData);
  1447.                    ok := true
  1448.         end;
  1449. end;
  1450.  
  1451.  
  1452. function CopyBinder.Dclone(D : pointer) : pointer;
  1453. type strPtr = ^string;
  1454. var cD : pointer;
  1455.     len : integer;
  1456. begin
  1457.  
  1458.     if (D = nil) then begin
  1459.             ok := false;
  1460.                 error(BdrNoData,0);
  1461.                 exit
  1462.                 end;
  1463.         if (sizeofData = 0) then
  1464.             len := length(strPtr(D)^) + 1
  1465.         else
  1466.             len := sizeofData;
  1467.            if (MaxAvail < len) then begin
  1468.         ok := false;
  1469.         error(BdrNoMemory,len);
  1470.         exit
  1471.         end;
  1472.     getmem(cD,len);
  1473.     move(D^,cD^,len);
  1474.         ok := true;
  1475.     Dclone := cD
  1476. end;
  1477.  
  1478. procedure CopyBinder.Dcopy(D, S : pointer);
  1479. type strPtr = ^string;
  1480. var len : integer;
  1481. begin
  1482.     if (D = nil) or (S = nil) then begin
  1483.             ok := false;
  1484.                 error(BdrNoData,0);
  1485.                 exit
  1486.                 end;
  1487.     if (sizeofData > 0) then
  1488.         move(S^,D^,sizeofData)
  1489.     else
  1490.         move(S^,D^,length(strPtr(S)^));
  1491.         ok := true
  1492. end;
  1493.  
  1494.  
  1495. constructor BinderNode.Init;
  1496. begin
  1497.     fail
  1498. end;
  1499.  
  1500. destructor BinderNode.Done;
  1501. begin
  1502. end;
  1503.  
  1504.  
  1505. end.