{$N+,A+,G+,F+,D-,E+,L-,R-,S-,Q-,Y-,I-}

{ The effect was coded especially for Demoded }
{ Code: bitl/7dump 2025 }

const
pattern: array[0..4*4-1] of byte =
(0,8,2,10, 12,4,14,6, 3,11,1,9, 15,7,13,5);

VGA = $A000;
MinScreenY = 1;
MaxScreenY = 197;

type
  Virtualscreen = Array[1..65535] of byte;
  Virscr = ^VirtualScreen;
var
 scr, scr2, scr3: virscr;
 vaddr, vaddr2, vaddr3: word;


procedure SetUpVirtual(VAR screenname:virscr;VAR add : word);
var n:word;
begin
  GetMem (Screenname,65535);
  add := seg (Screenname^);
  for n:=0 to 65535 do mem[add:n]:=0;
end;

procedure WaitVR; Assembler;
asm
  mov  dx, 3DAh
@w1:
    in   al, dx
    test al, 8h
  jnz  @w1
@w2:
    in   al, dx
    test al, 8h
  jz   @w2
end;

procedure setonecolor(c,r,g,b:byte);assembler;
asm
  mov dx,3c8h
  mov al,c
  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 Fblur2_(where:word);assembler;
asm
push ds
     mov ds, where
     mov es, where
     mov bx, -1  {; smear's effect factor}
     mov si, 64000
     mov cx, 320*199/4
     @blur:
        db $66; mov ax, ds:[si]
        add al, ds:[si+bx  -4]
        add al, ds:[si-320 -4]
        add al, ds:[si+320 -4]
        shr al, 2
        db $66; mov ds:[si-321], ax
        sub si, 4
     dec cx
     jnz @blur
pop ds
end;

procedure fill_dither_buffer(segs,offs,where:word); assembler;
{for y:=0 to 3 do for x:=0 to 319 do
mem[vaddr:x+y*320 +64000]:=pattern[(x and 3)+(y and 3)*4];{}
asm
 push ds
 mov es, segs
 mov si, offs

 mov di, 64000 + 8*4-1
 mov ds, where
 mov dx, 3
 @y:
   mov ax, dx
   and ax, 3
   shl ax, 2
   mov cx, 7
   @x:
      mov bx, cx
      add bx, 2
      and bx, 3
      add bx, ax
      mov bl, es:[bx+si]
      mov ds:[di], bl
      dec di
      dec cx
   jns @x
 dec dx
jns @y
pop ds
end;


PROCEDURE DrawLineH(X1,X2,Y1:integer; color:Byte;where:word);
BEGIN
if (y1<MinScreenY) or (y1>MaxScreenY) then exit;
if (x1<0) and (x2<0) then exit;
if (x1>319) and (x2>319) then exit;
if x1<0 then x1:=0;
if x1>319 then x1:=319;
if x2<0 then x2:=0;
if x2>319 then x2:=319;
     ASM
        mov  es, where
        mov  ax, y1
        mov  di, ax
        xchg ah, al     {y*256}
        shl  di, 6      {y*64}
        add  di, ax

        mov  cl, color  {set eax to color}
        mov  ch, cl
        mov  ax, cx
        db $66; shl ax, 16
        mov  ax, cx

        mov  bx, x1
        mov  dx, x2
{        cmp  bx, dx
        jl @skip_sort
        xchg bx, dx
        @skip_sort:
}
        add  di, bx     {start offset}

        inc  dx
        sub  dx, bx   {length}
        jz @exit; js @exit {}

                 test dx, 65520
                 jz @length_less_sixteen
                 mov  bx, dx
                 shr  bx, 4
                 @l16:
                    db $66; mov es:[di], ax
                    db $66; mov es:[di+4], ax
                    db $66; mov es:[di+8], ax
                    db $66; mov es:[di+12], ax
                    add di, 16
                    dec bx
                 jnz @l16

             @length_less_sixteen:
                 mov bx, dx
                 and bx, 15
                 shr bx, 2
                 jz @length_less_four
                 @l4:
                    db $66; mov es:[di], ax
                    add di, 4
                    dec bx
                 jnz @l4

             @length_less_four:
                 test dx, 2
                 jz @length_less_two
                    mov es:[di], ax
                    add di, 2
             @length_less_two:
                 test dx, 1
                 jz @exit
                    mov es:[di], al

             @exit:
  END;
END;

PROCEDURE DrawLineH_add(X1,X2,Y1:integer; color, max:Byte;where:word);
BEGIN
if (y1<MinScreenY) or (y1>MaxScreenY) then exit;
if (x1<0) and (x2<0) then exit;
if (x1>319) and (x2>319) then exit;
if x1<0 then x1:=0;
if x1>319 then x1:=319;
if x2<0 then x2:=0;
if x2>319 then x2:=319;
     ASM
        mov  es, where
        mov  ax, y1
        mov  di, ax
        xchg ah, al     {y*256}
        shl  di, 6      {y*64}
        add  di, ax

        mov  bx, x1
        mov  dx, x2
{        cmp  bx, dx
        jl @skip_sort
        xchg bx, dx
        @skip_sort:
}
        add  di, bx     {start offset}

        inc  dx
        sub  dx, bx   {length}
        jz @exit; js @exit {}

        mov bl, color
        mov bh, max

        test dx, 65532
        jz @length_less_four
        mov  cx, dx
        shr  cx, 2
        @ld:
          db $66; mov ax, es:[di]
          add al, bl; cmp al, bh; jbe @skip_clamp1; mov al, bh; @skip_clamp1:
          add ah, bl; cmp ah, bh; jbe @skip_clamp2; mov ah, bh; @skip_clamp2:
          db $66; ror ax, 16
          add al, bl; cmp al, bh; jbe @skip_clamp3; mov al, bh; @skip_clamp3:
          add ah, bl; cmp ah, bh; jbe @skip_clamp4; mov ah, bh; @skip_clamp4:
          db $66; ror ax, 16
          db $66; mov es:[di], ax
          add di, 4
          dec cx
        jnz @ld

     @length_less_four:
        test dx, 2
        jz @length_less_two
          mov ax, es:[di]
          add al, bl; cmp al, bh; jbe @skip_clamp5; mov al, bh; @skip_clamp5:
          add ah, bl; cmp ah, bh; jbe @skip_clamp6; mov ah, bh; @skip_clamp6:
          mov es:[di], ax
          add di, 2

     @length_less_two:
          test dx, 1
          jz @exit
          mov al, es:[di]
          add al, bl; cmp al, bh; jbe @skip_clamp7; mov al, bh; @skip_clamp7:
          mov es:[di], al

     @exit:
  END;
END;


PROCEDURE FillCircle3(centerX,centerY,radius:Integer; C:Byte;where:word);
VAR
   X,Y,m:Integer;
BEGIN
      x := 0;
      y := radius;
      m := 5 - 4 * radius;

      while (x <= y) do
      begin
        drawlineh(centerX - y, centerX + y, centerY - x, c, where);
        if x>0 then drawlineh(centerX - y, centerX + y, centerY + x, c, where);

        if (m > 0) then
        begin
          if x<>y then begin
          drawlineh(centerX - x, centerX + x, centerY - y, c, where);
          drawlineh(centerX - x, centerX + x, centerY + y, c, where);
          end;
          dec(y);
          m := m - y shl 3;
        end;

        inc(x);
        m:= m + (x shl 3 + 4);
      end;
end;

PROCEDURE FillCircle_Add(centerX,centerY,radius:Integer; C, max:Byte;where:word);
VAR
   X,Y,m:Integer;
BEGIN
      x := 0;
      y := radius;
      m := 5 - 4 * radius;

      while (x <= y) do
      begin
        drawlineh_add(centerX - y, centerX + y, centerY - x, c, max, where);
        if x>0 then drawlineh_add(centerX - y, centerX + y, centerY + x, c, max, where);

        if (m > 0) then
        begin
          if x<>y then begin
          drawlineh_add(centerX - x, centerX + x, centerY - y, c, max, where);
          drawlineh_add(centerX - x, centerX + x, centerY + y, c, max, where);
          end;
          dec(y);
          m := m - y shl 3;
        end;

        inc(x);
        m:= m + (x shl 3 + 4);
      end;
end;

procedure CircleRGB(x,y, d:integer; r,g,b:byte);
begin
   if r>0 then FillCircle3(x,y,d, r, vaddr);
   if g>0 then FillCircle3(x,y,d, g, vaddr2);
   if b>0 then FillCircle3(x,y,d, b, vaddr3);
end;

procedure CircleRGB_add(x,y, d:integer; r,g,b, max:byte);
begin
   if r>0 then FillCircle_Add(x,y,d, r, max, vaddr);
   if g>0 then FillCircle_Add(x,y,d, g, max, vaddr2);
   if b>0 then FillCircle_Add(x,y,d, b, max, vaddr3);
end;


{convert RGB(18bit) to indexed 8-bit color with dithering}
procedure Draw_screen(f, offset_di, offset_dx, vaddr,vaddr2,vaddr3, output:word);
begin
if (f=0) or (f=2) then
asm
mov di, offset_di
mov dx, offset_dx

push ds
push bp
mov ax, vaddr2
db $8E,$E0 {mov fs, ax}
mov ax, vaddr3
db $8e,$e8; {mov gs,ax}
mov es, output
mov ds, vaddr

mov bp, dx
@y:{for y:=0 to 199 do for x:=0 to 319 do begin}

mov si, bp  {bayer y}
and si, 3
shl si, 3
add si, 64000-2 +3
db $66; mov dx, ds:[si]
mov dh, dl
db $66; rol dx, 16
mov dh, dl
db $66; rol dx, 16

mov si, 319
@x:

mov ah, ds:[di]
db $64; mov al, [di]
db $65; mov bl, [di]
add ax, dx
add bl, dl

{col:=byte( (r*8 div 64)*32 + (g*8 div 64)*4 + (b*4 div 64) );}
shl ah, 2
shr al, 1
shr bl, 4
and ax, 0e0fch
add al, ah
add al, bl
mov es:[di], al {mem[vga:n]:=col;}{inc(n);}

{--------------------------------------------}
db $66; rol dx, 16 {@s2: mov bh, ds:[si+1111h]}

mov ah, ds:[di+2]
db $64; mov al, [di+2]
db $65; mov bl, [di+2]
add ax, dx
add bl, dh

{col:=byte( (r*8 div 64)*32 + (g*8 div 64)*4 + (b*4 div 64) );}
shl ah, 2
shr al, 1
shr bl, 4
and ax, 0e0fch
add al, ah
add al, bl
mov es:[di+2], al {mem[vga:n]:=col;}{inc(n);}
add di, 4

db $66; rol dx, 16

sub si, 4
jns @x

add di, 320
sub bp, 2
jns @y
pop bp
pop ds
end;

if (f=1) or (f=3) then
asm
push ds
push bp
mov di, offset_di
mov dx, offset_dx

mov ax, vaddr2
db $8E,$E0 {mov fs, ax}
mov ax, vaddr3
db $8e,$e8; {mov gs,ax}
mov ds, vaddr
push 0a000h
pop es

mov bp, dx
@y:{for y:=0 to 199 do for x:=0 to 319 do begin}
mov si, bp  {bayer y}
and si, 3
shl si, 3
add si, 64000-2 +2
db $66; mov dx, ds:[si]
mov dh, dl
db $66; rol dx, 16
mov dh, dl
db $66; rol dx, 16

mov si, 318
@x:

mov ah, ds:[di]
db $64; mov al, [di]
db $65; mov bl, [di]
add ax, dx
add bl, dl

{col:=byte( (r*8 div 64)*32 + (g*8 div 64)*4 + (b*4 div 64) );}
shl ah, 2
shr al, 1
shr bl, 4
and ax, 0e0fch
add al, ah
add al, bl
mov es:[di], al {mem[vga:n]:=col;}{inc(n);}

{--------------------------------------------}
db $66; rol dx, 16 {@s2: mov bh, ds:[si+1111h]}

mov ah, ds:[di+2]
db $64; mov al, [di+2]
db $65; mov bl, [di+2]
add ax, dx
add bl, dh

{col:=byte( (r*8 div 64)*32 + (g*8 div 64)*4 + (b*4 div 64) );}
shl ah, 2
shr al, 1
shr bl, 4
and ax, 0e0fch
add al, ah
add al, bl
mov es:[di+2], al {mem[vga:n]:=col;}{inc(n);}
add di, 4

db $66; rol dx, 16

sub si, 4
jns @x

add di, 320
sub bp, 2
jns @y
pop bp
pop ds
end;
end;


var
dd,qq,q,xx,yy:single;
col:byte;
d,x4,y4, x3,y3, x1,x2,y1,y2:integer;
segs,offs, n :word;
x,y:integer;
offset_di, offset_dx, f, r,g,b:word;
Aantal, T1: longint;
Timer: Longint ABSOLUTE $0040:$006C;


begin
SetUpVirtual(scr,vaddr);
SetUpVirtual(scr2, vaddr2);
SetUpVirtual(scr3, vaddr3);

asm
mov ax, 13h
int 10h
end;

segs:=seg(pattern); offs:=ofs(pattern);

n:=0;
for r:=0 to 7 do
  for g:=0 to 7 do
    for b:=0 to 3 do
     begin
     SetOneColor(n, r*9,g*9,b*21);
     inc(n);
     end;

fill_dither_buffer(seg(pattern),ofs(pattern), vaddr);

q:=0;
d:=35;

f:=0; b:=0;

Aantal:=0; T1:=Timer;


repeat
q:=q+0.2;


xx:=sin(pi*2 * (q/12) * 0.64543324)*82+160;
yy:=cos(pi*2 * (q/12) * 0.38457832)*25+140;

dd:=d*2;
qq:=q/2;
x1:=round(cos(qq)*dd+xx);
y1:=round(sin(qq)*dd+yy);
x2:=round(cos(qq+1.5)*dd+xx);
y2:=round(sin(qq+1.5)*dd+yy);
x3:=round(cos(qq+2.5)*dd+xx);
y3:=round(sin(qq+2.5)*dd+yy);
x4:=round(cos(qq+4.5)*dd+xx);
y4:=round(sin(qq+4.5)*dd+yy);


d:=round(cos(q/4)*5+14);
col:=15;{round(-cos(q)*7+8);}
CircleRGB_add(x1,y1,   d,  col,0,0,   48);
CircleRGB_add(x2,y2,   d,  0,col,0,   48);
CircleRGB_add(x4,y3,   d,  0,0,col, 48);{}
CircleRGB_add(x3,y4,   d,  col,col,0,   48);{}
CircleRGB_add(x4,y2,   d,  col,0,col,   48);{}



inc(b);
if b>2 then b:=0;

case b of
0: fblur2_(vaddr);
1: fblur2_(vaddr2);
2: fblur2_(vaddr3);
end;


{fill_dither_buffer(seg(pattern),ofs(pattern), vaddr);{}


inc(f);
f:=f and 3;
if f=0 then begin offset_di:=0;   offset_dx:=199; end;
if f=1 then begin offset_di:=320; offset_dx:=198; end;
if f=2 then begin offset_di:=1;   offset_dx:=199; end;
if f=3 then begin offset_di:=321; offset_dx:=198; end;

WaitVR;{}

{-------------------Draw frame -------------------------------}
Draw_screen(f, offset_di, offset_dx, vaddr,vaddr2,vaddr3, vga);



Inc(Aantal);

until port[$60]=1;


asm
mov ax, 03h
int 10h
end;
T1:=timer-T1;
WriteLn(Aantal/(T1/18.2):2:1,' Frames per second');

end.