home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / shadebob.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-21  |  6KB  |  168 lines
  1. {$G+}
  2.  
  3. program ShadingBobs;
  4. { Principles of shaded bobs, see comment below, by Bas van Gaalen, Holland, PD }
  5. uses dos;
  6. const
  7. colors : array[1..768] of byte =(
  8.  43, 0, 54, 44, 0, 54, 45, 0, 55, 46, 0, 56,
  9.  48, 0, 56, 49, 0, 57, 50, 0, 58, 52, 0, 59, 53, 0, 59, 54, 0, 60, 56, 0, 61,
  10.  57, 0, 61, 58, 0, 62, 60, 0, 62, 61, 0, 63, 63, 0, 63, 63, 0, 61, 62, 0, 60,
  11.  61, 0, 57, 60, 0, 54, 59, 0, 51, 58, 0, 48, 56, 0, 45, 55, 0, 42, 54, 0, 39,
  12.  53, 0, 36, 52, 0, 33, 51, 0, 30, 49, 0, 27, 48, 0, 24, 47, 0, 21, 45, 0, 15,
  13.  45,  0, 0, 46,  1, 0, 47,  2, 0, 48,  4, 0, 49,  6, 0, 50,  8, 0, 51,  9, 0,
  14.  51, 10, 0, 52, 11, 0, 52, 13, 0, 53, 14, 0, 53, 15, 0, 54, 17, 0, 54, 19, 0,
  15.  55, 20, 0, 55, 21, 0, 56, 21, 0, 56, 22, 0, 56, 23, 0, 56, 25, 0, 57, 26, 0,
  16.  57, 27, 0, 58, 29, 0, 58, 30, 0, 59, 31, 0, 59, 33, 0, 60, 34, 0, 60, 36, 0,
  17.  61, 38, 0, 61, 39, 0, 62, 40, 0, 63, 42, 0, 63, 42, 0, 63, 43, 0, 63, 44, 0,
  18.  63, 46, 0, 63, 47, 0, 63, 48, 0, 63, 50, 0, 63, 52, 0, 63, 53, 0, 63, 55, 0,
  19.  63, 56, 0, 63, 57, 0, 63, 59, 0, 63, 60, 0, 63, 62, 0, 63, 63, 0, 62, 63, 0,
  20.  62, 62, 0, 61, 62, 0, 60, 62, 0, 59, 62, 0, 58, 61, 0, 57, 61, 0, 55, 61, 0,
  21.  54, 61, 0, 53, 60, 0, 51, 60, 0, 50, 60, 0, 49, 60, 0, 48, 59, 0, 47, 59, 0,
  22.  46, 59, 0, 45, 59 ,0, 44, 59, 0, 43, 59, 0, 42, 59, 0, 41, 59, 0, 40, 59, 0,
  23.  39, 59, 0, 38, 59, 0, 38, 58, 0, 37, 58, 0, 36, 58, 0, 35, 58, 0, 34, 58, 0,
  24.  33, 58, 0, 32, 58, 0, 31, 58, 0, 30, 58, 0, 29, 57, 0, 27, 55, 0, 25, 54, 0,
  25.  23, 52, 0, 21, 51, 0, 19, 49, 0, 17, 48, 0, 15, 46, 0, 13, 45, 0, 11, 43, 0,
  26.   9, 42, 0, 07, 40, 0, 05, 38, 0, 03, 37, 0,  0, 36, 0, 0, 35,  0, 0, 36,  3,
  27.  0, 37,  5, 0, 38,  7, 0, 39,  9, 0, 40, 11, 0, 41, 13, 0, 42, 15, 0, 43, 17,
  28.  0, 44, 18, 0, 45, 19, 0, 46, 21, 0, 47, 22, 0, 48, 23, 0, 49, 24, 0, 49, 25,
  29.  0, 49, 26, 0, 49, 27, 0, 49, 29, 0, 50, 31, 0, 50, 33, 0, 50, 35, 0, 50, 37,
  30.  0, 51, 39, 0, 51, 41, 0, 51, 43, 0, 52, 45, 0, 52, 47, 0, 52, 49, 0, 52, 51,
  31.  0, 53, 52, 0, 53, 53, 0, 52, 53, 0, 51, 53, 0, 50, 53, 0, 49, 54, 0, 47, 54,
  32.  0, 46, 54, 0, 44, 55, 0, 43, 55, 0, 41, 55, 0, 40, 56, 0, 38, 56, 0, 37, 56,
  33.  0, 35, 57, 0, 34, 57, 0, 32, 57, 0, 30, 58, 0, 29, 58, 0, 28, 58, 0, 27, 58,
  34.  0, 26, 58, 0, 25, 58, 0, 24, 58, 0, 23, 58, 0, 22, 58, 0, 21, 57, 0, 20, 57,
  35.  0, 19, 57, 0, 19, 57, 0, 18, 57, 0, 17, 57, 0, 16, 57, 0, 16, 57, 0, 15, 57,
  36.  0, 14, 56, 0, 13, 56, 0, 12, 55, 0, 11, 55, 0, 10, 55, 0,  9, 54, 0,  8, 54,
  37.  0, 07, 53, 0, 06, 53, 0, 05, 52, 0, 04, 52, 0, 03, 51, 0, 03, 51, 0, 02, 51,
  38.  0, 01, 50,  0, 0, 50,  4, 0, 50,  8, 0, 50, 12, 0, 51, 16, 0, 51, 18, 0, 51,
  39.  21, 0, 51, 24, 0, 52, 27, 0, 52, 30, 0, 52, 33, 0, 53, 35, 0, 53, 37, 0, 53,
  40.  39, 0, 53, 41, 0, 54, 42, 0, 54, 43, 0, 54, 44, 0, 54, 45, 0, 55, 46, 0, 56,
  41.  48, 0, 56, 49, 0, 57, 50, 0, 58, 52, 0, 59, 53, 0, 59, 54, 0, 60, 56, 0, 61,
  42.  57, 0, 61, 58, 0, 62, 60, 0, 62, 61, 0, 63, 63, 0, 63, 63, 0, 61, 62, 0, 60,
  43.  61, 0, 57, 60, 0, 54, 59, 0, 51, 58, 0, 48, 56, 0, 45, 55, 0, 42, 54, 0, 39,
  44.  53, 0, 36, 52, 0, 33, 51, 0, 30, 49, 0, 27, 48, 0, 24, 47, 0, 21, 45, 0, 15);
  45.  
  46.   Gseg : word = $a000;
  47.   Sofs = 40; Samp = 50; Slen = 255;
  48.   SprPic : array[0..15,0..15] of byte = (
  49.     (0,0,0,0,0,0,2,2,2,2,0,0,0,0,0,0),
  50.     (0,0,0,0,2,2,1,1,1,1,2,2,0,0,0,0),
  51.     (0,0,0,2,1,1,1,1,1,1,1,1,2,0,0,0),
  52.     (0,0,2,1,1,1,1,1,1,1,1,1,1,2,0,0),
  53.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  54.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  55.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  56.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  57.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  58.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  59.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  60.     (0,0,2,1,1,1,1,1,1,1,1,1,1,2,0,0),
  61.     (0,0,2,1,1,1,1,1,1,1,1,1,1,2,0,0),
  62.     (0,0,0,2,1,1,1,1,1,1,1,1,2,0,0,0),
  63.     (0,0,0,0,2,2,1,1,1,1,2,2,0,0,0,0),
  64.     (0,0,0,0,0,0,2,2,2,2,0,0,0,0,0,0));
  65. type SinArray = array[0..Slen] of word;
  66. var Stab : SinArray;
  67.  
  68. procedure CalcSinus; var I : word; begin
  69.   for I := 0 to Slen do Stab[I] := round(sin(I*4*pi/Slen)*Samp)+Sofs; end;
  70.  
  71. procedure SetGraphics(Mode : word); assembler; asm
  72.   mov ax,Mode; int 10h end;
  73.  
  74. function keypressed : boolean; assembler; asm
  75.   mov ah,0bh; int 21h; and al,0feh; end;
  76.  
  77. procedure DrawSprite(X,Y : integer; W,H : byte; Sprite : pointer); assembler;
  78. asm
  79.   push ds
  80.   lds si,[Sprite]
  81.   mov es,Gseg
  82.   cld
  83.   mov ax,[Y]
  84.   shl ax,6
  85.   mov di,ax
  86.   shl ax,2
  87.   add di,ax
  88.   add di,[X]
  89.   mov bh,[H]
  90.   mov cx,320
  91.   sub cl,[W]
  92.   sbb ch,0
  93.  @L:
  94.   mov bl,[W]
  95.  @L2:
  96.   lodsb
  97.   or al,al
  98.   jz @S
  99.   mov dl,[es:di]
  100.   add dl,al
  101.   and dl,63
  102.   mov [es:di],dl
  103.  @S:
  104.   inc di
  105.   dec bl
  106.   jnz @L2
  107.   add di,cx
  108.   dec bh
  109.   jnz @L
  110.   pop ds
  111. end;
  112.  
  113. procedure Retrace; assembler; asm
  114.   mov dx,3dah;
  115.   @l1: in al,dx; test al,8; jnz @l1;
  116.   @l2: in al,dx; test al,8; jz @l2; end;
  117.  
  118. procedure Setpalette;
  119. var I : byte;
  120. begin
  121.   for I := 1 to 64 do begin
  122.     port[$3c8] := I;
  123.     port[$3c9] := 10+I div 3;
  124.     port[$3c9] := 5+I div 2;
  125.     port[$3c9] := I;
  126.   end;
  127. end;
  128.  
  129. {Procedure redac;
  130. var regs : registers;
  131. begin
  132.   regs.ah := $10;
  133.   regs.al := $12;
  134.   regs.bx := $00;
  135.   regs.cx := $100;
  136.   regs.dx := ofs(colors);
  137.   regs.es := seg(colors);
  138.   intr($10, regs);
  139. end;}
  140.  
  141. procedure Bobs;
  142. var X,Y : integer; I1,I2,J1,J2 : byte;
  143. begin
  144.   I1 := 60; I2 := 100; J1 := 55; J2 := 200;
  145.   repeat
  146.     X := Stab[I1]+Stab[I2]; Y := Stab[J1]+Stab[J2];
  147.     inc(I1,2); inc(I2,3); inc(J1); inc(J2,2);
  148.     Retrace;
  149.     DrawSprite(80+X,Y,16,16,addr(SprPic));
  150.   until keypressed;
  151. end;
  152.  
  153. begin
  154.   CalcSinus;
  155.   SetGraphics($13);
  156.   SetPalette;
  157.   {redac;}
  158.   Bobs;
  159.   SetGraphics(3);
  160. end.
  161.  
  162. { DrawSprite procedure taken from Sean Palmer (again).
  163.   It contained some minor bugs: [X] was added to AX, should be DI, and
  164.   jz @S was jnz @S, so the sprite wasn't drawn. Now it is...
  165.   And of course it was changed to INCREASE the video-mem, not to poke it.
  166.  
  167.   If you get rid of the Retrace it goes a LOT faster. }
  168.