[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]

    {$M 4096,0,0}
    {$a+,b-,d+,e-,f-,g+,i+,l+,n-,o-,p-,q-,r-,s+,t-,v+,x+}

    { if you have a 386 or better 'uncomment' the next line }
    {define cpu386}

    { if you want circles 'incomment' the next line }
    {$define CIRCLES }

    Program WrmhDance; { Demo by Wil Barath Oct 1994, Public Domain }
         { Based on Vortex demo by ??? }
    Var
      Map:word; {used as a pointer to the bitmap}
      stab,ctab:array[0..255] of integer;
      virseg:word;
      lstep:byte;
    const
      vidseg:word=$a000;
      pfx=1;    {try '1' for weird palette fx}
      SlowMode:Boolean=False;
      Circles:Boolean=False;
    Procedure AllocateMem;  {returns a segment pointer for a 64K bitmap}
    label noerror;
    begin
         asm
                  mov   ah,$48
                  mov   bx,$1000     { request 64K }
                  int   $21
                  jnc   noerror
                  mov   ax,0000
         noerror: mov   Map,ax       { The segment pointer goes in Map }
                  end;
         If Map=0 then begin
            Writeln('Could not allocate enough memory');
            Writeln('Program ending...');
            Halt;end;
    end;

    Procedure GiveBackMem; {returns the memory used for the map to the system}
    begin
         asm
            mov  ah,$49
            mov  dx,Map
            mov  es,dx
            int  $21
         end;
    end;
    procedure setpal(col,r,g,b : byte); assembler;
    asm
      mov dx,03c8h
      mov al,col
      out dx,al
      inc dx
      mov al,r
      out dx,al
      mov al,g
      out dx,al
      mov al,b
      out dx,al
    end;

    procedure cls(lvseg:word); assembler;
    asm
      mov es,[lvseg]
      xor di,di
      xor ax,ax
    {$ifdef cpu386}
      mov cx,256*256/4
      rep
      db $66; stosw
    {$else}
      mov cx,256*256/2
      rep stosw
    {$endif}
    end;

    procedure retrace; assembler;
    asm
      mov dx,03dah
     @vert1:
      in al,dx
      test al,8
      jnz @vert1
     @vert2:
      in al,dx
      test al,8
      jz @vert2
    end;

    Var cotable:Array[0..256] of Integer;
    Const costabptr:Pointer=(@CoTable);
    {----------------------------------------------------------------------}
    Procedure VideoMode(mode:word);assembler;
    Asm Mov ax,mode;Int 10h;end;
    Function MouseExists:Boolean;Assembler;
    asm Xor ax,ax;Int 33h;end;
    Function MouseAt(Var X:Word;Var y:Word):Word;assembler;
    asm Mov ax,03h;Int 33h;Les di,x;Mov ES:[DI],cx;Les di,y;Mov ES:[DI],dx
    Mov ax,bx;end;
    Function Readkey:Char;Assembler;
    asm Xor ax,ax;Int 16h;end;
    Function Keypressed:Boolean;Assembler;
    asm Mov ax,0100h;int 16h;Jnz @1;Xor ax,ax;@1:
    end;
    Function MouseStatus:LongInt;Assembler;
    asm Xor ax,ax;Int 33h;end;
    Procedure Pset(x,y,c:byte);Assembler;
    asm mov es,virseg;mov bh,y;Mov bl,x;Mov al,c;Mov es:[bx],al;end;
    Var ra,rb,rc:Word;
    Function rand:Word; Near ;Assembler;
    asm Mov ax,ra; Add ax,ax; Adc ax,904; Xor ax,$aaaa;Mov ra,ax;Xor ax,rb;Mov rb,ax;
    Xor ax,rc; Mov rc,ax; end;
    Function random(n:Word):Word; Near ;Assembler;
    asm Call Rand; Mul n;Mov ax,dx;end;
    Procedure mktabl;assembler;             {generates Sine approx. table}
    Const x:Integer=127*256+221;y:integer=0;{much smaller than using BP's}
    label cosloop;                          {FP math to make it!         }
    asm                                     {Oct 10/94 by Wil Barath     }
      Mov si,804      {sine portion of O }
      Mov bx,32758    {cosine portion of O }
      Mov cx,256      {number of degrees in our circle}
      Les di,costabptr{destination for our table}
      Push bp
    cosloop:
      Mov ax,x
      stosw
      Imul bx
      adc dx,dx
      Mov bp,dx       {bp:= x*cos(O)}
      Mov ax,si
      Imul y
      adc dx,dx
      Sub bp,dx       {bp:= x*cos(O)-y*sin(O)}
      Mov ax,bp
      Mov al,ah
      Mov ax,si
      Imul x
      adc dx,dx
      Mov x,bp        {x:=bp}
      Mov bp,dx       {bp:= x*sin(O)}
      Mov ax,bx
      Imul y
      adc dx,dx
      add bp,dx       {bp:= x*sin(O)+y*cos(O)}
      Mov y,bp        {y:=bp}
      Loop cosloop
      Pop bp
    end;
    {----------------------------------------------------------------------}
    Procedure DrawScreen(x,y,scale:Word;rot:word);assembler;
    label start,hloop,vloop;
    Procedure I;assembler;asm db 0;end; {fool the compiler into giving us}
    Procedure j;assembler;asm db 0;end; {2 WORD variables in CODE segment}
    asm
      push ds    { gotta save these or all hell breaks loose :-( }
      Push bp
      Mov bx,rot {compute scanning vectors}
      Add bx,bx
      Mov ax,word(cotable[bx])
      Imul scale {result in dx = scale*(ah/256)+scale*(al/65536)}
      Mov si,dx  {thusly si:=costable[rot]*scale/256}
      Add bx,128
      AND bx,511
      Mov ax,word(cotable[bx])
      Imul scale
      Mov cx,dx  {cx:=costable[(rot+64)Mod 256]*scale/256}
                 {this gives us the same as sin(...)}
      Mov bx,x   {compute screen center for rotation}
      Mov ax,160
      Mul si
      Sub bx,ax
      Mov ax,100
      Mul cx
      add bx,ax
      Mov Word(i),bx    {i:=x-si*160+cx*100}
     Mov bx,y
      Mov ax,160
      Mul cx
      Sub bx,ax
      Mov ax,100
      Mul si
      Sub bx,ax
      Mov Word(j),bx    {j:=y-cx*160-si*100}
      Mov  bp,cx        { put movement vector component here...}
                        { from here on we can't reference STACK variables...}
      mov  ax,[Map]     { get segment of bitmap (in the DATA segment)}
      mov  ds,ax
      mov  ax,$a000     { set es: to video memory}
      mov  es,ax
      sub  di,di        { start at 0,0 on the screen}
      mov  cx,200       { Number of rows on Screen}
    {-----This section has been hyper-optimised for 286+-------------------}
    vloop:
      push cx
      mov  bx,Word(j)   { start scanning the source bitmap}
      mov  dx,Word(i)   { at i,j which were calculated above.}
      mov  cx,160       { Number of columns on screen/2}
    hloop:
      add  bx,bp        { add the 'right' vector }
      add  dx,si    { add the 'down' vector }
      xchg bl,dh        { set up 8.8 fixed w/ Right MOD 256 and Down MOD 256}
      mov  al,[bx]      { load a pixel from source }
      xchg bl,dh        { restore the counting registers}
      add  bx,bp        { add the 'right' vector }
      add  dx,si    { add the 'down' vector }
      xchg bl,dh        { set up 8.8 fixed w/ Right MOD 256 and Down MOD 256}
      mov  ah,[bx]      { load a pixel from source }
      Stosw        { write and advance 2
    pixels (could do 4 w/386!)}
      xchg bl,dh        { restore the counting registers}
      Loop  hloop       { End of horizontal loop}
      dec  si;dec bp  { Unquote one or both of these to cause mag. f/x}
      sub  Word(i),bp   { i,j is the starting coords for a line }
      add  Word(j),si   { so this moves down one line }
      Pop  cx
      loop vloop        { End of verticle loop }
    {-----That's all there is to the actual screen-writing section!--------}
      Pop  bp
      pop  ds           { Restore the ds }
    end;
    {----------------------------------------------------------------------}
    var ax,ay,mx,my,x,y,h,i,j:word; c:byte;
        rot,dist,mouse:Word;
        dr,dx,dy,dd:Integer;

    procedure Circle(cx,cy,r,c:Integer);
    var rr,xx,yy:longint;x320,y320,p:Word;x,y:Integer;
    label Draw;
    begin
      rr:=r;y:=0;x:=r;rr:=r*r;xx:=rr-x;yy:=0;
      x320:=x*256;y320:=y;p:=cx+cy*256;
      asm
        Jmp @Skip
    @Curse:
        Add di,dx    {dx is the x offset from center}
        Mov es:[di+bx],al  {draw 4 cursor positions}
        Neg bx
        Mov es:[di+bx],al
        Sub di,dx
        Sub di,dx
        Mov es:[di+bx],al
        Neg bx
        Mov es:[di+bx],al
        Add di,dx
        Ret
    Draw:
        Mov es,VirSeg
        Mov di,p     {di is the center of the circle}
        Mov bx,y320   {bx is the Y offset from center}
        Mov dx,x
        Mov ax,c
        Call @Curse  {draw the 4 cursors in their quadrants}
        Mov bx,x320
        Mov dx,y
        Call @Curse  {draw the 4 cursors at 90 degrees}
        ret
    @Skip:
      end;
      Repeat
        if xx>(rr-yy) then
        Begin
    {      asm call draw;end;{}
          Inc(xx,1-x-x);dec(x);dec(x320,256);
        end;
        asm call draw;end;
        Inc(yy,y+y+1);inc(y);inc(y320,256);
      Until x<y;
    end;{}

    Procedure DoStars;
    var dsa,dsb,dsc,l:word;
    const x:Word=0;
    Begin
      inc(x,2);
      dsa:=ra;dsb:=rb;dsc:=rc;
      ra:=0;rb:=0;rc:=0;
      For l:=0 to 1024 do Mem[VirSeg:rand+x]:=240+rand AND $15;
      ra:=dsa;rb:=dsb;rc:=dsc;
    end;

    begin
      ra:=1;
      MouseStatus;
      AllocateMem;
      mktabl;
      mx:=128*256; my:=32*256;         {this corresponds to (128,32) in fixed
    point}
      rot:=192; dr:=1;          {rotation angle and it's delta}
      dist:=500; dd:=Word(0);  {distance to bitmap (sort of) and its delta}
      videomode($13);
      for i:=0 to 255 do begin
        ctab[i]:=cotable[i] div 400;
        stab[i]:=cotable[Byte(i+64)]div 640;
      end;
      virseg:=Map;
      x:=30; y:=90;
      repeat
      cls(virseg);
      {  retrace;{}
        dostars;
        c:=3; lstep:=33;
        if mx<128 then ax:=x else ax:=256-x;
        if my<128 then ay:=y else ay:=256-y;
       for i:=1 to 255 do Setpal(i,i+i+ax shr pfx,i+i+ay shr
    pfx,i+i+(ax+ay)shr (pfx+1));
        While c<20 do
        Begin
          j:=(c*(c+3))SHR(2)+5;
          i:=0;
       ax:=ctab[Byte(x-j+200)];
          ay:=stab[Byte(y-j+200)];
    {$ifdef CIRCLES}
          If Circles then circle(ax+160,ay+100,j,c)
          Else If Random(1000)=3 then Begin Circles:=True; SlowMode:=True; end;
    {$endif}
          If SlowMode then
        Begin
          DrawScreen(mx,my,dist,lo(rot));
            If Random(200)=0 then SlowMode:=False;
          end;
          Inc(c);
        end;
        DRAWScreen(mx,my,dist,lo(rot));
        If random(10)=0 then
      Begin
        dx:=dx+random(51)-25;
          dx:=dx*6 Div 9;
        end;
        If random(20)=0 then
      Begin
        dy:=dy+random(51)-25;
          dy:=dy*6 div 9;
        end;
        x:=Byte((x+dx+x+random(2)) SHR 1);
        y:=Byte((y+dy+y+random(2)) SHR 1);
        If Random(12)=0 then
       Begin
         dd:=dd+10-Random(21);
            dd:=dd*7 DIV 8;
          end;
        If Random(50)=1 then
       Begin
         dr:=dr+3-Random(7);
            dr:=dr*8 DIV 9;
          end;
            rot:=rot+dr;
            mouse:=MouseAt(mx,my);
            Case Mouse of
              1: Inc(dist,1+(dist SHR 4));
              2: Dec(dist,1+(dist SHR 4));
              3: dist:=1000;
              4: rot:=mx;
            end;
            mx:=mx*100;my:=my*256;
            if ((dist+dd)>500) THEN DD:=-5;
        If ((dist+dd)<10) then dd:=10;
            dist:=dist+dd;
      until keypressed;
      while keypressed do readkey;
         GiveBackMem;
         VideoMode($03);
    end.

[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]