home *** CD-ROM | disk | FTP | other *** search
/ ftp.ncsa.uiuc.edu / ftp.ncsa.uiuc.edu.zip / ftp.ncsa.uiuc.edu / Contour / routines.p < prev    next >
Text File  |  2017-03-03  |  19KB  |  586 lines
  1. {$U-}
  2. {$R-}
  3. unit Routines(30);
  4.  
  5. interface
  6. uses
  7.     MemTypes, Quickdraw, OSIntf, ToolIntf,MacPrint,FixMath,Graf3D,
  8.     Globals, Utilities;
  9.     
  10. procedure InitTables;
  11. procedure contourPlot(UpdateRect:rect);
  12.  
  13. procedure CalculateLevels;
  14.  
  15. procedure DrawGrid(xlow,xhigh,ylow,yhigh : integer);
  16.     
  17. implementation
  18.  
  19. const
  20.     minY = 0;
  21.     minX = 0;
  22.  
  23. var
  24.       divisor : integer;
  25.     
  26. function cancelOp : boolean;
  27. var
  28.     myEvent : EventRecord;
  29. begin
  30.     if GetNextEvent(everyEvent,myEvent) then 
  31.         cancelOp := (myEvent.what = keyDown) and
  32.                          (BitAnd(myEvent.message, charCodeMask) = 46) and
  33.                          (BitAnd(myEvent.modifiers,cmdKey) <> 0 )
  34.     else
  35.         cancelOp := false;
  36. end;
  37.        
  38. procedure CalculateLevels;
  39. var
  40.     i : integer;
  41. begin
  42.     for i := 1 to NoOfLevels[windowIndex] do
  43.         ContourLevel[windowIndex][i] := minData[windowIndex] +
  44.                                        (maxData[windowIndex]-minData[windowIndex])
  45.                                         div NoOfLevels[windowIndex] * i;
  46. end;    
  47.  
  48. procedure InitTables;
  49. var
  50. y : integer;
  51. begin
  52.     
  53.     setPort(ContourWindow[windowIndex]);
  54.     CalculateLevels;    
  55.     
  56. end; {InitTables}
  57.     
  58. procedure SwapPtr(var x,y : ArrayPtr);
  59. var
  60.     temptr : ArrayPtr;
  61. begin
  62.     temptr := y;
  63.     y := x;
  64.     x := temptr;
  65. end;
  66.  
  67. procedure DrawGrid;{xlow,xhigh,ylow,yhigh : integer}
  68. var 
  69.     x,y : integer;
  70. begin
  71.     y := ylow+1;
  72.     while y < yhigh do begin      
  73.         MoveTo(Xlow*currentGridSize,y*currentGridSize);
  74.         LineTo(Xhigh*currentGridSize,y*currentGridSize);
  75.         y := y + 5;
  76.     end;
  77.     x := xlow+1;
  78.     while x < xhigh do begin
  79.         MoveTo(x*currentGridSize,Ylow*currentGridSize);
  80.         LineTo(x*currentGridSize,Yhigh*currentGridSize);
  81.         x := x + 5;
  82.     end;
  83. end;
  84.      
  85. procedure contourPlot;
  86. var
  87.             
  88.     x,y,
  89.     level,
  90.     segment : integer;
  91.     Xlow,Xhigh,
  92.     Ylow,Yhigh : integer;
  93.         
  94.     NoOfSegments : integer;
  95.     remainingRows : integer;
  96.     DataMin,DataMax : integer;
  97.     RealY : longint;
  98.     NoOfRows : integer;
  99.     d0,d1,d2,d3,
  100.     h0,h1,h2,h3 : longint;
  101.     posOff : longint;
  102.     jump : integer;
  103.     PState : PenState;
  104.         
  105.     procedure minMaxVertex;
  106.     begin
  107.         d0 := ord(data[y]^[x]); d1 := ord(data[y]^[x+1]);
  108.         d2 := ord(data[y+1]^[x]); d3 := ord(data[y+1]^[x+1]);
  109.             
  110.         DataMin := d0; DataMax := d0;
  111.         if (d1<DataMin) then DataMin := d1;
  112.         if (d2<DataMin) then DataMin := d2;
  113.         if (d3<DataMin) then DataMin := d3;
  114.             
  115.         if (d1>DataMax) then DataMax := d1;
  116.         if (d2>DataMax) then DataMax := d2;
  117.         if (d3>DataMax) then DataMax := d3;
  118.             
  119.     end;
  120.     
  121.  
  122.     procedure ProcessVertices;
  123.     begin
  124.         h0 := d0 - ContourLevel[windowIndex][level];
  125.         h1 := d1 - ContourLevel[windowIndex][level];
  126.         h2 := d2 - ContourLevel[windowIndex][level];
  127.         h3 := d3 - ContourLevel[windowIndex][level];
  128.             
  129.         jump := 0;
  130.         if (h0 >= 0) then jump := 8;
  131.         if (h1 >= 0) then jump := jump + 4;
  132.         if (h2 >= 0) then jump := jump + 2;
  133.         if (h3 >= 0) then jump := jump + 1;
  134.             
  135.     end; {ProcessVertices}
  136.         
  137.     Procedure ProcessTriangles;
  138.     var
  139.         x1,x2,
  140.         y1,y2 : longint;
  141.             
  142.         procedure vecout(x1,y1,x2,y2 : longint);
  143.         begin
  144.         MoveTo(x1,y1);
  145.         LineTo(x2,y2);
  146.         end;
  147.                 
  148.                         
  149.     begin
  150.         
  151.         x1 := -1;
  152.         case jump of
  153.               
  154.         1,14 :
  155.             if h3 <> 0 then begin
  156.                 x1 := currentGridSize*(x+1);
  157.                 y1 := currentGridSize*(h3*RealY - h1*(RealY+1)) div (h3-h1);
  158.                 x2 := currentGridSize*(h3*x - h2*(x+1)) div(h3-h2);
  159.                 y2 := currentGridSize*(RealY+1);
  160.                 upHill^[x] := true;
  161.         end;
  162.               
  163.         2,13 :
  164.             if h2 <> 0 then begin
  165.                 x1 := currentGridSize*x;
  166.                 y1 := currentGridSize*(h2*RealY - h0*(RealY+1)) div(h2-h0);
  167.                 x2 := currentGridSize*(h3*x - h2*(x+1)) div(h3-h2);
  168.                 y2 := currentGridSize*(RealY+1);
  169.                 upHill^[x] := false;
  170.             end;
  171.                 
  172.         3,12 : begin
  173.             x1 := x*currentGridSize;
  174.             y1 := (h2*RealY - h0*(RealY+1))*currentGridSize div(h2-h0);
  175.             x2 := (x+1)*currentGridSize;
  176.             y2 := (h3*RealY - h1*(RealY+1))*currentGridSize div(h3-h1);
  177.         end;
  178.               
  179.         4,11 :
  180.             if h1 <> 0 then begin
  181.                 x1 := currentGridSize*(h1*x - h0*(x+1)) div(h1-h0);
  182.                 y1 := currentGridSize*RealY;
  183.                 x2 := currentGridSize*(x+1);
  184.                 y2 := currentGridSize*(h3*RealY - h1*(RealY+1)) div(h3-h1);
  185.         end;
  186.               
  187.         5,10 : begin
  188.             x1 := currentGridSize*(h1*x - h0*(x+1)) div(h1-h0);
  189.             y1 := currentGridSize*RealY;
  190.             x2 := currentGridSize*(h3*x - h2*(x+1)) div(h3-h2);
  191.             y2 := currentGridSize*(RealY+1);
  192.             upHill^[x] := x1 > x2;
  193.         end;
  194.               
  195.         6,9 :
  196.             if upHill^[x] then begin
  197.                 x1 := currentGridSize*(h1*x - h0*(x+1)) div(h1-h0);
  198.                 y1 := currentGridSize*RealY;
  199.                 x2 := currentGridSize*x;
  200.                 y2 := currentGridSize*(h2*RealY - h0*(RealY+1)) div(h2-h0);
  201.                 vecout(x1,y1,x2,y2);
  202.                 x1 := currentGridSize*(x+1);
  203.                 y1 := currentGridSize*(h3*RealY - h1*(RealY+1)) div(h3-h1);
  204.                 x2 := currentGridSize*(h3*x - h2*(x+1)) div(h3-h2);
  205.                 y2 := currentGridSize*(RealY+1);
  206.                 upHill^[x] := true;
  207.             end
  208.             else begin
  209.                 x1 := currentGridSize*(h1*x - h0*(x+1)) div(h1-h0);
  210.                 y1 := currentGridSize*RealY;
  211.                 x2 := currentGridSize*(x+1);
  212.                 y2 := currentGridSize*(h3*RealY - h1*(RealY+1)) div(h3-h1);
  213.                 vecout(x1,y1,x2,y2);
  214.                 x1 := currentGridSize*x;
  215.                 y1 := currentGridSize*(h2*RealY - h0*(RealY+1)) div(h2-h0);
  216.                 x2 := currentGridSize*(h3*x - h2*(x+1)) div(h3-h2);
  217.                 y2 := currentGridSize*(RealY+1);
  218.                 upHill^[x] := false;
  219.             end;
  220.                 
  221.         7,8 :
  222.             if h0 <> 0 then begin
  223.                 x1 := currentGridSize*(h1*x - h0*(x+1)) div(h1-h0);
  224.                 y1 := currentGridSize*RealY;
  225.                 x2 := currentGridSize*x;
  226.                 y2 := currentGridSize*(h2*RealY - h0*(RealY+1)) div (h2-h0);
  227.             end;
  228.             
  229.         otherwise;
  230.                         
  231.         end; {case}
  232.     
  233.         if x1 <> -1 then 
  234.             vecout(x1,y1,x2,y2);
  235.               
  236.     end; {ProcessTriangles}
  237.  
  238. procedure InitShade;
  239. const
  240.     numPatterns = 10;
  241.     UpperLeft = 1;
  242.     UpperRight = 2;
  243.     LowerLeft = 3;
  244.     LowerRight = 4;
  245.     NullBox = -1;
  246.  
  247. type
  248.     PatNum = -1..numPatterns;    
  249. var
  250.                 
  251.  divisor : longint;
  252.     PatList : array[1..numPatterns] of Pattern;        { selected standard patterns }
  253.     pState : PenState;
  254.  myPat : PatNum;
  255.  myRect : rect;
  256.  
  257.  
  258.     function ShadeSquare(x,y, xSize,ySize,
  259.                       ul,ll,lr,ur : integer) : PatNum;
  260.     var
  261.         centre,top,left,bottom,right : longint;
  262.         centrePat : longint;
  263.         leftWidth,rightWidth,
  264.         upperHeight,lowerHeight : integer;
  265.         recurse :  boolean;
  266.         smallerBox : array [UpperLeft..LowerRight] of PatNum;
  267.         uniform : boolean;
  268.         i : integer;
  269.         drawingPat : PatNum;
  270.         
  271.     procedure paintArea;
  272.     var
  273.         tempRect : rect;
  274.     begin
  275.         PenPat(PatList[smallerBox[i]]);
  276.         with tempRect do
  277.             case i of
  278.             
  279.             UpperLeft : begin
  280.                 left := x;
  281.                 top := y;
  282.                 right := x+leftWidth;
  283.                 bottom := y+upperHeight;
  284.             end;
  285.                 
  286.             UpperRight : begin
  287.                 left := x+leftWidth;
  288.                 top := y;
  289.                 right := x+leftWidth+rightWidth;
  290.                 bottom := y+upperHeight;
  291.             end;
  292.             
  293.             LowerLeft : begin
  294.                 left := x;
  295.                 top := y+upperHeight;
  296.                 right := x+leftWidth;
  297.                 bottom := y+upperHeight+lowerHeight;
  298.             end;
  299.             
  300.             LowerRight : begin
  301.                 left := x+leftWidth;
  302.                 top := y+upperHeight;
  303.                 right := x+leftWidth+rightWidth;
  304.                 bottom := y+upperHeight+lowerHeight;
  305.             end;
  306.             
  307.             end;
  308.         PaintRect(tempRect);
  309.         PenNormal;
  310.     end;
  311.     
  312.     begin
  313.         centre := (ul+ll+lr+ur) div 4;
  314.         centrePat := centre div divisor;
  315.         {find out if recursion is needed}
  316.         recurse := ((xSize > 8) or (ySize > 8)) and
  317.                    (((ul div divisor) <> centrePat) or
  318.                    ((ll div divisor) <> centrePat) or
  319.                    ((lr div divisor) <> centrePat) or
  320.                    ((ur div divisor) <> centrePat));
  321.         if not recurse then
  322.             shadeSquare := 1+centrePat
  323.         else begin
  324.             top := (ul+ur) div 2;
  325.             left := (ul+ll) div 2;
  326.             bottom := (ll+lr) div 2;
  327.             right := (lr+ur) div 2;
  328.             
  329.             rightWidth := (xSize+1) div 2;
  330.             leftWidth := xSize div 2;
  331.             lowerHeight := (ySize+1) div 2;
  332.             upperHeight := ySize div 2;
  333.             
  334.             smallerBox[UpperLeft] := ShadeSquare(x,y,leftWidth,upperHeight,ul,left,centre,top); {upper left rect}
  335.             smallerBox[LowerLeft] := ShadeSquare(x,y+upperHeight,leftWidth,lowerHeight,left,ll,bottom,centre); {lower left}
  336.             smallerBox[LowerRight] := ShadeSquare(x+leftWidth,y+upperHeight,rightWidth,
  337.                                                   lowerHeight,centre,bottom,lr,right);
  338.             smallerBox[UpperRight] := ShadeSquare(x+leftWidth,y,rightWidth,upperHeight,top,centre,right,ur); {upper right}
  339.             
  340.             uniform := true;
  341.             drawingPat := smallerBox[LowerRight];
  342.             for i := UpperLeft to LowerLeft do
  343.                 uniform := uniform and ((smallerBox[i] = NullBox) or (smallerBox[i] = drawingPat));
  344.             if uniform then
  345.                 shadeSquare := drawingPat
  346.             else begin
  347.                 for i := UpperLeft to LowerRight do
  348.                     if smallerBox[i] > 0 then
  349.                         paintArea;                        
  350.                 shadeSquare := 0;
  351.             end;        
  352.         end;
  353.     end;
  354.  
  355.     function shadePlot(x,y,width,height : integer) : PatNum;
  356.     var
  357.         i,
  358.         leftWidth,rightWidth,
  359.         upperHeight,lowerHeight : integer;
  360.         
  361.         smallerBox : array[1..4] of PatNum;
  362.         uniform : boolean;
  363.         drawingPat : PatNum;
  364.         realY : longint;
  365.  
  366.     procedure paintArea;
  367.     var
  368.         tempRect : rect;
  369.     begin
  370.         PenPat(PatList[smallerBox[i]]);
  371.         if not (smallerBox[i] in [1..10]) then
  372.         sysbeep(1);
  373.         with tempRect do
  374.             case i of
  375.             
  376.             UpperLeft : begin
  377.                 left := x;
  378.                 top := realY;
  379.                 right := x+leftWidth;
  380.                 bottom := realY+upperHeight;
  381.             end;
  382.                 
  383.             UpperRight : begin
  384.                 left := x+leftWidth;
  385.                 top := realY;
  386.                 right := x+leftWidth+rightWidth;
  387.                 bottom := realY+upperHeight;
  388.             end;
  389.             
  390.             LowerLeft : begin
  391.                 left := x;
  392.                 top := realY+upperHeight;
  393.                 right := x+leftWidth;
  394.                 bottom := realY+upperHeight+lowerHeight;
  395.             end;
  396.             
  397.             LowerRight : begin
  398.                 left := x+leftWidth;
  399.                 top := realY+upperHeight;
  400.                 right := x+leftWidth+rightWidth;
  401.                 bottom := realY+upperHeight+lowerHeight;
  402.             end;
  403.             
  404.             end;
  405.               with tempRect do begin
  406.                      left := left*currentGridSize;
  407.                      top := top *currentGridsize;
  408.                      right := right*currentGridSize;
  409.                      bottom := bottom*currentGridSize;
  410.               end;
  411.  
  412.         PaintRect(tempRect);
  413.         PenNormal;
  414.     end;
  415.         
  416.     begin
  417.         realY := yLow+segment*maxRows + y;
  418.         leftWidth := width div 2;
  419.         rightWidth := (width + 1) div 2;
  420.         upperHeight := height div 2;
  421.         lowerHeight := (height + 1) div 2;
  422.         for i := UpperLeft to LowerRight do
  423.             smallerBox[i] := 0;
  424.         if (leftWidth = 0) then begin
  425.             smallerBox[UpperLeft] := NullBox;
  426.             smallerBox[LowerLeft] := NullBox;
  427.         end;
  428.         if (upperHeight = 0) then begin
  429.             smallerBox[UpperLeft] := NullBox;
  430.             smallerBox[UpperRight] := NullBox;
  431.         end;
  432.         
  433.         if (smallerBox[UpperLeft] <> NullBox) then
  434.             if (leftWidth = 1) and (upperHeight = 1) then
  435.                 smallerBox[UpperLeft] := shadeSquare(x*currentGridSize,RealY*currentGridSize,
  436.                                                      currentGridSize,currentGridSize,
  437.                                                      ord(data[y]^[x]),ord(data[y+1]^[x]),
  438.                                                      ord(data[y+1]^[x+1]),ord(data[y]^[x+1]))
  439.             else
  440.                 smallerBox[UpperLeft] := shadePlot(x,y,leftWidth,upperHeight);
  441.         
  442.         if (smallerBox[UpperRight] <> NullBox) then
  443.             if (rightWidth = 1) and (upperHeight = 1) then
  444.                 smallerBox[UpperRight] := shadeSquare((x+leftWidth)*currentGridSize,
  445.                                                       RealY*currentGridSize,
  446.                                                       currentGridSize,currentGridSize,
  447.                                                       ord(data[y]^[x+leftwidth]),
  448.                                                       ord(data[y+1]^[x+leftWidth]),
  449.                                                       ord(data[y+1]^[x+leftWidth+1]),
  450.                                                       ord(data[y]^[x+leftWidth+1]))
  451.             else
  452.                 smallerBox[UpperRight] := shadePlot(x+leftWidth,y,rightWidth,upperHeight);
  453.         
  454.         if (smallerBox[LowerLeft] <> NullBox) then
  455.             if (leftWidth = 1) and (lowerHeight = 1) then
  456.                 smallerBox[LowerLeft] := shadeSquare(x*currentGridSize,
  457.                                                      (y+upperHeight)*currentGridSize,
  458.                                                      currentGridSize,currentGridSize,
  459.                                                      ord(data[y+upperHeight]^[x]),
  460.                                                      ord(data[y+upperHeight+1]^[x]),
  461.                                                      ord(data[y+upperHeight+1]^[x+1]),
  462.                                                      ord(data[y+upperHeight]^[x+1]))
  463.             else
  464.                 smallerBox[LowerLeft] := shadePlot(x,y+upperHeight,leftWidth,lowerHeight);
  465.                 
  466.         if (rightWidth = 1) and (lowerHeight = 1) then  
  467.             smallerBox[LowerRight] := shadeSquare((x+leftWidth)*currentGridSize,
  468.                                                   (y+upperHeight)*currentGridSize,
  469.                                                   currentGridSize,currentGridSize,
  470.                                                   ord(data[y+upperHeight]^[x+leftWidth]),
  471.                                                   ord(data[y+upperHeight+1]^[x+leftWidth]),
  472.                                                   ord(data[y+upperHeight+1]^[x+leftWidth+1]),
  473.                                                   ord(data[y+upperHeight]^[x+leftWidth+1]))     
  474.         else
  475.             smallerBox[LowerRight] := shadePlot(x+leftWidth,y+upperHeight,rightWidth,lowerHeight);
  476.         
  477.         uniform := true;
  478.         drawingPat := smallerBox[LowerRight];
  479.         for i := UpperLeft to LowerLeft do
  480.             uniform := uniform and ((smallerBox[i] = NullBox) or (smallerBox[i] = drawingPat));
  481.         if uniform then
  482.             shadePlot := drawingPat
  483.         else begin
  484.             for i := UpperLeft to LowerRight do
  485.                 if (smallerBox[i] > 0) then
  486.                     paintArea;
  487.             shadePlot := 0;
  488.         end;
  489. end;
  490.  
  491. begin
  492.     GetPenState(pState);
  493.        PenNormal;
  494.     divisor := 255 div numPatterns;
  495.     getIndPattern(patList[1], SysPatListID, 20);        { white }
  496.     getIndPattern(patList[2], SysPatListID, 13);
  497.     getIndPattern(patList[3], SysPatListID, 21);
  498.     getIndPattern(patList[4], SysPatListID, 22);
  499.     getIndPattern(patList[5], SysPatListID, 23);
  500.     getIndPattern(patList[6], SysPatListID, 4);
  501.     getIndPattern(patList[7], SysPatListID, 3);
  502.     getIndPattern(patList[8], SysPatListID, 2);
  503.     StuffHex(@patList[9], '7FFFFFFFFFFFFFFF');
  504.     getIndPattern(patList[10], SysPatListID, 1);        { black } 
  505.     myPat := shadePlot(xLow,0,xhigh-xlow,noOfRows);
  506.     if myPat > 0 then begin
  507.         realY := yLow + segment*maxRows;
  508.         SetRect(myRect,xLow*currentGridSize,realY*currentGridSize
  509.                 ,xHigh*currentGridSize,(realY+noOfRows)*currentGridSize);
  510.         PenPat(PatList[myPat]);
  511.         PaintRect(myRect);
  512.     end;
  513.         
  514.     SetPenState(pState);
  515.     
  516. end; { ShadePlot }
  517.  
  518.         
  519. begin
  520.     GetMatrixBounds(UpdateRect,Xlow,Xhigh,Ylow,Yhigh);
  521.     GetPenState(PState);
  522.         
  523.     NoOfSegments := round( (Yhigh-Ylow+1)/maxRows + 0.49);
  524.     remainingRows := (Yhigh-Ylow+1 - (NoOfSegments-1)*maxRows);
  525.     PenNormal;
  526.     count := maxX[windowIndex];
  527.     posOff := longint(Ylow)*maxX[windowIndex];
  528.     resultCode := SetFPos(theFile[windowIndex],fsFromStart,posOff);
  529.     if resultCode <> 0 then sysbeep(1);
  530.     resultCode := FSRead(theFile[windowIndex],count,ptr(data[maxRows]));
  531.     if resultCode <> 0 then sysbeep(1);
  532.     
  533.     for segment := 0 to NoOfSegments -1 do begin
  534.         
  535.                   if cancelOp then
  536.                          exit;
  537.         if segment = (NoOfSegments-1) then
  538.             NoOfRows := remainingRows -1
  539.         else
  540.             NoOfRows := maxRows;
  541.         SwapPtr(data[0],data[maxRows]);
  542.         
  543.         for y := 1 to NoOfRows do begin
  544.             resultCode := FSRead(theFile[windowIndex],count,ptr(data[y]));
  545.             if resultCode <> 0 then sysbeep(1);
  546.         end;
  547.         
  548.         if segment = (NoOfSegments-1) then
  549.             NoOfRows := NoOfRows+1;
  550.             
  551.         if shadeSurface[windowIndex] then
  552.             initShade
  553.         else
  554.             for y := minY to NoOfRows - 1 do begin
  555.                          if cancelOp then
  556.                                 exit;
  557.                 RealY := Ylow + segment*maxRows + y;
  558.                 for x := Xlow to Xhigh-1 do begin
  559.                     minMaxVertex;
  560.                     if (ContourLevel[windowIndex][1] <= DataMax) and
  561.                                       (DataMin <= contourLevel[windowIndex][NoOfLevels[windowIndex]]) then begin
  562.                         for level := 1 to NoOfLevels[windowIndex] do begin
  563.                             if (ContourLevel[windowIndex][level] <= DataMax) and
  564.                                (DataMin <= contourLevel[windowIndex][level]) then begin
  565.                                 ProcessVertices;
  566.                                 ProcessTriangles;
  567.                             end; {a plot in level}
  568.                         end; {each contour level}
  569.                     end; {at least one plot in box}
  570.                 end; { each x coordinate}
  571.             end; { each y coordinate}
  572.     end; { each segment}
  573.     if gridOn[windowIndex] then 
  574.         DrawGrid(xlow,xhigh,ylow,yhigh);
  575.     SetPenState(PState);
  576. end; { contourPlot }
  577.     
  578. end.
  579.             
  580.                 
  581.                 
  582.  
  583.  
  584.         
  585.  
  586.