home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / HEAP2SCR.ZIP / XHEAP2SC.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  14.0 KB  |  398 lines
  1.   {               --- January 4, 1986 ---
  2.  
  3.       DEMONSTRATION OF PROCEDURE HEAP2SCR, which will
  4.       be part of a future release of Boosters.
  5.       Boosters is a collection of assembler-based
  6.       programmer's utilities for Turbo Pascal, some
  7.       of which are used in this demo.
  8.  
  9.       As freeware, Boosters can be found on various
  10.       BBSs or ordered as follows:
  11.  
  12.       $25 - includes all source, many demos, 52-page users
  13.             guide text file.
  14.       $35 - all of the above, plus printed users guide.
  15.  
  16.       Send remittance to:  George F. Smith
  17.                            609 Candlewick Lane
  18.                            Lilburn, GA 30247
  19.                            (404) 923-6879
  20. }
  21.  
  22. Type
  23.    AnyString   =  string[255];
  24.    HeapBuf     = ^AnyBuf;
  25.    AnyBuf      =  Record
  26.                      Screen : array[1..4000] of byte;
  27.                   end;
  28.    ColumnType  =  1..80;      { With $R directive active, }
  29.    RowType     =  1..25;      { keeps video routines in line }
  30.  
  31. Var
  32.  
  33.    I                          { the ubiquitous index variable  }
  34.                      : Integer;
  35.  
  36.    Xheap             : ColumnType;
  37.    Yheap             : RowType;
  38.    HeapTop           : ^Integer;  { for marking current top of heap }
  39.  
  40.    Ch                         { as in read(Kbd,ch) after KeyPressed }
  41.                      : Char;
  42.  
  43.    page                       { screens for SaveScreen, RestoreScreen,
  44.                                 and MoveBg }
  45.                      : array[1..2] of HeapBuf;
  46.  
  47.    S                          { general string array }
  48.                      : AnyString;
  49.  
  50.    Dflag             : array[1..5] of boolean;
  51.  
  52.  
  53.  
  54. Const
  55.    H  = 'H';                  { Code for horizontal PutStr & GetStr }
  56.    V  = 'V';                  { "    "   vertical   "      " "      }
  57.    StartElapsed : Boolean = FALSE;
  58.                               { Initial value for etime function    }
  59.  
  60.  
  61. { ---------------
  62.   CENTER a string
  63.   --------------- }
  64.  
  65. Function CENTER ( A : AnyString;
  66.                   N : Integer;
  67.                   Pad : Char )  : AnyString;
  68.                   { AnyString is type String[255] }
  69.  
  70. begin
  71.    InLine ($1E/ $8D/$9E/$08/$01/ $8B/$46/$06/ $36/$88/$07/ $43/
  72.            $8A/$4E/$08/ $30/$ED/ $29/$C8/ $77/$05/ $31/$C0/ $EB/$12/$90/
  73.            $D1/$E8/ $50/ $8B/$FB/ $8B/$46/$04/ $8B/$4E/$06/ $16/ $07/
  74.            $FC/ $F3/$AA/ $58/ $01/$C3/ $8B/$FB/ $8D/$76/$09/ $16/ $1F/
  75.            $8A/$4E/$08/ $30/$ED/ $FC/ $F3/$A4/ $1F);
  76. end { Center };
  77.  
  78. { ---------------------------------------------------
  79.   PUTSTR  - Write a string directly to display memory
  80.   --------------------------------------------------- }
  81.  
  82. Procedure PutStr ( HV : Char;
  83.                     S : AnyString;
  84.                     X : ColumnType;
  85.                     Y : RowType;
  86.                   Att : Byte );
  87.  
  88. begin
  89.    InLine ($1E/ $BB/$49/$04/ $31/$C0/ $8E/$D8/ $8A/$07/ $3C/$07/ $75/$06/
  90.            $BA/$00/$B0/ $EB/$0C/$90/ $BA/$DA/$03/ $EC/ $24/$08/ $74/$FB/ 
  91.            $BA/$00/$B8/ $8E/$C2/ $8B/$5E/$08/ $09/$DB/ $74/$0C/ $4B/
  92.            $8B/$46/$06/ $48/ $8A/$F0/ $8A/$D3/ $EB/$05/$90/ $B4/$03/
  93.            $CD/$10/ $8A/$DE/ $30/$FF/ $8B/$C3/ $B1/$07/ $D3/$E0/ $B1/$05/
  94.            $D3/$E3/ $01/$C3/ $8A/$C2/ $30/$E4/ $D1/$E0/ $01/$C3/ $8B/$FB/
  95.            $8A/$4E/$0A/ $30/$ED/ $8D/$76/$0B/ $16/ $1F/ $8A/$66/$04/
  96.            $8B/$96/$0A/$01/ $80/$FA/$76/ $74/$0A/ $80/$FA/$56/ $74/$05/
  97.            $31/$D2/ $EB/$04/$90/ $BA/$9E/$00/ $FC/ $8A/$04/ $AB/ $01/$D7/
  98.            $46/ $E2/$F8/ $09/$D2/ $74/$04/ $81/$EF/$9E/$00/ $8B/$C7/
  99.            $31/$D2/ $BB/$A0/$00/ $F7/$F3/ $D0/$EA/ $8A/$F0/ $B4/$02/
  100.            $CD/$10/ $1F/$5D);
  101. end { PutStr };
  102.  
  103. { -------------------------------------------------
  104.   PUTHEAP  - Write a string to Page [n] of the heap
  105.   ------------------------------------------------- }
  106.  
  107. Procedure PutHeap ( PAGE : HeapBuf;
  108.                       HV : Char;
  109.                        S : AnyString;
  110.                        X : ColumnType;
  111.                        Y : RowType;
  112.                      Att : Byte );
  113.                      external 'PutHeap.com';
  114.  
  115. { -------------------------------
  116.   COPIES characters into a string
  117.   ------------------------------- }
  118. Function COPIES (C : Char;
  119.                  N : Integer ): AnyString;
  120.                 { AnyString is Type string[255] }
  121. begin
  122.    InLine ($16/ $07/ $8B/$4E/$04/ $88/$4E/$08/ $8B/$46/$06/ $8D/$7E/$09/
  123.            $FC/ $F3/$AA );
  124. end { Copies };
  125.  
  126. {$IBoxul}
  127. {$IBoxHeap}
  128.  
  129. { -----------------------------------
  130.   SAVESCREEN saves the current screen
  131.   ----------------------------------- }
  132. Procedure SaveScreen ( Page : HeapBuf);
  133.    external 'Saves.com';
  134.  
  135. { -------------------------------------
  136.   RESTORESCREEN restores a saved screen
  137.   ------------------------------------- }
  138. Procedure RestoreScreen ( Page : HeapBuf);
  139.    external 'Restores.com';
  140.  
  141. { --------
  142.   HEAP2SCR:
  143.   --------
  144.   Copies the block defined by (X1,Y1) and (X2,Y2) on a page of
  145.   heap memory to the video display beginning at (X3,Y3).
  146.   Unlike RestoreScreen, Heap2Scr copies only the block defined
  147.   by its upper-left and lower-right coordinates. }
  148.  
  149. Procedure Heap2Scr ( Page : HeapBuf;
  150.                      X1   : ColumnType;
  151.                      Y1   : RowType;
  152.                      X2   : ColumnType;
  153.                      Y2   : RowType;
  154.                      X3   : ColumnType;
  155.                      Y3   : RowType
  156.                                         ); external 'B:\Heap2scr.com';
  157.  
  158.  
  159.  
  160. Procedure ClearFlags;
  161. begin
  162.    for i := 1 to 5 do
  163.       dflag[i] := false;
  164. end; { ClearFlags }
  165.  
  166. BEGIN
  167.  
  168.    Mark ( HeapTop );
  169.    New ( Page[1] );
  170.    New ( Page[2] );
  171.    ClrScr;
  172.    SaveScreen ( page[1] );
  173.    SaveScreen ( page[2] );
  174.  
  175.    PutHeap ( Page[1], h, 'A', 40, 1, 11 );
  176.    PutHeap ( Page[1], h, Center (#17+'  B O O S T E R S  '+#16,80,' '),
  177.              1, 2, 11 );
  178.    PutHeap ( Page[1], h, Center('H E A P 2 S C R    D E M O',80,' '),
  179.              1,3, 11 );
  180.    BoxHeap ( Page[1], 1, 4, 80, 6, 3, 14 );
  181.    for i := 1 to 4 do
  182.    begin
  183.       PutHeap ( Page[1], h, #210, 16 * i, 4, 14 );
  184.       PutHeap ( Page[1], h, #186, 16 * i, 5, 14 );
  185.       PutHeap ( Page[1], h, #208, 16 * i, 6, 14 );
  186.    end;
  187.  
  188.    PutHeap ( Page[1], h, Center ( 'NORTHEAST',14,' '), 2, 5, 11 );
  189.    PutHeap ( Page[1], h, Center ( 'SOUTHEAST',14,' '),17, 5, 11 );
  190.    PutHeap ( Page[1], h, Center ( 'MIDWEST',  14,' '),33, 5, 11 );
  191.    PutHeap ( Page[1], h, Center ( 'NORTHWEST',14,' '),49, 5, 11 );
  192.    PutHeap ( Page[1], h, Center ( 'SOUTHWEST',14,' '),65, 5, 11 );
  193.  
  194.    BoxHeap ( Page[1], 20, 18, 60, 24, 1, 11 );
  195.    PutHeap ( Page[1], h, Center('PROCEDURE HEAP2SCR (1/4/86)',39,' '),
  196.              21, 19, 11 );
  197.    PutHeap ( Page[1], h, Center('A Turbo Pascal external .com routine',39,' '),
  198.              21, 20, 11 );
  199.    PutHeap ( Page[1], h, Center('that copies blocks from the heap to ',39,' '),
  200.              21, 21, 11 );
  201.    PutHeap ( Page[1], h, Center('the screen--see README.H2S.         ',39,' '),
  202.              21, 22, 11 );
  203.    PutHeap ( Page[1], h, Center('Arrow, tab keys for menus--Q quits. ',39,' '),
  204.              21, 23, 11 );
  205.    RestoreScreen ( Page[1] );
  206.  
  207. { ------------  NORTHEAST CITIES  ------------ }
  208.    Boxheap ( Page[2], 1, 1, 16, 10, 3, 14 );
  209.    PutHeap ( Page[2], h, #199,   1, 1, 14 );
  210.    PutHeap ( Page[2], h, #215,  16, 1, 14 );
  211.    PutHeap ( Page[2], h, #175+' BANGOR',     3, 3, 11 );
  212.    PutHeap ( Page[2], h, #175+' PAWTUCKET',  3, 4, 11 );
  213.    PutHeap ( Page[2], h, #175+' HOLYOKE',    3, 5, 11 );
  214.    PutHeap ( Page[2], h, #175+' CONCORD',    3, 6, 11 );
  215.    PutHeap ( Page[2], h, #175+' RIDGEFIELD', 3, 7, 11 );
  216.    PutHeap ( Page[2], h, #175+' HERSHEY',    3, 8, 11 );
  217.  
  218. { -----------  SOUTHEAST CITIES  ----------- }
  219.    Boxheap ( Page[2],20, 1, 36, 10, 3, 14 );
  220.    PutHeap ( Page[2], h, #215,  20, 1, 14 );
  221.    PutHeap ( Page[2], h, #215,  36, 1, 14 );
  222.    PutHeap ( Page[2], h, #175+' CHARLOTTE', 22, 3, 11 );
  223.    PutHeap ( Page[2], h, #175+' SHENANDOAH',22, 4, 11 );
  224.    PutHeap ( Page[2], h, #175+' ELLIJAY',   22, 5, 11 );
  225.    PutHeap ( Page[2], h, #175+' TUSCALOOSA',22, 6, 11 );
  226.    PutHeap ( Page[2], h, #175+' KINGSPORT', 22, 7, 11 );
  227.    PutHeap ( Page[2], h, #175+' TUPELO',    22, 8, 11 );
  228.  
  229.  
  230. { -----------  MIDWEST CITIES  ------------- }
  231.    Boxheap ( Page[2],40, 1, 56, 10, 3, 14 );
  232.    PutHeap ( Page[2], h, #215,  40, 1, 14 );
  233.    PutHeap ( Page[2], h, #215,  56, 1, 14 );
  234.    PutHeap ( Page[2], h, #175+' SAGINAW',   42, 3, 11 );
  235.    PutHeap ( Page[2], h, #175+' DUBUQUE',   42, 4, 11 );
  236.    PutHeap ( Page[2], h, #175+' PEORIA',    42, 5, 11 );
  237.    PutHeap ( Page[2], h, #175+' MANKATO',   42, 6, 11 );
  238.    PutHeap ( Page[2], h, #175+' DODGE CITY',42, 7, 11 );
  239.    PutHeap ( Page[2], h, #175+' JOPLIN',    42, 8, 11 );
  240.  
  241. { -----------  NORTHWEST CITIES  ------------ }
  242.    Boxheap ( Page[2],20,12, 36, 21, 3, 14 );
  243.    PutHeap ( Page[2], h, #215,  20,12, 14 );
  244.    PutHeap ( Page[2], h, #215,  36,12, 14 );
  245.    PutHeap ( Page[2], h, #175+' LARAMIE',   22,14, 11 );
  246.    PutHeap ( Page[2], h, #175+' HELENA',    22,15, 11 );
  247.    PutHeap ( Page[2], h, #175+' YAKIMA',    22,16, 11 );
  248.    PutHeap ( Page[2], h, #175+' EUGENE',    22,17, 11 );
  249.    PutHeap ( Page[2], h, #175+' FARGO',     22,18, 11 );
  250.    PutHeap ( Page[2], h, #175+' DUBOIS',    22,19, 11 );
  251.  
  252. { ------------ SOUTHWEST CITIES  ------------ }
  253.    Boxheap ( Page[2], 1,12, 17, 21, 3, 14 );
  254.    PutHeap ( Page[2], h, #215,   1,12, 14 );
  255.    PutHeap ( Page[2], h, #182,  17,12, 14 );
  256.    PutHeap ( Page[2], h, #175+' TUCUMCARI',  3,14, 11 );
  257.    PutHeap ( Page[2], h, #175+' FLAGSTAFF',  3,15, 11 );
  258.    PutHeap ( Page[2], h, #175+' LUBBOCK',    3,16, 11 );
  259.    PutHeap ( Page[2], h, #175+' MUSKOGEE',   3,17, 11 );
  260.    PutHeap ( Page[2], h, #175+' DURANGO',    3,18, 11 );
  261.    PutHeap ( Page[2], h, #175+' PROVO',      3,19, 11 );
  262.  
  263.  
  264.    ClearFlags;
  265.    GoToXY(1,5);
  266.    repeat
  267.       read(Kbd,ch);
  268.       if (ch = #27) and KeyPressed then { . . . move the cursor }
  269.       begin
  270.          read(Kbd,ch);
  271.          case Ch of
  272.  { SH-TAB } #15  :  if (WhereX >= 1) and (WhereX <= 16) then
  273.                        GotoXY(65,WhereY)
  274.                     else
  275.                     if (WhereX > 16) and (WhereX <= 32) then
  276.                        GotoXY(02,WhereY)
  277.                     else
  278.                     if (WhereX > 32) and (WhereX <= 48) then
  279.                        GotoXY(17,WhereY)
  280.                     else
  281.                     if (WhereX > 48) and (WhereX <= 64) then
  282.                        GotoXY(33,WhereY)
  283.                     else
  284.                     if (WhereX > 64) and (WhereX <= 80) then
  285.                        GotoXY(49,WhereY);
  286.  { HOME }   #71  :  GotoXY(2,WhereY);
  287.  { UP }     #72  :  if WhereY = 1 then
  288.                        gotoXY(WhereX,25)
  289.                     else
  290.                        gotoXY(WhereX,WhereY-1);
  291.  { LEFT }   #75  :  if WhereX = 1 then
  292.                        gotoXY(80, WhereY)
  293.                     else
  294.                        gotoXY(WhereX-1,WhereY);
  295.  { RIGHT }  #77  :  if WhereX = 80 then
  296.                        gotoXY(1, WhereY)
  297.                     else
  298.                        gotoXY(WhereX+1,WhereY);
  299.  { END }    #79  :  GotoXY(65,WhereY);
  300.  { DOWN }   #80  :  if WhereY = 25 then
  301.                        gotoXY(WhereX,1)
  302.                     else
  303.                        gotoXY(WhereX,WhereY+1);
  304.          end { case };
  305.       end
  306.       else
  307.       begin
  308.          case Ch of
  309.  { TAB }    #9   :  begin
  310.                        if (WhereX >= 1) and (WhereX <= 16) then
  311.                           GotoXY(17,WhereY)
  312.                        else
  313.                        if (WhereX > 16) and (WhereX <= 32) then
  314.                           GotoXY(33,WhereY)
  315.                        else
  316.                        if (WhereX > 32) and (WhereX <= 48) then
  317.                           GotoXY(49,WhereY)
  318.                        else
  319.                        if (WhereX > 48) and (WhereX <= 64) then
  320.                           GotoXY(65,WhereY)
  321.                        else
  322.                        if (WhereX > 64) and (WhereX <= 80) then
  323.                           GotoXY(2,WhereY);
  324.                     end;
  325.          end; { short case }
  326.       end { begin };
  327.  
  328.       { If cursor on line 5, check to see
  329.         if we need to display a menu from heap. }
  330.  
  331.       if WhereY = 5 then
  332.       begin
  333.          if (WhereX > 1) and (WhereX < 16) then
  334.          begin { . . . Northeast }
  335.             if not dflag[1] then
  336.             begin
  337.                RestoreScreen ( page[1] );
  338.                ClearFlags;
  339.                dflag[1] := true;
  340.                Heap2Scr ( Page[2], 1, 1, 16, 10, 1, 6 );
  341.             end;
  342.          end
  343.          else
  344.          if (WhereX > 16) and (WhereX < 32) then
  345.          begin { . . . Southeast }
  346.             if not dflag[2] then
  347.             begin
  348.                RestoreScreen ( page[1] );
  349.                ClearFlags;
  350.                dflag[2] := true;
  351.                Heap2Scr ( Page[2],20, 1, 36, 10,16, 6 );
  352.             end;
  353.          end
  354.          else
  355.          if (WhereX > 32) and (WhereX < 48) then
  356.          begin { . . . Midwest }
  357.             if not dflag[3] then
  358.             begin
  359.                RestoreScreen ( page[1] );
  360.                ClearFlags;
  361.                dflag[3] := true;
  362.                Heap2Scr ( Page[2],40, 1, 56, 10,32, 6 );
  363.             end;
  364.          end
  365.          else
  366.          if (WhereX > 48) and (WhereX < 64) then
  367.          begin { . . . Northwest }
  368.             if not dflag[4] then
  369.             begin
  370.                RestoreScreen ( page[1] );
  371.                ClearFlags;
  372.                dflag[4] := true;
  373.                Heap2Scr ( Page[2],20,12, 36, 21,48, 6 );
  374.             end;
  375.          end
  376.          else
  377.          if (WhereX > 64) and (WhereX < 80) then
  378.          begin { . . . Southwest }
  379.             if not dflag[5] then
  380.             begin
  381.                RestoreScreen ( page[1] );
  382.                ClearFlags;
  383.                dflag[5] := true;
  384.                Heap2Scr ( Page[2],1,12, 17, 21,64, 6 );
  385.             end;
  386.          end
  387.          else
  388.          begin
  389.             RestoreScreen ( page[1] );
  390.             ClearFlags;
  391.          end
  392.       end;
  393.    until UpCase(Ch) = #81;
  394.  
  395.    Release ( HeapTop );
  396.  
  397. END { demo of Heap2Scr }.
  398.