home *** CD-ROM | disk | FTP | other *** search
/ Solo Programadores 21 / SOLOPROG21.iso / disk21 / cdemos / shadebob.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1996-03-17  |  2.5 KB  |  122 lines
  1. {                                            }
  2. {  SHADING BOBS  ;)                          }
  3. {          Pascal version- No coprocesor ;(  }
  4. {          March 96 Crom / Spanish Lords     }
  5. Program ShadingBobs;
  6.  
  7. Uses
  8.   DemoVga, Crt;
  9.  
  10. Const
  11.   SprPic : array[0..15,0..15] of byte = (
  12.     (0,0,0,0,0,0,2,2,2,2,0,0,0,0,0,0),
  13.     (0,0,0,0,2,2,2,2,2,2,2,2,0,0,0,0),
  14.     (0,0,0,2,2,2,2,2,2,2,2,2,2,0,0,0),
  15.     (0,0,2,2,2,2,2,4,4,2,2,2,2,2,0,0),
  16.     (0,2,2,2,2,2,4,4,4,4,2,2,2,2,2,0),
  17.     (0,2,2,2,2,4,4,8,8,4,4,2,2,2,2,0),
  18.     (2,2,2,2,4,4,8,8,8,8,4,4,2,2,2,2),
  19.     (2,2,2,2,4,4,8,16,16,8,4,4,2,2,2,2),
  20.     (2,2,2,2,4,4,8,8,8,8,4,4,2,2,2,2),
  21.     (0,2,2,2,2,4,4,8,8,4,4,2,2,2,2,0),
  22.     (0,2,2,2,2,2,4,4,4,4,2,2,2,2,2,0),
  23.     (0,0,2,2,2,2,2,4,4,2,2,2,2,2,0,0),
  24.     (0,0,2,2,2,2,2,2,2,2,2,2,2,2,0,0),
  25.     (0,0,0,2,2,2,2,2,2,2,2,2,2,0,0,0),
  26.     (0,0,0,0,2,2,2,2,2,2,2,2,0,0,0,0),
  27.     (0,0,0,0,0,0,2,2,2,2,0,0,0,0,0,0));
  28.  
  29. Procedure PutSpriteShading (SegDes:Word; X,Y:Integer; Wide,Height:Byte; Sprite:pointer); assembler;
  30. asm
  31.   push ds
  32.   lds si,[Sprite]
  33.   mov ax,SegDes
  34.   mov es,ax
  35.   cld
  36.   mov ax,Y
  37.   shl ax,6
  38.   mov di,ax
  39.   shl ax,2
  40.   add di,ax
  41.   add di,X
  42.   mov bh,[Height]
  43.   mov cx,320
  44.   sub cl,[Wide]
  45.   sbb ch,0
  46. @@AnotherLine:
  47.   mov bl,[Wide]
  48. @@AnotherPix:
  49.   mov al,ds:[si]
  50.   inc si
  51.   or  al,al
  52.   jz  @@NoPutPix
  53.   mov dl,es:[di]
  54.   add dl,al
  55.   and dl,7Fh
  56.   mov es:[di],dl
  57. @@NoPutPix:
  58.   inc di
  59.   dec bl
  60.   jnz @@AnotherPix
  61.   add di,cx
  62.   dec bh
  63.   jnz @@AnotherLine
  64.   pop ds
  65. end;
  66.  
  67. Procedure Setpalette;
  68. Var
  69.   NumCol : Byte;
  70.   RGB    : Byte;
  71. Begin
  72.   For NumCol := 0 to 63 do
  73.     Begin
  74.       port[$3c8] := NumCol;
  75.       port[$3c9] := 0;
  76.       port[$3c9] := 0;
  77.       port[$3c9] := NumCol;
  78.     End;
  79.   RGB:=NumCol;
  80.   For NumCol := 64 to 127 do
  81.     Begin
  82.       port[$3c8] := NumCol;
  83.       port[$3c9] :=    RGB;
  84.       port[$3c9] :=    RGB;
  85.       port[$3c9] :=     63;
  86.       Dec (RGB);
  87.     End;
  88. End;
  89.  
  90. Procedure LissajousShadeBobs;
  91. Const
  92.   A1    =     145;
  93.   A2    =      85;
  94. Var
  95.   X,Y   : Integer;
  96.   Incw  :    Byte;
  97.   t     :    Real;
  98.   f     :    Real;
  99.  
  100. Begin
  101.   Incw := 2;
  102.   f    := 0;
  103.   Repeat
  104.   t:=0;
  105.   Repeat
  106.     X :=150+Trunc(A1*Cos(t));
  107.     Y := 90+Trunc(A2*Cos((Incw*t)+f));
  108.     t:=t+0.02;
  109.     VerticalRetrace;
  110.     PutSpriteShading ($A000,X,Y,16,16,addr(SprPic));
  111.   Until (t>2*PI) or keypressed;
  112.    f:=f+0.6;
  113.    If f>=2*PI then f:=0;
  114.   until (Keypressed);
  115. End;
  116.  
  117. BEGIN
  118.   McgaOn;
  119.   SetPalette;
  120.   LissajousShadeBobs;
  121.   McgaOff;
  122. END.