Power-Programmierung/CD1.mdf/pascal/library/dos/delite/dxfview/firework.pas

Pascal/Delphi Source File | 1992-04-01 | 5.9 KB | 220 lines

unit firework;


interface

  procedure fireworks (anz_explosions,anz_points,maxxpix,maxypix,maxcolor : word);

implementation

uses  dos,crt,kernel, VMEM;

Const max_points     = 450;
      max_explosions = 9;

Type  t_palette = array[0..16] of byte;

const standard_palette : t_palette =
        ($00,$01,$02,$03,$04,$05,$14,$07,
         $38,$39,$3a,$3b,$3c,$3d,$3e,$3f,$00);
      bright_palette   : t_palette =
        ($00,$2c,$35,$26,$2e,$27,$1e,$1b,
         $16,$3a,$2e,$2b,$2d,$3b,$3e,$3f,$0);

type  tp = record
             x,y : integer;
             dx,dy : integer;
             farbe : integer;
             dauer : integer;
           end;
      pv = array [1..max_points] of tp;
      te = record
             aktiv  : boolean;
             finish : boolean;
             mx,my  : integer;
             cfeld  : array [0..2] of word;
             anz_p  : word;
             points : pv;
           end;
      TheExplosion = Array[1..Max_Explosions] of te;

var dxmin, dxmax : integer;
    dymin, dymax : integer;
    xdiff,ydiff  : longint;
    explosions   : ^TheExplosion;
    Ready        : Boolean;
    MemHandle    : integer;

procedure fireworks (anz_explosions,anz_points,maxxpix,maxypix,maxcolor : word);
var e_no, p_i, NextRand : word;
     maxxval,maxyval    : integer;

Procedure CheckReady;
Var MyEvent : EventTyp;
    KeyConfirm    : Boolean;
    MouseConfirmR : Boolean;
    MouseConfirmL : Boolean;

Begin
  GetEvent(MyEvent);
  With MyEvent do
    Begin
      KeyConfirm    := ((Class=CtrlKey) and (Attrib = 'm')) or
                       ((Class=NormKey) and (Attrib = ESC));
      MouseConfirmR := (Class=LeMouse)  and (Char(Ord(Attrib)
                       and Ord(LeftButtonPressed)) = LeftButtonPressed);
      MouseConfirmL := (Class=LeMouse)  and (Char(Ord(Attrib)
                       and Ord(RightButtonPressed)) = RIghtButtonPressed);
      If KeyConFirm or MouseConfirmR or MouseConfirmL Then
        Ready := True;
      If (Class = NormKey) Then
        Begin
          Case Attrib of
            '1' .. '9' : Anz_Explosions := Ord(Attrib) - 48;
          End;
        End
    End;
End;

procedure InitExplosions;
var lauf : word;
begin
  dxmax :=  PortMaxX * 10 div 64;
  dxmin := -PortMaxX * 10 div 64;

  dymax := PortMaxY;
  dymin := (PortMaxY * 42) div 64;

  xdiff := dxmax-dxmin;
  ydiff := dymax-dymin;
  if anz_explosions > max_explosions then
     anz_explosions := max_explosions;
  if anz_points > max_points then
     anz_points := max_points;
  randomize;

  MemHandle := AllocatePage(SizeOf(Explosions));
  if MemHandle <> -1 then
   begin
     Explosions := GetPageAddress(MemHandle);
     for lauf := 1 to max_Explosions do
        explosions^[lauf ].aktiv := false;
   end
 else
   ready := true;  { Kein Platz für mich }
end;

procedure newexplosion(index: word);
var p_i               : word;
    rndcol            : word;
    x3,y3,rx,ry,vx,vy : integer;
    ScaleFak          : Integer;
    SoundVal          : Integer;

begin
  with explosions^[index] do
  begin
    aktiv := true; finish := false;
    mx := Random((PortMaxX * 8) div 10) + (PortMaxX div 10);
    my := ((PortMaxY * 3) div 4) - random((PortMaxY * 4) div 7);
    SoundVal := Random(200) + 50;
    Sound(SoundVal);
    rndcol := random(100);
    cfeld[0] := succ(random(maxcolor-1));
    if rndcol > 30 then cfeld[1] := succ(maxcolor-1)
    else cfeld[1] := cfeld[0];
    if rndcol > 60 then cfeld[2] := succ(random(maxcolor-1))
    else cfeld[2] := cfeld[0];
    anz_p := anz_points div anz_explosions;
    ry := 0;
    x3 := mx shl 5;
    y3 := my shl 5;
    ScaleFak := Random(12000) + 3000;
    for p_i := 1 to anz_p do
      with points[p_i] do
      begin
        x := x3;y := y3;
        farbe := cfeld[p_i mod 3];
        dauer := succ(random(50));
        repeat
          rx := ry;
          ry := random(256);
          vx := rx-128;
          vy := ry-128;
        until (vx*vx + vy*vy) < ScaleFak;
        dx :=  dxmin + integer((rx*xdiff) shr 8);
        dy := -dymin + integer((ry*ydiff) shr 8);
      end;
    end;
  nosound;
end;


begin
  initexplosions;
  maxxval  := portmaxx shl 5;
  maxyval  := portmaxy shl 5;
  Ready    := False;
  NextRand := Random(20*anz_points) + 10*anz_points;
  while not Ready do
    begin
      e_no     := succ((e_no mod max_explosions));
      NextRand := Pred(NextRand);
      If (NextRand = 0) Then
        Begin
          anz_explosions := succ(Integer(Random(10)));
          NextRand       := Random(20*anz_points) + 10*anz_points ;
        End;
      with explosions^[e_no] do
        begin
          if not aktiv then
            if e_no <= anz_explosions then
              newexplosion(e_no);
          if aktiv then
            begin
              aktiv := false;
              for p_i := 1 to anz_p do
                with points[p_i] do
                  begin
                    if dauer > 0 then SetPoint(x shr 5, y shr 5, 0)
                    else setpoint(0,0,0);
                    inc(x,dx);
                    inc(y,dy);
                    inc(dy,3);
                    if finish then dec(dauer);
                    if x >= maxxval then dauer := 0;
                    if y >= maxyval then
                      begin
                        dauer := 0;
                        finish := true;
                      end;
                    if dauer > 0 then
                      begin
                        setpoint(x shr 5, y shr 5, farbe);
                        aktiv := true;
                      end
                    else setpoint(0,0,0);
                  end;
            end;
        end;
      CheckReady;
    end;

  DeAllocatePage(MemHandle);

end;

procedure setallpalette(var new_palette: t_palette);
var regs : dos.registers;
begin
end;

function points : word;
var pno, error : integer;
begin
  points := max_points;
end;


end.