home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Pascal / Source□ / DeHQX-200-Source / MyLists.unit < prev    next >
Encoding:
Text File  |  1991-08-23  |  9.0 KB  |  359 lines  |  [TEXT/PJMM]
  1. unit MyLists;
  2. { DeHQX v2.0.0 © Peter Lewis, Aug 1991 }
  3.  
  4. interface
  5.  
  6. { Some types have been changed to avoid clashing with the list manager }
  7.     type
  8.         listHead = ^listItemPtr;            { Use to be listHeadHandle }
  9.         listItem = ^listItemPtr;            { Use to be listHandle }
  10.         listItemPtr = ^listNode;            { Use to be listPtr }
  11.         listNode = record
  12.                 head: boolean;
  13.                 next: listItem;
  14.                 prev: listItem;
  15.                 this: handle;
  16.             end;
  17.  
  18.     var
  19.         listError: boolean;
  20.  
  21.     procedure CreateList (var l: listHead);
  22.     procedure DestroyList (var l: listHead; dispose: boolean);
  23.  
  24.     procedure ReturnHead (lh: listHead; var l: listItem);
  25.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  26.     procedure ReturnTail (lh: listHead; var l: listItem);
  27.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  28.  
  29.     procedure MoveToHead (var l: listItem);
  30.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  31.     procedure MoveToTail (var l: listItem);
  32.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  33.     procedure MoveToNext (var l: listItem);
  34.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  35.     procedure MoveToPrev (var l: listItem);
  36.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  37.  
  38.     procedure AddHead (l: listHead; it: univ handle);
  39.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  40.     procedure AddTail (l: listHead; it: univ handle);
  41.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  42.     procedure AddBefore (l: listItem; it: univ handle);
  43.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  44.     procedure AddAfter (l: listItem; it: univ handle);
  45.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  46.  
  47.     procedure DeleteHead (l: listHead; var it: univ handle);
  48.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  49.     procedure DeleteTail (l: listHead; var it: univ handle);
  50.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  51.     procedure DeletePrev (l: listItem; var it: univ handle);
  52.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  53.     procedure DeleteNext (l: listItem; var it: univ handle);
  54.     (* <a> c / a <b> / error / error / error / error / error *)
  55.     procedure DeleteItem (var l: listItem; var it: univ handle);
  56.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  57.  
  58.     procedure FetchHead (l: listHead; var it: univ handle);
  59.     (* a / a / a / a / a / a / error  *)
  60.     procedure FetchTail (l: listHead; var it: univ handle);
  61.     (* c / c / c / c / a / a / error  *)
  62.     procedure FetchNext (l: listItem; var it: univ handle);
  63.     (* b / c / error / error / error / error / error *)
  64.     procedure FetchPrev (l: listItem; var it: univ handle);
  65.     (* error / a / b / c / error / a / error *)
  66.     procedure Fetch (l: listItem; var it: univ handle);
  67.     (* a / b / c / error / a / error / error *)
  68.  
  69.     function IsHead (l: listItem): boolean;
  70.     (* T / F / F / F / T / F / T *)
  71.     function IsTail (l: listItem): boolean;
  72.     (* F / F / F / T / F / T / T *)
  73.     function IsEmpty (l: listHead): boolean;
  74.     (* F / F / F / F / F / F / T *)
  75.  
  76.     procedure DisplayList (lh: listHead);
  77.    (* To the Text Screen *)
  78.  
  79. implementation
  80.  
  81. { Internal Routines }
  82.  
  83.     procedure DestroyListHandle (var l: univ listItem);
  84.     begin
  85. {    l^^.next := nil;                These dont do any good }
  86. {    l ^ ^ . prev := nil;            cause DisposHandle }
  87. {    l  ^ ^ . this := nil;            destroys the data }
  88.         DisposHandle(handle(l));
  89.         l := nil;
  90.     end;
  91.  
  92.     procedure CreateListHandle (var l: univ listItem);
  93.     begin
  94.         l := listItem(NewHandle(SizeOf(listNode)));
  95.     end;
  96.  
  97.     procedure MoveToStart (var l: univ listItem);
  98.         var
  99.             tmp: listItem;
  100.     begin
  101.         if not l^^.head then begin
  102.             tmp := l;
  103.             repeat
  104.                 l := l^^.next;
  105.             until (tmp = l) or l^^.head;
  106.             if tmp = l then
  107.                 listError := true;
  108.         end;
  109.     end;
  110.  
  111.     procedure InsertBefore (l: univ listItem; var it: univ handle);
  112.         var
  113.             tmp: listItem;
  114.     begin
  115.         CreateListHandle(tmp);
  116.         tmp^^.head := false;
  117.         tmp^^.this := it;
  118.         tmp^^.next := l;
  119.         tmp^^.prev := l^^.prev;
  120.         l^^.prev^^.next := tmp;
  121.         l^^.prev := tmp;
  122.     end;
  123.  
  124.     procedure DeleteNode (l: listItem; var it: univ handle);
  125.     begin
  126.         if l^^.head then
  127.             listError := true
  128.         else begin
  129.             it := l^^.this;
  130.             l^^.prev^^.next := l^^.next;
  131.             l^^.next^^.prev := l^^.prev;
  132.             DestroyListHandle(l);
  133.         end;
  134.     end;
  135.  
  136.     procedure FetchNode (l: listItem; var it: univ handle);
  137.     begin
  138.         if l^^.head then
  139.             listError := true;
  140.         it := l^^.this;
  141.     end;
  142.  
  143. { External Routines }
  144.  
  145.     procedure CreateList (var l: listHead);
  146.     begin
  147.         CreateListHandle(l);
  148.         l^^.head := true;
  149.         l^^.next := listItem(l);
  150.         l^^.prev := listItem(l);
  151.         l^^.this := nil;
  152.     end;
  153.  
  154.     procedure DestroyList (var l: listHead; dispose: boolean);
  155.         var
  156.             tmp, tmp2: listItem;
  157.     begin
  158.         tmp := l^^.next;
  159.         while tmp <> listItem(l) do begin
  160.             tmp2 := tmp;
  161.             tmp := tmp^^.next;
  162.             if dispose then
  163.                 DisposHandle(tmp2^^.this);
  164.             DestroyListHandle(tmp2);
  165.         end;
  166.         if dispose then
  167.             DisposHandle(l^^.this);
  168.         DestroyListHandle(l);
  169.     end;
  170.  
  171.     procedure ReturnHead (lh: listHead; var l: listItem);
  172.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  173.     begin
  174.         l := lh^^.next;
  175.     end;
  176.  
  177.     procedure ReturnTail (lh: listHead; var l: listItem);
  178.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  179.     begin
  180.         l := listItem(lh);
  181.     end;
  182.  
  183.     procedure MoveToHead (var l: listItem);
  184.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  185.     begin
  186.         MoveToStart(l);
  187.         l := l^^.next;
  188.     end;
  189.  
  190.     procedure MoveToTail (var l: listItem);
  191.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  192.     begin
  193.         MoveToStart(l);
  194.     end;
  195.  
  196.     procedure MoveToNext (var l: listItem);
  197.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  198.     begin
  199.         if l^^.head then
  200.             listError := true
  201.         else
  202.             l := l^^.next;
  203.     end;
  204.  
  205.     procedure MoveToPrev (var l: listItem);
  206.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  207.     begin
  208.         if l^^.prev^^.head then
  209.             listError := true
  210.         else
  211.             l := l^^.prev;
  212.     end;
  213.  
  214.     procedure AddHead (l: listHead; it: univ handle);
  215.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  216.     begin
  217.         InsertBefore(l^^.next, it);
  218.     end;
  219.  
  220.     procedure AddTail (l: listHead; it: univ handle);
  221.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  222.     begin
  223.         InsertBefore(l, it);
  224.     end;
  225.  
  226.     procedure AddBefore (l: listItem; it: univ handle);
  227.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  228.     begin
  229.         InsertBefore(l, it);
  230.     end;
  231.  
  232.     procedure AddAfter (l: listItem; it: univ handle);
  233.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  234.     begin
  235.         if l^^.head then
  236.             listError := true
  237.         else
  238.             InsertBefore(l^^.next, it);
  239.     end;
  240.  
  241.     procedure DeleteHead (l: listHead; var it: univ handle);
  242.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  243.     begin
  244.         DeleteNode(l^^.next, it);
  245.     end;
  246.  
  247.     procedure DeleteTail (l: listHead; var it: univ handle);
  248.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  249.     begin
  250.         DeleteNode(l^^.prev, it);
  251.     end;
  252.  
  253.     procedure DeletePrev (l: listItem; var it: univ handle);
  254.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  255.         var
  256.             tmp: listItem;
  257.     begin
  258.         DeleteNode(l^^.prev, it);
  259.     end;
  260.  
  261.     procedure DeleteNext (l: listItem; var it: univ handle);
  262.     (* <a> c / a <b> / error / error / error / error / error *)
  263.     begin
  264.         if l^^.head then begin
  265.             listError := true;
  266.             it := nil;
  267.         end
  268.         else
  269.             DeleteNode(l^^.next, it);
  270.     end;
  271.  
  272.     procedure DeleteItem (var l: listItem; var it: univ handle);
  273.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  274.         var
  275.             tmp: listItem;
  276.     begin
  277.         if l^^.head then begin
  278.             listError := true;
  279.             it := nil;
  280.         end
  281.         else begin
  282.             tmp := l^^.next;
  283.             DeleteNode(l, it);
  284.             l := tmp;
  285.         end;
  286.     end;
  287.  
  288.     procedure FetchHead (l: listHead; var it: univ handle);
  289.     (* a / a / a / a / a / a / error  *)
  290.     begin
  291.         FetchNode(l^^.next, it);
  292.     end;
  293.  
  294.     procedure FetchTail (l: listHead; var it: univ handle);
  295.     (* c / c / c / c / a / a / error  *)
  296.     begin
  297.         FetchNode(l^^.prev, it);
  298.     end;
  299.  
  300.     procedure FetchNext (l: listItem; var it: univ handle);
  301.     (* b / c / error / error / error / error / error *)
  302.     begin
  303.         if l^^.head then begin
  304.             listError := true;
  305.             it := nil;
  306.         end
  307.         else
  308.             FetchNode(l^^.next, it);
  309.     end;
  310.  
  311.     procedure FetchPrev (l: listItem; var it: univ handle);
  312.     (* error / a / b / c / error / a / error *)
  313.     begin
  314.         FetchNode(l^^.prev, it);
  315.     end;
  316.  
  317.     procedure Fetch (l: listItem; var it: univ handle);
  318.     (* a / b / c / error / a / error / error *)
  319.     begin
  320.         FetchNode(l, it);
  321.     end;
  322.  
  323.     function IsHead (l: listItem): boolean;
  324.     (* T / F / F / F / T / F / T *)
  325.     begin
  326.         IsHead := l^^.prev^^.head;
  327.     end;
  328.  
  329.     function IsTail (l: listItem): boolean;
  330.     (* F / F / F / T / F / T / T *)
  331.     begin
  332.         IsTail := l^^.head;
  333.     end;
  334.  
  335.     function IsEmpty (l: listHead): boolean;
  336.     (* F / F / F / F / F / F / T *)
  337.     begin
  338.         IsEmpty := l^^.next = listItem(l);
  339.     end;
  340.  
  341.     procedure DisplayList (lh: listHead);
  342.         var
  343.             l: listItem;
  344.             h: longInt;
  345.     begin
  346.         ShowText;
  347.         ReturnHead(lh, l);
  348.         write('(');
  349.         while not IsTail(l) do begin
  350.             Fetch(l, h);
  351.             MoveToNext(l);
  352.             write(h : 1);
  353.             if not IsTail(l) then
  354.                 write(',');
  355.         end;
  356.         writeln('  )');
  357.     end;
  358.  
  359. end.