home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / scape2.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-21  |  7KB  |  227 lines
  1.  
  2. program landscape_2d;
  3. { Perspective Landscape v3.0. By Bas van Gaalen, Holland, PD
  4.   A real piece of art (if it was bugless)! }
  5. const
  6.   vseg=$a000;
  7.   dy=6;
  8.   a_density=6;
  9.   roughness=30;
  10.   maxh=128;
  11.   maxx_scape=320;
  12.   maxy_scape=200;
  13.   maxx=180 div a_density;
  14.   maxy=180 div a_density;
  15. var
  16.   base:array[0..350 div dy] of pointer;
  17.   landscape:pointer;
  18.  
  19. { mouse routines ----------------------------------------------------------- }
  20.  
  21. function mouseinstalled:boolean; assembler; asm
  22.   xor ax,ax; int 33h; cmp ax,-1; je @skip; xor al,al; @skip: end;
  23.  
  24. function getmousex:word; assembler; asm
  25.   mov ax,3; int 33h; mov ax,cx end;
  26.  
  27. function getmousey:word; assembler; asm
  28.   mov ax,3; int 33h; mov ax,dx end;
  29.  
  30. function leftpressed:boolean; assembler; asm
  31.   mov ax,3; int 33h; and bx,1; mov ax,bx end;
  32.  
  33. function rightpressed:boolean; assembler; asm
  34.   mov ax,3; int 33h; and bx,2; mov ax,bx end;
  35.  
  36. procedure mousesensetivity(x,y:word); assembler; asm
  37.   mov ax,1ah; mov bx,x; mov cx,y; xor dx,dx; int 33h end;
  38.  
  39. procedure mousewindow(l,t,r,b:word); assembler; asm
  40.   mov ax,7; mov cx,l; mov dx,r; int 33h; mov ax,8
  41.   mov cx,t; mov dx,b; int 33h end;
  42.  
  43. { lowlevel video routines -------------------------------------------------- }
  44.  
  45. procedure setvideo(m:word); assembler; asm
  46.   mov ax,m; int 10h end;
  47.  
  48. procedure putpixel(x,y:word; c:byte); assembler; asm
  49.   mov ax,vseg; mov es,ax; mov ax,y; mov dx,320; mul dx
  50.   mov di,ax; add di,x; mov al,c; mov [es:di],al end;
  51.  
  52. function getpixel(x,y:word):byte; assembler; asm
  53.   mov ax,vseg; mov es,ax; mov ax,y; mov dx,320; mul dx
  54.   mov di,ax; add di,x; mov al,[es:di] end;
  55.  
  56. procedure setpal(c,r,g,b:byte); assembler; asm
  57.   mov dx,03c8h; mov al,c; out dx,al; inc dx; mov al,r
  58.   out dx,al; mov al,g; out dx,al; mov al,b; out dx,al end;
  59.  
  60. procedure retrace; assembler; asm
  61.   mov dx,03dah; @l1: in al,dx; test al,8; jnz @l1
  62.   @l2: in al,dx; test al,8; jz @l2 end;
  63.  
  64. { lowlevel memory routines ------------------------------------------------- }
  65.  
  66. function rmemb(var m; i:word):byte; assembler; asm
  67.   les di,m; add di,i; mov al,[es:di]; end;
  68.  
  69. procedure smemb(var m; i:word; v:byte); assembler; asm
  70.   les di,m; add di,i; mov al,v; mov [es:di],al; end;
  71.  
  72. function rmemw(var m; i:word):word; assembler; asm
  73.   les di,m; add di,i; add di,i; mov ax,[es:di]; end;
  74.  
  75. procedure smemw(var m; i:word; v:word); assembler; asm
  76.   les di,m; add di,i; add di,i; mov ax,v; mov [es:di],ax; end;
  77.  
  78. { initialize palette colors ------------------------------------------------ }
  79.  
  80. procedure initcolors;
  81. var i:byte;
  82. begin
  83.   for i:=0 to 63 do begin
  84.     setpal(i+1,21+i div 2,21+i div 2,63-i);
  85.     setpal(i+65,42-i div 3,42+i div 3,i div 3);
  86.   end;
  87. end;
  88.  
  89. { landscape generating routines -------------------------------------------- }
  90.  
  91. procedure adjust(xa,ya,x,y,xb,yb:integer);
  92. var d,c:integer;
  93. begin
  94.   if getpixel(x,y)<>0 then exit;
  95.   d:=abs(xa-xb)+abs(ya-yb);
  96.   c:=(50*(getpixel(xa,ya)+getpixel(xb,yb))+trunc((10*random-5)*d*roughness)) div 100;
  97.   if c<1 then c:=1;
  98.   if c>=maxh then c:=maxh;
  99.   putpixel(x,y,c);
  100. end;
  101.  
  102. procedure subdivide(l,t,r,b:integer);
  103. var x,y:integer; c:integer;
  104. begin
  105.   if (r-l<2) and (b-t<2) then exit;
  106.   x:=(l+r) div 2; y:=(t+b) div 2;
  107.   adjust(l,t,X,t,r,t);
  108.   adjust(r,t,r,Y,r,b);
  109.   adjust(l,b,X,b,r,b);
  110.   adjust(l,t,l,Y,l,b);
  111.   if getpixel(x,y)=0 then begin
  112.     c:=(getpixel(l,t)+getpixel(r,t)+getpixel(r,b)+getpixel(l,b)) div 4;
  113.     putpixel(x,y,c);
  114.   end;
  115.   subdivide(l,t,x,y);
  116.   subdivide(x,t,r,y);
  117.   subdivide(l,y,x,b);
  118.   subdivide(x,y,r,b);
  119. end;
  120.  
  121. procedure generatelandscape;
  122. var image:file; vidram:byte absolute vseg:0; i:word;
  123. begin
  124.   assign(image,'scape.dat');
  125.   {$I-} reset(image,1); {$I+}
  126.   if ioresult<>0 then begin
  127.     randomize;
  128.     putpixel(0,0,random(maxh));
  129.     putpixel(maxx_scape-1,0,random(maxh));
  130.     putpixel(maxx_scape-1,maxy_scape-1,random(maxh));
  131.     putpixel(0,maxy_scape-1,random(maxh));
  132.     subdivide(0,0,maxx_scape,maxy_scape);
  133.     rewrite(image,1);
  134.     blockwrite(image,mem[vseg:0],maxx_scape*maxy_scape);
  135.   end else blockread(image,mem[vseg:0],maxx_scape*maxy_scape);
  136.   close(image);
  137.   move(vidram,landscape^,maxx_scape*maxy_scape);
  138.   fillchar(vidram,maxx_scape*maxy_scape,0);
  139.   for i:=0 to maxx_scape*maxy_scape-1 do
  140.     smemb(landscape^,i,10+(rmemb(landscape^,i) div 2));
  141. end;
  142.  
  143. { precalculate basetables -------------------------------------------------- }
  144.  
  145. procedure precalc;
  146. const dots=maxx*maxy-1; divd=128; dist=280;
  147. type dotrec=record x,z:integer; end; dotpos=array[0..dots] of dotrec;
  148. var dot:dotpos; stab:array[0..439] of integer; st,py,n,i:word; xt,yt,x,z:integer;
  149. begin
  150.   i:=0; z:=-maxx*a_density div 2;
  151.   while z<(maxx*a_density div 2) do begin
  152.     x:=-maxy*a_density div 2;
  153.     while x<(maxy*a_density div 2) do begin
  154.       dot[i].x:=x;
  155.       dot[i].z:=z;
  156.       inc(i); inc(x,a_density);
  157.     end;
  158.     inc(z,a_density);
  159.   end;
  160.   for i:=0 to 439 do stab[i]:=round(sin(2*i*pi/349)*divd);
  161.   py:=0;
  162.   while py<350 do begin
  163.     getmem(base[py div dy],2*maxx*maxy);
  164.     for n:=0 to dots do begin
  165.       x:=(stab[py+90]*dot[n].x-stab[py]*dot[n].z) div divd;
  166.       z:=(stab[py+90]*dot[n].z+stab[py]*dot[n].x) div divd;
  167.       xt:=160+(-x*dist) div (z-dist);
  168.       yt:=100+(-40*dist) div (z-dist);
  169.       if (xt<320) and (yt<200) then st:=320*yt+xt else st:=0;
  170.       smemw(base[py div dy]^,n,st);
  171.     end;
  172.     inc(py,dy);
  173.   end;
  174. end;
  175.  
  176. { the actual displaying of the whole thing! -------------------------------- }
  177.  
  178. procedure displayscape;
  179. var pba,ba,tba,i,j,previ,prevj,n,k,l:word; x:integer;
  180. begin
  181.   pba:=0; ba:=0; i:=0; j:=0;
  182.   repeat
  183.     {retrace;
  184.     setpal(0,0,0,10);}
  185.     previ:=i; i:=getmousex; prevj:=j; j:=getmousey;
  186.     if rightpressed then begin pba:=ba; dec(ba); if ba>=(350 div dy) then ba:=(350 div dy)-1; end
  187.     else if leftpressed then begin pba:=ba; inc(ba); ba:=ba mod (350 div dy); end;
  188.     for n:=0 to maxx*maxy-1 do begin
  189.       tba:=rmemw(base[pba]^,n);
  190.       if tba>0 then
  191.         mem[vseg:rmemw(base[pba]^,n)-320*rmemb(landscape^,n mod maxx+previ+
  192.             (n div maxx+prevj)*maxx_scape)]:=0;
  193.       tba:=rmemw(base[ba]^,n);
  194.       if tba>0 then
  195.         mem[vseg:rmemw(base[ba]^,n)-320*rmemb(landscape^,n mod maxx+i+
  196.             (n div maxx+j)*maxx_scape)]:=
  197.             rmemb(landscape^,(integer(n mod maxx)+i)+
  198.             (integer(n div maxx)+j)*maxx_scape);
  199.     end;
  200.     pba:=ba;
  201.     {setpal(0,0,0,0);}
  202.   until port[$60]=1;
  203. end;
  204.  
  205. { main routine --------------------------------------------------------------}
  206.  
  207. var memory:longint; i:word;
  208. begin
  209.   if not mouseinstalled then begin writeln('need mouse.'); halt; end;
  210.   if maxavail<(maxx_scape*maxy_scape+((360 div dy)*maxx*maxy)) then begin
  211.     writeln('not enough memory.'); halt; end;
  212.   setvideo($13);
  213.   initcolors;
  214.   memory:=maxavail;
  215.   getmem(landscape,maxx_scape*maxy_scape);
  216.   generatelandscape;
  217.   precalc;
  218.   mousewindow(0,0,maxx_scape-maxx,maxy_scape-maxy);
  219.   mousesensetivity(25,25);
  220.   displayscape;
  221.   setvideo(3);
  222.   freemem(landscape,maxx_scape*maxy_scape);
  223.   for i:=0 to (350 div dy)-1 do freemem(base[i],2*maxx*maxy);
  224.   writeln('before : ',memory);
  225.   writeln('after  : ',maxavail);
  226. end.
  227.