Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/CONTOUR.ZIP/CONTOUR.PAS

Pascal/Delphi Source File | 1988-12-07 | 8.3 KB | 266 lines

{$N+,E+}
{contour plot routines
 copyright 1988, Optimal Systems Laboratory, Plainfield, NJ}
unit contour;

interface

uses video,c_defs;

{procedure local_contour(block_x,block_y,
  num_contours,x_size,y_size : integer);

 plots all contours within a single cell, using bilinear patch approximation.

 explicit Inputs:
  block_x     x number of upper left datum for this patch
  block_y     y number of upper left datum for this patch
  num_contours  number of contour lines specified
  x_size      number of x points in data array (used for scaling)
  y_size      number of y points in data array (used for scaling)

 implicit inputs:
  data_array_pointer    array of data
  contours              array of contour levels

 outputs:
  screen

 calls:
  sign                  sign of a floating point number
  make_line             draws scaled line segment on crt
 }

procedure local_contour(block_x,block_y,
  num_contours,x_size,y_size : integer);

{procedure contour_plot(x_size,y_size,num_contours : integer);

 plots all contours within data array, using bilinear patch approximation.

 explicit Inputs:
  num_contours  number of contour lines specified
  x_size      number of x points in data array
  y_size      number of y points in data array

 implicit inputs:
  data_array_pointer    array of data
  contours              array of contour levels

 outputs:
  screen

 calls:
  local_contour         plots contour within single patch
 }

procedure contour_plot(x_size,y_size,num_contours : integer);

implementation

{function sign(invalue : float) : float;
  calculates the sign of a floating point number

 }
function sign(invalue : float) : float;

var
  result : float;

begin
  if (invalue <0.0) then
    result:= -1.0
  else
    result:=1.0;
  sign:=result;
end;

procedure local_contour(block_x,block_y,
  num_contours,x_size,y_size : integer);

const
  epsilon = 1.0e-3;

var
  x_term,y_term,x_y_term,constant,x_value,y_value : float;
  line_number : array[0..3] of integer;
  i,number_of_points,contour_number : integer;
  v00,v01,v10,v11 : float;
  x_array,y_array : array[0..3] of float;
  contour_level,min,max : float;

{ procedure findxy(segment_number : integer;var x,y : float) ;
  calculates the x,y coordinates of a contour line, given which
 segment it penetrates

 inputs:
  segment_number            0=upper segment, 1=left segment, 2=right segment
                            3=bottom segment
  contour_level             value of contour line
  constant                  constant term of bilinear patch
  x_term                    x linear term of bilinear patch
  y_term                    y linear term of bilinear patch
  x_y_term                  bilinear term of bilinear patch

 outputs:
  x,y                       local x,y coordinates of segment intersection
 }
  procedure findxy(segment_number : integer;var x,y : float) ;

    begin
      case (segment_number) of
        {upper segment}
        0 : begin
          y:=0.0;
          x:=(contour_level-constant)/x_term;
        end;
        {left segment}
        1 : begin
          x:=0.0;
          y:=(contour_level-constant)/y_term;
        end;
        {right segment}
        2 : begin
          x:=1.0;
          y:=(contour_level-constant-x_term)/(y_term+x_y_term);
        end;
        {bottom segment}
        3 : begin
          y:=1.0;
          x:=(contour_level-constant-y_term)/(x_term+x_y_term);
        end;
      end;
    end;

