home *** CD-ROM | disk | FTP | other *** search
/ Prima Shareware 3 / DuCom_Prima-Shareware-3_cd1.bin / PROGRAMO / PASCAL / PMAGIC / DEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-11-16  |  14.8 KB  |  343 lines
  1. program demo; {to show some of the capabilities of Pascal Magic}
  2. uses crt,graph,magic;
  3. (***********************************************************************)
  4. procedure showcode;
  5. begin
  6.    vgahivideo;              {switch to VGA 640 x 480 graphics}
  7.    mainback := red;
  8.    xclear;                  {clear the screen to all red}
  9.    ntext(200,100,'Let''s look at the code so far:');
  10.    ntext(180,152,'uses graph,magic;');
  11.    ntext(180,168,'begin');
  12.    ntext(204,184,'putpcx(''earth'');');
  13.    ntext(204,200,'outtextxy(94,124,''Copyright 1992'');');
  14.    ntext(204,216,'outtextxy(92,135,''Another Company'');');
  15.    ntext(204,232,'triplex;');
  16.    ntext(204,248,'setrgbpalette(255,63,63,0);');
  17.    ntext(204,264,'outtextxy(101,30,''Pascal'');');
  18.    ntext(204,280,'outtextxy(107,58,''Magic'');');
  19.    ntext(204,296,'outtextxy(107,86,''Demo'');');
  20.    ntext(204,312,'waitforuser;');
  21.    setlinestyle(0,0,3);
  22.    setcolor(yellow);
  23.    line(194,118,440,118);
  24.    circle(320,220,200);
  25.    triplex;                          {engage Triplex font}
  26.    settextjustify(lefttext,toptext); {restore normal justification}
  27.    setcolor(black);            {make a black shadow to emphasize text}
  28.    outtextxy(162,432,'It''s just that simple!');
  29.    setcolor(lightgreen);       {the shadowed text itself}
  30.    outtextxy(160,430,'It''s just that simple!');
  31. end; {procedure showcode}
  32. (***********************************************************************)
  33. procedure demonstratemouse;
  34. begin
  35.    centerjustify := false;       {No centering of strings in pop-up box}
  36.    pile('An arrow will appear.');
  37.    pile('You can move it whether');
  38.    pile('or not you have a mouse,');
  39.    pile('because you can also');
  40.    pile('use the arrow keys,');
  41.    pile('[Page Up], [Page Down],');
  42.    pile('[Home], [End] or the');
  43.    pile('number keys.  Try it!');
  44.    pile('Press [Enter] or a');
  45.    pile('mouse button when done.');
  46.    present.init(-1,40);         {Pops a text box onto the screen}
  47.    bugle;                       {sound effect}
  48.    px := 50;
  49.    py := 80;
  50.    pointertoxy;                 {move cursor position to 50,80}
  51.    pointeron;                   {show cursor - "mouse" arrow}
  52.    repeat poll; until left or right;       {wait until user clicks button}
  53.                                            {or presses [Enter] or [Esc]}
  54.    pointeroff;                  {turn off cursor}
  55.    present.done;                {get rid of pop up text box}
  56.    centerjustify := true;       {restore center justification of strings}
  57.    waste;                       {wait until user is not pressing mouse}
  58.                                 {button or keyboard key and clear key-}
  59.                                 {board buffer}
  60. end; {procedure demonstratemouse}
  61. (***********************************************************************)
  62. procedure extkey; {shows ASCII codes when a key is pressed}
  63. var
  64.    tempstr : string[3];
  65. begin
  66.    XClear;                 {clear screen to current background color}
  67.    sent[1] := 'Press any key to see it''s extended code';
  68.    sent[2] := 'Press [Esc] when done.';
  69.    present.init(18,3);     {pop up a text box on screen}
  70.    sent[1] := ' ';
  71.    sent[2] := '';
  72.       repeat
  73.       present.getanykey(-1,-1);   {wait for user to press a key}
  74.       if keydetect = 2 then sent[1] := '#0 + ';
  75.       case u of
  76.          #13,#8,#10,#7 : answer := ' '; {don't try to print unprintables}
  77.          else answer := u;
  78.       end; {case}
  79.       str(ord(u),tempstr);            {make a string of it's ASCII value}
  80.       sent[1] := sent[1] + answer + ' (#' + tempstr + ')';
  81.    until u = #27;                     {fall through if user presses [Esc]}
  82.    present.done;                      {Get rid of pop up text box}
  83.    waste;                             {Wait for user to let go of keys}
  84.                                       {and clear the buffer}
  85. end;  {procedure ExtKey}
  86. (***********************************************************************)
  87. procedure asciichart;  {makes a chart of the ASCII codes}
  88. var
  89.    x,y : byte;
  90.    temp : integer;
  91. begin
  92.    textcolor(white); textbackground(blue);
  93.    x := 1;
  94.    y := 1;
  95.    clrscr;
  96.    for temp := 0 to 255 do
  97.    begin
  98.       u := chr(temp);        {get the character equivalent of "temp"}
  99.       gotoxy(x,y);
  100.       write(' ');
  101.       if temp < 10 then write(' ');
  102.       if temp < 100 then write(' ');
  103.       if (temp <> 7) and (temp <> 8) and (temp <> 10)
  104.          and (temp <> 13) and (temp <> 27)
  105.          then write(temp,'=',u,' ')
  106.       else write(temp,'=');
  107.       inc(y);
  108.       if y > 25 then
  109.       begin
  110.          y := 1;
  111.          x := x + 7;
  112.       end;
  113.    end; {end of for 0 to 255 loop}
  114.    waitforuser;            {show the chart until user presses any key}
  115.    waste;                  {wait for user to let go of keyboard and}
  116.                            {clear the buffer.}
  117. end; {procedure Asciichart}
  118. (***********************************************************************)
  119. procedure typotrap;
  120. begin
  121.    centerjustify := false;  {does not center text in pop-up boxes}
  122.    mainback := green;
  123.    boxback := blue;
  124.    xclear;                  {clears background to MainBack - green}
  125.    pile('This procedure reads a Pascal source code file from disk,');
  126.    pile('and looks for lines containing literal strings.  It then');
  127.    pile('prints only those lines to a disk file named "RESULTS.DOC."');
  128.    pile('    This is very helpful in finding typographical errors');
  129.    pile('which your compiler will not be able to catch but which');
  130.    pile('your end users would notice.');
  131.    pile('                              Press any key to begin...');
  132.    present.getanykey(-1,-1);   {pops a text box on screen, wait for user}
  133.    centerjustify := true;      {lines of text will be centered in pop-ups}
  134.    pile('Type the name of a source code file to check:');
  135.    present.dialog(-1,-1);       {get an answer from user}
  136.    if answer = '' then exit;
  137.    if pos('.',answer) = 0 then answer := answer + '.PAS';
  138.    nameinfile(answer);          {input file named as user's answer}
  139.    nameoutfile('results.doc');  {output file named "results.doc"}
  140.    mainback := blue;
  141.    xclear;                      {background cleared to MainBack - blue}
  142.    sent[1] := '*************** String literals from file: ' + answer + '****************';
  143.    fileecholn(sent[1]);         {print sent[1] to screen and file}
  144.    repeat
  145.        answer := filereadln;    {string "Answer" read from input file}
  146.        if pos('''',answer) > 0 then fileecholn(answer);
  147.                                 {If there is a quote mark in string,}
  148.                                 {then print it to file and screen.}
  149.    until problem > 0;           {Problem is 1 when end of file}
  150.    filewriteln('');             {write a blank line to file}
  151.    boxback := magenta;          {make pop-up boxes in magenta}
  152.    pile('Results written to disk file: RESULTS.DOC');
  153.    pile('');
  154.    pile('Press any key to continue...');
  155.    present.getanykey(-1,-1);    {pop up text box, and wait for user}
  156.    boxback := blue;
  157.    mainback := green;
  158.    waste;                       {clear keyboard buffer (and mouse)}
  159. end; {procedure typotrap}
  160. (***********************************************************************)
  161. procedure tools;     {Programmer's Toolkit}
  162. begin
  163.    textvideo;        {get rid of graphics mode screen}
  164.    mc := 1;
  165.    centerjustify := true;   {text will be centered in pop-up boxes}
  166.    repeat
  167.       mainback := green;
  168.       xclear;               {clears background to green}
  169.       BoxBack := red;
  170.       sent[1] := 'Programmer''s Tools';
  171.       sent[2] := 'Copyright 1991, Another Company';
  172.       present.init(-1,2);              {pops up a text box}
  173.       BoxBack := blue;
  174.       sent[1] := 'ASCII Chart';
  175.       sent[2] := 'Extended Keys';
  176.       sent[3] := 'Typo Trap';
  177.       sent[4] := 'Quit';
  178.       present.menu(-1,-1,'AETQ');   {pops up a menu which will fall}
  179.                                     {through when end user presses}
  180.                                     {[Enter], [Esc], left or right}
  181.                                     {mouse buttons, or [A],[E],[T],}
  182.                                     {or [Q] in upper or lower case.}
  183.  
  184.       present.done;                 {Get rid of original pop-up box}
  185.       case u of
  186.          'A' : asciichart;
  187.          'E' : extkey;              {if user selected from menu by}
  188.          'T' : typotrap;            {pressing an alphanumeric key}
  189.          'Q' : right := true;
  190.       end;
  191.       if left then case mc of
  192.          1 : asciichart;            {if user seleted from menu by}
  193.          2 : extkey;                {highlighting and pressing left}
  194.          3 : typotrap;              {mouse button or [Enter]}
  195.          4 : right := true;
  196.       end;
  197.    until right;                     {falls through if user presses}
  198.                                     {[Esc] or right mouse button}
  199.    waste;                           {clears keyboard buffer and mouse}
  200.    showcode;
  201. end; {procedure tools}
  202. (***********************************************************************)
  203. procedure saveearth;   {Demonstrates how to build a video game}
  204. var
  205.   holdsize,oldx,oldy : word;
  206.   hold : pointer;
  207. begin
  208.    egalovideo;               {switch to EGA 640 x 200, 16-color mode}
  209.    centerjustify := false;   {strings will not be centered in pop-up box}
  210.    pile('This demonstrates a very (very!) simple');
  211.    pile('video game.  Try it, look at how small');
  212.    pile('and straight-forward the source code is');
  213.    pile('(Procedure SaveEarth within DEMO.PAS).');
  214.    pile('Then imagine adding more rules, timer,');
  215.    pile('function, sound effects, and perhaps');
  216.    pile('some adversary action...');
  217.    present.getanykey(-1,-1);      {pops up a text box and waits for user}
  218.    pile('The earth is suffering from pollution.');
  219.    pile('Only YOU can reverse it. Change the');
  220.    pile('black spots to white.  Do this by ');
  221.    pile('clicking the left mouse button or');
  222.    pile('pressing [Enter]. When done, click');
  223.    pile('the right button or press [Esc].');
  224.    pile('');
  225.    pile('             Press any key to begin...');
  226.    present.getanykey(-1,-1);      {pops up a text box and waits for user}
  227.    putpcx('Earth',true);            {displays a .PCX file called "Earth"}
  228.    setrgbpalette(255,53,53,53);        {customize color #255}
  229.    setcolor(255);
  230.    settextjustify(centertext,bottomtext);  {Text justification}
  231.    if mouseinstalled then
  232.       outtextxy(160,199,'Left = Fill spot | Right = Quit')
  233.       else outtextxy(160,199,'Enter = Fill spot | Esc = Quit');
  234.                                        {puts a note at bottom of screen}
  235.    holdsize := imagesize(0,0,20,20);
  236.    getmem(hold,holdsize);              {gets a chunk of RAM to hold a}
  237.                                        {portion of video image}
  238.    waste;                              {clears keyboard buffer and mouse}
  239.    px := 160;
  240.    py := 100;
  241.    pointertoxy;                        {position cursor at 160,100}
  242.    repeat
  243.       getimage(px - 10,py - 10,px + 10,py + 10,hold^);  {store portion of}
  244.                                                         {screen to RAM}
  245.       line(px - 1,py,px - 10,py);
  246.       line(px + 1,py,px + 10,py);                   {make + shaped cursor}
  247.       line(px,py - 1,px,py - 10);                   {with a small hole in}
  248.       line(px,py + 1,px,py + 10);                   {the middle}
  249.       oldx := px;
  250.       oldy := py;
  251.       repeat
  252.          poll;                             {get of mouse position & status}
  253.          if px < 10 then px := 10;
  254.          if px > 307 then px := 307;
  255.          if py < 10 then py := 10;         {keep cursor location on screen}
  256.          if py > 188 then py := 188;
  257.       until (px <> oldx) or (py <> oldy)   {keep polling until action is}
  258.          or left or right;                 {detected}
  259.       putimage(oldx - 10, oldy - 10, hold^,copyput); {replace screen image}
  260.       if left then putpixel(px,py,255);    {draw a dot on screen}
  261.    until right;                            {done when user presses right}
  262.                                            {mouse button or [Esc] key}
  263.    freemem(hold,holdsize);                 {release RAM held for image}
  264.    waste;
  265.    centerjustify := true;
  266.    showcode;
  267. end; {procedure saveearth}
  268. (***********************************************************************)
  269. procedure fixsound;  {if sound effects are on, turn them off, & visa versa}
  270. begin
  271.    if musicon then
  272.    begin
  273.       musicon := false;
  274.       pile('Sound Turned OFF')
  275.    end else begin
  276.       musicon := true;
  277.       pile('Sound turned ON');
  278.    end;
  279.    present.init(-1,-1);  {pop a line of text on screen in small box}
  280.    delay(500);           {wait 1/2 second}
  281.    present.done;         {get rid of pop-up box}
  282. end; {procedure fixsound}
  283. (***********************************************************************)
  284. begin {main}
  285.    putpcx('earth',true);                    {display .PCX file}
  286.    setcolor(yellow);
  287.    outtextxy(94,124,'Copyright 1992');
  288.    outtextxy(92,135,'Another Company');
  289.    triplex;                               {Engage Triplex font}
  290.    setrgbpalette(255,63,63,0);
  291.    outtextxy(101,30,'Pascal');
  292.    outtextxy(107,58,'Magic');
  293.    outtextxy(107,86,'Demo');
  294.    waitforuser;                           {wait for user to press something}
  295.    showcode;                              {procedure at top of this file}
  296.    waitforuser;
  297.    mc := 1;                               {first menu item to highlight}
  298.    centerjustify := true;                 {text will be centered in boxes}
  299.    repeat
  300.       pile('Mouse Interface');
  301.       pile('Programmer''s Tools');
  302.       pile('Save The Earth');
  303.       if musicon then pile('Turn Off Sound Effects')
  304.          else pile('Turn On Sound Effects');
  305.       pile('Quit');
  306.       present.menu(-1,150,'MPQST');       {a menu will pop up which will}
  307.                                           {drop out when the user presses}
  308.                                           {[Enter], [Esc] a mouse button,}
  309.                                           {[M], [P], [Q], [S] or [T].}
  310.       case u of
  311.          'M' : demonstratemouse;
  312.          'P' : tools;
  313.          'S' : saveearth;
  314.          'T' : fixsound;                  {if user selected by pressing}
  315.          'Q' : right := true;             {a key}
  316.       end;
  317.       if left then case mc of
  318.          1 : demonstratemouse;
  319.          2 : tools;
  320.          3 : saveearth;                  {if user selected by hilighting}
  321.          4 : fixsound;
  322.          5 : right := true;
  323.       end;
  324.    until right;                   {if user pressed right mouse button}
  325.                                   {or [Esc] key, we're done}
  326.  
  327.    textvideo;
  328.    mainback := green;
  329.    xclear;
  330.    clearsents;
  331.    centerjustify := true;
  332.    pile('Pascal Magic - Demo');
  333.    pile('');
  334.    pile('For use with Turbo Pascal, Version 7.0');
  335.    pile('');
  336.    pile('Copyright 1992, Another Company');
  337.    pile('P.O. Box 298');
  338.    pile('Applegate, OR 97530, USA');
  339.    pile('phone 503-846-7884');
  340.    present.getanykey(-1,-1);
  341.    cleanup;
  342. end.
  343.