home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / scrsaver.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-21  |  7KB  |  182 lines
  1.  
  2. program ScreenSaver1;
  3. { paralax screensaver, run a few times, by Bas van Gaalen, Holland, PD }
  4. uses
  5.   crt,dos;
  6.  
  7. const
  8.   Xspeed = 1;
  9.   Yspeed = 1;
  10.   NofTab = 6;
  11.   TxtCol = 31;
  12.   ColLen = 17;
  13.   ColTab : array[0..NofTab,0..ColLen] of byte = (
  14.   (3,3,11,3,11,11,15,11,15,15,7,15,7,7,8,7,8,8),
  15.   (8,8,7,8,7,7,15,7,15,15,7,15,7,7,8,7,8,8),
  16.   (1,1,9,1,9,9,11,9,11,11,9,11,9,9,1,9,1,1),
  17.   (4,4,12,4,12,12,15,12,15,15,12,15,12,12,4,12,4,4),
  18.   (3,3,11,3,11,11,15,11,15,15,11,15,11,11,3,11,3,3),
  19.   (3,3,11,3,11,11,15,11,15,15,10,15,10,10,2,10,2,2),
  20.   (4,4,12,4,12,12,15,12,15,15,11,15,11,11,3,11,3,3));
  21.  
  22.   SinTab : array[0..1000] of byte = (
  23.   100,100,100,100,100,100, 99, 99, 99, 99, 98, 98, 98, 97, 97,
  24.    96, 96, 95, 95, 94, 94, 93, 92, 92, 91, 90, 89, 88, 88, 87,
  25.    86, 85, 84, 83, 82, 81, 80, 79, 78, 77, 76, 75, 74, 73, 72,
  26.    71, 69, 68, 67, 66, 65, 64, 63, 61, 60, 59, 58, 57, 55, 54,
  27.    53, 52, 51, 50, 48, 47, 46, 45, 44, 43, 42, 41, 39, 38, 37,
  28.    36, 35, 34, 33, 32, 32, 31, 30, 29, 28, 27, 26, 26, 25, 24,
  29.    23, 23, 22, 22, 21, 20, 20, 19, 19, 19, 18, 18, 17, 17, 17,
  30.    17, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 17, 17,
  31.    17, 17, 18, 18, 18, 19, 19, 20, 20, 21, 21, 22, 22, 23, 24,
  32.    24, 25, 26, 27, 27, 28, 29, 30, 31, 32, 33, 33, 34, 35, 36,
  33.    37, 38, 39, 40, 41, 42, 43, 45, 46, 47, 48, 49, 50, 51, 52,
  34.    53, 54, 55, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68,
  35.    69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 81, 82,
  36.    83, 84, 85, 85, 86, 87, 88, 88, 89, 90, 90, 91, 91, 92, 92,
  37.    93, 93, 94, 94, 95, 95, 95, 96, 96, 97, 97, 97, 97, 98, 98,
  38.    98, 98, 99, 99, 99, 99, 99, 99, 99,100,100,100,100,100,100,
  39.   100,100,100,100,100,100,100,100,100,100,100,100,100,100,100,
  40.   100,100,100,100,100,100,100,100,100,100,100,100,101,101,101,
  41.   101,101,101,101,102,102,102,102,103,103,103,103,104,104,105,
  42.   105,105,106,106,107,107,108,108,109,109,110,110,111,112,112,
  43.   113,114,115,115,116,117,118,119,119,120,121,122,123,124,125,
  44.   126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,
  45.   141,142,143,145,146,147,148,149,150,151,152,153,154,155,157,
  46.   158,159,160,161,162,163,164,165,166,167,167,168,169,170,171,
  47.   172,173,173,174,175,176,176,177,178,178,179,179,180,180,181,
  48.   181,182,182,182,183,183,183,183,184,184,184,184,184,184,184,
  49.   184,184,184,184,184,183,183,183,183,182,182,181,181,181,180,
  50.   180,179,178,178,177,177,176,175,174,174,173,172,171,170,169,
  51.   168,168,167,166,165,164,163,162,161,159,158,157,156,155,154,
  52.   153,152,150,149,148,147,146,145,143,142,141,140,139,137,136,
  53.   135,134,133,132,131,129,128,127,126,125,124,123,122,121,120,
  54.   119,118,117,116,115,114,113,112,112,111,110,109,108,108,107,
  55.   106,106,105,105,104,104,103,103,102,102,102,101,101,101,101,
  56.   100,100,100,100,100,100,100,100,100,100,100,101,101,101,101,
  57.   102,102,102,103,103,104,104,105,105,106,106,107,108,108,109,
  58.   110,111,112,112,113,114,115,116,117,118,119,120,121,122,123,
  59.   124,125,126,127,128,129,131,132,133,134,135,136,137,139,140,
  60.   141,142,143,145,146,147,148,149,150,152,153,154,155,156,157,
  61.   158,159,161,162,163,164,165,166,167,168,168,169,170,171,172,
  62.   173,174,174,175,176,177,177,178,178,179,180,180,181,181,181,
  63.   182,182,183,183,183,183,184,184,184,184,184,184,184,184,184,
  64.   184,184,184,183,183,183,183,182,182,182,181,181,180,180,179,
  65.   179,178,178,177,176,176,175,174,173,173,172,171,170,169,168,
  66.   167,167,166,165,164,163,162,161,160,159,158,157,155,154,153,
  67.   152,151,150,149,148,147,146,145,143,142,141,140,139,138,137,
  68.   136,135,134,133,132,131,130,129,128,127,126,125,124,123,122,
  69.   121,120,119,119,118,117,116,115,115,114,113,112,112,111,110,
  70.   110,109,109,108,108,107,107,106,106,105,105,105,104,104,103,
  71.   103,103,103,102,102,102,102,101,101,101,101,101,101,101,100,
  72.   100,100,100,100,100,100,100,100,100,100,100,100,100,100,100,
  73.   100,100,100,100,100,100,100,100,100,100,100,100,100,100,100,
  74.   100,100, 99, 99, 99, 99, 99, 99, 99, 98, 98, 98, 98, 97, 97,
  75.    97, 97, 96, 96, 95, 95, 95, 94, 94, 93, 93, 92, 92, 91, 91,
  76.    90, 90, 89, 88, 88, 87, 86, 85, 85, 84, 83, 82, 81, 81, 80,
  77.    79, 78, 77, 76, 75, 74, 73, 72, 71, 70, 69, 68, 67, 66, 65,
  78.    64, 63, 62, 61, 60, 59, 58, 57, 55, 54, 53, 52, 51, 50, 49,
  79.    48, 47, 46, 45, 43, 42, 41, 40, 39, 38, 37, 36, 35, 34, 33,
  80.    33, 32, 31, 30, 29, 28, 27, 27, 26, 25, 24, 24, 23, 22, 22,
  81.    21, 21, 20, 20, 19, 19, 18, 18, 18, 17, 17, 17, 17, 16, 16,
  82.    16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18,
  83.    18, 19, 19, 19, 20, 20, 21, 22, 22, 23, 23, 24, 25, 26, 26,
  84.    27, 28, 29, 30, 31, 32, 32, 33, 34, 35, 36, 37, 38, 39, 41,
  85.    42, 43, 44, 45, 46, 47, 48, 50, 51, 52, 53, 54, 55, 57, 58,
  86.    59, 60, 61, 63, 64, 65, 66, 67, 68, 69, 71, 72, 73, 74, 75,
  87.    76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 88, 89,
  88.    90, 91, 92, 92, 93, 94, 94, 95, 95, 96, 96, 97, 97, 98, 98,
  89.    98, 99, 99, 99, 99,100,100,100,100,100,100);
  90.  
  91. var
  92.   FontSegment,FontOfset : word;
  93.  
  94. {----------------------------------------------------------------------------}
  95.  
  96. procedure SetGraphics(Mode : byte); assembler;
  97.  
  98. asm
  99.   mov AH,0
  100.   mov AL,Mode
  101.   int 10h
  102. end;
  103.  
  104. {----------------------------------------------------------------------------}
  105.  
  106. procedure GetFont(var FontSeg,FontOfs : word);
  107.  
  108. var
  109.   Regs : registers;
  110.  
  111. begin
  112.   with Regs do begin
  113.     AX := $1130;
  114.     BH := 1;
  115.     intr($10,Regs);
  116.     FontSeg := ES;
  117.     FontOfs := BP;
  118.   end;
  119. end;
  120.  
  121. {----------------------------------------------------------------------------}
  122.  
  123. procedure WriteText(Xpos,Ypos : word; Color : byte; ScrTxt : string);
  124.  
  125. var
  126.   I,J,K : byte;
  127.  
  128. begin
  129.   for I := 1 to length(ScrTxt) do
  130.     for J := 0 to 7 do
  131.       for K := 0 to 7 do
  132.         if ((mem[FontSegment:FontOfset+ord(ScrTxt[I])*8+J] shl K) and 128) <> 0 then
  133.           mem[$a000:(Ypos+J)*320+(I*8)+Xpos+K] := Color;
  134. end;
  135.  
  136. {----------------------------------------------------------------------------}
  137.  
  138. procedure Plotter;
  139.  
  140. const
  141.   StartCount = 150;
  142.  
  143. var
  144.   Xst,Yst,I,Dots,OffSet,OnSet,Countdown,TxtX,TxtY : word;
  145.   ColStart,Xstep,Ystep : byte;
  146.  
  147. begin
  148.   randomize;
  149.   Dots := (20+random(20))*(ColLen+1);
  150.   ColStart := random(NofTab+1);
  151.   Xstep := succ(random(8));
  152.   YStep := succ(random(8)); if Ystep = Xstep then inc(Ystep);
  153.   Xst := 0; Yst := 0; Countdown := 1; TxtX := 0; TxtY := 0;
  154.   repeat
  155.     while (port[$3da] and 8) <> 0 do;
  156.     while (port[$3da] and 8) = 0 do;
  157.     for I := 0 to Dots do begin
  158.       OffSet := (SinTab[(Yst+I*Ystep) mod 1000]*320)+(SinTab[(Xst+I*Xstep) mod 1000])+50;
  159.       OnSet := (SinTab[(Yst+Yspeed+I*Ystep) mod 1000]*320)+(SinTab[(Xst+Xspeed+I*Xstep) mod 1000])+50;
  160.       if mem[$a000:OffSet] <> TxtCol then mem[$a000:OffSet] := 0;
  161.       if mem[$a000:OnSet] <> TxtCol then mem[$a000:OnSet] := ColTab[ColStart,I mod (ColLen+1)];
  162.     end;
  163.     Xst := (Xst+Xspeed) mod 1000;
  164.     Yst := (Yst+Yspeed) mod 1000;
  165.     dec(Countdown); if Countdown = 0 then begin
  166.       WriteText(TxtX,TxtY,0,' press a key ');
  167.       TxtX := 50+random(132); TxtY := 50+random(100);
  168.       WriteText(TxtX,TxtY,TxtCol,' press a key ');
  169.       Countdown := StartCount;
  170.     end;
  171.   until keypressed;
  172. end;
  173.  
  174. {----------------------------------------------------------------------------}
  175.  
  176. begin
  177.   GetFont(FontSegment,FontOfset);
  178.   SetGraphics($13);
  179.   Plotter;
  180.   textmode(lastmode);
  181. end.
  182.