home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / scape.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-21  |  5KB  |  152 lines
  1.  
  2. program landscape_2d;
  3. { 2D landscape (without rotation). Made by Bas van Gaalen, Holland, PD }
  4. const
  5.   vseg = $a000;
  6.   a_density = 4;
  7.   roughness = 20;
  8.   maxx_scape = 320; maxy_scape = 200;
  9.   maxh = 128;
  10.   maxx = 250 div a_density; maxy = 110 div a_density;
  11. var landscape : array[0..maxx_scape*maxy_scape] of byte;
  12.  
  13. { mouse routines ------------------------------------------------------------}
  14.  
  15. function mouseinstalled : boolean; assembler; asm
  16.   xor ax,ax; int 33h; cmp ax,-1; je @skip; xor al,al; @skip: end;
  17.  
  18. function getmousex : word; assembler; asm
  19.   mov ax,3; int 33h; mov ax,cx end;
  20.  
  21. function getmousey : word; assembler; asm
  22.   mov ax,3; int 33h; mov ax,dx end;
  23.  
  24. function leftpressed : boolean; assembler; asm
  25.   mov ax,3; int 33h; and bx,1; mov ax,bx end;
  26.  
  27. procedure mousesensetivity(x,y : word); assembler; asm
  28.   mov ax,1ah; mov bx,x; mov cx,y; xor dx,dx; int 33h end;
  29.  
  30. procedure mousewindow(l,t,r,b : word); assembler; asm
  31.   mov ax,7; mov cx,l; mov dx,r; int 33h; mov ax,8
  32.   mov cx,t; mov dx,b; int 33h end;
  33.  
  34. { lowlevel video routines ---------------------------------------------------}
  35.  
  36. procedure setvideo(m : word); assembler; asm
  37.   mov ax,m; int 10h end;
  38.  
  39. procedure putpixel(x,y : word; c : byte); assembler; asm
  40.   mov ax,vseg; mov es,ax; mov ax,y; mov dx,320; mul dx
  41.   mov di,ax; add di,x; mov al,c; mov [es:di],al end;
  42.  
  43. function getpixel(x,y : word) : byte; assembler; asm
  44.   mov ax,vseg; mov es,ax; mov ax,y; mov dx,320; mul dx
  45.   mov di,ax; add di,x; mov al,[es:di] end;
  46.  
  47. procedure setpal(c,r,g,b : byte); assembler; asm
  48.   mov dx,03c8h; mov al,c; out dx,al; inc dx; mov al,r
  49.   out dx,al; mov al,g; out dx,al; mov al,b; out dx,al end;
  50.  
  51. procedure retrace; assembler; asm
  52.   mov dx,03dah; @l1: in al,dx; test al,8; jnz @l1
  53.   @l2: in al,dx; test al,8; jz @l2 end;
  54.  
  55. { initialize palette colors -------------------------------------------------}
  56.  
  57. procedure initcolors;
  58. var i : byte;
  59. begin
  60.   for i := 0 to 63 do begin
  61.     setpal(i+1,21+i div 3,21+i div 3,63-i);
  62.     setpal(i+65,42-i div 3,42+i div 3,i div 3);
  63.   end;
  64. end;
  65.  
  66. { landscape generating routines ---------------------------------------------}
  67.  
  68. procedure adjust(xa,ya,x,y,xb,yb : integer);
  69. var d,c : integer;
  70. begin
  71.   if getpixel(x,y) <> 0 then exit;
  72.   d := abs(xa-xb)+abs(ya-yb);
  73.   c := (50*(getpixel(xa,ya)+getpixel(xb,yb))+trunc((10*random-5)*d*roughness)) div 100;
  74.   if c < 1 then c := 1;
  75.   if c >= maxh then c := maxh;
  76.   putpixel(x,y,c);
  77. end;
  78.  
  79. procedure subdivide(l,t,r,b : integer);
  80. var x,y : integer; c : integer;
  81. begin
  82.   if (r-l < 2) and (b-t < 2) then exit;
  83.   x := (l+r) div 2; y := (t+b) div 2;
  84.   adjust(l,t,X,t,r,t);
  85.   adjust(r,t,r,Y,r,b);
  86.   adjust(l,b,X,b,r,b);
  87.   adjust(l,t,l,Y,l,b);
  88.   if getpixel(x,y) = 0 then begin
  89.     c := (getpixel(l,t)+getpixel(r,t)+getpixel(r,b)+getpixel(l,b)) div 4;
  90.     putpixel(x,y,c);
  91.   end;
  92.   subdivide(l,t,x,y);
  93.   subdivide(x,t,r,y);
  94.   subdivide(l,y,x,b);
  95.   subdivide(x,y,r,b);
  96. end;
  97.  
  98. procedure generatelandscape;
  99. var image : file; vidram : byte absolute vseg:0000; i : word;
  100. begin
  101.   assign(image,'plasma.img');
  102.   {$I-} reset(image,1); {$I+}
  103.   if ioresult <> 0 then begin
  104.     randomize;
  105.     putpixel(0,0,random(maxh));
  106.     putpixel(maxx_scape-1,0,random(maxh));
  107.     putpixel(maxx_scape-1,maxy_scape-1,random(maxh));
  108.     putpixel(0,maxy_scape-1,random(maxh));
  109.     subdivide(0,0,maxx_scape,maxy_scape);
  110.     rewrite(image,1);
  111.     blockwrite(image,mem[vseg:0],maxx_scape*maxy_scape);
  112.   end else blockread(image,mem[vseg:0],maxx_scape*maxy_scape);
  113.   close(image);
  114.   move(vidram,landscape,sizeof(landscape));
  115.   fillchar(vidram,maxx_scape*maxy_scape,0);
  116.   for i := 0 to maxx_scape*maxy_scape-1 do landscape[i] := 110+Landscape[i] div 2;
  117. end;
  118.  
  119. { the actual displaying of the whole thing! ---------------------------------}
  120.  
  121. procedure displayscape;
  122. var i,j,previ,prevj,n,k,l : word; x : integer;
  123. begin
  124.   i := 0; j := 0;
  125.   repeat
  126.     {retrace;}
  127.     previ := i; i := getmousex; prevj := j; j := getmousey;
  128.     for n := 0 to maxx*maxy-1 do begin
  129.       x := -(a_density*(integer(n mod maxx)-(maxx shr 1)-1)*45) div (integer(n div maxx)-45)-90;
  130.       if (x >= -250) and (X <= 60) then begin
  131.         mem[vseg:320*(a_density*integer(n div maxx)-landscape[n mod maxx+previ+(n div maxx+prevj)*maxx_scape])+x] := 0;
  132.         mem[vseg:320*(a_density*integer(n div maxx)-landscape[n mod maxx+i+(n div maxx+j)*maxx_scape])+x] :=
  133.           landscape[(integer(n mod maxx)+i)+(integer(n div maxx)+j)*maxx_scape]-100;
  134.       end;
  135.     end;
  136.   until leftpressed;
  137. end;
  138.  
  139. { main routine --------------------------------------------------------------}
  140.  
  141. begin
  142.   if mouseinstalled then begin
  143.     setvideo($13);
  144.     initcolors;
  145.     generatelandscape;
  146.     mousewindow(0,0,maxx_scape-maxx,maxy_scape-maxy);
  147.     mousesensetivity(25,25);
  148.     displayscape;
  149.     setvideo(3);
  150.   end else writeln('This interactive thing realy needs a mouse...');
  151. end.
  152.