The Unsorted BBS Collection/thegreatunsorted.tar/thegreatunsorted/programming/misc_programming/AGUL/DRAW.ADB

Text File | 1990-10-25 | 15.4 KB | 455 lines

--        ╔═════════════════════════════════════════════════════════════╗
--        ║█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█║
--        ║█                                                           █║
--        ║█                 Meridian Software Systems                 █║
--        ║█                                                           █║
--        ║█                    Copyright (C)  1990                    █║
--        ║█                                                           █║
--        ║█                    ALL RIGHTS RESERVED                    █║
--        ║█                                                           █║
--        ║█▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄█║
--        ╚═════════════════════════════════════════════════════════════╝

------------------------------------------------------------------------------
--
--   Unit Name:   DRAW           - package body
--
--   Purpose of unit:   This package is called to display the geometric
--                      shapes including lines, circles, circle segments,
--                      arcs, rectangles, and ellipses.  This package also
--                      handles setting the foreground and background colors.
--                      Additional functions include clearscreen and object
--                      fill.
--
------------------------------------------------------------------------------

with COMMON_DISPLAY_TYPES, INTERRUPT;
with COMMON_GRAPHIC_TYPES, MATH_LIB, ASMPAK;
use  COMMON_GRAPHIC_TYPES, MATH_LIB, ASMPAK;

