home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / PLOT / SURFUTI3.ZIP / GXZOOM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-10  |  4.8 KB  |  176 lines
  1. VAR
  2.   GxZoomIndex : Integer;
  3.  
  4.   PROCEDURE ZoomPan;
  5.  
  6.   {Package to enable zoom and pan. Pan is achieved by pressing the ARROWED
  7.    KEYS in the numeric key pad, Zoom by pressing + for out and - for in.
  8.    To fix the new window to the currently displayed frame press key 5.
  9.    To leave without changing the current window press key 7 (home).
  10.  
  11.    The old window coordinates are NOT saved.
  12.  
  13.    IMPORTANT:  the numeric keypad MUST be in NumLock mode, otherwise the
  14.                bell is sounded.}
  15.  
  16.  
  17. CONST
  18.     BELL = ^G;
  19.     Esc = ^[;
  20.     control : SET OF Char = ['2', '4', '5', '6', '7', '8', '+', '-'];
  21.  
  22.   TYPE
  23.     actions = (ZoomIn, ZoomOut, PanLeft, PanRight, PanUp, PanDown, Fix, Quit);
  24.  
  25.   VAR
  26.     action : actions;
  27.     Fxc, Fyc : Real; {centre of frame}
  28.     Fw, Fh : Real; {frame width and height}
  29.     SemiFw, SemiFh : Real;
  30.     bx, By, Tx, Ty : Real; {frame coordinates: bottom left, top right}
  31.     DeltaW, DeltaH : Real; {zoom-pan step increments}
  32.     DeltaWmin, DeltaHmin : Real;
  33.     CurrMode : Integer;
  34.     CurrIndex : Integer;
  35.  
  36.     PROCEDURE DrawFrame;
  37.     VAR
  38.       LineX, LineY : Real;
  39.  
  40.     BEGIN
  41.       SemiFw := Fw*0.5;
  42.       SemiFh := Fh*0.5;
  43.       bx := Fxc-SemiFw;
  44.       By := Fyc-SemiFh;
  45.       Tx := Fxc+SemiFw;
  46.       Ty := Fyc+SemiFh;
  47.       LineX := 0.05*Fw;
  48.       IF LineX < DeltaWmin THEN
  49.         BEGIN
  50.           MoveTo(bx, By);
  51.           DrawTo(Tx, By);
  52.           DrawTo(Tx, Ty);
  53.           DrawTo(bx, Ty);
  54.           DrawTo(bx, By);
  55.           PlotAt(bx, By);
  56.  
  57.          PlotAt(Tx, By);
  58.           PlotAt(Tx, Ty);
  59.           PlotAt(bx, Ty);
  60.         END
  61.       ELSE
  62.         BEGIN
  63.           LineY := 0.05*Fh;
  64.           MoveTo(bx, By+LineY);
  65.           RelDrawTo(0, -LineY);
  66.           RelDrawTo(LineX, 0);
  67.           MoveTo(Tx-LineX, By);
  68.           RelDrawTo(LineX, 0);
  69.           RelDrawTo(0, LineY);
  70.           MoveTo(Tx, Ty-LineY);
  71.           RelDrawTo(0, LineY);
  72.           RelDrawTo(-LineX, 0);
  73.           MoveTo(bx+LineX, Ty);
  74.           RelDrawTo(-LineX, 0);
  75.  
  76.         RelDrawTo(0, -LineY);
  77.         END;
  78.     END {DrawFrame} ;
  79.  
  80.     FUNCTION GetAction : actions;
  81.     VAR
  82.       c : Char;
  83.       numlock : Byte;
  84.  
  85.     BEGIN
  86.       numlock := Mem[$40:$17] AND $20; {record Numlock status}
  87.       Mem[$40:$17] := Mem[$40:$17] OR $20; {force NumLock on}
  88.       REPEAT
  89.         Read(Kbd, c);
  90.         IF c = Esc THEN
  91.           BEGIN
  92.             Read(Kbd, c);
  93.             IF c IN ['1'..'9'] THEN
  94.               BEGIN
  95.                 DeltaW := ((Ord(c)-Ord('0')) SHL 2)*
  96.  
  97.                 (GxWxt-GxWxb)/(GxVxt-GxVxb);
  98.                 DeltaH := DeltaW*(Fh/Fw);
  99.                 c := Esc;
  100.               END
  101.             ELSE
  102.               Write(BELL);
  103.           END;
  104.       UNTIL c IN control;
  105.       CASE c OF
  106.         '2' : GetAction := PanDown;
  107.         '4' : GetAction := PanLeft;
  108.         '6' : GetAction := PanRight;
  109.         '8' : GetAction := PanUp;
  110.         '+' : GetAction := ZoomOut;
  111.         '-' : GetAction := ZoomIn;
  112.         '5' : GetAction := Fix;
  113.         '7' :
  114. GetAction := Quit;
  115.       END;
  116.       Mem[$40:$17] := Mem[$40:$17] AND NOT($20); {force NumLock off}
  117.       Mem[$40:$17] := Mem[$40:$17] OR numlock; {restore Numlock status}
  118.     END {GetAction} ;
  119.  
  120.   BEGIN {Zoom - Pan}
  121.     IF NOT(GxZoomIndex IN [0..GxIndexRng]) THEN
  122.       GxZoomIndex := GxPalette[15]; {white in default colour map}
  123.     CurrMode := GxMode;
  124.     CurrIndex := GxIndex;
  125.     GxIndex := GxZoomIndex;
  126.     Fxc := (GxWxt+GxWxb)*0.5;
  127.     Fyc := (GxWyt+GxWyb)*0.5;
  128.     Fw := (GxWxt-GxWxb)*0.5;
  129.  
  130.     Fh := (GxWyt-GxWyb)*0.5;
  131.     DeltaW := 4.0*(GxWxt-GxWxb)/(GxVxt-GxVxb);
  132.     DeltaH := DeltaW*(Fh/Fw);
  133.     DeltaWmin := DeltaW;
  134.     DeltaHmin := DeltaH;
  135.     WriteModeXor;
  136.     DrawFrame;
  137.     REPEAT {... until action is either Fix or Quit}
  138.       action := GetAction;
  139.       DrawFrame; {to delete currently displayed frame}
  140.       CASE action OF
  141.         ZoomIn : BEGIN
  142.                    Fw := Fw-DeltaW; Fh := Fh-DeltaH;
  143.                    IF Fw < DeltaWmin THEN
  144.                      BEGIN
  145.  
  146.                   Fw := DeltaWmin; Fh := DeltaHmin;
  147.                      END;
  148.                  END;
  149.         ZoomOut : BEGIN
  150.                     Fw := Fw+DeltaW; Fh := Fh+DeltaH;
  151.                   END;
  152.         PanLeft : Fxc := Fxc-DeltaW;
  153.         PanRight : Fxc := Fxc+DeltaW;
  154.         PanUp : Fyc := Fyc+DeltaH;
  155.         PanDown : Fyc := Fyc-DeltaH;
  156.         Fix, Quit : ;
  157.       END;
  158.       DrawFrame; {to display new frame}
  159.     UNTIL action IN [Quit, Fix];
  160.  
  161.     DrawFrame; {to delete finally select
  162. ed frame}
  163.     IF action = Fix THEN
  164.       Window(bx, By, Tx, Ty);
  165.     GxMode := CurrMode;
  166.     IF GxMode = GxXor THEN
  167.       WriteModeSet;
  168.     GxIndex := CurrIndex;
  169.   END {ZoomPan} ;
  170.  
  171.   PROCEDURE ZoomColour(index : Integer);
  172.   BEGIN
  173.     GxZoomIndex := index AND $F;
  174.   END {ZoomColour} ;
  175.  
  176.