home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / TUT15.ZIP / TUTPRO15.PAS < prev   
Pascal/Delphi Source File  |  1994-09-16  |  12KB  |  400 lines
  1. {$X+}
  2. USES crt;
  3.  
  4. TYPE RGBType = Record
  5.                R, G, B : Byte;
  6.             End;
  7.      PalType = Array[0..255] of RGBType;
  8.  
  9. VAR bob,bob2:paltype;  { Two pallettes, current and temporary }
  10.     biiiigpallette : array [1..6656] of RGBType; { A massive pallette for the
  11.                                                    psychadelic effect }
  12.     start:integer;  { Where in the Biiiig pallette are we? }
  13.     Effect,Background:Boolean; { Configuration of effects }
  14.  
  15.     costbl : Array [0..255] of byte; { cos table lookup }
  16.     mov1,mov2,mov3,mov4 : byte;  { current positions }
  17.     bkg : array [1..50,1..80] of byte; { The pic in the background }
  18.  
  19.  
  20.  
  21. {──────────────────────────────────────────────────────────────────────────}
  22. procedure PAL(Col,R,G,B : Byte); assembler;
  23.    { This sets the Red, Green and Blue values of a certain color }
  24. asm
  25.    mov    dx,3c8h
  26.    mov    al,[col]
  27.    out    dx,al
  28.    inc    dx
  29.    mov    al,[r]
  30.    out    dx,al
  31.    mov    al,[g]
  32.    out    dx,al
  33.    mov    al,[b]
  34.    out    dx,al
  35. end;
  36.  
  37. {──────────────────────────────────────────────────────────────────────────}
  38. Procedure SetAllPal(Var Palette : PalType); Assembler;
  39.   { This dumps the pallette in our variable onto the screen, fast }
  40. Asm
  41.    push   ds
  42.    lds    si, Palette
  43.    mov    dx, 3c8h
  44.    mov    al, 0
  45.    out    dx, al
  46.    inc    dx
  47.    mov    cx, 768
  48.    rep    outsb
  49.    pop    ds
  50. End;
  51.  
  52. {──────────────────────────────────────────────────────────────────────────}
  53. Procedure Makerun (r,g,b:integer);
  54.   { This creates a ramp of colors and puts them into biiiigpallette }
  55. VAR loop1:integer;
  56. BEGIN
  57.   for loop1:=start to start+127 do BEGIN
  58.     if r=1 then
  59.       biiiigpallette[loop1].r:=63-(loop1-start) div 4 else
  60.     if r=2 then
  61.       biiiigpallette[loop1].r:=(loop1-start) div 4 else
  62.       biiiigpallette[loop1].r:=0;
  63.  
  64.     if g=1 then
  65.       biiiigpallette[loop1].g:=63-(loop1-start) div 4 else
  66.     if g=2 then
  67.       biiiigpallette[loop1].g:=(loop1-start) div 4 else
  68.       biiiigpallette[loop1].g:=0;
  69.  
  70.     if b=1 then
  71.       biiiigpallette[loop1].b:=63-(loop1-start) div 4 else
  72.     if b=2 then
  73.       biiiigpallette[loop1].b:=(loop1-start) div 4 else
  74.       biiiigpallette[loop1].b:=0;
  75.   END;
  76.  
  77.   for loop1:=start+128 to start+255 do BEGIN
  78.     if r=2 then
  79.       biiiigpallette[loop1].r:=63-(loop1-start) div 4 else
  80.     if r=1 then
  81.       biiiigpallette[loop1].r:=(loop1-start) div 4 else
  82.       biiiigpallette[loop1].r:=0;
  83.  
  84.     if g=2 then
  85.       biiiigpallette[loop1].g:=63-(loop1-start) div 4 else
  86.     if g=1 then
  87.       biiiigpallette[loop1].g:=(loop1-start) div 4 else
  88.       biiiigpallette[loop1].g:=0;
  89.  
  90.     if b=2 then
  91.       biiiigpallette[loop1].b:=63-(loop1-start) div 4 else
  92.     if b=1 then
  93.       biiiigpallette[loop1].b:=(loop1-start) div 4 else
  94.       biiiigpallette[loop1].b:=0;
  95.   END;
  96.   start:=start+256;
  97. END;
  98.  
  99.  
  100. {──────────────────────────────────────────────────────────────────────────}
  101. Procedure init;
  102. VAR loop1,loop2,r,g,b:integer;
  103.     f:text;
  104.     ch:char;
  105.  
  106.   Function rad (theta : real) : real; { Converts degrees to radians }
  107.   BEGIN
  108.     rad := theta * pi / 180
  109.   END;
  110.  
  111. BEGIN
  112.   write ('Do you want the Psychadelic effect? ');
  113.   repeat
  114.     ch:=upcase(readkey);
  115.   until ch in ['Y','N'];
  116.   if ch='Y' then BEGIN
  117.     Writeln ('Yeah!');
  118.     effect:=true;
  119.   END else BEGIN
  120.     Writeln ('Nah');
  121.     effect:=false;
  122.   END;
  123.   writeln;
  124.   while keypressed do readkey;
  125.   write ('Do you want the background? ');
  126.   repeat
  127.     ch:=upcase(readkey);
  128.   until ch in ['Y','N'];
  129.   if ch='Y' then BEGIN
  130.     Writeln ('Yeah!');
  131.     background:=true;
  132.   END else BEGIN
  133.     Writeln ('Nah');
  134.     background:=false;
  135.   END;
  136.   writeln;
  137.   while keypressed do readkey;
  138.   writeln ('Hit any key to continue...');
  139.   readkey;
  140.   while keypressed do readkey;
  141.   asm
  142.     mov     ax,0013h
  143.     int     10h                     { Enter mode 13 }
  144.     cli
  145.     mov     dx,3c4h
  146.     mov     ax,604h                 { Enter unchained mode }
  147.     out     dx,ax
  148.     mov     ax,0F02h                { All planes}
  149.     out     dx,ax
  150.  
  151.     mov     dx,3D4h
  152.     mov     ax,14h                  { Disable dword mode}
  153.     out     dx,ax
  154.     mov     ax,0E317h               { Enable byte mode.}
  155.     out     dx,ax
  156.     mov     al,9
  157.     out     dx,al
  158.     inc     dx
  159.     in      al,dx
  160.     and     al,0E0h                 { Duplicate each scan 8 times.}
  161.     add     al,7
  162.     out     dx,al
  163.   end;
  164.  
  165.   fillchar (bob2,sizeof(bob2),0);  { Clear pallette bob2 }
  166.   setallpal (bob2);
  167.  
  168.   start:=0;
  169.   r:=0;
  170.   g:=0;
  171.   b:=0;
  172.   Repeat
  173.     makerun (r,g,b);
  174.     b:=b+1;
  175.     if b=3 then BEGIN
  176.       b:=0;
  177.       g:=g+1;
  178.     END;
  179.     if g=3 then BEGIN
  180.       g:=0;
  181.       r:=r+1;
  182.     END;
  183.   until (r=2) and (g=2) and (b=2);
  184.     { Set up our major run of colors }
  185.  
  186.   start:=0;
  187.   if not effect then BEGIN
  188.     for loop1:=0 to 128 do BEGIN
  189.       bob[loop1].r:=63-loop1 div 4;
  190.       bob[loop1].g:=0;
  191.       bob[loop1].b:=loop1 div 4;
  192.     END;
  193.     for loop1:=129 to 255 do BEGIN
  194.       bob[loop1].r:=loop1 div 4;
  195.       bob[loop1].g:=0;
  196.       bob[loop1].b:=63-loop1 div 4;
  197.     END;
  198.   END else
  199.     for loop1:=0 to 255 do bob[loop1]:=biiiigpallette[loop1];
  200.  
  201.     { Set up a nice looking pallette ... we alter color 0, so the border will
  202.       be altered. }
  203.  
  204.   For loop1:=0 to 255 do
  205.     costbl[loop1]:=round (cos (rad (loop1/360*255*2))*31)+32;
  206.     { Set up our lookup table...}
  207.  
  208.   fillchar (bkg,sizeof(bkg),0);
  209.   assign (f,'a:bkg.dat');
  210.   reset (f);
  211.   for loop1:=1 to 50 do BEGIN
  212.     for loop2:=1 to 80 do BEGIN
  213.       read (f,ch);
  214.       if ord (ch)<>48 then
  215.         bkg[loop1,loop2]:=ord (ch)-28;
  216.     END;
  217.     readln (f);
  218.   END;
  219.   close (f);
  220.     { Here we read in our background from the file bkg.dat }
  221. END;
  222.  
  223.  
  224. {──────────────────────────────────────────────────────────────────────────}
  225. Procedure DrawPlasma;
  226.   { This procedure draws the plasma onto the screen }
  227. VAR loop1,loop2:integer;
  228.     tmov1,tmov2,tmov3,tmov4:byte; { Temporary variables, so we dont destroy
  229.                                     the values of our main variables }
  230.     col:byte;
  231.     where:word;
  232. BEGIN
  233.   tmov3:=mov3;
  234.   tmov4:=mov4;
  235.   where:=0;
  236.   asm
  237.     mov   ax,0a000h
  238.     mov   es,ax        { In the two loops that follow, ES is not altered so
  239.                          we just set it once, now }
  240.   end;
  241.   For loop1:=1 to 50 do BEGIN   { Fifty rows down }
  242.     tmov1:=mov1;
  243.     tmov2:=mov2;
  244.     for loop2:=1 to 80 do BEGIN { Eighty columns across }
  245.       if background then
  246.         col:=costbl[tmov1]+costbl[tmov2]+costbl[tmov3]+costbl[tmov4]+costbl[loop1]+costbl[loop2]+bkg[loop1,loop2]
  247.       else
  248.         col:=costbl[tmov1]+costbl[tmov2]+costbl[tmov3]+costbl[tmov4]+costbl[loop1]+costbl[loop2];
  249.         { col = Intersection of numerous cos waves }
  250.       asm
  251.         mov    di,where   { di is killed elsewhere, so we need to restore it}
  252.         mov    al,col
  253.         mov    es:[di],al { Place col at ES:DI ... sequential across the screen}
  254.       end;
  255.       where:=where+1;  { Inc the place to put the pixel }
  256.       tmov1:=tmov1+4;
  257.       tmov2:=tmov2+3;  { Arb numbers ... replace to zoom in/out }
  258.     END;
  259.     tmov3:=tmov3+4;
  260.     tmov4:=tmov4+5;    { Arb numbers ... replace to zoom in/out }
  261.   END;
  262. END;
  263.  
  264.  
  265. {──────────────────────────────────────────────────────────────────────────}
  266. Procedure MovePlasma;
  267.   { This procedure moves the plasma left/right/up/down }
  268. BEGIN
  269.   mov1:=mov1-4;
  270.   mov3:=mov3+4;
  271.   mov1:=mov1+random (1);
  272.   mov2:=mov2-random (2);
  273.   mov3:=mov3+random (1);
  274.   mov4:=mov4-random (2);   { Movement along the plasma + noise}
  275. END;
  276.  
  277. {──────────────────────────────────────────────────────────────────────────}
  278. procedure WaitRetrace; assembler;
  279.    {  This waits for a vertical retrace to reduce snow on the screen }
  280. label
  281.   l1, l2;
  282. asm
  283.     mov   dx,3DAh
  284. l1:
  285.     in    al,dx
  286.     test  al,8
  287.     jnz   l1
  288. l2:
  289.     in    al,dx
  290.     test  al,8
  291.     jz    l2
  292. end;
  293.  
  294. {──────────────────────────────────────────────────────────────────────────}
  295. Procedure fadeupone (stage:integer);
  296.   { This procedure fades up the pallette bob2 by one increment and sets the
  297.     onscreen pallette. Colors are increased proportionally, do that all colors
  298.     reach their destonation at the same time }
  299. VAR loop1:integer;
  300.     temp:rgbtype;
  301. BEGIN
  302.   if not effect then move (bob[0],temp,3);
  303.   move (bob[1],bob[0],765);
  304.   if effect then move (biiiigpallette[start],bob[255],3) else
  305.     move (temp,bob[255],3);
  306.   start:=start+1;
  307.   if start=6657 then start:=0;
  308.     { Rotate the pallette }
  309.  
  310.   for loop1:=0 to 255 do BEGIN
  311.     bob2[loop1].r:=integer(bob[loop1].r*stage div 64);
  312.     bob2[loop1].g:=integer(bob[loop1].g*stage div 64);
  313.     bob2[loop1].b:=integer(bob[loop1].b*stage div 64);
  314.   END; { Fade up the pallette }
  315.   setallpal (bob2);
  316. END;
  317.  
  318.  
  319. {──────────────────────────────────────────────────────────────────────────}
  320. Procedure Shiftpallette;
  321.   { This rotates the pallette, and introduces new colors if the psychadelic
  322.     effect has been chosen }
  323. VAR loop1:integer;
  324.     temp:rgbtype;
  325. BEGIN
  326.   if not effect then move (bob2[0],temp,3);
  327.   move (bob2[1],bob2[0],765);
  328.   if effect then move (biiiigpallette[start],bob2[255],3) else
  329.     move (temp,bob2[255],3);
  330.   start:=start+1;
  331.   if start=6657 then start:=0;
  332.   setallpal (bob2);
  333. END;
  334.  
  335.  
  336. {──────────────────────────────────────────────────────────────────────────}
  337. Procedure Play;
  338. VAR loop1:integer;
  339. BEGIN
  340.   start:=256;
  341.   for loop1:=1 to 64 do BEGIN
  342.     fadeupone(loop1);
  343.     drawplasma;
  344.     moveplasma;
  345.   END; { Fade up the plasma }
  346.   while keypressed do readkey;
  347.   Repeat
  348.     shiftpallette;
  349.     drawplasma;
  350.     moveplasma;
  351.   Until keypressed; { Do the plasma }
  352.   move (bob2,bob,768);
  353.   for loop1:=1 to 64 do BEGIN
  354.     fadeupone(64-loop1);
  355.     drawplasma;
  356.     moveplasma;
  357.   END; { fade down the plasma }
  358.   while keypressed do readkey;
  359. END;
  360.  
  361. BEGIN
  362.   clrscr;
  363.   writeln ('Hi there ... here is a tut on plasmas! (By popular demand). The');
  364.   writeln ('program will ask you weather you want the Psychadelic effect, in');
  365.   writeln ('which the pallette does strange things (otherwise the pallette');
  366.   writeln ('remains constant), and it will ask weather you want a background');
  367.   writeln ('(a static pic behind the plasma). Try them both!');
  368.   writeln;
  369.   writeln ('The thing about plasmas is that they are very easy to change/modify');
  370.   writeln ('and this one is no exception .. you can even change the background');
  371.   writeln ('with minimum hassle. Try adding and deleting things, you will be');
  372.   writeln ('surprised by the results!');
  373.   writeln;
  374.   writeln ('This is by no means the only way to do plasmas, and there are other');
  375.   writeln ('sample programs out there. Have fun with this one though! ;-)');
  376.   writeln;
  377.   writeln;
  378.   init;
  379.   play;
  380.   asm
  381.     mov  ax,0003h
  382.     int  10h
  383.   end;
  384.   Writeln ('All done. This concludes the fifteenth sample program in the ASPHYXIA');
  385.   Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  386.   Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS.I also occasinally');
  387.   Writeln ('RSAProg, comp.lang.pascal and comp.sys.ibm.pc.demos. E-mail me at :');
  388.   Writeln ('    denthor@beastie.cs.und.ac.za');
  389.   Writeln ('The numbers are available in the main text. You may also write to me at:');
  390.   Writeln ('             Grant Smith');
  391.   Writeln ('             P.O. Box 270');
  392.   Writeln ('             Kloof');
  393.   Writeln ('             3640');
  394.   Writeln ('             Natal');
  395.   Writeln ('             South Africa');
  396.   Writeln ('I hope to hear from you soon!');
  397.   Writeln; Writeln;
  398.   Write   ('Hit any key to exit ...');
  399.   readkey;
  400. END.