home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / pctech / 1986_08 / mandel87.pas < prev    next >
Pascal/Delphi Source File  |  1986-05-06  |  7KB  |  163 lines
  1. Program Mandelbrot87;
  2.  
  3. type
  4.    reg       = array[0..11] of byte;
  5. const
  6.    xmin      = -2.0;
  7.    xrange    =  2.6;
  8.    ymin      = -1.3;
  9.    yrange    =  2.6;
  10.  crt_index_reg     = $03D4; { Port # of Index register of 6845      }
  11.  crt_data_reg      = $03D5; { Port # of Input register of 6845      }
  12.  mode_select_reg   = $03D8; { Port # of video mode select register  }
  13.  color_select_reg  = $03D9; { Port # of video color select register }
  14. var
  15.    c,j,k,n      : integer;
  16.    x,y,dx,dy    : real;
  17.    crt_mode_set : byte absolute $0000:$0465; 
  18.    crt_palette  : byte absolute $0000:$0466; 
  19.             { Used by BIOS to maintain values of mode & color regs }
  20.    screen       : array[1..16384] of byte absolute $B800:$0000;
  21. label
  22.    quit;
  23.  
  24. {-------- CLEARS SCREEN --------------------------------------------}
  25.  
  26. Procedure ClearScreen;
  27. begin
  28.    port[mode_select_reg] := 0; { Disables video to prevent snow      }
  29.    FillChar(screen,16384,0);   { Fills screen with chr 0 attribute 0 }
  30.    port[mode_select_reg] := 9;  { Enables video to see screen        }
  31. end;
  32.  
  33. {-------- SET 6845 CRT CONTROLLER TO LO-RES MODE --------------------}
  34.  
  35. Procedure LoRes;
  36. const
  37.    regdata  :  reg = (113,80,90,10,127,6,100,112,2,1,32,0);
  38. var
  39.    i        :  byte;
  40. begin
  41.    crt_mode_set := 0;
  42.    crt_palette  := 0;
  43.    port[color_select_reg] := 0;
  44.    for i := 0 to 11 do
  45.    begin
  46.       port[crt_index_reg] := i;
  47.       port[crt_data_reg]  := regdata[i];
  48.    end;
  49.    ClearScreen;
  50.    crt_mode_set := 9;
  51. end;
  52.  
  53. {-------- SET 6845 CRT CONTROLLER TO 80x25 TEXT SCREEN -------------}
  54.  
  55. Procedure TextScreen;
  56. const
  57.     regdata  :  reg = (113,80,90,10,31,6,25,28,2,7,6,7);
  58. var
  59.    i         :  byte;
  60. begin
  61.    for i := 0 to 11 do
  62.    begin
  63.       port[crt_index_reg] := i;
  64.       port[crt_data_reg]  := regdata[i];
  65.    end;
  66.    crt_mode_set := 41;
  67.    ClrScr;
  68. end;
  69.  
  70. {-------- PLOTS POINT AT (x,y) in COLOR c --------------------------}
  71.  
  72. Procedure Point(x,y,c:integer);
  73. begin
  74.    inline($B8/$00/$02/      { MOV AX,0200H   0200 -> AX      }
  75.           $30/$FF/          { XOR BH,BH      0 -> BH         }
  76.           $8A/$56/$08/      { MOV DL,[BP+8]  x -> DL         }
  77.           $D0/$EA/          { SHR DL,1       x/2->DL,rem->CF }
  78.           $8A/$76/$06/      { MOV DH,[BP+6]  y -> DH         }
  79.           $CD/$10/          { INT 10H        locates cursor  }
  80.           $B8/$00/$08/      { MOV AX,0800H   0800 -> AX      }
  81.           $CD/$10/          { INT 10H        read attribute  }
  82.           $8A/$5E/$04/      { MOV BL,[BP+4]  c -> BL         }
  83.           $73/$05/          { JNC +5         x even => CF=0  }
  84.           $25/$00/$F0/      { AND AH,F0H     discard old fg  }
  85.           $EB/$0B/          { JMP +11        Jmp to col asmb }
  86.           $D0/$E3/          { SHL BL,1       x even so       }
  87.           $D0/$E3/          { SHL BL,1        c is bg        }
  88.           $D0/$E3/          { SHL BL,1         shift bg      }
  89.           $D0/$E3/          { SHL BL,1          left 4 bits  }
  90.           $25/$00/$0F/      { AND AH,0FH     discard old bg  }
  91.           $00/$E3/          { ADD BL,AH      assemble color  }
  92.           $B8/$DE/$09/      { MOV AX,09DE    chr ▐ to AH     }
  93.           $B9/$01/$00/      { MOV CX,01      one to write    }
  94.           $CD/$10);         { INT 10H        write chr, attr }
  95. end;
  96.  
  97. {-------- DETERMINE NUMBER OF ITERATIONS AT (x,y) ------------------}
  98.  
  99. Function Iterate(x,y:real):integer;
  100. var
  101.    scratch : integer;
  102. begin
  103.    Inline(
  104.       $B9/$3F/$00/     { MOV   CX,3FH             # iterates -> CX }
  105.       $9B/$D9/$E8/     { FLD1                     1 to 8087 Stack  }
  106.       $9B/$D8/$C0/     { FADD  ST(0),ST(0)        2 on Stack       }
  107.       $9B/$D8/$C0/     { FADD  ST(0),ST(0)        4 on Stack       }
  108.       $9B/$DD/$46/$0C/ { FLD   QWORD PTR [BP+12]  x to Stack       }
  109.       $9B/$DD/$46/$04/ { FLD   QWORD PTR [BP+4]   y to Stack       }
  110.       $9B/$D9/$C1/     { FLD   ST(1)              Copy x           }
  111.       $9B/$D9/$C1/     { FLD   ST(1)              Copy y           }
  112.                        { HERE:                    Loop label       }
  113.       $9B/$D9/$C1/     { FLD   ST(1)              Copy x           }
  114.       $9B/$D8/$C8/     { FMUL  ST(0),ST(0)        x*x              }
  115.       $9B/$D9/$C1/     { FLD   ST(1)              Copy y           }
  116.       $9B/$D8/$C8/     { FMUL  ST(0),ST(0)        y*y              }
  117.       $9B/$DE/$E9/     { FSUBP ST(1),ST(0)        x*x - y*y        }
  118.       $9B/$D8/$C4/     { FADD  ST(0),ST(4)        x*x - y*y + x    }
  119.       $9B/$D9/$CA/     { FXCH  ST(2)              new x <-> old x  }
  120.       $9B/$DE/$C9/     { FMULP ST(1),ST(0)        x*y              }
  121.       $9B/$D8/$C0/     { FADD  ST(0),ST(0)        2*x*y            }
  122.       $9B/$D8/$C2/     { FADD  ST(0),ST(2)        2*x*y + y        }
  123.       $9B/$D9/$C1/     { FLD   ST(1)              Copy x           }
  124.       $9B/$D8/$C8/     { FMUL  ST(0),ST(0)        x*x              }
  125.       $9B/$D9/$C1/     { FLD   ST(1)              Copy y           }
  126.       $9B/$D8/$C8/     { FMUL  ST(0),ST(0)        y*y              }
  127.       $9B/$DE/$C1/     { FADDP ST(1),ST(0)        x*x + y*y        }
  128.       $9B/$D8/$DD/     { FCOMP ST(5)              Greater than 4?  }
  129.       $9B/$DD/$7E/$FC/ { FSTSW [BP-4]             Status to Scratch}
  130.       $9B/             { FWAIT                    8087 Done?       }
  131.       $8A/$66/$FD/     { MOV   AH,[BP-3]          Status to AH     }
  132.       $9E/             { SAHF                     Status to Flags  }
  133.       $77/$02/         { JA    QUIT               x*x+y*y > 4?     }
  134.       $E2/$C3/         { LOOP  HERE               No then Loop     }
  135.                        { QUIT:                    Yes              }
  136.       $89/$4E/$14);    { MOV   [BP+20],CX         Return # iterates}
  137. end;
  138.  
  139. {-------- MAIN PROGRAM BEGINS --------------------------------------}
  140.  
  141. begin
  142.    LoRes;                              { Switch to LoRes mode       }
  143.    dx := xrange/159; dy := yrange/99;  { Scale world to screen      }
  144.    y := ymin + yrange;                 { Maximum y to top of screen }
  145.    for j := 0 to 99 do                 { 100 rows on LoRes screen   }
  146.    begin
  147.       x := xmin;                       { Minimum x to left of screen}
  148.       for k := 0 to 159 do             { 160 columns on LoRes screen}
  149.       begin
  150.          n := Iterate(x,y);       { Determine number of iterations  }
  151.          c := n div 8;            { Determine color number 0..7     }
  152.          if n mod 8 > 3 then c := c+8; 
  153.                                   { If remainder = 4..7 then bright }
  154.          Point(k,j,c);            { Plot point on screen            }
  155.          if keypressed then goto quit;   
  156.                                   { Press any key to interrupt/quit }
  157.          x := x + dx;             { Update x coordinate of point    }
  158.       end;                        { Loop until finished with row    }
  159.       y := y - dy;                { Update y coordinate of point    }
  160.    end;                           { Loop until finished with screen }
  161. quit:   repeat until keypressed;  { Hold picture until key pressed  }
  162.    TextScreen;                    { Restore normal text screen      }
  163. end.