Old Pascal sourcecode

{$M 1024,0,0}
{$R-,Q-,S-}

{ Die Farbpalette - jetzt von 768 auf 45 Bytes optimiert ;-) }

Const PAL : Array [1..45] of Byte =($0A,$0A,$0A,$12,$12,$12,$1B,$1B,$1B,$24,
$24,$24,$2D,$2D,$2D,$36,$36,$36,$3F,$3F,$3F,$10,$02,$00,$18,$07,$01,$20,$0F,
$05,$28,$18,$0A,$31,$23,$11,$35,$2B,$18,$3A,$33,$1F,$3F,$3B,$28);

{ Die Blume :-) (stammt aus TIMELESS von TRAN) }

Flower : Array [0..30,0..30] of Byte =(
(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,193,193,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,0,193,194,193,194,0,0,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,193,194,195,194,195,194,0,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,193,193,0,0,0,0,0,0,194,195,196,195,196,194,0,0,0,0,0,0,193,193,0,0,0,0),
(0,0,0,0,193,193,195,195,194,194,0,0,194,195,196,196,196,196,195,194,0,0,0,193,194,193,193,194,193,0,0),
(0,0,0,193,194,195,195,196,196,195,195,0,194,195,196,197,197,197,195,195,0,193,194,196,195,195,195,194,193,0,0),
(0,0,0,193,194,195,196,196,197,196,196,196,194,195,196,197,197,197,196,195,193,194,195,196,197,196,195,195,193,0,0),
(0,0,0,0,195,195,196,197,197,198,197,196,194,196,197,198,198,198,197,193,194,195,196,197,197,196,195,194,194,0,0),
(0,0,0,0,194,195,196,197,198,198,197,197,194,195,197,198,198,198,193,194,196,196,198,197,197,197,196,195,0,0,0),
(0,0,0,0,194,195,196,197,198,198,198,197,194,196,197,198,198,197,194,196,197,198,198,198,198,197,195,194,0,0,0),
(0,0,0,0,0,194,195,196,197,198,198,198,194,195,196,198,198,193,195,196,197,198,198,198,197,197,195,0,0,0,0),
(0,0,0,0,0,0,194,195,197,197,197,197,194,195,196,196,197,194,195,196,196,197,197,197,196,195,195,0,0,0,0),
(0,0,0,0,0,0,194,193,194,196,197,196,193,195,200,201,201,200,200,193,194,194,194,193,194,194,194,193,193,0,0),
(0,0,0,194,195,195,196,196,194,194,196,195,195,201,202,203,203,202,202,200,195,196,196,196,195,196,195,196,194,194,193),
(0,193,194,194,196,196,197,197,197,194,194,194,200,202,203,205,205,204,203,201,196,197,197,197,197,197,196,196,195,195,194),
(0,193,195,195,196,197,197,197,198,198,198,193,201,203,204,206,207,205,204,202,200,198,198,198,198,197,197,197,196,195,194),
(193,194,195,195,196,197,198,198,198,198,198,197,201,203,205,206,207,206,204,202,200,197,198,198,198,198,197,196,196,195,194),
(0,194,195,195,196,197,197,198,198,198,197,196,201,202,204,205,206,205,203,202,200,194,193,198,197,198,196,196,196,195,194),
(0,193,193,194,195,196,196,196,196,196,196,196,200,201,203,204,204,204,202,200,195,196,195,194,196,197,196,195,195,194,194),
(0,0,0,194,194,195,195,195,194,194,195,194,194,200,201,202,202,202,201,194,196,196,197,195,194,196,195,194,193,0,0),
(0,0,0,0,0,0,193,193,193,193,193,197,197,196,194,200,200,200,196,195,197,197,196,196,194,194,0,0,0,0,0),
(0,0,0,0,0,194,196,196,197,198,198,198,196,196,194,197,197,197,197,194,193,198,198,197,197,195,194,0,0,0,0),
(0,0,0,0,0,195,196,196,198,198,198,198,197,195,194,197,198,198,197,195,193,198,198,198,197,196,194,194,0,0,0),
(0,0,0,0,193,195,196,197,198,198,198,196,196,194,197,197,198,198,197,194,193,198,198,198,198,196,196,194,193,0,0),
(0,0,0,0,194,195,196,197,197,198,197,195,194,193,197,198,198,198,197,195,193,197,198,198,198,197,196,195,193,0,0),
(0,0,0,194,194,195,196,197,197,196,196,194,193,196,196,198,198,198,196,195,193,196,196,196,197,196,196,195,193,0,0),
(0,0,0,193,194,194,196,196,196,195,194,193,195,195,196,197,198,197,196,194,193,196,195,196,196,196,195,195,193,0,0),
(0,0,0,0,193,194,195,194,194,193,0,0,0,195,196,196,196,197,196,195,0,0,195,195,195,195,194,194,193,0,0),
(0,0,0,0,193,194,194,193,0,0,0,0,0,194,195,195,196,196,195,194,0,0,0,193,194,194,194,194,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,194,195,195,195,195,195,193,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,0,193,194,194,193,194,0,0,0,0,0,0,0,0,0,0,0,0));

     b  = 159; { Breite }
     h  = 199;  { Höhe   }
     hb = b/2;
     hh = h/2;
     pw = pi/180;

Var
   Pic                          : Array[0..255,0..127] of Byte; { Das Array, welches gedreht wird }
   x,dw,nx,ny,xp,yp,s,o         : Word;
   z,za,f1,f2                   : Real;
   xqd,yqd,f1i,f2i,xwd,ywd      : Integer;
   STab,CTab                    : Array [1..360] of Real;
   YOffset                      : Array [0..199] of Word;