package body DRAW is

  procedure SET4PIXELS (X, Y, XC, YC : integer) is
    X_RIGHT_HALF : integer := integer(float(XC + X) * SCREEN_WORLD_RATIO_X);
    X_LEFT_HALF  : integer := integer(float(XC - X) * SCREEN_WORLD_RATIO_X);
    Y_UPPER_HALF : integer := integer(float(YC - Y) * SCREEN_WORLD_RATIO_Y);
    Y_LOWER_HALF : integer := integer(float(YC + Y) * SCREEN_WORLD_RATIO_Y);
    QUAD1_PLOT   : boolean := true;
    QUAD2_PLOT   : boolean := true;
    QUAD3_PLOT   : boolean := true;
    QUAD4_PLOT   : boolean := true;

  begin
    -- check and limit circle drawing to within active screen boundaries
    if X_RIGHT_HALF > SCREEN_DIMENSION_LOWER_RIGHT_X then
      QUAD1_PLOT := false;
      QUAD4_PLOT := false;
    end if;
    if X_LEFT_HALF  < SCREEN_DIMENSION_UPPER_LEFT_X then
      QUAD2_PLOT := false;
      QUAD3_PLOT := false;
    end if;
    if Y_UPPER_HALF < SCREEN_DIMENSION_UPPER_LEFT_Y then
      QUAD1_PLOT := false;
      QUAD2_PLOT := false;
    end if;
    if Y_LOWER_HALF > SCREEN_DIMENSION_LOWER_RIGHT_Y then
      QUAD3_PLOT := false;
      QUAD4_PLOT := false;
    end if;

    if CLIP_ENABLE then
      -- check and limit circle drawing to within window boundaries
      if X_RIGHT_HALF > CURRENT_WINDOW_LOWER_RIGHT_X then
    QUAD1_PLOT := false;
    QUAD4_PLOT := false;
      end if;
      if X_LEFT_HALF  < CURRENT_WINDOW_UPPER_LEFT_X then
    QUAD2_PLOT := false;
    QUAD3_PLOT := false;
      end if;
      if Y_UPPER_HALF < CURRENT_WINDOW_UPPER_LEFT_Y then
    QUAD1_PLOT := false;
    QUAD2_PLOT := false;
      end if;
      if Y_LOWER_HALF > CURRENT_WINDOW_LOWER_RIGHT_Y then
    QUAD3_PLOT := false;
    QUAD4_PLOT := false;
      end if;
    end if;

    -- now plot pixels on four quadrants
    if QUAD1_PLOT then
      PLOTXY (ABS(X_RIGHT_HALF), ABS(Y_UPPER_HALF),     -- first  quadrant
          COMMON_DISPLAY_TYPES.COLOR'pos(FORE_COLOR),
          CURRENT_VIDEO_PAGE);
    end if;

    if QUAD2_PLOT then
      PLOTXY (ABS(X_LEFT_HALF), ABS(Y_UPPER_HALF),      -- second quadrant
          COMMON_DISPLAY_TYPES.COLOR'pos(FORE_COLOR),
          CURRENT_VIDEO_PAGE);
    end if;

    if QUAD3_PLOT then
      PLOTXY (ABS(X_LEFT_HALF), ABS(Y_LOWER_HALF),      -- third quadrant
          COMMON_DISPLAY_TYPES.COLOR'pos(FORE_COLOR),
          CURRENT_VIDEO_PAGE);
    end if;

    if QUAD4_PLOT then
      PLOTXY (ABS(X_RIGHT_HALF), ABS(Y_LOWER_HALF),     -- fourth quadrant
          COMMON_DISPLAY_TYPES.COLOR'pos(FORE_COLOR),
          CURRENT_VIDEO_PAGE);
    end if;

  end SET4PIXELS;

  procedure SCAN_LEFT ( X : in out integer;
            Y, BorderC, FillC : integer ) is
    ATTR : integer := -1;
  begin
    while (ATTR /= BorderC) and (ATTR /= FillC) loop
      ATTR := READ_PIXEL_ATTR (X, Y);
      X := X - 1;
    end loop;

    X := X + 2;
  end SCAN_LEFT;

  procedure SCAN_RIGHT (X : in out integer;
            Y, BorderC, FillC : integer ) is
    ATTR : integer := -1;
  begin
    while (ATTR /= BorderC) and (ATTR /= FillC) loop
      ATTR := READ_PIXEL_ATTR ( X,Y);
      X := X + 1;
    end loop;

    X := X - 1;
  end SCAN_RIGHT;

  function LINE_ADJ_FILL (SEEDX, SEEDY, D,
              PREVXL, PREVXR,
              BorderC, FillC : integer) return integer is
    XL      : integer := SEEDX;
    XR      : integer := SEEDX;
    Y       : integer := SEEDY;
    ATTR    : integer;
    X_COUNT : integer;
  begin
    SCAN_LEFT  (XL, Y, BorderC, FillC);    -- determine left  most pixel on row to be filled
    SCAN_RIGHT (XR, Y, BorderC, FillC);    -- determine right most pixel on row to be filled

    DRAW_BASIC_LINE (XL, Y, XR, Y, FillC, 1, 1, 640, 350, 0, CURRENT_VIDEO_PAGE);

    X_COUNT := XL;
    while X_COUNT < XR loop
      ATTR := READ_PIXEL_ATTR ( X_COUNT, Y + D );
      if (ATTR /= BorderC) and (ATTR /= FillC) then
    X_COUNT := LINE_ADJ_FILL (X_COUNT, Y + D, D, XL, XR, BorderC, FillC);
      end if;
      X_COUNT := X_COUNT + 1;
    end loop;

    X_COUNT := XL;
    while X_COUNT < PREVXL loop
      ATTR := READ_PIXEL_ATTR (X_COUNT, Y - D);
      if (ATTR /= Borderc) and (ATTR /= FillC) then
    X_COUNT := LINE_ADJ_FILL (X_COUNT, Y - D, -D, XL, XR, BorderC, FillC);
      end if;
      X_COUNT := X_COUNT + 1;
    end loop;

    X_COUNT := PREVXR;
    while X_COUNT < PREVXR loop
      ATTR := READ_PIXEL_ATTR (X_COUNT, Y - D);
      if (ATTR /= BorderC) and (ATTR /= FillC) then
    X_COUNT := LINE_ADJ_FILL (X_COUNT, Y - D, -D, XL, XR, BorderC, FillC);
      end if;
      X_COUNT := X_COUNT + 1;
    end loop;

    return XR;
  end LINE_ADJ_FILL;

  procedure ELLIPSE (XC, YC, A0, B0 : natural) is
    -- This procedure draws an ellipse defined by:
    --
    --   XC, YC:   coordinate of the ellipse center
    --   A0:       length of the X axis (measured from center to the vertex)
    --   B0:       length of the Y axis (measured from center to the vertex)
    --
    -- Bresenham's algorithm is used to draw the ellipse.

    X           : integer      := 0;
    Y           : integer      := B0;
    A           : long_integer := long_integer (float (A0) * ASPECT_RATIO);
    B           : long_integer := long_integer (B0);
    ASQUARED    : long_integer := A * A;
    TWOASQUARED : long_integer := 2 * ASQUARED;
    BSQUARED    : long_integer := B * B;
    TWOBSQUARED : long_integer := 2 * BSQUARED;
    D, DX, DY   : long_integer;

  begin
    D  := BSQUARED - ASQUARED * B + ASQUARED / 4;  -- initial midpoint value
    DX := 0;                                       -- initial delta X
    DY := TWOASQUARED * B;                         -- initial delta Y

    while DX < DY loop
      SET4PIXELS (X, Y, integer(XC), integer(YC));
      -- Plot all four quadrants
      if D > 0 then
    Y  := Y - 1;
    DY := DY - TWOASQUARED;
    D  := D - DY;
      end if;
      X  := X + 1;
      DX := DX + TWOBSQUARED;
      D  := D + BSQUARED + DX;   -- Until DY/DX reaches -1
    end loop;

    -- Adjust new midpoint value
    D := D + (3 * (ASQUARED - BSQUARED) / 2 - (DX + DY)) / 2;

    while Y >= 0 loop          -- Continue ploting in all four quadrants
      SET4PIXELS (X, Y, integer(XC), integer(YC));
      if D < 0 then
    X  := X + 1;
    DX := DX + TWOBSQUARED;
    D  := D + DX;
      end if;
      Y  := Y - 1;
      DY := DY - TWOASQUARED;
      D  := D + ASQUARED - DY;
    end loop;                  -- Until X-axis is reached

  end ELLIPSE;

  procedure CIRCLE (XC, YC, R: natural) is

    --  This procedure draws a circle defined by:
    --
    --        XC, YC:    coordinate of the circle center
    --        R:         radius of the circle
    --
    --  Ellipse algorithm is used for the circle,
    --    where major and minor axes are equal

  begin
    ELLIPSE (XC, YC, R, R);   -- Circle is a degenerated ellipse
  end CIRCLE;

  procedure CIRCLE_SEGMENT (XC, YC, SA, EA, R: natural) is
    START_A          : float := float (SA);
    END_A            : float := float (EA);
    POINT_X, POINT_Y : integer;
  begin

    -- Calculate coordinate of arc starting position
    POINT_X := integer(XC + integer(float(R) *
                COS(float(START_A)/57.29578) * ASPECT_RATIO));
    POINT_Y := integer(YC - integer(float(R) *
                SIN(float(START_A)/57.29578)));

    -- Draw a line from center of circle to it
    DRAW_BASIC_LINE (XC, YC, POINT_X, POINT_Y,
             COMMON_DISPLAY_TYPES.COLOR'pos(FORE_COLOR),
             CURRENT_WINDOW_UPPER_LEFT_X,
             CURRENT_WINDOW_UPPER_LEFT_Y,
             CURRENT_WINDOW_LOWER_RIGHT_X,
             CURRENT_WINDOW_LOWER_RIGHT_Y,
             boolean'pos (CLIP_ENABLE),
             CURRENT_VIDEO_PAGE);

    -- Draw an arc from starting position to ending position
    ARC ( XC, YC, SA, EA, R);

    -- Calculate coordinate of arc ending position
    POINT_X := integer(XC + integer(float(R) *
                COS(float(END_A)/57.29578) * ASPECT_RATIO));
    POINT_Y := integer(YC - integer(float(R) *
                SIN(float(END_A)/57.29578)));

    -- Draw a line from it to center of circle to close circle segment
    DRAW_BASIC_LINE (POINT_X, POINT_Y, XC, YC,
             COMMON_DISPLAY_TYPES.COLOR'pos (FORE_COLOR),
             CURRENT_WINDOW_UPPER_LEFT_X,
             CURRENT_WINDOW_UPPER_LEFT_Y,
             CURRENT_WINDOW_LOWER_RIGHT_X,
             CURRENT_WINDOW_LOWER_RIGHT_Y,
             boolean'pos (CLIP_ENABLE),
             CURRENT_VIDEO_PAGE);
  end CIRCLE_SEGMENT;

  procedure ARC (XC,YC,SA,EA,R: natural) is

    -- This procedure draws an arc of a circle defined by:
    --
    --        XC,YC:    coordinate of the circle center
    --        SA:       starting angle in degrees
    --        EA:       ending angle in degrees
    --        R:        radius of the circle
    --
    -- Transcendental calculation of points on the circle form the arc

    START_A    : float := float (SA);
    END_A      : float := float (EA);
    DEG_INC    : float := START_A;
    POINT_X    : integer;
    POINT_Y    : integer;
    PLOT_VALID : boolean;

  begin
    if START_A > END_A then     -- to guarantee that can draw Theta > 360 deg.
      END_A := END_A + 360.0;
    end if;

    while DEG_INC <= END_A loop -- transcendental loop drawing
      POINT_X := integer(SCREEN_WORLD_RATIO_X *
             (float(XC) +
              float(R) * COS(DEG_INC/57.29578) * ASPECT_RATIO));
      POINT_Y := integer(SCREEN_WORLD_RATIO_Y *
             (float(YC) -
              float(R) * SIN(DEG_INC/57.29578)));

      -- check for screen boundaries
      if (POINT_X > SCREEN_DIMENSION_UPPER_LEFT_X ) and
     (POINT_X < SCREEN_DIMENSION_LOWER_RIGHT_X) and
     (POINT_Y > SCREEN_DIMENSION_UPPER_LEFT_Y ) and
     (POINT_Y < SCREEN_DIMENSION_LOWER_RIGHT_Y) then
    PLOT_VALID := true;
      else
    PLOT_VALID := false;
      end if;

      -- only draw inside the window if clipping is on
      if PLOT_VALID and CLIP_ENABLE then
    if (POINT_X > CURRENT_WINDOW_UPPER_LEFT_X ) and
       (POINT_X < CURRENT_WINDOW_LOWER_RIGHT_X) and
       (POINT_Y > CURRENT_WINDOW_UPPER_LEFT_Y ) and
       (POINT_Y < CURRENT_WINDOW_LOWER_RIGHT_Y) then
      PLOT_VALID := true;
        else
      PLOT_VALID := false;
        end if;
      end if;

      -- after all conditions are met, plot the point
      if PLOT_VALID then
    PLOTXY (POINT_X, POINT_Y,
        COMMON_DISPLAY_TYPES.COLOR'pos (FORE_COLOR),
        CURRENT_VIDEO_PAGE);
      end if;

      DEG_INC := DEG_INC + 0.4;   -- increment by 0.2 degree for nice plot

    end loop;
  end ARC;

  procedure RECTANGLE (X1, Y1, X2, Y2 : natural) is

    -- This procedure draws a rectangle defined by:
    --
    --        X1, Y1:    coordinate of the upper left  corner
    --        X2, Y2:    coordinate of the lower right corner
    --
    -- Line drawing routine is used to complete the rectangle

  begin
    LINE (X1, Y1, X2, Y1);       -- from upper left  to upper right
    LINE (X2, Y1, X2, Y2);       -- from upper right to lower right
    LINE (X2, Y2, X1, Y2);       -- from lower right to lower left
    LINE (X1, Y2, X1, Y1);       -- from lower left  to upper left
  end RECTANGLE;

  procedure LINE (X1, Y1, X2, Y2 : natural) is

    --  This procedure draws a line defined by:
    --
    --        X1, Y1:    coordinate of the starting point
    --        X2, Y2:    coordinate of the ending point
    --
    --  Bresenham's algorithm is used to draw the line

    XSTART : integer := integer(float(X1) * SCREEN_WORLD_RATIO_X);
    XEND   : integer := integer(float(X2) * SCREEN_WORLD_RATIO_X);
    YSTART : integer := integer(float(Y1) * SCREEN_WORLD_RATIO_Y);
    YEND   : integer := integer(float(Y2) * SCREEN_WORLD_RATIO_Y);
    UPPERX : integer := SCREEN_DIMENSION_UPPER_LEFT_X;
    UPPERY : integer := SCREEN_DIMENSION_UPPER_LEFT_Y;
    LOWERX : integer := SCREEN_DIMENSION_LOWER_RIGHT_X;
    LOWERY : integer := SCREEN_DIMENSION_LOWER_RIGHT_Y;

  begin
    -- limit line x-coordinate to within screen x-boundary
    if XSTART < SCREEN_DIMENSION_UPPER_LEFT_X then
      XSTART :=  SCREEN_DIMENSION_UPPER_LEFT_X;
    end if;
    if XSTART > SCREEN_DIMENSION_LOWER_RIGHT_X then
      XSTART := SCREEN_DIMENSION_LOWER_RIGHT_X;
    end if;
    if XEND > SCREEN_DIMENSION_LOWER_RIGHT_X then
      XEND := SCREEN_DIMENSION_LOWER_RIGHT_X;
    end if;
    if XEND < SCREEN_DIMENSION_UPPER_LEFT_X then
      XEND := SCREEN_DIMENSION_UPPER_LEFT_X;
    end if;

    -- limit line y-coordinate to within screen y-boundary
    if YSTART > SCREEN_DIMENSION_LOWER_RIGHT_Y then
      YSTART := SCREEN_DIMENSION_LOWER_RIGHT_Y;
    end if;
    if YSTART < SCREEN_DIMENSION_UPPER_LEFT_Y then
      YSTART := SCREEN_DIMENSION_UPPER_LEFT_Y;
    end if;
    if YEND > SCREEN_DIMENSION_LOWER_RIGHT_Y then
      YEND := SCREEN_DIMENSION_LOWER_RIGHT_Y;
    end if;
    if YEND < SCREEN_DIMENSION_UPPER_LEFT_Y then
      YEND := SCREEN_DIMENSION_UPPER_LEFT_Y;
    end if;

    if CLIP_ENABLE then
      -- limit line x-coordinate to within window x-boundary
      UPPERX := CURRENT_WINDOW_UPPER_LEFT_X;
      UPPERY := CURRENT_WINDOW_UPPER_LEFT_Y;
      LOWERX := CURRENT_WINDOW_LOWER_RIGHT_X;
      LOWERY := CURRENT_WINDOW_LOWER_RIGHT_Y;
    end if;

    DRAW_BASIC_LINE (XSTART, YSTART, XEND, YEND,
             COMMON_DISPLAY_TYPES.COLOR'pos (FORE_COLOR),
             UPPERX, UPPERY, LOWERX, LOWERY,
             boolean'pos (CLIP_ENABLE),
             CURRENT_VIDEO_PAGE);
  end LINE;

  procedure OBJECT_FILL (X, Y : natural;
             FIL_C, BRD_C : COMMON_DISPLAY_TYPES.COLOR) is
    DUMMY : integer;
  begin
    DUMMY := LINE_ADJ_FILL (X, Y, -1, X, Y,
                COMMON_DISPLAY_TYPES.COLOR'pos (BRD_C),
                COMMON_DISPLAY_TYPES.COLOR'pos (FIL_C));
  end OBJECT_FILL;

  procedure FOREGROUND_COLOR (COLOR : COMMON_DISPLAY_TYPES.COLOR) is
  begin
    FORE_COLOR := COLOR;    -- Set foreground color for all future draws
  end FOREGROUND_COLOR;


  procedure BACKGROUND_COLOR (COLOR : COMMON_DISPLAY_TYPES.COLOR) is
  begin
    BACK_COLOR := COLOR;    -- Set background color for all future draws
  end BACKGROUND_COLOR;

  procedure CLEAR_SCREEN is
  begin
    ASMPAK.CLEAR_SCREEN;
  end CLEAR_SCREEN;

end DRAW;