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

    {another plasma. Uses John Bridges' 360x480x256 non standard vga mode,
     somebody elses plasma routine, yet another person's palette cycle
     routine, and my color mutator. }

    uses crt,printer;
    Const
      granularity=0.5;
      EndProgram:Boolean=False;
      DelayFactor:Byte=20;
      skyr=0;
      skyg=0;
      skyb=55;

    var
      pal:array[0..773] of byte;
      r,g,b,dir,which:byte;
      i,j,counter:integer;
      ch:char;

    {$F+}
    procedure set360x480;
    {courtesy of John Bridges}
    begin
       asm
          push si
          push di
          mov ax,12h     {clear video memory with bios}
          int 10h        {and set 640x480x16 mode}
          mov ax,13h     {set 320x200x256 mode with bios}
          int 10h
          mov dx,3c4h    {alter sequencer registers}
          mov ax,0604h   {disable chain 4}
          out dx,ax
          mov ax,0100h   {syncronus reset}
          out dx,ax
          mov dx,3c2h
          mov al,0e7h
          out dx,al
          mov dx,3c4h
          mov ax,0300h
          out dx,ax
          mov dx,3d4h
          mov al,11h
          out dx,al
          inc dx
          in al,dx
          and al,7fh
          out dx,al
          dec dx
          mov ax,06b00h  {horiz total}
          out dx,ax
          mov ax,05901h  {horiz displayed}
          out dx,ax
          mov ax,05a02h  {start horiz blanking}
          out dx,ax
          mov ax,08e03h  {end horiz blanking}
          out dx,ax
          mov ax, 05e04h  {start h sync}
          out dx,ax
          mov ax, 08a05h  {end h sync}
          out dx,ax
          mov ax, 00d06h  {vertical total}
          out dx,ax
          mov ax, 03e07h  {overflow}
          out dx,ax
          mov ax, 04009h  {cell height}
          out dx,ax
          mov ax, 0ea10h  {v sync start}
          out dx,ax
          mov ax, 0ac11h  {v sync end and protect cr0-cr7}
          out dx,ax
          mov ax, 0df12h  {vertical displayed}
          out dx,ax
          mov ax, 02d13h  {offset}
          out dx,ax
          mov ax, 00014h  {turn off dword mode}
          out dx,ax
          mov ax, 0e715h  {v blank start}
          out dx,ax
          mov ax, 00616h  {v blank end}
          out dx,ax
          mov ax, 0e317h  {turn on byte mode}
          out dx,ax
         pop di
         pop si
       end;
    end;

    procedure dot360x480(drawx,drawy,color:word);
    begin
       asm
           mov ax,0a000h                {VGA_SEGMENT}
           mov es,ax
           mov ax,90                    {SCREEN_WIDTH/4}
           mul DrawY
           mov di,DrawX
           shr di,1
           shr di,1
           add di,ax
           mov cl,byte ptr DrawX
           and cl,3
           mov ah,1
           shl ah,cl
           mov al,2                    {MAP_MASK}
           mov dx,03c4h                {SC_INDEX}
           out dx,ax
           mov al,byte ptr Color
           stosb                       {draw pixel}
        end;
    end;

    Function Read360x480(Readx,Ready:word):word;
    {Read360x480 PROC FAR ReadX:WORD, ReadY:WORD RETURNS result:WORD}
    begin
       asm
           mov ax,0a000h                {VGA_SEGMENT}
           mov es,ax
           mov ax,90                    {SCREEN_WIDTH/4}
           mul ReadY
           mov si,ReadX
           shr si,1
           shr si,1
           add si,ax
           mov ah,byte ptr ReadX
           and ah,3
           mov al,4                    {READ_MAP}
           mov dx,3ceh                 {GC_INDEX}
           out dx,ax
           SEGES mov al,[si]
           sub ah,ah
           mov @result,ax
       end;
    end;

    {$F-}

    procedure bump(var r:byte; var g:byte; var b:byte);
    {this one's mine. Inc/dec one r, g, or b value to make returned
     color one bit off from delivered one.
     Ron Nossaman       nossaman@southwind.net }
    begin
       dec(counter);
       if counter<=0 then
       begin
          counter:=random(10)+1;
          dir:=random(2);
          which:=random(3);
       end;
       dec(counter);
       case dir of
         0: case which of
             0:if r>0 then dec(r) else counter:=0;
             1:if g>0 then dec(g) else counter:=0;
             2:if b>0 then dec(b) else counter:=0;
            end;
         1: case which of
             0:if r<63 then inc(r) else counter:=0;
             1:if g<63 then inc(g) else counter:=0;
             2:if b<63 then inc(b) else counter:=0;
            end;
       end;
    end;

    Procedure CyclePalette(s,e:Byte);
    var r,g,b:byte;
        p,j:word;
    Begin
       r:=pal[s*3];
       g:=pal[s*3+1];
       b:=pal[s*3+2];
       bump(r,g,b);
       move(pal[s*3],pal[s*3+3],(e-(s))*3);
       pal[s*3]:=r;
       pal[s*3+1]:=g;
       pal[s*3+2]:=b;
     {install palette}
       for p:=0 to 255 do
       begin
          j:=p*3;
          ASM
            CLI
          END;
          Port[$3C8]:=p;
          Port[$3C9]:=pal[j];
          Port[$3C9]:=pal[j+1];
          Port[$3C9]:=pal[j+2];
          ASM
            STI
          END;
       end;
    End;

    procedure setpixel(x,y,hue:integer);
    {with brute force (dip stick) clipping}
    begin
       if x<0 then exit;
       if y<0 then exit;
       if x>359 then exit;
       if y>479 then exit;
       dot360x480(x,y,hue);
    end;

    Procedure dopal;        {define palette}
    var iback,i3,i,j:integer;
        dir,which:byte;
    begin
       pal[0]:=0;
       pal[1]:=0;
       pal[2]:=0;
       pal[3]:=random(10)+26;
       pal[4]:=random(10)+26;
       pal[5]:=random(10)+26;
       counter:=0;
       r:=pal[3];
       g:=pal[4];
       b:=pal[5];
       for i:=1 to 255 do
       begin
          bump(r,g,b);
          pal[i*3]:=r;
          pal[i*3+1]:=g;
          pal[i*3+2]:=b;
       end;
    end;

    procedure installpal;
    var pseg,pofs:word;
    begin
        pseg:=seg(pal);
        pofs:=ofs(pal);
        set360x480;
        asm
          mov ah,$10;
          mov al,$12;
          mov bx,0;
          mov cx,256;
          mov dx,pofs;
          mov es,pseg;
          int $10;
        end;
    end;

    Procedure adjust(xa,ya,x,y,xb,yb:Integer);
    Var
      d,v:Integer;
    begin
      if read360x480(x,y)<>0 then
        Exit;
      d:=abs(xa-xb)+abs(ya-yb);
      v:=trunc((read360x480(xa,ya)+read360x480(xb,yb))/2+
          (random-0.5)*d*granularity);
      if v<1 then
        v:=1;
      if v>=255 then
        v:=255;
      setpixel(x,y,v);
    end;

    Procedure subDivide(x1, y1, x2, y2:Integer);
    Var
      x, y:Integer;
      v:Real;
    begin
      if KeyPressed then
        Exit;
      if (x2-x1 <2)and(y2-y1 <2) then
        Exit;
      x:=(x1+x2) div 2;
      y:=(y1+y2) div 2;
      adjust(x1,y1,x,y1,x2,y1);
      adjust(x2,y1,x2,y,x2,y2);
      adjust(x1,y2,x,y2,x2,y2);
      adjust(x1,y1,x1,y,x1,y2);
      if read360x480(x,y)=0 then
      begin
        v:=(read360x480(x1,y1)+read360x480(x2,y1)+read360x480(x2,y2)+
              read360x480(x1,y2))/4;
        setpixel(x,y,Trunc(v));
      end;

      SubDivide(x1,y1,x,y);
      subDivide(x,y1,x2,y);
      subDivide(x,y,x2,y2);
      subDivide(x1,y,x,y2);
    end;

    begin
       randomize;
       dopal;
       installpal;
       Randomize;
       setpixel(0,0,1+random(255));
       setpixel(359,0,1+random(255));
       setpixel(359,479,1+random(255));
       setpixel(0,479,1+random(255));
       SubDivide(0,0,359,479);
       Repeat
          cyclepalette(1,255);
          Delay(DelayFactor);
          If KeyPressed then
          Case ReadKey of
            #0:Case ReadKey of
                   #80,#75:If DelayFactor<255 then Inc(DelayFactor);{down,left}
                   #72,#77:If DelayFactor>0 then Dec(DelayFactor);{up,right}
                 end;
            #113,#81,#27 {Q,q}:EndProgram:=True;
            'p':for i:=0 to 86 do
               begin
                write(lst,i*3,': ',pal[i*9],',',pal[i*9+1],',',pal[i*9+2],'   ');
                write(lst,pal[i*9+3],',',pal[i*9+4],',',pal[i*9+5],'   ');
                writeln(lst,pal[i*9+6],',',pal[i*9+7],',',pal[i*9+8]);
               end;
          end;
        Until EndProgram;

      TextMode(lastmode);
    end.

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