Vykreslí špirálu v 256 farbách

Kategorija: KMP (Programy mladňakoch
Zrobil: PemaSoft
Program: Spirala.pas
Subor exe: Spirala.exe

{ SPIRALA.PAS                                   Copyright (c) Corel }
{ Vykresli spiralu v 256 farbach.                                   }
{ E-Mail: pemasoft@pobox.sk                                         }
{                                                                   }
{ Datum:07.11.2000                             http://www.trsek.com }
 
Program Spiral;
 
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V-,X+,Y+}
{$M 16384,0,655360}
 
Uses Crt;
 
 
type
  RGB = Array[1..3] of Byte;
  TPalette = Array[0..255] of RGB;
 
const
  MaxX = 319;            { Dimensions of MCGA screen. }{ Waits for VGA's vertical retrace. }
procedure WaitVRetrace; Assembler;
Asm
  mov  dx, 3DAh
@@1:
  in   al, dx
  and  al, 08h
  jnz  @@1
@@2:
  in   al, dx
  and  al, 08h
  jz   @@2
end;
 
{ Sets a complete palette. }
procedure SetPal(var Palet: TPalette); Assembler;
Asm
  call  WaitVRetrace
  push  ds
  lds   si, Palet
  mov   dx, 3c8h
  mov   al, 0
  out   dx, al
  inc   dx
  mov   cx, 768
  rep   outsb
  pop   ds
end;
 
{ Flips the screen to 320x200x256 MCGA mode and puts all palette colours to
  black.
}
 
procedure SetMCGAMode;
var
  Palet: TPalette;
begin
  Asm
    mov  ax, 0013h
    int  10h
  end;
 
  FillChar(Palet, 768, 0);   { Put all palette colors to black. }
  SetPal(Palet);
end;
 
{ Flips screen back to text mode. }
procedure SetTextMode; Assembler;
Asm
  mov ax, $0003
  int 10h
end;
 
{ PutPixel in MCGA mode. }
procedure PutPixel(x, y: Word; Color: Byte); Assembler;
Asm
  mov  ax, y
  mov  bx, x
  xchg ah, al
  add  bx, ax
  shr  ax, 2
  add  bx, ax
  mov  ax, $A000
  mov  es, ax
  mov  al, Color
  mov  es:[bx], al
end;
 
{ Cycles all colours in both Palettes. }
 
procedure CyclePalettes;
var
  ColMin: RGB;
  i, j, k: Byte;
begin
  ColMin := MyPal[1];
  for i := 1 to 254 do MyPal[i] := MyPal[i+1];
  MyPal[255] := ColMin;
  ColMin := InitPal[1];
  for i := 1 to 254 do InitPal[i] := InitPal[i+1];
  InitPal[255] := ColMin;
  SetPal(MyPal);
end;
 
{ Draws a spiral on the screen. }
 
procedure DrawSpiral(Phi0: Double; Colour: Byte);
var
  x, y, i: Integer;
  Phase1, Phase2: Double;
begin
  Phase1 := Phi0;
  Phase2 := 0;
  for i := 0 to 1850 do
  begin
    x := MidX + round(Phase2*sin(Phase1));
    y := MidY + round(Phase2*cos(Phase1)/1.2);  { Divide by 1.2 to correct for non-square pixels. }
    if (x >= 0) and (x <= MaxX) and (y >= 0) and (y <= MaxY) then PutPixel(x, y, Colour);
    Phase1 := Phase1 + 0.0035*Pi;
    Phase2 := Phase2 + 0.035*Pi;
  end;
end;
 
 
begin
  SetMCGAMode;
  MyPal := Palette;
  InitPal := Palette;
 
  StartTime := Time;
  for i := 0 to 255 do                { Draw spirals in 255 different colours. }
    DrawSpiral(i*2*Pi/255, i);
  EndTime := Time;
 
  TimesRun := 0;
  Repeat
    if (TimesRun < 256) then          { Start with turning colours up. }
    begin
      for i := 0 to 255 do
        for j := 1 to 3 do
          MyPal[i,j] := round(InitPal[i,j]*TimesRun/255);
    end;
    if (TimesRun > 3000-256) then    { And end with turning colours down. }
    begin
      for i := 0 to 255 do
        for j := 1 to 3 do
          MyPal[i,j] := round(InitPal[i,j]*(3000-TimesRun)/255);
    end;
    CyclePalettes;
    Inc(TimesRun);
  Until KeyPressed or (TimesRun > 3000);
  SetTextMode;
  WriteLn('Time required to generate image: ', (EndTime-StartTime)/18.0:2:2, ' seconds.');
end.