Topspeed_JPI/TS-V3/REP16/RECTANGL.MOD

IMPLEMENTATION MODULE Rectangles;
(*
 *  REPERTOIRE
 *  Release 1.6
 *  By Charles Bradford and Cole Brecheen
 *  (c) Copyright 1985-1992 PMI
 *  Green Bay, Wisconsin
 *  All rights reserved
 *  (414) 468-6040
 *
 *  $Header:   D:/logfiles/mods/rectangl.mov   1.5   10 Mar 1991 15:35:22   coleb  $
 *
 *
 *  Adapted from an earlier version written and contributed
 *  by Martin Johnston of GTJ Consultants, New York, NY.
 *
 *)


IMPORT Numbers;

VAR
  Initialized : BOOLEAN;

  PROCEDURE Init();
    BEGIN
      IF Initialized THEN
        RETURN;
      ELSE
        Initialized := TRUE;
      END;
      Numbers.Init();
    END Init;


  PROCEDURE PointInside( VAR p : APoint; VAR r : ARectangle) :
      BOOLEAN;
    BEGIN
      RETURN (p.col >= r.col1) AND (p.col < r.col2) AND (p.row >= r.row1) AND
          (p.row < r.row2);
    END PointInside;


  PROCEDURE Distance(p1, p2 : APoint) : CARDINAL;
    VAR
      colDiff, rowDiff : CARDINAL;

    PROCEDURE IntToCardRange(n : INTEGER) : CARDINAL;
      BEGIN
        IF n >= 0 THEN
          RETURN CARDINAL(n)+32767+1;
        ELSE
          RETURN CARDINAL(n+32767+1);
        END;
      END IntToCardRange;

    PROCEDURE dist(a, b : INTEGER) : CARDINAL;
      BEGIN
        IF a > b THEN
          RETURN IntToCardRange(a) - IntToCardRange(b);
        ELSE
          RETURN IntToCardRange(b) - IntToCardRange(a);
        END;
      END dist;

    BEGIN
      colDiff := dist(p1.col, p2.col);
      rowDiff := dist(p1.row, p2.row);
      RETURN Numbers.CardSqrt( (colDiff * colDiff) + (rowDiff * rowDiff) );
    END Distance;


  PROCEDURE RectsIntersect(VAR r1, r2, intersection : ARectangle) : BOOLEAN;
    BEGIN
      IF r1.row1 > r2.row1 THEN
        intersection.row1 := r1.row1;
      ELSE
        intersection.row1 := r2.row1;
      END;
      IF r1.row2 < r2.row2 THEN
        intersection.row2 := r1.row2;
      ELSE
        intersection.row2 := r2.row2;
      END;
      IF r1.col1 > r2.col1 THEN
        intersection.col1 := r1.col1;
      ELSE
        intersection.col1 := r2.col1;
      END;
      IF r1.col2 < r2.col2 THEN
        intersection.col2 := r1.col2;
      ELSE
        intersection.col2 := r2.col2;
      END;
      RETURN (intersection.row1 <= intersection.row2) AND
          (intersection.col1 <= intersection.col2);
    END RectsIntersect;


  PROCEDURE FindRowOnCol(VAR col1, row1, col2, row2, col : INTEGER) : INTEGER;
    VAR
      dcol, rise, run : INTEGER;

    PROCEDURE HalfPoint(xl, yl, xr, yr : INTEGER) : INTEGER;
      VAR
        syl, sxr, syr : INTEGER;
      BEGIN
        REPEAT
          syl := yl;
          sxr := xr;
          syr := yr;
          xr := (xl+xr) DIV 2;
          yr := (yl+yr) DIV 2;
          IF xr < col THEN
            xl := xr;
            yl := yr;
            xr := sxr;
            yr := syr;
          END;
        UNTIL ((syl=yl) AND (syr=yr));
        RETURN yr;
      END HalfPoint;

    BEGIN
      IF row1 = row2 THEN
        RETURN row1;
      ELSE
        rise := row2-row1;
        run := col2-col1;
        dcol := Numbers.LowestCommonDenom(rise, run);
        IF dcol # rise THEN
          rise := rise DIV dcol;
          run := run DIV dcol;
        END;
        dcol := col-col1;
        IF (ABS(32767 DIV rise) < ABS(dcol)) OR ((32767 DIV ABS(dcol)) <
            ABS(rise)) THEN
          RETURN HalfPoint(col1, row1, col2, row2);
        ELSE
          RETURN ((rise*dcol) DIV run)+row1;
        END;
      END;
    END FindRowOnCol;


  PROCEDURE LineInside(TheLine : ALine; r : ARectangle; VAR
      intersection : ALine) : BOOLEAN;

    PROCEDURE order(VAR col1, col2, row1, row2 : INTEGER);
      VAR
        col : INTEGER;
      BEGIN
        IF col1 > col2 THEN
          col := col1;
          col1 := col2;
          col2 := col;
          col := row1;
          row1 := row2;
          row2 := col;
        END;
      END order;

    BEGIN
      WITH TheLine DO
        order(p1.col, p2.col, p1.row, p2.row);
        IF (p1.col < r.col1) AND (p2.col > r.col1) THEN
          p1.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col1);
          p1.col := r.col1;
        END;
        IF (p1.col < r.col2) AND (p2.col > r.col2) THEN
          p2.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col2);
          p2.col := r.col2;
        END;
        order(p1.row, p2.row, p1.col, p2.col);
        IF (p1.row < r.row1) AND (p2.row > r.row1) THEN
          p1.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row1);
          p1.row := r.row1;
        END;
        IF (p1.row < r.row2) AND (p2.row > r.row2) THEN
          p2.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row2);
          p2.row := r.row2;
        END;
        IF PointInside(p1, r) AND PointInside(p2, r) THEN
          intersection := TheLine;
          RETURN TRUE;
        ELSE
          RETURN FALSE;
        END;
      END;
    END LineInside;


  PROCEDURE DefineRectangle(VAR r : ARectangle; col1, row1, col2, row2 :
      INTEGER);
    BEGIN
      r.col1 := col1;
      r.row1 := row1;
      r.col2 := col2;
      r.row2 := row2;
    END DefineRectangle;


  PROCEDURE DefineByPoints(VAR r : ARectangle; TopLeft, BottomRight
      : APoint);
    BEGIN
      r.TopLeft := TopLeft;
      r.BottomRight := BottomRight;
    END DefineByPoints;


  PROCEDURE RectIsInside( VAR r1, r2 : ARectangle) : BOOLEAN;
    BEGIN
      RETURN (r1.col1 >= r2.col1) AND (r1.col2 <= r2.col2) AND
          (r1.row1 >= r2.row1) AND (r1.row2 <= r2.row2);
    END RectIsInside;


  PROCEDURE ShrinkRect( VAR r : ARectangle );
    BEGIN
      IF r.col2 > (r.col1 + 1) THEN
        INC( r.col1 );
        DEC( r.col2 );
      END;
      IF r.row2 > (r.row1 + 1) THEN
        INC( r.row1 );
        DEC( r.row2 );
      END;
    END ShrinkRect;

  PROCEDURE ExpandRect( VAR r : ARectangle );
    BEGIN
      IF r.col1 > 1 THEN
        DEC( r.col1 );
      END;
      IF r.row1 > 1 THEN
        DEC( r.row1 );
      END;
      INC( r.col2 );
      INC( r.row2 );
    END ExpandRect;

BEGIN
  Initialized := FALSE;
  Init();
END Rectangles.