home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / PASCAL / CONTOUR.ZIP / CONTOUR.PAS < prev    next >
Pascal/Delphi Source File  |  1988-12-07  |  8KB  |  266 lines
  1. {$N+,E+}
  2. {contour plot routines
  3.  copyright 1988, Optimal Systems Laboratory, Plainfield, NJ}
  4. unit contour;
  5.  
  6. interface
  7.  
  8. uses video,c_defs;
  9.  
  10. {procedure local_contour(block_x,block_y,
  11.   num_contours,x_size,y_size : integer);
  12.  
  13.  plots all contours within a single cell, using bilinear patch approximation.
  14.  
  15.  explicit Inputs:
  16.   block_x     x number of upper left datum for this patch
  17.   block_y     y number of upper left datum for this patch
  18.   num_contours  number of contour lines specified
  19.   x_size      number of x points in data array (used for scaling)
  20.   y_size      number of y points in data array (used for scaling)
  21.  
  22.  implicit inputs:
  23.   data_array_pointer    array of data
  24.   contours              array of contour levels
  25.  
  26.  outputs:
  27.   screen
  28.  
  29.  calls:
  30.   sign                  sign of a floating point number
  31.   make_line             draws scaled line segment on crt
  32.  }
  33.  
  34. procedure local_contour(block_x,block_y,
  35.   num_contours,x_size,y_size : integer);
  36.  
  37. {procedure contour_plot(x_size,y_size,num_contours : integer);
  38.  
  39.  plots all contours within data array, using bilinear patch approximation.
  40.  
  41.  explicit Inputs:
  42.   num_contours  number of contour lines specified
  43.   x_size      number of x points in data array
  44.   y_size      number of y points in data array
  45.  
  46.  implicit inputs:
  47.   data_array_pointer    array of data
  48.   contours              array of contour levels
  49.  
  50.  outputs:
  51.   screen
  52.  
  53.  calls:
  54.   local_contour         plots contour within single patch
  55.  }
  56.  
  57. procedure contour_plot(x_size,y_size,num_contours : integer);
  58.  
  59. implementation
  60.  
  61. {function sign(invalue : float) : float;
  62.   calculates the sign of a floating point number
  63.  
  64.  }
  65. function sign(invalue : float) : float;
  66.  
  67. var
  68.   result : float;
  69.  
  70. begin
  71.   if (invalue <0.0) then
  72.     result:= -1.0
  73.   else
  74.     result:=1.0;
  75.   sign:=result;
  76. end;
  77.  
  78. procedure local_contour(block_x,block_y,
  79.   num_contours,x_size,y_size : integer);
  80.  
  81. const
  82.   epsilon = 1.0e-3;
  83.  
  84. var
  85.   x_term,y_term,x_y_term,constant,x_value,y_value : float;
  86.   line_number : array[0..3] of integer;
  87.   i,number_of_points,contour_number : integer;
  88.   v00,v01,v10,v11 : float;
  89.   x_array,y_array : array[0..3] of float;
  90.   contour_level,min,max : float;
  91.  
  92. { procedure findxy(segment_number : integer;var x,y : float) ;
  93.   calculates the x,y coordinates of a contour line, given which
  94.  segment it penetrates
  95.  
  96.  inputs:
  97.   segment_number            0=upper segment, 1=left segment, 2=right segment
  98.                             3=bottom segment
  99.   contour_level             value of contour line
  100.   constant                  constant term of bilinear patch
  101.   x_term                    x linear term of bilinear patch
  102.   y_term                    y linear term of bilinear patch
  103.   x_y_term                  bilinear term of bilinear patch
  104.  
  105.  outputs:
  106.   x,y                       local x,y coordinates of segment intersection
  107.  }
  108.   procedure findxy(segment_number : integer;var x,y : float) ;
  109.  
  110.     begin
  111.       case (segment_number) of
  112.         {upper segment}
  113.         0 : begin
  114.           y:=0.0;
  115.           x:=(contour_level-constant)/x_term;
  116.         end;
  117.         {left segment}
  118.         1 : begin
  119.           x:=0.0;
  120.           y:=(contour_level-constant)/y_term;
  121.         end;
  122.         {right segment}
  123.         2 : begin
  124.           x:=1.0;
  125.           y:=(contour_level-constant-x_term)/(y_term+x_y_term);
  126.         end;
  127.         {bottom segment}
  128.         3 : begin
  129.           y:=1.0;
  130.           x:=(contour_level-constant-y_term)/(x_term+x_y_term);
  131.         end;
  132.       end;
  133.     end;
  134.  
  135. { procedure sort_arrays;
  136.   sorts the x,y segment intersections in order of ascending y value, via
  137.   a slow, dumb bubble sort
  138.  REVISION HISTORY:
  139.  12/7/88    modified to sort only elements 1 and 2 of the array, as it is
  140.                     guaranteed that element 0 has a y value of 0 and element 3 has
  141.                     a y value of 1 - nhj
  142.  
  143.  inputs:
  144.   x_array,y_array       arrays of segment intersections
  145.  outputs:
  146.   x_array,y_array       sorted arrays of segment intersections
  147. }
  148.   procedure sort_arrays;
  149.  
  150.     var
  151.       x_temp,y_temp : float;
  152.     begin
  153.             if (y_array[1]>y_array[2]) then
  154.               begin
  155.                 y_temp:=y_array[1];
  156.                 x_temp:=x_array[1];
  157.                 y_array[1]:=y_array[2];
  158.                 x_array[1]:=x_array[2];
  159.                 y_array[2]:=y_temp;
  160.                 x_array[2]:=x_temp;
  161.               end;
  162.     end;
  163.  
  164.   begin
  165.     {vxx are used to enhance speed by not requiring pointer arithmetic
  166.      in many places}
  167.     v00:=data_array_pointer^[block_x]^[block_y];
  168.     v01:=data_array_pointer^[block_x]^[block_y+1];
  169.     v10:=data_array_pointer^[block_x+1]^[block_y];
  170.     v11:=data_array_pointer^[block_x+1]^[block_y+1];
  171.     {set min and max values for this patch to make quick comparisons to
  172.      decide if necessary to draw contour line through this patch}
  173.     min:=v00;
  174.     max:=v00;
  175.     if (min>v01) then
  176.       min:=v01;
  177.     if (max<v01) then
  178.       max:=v01;
  179.     if (min>v10) then
  180.       min:=v10;
  181.     if (max<v10) then
  182.       max:=v10;
  183.     if (min>v11) then
  184.       min:=v11;
  185.     if (max<v11) then
  186.       max:=v11;
  187.     {calculate the terms of the bilinear equation for this patch}
  188.     constant:=v00;
  189.     x_term:=v10-constant;
  190.     y_term:=v01-constant;
  191.     x_y_term:=v11-(x_term+y_term+constant);
  192.     {for each contour line}
  193.     for contour_number:=0 to num_contours-1 do
  194.       begin
  195.         {make sure that the contour line is NOT an integer, so that it cannot
  196.          go through a corner of the patch}
  197.         contour_level:=contours^[contour_number];
  198.         if (contour_level=round(contour_level)) then
  199.           contour_level:=contour_level+epsilon;
  200.         {if this contour level requires a line in this patch}
  201.         if ((contour_level>min) and (contour_level<max))then
  202.           begin
  203.             {see how many endpoints there are, either 2 or 4}
  204.             number_of_points:=0;
  205.             {check top line first}
  206.             if (sign(v00-contour_level)<>sign(v10-contour_level)) then
  207.               begin
  208.                 line_number[number_of_points]:=0;
  209.                 number_of_points:=number_of_points+1;
  210.               end;
  211.             {now check left side line}
  212.             if (sign(v00-contour_level)<>sign(v01-contour_level)) then
  213.               begin
  214.                 line_number[number_of_points]:=1;
  215.                 number_of_points:=number_of_points+1;
  216.               end;
  217.             {now check right side line}
  218.             if (sign(v10-contour_level)<>sign(v11-contour_level)) then
  219.               begin
  220.                 line_number[number_of_points]:=2;
  221.                 number_of_points:=number_of_points+1;
  222.               end;
  223.             {check for bottom is a little easier}
  224.             if((number_of_points=1) or (number_of_points=3)) then
  225.               begin
  226.                 line_number[number_of_points]:=3;
  227.                 number_of_points:=number_of_points+1;
  228.               end;
  229.             {if we find a line needs to be drawn}
  230.             if(number_of_points>0) then begin
  231.               for  i:=0  to number_of_points-1  do
  232.                 {then calculate intersection of contour with patch sides}
  233.                 findxy(line_number[i],x_array[i],y_array[i]);
  234.               {if we have only two intersections, just draw the line}
  235.               if (number_of_points=2) then
  236.                 begin
  237.                   make_line(block_x,block_y,x_array[0],y_array[0],
  238.                     x_array[1],y_array[1],contour_number,x_size,y_size);
  239.                 end else begin
  240.                   {if we have 4 intersections (2 lines), then we need to
  241.                    sort the intersection points by y to prevent crossing of
  242.                    the contours, and to match with bilinear contour}
  243.                   sort_arrays;
  244.                   {then draw the two lines up}
  245.                   make_line(block_x,block_y,x_array[0],y_array[0],
  246.                     x_array[1],y_array[1],contour_number,x_size,y_size);
  247.                   make_line(block_x,block_y,x_array[2],y_array[2],
  248.                     x_array[3],y_array[3],contour_number,x_size,y_size);
  249.                 end;
  250.             end;
  251.         end;
  252.     end;
  253.   end;
  254.  
  255. procedure contour_plot(x_size,y_size,num_contours : integer);
  256.   var
  257.     i,j,k : integer;
  258.  
  259.   begin
  260.     for  i:=0 to x_size-2 do
  261.       for  j:=0 to y_size-2 do
  262.         local_contour(i,j,num_contours,x_size,y_size);
  263.   end;
  264.  
  265. end.
  266.