home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / GB_FMINT.ZIP / SRC / CVGA256.PAS next >
Pascal/Delphi Source File  |  1997-01-27  |  16KB  |  606 lines
  1. Unit CVGA256;
  2.  
  3.  
  4. interface
  5.  
  6. uses crt;
  7.  
  8. type GrCh = Array[1..8] of Byte;
  9.  
  10. Const VGA = $A000;
  11.       Alpha : Array[1..41] of GrCh =
  12. ((0,8,20,34,65,127,65,65), (0,63,65,65,63,65,65,63), (0,28,34,1,1,65,34,28),
  13. (0,63,97,65,65,65,97,63),  (0,127,1,1,31,1,1,127),   (0,127,1,1,31,1,1,1),
  14. (0,60,66,1,1,113,65,62),   (0,65,65,65,127,65,65,65),(0,127,8,8,8,8,8,127),
  15. (0,127,8,8,8,9,9,6),       (0,65,33,17,15,17,33,65), (0,1,1,1,1,1,65,127),
  16. (0,65,99,85,73,65,65,65),  (0,65,67,69,73,81,97,65), (0,28,34,65,65,65,34,28),
  17. (0,63,65,65,63,1,1,1),     (0,28,34,65,65,113,34,92),(0,63,65,65,63,9,17,33),
  18. (0,127,65,1,127,64,65,127),(0,127,8,8,8,8,8,8),      (0,65,65,65,65,65,65,62),
  19. (0,65,65,65,65,34,20,8),   (0,65,65,65,73,73,73,54), (0,65,34,20,8,20,34,65),
  20. (0,65,34,20,8,8,8,8),      (0,127,32,16,8,4,2,127),  (0,0,0,0,0,0,0,0),
  21. (0,62,97,81,73,69,67,62),  (0,8,12,10,8,8,8,127),    (0,62,65,32,16,8,4,127),
  22. (0,62,65,64,32,64,65,62),  (0,17,17,17,127,16,16,16),(0,127,1,1,63,64,64,63),
  23. (0,60,2,1,63,65,65,62),    (0,127,65,64,32,16,8,8),  (0,62,65,65,62,65,65,62),
  24. (0,62,65,65,126,64,32,28), (0,0,0,0,0,16,16,8),        (0,0,0,0,0,0,24,24),
  25. (0,67,35,16,8,4,98,97),    (0,0,0,0,127,0,0,0));
  26.  
  27. type VirtualP = Array [1..64000] of byte;  { The size of our Virtual Screen }
  28.       VirtPtr = ^VirtualP;                  { Pointer to the virtual screen }
  29.      RGB256 = Array[0..255,1..3] of byte;
  30.      DataPicLine = array[0..319] of Byte;
  31.  
  32. var VirScr: VirtPtr; { Global }
  33.     Vaddr: Word;
  34.  
  35. procedure StartGraphics;
  36. procedure StartText;
  37. procedure Cls (Col : Byte; Where:word);
  38. procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
  39. procedure PutpixelClip (X,Y : Integer; Col : Byte; where:word);
  40. procedure WaitRetrace;
  41. procedure SetColor(Col,R,G,B : Byte);
  42. procedure GetColor(Col : Byte; Var R,G,B : Byte);
  43. procedure GetAllRGB (var Pal: RGB256);
  44. procedure SetAllRGB (var Pal: RGB256);
  45. procedure ResetPalette (var Pal: RGB256; Col: Byte);
  46. procedure ResetScreenPalette (Col: Byte);
  47. procedure FadeOut (Time: Byte);
  48. procedure FadeIn (Pal: RGB256;Time: byte);
  49. procedure CycleColors (var Pal: RGB256; Start,Finish: Byte; Forw: Boolean);
  50. procedure SetUpVirtual;
  51. procedure ShutDown;
  52. procedure Flip(source,dest:Word);
  53. procedure WriteGraphString (s: string; x,y: word; color: byte; where: word);
  54. procedure WriteGraphStringCentered (s: string; y: word; color: byte; where: word);
  55. procedure Line(a,b,c,d:integer;col:byte;where:word);
  56. procedure LineClip(a,b,c,d:integer;col:byte;where:word);
  57. procedure LoadPic (Filename: String; Xoffs, Yoffs, Where: Word; var Pal: RGB256);
  58. procedure Circle (X,Y,Radius: Word; Color: Byte; Where: Word);
  59. procedure Rectangle (X1,Y1,X2,Y2: Word; Color: Byte; Where: Word);
  60. procedure Hline (x1,x2,y:word;col:byte;where:word);
  61. procedure DrawPoly(x1,y1,x2,y2,x3,y3,x4,y4:integer;color:byte;where:word);
  62.  
  63.  
  64. implementation
  65.  
  66. Procedure StartGraphics; assembler;
  67. asm
  68.   mov  ax,0013h
  69.   int  10h
  70. end;
  71.  
  72. Procedure StartText; assembler;
  73. asm
  74.   mov  ax,0003h
  75.   int  10h
  76. end;
  77.  
  78.  
  79.  
  80. Procedure Cls (Col : Byte; Where:word); assembler;
  81. asm
  82.   push    es
  83.   mov     cx, 32000;
  84.   mov     es,[where]
  85.   xor     di,di
  86.   mov     al,[col]
  87.   mov     ah,al
  88.   rep     stosw
  89.   pop     es
  90. end;
  91.  
  92.  
  93. Procedure Putpixel (X,Y : Integer; Col : Byte; where:word); assembler;
  94. Asm
  95.   push    ds
  96.   push    es
  97.   mov     ax,[where]
  98.   mov     es,ax
  99.   mov     bx,[X]
  100.   mov     dx,[Y]
  101.   push    bx                      {; and this again for later}
  102.   mov     bx, dx                  {; bx = dx}
  103.   mov     dh, dl                  {; dx = dx * 256}
  104.   xor     dl, dl
  105.   shl     bx, 6
  106.   add     dx, bx                  {; dx = dx + bx (ie y*320)}
  107.   pop     bx                      {; get back our x}
  108.   add     bx, dx                  {; finalise location}
  109.   mov     di, bx
  110.   xor     al,al
  111.   mov     ah, [Col]
  112.   mov     es:[di],ah
  113.   pop     es
  114.   pop     ds
  115. end;
  116.  
  117. procedure PutpixelClip (X,Y : Integer; Col : Byte; where:word);
  118. begin
  119.   if (Abs (X-160) < 160) and (Abs (Y-100) < 100) then PutPixel (X,Y,Col,Where);
  120. end;
  121.  
  122.  
  123. procedure WaitRetrace; assembler;
  124.   {  This waits for a vertical retrace to reduce snow on the screen }
  125. label
  126.   l1, l2;
  127. asm
  128.   mov dx,3DAh
  129.   l1:
  130.     in al,dx
  131.     and al,08h
  132.     jnz l1
  133.   l2:
  134.     in al,dx
  135.     and al,08h
  136.     jz  l2
  137. end;
  138.  
  139.  
  140. procedure SetColor(Col,R,G,B : Byte);
  141. Begin
  142.     asm
  143.       mov    dx,3c8h
  144.       mov    al,[col]
  145.       out    dx,al
  146.       inc    dx
  147.       mov    al,[r]
  148.       out    dx,al
  149.       mov    al,[g]
  150.       out    dx,al
  151.       mov    al,[b]
  152.       out    dx,al
  153.    end;
  154. End;
  155.  
  156. Procedure GetColor(Col : Byte; Var R,G,B : Byte);
  157. Var
  158.     rr,gg,bb : Byte;
  159. Begin
  160.    asm
  161.         mov    dx,3c7h
  162.       mov    al,col
  163.       out    dx,al
  164.       add    dx,2
  165.       in     al,dx
  166.       mov    [rr],al
  167.       in     al,dx
  168.       mov    [gg],al
  169.       in     al,dx
  170.       mov    [bb],al
  171.    end;
  172.    r := rr;
  173.    g := gg;
  174.    b := bb;
  175. end;
  176.  
  177. procedure GetAllRGB (var Pal: RGB256);
  178. var i: byte;
  179. begin
  180.   for i := 0 to 255 do
  181.     GetColor (i,Pal[i,1],Pal[i,2],Pal[i,3]);
  182. end;
  183.  
  184.  
  185. procedure SetAllRGB (var Pal: RGB256);
  186. var i: byte;
  187. begin
  188.   WaitRetrace;
  189.   for i := 0 to 85 do
  190.     SetColor (i,Pal[i,1],Pal[i,2],Pal[i,3]);
  191.   WaitRetrace;
  192.   for i := 86 to 170 do
  193.     SetColor (i,Pal[i,1],Pal[i,2],Pal[i,3]);
  194.   WaitRetrace;
  195.   for i := 171 to 255 do
  196.      SetColor (i,Pal[i,1],Pal[i,2],Pal[i,3]);
  197. end;
  198.  
  199. procedure ResetPalette (var Pal: RGB256; Col: Byte);
  200. var i: byte;
  201. begin
  202.   for i := 0 to 255
  203.     do begin
  204.       Pal[i,1] := Col;
  205.       Pal[i,2] := Col;
  206.       Pal[i,3] := Col;
  207.     end;
  208. end;
  209.  
  210. procedure ResetScreenPalette (Col: Byte);
  211. var i: byte;
  212. begin
  213.   for i := 0 to 255 do
  214.     SetColor (i,Col,Col,Col);
  215. end;
  216.  
  217.  
  218. procedure FadeOut (Time: Byte);
  219. var i,
  220.     j: byte;
  221.     FadeOutPal: RGB256;
  222. begin
  223.   GetAllRGB (FadeOutPal);
  224.   for i := 0 to 63 do
  225.   begin
  226.     for j := 0 to 255 do
  227.     begin
  228.       If FadeOutPal[j,1] > 0 then dec(FadeOutPal[j,1]);
  229.       If FadeOutPal[j,2] > 0 then dec(FadeOutPal[j,2]);
  230.       If FadeOutPal[j,3] > 0 then dec(FadeOutPal[j,3]);
  231.     end;
  232.     delay(Time);
  233.     SetAllRGB (FadeOutPal);
  234.   end;
  235. end;
  236.  
  237. procedure FadeIn (Pal: RGB256; Time: byte);
  238. var
  239.      TempPal: RGB256;
  240.      i,
  241.      j: byte;
  242.  
  243. begin
  244.   ResetPalette(TempPal,0);
  245.   for i := 0 to 63 do
  246.   begin
  247.      for j := 0 to 255 do
  248.      begin
  249.         If TempPal[j,1]+1 < Pal[j,1] then inc (TempPal[j,1],2);
  250.         If TempPal[j,2]+1 < Pal[j,2] then inc (TempPal[j,2],2);
  251.         If TempPal[j,3]+1 < Pal[j,3] then inc (TempPal[j,3],2);
  252.      end;
  253.      delay(Time);
  254.     SetAllRGB (TempPal);
  255.   end;
  256.   SetAllRGB (Pal);
  257. end;
  258.  
  259. procedure CycleColors (var Pal: RGB256; Start,Finish: Byte; Forw: Boolean);
  260. var i,R,G,B: byte;
  261. begin
  262.   if Forw then
  263.   begin
  264.     R := Pal[start,1];
  265.     G := Pal[start,2];
  266.     B := Pal[start,3];
  267.     for i := Start to Finish - 1
  268.     do Pal[i] := Pal[i+1];
  269.     Pal[finish,1] := R;
  270.     Pal[finish,2] := B;
  271.     Pal[finish,3] := G;
  272.   end
  273.   else
  274.   begin
  275.     R := Pal[finish,1];
  276.     G := Pal[finish,2];
  277.     B := Pal[finish,3];
  278.     for i := Finish downto start + 1
  279.     do Pal[i] := Pal[i-1];
  280.     Pal[start,1] := R;
  281.     Pal[start,2] := B;
  282.     Pal[start,3] := G;
  283.   end
  284. end;
  285.  
  286.  
  287. Procedure SetUpVirtual;
  288. BEGIN
  289.   GetMem (VirScr,64000);
  290.   vaddr := seg (virscr^);
  291. END;
  292.  
  293. Procedure ShutDown;
  294. BEGIN
  295.   FreeMem (VirScr,64000);
  296. END;
  297.  
  298.  
  299. procedure flip(source,dest:Word);
  300.   { This copies the entire screen at "source" to destination }
  301. begin
  302.   asm
  303.     push    ds
  304.     mov     ax, [Dest]
  305.     mov     es, ax
  306.     mov     ax, [Source]
  307.     mov     ds, ax
  308.     xor     si, si
  309.     xor     di, di
  310.     mov     cx, 32000
  311.     rep     movsw
  312.     pop     ds
  313.   end;
  314. end;
  315.  
  316.  
  317. procedure WriteGraphCh (Ch: GrCh; Color:Byte; X,Y: word; Where: Word);
  318. var i: byte;
  319. begin
  320.   for i := 1 to 8 do
  321.   begin
  322.     if (ch[i] and $01<>0) then PutPixelClip(x  ,y+i-1,Color,Where);
  323.     if (ch[i] and $02<>0) then PutPixelClip(x+1,y+i-1,Color,Where);
  324.     if (ch[i] and $04<>0) then PutPixelClip(x+2,y+i-1,Color,Where);
  325.     if (ch[i] and $08<>0) then PutPixelClip(x+3,y+i-1,Color,Where);
  326.     if (ch[i] and $10<>0) then PutPixelClip(x+4,y+i-1,Color,Where);
  327.     if (ch[i] and $20<>0) then PutPixelClip(x+5,y+i-1,Color,Where);
  328.     if (ch[i] and $40<>0) then PutPixelClip(x+6,y+i-1,Color,Where);
  329.     if (ch[i] and $80<>0) then PutPixelClip(x+7,y+i-1,Color,Where);
  330.   end;
  331. end;
  332.  
  333. procedure ConvertString(var S: String);
  334. var i: byte;
  335. begin
  336.   for i := 1 to length(s) do
  337.     case S[i] of
  338.       'A'..'Z':  S[i] := chr(ord(S[i]) - 64);
  339.       'a'..'z':  S[i] := chr(ord(S[i]) - 96);
  340.       #32:      S[i] := chr(27);
  341.       #48..#57:  S[i] := chr(ord(S[i]) - 20);
  342.       ',':S[i] := chr(38);
  343.       '.':S[i] := chr(39);
  344.       '%':S[i] := chr(40);
  345.       '-':S[i] := chr(41);
  346.       else s[i] := chr(27);
  347.     end;
  348. end;
  349.  
  350. procedure WriteGraphString (s: string; x,y: word; color: byte; where: word);
  351. var i: byte;
  352. begin
  353.   convertstring(s);
  354.   for i := 1 to length(S)
  355.     do writeGraphCh ((Alpha[ord(s[i])]),Color,X+i*8-1,Y,Where);
  356. end;
  357.  
  358. procedure WriteGraphStringCentered (s: string; y: word; color: byte; where: word);
  359. var i: byte;
  360. begin
  361.   convertstring(s);
  362.   for i := 1 to length(S)
  363.     do writeGraphCh (Alpha[ord(S[i])],Color,round((160-(length(S)/2)*8)+i*8-1),Y,Where);
  364. end;
  365.  
  366. Procedure Line(a,b,c,d:integer;col:byte;where:word);
  367.   { This draws a solid line from a,b to c,d in colour col }
  368.   function sgn(a:real):integer;
  369.   begin
  370.        if a>0 then sgn:=+1;
  371.        if a<0 then sgn:=-1;
  372.        if a=0 then sgn:=0;
  373.   end;
  374. var i,s,d1x,d1y,d2x,d2y,u,v,m,n:integer;
  375. begin
  376.      u:= c - a;
  377.      v:= d - b;
  378.      d1x:= SGN(u);
  379.      d1y:= SGN(v);
  380.      d2x:= SGN(u);
  381.      d2y:= 0;
  382.      m:= ABS(u);
  383.      n := ABS(v);
  384.      IF NOT (M>N) then
  385.      BEGIN
  386.           d2x := 0 ;
  387.           d2y := SGN(v);
  388.           m := ABS(v);
  389.           n := ABS(u);
  390.      END;
  391.      s := m shr 1;
  392.      FOR i := 0 TO m DO
  393.      BEGIN
  394.           putpixel(a,b,col,where);
  395.           s := s + n;
  396.           IF not (s<m) THEN
  397.           BEGIN
  398.                s := s - m;
  399.                a:= a + d1x;
  400.                b := b + d1y;
  401.           END
  402.           ELSE
  403.           BEGIN
  404.                a := a + d2x;
  405.                b := b + d2y;
  406.           END;
  407.      end;
  408. END;
  409.  
  410. Procedure LineClip(a,b,c,d:integer;col:byte;where:word);
  411.   { This draws a solid line from a,b to c,d in colour col }
  412.   function sgn(a:real):integer;
  413.   begin
  414.        if a>0 then sgn:=+1;
  415.        if a<0 then sgn:=-1;
  416.        if a=0 then sgn:=0;
  417.   end;
  418. var i,s,d1x,d1y,d2x,d2y,u,v,m,n:integer;
  419. begin
  420.      u:= c - a;
  421.      v:= d - b;
  422.      d1x:= SGN(u);
  423.      d1y:= SGN(v);
  424.      d2x:= SGN(u);
  425.      d2y:= 0;
  426.      m:= ABS(u);
  427.      n := ABS(v);
  428.      IF NOT (M>N) then
  429.      BEGIN
  430.           d2x := 0 ;
  431.           d2y := SGN(v);
  432.           m := ABS(v);
  433.           n := ABS(u);
  434.      END;
  435.      s := m shr 1;
  436.      FOR i := 0 TO m DO
  437.      BEGIN
  438.           if (abs(a-160) < 160) and (abs(b-100) < 100) then
  439.           putpixel(a,b,col,where);
  440.           s := s + n;
  441.           IF not (s<m) THEN
  442.           BEGIN
  443.                s := s - m;
  444.                a:= a + d1x;
  445.                b := b + d1y;
  446.           END
  447.           ELSE
  448.           BEGIN
  449.                a := a + d2x;
  450.                b := b + d2y;
  451.           END;
  452.      end;
  453. END;
  454.  
  455. procedure LoadPic (    Filename: String;
  456.                        Xoffs,
  457.                        Yoffs,
  458.                        Where: Word;
  459.                    var Pal: RGB256);
  460.  
  461. var F: File of DataPicLine;
  462.     D: DataPicLine;
  463.     I,J: Word;
  464. begin
  465.   Assign (F,Filename);
  466.   reset(F);
  467.   for J := 1 to 3 do
  468.   begin
  469.     read(F,D);
  470.     for I := 1 to 256 do Pal[I,J] := D[i];
  471.   end;
  472.   For j := 0 to 200 do
  473.     begin
  474.     read(f,d);
  475.     For i := 0 to 319 do
  476.       PutPixel (i,j,d[i],Where);
  477.     end;
  478.   close(f);
  479. end;
  480.  
  481. procedure Circle (X,Y,Radius: Word; Color: Byte; Where: Word);
  482. var i: byte;
  483. begin
  484.   for i := 1 to 30 do
  485.     LineClip ( Round(X+Sin(I*Pi/15)*Radius),
  486.                Round(Y+Cos(I*Pi/15)*Radius),
  487.                Round(X+Sin((I+1)*pi/15)*Radius),
  488.                Round(Y+Cos((I+1)*pi/15)*Radius),
  489.                Color,Where);
  490. end;
  491.  
  492. procedure Rectangle (X1,Y1,X2,Y2: Word; Color: Byte; Where: Word);
  493. begin
  494.   line (x1,y1,x2,y1,Color,Where);
  495.   line (x2,y2,x2,y1,Color,Where);
  496.   line (x1,y1,x1,y2,Color,Where);
  497.   line (x2,y2,x1,y2,Color,Where);
  498. end;
  499.  
  500. Procedure Hline (x1,x2,y:word;col:byte;where:word); assembler;
  501.   { This draws a horizontal line from x1 to x2 on line y in color col }
  502. asm
  503.   mov   ax,where
  504.   mov   es,ax
  505.   mov   ax,y
  506.   mov   di,ax
  507.   shl   ax,8
  508.   shl   di,6
  509.   add   di,ax
  510.   add   di,x1
  511.  
  512.   mov   al,col
  513.   mov   ah,al
  514.   mov   cx,x2
  515.   sub   cx,x1
  516.   shr   cx,1
  517.   jnc   @start
  518.   stosb
  519. @Start :
  520.   rep   stosw
  521. end;
  522.  
  523.  
  524. Procedure DrawPoly(x1,y1,x2,y2,x3,y3,x4,y4:integer;color:byte;where:word);
  525. { Muck of this procedure I can credit Asphixia }
  526. var
  527.   x:integer;
  528.   mny,mxy:integer;
  529.   mnx,mxx,yc:integer;
  530.   mul1,div1,
  531.   mul2,div2,
  532.   mul3,div3,
  533.   mul4,div4:integer;
  534. begin
  535.   mny:=y1; mxy:=y1;
  536.   if y2<mny then mny:=y2;
  537.   if y2>mxy then mxy:=y2;
  538.   if y3<mny then mny:=y3;
  539.   if y3>mxy then mxy:=y3;
  540.   if y4<mny then mny:=y4;
  541.   if y4>mxy then mxy:=y4;
  542.  
  543.   if mny<0 then mny:=0;
  544.   if mxy>199 then mxy:=199;
  545.   if mny>199 then exit;
  546.   if mxy<0 then exit;        { Verticle range checking }
  547.  
  548.   mul1:=x1-x4; div1:=y1-y4;
  549.   mul2:=x2-x1; div2:=y2-y1;
  550.   mul3:=x3-x2; div3:=y3-y2;
  551.   mul4:=x4-x3; div4:=y4-y3;  { Constansts needed for intersection calc }
  552.  
  553.   for yc:=mny to mxy do
  554.     begin
  555.       mnx:=320;
  556.       mxx:=-1;
  557.       if (y4>=yc) or (y1>=yc) then
  558.         if (y4<=yc) or (y1<=yc) then   { Check that yc is between y1 and y4 }
  559.           if not(y4=y1) then
  560.             begin
  561.               x:=(yc-y4)*mul1 div div1+x4; { Point of intersection on x axis }
  562.               if x<mnx then
  563.                 mnx:=x;
  564.               if x>mxx then
  565.                 mxx:=x;       { Set point as start or end of horiz line }
  566.             end;
  567.       if (y1>=yc) or (y2>=yc) then
  568.         if (y1<=yc) or (y2<=yc) then   { Check that yc is between y1 and y2 }
  569.           if not(y1=y2) then
  570.             begin
  571.               x:=(yc-y1)*mul2 div div2+x1; { Point of intersection on x axis }
  572.               if x<mnx then
  573.                 mnx:=x;
  574.               if x>mxx then
  575.                 mxx:=x;       { Set point as start or end of horiz line }
  576.             end;
  577.       if (y2>=yc) or (y3>=yc) then
  578.         if (y2<=yc) or (y3<=yc) then   { Check that yc is between y2 and y3 }
  579.           if not(y2=y3) then
  580.             begin
  581.               x:=(yc-y2)*mul3 div div3+x2; { Point of intersection on x axis }
  582.               if x<mnx then
  583.                 mnx:=x;
  584.               if x>mxx then
  585.                 mxx:=x;       { Set point as start or end of horiz line }
  586.             end;
  587.       if (y3>=yc) or (y4>=yc) then
  588.         if (y3<=yc) or (y4<=yc) then   { Check that yc is between y3 and y4 }
  589.           if not(y3=y4) then
  590.             begin
  591.               x:=(yc-y3)*mul4 div div4+x3; { Point of intersection on x axis }
  592.               if x<mnx then
  593.                 mnx:=x;
  594.               if x>mxx then
  595.                 mxx:=x;       { Set point as start or end of horiz line }
  596.             end;
  597.       if mnx<0 then
  598.         mnx:=0;
  599.       if mxx>319 then
  600.         mxx:=319;          { Range checking on horizontal line }
  601.       if mnx<=mxx then
  602.         hline (mnx,mxx,yc,color,where);   { Draw the horizontal line }
  603.     end;
  604.   end;
  605.  
  606. end.