home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / PASTUT34 / TWOLINKS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-01  |  11KB  |  385 lines
  1. {$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,R-,S+,V+,X-}
  2. {$M 4096,0,20000}
  3.  
  4. Program TwoLinks;
  5.  
  6. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  7. { Program to display on the screen the creation of a double-linked    }
  8. { list on the Heap and to show the action as the records of the list  }
  9. { are traversed both forward and backward under the control of the    }
  10. { right and left arrow keys.                                          }
  11. { The functions Seg and Ofs are used to determine the addresses on    }
  12. { Heap of each record of the linked list and these addresses are then }
  13. { displayed as Seg:Ofs for the record and for its fields Previous and }
  14. { Next. The Number field is also displayed.                           }
  15. { The active record is shown in red.                                  }
  16. {                                                                     }
  17. { TWOLINKS.PAS  ->  .EXE      R. Shaw       5.12.92                   }
  18. {_____________________________________________________________________}
  19.  
  20.  
  21. Uses  Crt, Dos, hexa;
  22.  
  23. Type
  24.    PItem = ^ TItem;
  25.    TItem = record
  26.      Previous : PItem;
  27.      Number   : integer;
  28.      Next     : PItem;
  29.    End;
  30.  
  31. Var
  32.    First, Last, This : PItem;
  33.    i, n, interval    : integer;
  34.    FirstSeg, LastSeg, ThisSeg, FirstOfs, LastOfs, ThisOfs : word;
  35.    FirstSegX, LastSegX, FirstOfsX, LastOfsX : string;
  36.    PrevSeg, PrevOfs, NextSeg, NextOfs : word;
  37.    NextSegX, NextOfsX : string;
  38.    ThisSegX, ThisOfsX, PrevSegX, PrevOfsX : Array[1..10] of string;
  39.    Speed, reply : char;
  40.    k,x,y : integer;
  41.    Str : array[0..10] of string;
  42.    Step : boolean;
  43.    HeapTop : ^integer;
  44.    SegHeap, OfsHeap : word;
  45.  
  46. Procedure Instructions;
  47. begin
  48.    TextColor(cyan);
  49.    GoToXY(1,13);
  50.    writeln('    Please press arrow keys <- or -> to move about list or Q to quit');
  51.    writeln('    If at either end, only the inward arrow key is effective.');
  52.    write('    The selected record of the double-linked list is shown in ');
  53.    TextColor(red);
  54.    writeln('red');
  55.    GoToXY(14*n+4,12);
  56. end;          { Proc Instructions }
  57.  
  58.  
  59. Procedure CodeDisplay(k,Colour: integer);
  60. begin
  61.    Case k of
  62.         0 : begin x := 1; y := 13; Str[0] := 'CODE'; end;
  63.         1 : begin x := 5; y := 14; Str[1] := 'New(This);'; end;
  64.         2 : begin x := 5; y := 15;
  65.                   Str[2] := 'If First = Nil then First := This'; end;
  66.         3 : begin x := 40; y := 15;
  67.                   Str[3] := 'else Last^.Next := This;    {old Last}'; end;
  68.         4 : begin x := 5; y := 16; Str[4] := 'This^.Number := i;'; end;
  69.         5 : begin x := 5; y := 17;
  70.                   Str[5] := 'If First = This then This^.Previous := Nil'; end;
  71.         6 : begin x := 49; y := 17;
  72.                   Str[6] := 'else This^.Previous := Last;'; end;
  73.         7 : begin x := 5; y := 18; Str[7] := 'Last := This;      {new Last}'; end;
  74.         8 : begin x := 5; y := 19; Str[8] := 'Last^.Next := Nil;'; end;
  75.    end;
  76.    TextColor(Colour);
  77.    GoToXY(x,y);
  78.    writeln(Str[k]);
  79. end;        { Proc CodeDisplay }
  80.  
  81.  
  82. Procedure CreateList;
  83.  
  84. begin
  85.    TextColor(yellow);
  86.    GoToXY(1,3);
  87.    write('Pointer');
  88.    GoToXY(1,5);
  89.    write('Record');
  90.    GoToXY(1,6);
  91.    write('Address');
  92.    GoToXY(1,8);
  93.    write('Record fields');
  94.    GoToXY(1,9);
  95.    write('Previous');
  96.    GoToXY(1,10);
  97.    write('Number');
  98.    GoToXY(1,11);
  99.    write('Next');
  100.    If Step then
  101.       begin
  102.          TextColor(cyan);
  103.          GoToXY(5,24);
  104.          write('Please press the spacebar to continue to next statement. ');
  105.       end
  106.    else
  107.       begin
  108.         TextColor(cyan);
  109.         GoToXY(5,24);
  110.         write('Successive statements are executed and displayed automatically. ');
  111.       end;
  112.    TextColor(Yellow);
  113.    for i := 1 to n do
  114.    begin
  115.       New(This);
  116.       GoToXY(14*i,3);
  117.       write('This');
  118.       ThisSeg := Seg(This^);
  119.       ThisOfs := Ofs(This^);
  120.       ThisSegX[i] := IntToHex(ThisSeg);
  121.       ThisOfsX[i] := IntToHex(ThisOfs);
  122.       CodeDisplay(1,white);
  123.       If i = n then TextColor(Red) else TextColor(white);
  124.       GoToXY(14*i,6);
  125.       write(ThisSegX[i],':',ThisOfsX[i]);
  126.       If Step then reply := readkey else delay(interval);
  127.       CodeDisplay(1,yellow);
  128.  
  129.       If First = Nil then
  130.          begin
  131.             First := This;
  132.             GoToXY(14*i,3);
  133.             write('First');
  134.             CodeDisplay(2,white);
  135.          end
  136.       else
  137.          begin
  138.             Last^.Next := This;
  139.             CodeDisplay(3,white);
  140.             TextColor(white);
  141.             GoToXY(14*(i-1),11);
  142.             write(ThisSegX[i],':',ThisOfsX[i]);
  143.          end;
  144.       If Step then reply := readkey else delay(interval);
  145.       CodeDisplay(2,yellow);
  146.       CodeDisplay(3,yellow);
  147.  
  148.       This^.Number := i;
  149.       CodeDisplay(4,white);
  150.       If i = n then TextColor(red) else TextColor(white);
  151.       GoToXY(14*i,10);
  152.       write(This^.Number);
  153.       If Step then reply := readkey else delay(interval);
  154.       CodeDisplay(4,yellow);
  155.  
  156.       If First = This then
  157.           begin
  158.              This^.Previous := Nil;
  159.              CodeDisplay(5,white);
  160.           end
  161.       else
  162.           begin
  163.              This^.Previous := Last;
  164.              CodeDisplay(6,white);
  165.           end;
  166.       PrevSeg := Seg(This^.Previous^);
  167.       PrevOfs := Ofs(This^.Previous^);
  168.       PrevSegX[i] := IntToHex(PrevSeg);
  169.       PrevOfsX[i] := IntToHex(PrevOfs);
  170.       If i = n then TextColor(red) else TextColor(white);
  171.       GoToXY(14*i,9);
  172.       write(PrevSegX[i],':',PrevOfsX[i]);
  173.       If Step then reply := readkey else delay(interval);
  174.       CodeDisplay(5,yellow);
  175.       CodeDisplay(6,yellow);
  176.  
  177.       Last := This;
  178.       GoToXY(14*i,3);
  179.       If i = 1 then write('First/Last') else write('Last');
  180.       If i > 1 then
  181.          begin
  182.             GoToXY(14*(i-1),3);
  183.             If i = 2 then write('First     ') else write('    ');
  184.          end;
  185.       CodeDisplay(7,white);
  186.       If Step then reply := readkey else delay(interval);
  187.       CodeDisplay(7,yellow);
  188.  
  189.       Last^.Next := Nil;
  190.       CodeDisplay(8,white);
  191.       If i = n then TextColor(red) else TextColor(white);
  192.       GoToXY(14*i,11);
  193.       write('0000:0000');
  194.       If Step then reply := readkey else delay(interval);
  195.       CodeDisplay(8,yellow);
  196.    end;
  197. end;    { Proc CreateList }
  198.  
  199. Procedure Change(j, colour : integer);
  200. begin
  201.    TextColor(Colour);
  202.    GoToXY(14*j,9);
  203.    write(PrevSegX[j],':',PrevOfsX[j]);
  204.    GoToXY(14*j,10);
  205.    write(i);
  206.    GoToXY(14*j,6);
  207.    write(ThisSegX[j],':',ThisOfsX[j]);
  208.       If (j > 0) and (j < n) then
  209.          begin
  210.            GoToXY(14*j,11);
  211.            write(ThisSegX[j+1],':',ThisOfsX[j+1]);
  212.          end;
  213.       If j = n then
  214.          begin
  215.            GoToXY(14*j,11);
  216.            write('0000:0000');
  217.          end;
  218. end;          { Proc Change }
  219.  
  220. Procedure Advance(i, colour : integer);
  221.  
  222. Var
  223.    j :integer;
  224.  
  225. begin
  226.    TextColor(Colour);
  227.    If colour = 0 then i := i - 1;
  228.    GoToXY(14*i+9,11);
  229.    write('──┘');
  230.    For j := 10 downto 7 do
  231.       begin
  232.          GoToXY(14*i+11,j);
  233.          write('│');
  234.       end;
  235.    GoToXY(14*i+11,6);
  236.    write('┌─>');
  237.    If i <> n then i := i + 1;
  238.    GoToXY(14*i-1,12);
  239.    write('Please Wait');
  240.    If Colour <> 0 then delay(1000);
  241.    TextColor(cyan);
  242.    GoToXY(70,13);
  243. end;          { Proc Advance }
  244.  
  245. Procedure Retreat(i, colour : integer);
  246.  
  247. Var
  248.    j :integer;
  249.  
  250. begin
  251.    TextColor(colour);
  252.    If colour = 0 then i := i + 1;
  253.    GoToXY(14*i-3,9);
  254.    write('└──');
  255.    For j := 8 downto 7 do
  256.       begin
  257.          GoToXY(14*i-3,j);
  258.          write('│');
  259.       end;
  260.    GoToXY(14*i-5,6);
  261.    write('<─┐');
  262.    GoToXY(14*(i-1)-1,12);
  263.    write('Please Wait');
  264.    If Colour <> 0 then delay(1000);
  265.    TextColor(cyan);
  266.    GoToXY(70,13);
  267. end;          { Proc Retreat }
  268.  
  269.  
  270. Procedure ArrowKey;
  271.  
  272. var
  273.    Key  : char;
  274.    EKey : boolean;
  275.  
  276. begin
  277.  interval := 500;
  278.  repeat
  279.     repeat
  280.       Ekey := False;
  281.       Key  := Readkey;
  282.       if UpCase(Key) = 'Q' then exit;
  283.       if Key = #0 then
  284.         begin
  285.           Ekey := True;
  286.           Key  := Readkey;
  287.           if (Key = #75) and (i > 1) then
  288.              begin
  289.                 Retreat(i,red);
  290.                 delay(interval);
  291.                 Change(i, white);
  292.                 dec(i);
  293.                 Change(i, red);
  294.                 Retreat(i,black);
  295.              end;
  296.           if (Key = #77) and (i < 5) then
  297.              begin
  298.                 Advance(i,red);
  299.                 delay(interval);
  300.                 Change(i, white);
  301.                 inc(i);
  302.                 Change(i, red);
  303.                 Advance(i,black);
  304.              end;
  305.         end;
  306.     until (EKey = True) and ((Key = #75) or (Key = #77));
  307.   until UpCase(Key) = 'Q';
  308. end;             { Proc ArrowKey }
  309.  
  310. Procedure DosDebug;
  311.  
  312. Function DebugPath : Pathstr;
  313.  
  314. var
  315.   DPath : PathStr;
  316.  
  317. begin
  318.   DPath := '';
  319.   DPath := FSearch('DEBUG.EXE', GetEnv('PATH'));
  320.   If DPath = '' then DPath := FSearch('DEBUG.COM', GetEnv('PATH'));
  321.   If DPath = '' then
  322.      begin
  323.         writeln('DEBUG file not found. Please check your DOS system.');
  324.         writeln;
  325.         writeln('Press any key to continue: ');
  326.         repeat until keypressed;
  327.      end;
  328.   DebugPath := DPath;
  329. end;      {of Function DebugPath}
  330.  
  331.  
  332. begin
  333.   TextColor(LightGray);
  334.   SwapVectors;
  335.   Exec(DebugPath,'');
  336.   If DosError <> 0 then writeln('Dos error # ',DosError);
  337.   SwapVectors;
  338. end;         { Proc DosDebug }
  339.  
  340. {Main}
  341.  
  342. begin
  343.    ClrScr;
  344.    Mark(HeapTop);
  345.    SegHeap := Seg(HeapTop^);
  346.    OfsHeap := Ofs(HeapTop^);
  347.    For i := OfsHeap to (OfsHeap + 1000) do Mem[SegHeap:i] := 0;
  348.    Step := False;
  349.    TextColor(LightGray);
  350.    write('Please specify speed of display as Slow[S] or Fast[F] or Key Step[K]: ');
  351.    Speed := readkey;
  352.    ClrScr;
  353.    TextColor(cyan);
  354.    write('THE CREATION OF A DOUBLE-LINKED LIST AND MOVEMENT FROM RECORD TO RECORD.');
  355.    Case UpCase(Speed) of
  356.       'S' : interval := 4000;
  357.       'F' : interval := 1000;
  358.       'K' : step := true;
  359.       else interval := 0;
  360.    end;
  361.    CodeDisplay(0,cyan);
  362.    For k := 1 to 8 do CodeDisplay(k, yellow);
  363.    n := 5;
  364.    CreateList;
  365.    Window(1,12,80,25);
  366.    ClrScr;
  367.    Window(1,1,80,25);
  368.    Instructions;
  369.    GoToXY(70,13);
  370.    ArrowKey;
  371.    Window(1,13,80,25);
  372.    ClrScr;
  373.    TextColor(cyan);
  374.    GoToXY(1,1);
  375.    writeln('Please wait for DOS Debug prompt (-) and then type d followed by a space and');
  376.    writeln('then the address of the first record, as shown above, and then press ENTER.');
  377.    writeln('After studying the contents of memory, press Q followed by ENTER to quit.');
  378.    TextColor(lightGray);
  379.    write(' ');
  380.    Window(1,16,80,25);
  381.    ClrScr;
  382.    DosDebug;
  383. end.
  384.      
  385.