home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TUR6_101.ZIP / V_DEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-06-07  |  12.5 KB  |  373 lines
  1. program demo;
  2.  
  3. {----------------------------------------------------------}
  4. {-                                                        -}
  5. {- Global type delcarations required for the procedures:  -}
  6. {-                                                        -}
  7. {-                 ColorMsg                               -}
  8. {-                 WaitMsg                                -}
  9. {-                 WriteSt                                -}
  10. {-                 WriteStLn                              -}
  11. {-                                                        -}
  12. {----------------------------------------------------------}
  13.  
  14. Type
  15.    Str255 = String[255];
  16.    Str2   = String[2];
  17.    TCSet  = Set of 0..255;
  18.  
  19.  
  20. {----------------------------------------------------------}
  21. {-                                                        -}
  22. {- External procedure declarations                        -}
  23. {-                                                        -}
  24. {----------------------------------------------------------}
  25.  
  26. Procedure BoarderColor(Color : Integer);                    External 'V1.ENH';
  27. Procedure ClrWin;                                           External 'V2.ENH';
  28. Procedure ColorMsg(X,Y,Color : Integer; Message : Str255);  External 'V3.ENH';
  29. Procedure FillCol(X,Y,Num : Integer; Ch : Char);            External 'V4.ENH';
  30. Procedure FillColAttrib(X,Y,Num,Color : Integer);           External 'V5.ENH';
  31. Procedure FillRow(X,Y,Num : Integer; Ch : Char);            External 'V6.ENH';
  32. Procedure FillRowAttrib(X,Y,Num,Color : Integer);           External 'V7.ENH';
  33. Procedure FrameWin(UL,UR,LL,LR,Hor,Ver : Char);             External 'V8.ENH';
  34. Procedure GetScrn(X,Y,NumChars : Integer; Var ChArray);     External 'V10.ENH';
  35. Procedure GotoXYAbs(X,Y : Integer);                         External 'V12.ENH';
  36. Procedure InitVideo(Mode : Integer);                        External 'V13.ENH';
  37. Procedure PutScrn(X,Y,NumChars : Integer; Var ChArray);     External 'V14.ENH';
  38. Procedure RvsVideo;                                         External 'V15.ENH';
  39. Procedure ScrollDn(Lines,Color,X1,Y1,X2,Y2 : Integer);      External 'V16.ENH';
  40. Procedure ScrollLeft(Columns,Color,X1,Y1,X2,Y2 : Integer);  External 'V17.ENH';
  41. Procedure ScrollUp(Lines,Color,X1,Y1,X2,Y2 : Integer);      External 'V18.ENH';
  42. Procedure ScrollRight(Columns,Color,X1,Y1,X2,Y2 : Integer); External 'V19.ENH';
  43. Procedure SetCursorSize(StartLine,EndLine : Integer);       External 'V20.ENH';
  44. Procedure WaitMsg(X,Y   : Integer;     Msg : Str255;
  45.                   TESet : TCSet;   Var TC  : Str2);         External 'V21.ENH';
  46. Procedure WriteSt(St : Str255);                             External 'V24.ENH';
  47. Procedure WriteStLn(St : Str255);                           External 'V25.ENH';
  48.  
  49. Function GetCursorSize : Integer;                           External 'V9.ENH';
  50. Function GetVideoMode  : Integer;                           External 'V11.ENH';
  51. Function WhereXAbs     : Integer;                           External 'V22.ENH';
  52. Function WhereYAbs     : Integer;                           External 'V23.ENH';
  53.  
  54. {----------------------------------------------------------}
  55. {- Global type and variable declarations for demo program -}
  56. {----------------------------------------------------------}
  57.  
  58. Var
  59.    Done : Boolean;
  60.    Ch   : Char;
  61.  
  62.  
  63. Procedure DoBoarderColor;
  64. Var
  65.    Color : Integer;
  66. Begin
  67.    Repeat
  68.       ClrScr;
  69.       WriteStLn('Enter a value from 0-15 to see a boarder color');
  70.       WriteSt('Enter a value >15 to quit ');
  71.       Readln(Color);
  72.       BoarderColor(Color);
  73.    Until (Color < 0) Or (Color > 15);
  74.    BoarderColor(0);
  75. End;
  76.  
  77. Procedure DoColorMsg;
  78. Var
  79.    i : Integer;
  80. Begin
  81.    For i := 1 To 20 Do
  82.       ColorMsg(10,i,i,'This is a message using color');
  83.    ColorMsg(10,24,7,'Press [ENTER] to continue');
  84.    Readln;
  85. End;
  86.  
  87. Procedure DoFillCol;
  88. Var
  89.    i,j,k : Integer;
  90. Begin
  91.    j := 1;
  92.    repeat
  93.       ColorMsg(41,4,48,'                                    ');
  94.       ColorMsg(41,5,48,'  Enter a value (1-40) to display   ');
  95.       ColorMsg(41,6,48,'  a column of characters.           ');
  96.       ColorMsg(41,7,48,'                                    ');
  97.       ColorMsg(41,8,48,'  Any value not in range will exit  ');
  98.       ColorMsg(41,9,48,'                                    ');
  99.       GotoXYAbs(41,10);
  100.       ClrEol;
  101.       Readln(i);
  102.       FillCol(i,1,25,Chr(64+j));
  103.       If (i > 0) And (i < 41) Then Begin
  104.             ColorMsg(41,4,48,'                                    ');
  105.             ColorMsg(41,5,48,'  Enter a value (0-255) to display  ');
  106.             ColorMsg(41,6,48,'  the color for the column of chars.');
  107.             ColorMsg(41,7,48,'                                    ');
  108.             ColorMsg(41,8,48,'  Any value not in range will exit  ');
  109.             ColorMsg(41,9,48,'                                    ');
  110.             GotoXYAbs(41,10);
  111.             ClrEol;
  112.             Readln(k);
  113.             FillColAttrib(i,1,25,k);
  114.             j := j + 1;
  115.          End
  116.       Else
  117.          j := 26;
  118.    Until (i < 0) Or (i > 40) Or (j > 25) Or (k < 0) Or (k > 255);
  119. End;
  120.  
  121. Procedure DoFillRow;
  122. Var
  123.    i,j,k : Integer;
  124. Begin
  125.    j := 1;
  126.    repeat
  127.       ColorMsg(41,18,48,'                                    ');
  128.       ColorMsg(41,19,48,'  Enter a value (1-25) to display   ');
  129.       ColorMsg(41,20,48,'  a row of characters.              ');
  130.       ColorMsg(41,21,48,'                                    ');
  131.       ColorMsg(41,22,48,'  Any value not in range will exit  ');
  132.       ColorMsg(41,23,48,'                                    ');
  133.       GotoXYAbs(41,24);
  134.       ClrEol;
  135.       Readln(i);
  136.       FillRow(1,i,80,Chr(64+j));
  137.       If (i > 0) And (i < 26) Then Begin
  138.             ColorMsg(41,18,48,'                                    ');
  139.             ColorMsg(41,19,48,'  Enter a value (0-255) to display  ');
  140.             ColorMsg(41,20,48,'  the color for the row of chars.   ');
  141.             ColorMsg(41,21,48,'                                    ');
  142.             ColorMsg(41,22,48,'  Any value not in range will exit  ');
  143.             ColorMsg(41,23,48,'                                    ');
  144.             GotoXYAbs(41,24);
  145.             ClrEol;
  146.             Readln(k);
  147.             FillRowAttrib(1,i,80,k);
  148.             j := j + 1;
  149.          End
  150.       Else
  151.          j := 26;
  152.    Until (i < 0) Or (i > 25) Or (j > 25) Or (k < 0) Or (k > 255);
  153. End;
  154.  
  155. Procedure DoFrameWin;
  156. Var
  157.    i,j : Integer;
  158. Begin
  159.    For i := 1 To 10 Do Begin
  160.       Window(i,i,80-i,25-i);
  161.       FrameWin('┌','┐','└','┘','─','│');
  162.       ClrWin;
  163.       GotoXY(1,1);
  164.       For j := 1 to 20 do
  165.          Writeln('This is window ',i:1);
  166.       Writeln('Press [ENTER] to continue... ');
  167.       Readln;
  168.    End;
  169.    Window(1,1,80,25);
  170. End;
  171.  
  172. Procedure DoCursorSize;
  173. Var
  174.    i    : Integer;
  175.    Done : Boolean;
  176. Begin
  177.    Repeat
  178.       ClrScr;
  179.       WriteStLn('This routine demonstrates 3 Cursor sizes');
  180.       WriteStLn('for use with the color/graphic adapter');
  181.       WriteStLn(' ');
  182.       WriteStLn('    0 - Normal');
  183.       WriteStLn('    1 - Large');
  184.       WriteStLn('    2 - Hidden');
  185.       WriteStLn(' ');
  186.       WriteStLn('Enter a value (0-3) for the size cursor you want ');
  187.       WriteSt('Enter any value outside range to exit ');
  188.       Readln(i);
  189.       Case i Of
  190.          0 : SetCursorSize(7,6);
  191.          1 : SetCursorSize(7,0);
  192.          2 : SetCursorSize(32,32);
  193.       Else
  194.          Done := True;
  195.       End;
  196.       WriteStLn(' ');
  197.       WriteStLn('The new cursor scan lines are:');
  198.       WriteStLn(' ');
  199.       WriteStLn('  Start Scan       Stop Scan');
  200.       WriteStLn('  ----------       ---------');
  201.       i := GetCursorSize;
  202.       Writeln(Hi(i):7,Lo(i):17);
  203.       WriteStLn(' ');
  204.       WriteStLn('Press [ENTER] to continue... ');
  205.       Readln;
  206.    Until Done;
  207. End;
  208.  
  209. Procedure DoScrn;
  210. Var
  211.    CA2 : Array[1..640] Of Char;
  212.    TC  : Str2;
  213. Begin
  214.    WriteStLn('This is line 1 of the screen.  This line and the next 3 lines');
  215.    WriteStLn('will be read from the screen and placed on lines 15-18');
  216.    WriteStLn('All you will have to do is press the [ENTER] key to continue');
  217.    WriteStLn('thru this procedure.');
  218.    Readln;
  219.    GetScrn(1,1,320,CA2);
  220.    WaitMsg(1,6,
  221.           'The screen has been read.  Press [ENTER] to continue... ',[13],TC);
  222.    PutScrn(1,15,320,CA2);
  223.    WaitMsg(1,7,'Press [ENTER] to exit this procedure',[13],TC);
  224. End;
  225.  
  226. Procedure DoRvsVideo;
  227. Var
  228.    TC : Str2;
  229. Begin
  230.    WriteLn('This is how text is displayed before RvsVideo');
  231.    WaitMsg(1,5,'Press [ESC] to continue...',[1],TC);
  232.    RvsVideo;
  233.    WriteLn('This is how text is displayed after RvsVideo');
  234.    WaitMsg(1,5,'Press [ESC] to continue...',[1],TC);
  235.    RvsVideo;
  236. End;
  237.  
  238. Procedure DoScroll;
  239. Var
  240.    i  : Integer;
  241.    Ch : Char;
  242. Begin
  243.    ClrScr;
  244.    WriteStLn(' We will be scrolling the contents of window');
  245.    WriteStLn(' either one column or row at a time');
  246.    WriteStLn(' ');
  247.    WriteStLn(' L - Scroll Left one column');
  248.    WriteStLn(' R - Scroll Right one column');
  249.    WriteStLn(' U - Scroll Up one row');
  250.    WriteStLn(' D - Scroll Down one row');
  251.    WriteStLn(' Q - Quit and return to menu');
  252.    WriteStLn(' Press key for desired action');
  253.    Window(48,1,80,25);
  254.    FrameWin('┌','┐','└','┘','─','│');
  255.    For i := 49 To 79 Do
  256.       FillCol(i,2,23,Chr(i+16));
  257.    Repeat
  258.       Read(Kbd,Ch);
  259.       Ch := UpCase(Ch);
  260.       Case Ch Of
  261.          'L' : ScrollLeft (1,48,49,2,79,24);
  262.          'R' : ScrollRight(1,48,49,2,79,24);
  263.          'U' : ScrollUp   (1,0 ,49,2,79,24);
  264.          'D' : ScrollDn   (1,0 ,49,2,79,24);
  265.       End;
  266.    Until Ch = 'Q';
  267.    Window(1,1,80,25);
  268. End;
  269.  
  270. Procedure DoCursorPos;
  271. Var
  272.    x,y : Integer;
  273. Begin
  274.    Window(54,9,80,14);
  275.    FrameWin('┌','┐','└','┘','─','│');
  276.    Repeat
  277.       ClrWin;
  278.       ColorMsg(55,10,6,'                      ');
  279.       ColorMsg(55,11,6,'Enter Column (1-40)   ');
  280.       ColorMsg(55,12,6,'                      ');
  281.       GotoXYAbs(75,11);
  282.       Readln(x);
  283.       ColorMsg(55,12,11,'Enter Row (1-25)      ');
  284.       GotoXYAbs(72,12);
  285.       Readln(y);
  286.       GotoXYAbs(x,y);
  287.       y := WhereXAbs;
  288.       x := WhereYAbs;
  289.       ClrWin;
  290.       ColorMsg(55,11,1,'Press [ENTER] to continue');
  291.       Readln;
  292.       ClrScr;
  293.       GotoXY(1,1);
  294.       Writeln('The absolute column = ',y:1);
  295.       Writeln('The absolure row    = ',x:1);
  296.       ColorMsg(55,13,1,'Press [ENTER] to continue');
  297.       GotoXYAbs(y,x);
  298.       Readln;
  299.    Until (x > 40) Or (x < 1) Or (y > 25) Or (y < 1);
  300.    Window(1,1,80,25);
  301. End;
  302.  
  303. Procedure DoVideoModes;
  304. Var
  305.    i,j : Integer;
  306.    TC  : Str2;
  307. Begin
  308.    i := GetVideoMode;
  309.    Gotoxy(5,10);
  310.    Case i of
  311.       0..6 : WriteStln('You have a color/graphics adapter card installed');
  312.       7    : WriteStln('You use a monochrome monitor on your system');
  313.    Else
  314.       WriteStln('Enhance graphics adapter card installed?');
  315.    End;
  316.    Writeln;
  317.    WriteStLn('Press [ENTER] to continue...');
  318.    Readln;
  319.    Writeln;
  320.    WriteStln('Enter a value (0-7) for initializing a video mode');
  321.    Readln(j);
  322.    InitVideo(j);
  323.    j := GetVideoMode;
  324.    InitVideo(i);
  325.    WriteSt('I initialized the video mode to number ');
  326.    Writeln(j:1);
  327.    WriteStln('I also returned you to the mode you were in before');
  328.    WriteStln('I printed out the above statement.');
  329.    WriteStln(' ');
  330.    WaitMsg(1,25,'Press [ESC] to continue...',[1],TC);
  331. End;
  332.  
  333. Begin
  334.    Done := False;
  335.    Repeat
  336.       ClrScr;
  337.       WriteStLn('   This menu is displayed using WriteStLn');
  338.       WriteStLn(' ');
  339.       WriteStLn('   Press a letter for the procedures to demonstrate');
  340.       WriteStLn(' ');
  341.       WriteStLn('      A.  BoarderColor, WriteSt');
  342.       WriteStLn('      B.  FillCol, FillColAttrib, ColorMsg');
  343.       WriteStLn('      C.  FillRow, FillRowAttrib, ColorMsg');
  344.       WriteStLn('      D.  FrameWin, ClrWin');
  345.       WriteStLn('      E.  GetCursorSize, SetCursorSize');
  346.       WriteStLn('      F.  GetScrn, PutScrn');
  347.       WriteStLn('      G.  RvsVideo');
  348.       WriteStLn('      H.  ScrollLeft, ScrollRight, ScrollUp, ScrollDn');
  349.       WriteStLn('      I.  GotoXYAbs, WhereXAbs, WhereYAbs');
  350.       WriteStLn('      J.  InitVideo, GetVideoMode');
  351.       WriteStLn(' ');
  352.       WriteStLn('      K.  Quit this demo');
  353.       WriteStLn(' ');
  354.       Read(Kbd,Ch);
  355.       Ch := UpCase(Ch);
  356.       ClrScr;
  357.       Case Ch Of
  358.          'A' : DoBoarderColor;
  359.          'B' : DoFillCol;
  360.          'C' : DoFillRow;
  361.          'D' : DoFrameWin;
  362.          'E' : DoCursorSize;
  363.          'F' : DoScrn;
  364.          'G' : DoRvsVideo;
  365.          'H' : DoScroll;
  366.          'I' : DoCursorPos;
  367.          'J' : DoVideoModes;
  368.          'K' : Done := True;
  369.       End;
  370.    Until Done;
  371.    ClrScr;
  372. End.
  373.