{ VGA Karte vorhanden ???? }

Function isVGA:Boolean;Assembler;
Asm
   mov  ah, $1A
   mov  al, $00
   int  $10
   cmp  al, $1A
   jne  @NoVGA
   mov  al, 1
   jmp  @Quit
   @NoVGA:
   mov  al, 0
   @Quit:
End;

{ Keypressed - Ersatz }

Function Keypressed:Boolean;Assembler;
Asm
   mov  ah, $0b
   int  $21
   and  al, $0fe
End;

{ Das Hauptprogramm :-) }
procedure SetBorder(color : byte); assembler;
asm
   mov     dx,03C0h
   mov     al,31h
   out     dx,al
   mov     al,color
   out     dx,al
end;


Begin
     If not isVGA then
     Begin
          WriteLn('This little Demo needs VGA !!!!!!!!');
          Halt;
     End;
     Asm
        mov     ax,$13
        int     $10
     End;
     s:=Seg(pal);
     o:=Ofs(pal);
     For x:=0 to 199 do
         YOffset[x]:=x*320;
     Asm
        mov  es,s
        mov  dx,o
        mov  ax,$1012
        mov  bx,193      { Palette von Farbe 193 an setzen      }
        mov  cx,$000F    { Anzahl der zu setzenden Farben       }
        int  $10
     End;
     FillChar(Pic,SizeOf(Pic),0);
     dw:=1;x:=1;z:=0.01;za:=0.005;
     Randomize;

     { Sinus/Cosinus vorberechnen }

     For x:=1 to 360 do
     Begin
          STab[x]:=Sin(x*pw);
          CTab[x]:=Cos(x*pw);
     End;

     Repeat
           { Beginn der Rotate-Routine aus der PC-Heimwerker 8/95, allerdings
             stark verÑndert und teilweise optimiert }

           F1:=STab[dw]*z;
           F2:=CTab[dw]*z;
           f1i:=Round(f1*256);
           f2i:=Round(f2*256);
           xqd:=Round((127-(F2*hh+f1*hb))*256);
           yqd:=Round((63-(f2*hb-f1*hh))*256);
           xwd:=xqd;
           ywd:=yqd;

                Asm
                   { Segment initialisieren }
                   mov   ax, $A000
                   mov   es, ax
                   mov   x, 0

                   @xp:
                   xor   cx, cx

                   @yp:
                   { Offset berechnen }
                   mov   ax, cx
                   mov   bx, ax

                   shl   bx, 1
                   mov   dx, word ptr [YOffset+bx]
                   mov   bx, dx
                   add   bx, [x]

                   { Farbe des aktuellen Punktes holen }
                   push  cx
                   mov   ax, xwd
                   mov   cx, ywd
                   and   ch, $7F
                   mov   cl, ah
                   mov   si, cx
                   mov   al, byte ptr Pic[si]
                   pop   cx

                   { Punkt setzen - Oben links}
                   mov   di, bx
                   mov   es:[di], al

                   { Punkt setzen - Unten rechts }
                   mov   di, 63999
                   sub   di, bx
                   mov   es:[di], al

                   { Punkt setzen - Oben rechts }
                   add   dx, $13F
                   sub   dx, x
                   mov   di, dx
                   mov   es:[di], al

                   { Punkt setzen - Unten links }
                   mov   di, 63999
                   sub   di, dx
                   mov   es:[di], al

                   { xwd & ywd erhöhen }
                   mov   ax, f1i
                   add   xwd, ax
                   mov   ax, f2i
                   add   ywd, ax

                   { Schleife testen }
                   inc   cx
                   cmp   cx, h+1
                   jne   @yp

                   { Den restlichen Kram erledigen }
                   inc  f2i
                   inc  f2i
                   mov  ax, f2i
                   add  xqd, ax
                   mov  ax, f1i
                   sub  yqd, ax
                   mov  ax, xqd
                   mov  xwd, ax
                   mov  ax, yqd
                   mov  ywd, ax

                   inc   x
                   cmp   x, b+1
                   jne   @xp


                End;

           { Ende der Rotate-Routine }

           { Zoomfaktor & Drehwinkel Ñndern }
           Inc(dw);
           z:=z+za;

           If (z<0.004) or (z>1.4) then
              za:=-za;

           If dw=360 then
              dw:=1;

           { Zufällig neue Blumen einfügen }

           If dw mod 60=0{Random(100)<=5} then
           Begin
                xp:=Random(255);
                yp:=Random(128);
                For ny:=0 to 30 do
                    For nx:=0 to 30 do
                        If (xp+nx<=255) then
                        Begin
                             If (yp+ny<=127) and (Flower[nx,ny]<>0) then
                                Pic[nx+xp,ny+yp]:=Flower[nx,ny]
                             Else
                                If Flower[nx,ny]<>0 then
                                   Pic[nx+xp,(yp+ny)-128]:=Flower[nx,ny];
                        End
                        Else
                            If (yp+ny<=127) and (Flower[nx,ny]<>0) then
                               Pic[(nx+xp)-256,ny+yp]:=Flower[nx,ny]
                            Else
                                If Flower[nx,ny]<>0 then
                                   Pic[(nx+xp)-256,(yp+ny)-128]:=Flower[nx,ny];
           End;
     Until KeyPressed;
     Asm
        mov     ax,$3
        int     $10
     End;
     WriteLn('     PSYCHEDELIC-FLOWERS (c) 1996 by DiGiTAL PRoJECTS');
     For x:=0 to 79 do
         Mem[$B800:(x*2)+1]:=30;
     WriteLn;
End.