home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / EGAMOV.ZIP / MANDEM.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-05-04  |  4.3 KB  |  143 lines
  1. {$title:'MANDEM.PAS Version 2.00' $pagesize:55 $linesize:96}
  2. {$symtab- $debug-}
  3. program mandem(input,output);
  4. const lm='                    ';
  5. type chunk=record
  6.             val1,val2,val3,val4:lstring(23);
  7.             littlechunk : array[0..319,0..199] of byte;
  8.      end;
  9.      band=record
  10.             frequency:word;
  11.             color_ind:integer;
  12.      end;
  13.      color_bands=array [0..255] of band;
  14. function writfil(var fnam:lstring;count:word;buffer:adsmem):word;extern;
  15. function readfil(var fnam:lstring;count:word;buffer:adsmem):word;extern;
  16. function allmqq(wants:word):adsmem;extern;
  17. function egamove(mode:integer;buf1,buf2:adsmem):word;extern;
  18. label 13;
  19. var adchunk:ads of chunk;
  20.     bfa:ads of byte;
  21.     answ:char;
  22.     r0:word;
  23. {$page+}
  24. procedure load_mand;
  25. var pfname:lstring(65);
  26.     cb:color_bands;
  27.     x,y,y0,binx,binx0:integer;
  28.     w,res,limit:word;
  29.     color:array[0..15] of byte;
  30. begin
  31.    writeln('Enter Mandelbrot picture filespec:');
  32.    readln(pfname);
  33.    res:=readfil(pfname,sizeof(adchunk^),adchunk);
  34.    if res=#ffff then
  35.       begin writeln('File not read.');return end;
  36.    writeln('Analyzing Mandelbrot picture array...');
  37.    for x:=0 to 255 do
  38.       cb[x].frequency:=0;
  39.    for x:=0 to 319 do
  40.       for y:=0 to 199 do
  41.          begin
  42.             binx:=ord(adchunk^.littlechunk[x,y]);
  43.             cb[binx].frequency:=cb[binx].frequency+1
  44.          end;
  45.    cb[255].color_ind:=0;
  46.    limit:=(64000 - cb[255].frequency) div 15;
  47.    binx0:=1;
  48.    while binx0<16 do
  49.       begin
  50.          y0:=0;w:=0;binx:=1;
  51.          for x:=0 to 254 do
  52.             begin
  53.                cb[x].color_ind:=7;
  54.                w:=w+cb[x].frequency;
  55.                if w>=limit then
  56.                   begin
  57.                      for y:=y0 to x do
  58.                         cb[y].color_ind:=binx mod 16;
  59.                      binx:=binx+1;y0:=x+1;w:=0
  60.                   end
  61.             end;
  62.          limit:=limit div 2;binx0:=binx;
  63.       end;
  64.    for x:=0 to 15 do color[x]:=wrd(x);
  65.    writeln('Creating display buffer...');
  66.    for y:=0 to 199 do
  67.       begin
  68.          x:=0;
  69.          while x<=319 do
  70.             begin
  71.                binx0:=ord(adchunk^.littlechunk[x,y]);
  72.                binx:=ord(adchunk^.littlechunk[x+1,y]);
  73.                bfa^:=16*color[cb[binx0].color_ind]+
  74.                   color[cb[binx].color_ind];
  75.                x:=x+2;bfa.r:=bfa.r+1
  76.            end
  77.       end;
  78.    writeln('Cancel display by pressing ESC.');
  79.    w:=0;while w<15000 do w:=w+1;
  80.    bfa.r:=r0;res:=egamove(13,bfa,bfa);
  81.    case res of
  82.       0:writeln('Display generated successfully.');
  83.       1:writeln('EGA not attached.');
  84.       2:writeln('Illegal mode invoked.');
  85.       otherwise writeln('Unknown error',res,' occured.')
  86.    end;
  87. end;{load_mand}
  88. {$page+}
  89. procedure load_dump;
  90. var pfdump:lstring(65);
  91.     w,res:word;
  92. begin
  93.    writeln('Enter screen dump filespec:');
  94.    readln(pfdump);
  95.    res:=readfil(pfdump,32000,bfa);
  96.    if res<>#ffff then writeln('File ',pfdump,' read.')
  97.    else begin writeln('Read error occured.');return end;
  98.    writeln('Cancel display by pressing ESC.');
  99.    w:=0;while w<15000 do w:=w+1;
  100.    bfa.r:=r0;res:=egamove(13,bfa,bfa);
  101.    case res of
  102.       0:writeln('Display generated successfully.');
  103.       1:writeln('EGA not attached.');
  104.       2:writeln('Illegal mode invoked.');
  105.       otherwise writeln('Unknown error',res,' occured.')
  106.    end;
  107. end;{load_dump}
  108. procedure save_dump;
  109. var pfdump:lstring(65);
  110.     res:word;
  111. begin
  112.    writeln('Enter screen dump filespec:');
  113.    readln(pfdump);
  114.    res:=writfil(pfdump,32000,bfa);
  115.    if res<>#ffff then writeln('File ',pfdump,' written.')
  116.    else writeln('Write error occured.')
  117. end;{save_dump}
  118. {$page+}
  119. begin
  120.    adchunk:=allmqq(sizeof(adchunk^));
  121.    bfa:=allmqq(32000);r0:=bfa.r;
  122.    if (adchunk.r<=1) or (bfa.r<=1) then
  123.       begin writeln('Insufficient memory.');goto 13 end;
  124.    repeat
  125.       writeln(lm,'Select one of the following:');
  126.       writeln(lm,'m: Load Mandelbrot pic file.');
  127.       writeln(lm,'l: Load Screen dump file.');
  128.       writeln(lm,'s: Save Screen dump file.');
  129.       writeln(lm,'x: Exit program.');
  130.       writeln;
  131.       write(lm,':');
  132.       readln(answ);
  133.       case answ of
  134.          'm':load_mand;
  135.          'l':load_dump;
  136.          's':save_dump;
  137.          'x':break;
  138.          otherwise
  139.       end
  140.    until not true;
  141. 13:writeln('Exiting program.')
  142. end.{mandem}
  143.