{ procedure sort_arrays;
  sorts the x,y segment intersections in order of ascending y value, via
  a slow, dumb bubble sort
 REVISION HISTORY:
 12/7/88    modified to sort only elements 1 and 2 of the array, as it is
                    guaranteed that element 0 has a y value of 0 and element 3 has
                    a y value of 1 - nhj

 inputs:
  x_array,y_array       arrays of segment intersections
 outputs:
  x_array,y_array       sorted arrays of segment intersections
}
  procedure sort_arrays;

    var
      x_temp,y_temp : float;
    begin
            if (y_array[1]>y_array[2]) then
              begin
                y_temp:=y_array[1];
                x_temp:=x_array[1];
                y_array[1]:=y_array[2];
                x_array[1]:=x_array[2];
                y_array[2]:=y_temp;
                x_array[2]:=x_temp;
              end;
    end;

  begin
    {vxx are used to enhance speed by not requiring pointer arithmetic
     in many places}
    v00:=data_array_pointer^[block_x]^[block_y];
    v01:=data_array_pointer^[block_x]^[block_y+1];
    v10:=data_array_pointer^[block_x+1]^[block_y];
    v11:=data_array_pointer^[block_x+1]^[block_y+1];
    {set min and max values for this patch to make quick comparisons to
     decide if necessary to draw contour line through this patch}
    min:=v00;
    max:=v00;
    if (min>v01) then
      min:=v01;
    if (max<v01) then
      max:=v01;
    if (min>v10) then
      min:=v10;
    if (max<v10) then
      max:=v10;
    if (min>v11) then
      min:=v11;
    if (max<v11) then
      max:=v11;
    {calculate the terms of the bilinear equation for this patch}
    constant:=v00;
    x_term:=v10-constant;
    y_term:=v01-constant;
    x_y_term:=v11-(x_term+y_term+constant);
    {for each contour line}
    for contour_number:=0 to num_contours-1 do
      begin
        {make sure that the contour line is NOT an integer, so that it cannot
         go through a corner of the patch}
        contour_level:=contours^[contour_number];
        if (contour_level=round(contour_level)) then
          contour_level:=contour_level+epsilon;
        {if this contour level requires a line in this patch}
        if ((contour_level>min) and (contour_level<max))then
          begin
            {see how many endpoints there are, either 2 or 4}
            number_of_points:=0;
            {check top line first}
            if (sign(v00-contour_level)<>sign(v10-contour_level)) then
              begin
                line_number[number_of_points]:=0;
                number_of_points:=number_of_points+1;
              end;
            {now check left side line}
            if (sign(v00-contour_level)<>sign(v01-contour_level)) then
              begin
                line_number[number_of_points]:=1;
                number_of_points:=number_of_points+1;
              end;
            {now check right side line}
            if (sign(v10-contour_level)<>sign(v11-contour_level)) then
              begin
                line_number[number_of_points]:=2;
                number_of_points:=number_of_points+1;
              end;
            {check for bottom is a little easier}
            if((number_of_points=1) or (number_of_points=3)) then
              begin
                line_number[number_of_points]:=3;
                number_of_points:=number_of_points+1;
              end;
            {if we find a line needs to be drawn}
            if(number_of_points>0) then begin
              for  i:=0  to number_of_points-1  do
                {then calculate intersection of contour with patch sides}
                findxy(line_number[i],x_array[i],y_array[i]);
              {if we have only two intersections, just draw the line}
              if (number_of_points=2) then
                begin
                  make_line(block_x,block_y,x_array[0],y_array[0],
                    x_array[1],y_array[1],contour_number,x_size,y_size);
                end else begin
                  {if we have 4 intersections (2 lines), then we need to
                   sort the intersection points by y to prevent crossing of
                   the contours, and to match with bilinear contour}
                  sort_arrays;
                  {then draw the two lines up}
                  make_line(block_x,block_y,x_array[0],y_array[0],
                    x_array[1],y_array[1],contour_number,x_size,y_size);
                  make_line(block_x,block_y,x_array[2],y_array[2],
                    x_array[3],y_array[3],contour_number,x_size,y_size);
                end;
            end;
        end;
    end;
  end;

procedure contour_plot(x_size,y_size,num_contours : integer);
  var
    i,j,k : integer;

  begin
    for  i:=0 to x_size-2 do
      for  j:=0 to y_size-2 do
        local_contour(i,j,num_contours,x_size,y_size);
  end;

end.