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

{Magnify glass moving over ANY background, needs 386 machine}
{Jaco van Niekerk, jvn@rkw.rau.ac.za}
{Mail me if you have any questions/ideas/comments about this code}
program magnify_glass;
uses crt;

const r : byte = 40;                  {radius of sphere}
      h : integer = 20;               {distace from plane to focus point}
      d : byte = 80;                  {diameter of magnify glass}

var offs : array[0..22500] of integer; {150x150}
    b, v : pointer;

{This is the easiest mouse routines available!}
function initmouse: word;assembler;
{Initialize mouse driver}
asm mov ax, 0h; int 33h; end;

procedure showmousecursor;assembler;
{Instruct BIOS to show mouse cursor}
asm mov ax, 01h; int 33h; end;

procedure hidemousecursor;assembler;
{Instruct BIOS to hide mouse cursor}
asm mov ax, 02h; int 33h; end;

procedure getmousepos (var x, y, button: word);
{Return the current location of the mouse}
var x1, y1, b : word;
begin
     Asm mov ax, 03h; int 33h; mov [b], bx; mov [x1], cx; mov [y1], dx; end;
     x:=x1; y:=y1; button := b;
end;

Procedure setmousewindow (X1, Y1, X2, Y2: Word);assembler;
{Set the mouse window}
asm mov ax, 07h; mov cx,[x1]; mov dx,[x2]; int 33h; inc ax;
    mov cx,[y1]; mov dx,[y2]; int 33h; end;

procedure copyw(source : pointer; dest : pointer; cnt : word);assembler;
asm {copy [cnt] words from [source] to [dest]}
   les di, [dest]    {[dest] moves into [es:di]}
   push ds           {ds must be preserved}
   lds si, [source]  {[source] moves into [ds:di]}
   mov cx, [cnt]     {cx <- [cnt] : number of words to move}
   cld               {clear the direction flag, si will increment}
   rep movsw         {copies cx words from source to destination}
   pop ds            {restore ds to it's original state}
end;

procedure cls(dest : pointer);assembler;
asm
   les di, [dest]
   mov cx, 16000
   xor ax, ax
   db $66; rep stosw
end;

procedure calc_mask; {a bit of maths!}
{this calculates the pixel mask, to optimize the speed}
var x, y, z : integer;
    ux, uy : integer;
    sx, sy : integer;
begin
     for y:=0 to d do
         for x:=0 to d do
         begin
              ux:=x - d div 2;
              uy:=y - d div 2;
              if (ux*ux+uy*uy < r*r) then {point is defined on sphere}
              begin
                   z:=round(sqrt(r*r-ux*ux-uy*uy));
                   sx:=round((h-z)*(ux/z)); {took me 2 hours to work, these}
                   sy:=round((h-z)*(uy/z)); {two formulas out!!!}
                   {point on "s phere"}
                   offs[x+y*d]:=sy*320+sx;
              end else offs[x+y*d]:=0;
         end;
end;

procedure construct(xp, yp : word);
{if you want to optimize the code, do it in this procedure, since it}
{does all the main thingies, please send me a copy then too ;)  }
var seg1, ofs1, seg2, ofs2 : word;
    x, y : word;
    vp, hp : word;
    ux, uy : integer;
begin
     seg1:=seg(b^); ofs1:=ofs(b^);
     seg2:=seg(v^); ofs2:=ofs(v^);
     copyw(b,v,32000);
     for y:=0 to d do
         for x:=0 to d do
         begin
              ux:=x - d div 2;
              uy:=y - d div 2;
              vp:=y+yp+offs[y*d+x] div 320;
              hp:=x+xp+offs[y*d+x] mod 320;
              if (vp<200) and (vp>0) and (xp<320) and (xp>0) and
                 (sqr(r-1)> ux*ux+uy*uy) then
              begin
                 mem[seg2:ofs2+(y+yp)*320+x+xp]:=
                    mem[seg1:(ofs1+vp*320+hp)];
              end;
         end;
     copyw(v,ptr($a000,000),32000);
end;

procedure background;
{replace this with any background, of your choice, even a dynamic }
{background, like a fire or plasma, just remember to copy it to b^}
var i, j : integer;
begin
     directvideo:=false;
     writeln; writeln; writeln; writeln;
     textcolor(15);
     writeln('  This is a test. Please feel free');
     writeln('  to do anything you wish with this');
     writeln('  code, but please do give credit');
     writeln('  where credit is due.');
     writeln;
     writeln('  Real programmers, do!');
     writeln;
     writeln('  J v Niekerk (jvn@rkw.rau.ac.za)');
     writeln;
     writeln(' O, yes, if nothing is happening,');
     writeln(' now try moving your mouse around!!');
     directvideo:=true;

     for i:=0 to 319 do
         for j:=0 to 199 do
             if mem[$a000:320*j+i]=0 then mem[$a000:320*j+i]:=((i+j) mod 10)+20;

     copyw(ptr($a000,000),b,32000);
end;

var deg : real;
    x, y, but : word;

begin
     clrscr;
     getmem(v,64000); getmem(b,64000);

     asm
        mov ax, 13h
        int 10h
     end;

     background;
     calc_mask;
     initmouse;
     setmousewindow(5,5,315-d, 200-d);

     repeat
           getmousepos(x, y, but);
           construct(x,y);
     until but=1;

     freemem(v, 64000);
     freemem(b, 64000);
     asm
        mov ax, 03h
        int 10h
     end;
end.

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