|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 104403 (0x197d3)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Unchecked_Deallocation;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_Region;
use Xlbt_Region;
with Xlbt_Region2;
use Xlbt_Region2;
with Xlbp_Gc;
use Xlbp_Gc;
package body Xlbp_Region is
------------------------------------------------------------------------------
-- X Library Regions
--
-- Xlbp_Region - Create and manipulate regions.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1987 - 1989 by Digital Equipment Corporation, Maynard, Mass.
-- Copyright 1987 - 1989 by Massachusetts Institute of Technology,
-- Cambridge, Massachusetts.
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of Digital, MIT, or Rational
-- not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- Digital, MIT, and Rational disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall Digital, MIT, or Rational be liable for any special,
-- indirect or consequential damages or any damages whatsoever resulting from
-- loss of use, data or profits, whether in an action of contract, negligence
-- or other tortious action, arising out of or in connection with the use or
-- performance of this software.
------------------------------------------------------------------------------
--\f
------------------------------------------------------------------------------
-- This file contains a few routines to help track
-- the edge of a filled object. The object is assumed
-- to be filled in scan_line order, and thus the
-- algorithm used is an extension of Bresenham's line
-- drawing algorithm which assumes that y is always the
-- major axis.
-- Since these pieces of code are the same for any filled shape,
-- it is more convenient to gather the library in one
-- place, but since these pieces of code are also in
-- the inner loops of output primitives, procedure call
-- overhead is out of the question.
-- See the author for a derivation if needed.
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- This structure contains all of the information needed
-- to run the Bresenham algorithm.
-- The variables may be hardcoded into the declarations
-- instead of using this structure to make use of
-- register declarations.
------------------------------------------------------------------------------
type Bres_Info is
record
Minor_Axis : S_Long := 0; -- minor axis
D : S_Long := 0; -- decision variable
M : S_Long := 0; -- slope
M1 : S_Long := 0; -- slope+1
Incr1 : S_Long := 0; -- error increment
Incr2 : S_Long := 0; -- error increment
end record;
------------------------------------------------------------------------------
------------------------------------------------------------------------------
type X_Winding_Number_Rule is (Clockwise,
Counterclockwise);
None_X_Winding_Rule : constant X_Winding_Number_Rule :=
X_Winding_Number_Rule'Val (0);
------------------------------------------------------------------------------
------------------------------------------------------------------------------
type X_Edge_Table_Entry_Rec;
type X_Edge_Table_Entry is access X_Edge_Table_Entry_Rec;
type X_Edge_Table_Entry_Rec is
record
Y_Max : S_Long := 0; -- y_coord at which we exit this edge.
Bres : Bres_Info; -- Bresenham info to run the edge
Next : X_Edge_Table_Entry; -- next in the list
Back : X_Edge_Table_Entry; -- for insertion sort
Next_Wete : -- for winding num rule
X_Edge_Table_Entry;
Clock_Wise : -- flag for winding number rule
X_Winding_Number_Rule := None_X_Winding_Rule;
end record;
--/ if Enable_Deallocation then
pragma Enable_Deallocation (X_Edge_Table_Entry);
--/ end if;
-- procedure Free_X_Edge_Table_Entry is
-- new Unchecked_Deallocation (X_Edge_Table_Entry_Rec,
-- X_Edge_Table_Entry);
type X_Edge_Table_Entry_Array is
array (S_Natural range <>) of X_Edge_Table_Entry;
------------------------------------------------------------------------------
------------------------------------------------------------------------------
type X_Scan_Line_List_Rec;
type X_Scan_Line_List is access X_Scan_Line_List_Rec;
type X_Scan_Line_List_Rec is
record
Scan_Line : S_Long := 0; -- the scan_line represented
Edgelist : -- header node
X_Edge_Table_Entry;
Next : X_Scan_Line_List; -- next in the list
end record;
--/ if Enable_Deallocation then
pragma Enable_Deallocation (X_Scan_Line_List);
--/ end if;
-- procedure Free_X_Scan_Line_List is
-- new Unchecked_Deallocation (X_Scan_Line_List_Rec,
-- X_Scan_Line_List);
------------------------------------------------------------------------------
-- Here is a struct to help with storage allocation
-- so we can allocate a big chunk at a time, and then take
-- pieces from this heap when we need to.
------------------------------------------------------------------------------
Slls_Per_Block : constant := 25;
type X_Scan_Line_List_Block_Rec;
type X_Scan_Line_List_Block is access X_Scan_Line_List_Block_Rec;
type X_Scan_Line_List_Rec_Array is
array (S_Natural range <>) of X_Scan_Line_List;
type X_Scan_Line_List_Block_Rec is
record
Slls : X_Scan_Line_List_Rec_Array (0 .. Slls_Per_Block);
Next : X_Scan_Line_List_Block;
end record;
--/ if Enable_Deallocation then
pragma Enable_Deallocation (X_Scan_Line_List_Block);
--/ end if;
procedure Real_Free_X_Scan_Line_List_Block is
new Unchecked_Deallocation (X_Scan_Line_List_Block_Rec,
X_Scan_Line_List_Block);
------------------------------------------------------------------------------
------------------------------------------------------------------------------
type X_Edge_Table is
record
Y_Max : S_Long := 0; -- y_max for the polygon
Y_Min : S_Long := 0; -- y_min for the polygon
Scan_Lines : -- header node
X_Scan_Line_List;
end record;
------------------------------------------------------------------------------
-- number of points to buffer before sending them off
-- to scan_lines() : Must be an even number
------------------------------------------------------------------------------
X_Num_Pts_To_Buffer : constant := 200;
------------------------------------------------------------------------------
-- X_Point_Block_Rec - used to allocate buffers for points and link the
-- buffers together
------------------------------------------------------------------------------
type X_Point_Block_Rec;
type X_Point_Block is access X_Point_Block_Rec;
type X_Point_Block_Rec is
record
Pts : X_Point_Array (0 .. X_Num_Pts_To_Buffer - 1);
Next : X_Point_Block := null;
end record;
--/ if Enable_Deallocation then
pragma Enable_Deallocation (X_Point_Block);
--/ end if;
procedure Free_X_Point_Block is
new Unchecked_Deallocation (X_Point_Block_Rec, X_Point_Block);
------------------------------------------------------------------------------
-- These are the data structures needed to scan
-- convert regions. Two different scan conversion
-- methods are available -- the even-odd method, and
-- the winding number method.
-- The even-odd rule states that a point is inside
-- the polygon if a ray drawn from that point in any
-- direction will pass through an odd number of
-- path segments.
-- By the winding number rule, a point is decided
-- to be inside the polygon if a ray drawn from that
-- point in any direction passes through a different
-- number of clockwise and counter-clockwise path
-- segments.
--
-- These data structures are adapted somewhat from
-- the algorithm in (Foley/Van D_am) for scan converting
-- polygons.
-- The basic algorithm is to start at the top (smallest y)
-- of the polygon, stepping down to the bottom of
-- the polygon by incrementing the y coordinate. We
-- keep a list of edges which the current scan_line crosses,
-- sorted by x. This list is called the Active Edge Table (AET)
-- As we change the y-coordinate, we update each entry in
-- in the active edge table to reflect the edges new x_coord.
-- This list must be sorted at each scan_line in case
-- two edges intersect.
-- We also keep a data structure known as the Edge Table (ET),
-- which keeps track of all the edges which the current
-- scan_line has not yet reached. The ET is basically a
-- list of Scan_Line_List structures containing a list of
-- edges which are entered at a given scan_line. There is one
-- Scan_Line_List per scan_line at which an edge is entered.
-- When we enter a new edge, we move it from the ET to the AET.
--
-- From the AET, we can implement the even-odd rule as in
-- (Foley/Van D_am).
-- The winding number rule is a little trickier. We also
-- keep the Edge_Table_Entries in the AET linked by the
-- next_WETE (winding Edge_Table_Entry) link. This allows
-- the edges to be linked just as before for updating
-- purposes, but only uses the edges linked by the next_WETE
-- link as edges representing spans of the polygon to
-- drawn (as with the even-odd rule).
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- In scan converting polygons, we want to choose those pixels
-- which are inside the polygon. Thus, we add .5 to the starting
-- x coordinate for both left and right edges. Now we choose the
-- first pixel which is inside the polygon for the left edge and the
-- first pixel which is outside the polygon for the right edge.
-- Draw the left pixel, but not the right.
--
-- How to add .5 to the starting x coordinate:
-- If the edge is moving to the right, then subtract dy from the
-- error term from the general form of the algorithm.
-- If the edge is moving to the left, then add dy to the error term.
--
-- The reason for the difference between edges moving to the left
-- and edges moving to the right is simple: If an edge is moving
-- to the right, then we want the algorithm to flip immediately.
-- If it is moving to the left, then we don't want it to flip until
-- we traverse an entire pixel.
------------------------------------------------------------------------------
Max_Short : constant := 32767;
Min_Short : constant := -Max_Short;
Large_Coordinate : constant := 1000000;
Small_Coordinate : constant := -Large_Coordinate;
--\f
function Extent_Check (R1 : X_Box_Rec;
R2 : X_Box_Rec) return Boolean is
begin
return not ((R1.X2 <= R2.X1) or else
(R1.X1 >= R2.X2) or else
(R1.Y2 <= R2.Y1) or else
(R1.Y1 >= R2.Y2));
end Extent_Check;
--\f
-- procedure Extents (R : X_Box_Rec; Id_Rect : X_Region) is
-- begin
-- if R.X1 < Id_Rect.Extents.X1 then
-- Id_Rect.Extents.X1 := R.X1;
-- end if;
-- if R.Y1 < Id_Rect.Extents.Y1 then
-- Id_Rect.Extents.Y1 := R.Y1;
-- end if;
-- if R.X2 > Id_Rect.Extents.X2 then
-- Id_Rect.Extents.X2 := R.X2;
-- end if;
-- if R.Y2 > Id_Rect.Extents.Y2 then
-- Id_Rect.Extents.Y2 := R.Y2;
-- end if;
-- end Extents;
--\f
-- procedure Mem_Check (Reg : X_Region) is
-- New_Rect : X_Box_List;
-- begin
--
-- if Reg.Num_Rects >= Reg.Size - 1 then
-- New_Rect := new X_Box_Array (1 .. 2 * s_natural (Reg.Size));
-- New_Rect (Reg.Rects'Range) := Reg.Rects.all;
-- Free_X_Box_List (Reg.Rects);
-- Reg.Rects := New_Rect;
-- Reg.Size := Reg.Size * 2;
-- end if;
--
-- end Mem_Check;
--\f
procedure Empty_Region (P_Reg : X_Region) is
begin
P_Reg.Num_Rects := 0;
end Empty_Region;
--\f
function Region_Not_Empty (P_Reg : X_Region) return Boolean is
begin
return P_Reg.Num_Rects /= 0;
end Region_Not_Empty;
--\f
function In_Box (R : X_Box_Rec;
X : S_Short;
Y : S_Short) return Boolean is
begin
return (R.X2 >= X) and then
(R.X1 <= X) and then
(R.Y2 >= Y) and then
(R.Y1 <= Y);
end In_Box;
--\f
------------------------------------------------------------------------------
-- Clean up our act.
------------------------------------------------------------------------------
procedure Free_X_Scan_Line_List_Block
(P_Sll_Block : in out X_Scan_Line_List_Block) is
Tmp_Sll_Block : X_Scan_Line_List_Block;
begin
while P_Sll_Block /= null loop
Tmp_Sll_Block := P_Sll_Block.Next;
Real_Free_X_Scan_Line_List_Block (P_Sll_Block);
P_Sll_Block := Tmp_Sll_Block;
end loop;
end Free_X_Scan_Line_List_Block;
--\f
procedure B_Res_Init_Pgon (Dy : S_Long;
X1 : S_Long;
X2 : S_Long;
X_Start : out S_Long;
D : out S_Long;
M : out S_Long;
M1 : out S_Long;
Incr1 : out S_Long;
Incr2 : out S_Long) is
Dx : S_Long; -- local storage
Q : S_Long;
Q1 : S_Long;
begin
-- if the edge is horizontal, then it is ignored
-- and assumed not to be processed. Otherwise, do this stuff.
if Dy /= 0 then
X_Start := X1;
Dx := X2 - X1;
if Dx < 0 then
Q := Dx / Dy;
M := Q;
Q1 := Q - 1;
M1 := Q1;
Incr1 := -2 * Dx + 2 * Dy * Q1;
Incr2 := -2 * Dx + 2 * Dy * Q;
D := 2 * Q * Dy - 2 * Dx - 2 * Dy;
else
Q := Dx / Dy;
M := Q;
Q1 := Q + 1;
M1 := Q1;
Incr1 := 2 * Dx - 2 * Dy * Q1;
Incr2 := 2 * Dx - 2 * Dy * Q;
D := (-2) * Q * Dy + 2 * Dx;
end if;
end if;
end B_Res_Init_Pgon;
--\f
procedure B_Res_Incr_Pgon (D : in out S_Long;
Minval : in out S_Long;
M : S_Long;
M1 : S_Long;
Incr1 : S_Long;
Incr2 : S_Long) is
begin
if M1 > 0 then
if D > 0 then
Minval := Minval + M1;
D := D + Incr1;
else
Minval := Minval + M;
D := D + Incr2;
end if;
else
if D >= 0 then
Minval := Minval + M1;
D := D + Incr1;
else
Minval := Minval + M;
D := D + Incr2;
end if;
end if;
end B_Res_Incr_Pgon;
--\f
procedure B_Res_Init_Pgon_Struct (Dmaj : S_Long;
Min1 : S_Long;
Min2 : S_Long;
Bres : out Bres_Info) is
begin
B_Res_Init_Pgon (Dmaj, Min1, Min2, Bres.Minor_Axis, Bres.D,
Bres.M, Bres.M1, Bres.Incr1, Bres.Incr2);
end B_Res_Init_Pgon_Struct;
--\f
procedure B_Res_Incr_Pgon_Struct (Bres : in out Bres_Info) is
begin
B_Res_Incr_Pgon (Bres.D, Bres.Minor_Axis, Bres.M,
Bres.M1, Bres.Incr1, Bres.Incr2);
end B_Res_Incr_Pgon_Struct;
--\f
------------------------------------------------------------------------------
-- a few macros for the inner loops of the fill code where
-- performance considerations don't allow a procedure call.
--
-- Evaluate the given edge at the given scan_line.
-- If the edge has expired, then we leave it and fix up
-- the active edge table; otherwise, we increment the
-- x value to be ready for the next scan_line.
-- The winding number rule is in effect, so we must notify
-- the caller when the edge has been removed so he
-- can reorder the Winding Active Edge Table.
------------------------------------------------------------------------------
procedure Evaluate_Edge_Winding (P_Aet : in out X_Edge_Table_Entry;
P_Prev_Aet : in out X_Edge_Table_Entry;
Y : S_Long;
Fix_Waet : in out Boolean) is
begin
if P_Aet.Y_Max = Y then -- leaving this edge
P_Prev_Aet.Next := P_Aet.Next;
P_Aet := P_Prev_Aet.Next;
Fix_Waet := True;
if P_Aet /= null then
P_Aet.Back := P_Prev_Aet;
end if;
else
B_Res_Incr_Pgon_Struct (P_Aet.Bres);
P_Prev_Aet := P_Aet;
P_Aet := P_Aet.Next;
end if;
end Evaluate_Edge_Winding;
--\f
------------------------------------------------------------------------------
-- Evaluate the given edge at the given scan_line.
-- If the edge has expired, then we leave it and fix up
-- the active edge table; otherwise, we increment the
-- x value to be ready for the next scan_line.
-- The even-odd rule is in effect.
------------------------------------------------------------------------------
procedure Evaluate_Edge_Even_Odd (P_Aet : in out X_Edge_Table_Entry;
P_Prev_Aet : in out X_Edge_Table_Entry;
Y : S_Long) is
begin
if P_Aet.Y_Max = Y then -- leaving this edge
P_Prev_Aet.Next := P_Aet.Next;
P_Aet := P_Prev_Aet.Next;
if P_Aet /= null then
P_Aet.Back := P_Prev_Aet;
end if;
else
B_Res_Incr_Pgon_Struct (P_Aet.Bres);
P_Prev_Aet := P_Aet;
P_Aet := P_Aet.Next;
end if;
end Evaluate_Edge_Even_Odd;
--\f
------------------------------------------------------------------------------
-- Insert_Edge_In_ET
--
-- Insert the given edge into the edge table.
-- First we must find the correct bucket in the
-- Edge table, then find the right slot in the
-- bucket. Finally, we can insert it.
------------------------------------------------------------------------------
procedure Insert_Edge_In_Et (Et : X_Edge_Table;
Ete : X_Edge_Table_Entry;
Scan_Line : S_Long;
Sll_Block : in out X_Scan_Line_List_Block;
I_Sll_Block : in out S_Natural) is
Start : X_Edge_Table_Entry;
Prev : X_Edge_Table_Entry;
P_Sll : X_Scan_Line_List;
P_Prev_Sll : X_Scan_Line_List;
Tmp_Sll_Block : X_Scan_Line_List_Block;
begin
----Find the right bucket to put the edge into.
P_Prev_Sll := Et.Scan_Lines;
P_Sll := P_Prev_Sll.Next;
while P_Sll /= null and then P_Sll.Scan_Line < Scan_Line loop
P_Prev_Sll := P_Sll;
P_Sll := P_Sll.Next;
end loop;
----Reassign p_SLL (pointer to Scan_Line_List) if necessary
if P_Sll = null or else P_Sll.Scan_Line > Scan_Line then
if I_Sll_Block > Slls_Per_Block - 1 then
Tmp_Sll_Block := new X_Scan_Line_List_Block_Rec;
Sll_Block.Next := Tmp_Sll_Block;
Tmp_Sll_Block.Next := null;
Sll_Block := Tmp_Sll_Block;
I_Sll_Block := 0;
end if;
P_Sll := Sll_Block.Slls (I_Sll_Block);
I_Sll_Block := I_Sll_Block + 1;
P_Sll.Next := P_Prev_Sll.Next;
P_Sll.Edgelist := null;
P_Prev_Sll.Next := P_Sll;
end if;
P_Sll.Scan_Line := Scan_Line;
----Now insert the edge in the right bucket
Prev := null;
Start := P_Sll.Edgelist;
while Start /= null and then
Start.Bres.Minor_Axis < Ete.Bres.Minor_Axis loop
Prev := Start;
Start := Start.Next;
end loop;
Ete.Next := Start;
if Prev /= null then
Prev.Next := Ete;
else
P_Sll.Edgelist := Ete;
end if;
end Insert_Edge_In_Et;
--\f
procedure Create_Et_And_Aet (Pts : X_Point_Array;
Et : in out X_Edge_Table;
Aet : X_Edge_Table_Entry;
P_Etes : X_Edge_Table_Entry_Array;
P_Sll_Block_In : X_Scan_Line_List_Block) is
------------------------------------------------------------------------------
-- Create_Edge_Table
--
-- This routine creates the edge table for
-- scan converting polygons.
-- The Edge Table (ET) looks like:
--
-- Edge_Table
-- ---------
-- | y_max | Scan_Line_Lists
-- |scan_line|...---------.....---------....
-- -------- |scan_line| |scan_line|
-- |edgelist | |edgelist |
-- --------- ---------
-- | |
-- | |
-- V V list of ETEs list of ETEs
--
-- where ETE is an Edge_Table_Entry data structure,
-- and there is one Scan_Line_List per scan_line at
-- which an edge is initially entered.
--
------------------------------------------------------------------------------
P_Sll_Block : X_Scan_Line_List_Block := P_Sll_Block_In;
Top : S_Natural;
Bottom : S_Natural;
Prev_Pt : S_Natural;
I_Sll_Block : S_Natural := 0;
Dy : S_Long;
P_Etes_I : S_Natural := P_Etes'First;
begin
if Pts'Length < 2 then
return;
end if;
----Initialize the Active Edge Table
Aet.Next := null;
Aet.Back := null;
Aet.Next_Wete := null;
Aet.Bres.Minor_Axis := Small_Coordinate;
----Initialize the Edge Table.
Et.Scan_Lines.Next := null;
Et.Y_Max := Small_Coordinate;
Et.Y_Min := Large_Coordinate;
P_Sll_Block.Next := null;
Prev_Pt := Pts'Length - 1;
----For each vertex in the array of points...
-- In this loop we are dealing with two vertices at a time. These make up
-- one edge of the polygon.
for Curr_Pt in Pts'First .. Pts'First + Pts'Length - 1 loop
----Find out which point is above and which is below.
if Pts (Prev_Pt).Y > Pts (Curr_Pt).Y then
Bottom := Prev_Pt;
Top := Curr_Pt;
P_Etes (P_Etes_I).Clock_Wise := Counterclockwise;
else
Bottom := Curr_Pt;
Top := Prev_Pt;
P_Etes (P_Etes_I).Clock_Wise := Clockwise;
end if;
----Don't add horizontal edges to the Edge table.
if Pts (Bottom).Y /= Pts (Top).Y then
P_Etes (P_Etes_I).Y_Max := S_Long (Pts (Bottom).Y) - 1;
-- -1 so we don't get last scan_line
----Initialize integer edge algorithm
Dy := S_Long (Pts (Bottom).Y) - S_Long (Pts (Top).Y);
B_Res_Init_Pgon_Struct (Dy, S_Long (Pts (Top).X),
S_Long (Pts (Bottom).X),
P_Etes (P_Etes_I).Bres);
Insert_Edge_In_Et (Et, P_Etes (P_Etes_I), S_Long (Pts (Top).Y),
P_Sll_Block, I_Sll_Block);
Et.Y_Max := Max (Et.Y_Max, S_Long (Pts (Prev_Pt).Y));
Et.Y_Min := Min (Et.Y_Min, S_Long (Pts (Prev_Pt).Y));
P_Etes_I := P_Etes_I + 1;
end if;
Prev_Pt := Curr_Pt;
end loop;
end Create_Et_And_Aet;
--\f
procedure Load_Aet (Aet_In : X_Edge_Table_Entry;
Etes_In : X_Edge_Table_Entry) is
------------------------------------------------------------------------------
-- load_AET
--
-- This routine moves Edge_Table_Entries from the
-- Edge_Table into the Active Edge Table,
-- leaving them sorted by smaller x coordinate.
--
------------------------------------------------------------------------------
Aet : X_Edge_Table_Entry := Aet_In;
Etes : X_Edge_Table_Entry := Etes_In;
P_Prev_Aet : X_Edge_Table_Entry;
Tmp : X_Edge_Table_Entry;
begin
P_Prev_Aet := Aet;
Aet := Aet.Next;
while Etes /= null loop
while Aet /= null and then
Aet.Bres.Minor_Axis < Etes.Bres.Minor_Axis loop
P_Prev_Aet := Aet;
Aet := Aet.Next;
end loop;
Tmp := Etes.Next;
Etes.Next := Aet;
if Aet /= null then
Aet.Back := Etes;
end if;
Etes.Back := P_Prev_Aet;
P_Prev_Aet.Next := Etes;
P_Prev_Aet := Etes;
Etes := Tmp;
end loop;
end Load_Aet;
--\f
procedure Compute_Waet (Aet_In : X_Edge_Table_Entry) is
------------------------------------------------------------------------------
-- compute_WAET
--
-- This routine links the AET by the
-- next_WETE (winding Edge_Table_Entry) link for
-- use by the winding number rule. The final
-- Active Edge Table (AET) might look something
-- like:
--
-- AET
-- ---------- --------- ---------
-- |y_max or |y_max or |y_max or
-- or ... or |... or |... |
-- |next |.|next |.|next |....
-- |next_WETE| |next_WETE| |next_WETE|
-- --------- --------- ^--------
-- or or |
-- V------------------. V--. ...
--
------------------------------------------------------------------------------
P_Wete : X_Edge_Table_Entry;
Aet : X_Edge_Table_Entry := Aet_In;
Inside : Boolean := True;
Isinside : Integer := 0;
begin
Aet.Next_Wete := null;
P_Wete := Aet;
Aet := Aet.Next;
while Aet /= null loop
if Aet.Clock_Wise = Clockwise then
Isinside := Isinside + 1;
else
Isinside := Isinside - 1;
end if;
if (not Inside and then Isinside = 0) or else
(Inside and then Isinside /= 0) then
P_Wete.Next_Wete := Aet;
P_Wete := Aet;
Inside := not Inside;
end if;
Aet := Aet.Next;
end loop;
P_Wete.Next_Wete := null;
end Compute_Waet;
--\f
function Insertion_Sort (Aet_In : X_Edge_Table_Entry) return Boolean is
------------------------------------------------------------------------------
-- Insertion_Sort
--
-- Just a simple insertion sort using
-- pointers and back pointers to sort the Active
-- Edge Table.
------------------------------------------------------------------------------
Aet : X_Edge_Table_Entry := Aet_In;
P_Ete_Chase : X_Edge_Table_Entry;
P_Ete_Insert : X_Edge_Table_Entry;
P_Ete_Chase_Back_Tmp : X_Edge_Table_Entry;
Changed : Boolean := False;
begin
Aet := Aet.Next;
while Aet /= null loop
P_Ete_Insert := Aet;
P_Ete_Chase := Aet;
while P_Ete_Chase.Back.Bres.Minor_Axis > Aet.Bres.Minor_Axis loop
P_Ete_Chase := P_Ete_Chase.Back;
end loop;
Aet := Aet.Next;
if P_Ete_Chase /= P_Ete_Insert then
P_Ete_Chase_Back_Tmp := P_Ete_Chase.Back;
P_Ete_Insert.Back.Next := Aet;
if Aet /= null then
Aet.Back := P_Ete_Insert.Back;
end if;
P_Ete_Insert.Next := P_Ete_Chase;
P_Ete_Chase.Back.Next := P_Ete_Insert;
P_Ete_Chase.Back := P_Ete_Insert;
P_Ete_Insert.Back := P_Ete_Chase_Back_Tmp;
Changed := True;
end if;
end loop;
return Changed;
end Insertion_Sort;
--\f
procedure Pts_To_Region (Num_Full_Pt_Blocks_In : S_Natural;
I_Cur_Pt_Block : S_Natural;
First_Pt_Block : X_Point_Block;
Reg : X_Region;
Success : out Boolean) is
------------------------------------------------------------------------------
-- Create an array of rectangles from a list of points.
-- If indeed these things (POINTS, RECTS) are the same,
-- then this proc is still needed, because it allocates
-- storage for the array, which was allocated on the
-- stack by the calling procedure.
------------------------------------------------------------------------------
Num_Full_Pt_Blocks : S_Natural := Num_Full_Pt_Blocks_In;
Rects : S_Natural;
Cur_Pt_Block : X_Point_Block;
Extents : X_Box_Rec renames Reg.Extents;
Num_Rects : S_Natural;
begin
Num_Rects :=
(Num_Full_Pt_Blocks * X_Num_Pts_To_Buffer + I_Cur_Pt_Block) / 2;
begin
Reg.Rects := new X_Box_Array (1 .. Num_Rects);
exception
when Storage_Error =>
Success := False;
return;
end;
Reg.Size := Num_Rects;
Cur_Pt_Block := First_Pt_Block;
Rects := 1;
Extents.X1 := Max_Short;
Extents.X2 := Min_Short;
while Num_Full_Pt_Blocks /= 0 loop
Num_Full_Pt_Blocks := Num_Full_Pt_Blocks - 1;
for I in 1 .. S_Natural (X_Num_Pts_To_Buffer) / 2 loop
-- the loop uses 2 points per iteration
declare
Pts : X_Point renames Cur_Pt_Block.Pts
(Cur_Pt_Block.Pts'First - 1 + I);
Pts1 : X_Point renames Cur_Pt_Block.Pts
(Cur_Pt_Block.Pts'First + I);
Rect : X_Box_Rec renames Reg.Rects (Rects);
begin
Rect.X1 := Pts.X;
Rect.Y1 := Pts.Y;
if Pts1.X = Rect.X1 then
Num_Rects := Num_Rects - 1;
else
Rect.X2 := Pts1.X;
Rect.Y2 := Pts1.Y + 1;
Extents.X1 := Min (Extents.X1, Pts.X);
Extents.X2 := Max (Extents.X2, Pts1.X);
Rects := Rects + 1;
end if;
end;
end loop;
Cur_Pt_Block := Cur_Pt_Block.Next;
end loop;
if I_Cur_Pt_Block /= 0 then
for I in 1 .. I_Cur_Pt_Block / 2 loop
while I_Cur_Pt_Block /= 0 loop
declare
Pts : X_Point
renames Cur_Pt_Block.Pts
(Cur_Pt_Block.Pts'First - 2 + 2 * I);
Pts1 : X_Point
renames Cur_Pt_Block.Pts
(Cur_Pt_Block.Pts'First - 1 + 2 * I);
Rect : X_Box_Rec renames Reg.Rects (Rects);
begin
Rect.X1 := Pts.X;
Rect.Y1 := Pts.Y;
if Pts1.X = Rect.X1 then
Num_Rects := Num_Rects - 1;
else
Rect.X2 := Pts1.X;
Rect.Y2 := Pts1.Y + 1;
Extents.X1 := Min (Extents.X1, Pts.X);
Extents.X2 := Max (Extents.X2, Pts1.X);
Rects := Rects + 1;
end if;
end;
end loop;
end loop;
if Num_Rects > 0 then
Extents.Y1 := Reg.Rects (0).Y1;
Extents.Y2 := Cur_Pt_Block.Pts (Cur_Pt_Block.Pts'First +
I_Cur_Pt_Block).Y + 1;
end if;
end if;
Reg.Num_Rects := Num_Rects;
Reg.Size := Reg.Num_Rects;
Success := True;
end Pts_To_Region;
--\f
function X_Polygon_Region (Points : X_Point_Array;
Rule : X_Fill_Rule) return X_Region is
------------------------------------------------------------------------------
-- poly_to_region
--
-- Scan converts a polygon by returning a run-length encoding of the resultant
-- bitmap -- the run-length encoding is in the form of an array of rectangles.
------------------------------------------------------------------------------
Regn : X_Region;
Y : S_Long; -- current scan line
P_Aet : X_Edge_Table_Entry; -- Active Edge Table
I_Pts : S_Natural := 0; -- number of points in buffer
P_Wete : X_Edge_Table_Entry; -- Winding Edge Table Entry
P_Sll : X_Scan_Line_List; -- current scan_Line_List
L_Pts : X_Point_Block; -- output buffer
L_I_Pts : S_Natural;
P_Prev_Aet : X_Edge_Table_Entry; -- ptr to previous AET
Et : X_Edge_Table; -- header node for ET
Aet : X_Edge_Table_Entry; -- header node for AET
P_Etes : X_Edge_Table_Entry_Array (1 .. Points'Length);-- ETE pool
Sll_Block : X_Scan_Line_List_Block; -- header for scan_line_list
Fix_Waet : Boolean := False;
First_Pt_Block : X_Point_Block;
Cur_Pt_Block : X_Point_Block; -- Pt_Block buffers
Tmp_Pt_Block : X_Point_Block;
Num_Full_Pt_Blocks : S_Natural := 0;
Void : Boolean;
begin
Regn := X_Create_Region;
if Regn = None_X_Region then
return None_X_Region;
end if;
----Special case a rectangle.
I_Pts := Points'First;
if (Points'Length = 4 or else
(Points'Length = 5 and then
Points (4).X = Points (0).X and then
Points (4).Y = Points (0).Y)) and then
((Points (0).Y = Points (1).Y and then
Points (1).X = Points (2).X and then
Points (2).Y = Points (3).Y and then
Points (3).X = Points (0).X) or else
(Points (0).X = Points (1).X and then
Points (1).Y = Points (2).Y and then
Points (2).X = Points (3).X and then
Points (3).Y = Points (0).Y)) then
Regn.Extents.X1 := Min (Points (0).X, Points (2).X);
Regn.Extents.Y1 := Min (Points (0).Y, Points (2).Y);
Regn.Extents.X2 := Max (Points (0).X, Points (2).X);
Regn.Extents.Y2 := Max (Points (0).Y, Points (2).Y);
if Regn.Extents.X1 /= Regn.Extents.X2 and then
Regn.Extents.Y1 /= Regn.Extents.Y2 then
Regn.Num_Rects := 1;
Regn.Rects := new X_Box_Array'(1 => Regn.Extents);
end if;
return Regn;
end if;
First_Pt_Block := new X_Point_Block_Rec;
L_Pts := First_Pt_Block;
L_I_Pts := L_Pts.Pts'First;
Create_Et_And_Aet (Points, Et, Aet, P_Etes, Sll_Block);
P_Sll := Et.Scan_Lines.Next;
Cur_Pt_Block := First_Pt_Block;
if Rule = Even_Odd_Rule then
----For each scan_line....
Y := Et.Y_Min;
while Y < Et.Y_Max loop
----Add a new edge to the active edge table when we get to the next edge.
if P_Sll /= null and then Y = P_Sll.Scan_Line then
Load_Aet (Aet, P_Sll.Edgelist);
P_Sll := P_Sll.Next;
end if;
P_Prev_Aet := Aet;
P_Aet := Aet.Next;
----For each active edge....
while P_Aet /= null loop
L_Pts.Pts (L_I_Pts).X := S_Short (P_Aet.Bres.Minor_Axis);
L_Pts.Pts (L_I_Pts).Y := S_Short (Y);
L_I_Pts := L_I_Pts + 1;
I_Pts := I_Pts + 1;
----Send out the buffer.
if I_Pts = X_Num_Pts_To_Buffer then
Tmp_Pt_Block := new X_Point_Block_Rec;
Cur_Pt_Block.Next := Tmp_Pt_Block;
Cur_Pt_Block := Tmp_Pt_Block;
L_Pts := Cur_Pt_Block;
L_I_Pts := L_Pts.Pts'First;
Num_Full_Pt_Blocks := Num_Full_Pt_Blocks + 1;
I_Pts := 0;
end if;
Evaluate_Edge_Even_Odd (P_Aet, P_Prev_Aet, Y);
end loop;
Void := Insertion_Sort (Aet);
Y := Y + 1;
end loop;
else
----For each scan_line....
for Y in Et.Y_Min .. Et.Y_Max - 1 loop
----Add a new edge to the active edge table when we get to the next edge.
if P_Sll /= null and then Y = P_Sll.Scan_Line then
Load_Aet (Aet, P_Sll.Edgelist);
Compute_Waet (Aet);
P_Sll := P_Sll.Next;
end if;
P_Prev_Aet := Aet;
P_Aet := Aet.Next;
P_Wete := P_Aet;
----For each active edge....
while P_Aet /= null loop
----Add to the buffer only those edges that are in the Winding active edge table.
if P_Wete = P_Aet then
L_Pts.Pts (L_I_Pts).X :=
S_Short (P_Aet.Bres.Minor_Axis);
L_Pts.Pts (L_I_Pts).Y := S_Short (Y);
L_I_Pts := L_I_Pts + 1;
I_Pts := I_Pts + 1;
----Send out the buffer
if I_Pts = X_Num_Pts_To_Buffer then
Tmp_Pt_Block := new X_Point_Block_Rec;
Cur_Pt_Block.Next := Tmp_Pt_Block;
Cur_Pt_Block := Tmp_Pt_Block;
L_Pts := Cur_Pt_Block;
L_I_Pts := L_Pts.Pts'First;
Num_Full_Pt_Blocks := Num_Full_Pt_Blocks + 1;
I_Pts := 0;
end if;
P_Wete := P_Wete.Next_Wete;
end if;
Evaluate_Edge_Winding (P_Aet, P_Prev_Aet, Y, Fix_Waet);
end loop;
----Recompute the winding active edge table if we just resorted or have exited
-- an edge.
if Insertion_Sort (Aet) or else Fix_Waet then
Compute_Waet (Aet);
Fix_Waet := False;
end if;
end loop;
end if;
Free_X_Scan_Line_List_Block (Sll_Block.Next);
Pts_To_Region (Num_Full_Pt_Blocks, I_Pts, First_Pt_Block, Regn, Void);
----Free up storage used.
Tmp_Pt_Block := First_Pt_Block.Next;
loop
Free_X_Point_Block (First_Pt_Block);
First_Pt_Block := Tmp_Pt_Block;
if First_Pt_Block = null then
exit;
end if;
Tmp_Pt_Block := First_Pt_Block.Next;
end loop;
return Regn;
exception
when others =>
Free_X_Region (Regn);
while First_Pt_Block /= null loop
Tmp_Pt_Block := First_Pt_Block.Next;
Free_X_Point_Block (First_Pt_Block);
First_Pt_Block := Tmp_Pt_Block;
end loop;
raise;
end X_Polygon_Region;
--\f
function Max (A, B : S_Natural) return S_Natural is
begin
if A > B then
return A;
else
return B;
end if;
end Max;
--/ if INLINE then
--// pragma Inline (Max);
--/ end if;
--\f
--
-- The functions in this file implement the Region abstraction used extensively
-- throughout the X11 sample server. A Region is simply an area, as the name
-- implies, and is implemented as a "y-x-banded" array of rectangles. To
-- explain: Each Region is made up of a certain number of rectangles sorted
-- by y coordinate first, and then by x coordinate.
--
-- Furthermore, the rectangles are banded such that every rectangle with a
-- given upper-left y coordinate (y1) will have the same lower-right y
-- coordinate (y2) and vice versa. If a rectangle has scan_lines in a band, it
-- will span the entire vertical distance of the band. This means that some
-- areas that could be merged into a taller rectangle will be represented as
-- several shorter rectangles to account for shorter rectangles to its left
-- or right but within its "vertical scope".
--
-- An added constraint on the rectangles is that they must cover as much
-- horizontal area as possible. E.g. no two rectangles in a band are allowed
-- to touch.
--
-- Whenever possible, bands will be merged together to cover a greater vertical
-- distance (and thus reduce the number of rectangles). Two bands can be merged
-- only if the bottom of one touches the top of the other and they have
-- rectangles in the same places (of the same width, of course). This maintains
-- the y-x-banding that's so nice to have...
--
--\f
function X_Create_Region return X_Region is
------------------------------------------------------------------------------
-- Create a new empty region
------------------------------------------------------------------------------
Temp : X_Region;
begin
Temp := new X_Region_Rec;
Temp.Rects := new X_Box_Array (1 .. 1);
Temp.Num_Rects := 0;
Temp.Extents.X1 := 0;
Temp.Extents.Y1 := 0;
Temp.Extents.X2 := 0;
Temp.Extents.Y2 := 0;
Temp.Size := 1;
return Temp;
exception
when others =>
Free_X_Region (Temp);
raise;
end X_Create_Region;
--\f
procedure X_Clip_Box (Region : X_Region;
Rectangle : out X_Rectangle) is
begin
Rectangle.X := Region.Extents.X1;
Rectangle.Y := Region.Extents.Y1;
Rectangle.Width := U_Short (Region.Extents.X2 - Region.Extents.X1);
Rectangle.Height := U_Short (Region.Extents.Y2 - Region.Extents.Y1);
end X_Clip_Box;
--\f
procedure X_Union_Rect_With_Region (Rectangle : X_Rectangle;
Region : X_Region;
New_Region : X_Region) is
Lregion : X_Region;
begin
Lregion := new X_Region_Rec;
Lregion.Extents.X1 := Rectangle.X;
Lregion.Extents.Y1 := Rectangle.Y;
Lregion.Extents.X2 := Rectangle.X + S_Short (Rectangle.Width);
Lregion.Extents.Y2 := Rectangle.Y + S_Short (Rectangle.Height);
Lregion.Size := 1;
Lregion.Rects := new X_Box_Array'(1 => Region.Extents);
Lregion.Num_Rects := 1;
X_Union_Region (Lregion, Region, New_Region);
Free_X_Region (Lregion);
Free_X_Box_List (Lregion.Rects);
exception
when others =>
Free_X_Region (Lregion);
raise;
end X_Union_Rect_With_Region;
--\f
procedure Mi_Set_Extents (P_Reg : X_Region) is
-------------------------------------------------------------------------
-- mi_Set_Extents --
-- Reset the extents of a region to what they should be. Called by
-- mi_Subtract and mi_Intersect b/c they can't figure it out along the
-- way or do so easily, as mi_Union can.
--
-- Results:
-- None.
--
-- Side Effects:
-- The region's 'extents' structure is overwritten.
--
-------------------------------------------------------------------------
P_Extents : X_Box_Rec renames P_Reg.Extents;
P_Box : X_Box_List renames P_Reg.Rects;
begin
----No rectangles means no extents.
if P_Reg.Num_Rects = 0 then
P_Extents.X1 := 0;
P_Extents.Y1 := 0;
P_Extents.X2 := 0;
P_Extents.Y2 := 0;
return;
end if;
----Since p_Box is the first rectangle in the region, it must have the smallest
-- y1 and since p_Box_End is the last rectangle in the region, it must have
-- the largest y2, because of banding. Initialize x1 and x2 from p_Box and
-- p_Box_End, resp., as good things to initialize them to...
P_Extents.X1 := P_Box (1).X1;
P_Extents.Y1 := P_Box (1).Y1;
P_Extents.X2 := P_Box (P_Reg.Num_Rects).X2;
P_Extents.Y2 := P_Box (P_Reg.Num_Rects).Y2;
--/ if DEBUG then
if not (P_Extents.Y1 < P_Extents.Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
for Pbi in 1 .. P_Reg.Num_Rects loop
if P_Box (Pbi).X1 < P_Extents.X1 then
P_Extents.X1 := P_Box (Pbi).X1;
end if;
if P_Box (Pbi).X2 > P_Extents.X2 then
P_Extents.X2 := P_Box (Pbi).X2;
end if;
end loop;
--/ if DEBUG then
if not (P_Extents.X1 < P_Extents.X2) then
raise X_Library_Confusion;
end if;
--/ end if;
end Mi_Set_Extents;
--\f
procedure X_Set_Region (Display : X_Display;
Gc : X_Gc;
Region : X_Region) is
X_R : X_Rectangle_Array (1 .. Region.Num_Rects);
begin
for I in X_R'Range loop
X_R (I).X := Region.Rects (I).X1;
X_R (I).Y := Region.Rects (I).Y1;
X_R (I).Width := U_Short
(Region.Rects (I).X2 - Region.Rects (I).X1);
X_R (I).Height := U_Short
(Region.Rects (I).Y2 - Region.Rects (I).Y1);
end loop;
X_Set_Clip_Rectangles (Display, Gc, 0, 0, X_R, Unsorted);
end X_Set_Region;
--\f
procedure X_Offset_Region (Region : X_Region;
Dx : S_Short;
Dy : S_Short) is
------------------------------------------------------------------------------
-- Translate_Region(Region, x, y)
-- translates in place
-- added by raymond
------------------------------------------------------------------------------
Pbox : X_Box_List renames Region.Rects;
begin
for I in 1 .. Region.Num_Rects loop
Pbox (I).X1 := Pbox (I).X1 + Dx;
Pbox (I).X2 := Pbox (I).X2 + Dx;
Pbox (I).Y1 := Pbox (I).Y1 + Dy;
Pbox (I).Y2 := Pbox (I).Y2 + Dy;
end loop;
Region.Extents.X1 := Region.Extents.X1 + Dx;
Region.Extents.X2 := Region.Extents.X2 + Dx;
Region.Extents.Y1 := Region.Extents.Y1 + Dy;
Region.Extents.Y2 := Region.Extents.Y2 + Dy;
end X_Offset_Region;
--\f
-- Utility procedure Compress:
-- Replace r by the region r', where
-- p in r' iff (Quantifer m <= dx) (p + m in r), and
-- Quantifier is Exists if grow is TRUE, For all if grow is FALSE, and
-- (x,y) + m = (x+m,y) if xdir is TRUE; (x,y+m) if xdir is FALSE.
--
-- Thus, if xdir is TRUE and grow is FALSE, r is replaced by the region
-- of all points p such that p and the next dx points on the same
-- horizontal scan line are all in r. We do this using by noting
-- that p is the head of a run of length 2^i + k iff p is the head
-- of a run of length 2^i and p+2^i is the head of a run of length
-- k. Thus, the loop invariant: s contains the region corresponding
-- to the runs of length shift. r contains the region corresponding
-- to the runs of length 1 + dxo & (shift-1), where dxo is the original
-- value of dx. dx = dxo & ~(shift-1). As parameters, s and t are
-- scratch regions, so that we don't have to allocate them on every
-- call.
procedure Compress (R : X_Region;
S : X_Region;
T : X_Region;
Dx : S_Short;
Xdir : Boolean;
Grow : Boolean) is
Shift : S_Short := 1;
Rp : X_Region := R;
Sp : X_Region := S;
Tp : X_Region := T;
Dxi : S_Short := Dx;
procedure Zopregion (A : X_Region; B : X_Region; C : X_Region) is
begin
if Grow then
X_Union_Region (A, B, C);
else
X_Intersect_Region (A, B, C);
end if;
end Zopregion;
procedure Zshiftregion (A : X_Region; B : S_Short) is
begin
if Xdir then
X_Offset_Region (A, B, 0);
else
X_Offset_Region (A, 0, B);
end if;
end Zshiftregion;
procedure Zcopyregion (A : X_Region; B : X_Region) is
begin
X_Union_Region (A, A, B);
end Zcopyregion;
begin
Zcopyregion (Rp, Sp);
while Dxi /= 0 loop
if Dxi mod 2 /= 0 then
Zshiftregion (Rp, -Shift);
Zopregion (Rp, Sp, Rp);
Dxi := Dxi / 2;
if Dxi = 0 then
exit;
end if;
end if;
Zcopyregion (Sp, Tp);
Zshiftregion (Sp, -Shift);
Zopregion (Sp, Tp, Sp);
if Dxi /= 0 then
----We don't want overflow; dxi /= 0 means this is ok.
Shift := Shift + Shift;
end if;
end loop;
end Compress;
--\f
procedure X_Shrink_Region (Region : X_Region;
Dx : S_Short;
Dy : S_Short) is
Regioni : X_Region := Region;
S : X_Region;
T : X_Region;
Grow : Boolean;
Dxi : S_Short := Dx;
Dyi : S_Short := Dy;
begin
if Dx = 0 and then
Dy = 0 then
return;
end if;
S := new X_Region_Rec;
T := new X_Region_Rec;
Grow := Dxi < 0;
if Grow then
Dxi := -Dxi;
end if;
if Dxi /= 0 then
Compress (Regioni, S, T, 2 * Dxi, True, Grow);
end if;
Grow := Dyi < 0;
if Grow then
Dyi := -Dyi;
end if;
if Dyi /= 0 then
Compress (Regioni, S, T, 2 * Dyi, False, Grow);
end if;
X_Offset_Region (Region, Dxi, Dyi);
Free_X_Region (S);
Free_X_Region (T);
exception
when others =>
Free_X_Region (S);
Free_X_Region (T);
raise;
end X_Shrink_Region;
--\f
-- #ifdef notdef
-- --**********************************************************
-- -- Bop down the array of rects until we have passed
-- -- scan_line y. num_Rects is the size of the array.
-- --*********************************************************
--
-- static BOX
-- *Index_Rects(rects, num_Rects, y)
-- BOX *rects;
-- s_long num_Rects;
-- s_long y;
-- {
-- while ((num_Rects--) and then (rects.y2 <= y))
-- rects++;
-- return(rects);
-- }
-- #endif
--\f
--======================================================================
-- Generic Region Operator
--====================================================================
function Mi_Coalesce
(P_Reg : X_Region; -- Region to coalesce
Prev_Start_In : S_Natural; -- Index of start of previous band
Cur_Start_In : S_Natural) -- Index of start of current band
return S_Natural is
-------------------------------------------------------------------------
-- mi_Coalesce --
-- Attempt to merge the boxes in the current band with those in the
-- previous one. Used only by mi_Region_Op.
--
-- Results:
-- The new index for the previous band.
--
-- Side Effects:
-- If coalescing takes place:
-- - rectangles in the previous band will have their y2 fields altered.
-- - p_Reg.num_Rects will be decreased.
--
-------------------------------------------------------------------------
Prev_Start : S_Natural := Prev_Start_In;
Cur_Start : S_Natural := Cur_Start_In;
P_Prev_Box : S_Natural; -- Current box in previous band
P_Cur_Box : S_Natural; -- Current box in current band
P_Reg_End : S_Natural; -- End of regionn
Cur_Num_Rects : S_Natural; -- Number of rectangles in current band
Prev_Num_Rects : S_Natural; -- Number of rectangles in previous band
Bandy1 : S_Short; -- Y1 coordinate for current band
begin
P_Reg_End := P_Reg.Num_Rects + 1;
P_Prev_Box := Prev_Start;
Prev_Num_Rects := Cur_Start - Prev_Start;
----Figure out how many rectangles are in the current band. Have to do this
-- because multiple bands could have been added in mi_Region_Op at the end
-- when one region has been exhausted.
P_Cur_Box := Cur_Start;
Bandy1 := P_Reg.Rects (P_Cur_Box).Y1;
Cur_Num_Rects := 0;
while P_Cur_Box < P_Reg_End and then
P_Reg.Rects (P_Cur_Box).Y1 = Bandy1 loop
Cur_Num_Rects := Cur_Num_Rects + 1;
P_Cur_Box := P_Cur_Box + 1;
end loop;
----If more than one band was added, we have to find the start of the last band
-- added so the next coalescing job can start at the right place... (given when
-- multiple bands are added, this may be pointless -- see above).
if P_Cur_Box < P_Reg_End then
Cur_Start := P_Reg_End - 1;
while P_Reg.Rects (Cur_Start - 1).Y1 =
P_Reg.Rects (Cur_Start).Y1 loop
Cur_Start := Cur_Start - 1;
end loop;
end if;
if Cur_Num_Rects = Prev_Num_Rects and then Cur_Num_Rects /= 0 then
P_Cur_Box := P_Cur_Box - Cur_Num_Rects;
----The bands may only be coalesced if the bottom of the previous matches the
-- top scan_line of the current.
if P_Reg.Rects (P_Prev_Box).Y2 = P_Reg.Rects (P_Cur_Box).Y1 then
----Make sure the bands have boxes in the same places. This assumes that boxes
-- have been added in such a way that they cover the most area possible. I.e.
-- two boxes in a band must have some horizontal space between them.
loop
if P_Reg.Rects (P_Prev_Box).X1 /=
P_Reg.Rects (P_Cur_Box).X1 or else
P_Reg.Rects (P_Prev_Box).X2 /=
P_Reg.Rects (P_Cur_Box).X2 then
----The bands don't line up so they can't be coalesced.
return Cur_Start;
end if;
P_Prev_Box := P_Prev_Box + 1;
P_Cur_Box := P_Cur_Box + 1;
Prev_Num_Rects := Prev_Num_Rects - 1;
if Prev_Num_Rects = 0 then
exit;
end if;
end loop;
P_Reg.Num_Rects := P_Reg.Num_Rects - Cur_Num_Rects;
P_Cur_Box := P_Cur_Box - Cur_Num_Rects;
P_Prev_Box := P_Prev_Box - Cur_Num_Rects;
----The bands may be merged, so set the bottom y of each box in the previous
-- band to that of the corresponding box in the current band.
loop
P_Reg.Rects (P_Prev_Box).Y2 := P_Reg.Rects (P_Cur_Box).Y2;
P_Prev_Box := P_Prev_Box + 1;
P_Cur_Box := P_Cur_Box + 1;
Cur_Num_Rects := Cur_Num_Rects - 1;
if Cur_Num_Rects = 0 then
exit;
end if;
end loop;
----If only one band was added to the region, we have to backup cur_Start to
-- the start of the previous band.
--
-- If more than one band was added to the region, copy the other bands down.
-- The assumption here is that the other bands came from the same region as
-- the current one and no further coalescing can be done on them since it's
-- all been done already... Cur_Start is already in the right place.
if P_Cur_Box = P_Reg_End then
Cur_Start := Prev_Start;
else
loop
P_Reg.Rects (P_Prev_Box) := P_Reg.Rects (P_Cur_Box);
P_Prev_Box := P_Prev_Box + 1;
P_Cur_Box := P_Cur_Box + 1;
if P_Cur_Box = P_Reg_End then
exit;
end if;
end loop;
end if;
end if;
end if;
return Cur_Start;
end Mi_Coalesce;
--\f
generic
Overlap_Func_Non_Null : in Boolean;
Non_Overlap1_Func_Non_Null : in Boolean;
Non_Overlap2_Func_Non_Null : in Boolean;
with procedure Overlap_Func (New_Reg : X_Region;
Reg1 : X_Box_List;
Reg1_Begin : S_Natural;
Reg1_End : S_Natural;
Reg2 : X_Box_List;
Reg2_Begin : S_Natural;
Reg2_End : S_Natural;
Y_Top : S_Short;
Y_Bot : S_Short);
-- called for overlapping bands
with procedure Non_Overlap1_Func (New_Reg : X_Region;
Reg1 : X_Box_List;
Reg1_Begin : S_Natural;
Reg1_End : S_Natural;
Top : S_Short;
Bot : S_Short);
-- called for non-overlapping bands in region 1
with procedure Non_Overlap2_Func (New_Reg : X_Region;
Reg2 : X_Box_List;
Reg2_Begin : S_Natural;
Reg2_End : S_Natural;
Top : S_Short;
Bot : S_Short);
-- called for non-overlapping bands in region 2
procedure Mi_Region_Op (New_Reg : X_Region; -- Place to store result
Reg1 : X_Region; -- First region in operation
Reg2 : X_Region); -- 2d region in operation
procedure Mi_Region_Op (New_Reg : X_Region; -- Place to store result
Reg1 : X_Region; -- 1st region in operation
Reg2 : X_Region) is -- 2nd region in operation
-------------------------------------------------------------------------
-- mi_Region_Op --
-- Apply an operation to two regions. Called by mi_Union, mi_Inverse,
-- mi_Subtract, mi_Intersect...
--
-- Results:
-- None.
--
-- Side Effects:
-- The new region is overwritten.
--
-- Notes:
-- The idea behind this funct is to view the two regions as sets. Together
-- they cover a rectangle of area that this funct divides into horizontal
-- bands where points are covered only by one region or by both. For the
-- first case, the non_Overlap_Func is called with each the band and the
-- band's upper and lower extents. For the second, the Overlap_Func is
-- called to process the entire band. It is responsible for clipping the
-- rectangles in the band, though this function provides the boundaries.
-- At the end of each band, the new region is coalesced, if possible, to
-- reduce the number of rectangles in the region.
--
-------------------------------------------------------------------------
Rects1 : X_Box_List := Reg1.Rects;
Rects2 : X_Box_List := Reg2.Rects;
R1 : S_Natural; -- Pointer into 1st region
R2 : S_Natural; -- Pointer into 2nd region
R1_End : S_Natural; -- End of 1st region
R2_End : S_Natural; -- End of 2nd region
Y_Bot : S_Short; -- Bottom of intersection
Y_Top : S_Short; -- Top of intersection
Old_Rects : X_Box_List; -- Old rects for new_Reg
Prev_Band : S_Natural; -- Index of start of previous band
-- in new_Reg
Cur_Band : S_Natural; -- Index of start of current band
-- in new_Reg
R1_Band_End : S_Natural; -- End of current band in r1
R2_Band_End : S_Natural; -- End of current band in r2
Top : S_Short; -- Top of non-overlapping band
Bot : S_Short; -- Bottom of non-overlapping band
begin
----Initialization:
-- Set r1, r2, r1_End and r2_End appropriately, preserve the important parts
-- of the destination region until the end in case it's one of the two source
-- regions, then mark the "new" region empty, allocating another array of
-- rectangles for it to use.
R1 := 1;
R2 := 1;
R1_End := Reg1.Num_Rects + 1;
R2_End := Reg2.Num_Rects + 1;
Old_Rects := New_Reg.Rects;
Empty_Region (New_Reg);
----Allocate a reasonable number of rectangles for the new region. The idea is
-- to allocate enough so the individual functions don't need to reallocate and
-- copy the array, which is time consuming, yet we don't have to worry about
-- using too much memory. I hope to be able to nuke the X_realloc() at the end
-- of this funct eventually.
New_Reg.Size := Max (Reg1.Num_Rects, Reg2.Num_Rects) * 2;
New_Reg.Rects := new X_Box_Array (0 .. New_Reg.Size - 1);
----Initialize y_bot and y_top. In the upcoming loop, y_bot and y_top serve
-- different functions depending on whether the band being handled is an
-- overlapping or non-overlapping band.
-- In the case of a non-overlapping band (only one of the regions has points
-- in the band), y_bot is the bottom of the most recent intersection and thus
-- clips the top of the rectangles in that band. y_top is the top of the
-- next intersection between the two regions and serves to clip the bottom of
-- the rectangles in the current band.
-- For an overlapping band (where the two regions intersect), y_top clips the
-- top of the rectangles of both regions and y_bot clips the bottoms.
if Reg1.Extents.Y1 < Reg2.Extents.Y1 then
Y_Bot := Reg1.Extents.Y1;
else
Y_Bot := Reg2.Extents.Y1;
end if;
----Prev_Band serves to mark the start of the previous band so rectangles can
-- be coalesced into larger rectangles. qv. mi_Coalesce, above. In the
-- beginning, there is no previous band, so prev_Band = cur_Band (cur_Band is
-- set later on, of course, but the first band will always start at index 1).
-- prev_Band and cur_Band must be indices because of the possible expansion,
-- and resultant moving, of the new region's array of rectangles.
Prev_Band := 1;
loop
Cur_Band := New_Reg.Num_Rects;
----This algorithm proceeds one source-band (as opposed to a destination band,
-- which is determined by where the two regions intersect) at a time.
-- r1_Band_End and r2_Band_End serve to mark the rectangle after the last one
-- in the current band for their respective regions.
R1_Band_End := R1;
while R1_Band_End < R1_End and then
Rects1 (R1_Band_End).Y1 = Rects1 (R1).Y1 loop
R1_Band_End := R1_Band_End + 1;
end loop;
R2_Band_End := R2;
while R2_Band_End < R2_End and then
Rects2 (R2_Band_End).Y1 = Rects2 (R2).Y1 loop
R2_Band_End := R2_Band_End + 1;
end loop;
----First handle the band that doesn't intersect, if any.
-- Note that attention is restricted to one band in the non-intersecting region
-- at once, so if a region has N bands between the current the_position and
-- the next place it overlaps the other, this entire loop will be passed
-- through N times.
if Rects1 (R1).Y1 < Rects2 (R2).Y1 then
Top := Max (Rects1 (R1).Y1, Y_Bot);
Bot := Min (Rects1 (R1).Y2, Rects2 (R2).Y1);
if Non_Overlap1_Func_Non_Null and then
Top /= Bot then
Non_Overlap1_Func (New_Reg, Rects1, R1, R1_Band_End,
Top, Bot);
end if;
Y_Top := Rects2 (R2).Y1;
elsif Rects2 (R2).Y1 < Rects1 (R1).Y1 then
Top := Max (Rects2 (R2).Y1, Y_Bot);
Bot := Min (Rects2 (R2).Y2, Rects1 (R1).Y1);
if Non_Overlap2_Func_Non_Null and then
Top /= Bot then
Non_Overlap2_Func (New_Reg, Rects2, R2, R2_Band_End,
Top, Bot);
end if;
Y_Top := Rects1 (R1).Y1;
else
Y_Top := Rects1 (R1).Y1;
end if;
----If any rectangles got added to the region, try and coalesce them with
-- rectangles from the previous band. Note we could just do this test in
-- mi_Coalesce, but some machines incur a not inconsiderable cost for
-- function calls, so...
if New_Reg.Num_Rects /= Cur_Band then
Prev_Band := Mi_Coalesce (New_Reg, Prev_Band, Cur_Band + 1);
end if;
----Now see if we've hit an intersecting band. The two bands only intersect
-- if y_bot > y_top.
Y_Bot := Min (Rects1 (R1).Y2, Rects2 (R2).Y2);
Cur_Band := New_Reg.Num_Rects;
if Overlap_Func_Non_Null and then
Y_Bot > Y_Top then
Overlap_Func (New_Reg,
Rects1, R1, R1_Band_End,
Rects2, R2, R2_Band_End,
Y_Top, Y_Bot);
end if;
if New_Reg.Num_Rects /= Cur_Band then
Prev_Band := Mi_Coalesce (New_Reg, Prev_Band, Cur_Band + 1);
end if;
----If we've finished with a band (y2 = y_bot) we skip forward in the region to
-- the next band.
if Rects1 (R1).Y2 = Y_Bot then
R1 := R1_Band_End;
end if;
if Rects2 (R2).Y2 = Y_Bot then
R2 := R2_Band_End;
end if;
if R1 = R1_End or else R2 = R2_End then
exit;
end if;
end loop;
----Deal with whichever region still has rectangles left.
Cur_Band := New_Reg.Num_Rects;
if R1 < R1_End and then Non_Overlap1_Func_Non_Null then
loop
R1_Band_End := R1 + 1;
while R1_Band_End < R1_End and then
Rects1 (R1_Band_End).Y1 = Rects1 (R1).Y1 loop
R1_Band_End := R1_Band_End + 1;
end loop;
Non_Overlap1_Func (New_Reg, Rects1, R1, R1_Band_End,
Max (Rects1 (R1).Y1, Y_Bot), Rects1 (R1).Y2);
R1 := R1_Band_End;
if R1 >= R1_End then
exit;
end if;
end loop;
elsif R2 < R2_End and then Non_Overlap2_Func_Non_Null then
loop
R2_Band_End := R2 + 1;
while R2_Band_End < R2_End and then
Rects2 (R2_Band_End).Y1 = Rects2 (R2).Y1 loop
R2_Band_End := R2_Band_End + 1;
end loop;
Non_Overlap2_Func (New_Reg, Rects2, R2, R2_Band_End,
Max (Rects2 (R2).Y1, Y_Bot), Rects2 (R2).Y2);
R2 := R2_Band_End;
if R2 >= R2_End then
exit;
end if;
end loop;
end if;
if New_Reg.Num_Rects /= Cur_Band then
Prev_Band := Mi_Coalesce (New_Reg, Prev_Band, Cur_Band + 1);
end if;
----A bit of cleanup. To keep regions from growing without bound, we shrink
-- the array of rectangles to match the new number of rectangles in the region.
-- This never goes to 0, however...
--
-- Only do this stuff if the number of rectangles allocated is more than twice
-- the number of rectangles in the region (a simple optimization...).
if New_Reg.Num_Rects < New_Reg.Size / 2 then
if Region_Not_Empty (New_Reg) then
New_Reg.Size := New_Reg.Num_Rects;
declare
Newa : X_Box_List := new X_Box_Array (1 .. New_Reg.Size);
begin
Newa.all := New_Reg.Rects (Newa'Range);
Free_X_Box_List (New_Reg.Rects);
New_Reg.Rects := Newa;
end;
----No point in doing the extra work involved in a copy if the region is empty.
else
New_Reg.Size := 1;
Free_X_Box_List (New_Reg.Rects);
New_Reg.Rects := new X_Box_Array (1 .. 1);
end if;
end if;
Free_X_Box_List (Old_Rects);
exception
when others =>
if New_Reg.Rects = Old_Rects then
Old_Rects := null;
end if;
Free_X_Box_List (New_Reg.Rects);
Free_X_Box_List (Old_Rects);
raise;
end Mi_Region_Op;
--\f
-- procedure Null_Overlap_Func (New_Reg : X_Region;
-- Reg1 : X_Box_List;
-- Reg1_Begin : S_Natural;
-- Reg1_End : S_Natural;
-- Reg2 : X_Box_List;
-- Reg2_Begin : S_Natural;
-- Reg2_End : S_Natural;
-- Y_Top : S_Short;
-- Y_Bot : S_Short) is
-- -- called for overlapping bands
-- begin
-- null;
-- end Null_Overlap_Func;
--
procedure Null_Non_Overlap1_Func (New_Reg : X_Region;
Reg1 : X_Box_List;
Reg1_Begin : S_Natural;
Reg1_End : S_Natural;
Top : S_Short;
Bot : S_Short) is
-- called for non-overlapping bands in region 1
begin
null;
end Null_Non_Overlap1_Func;
procedure Null_Non_Overlap2_Func (New_Reg : X_Region;
Reg2 : X_Box_List;
Reg2_Begin : S_Natural;
Reg2_End : S_Natural;
Top : S_Short;
Bot : S_Short) is
-- called for non-overlapping bands in region 2
begin
null;
end Null_Non_Overlap2_Func;
--\f
--======================================================================
-- Region Intersection
--====================================================================
procedure Mi_Intersect_O (P_Reg : X_Region;
Rects1 : X_Box_List;
R1 : S_Natural;
R1_End : S_Natural;
Rects2 : X_Box_List;
R2 : S_Natural;
R2_End : S_Natural;
Y1 : S_Short;
Y2 : S_Short) is
-------------------------------------------------------------------------
-- mi_Intersect_O --
-- Handle an overlapping band for mi_Intersect.
--
-- Results:
-- None.
--
-- Side Effects:
-- Rectangles may be added to the region.
--
-------------------------------------------------------------------------
X1 : S_Short;
X2 : S_Short;
R1_I : S_Natural := 1;
R2_I : S_Natural := 1;
I : S_Natural := P_Reg.Num_Rects;
begin
while R1_I < R1_End and then R2_I < R2_End loop
X1 := Max (Rects1 (R1_I).X1, Rects2 (R2_I).X1);
X2 := Min (Rects1 (R1_I).X2, Rects2 (R2_I).X2);
----If there's any overlap between the two rectangles, add that overlap to the
-- new region. There's no need to check for subsumption because the only way
-- such a need could arise is if some region has two rectangles right next to
-- each other. Since that should never happen...
if X1 < X2 then
--/ if DEBUG then
if not (Y1 < Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := X2;
P_Reg.Rects (I).Y2 := Y2;
end if;
----Need to advance the pointers. Shift the one that extends to the right the
-- least, since the other still has a chance to overlap with that region's
-- next rectangle, if you see what I mean.
if Rects1 (R1_I).X2 < Rects2 (R2_I).X2 then
R1_I := R1_I + 1;
elsif Rects2 (R2_I).X2 < Rects1 (R1_I).X2 then
R2_I := R2_I + 1;
else
R1_I := R1_I + 1;
R2_I := R2_I + 1;
end if;
end loop;
end Mi_Intersect_O;
--\f
procedure Mi_Region_Op_Intersect is
new Mi_Region_Op
(True, False, False,
Mi_Intersect_O, Null_Non_Overlap1_Func, Null_Non_Overlap2_Func);
--\f
procedure X_Intersect_Region
(Region1 : X_Region;
Region2 : X_Region; -- source regions
New_Region : X_Region) is -- destination Region
begin
----Check for trivial reject
if Region1.Num_Rects = 0 or else Region2.Num_Rects = 0 or else
not Extent_Check (Region1.Extents, Region2.Extents) then
New_Region.Num_Rects := 0;
else
Mi_Region_Op_Intersect (New_Region, Region1, Region2);
end if;
----Can't alter New_Region's extents before we call mi_Region_Op because it might
-- be one of the source regions and mi_Region_Op depends on the extents of
-- those regions being the same. Besides, this way there's no checking against
-- rectangles that will be nuked due to coalescing, so we have to examine
-- fewer rectangles.
Mi_Set_Extents (New_Region);
end X_Intersect_Region;
--\f
procedure Mi_Region_Copy (Dst_Rgn : X_Region;
Rgn : X_Region) is
begin
if Dst_Rgn /= Rgn -- don't want to copy to itself
then
if Dst_Rgn.Size < Rgn.Num_Rects then
if Dst_Rgn.Rects /= null then
Free_X_Box_List (Dst_Rgn.Rects);
end if;
Dst_Rgn.Rects := new X_Box_Array (1 .. Rgn.Num_Rects);
Dst_Rgn.Size := Rgn.Num_Rects;
end if;
Dst_Rgn.Num_Rects := Rgn.Num_Rects;
Dst_Rgn.Extents := Rgn.Extents;
Dst_Rgn.Rects (1 .. Rgn.Num_Rects) :=
Rgn.Rects (1 .. Rgn.Num_Rects);
end if;
end Mi_Region_Copy;
--\f
-- procedure Combine_Regs
-- (New_Reg : X_Region_internal;
-- Reg1 : X_Region_internal;
-- Reg2 : X_Region_internal) is
-- ------------------------------------------------------------------------------
-- -- if one region is above or below the other.
-- ------------------------------------------------------------------------------
-- Temp_Reg : X_Region_internal;
-- Rects : s_natural;
-- Rects1 : s_natural;
-- Rects2 : s_natural;
-- Total : s_natural;
-- begin
--
-- Rects1 := 1;
-- Rects2 := 1;
--
-- Total := Reg1.Num_Rects + Reg2.Num_Rects;
-- Temp_Reg := X_Create_Region;
-- Temp_Reg.Size := Total;
--
-- ----Region 1 is below region 2
--
-- if Reg1.Extents.Y1 > Reg2.Extents.Y1 then
-- Mi_Region_Copy (Temp_Reg, Reg2);
-- Rects := Temp_Reg.Num_Rects + 1;
-- for I in 0 .. Total - Temp_Reg.Num_Rects - 1 loop
-- Temp_Reg.Rects (Rects + I) := Reg1.Rects (Rects1 + I);
-- end loop;
-- else
-- Mi_Region_Copy (Temp_Reg, Reg1);
-- Rects := Temp_Reg.Num_Rects + 1;
-- for I in 0 .. Total - Temp_Reg.Num_Rects - 1 loop
-- Temp_Reg.Rects (Rects + 1) := Reg2.Rects (Rects2 + 1);
-- end loop;
-- end if;
--
-- Temp_Reg.Extents := Reg1.Extents;
-- Temp_Reg.Num_Rects := Total;
-- Extents (Reg2.Extents, Temp_Reg);
-- Mi_Region_Copy (New_Reg, Temp_Reg);
-- Free_X_Region_internal (Temp_Reg);
--
-- end Combine_Regs;
-- #ifdef notdef
-- --
-- -- Quick_Check checks to see if it does not have to go through all the
-- -- the ugly code for the region call. It returns 1 if it did all
-- -- the work for Union, otherwise 0 - still work to be done.
-- --
--
-- static int
-- Quick_Check(new_Reg, reg1, reg2)
-- Region new_Reg, reg1, reg2;
-- {
--
-- -- if unioning with itself or no rects to union with
-- if ( (reg1 = reg2) or else (!(reg1.num_Rects)) )
-- {
-- mi_Region_Copy(new_Reg, reg2);
-- return(TRUE);
-- }
--
-- -- if nothing to union
-- if (!(reg2.num_Rects))
-- {
-- mi_Region_Copy(new_Reg, reg1);
-- return(TRUE);
-- }
--
-- -- could put an extent check to see if add above or below
--
-- if ((reg1.extents.y1 >= reg2.extents.y2) or else
-- (reg2.extents.y1 >= reg1.extents.y2) )
-- {
-- combine_Regs(new_Reg, reg1, reg2);
-- return(TRUE);
-- }
-- return(FALSE);
-- }
-- #endif
--
-- #ifdef notdef
-- -- Top_Rects(rects, reg1, reg2)
-- -- N.B. We now assume that reg1 and reg2 intersect. Therefore we are
-- -- NOT checking in the two while loops for stepping off the end of the
-- -- region.
-- --
--
-- static int
-- Top_Rects(new_Reg, rects, reg1, reg2, First_Rect)
-- Region new_Reg;
-- box_ptr rects;
-- Region reg1;
-- Region reg2;
-- box_ptr First_Rect;
-- {
-- box_ptr temp_Rects;
--
-- -- need to add some rects from region 1
-- if (reg1.extents.y1 < reg2.extents.y1)
-- {
-- temp_Rects := reg1.rects;
-- while(temp_Rects.y1 < reg2.extents.y1)
-- {
-- MEM_CHECK(new_Reg, rects, First_Rect);
-- ADD_RECT_NOX(new_Reg,rects, temp_Rects.x1, temp_Rects.y1,
-- temp_Rects.x2, MIN(temp_Rects.y2, reg2.extents.y1));
-- temp_Rects++;
-- }
-- }
-- -- need to add some rects from region 2
-- if (reg2.extents.y1 < reg1.extents.y1)
-- {
-- temp_Rects := reg2.rects;
-- while (temp_Rects.y1 < reg1.extents.y1)
-- {
-- MEM_CHECK(new_Reg, rects, First_Rect);
-- ADD_RECT_NOX(new_Reg, rects, temp_Rects.x1,temp_Rects.y1,
-- temp_Rects.x2, MIN(temp_Rects.y2, reg1.extents.y1));
-- temp_Rects++;
-- }
-- }
-- return(1);
-- }
-- #endif
--\f
--======================================================================
-- Region Union
--====================================================================
procedure Mi_Union_Non_O (P_Reg : X_Region;
Rects : X_Box_List;
R : S_Natural;
R_End : S_Natural;
Y1 : S_Short;
Y2 : S_Short) is
-------------------------------------------------------------------------
-- mi_Union_Non_O --
-- Handle a non-overlapping band for the union operation. Just
-- Adds the rectangles into the region. Doesn't have to check for
-- subsumption or anything.
--
-- Results:
-- None.
--
-- Side Effects:
-- p_Reg.num_Rects is incremented and the final rectangles overwritten
-- with the rectangles we're passed.
--
-------------------------------------------------------------------------
I : S_Natural;
begin
--/ if DEBUG then
if not (Y1 < Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
for Ri in R .. R_End - 1 loop
--/ if DEBUG then
if not (Rects (Ri).X1 < Rects (Ri).X2) then
raise X_Library_Confusion;
end if;
--/ end if;
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := Rects (Ri).X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := Rects (Ri).X2;
P_Reg.Rects (I).Y2 := Y2;
end loop;
end Mi_Union_Non_O;
--\f
procedure Mi_Union_O (P_Reg : X_Region;
Rects1 : X_Box_List;
R1 : S_Natural;
R1_End : S_Natural;
Rects2 : X_Box_List;
R2 : S_Natural;
R2_End : S_Natural;
Y1 : S_Short;
Y2 : S_Short) is
-------------------------------------------------------------------------
-- mi_Union_O --
-- Handle an overlapping band for the union operation. Picks the
-- left-most rectangle each time and merges it into the region.
--
-- Results:
-- None.
--
-- Side Effects:
-- Rectangles are overwritten in p_Reg.rects and p_Reg.num_Rects will
-- be changed.
--
-------------------------------------------------------------------------
I : S_Natural;
R1_I : S_Natural := R1;
R2_I : S_Natural := R2;
procedure Merge_Rect (R : X_Box_List; Ri : in out S_Natural) is
begin
if I /= 0 and then P_Reg.Rects (I - 1).Y1 = Y1 and then
P_Reg.Rects (I - 1).Y2 = Y2 and then
P_Reg.Rects (I - 1).X2 >= R (Ri).X1 then
if P_Reg.Rects (I - 1).X2 < R (Ri).X2 then
P_Reg.Rects (I - 1).X2 := R (R1).X2;
--/ if DEBUG then
if not (P_Reg.Rects (I - 1).X1 <
P_Reg.Rects (I - 1).X2) then
raise X_Library_Confusion;
end if;
--/ end if;
end if;
else
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).Y2 := Y2;
P_Reg.Rects (I).X1 := R (Ri).X1;
P_Reg.Rects (I).X2 := R (Ri).X2;
end if;
Ri := Ri + 1;
end Merge_Rect;
begin
I := P_Reg.Num_Rects;
--/ if DEBUG then
if not (Y1 < Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
while R1_I < R1_End and then R2_I < R2_End loop
if Rects1 (R1_I).X1 < Rects2 (R2_I).X1 then
Merge_Rect (Rects1, R1_I);
else
Merge_Rect (Rects2, R2_I);
end if;
end loop;
if R1_I < R1_End then
loop
Merge_Rect (Rects1, R1_I);
if R1 = R1_End then
exit;
end if;
end loop;
else
while R2 < R2_End loop
Merge_Rect (Rects2, R2_I);
end loop;
end if;
end Mi_Union_O;
--\f
procedure Mi_Region_Op_Union is
new Mi_Region_Op
(True, True, True,
Mi_Union_O, Mi_Union_Non_O, Mi_Union_Non_O);
--\f
procedure X_Union_Region (Region1 : X_Region;
Region2 : X_Region; -- source regions
New_Region : X_Region) is -- destination regions
begin
----Checks all the simple cases
----Region 1 and 2 are the same or region 1 is empty
if Region1 = Region2 or else Region1.Num_Rects = 0 then
if New_Region /= Region2 then
Mi_Region_Copy (New_Region, Region2);
end if;
return;
end if;
----If nothing to union (region 2 empty)
if Region2.Num_Rects = 0 then
if New_Region /= Region1 then
Mi_Region_Copy (New_Region, Region1);
end if;
return;
end if;
----Region 1 completely subsumes region 2
if Region1.Num_Rects = 1 and then
Region1.Extents.X1 <= Region2.Extents.X1 and then
Region1.Extents.Y1 <= Region2.Extents.Y1 and then
Region1.Extents.X2 >= Region2.Extents.X2 and then
Region1.Extents.Y2 >= Region2.Extents.Y2 then
if New_Region /= Region1 then
Mi_Region_Copy (New_Region, Region1);
end if;
return;
end if;
----Region 2 completely subsumes region 1
if Region2.Num_Rects = 1 and then
Region2.Extents.X1 <= Region1.Extents.X1 and then
Region2.Extents.Y1 <= Region1.Extents.Y1 and then
Region2.Extents.X2 >= Region1.Extents.X2 and then
Region2.Extents.Y2 >= Region1.Extents.Y2 then
if New_Region /= Region2 then
Mi_Region_Copy (New_Region, Region2);
end if;
return;
end if;
Mi_Region_Op_Union (New_Region, Region1, Region2);
New_Region.Extents.X1 := Min (Region1.Extents.X1, Region2.Extents.X1);
New_Region.Extents.Y1 := Min (Region1.Extents.Y1, Region2.Extents.Y1);
New_Region.Extents.X2 := Max (Region1.Extents.X2, Region2.Extents.X2);
New_Region.Extents.Y2 := Max (Region1.Extents.Y2, Region2.Extents.Y2);
end X_Union_Region;
--\f
--======================================================================
-- Region Subtraction
--====================================================================
procedure Mi_Subtract_Non_O1 (P_Reg : X_Region;
Rects : X_Box_List;
R : S_Natural;
R_End : S_Natural;
Y1 : S_Short;
Y2 : S_Short) is
-------------------------------------------------------------------------
-- mi_Subtract_Non_O --
-- Deal with non-overlapping band for subtraction. Any parts from
-- region 2 we discard. Anything from region 1 we add to the region.
--
-- Results:
-- None.
--
-- Side Effects:
-- p_Reg may be affected.
--
-------------------------------------------------------------------------
I : S_Natural;
begin
--/ if DEBUG then
if not (Y1 < Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
for Ri in R .. R_End - 1 loop
--/ if DEBUG then
if not (Rects (Ri).X1 < Rects (Ri).X2) then
raise X_Library_Confusion;
end if;
--/ end if;
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := Rects (Ri).X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := Rects (Ri).X2;
P_Reg.Rects (I).Y2 := Y2;
end loop;
end Mi_Subtract_Non_O1;
--\f
procedure Mi_Subtract_O (P_Reg : X_Region;
Rects1 : X_Box_List;
R1 : S_Natural;
R1_End : S_Natural;
Rects2 : X_Box_List;
R2 : S_Natural;
R2_End : S_Natural;
Y1 : S_Short;
Y2 : S_Short) is
-------------------------------------------------------------------------
-- mi_Subtract_O --
-- Overlapping band subtraction. x1 is the left-most point not yet
-- checked.
--
-- Results:
-- None.
--
-- Side Effects:
-- p_Reg may have rectangles added to it.
--
-------------------------------------------------------------------------
X1 : S_Short;
R1_I : S_Natural := R1;
R2_I : S_Natural := R2;
I : S_Natural;
begin
X1 := Rects1 (R1_I).X1;
--/ if DEBUG then
if not (Y1 < Y2) then
raise X_Library_Confusion;
end if;
--/ end if;
while R1_I < R1_End and then R2_I < R2_End loop
----If subtrahend missed the boat: go to next subtrahend.
if Rects2 (R2_I).X2 <= X1 then
R2_I := R2_I + 1;
----If subtrahend preceeds minuend: nuke left edge of minuend.
elsif Rects2 (R2_I).X1 <= X1 then
X1 := Rects2 (R2_I).X2;
----If minuend completely covered: advance to next minuend and reset left fence
-- to edge of new minuend.
if X1 >= Rects1 (R1_I).X2 then
R1_I := R1_I + 1;
X1 := Rects1 (R1_I).X1;
----Else subtrahend now used up since it doesn't extend beyond minuend
else
R2_I := R2_I + 1;
end if;
----Left part of subtrahend covers part of minuend: add uncovered part of
-- minuend to region and skip to next subtrahend.
elsif Rects2 (R2_I).X1 < Rects1 (R1_I).X2 then
--/ if DEBUG then
if not (X1 < Rects2 (R2_I).X1) then
raise X_Library_Confusion;
end if;
--/ end if;
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := Rects2 (R2_I).X1;
P_Reg.Rects (I).Y2 := Y2;
X1 := Rects2 (R2_I).X2;
---If minuend used up: advance to new...
if X1 >= Rects1 (R2_I).X2 then
R1_I := R1_I + 1;
X1 := Rects1 (R1_I).X1;
----Else subtrahend used up
else
R2_I := R2_I + 1;
end if;
----Minuend used up: add any remaining piece before advancing.
else
if Rects1 (R1_I).X2 > X1 then
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := Rects1 (R1_I).X2;
P_Reg.Rects (I).Y2 := Y2;
end if;
R1_I := R1_I + 1;
X1 := Rects1 (R1_I).X1;
end if;
end loop;
----Add remaining minuend rectangles to region.
while R1_I < R1_End loop
--/ if DEBUG then
if not (X1 < Rects1 (R1_I).X2) then
raise X_Library_Confusion;
end if;
--/ end if;
P_Reg.Num_Rects := P_Reg.Num_Rects + 1;
I := P_Reg.Num_Rects;
P_Reg.Rects (I).X1 := X1;
P_Reg.Rects (I).Y1 := Y1;
P_Reg.Rects (I).X2 := Rects1 (R1_I).X2;
P_Reg.Rects (I).Y2 := Y2;
--/ if DEBUG then
if not (P_Reg.Num_Rects <= P_Reg.Size) then
raise X_Library_Confusion;
end if;
--/ end if;
R1_I := R1_I + 1;
if R1_I < R1_End then
X1 := Rects1 (R1_I).X1;
end if;
end loop;
end Mi_Subtract_O;
--\f
procedure Mi_Region_Op_Subtract is
new Mi_Region_Op
(True, True, False,
Mi_Subtract_O, Mi_Subtract_Non_O1, Null_Non_Overlap2_Func);
--\f
procedure X_Subtract_Region (Region1 : X_Region;
Region2 : X_Region;
New_Region : X_Region) is
-------------------------------------------------------------------------
-- mi_Subtract --
-- Subtract Region2 from Region1 and leave the result in New_Region.
-- S stands for subtrahend, M for minuend and D for difference.
--
-- Results:
-- TRUE.
--
-- Side Effects:
-- New_Region is overwritten.
--
-------------------------------------------------------------------------
begin
----Check for trivial reject.
if Region1.Num_Rects = 0 or else
Region2.Num_Rects = 0 or else
not Extent_Check (Region1.Extents, Region2.Extents) then
Mi_Region_Copy (New_Region, Region1);
return;
end if;
Mi_Region_Op_Subtract (New_Region, Region1, Region2);
----Can't alter New_Region's extents before we call mi_Region_Op because it might
-- be one of the source regions and mi_Region_Op depends on the extents of
-- those regions being unaltered. Besides, this way there's no checking
-- against rectangles that will be nuked due to coalescing, so we have to
-- examine fewer rectangles.
Mi_Set_Extents (New_Region);
end X_Subtract_Region;
--\f
procedure X_Xor_Region (Region1 : X_Region;
Region2 : X_Region;
New_Region : X_Region) is
Tra : X_Region;
Trb : X_Region;
begin
Tra := new X_Region_Rec;
Trb := new X_Region_Rec;
X_Subtract_Region (Region1, Region2, Tra);
X_Subtract_Region (Region2, Region1, Trb);
X_Union_Region (Tra, Trb, New_Region);
Free_X_Region (Tra);
Free_X_Region (Trb);
exception
when others =>
Free_X_Region (Tra);
Free_X_Region (Trb);
raise;
end X_Xor_Region;
--\f
function X_Empty_Region (Region : X_Region) return Boolean is
------------------------------------------------------------------------------
-- Check to see if the region is empty. Assumes a region is passed
-- as a parameter
------------------------------------------------------------------------------
begin
return Region.Num_Rects = 0;
end X_Empty_Region;
--\f
function X_Equal_Region (Region1 : X_Region;
Region2 : X_Region) return Boolean is
------------------------------------------------------------------------------
-- Check to see if two regions are equal
------------------------------------------------------------------------------
begin
if Region1.Num_Rects /= Region2.Num_Rects then
return False;
elsif Region1.Num_Rects = 0 then
return True;
elsif Region1.Extents /= Region2.Extents then
return False;
end if;
for I in 1 .. Region1.Num_Rects loop
if Region1.Rects (I) /= Region2.Rects (I) then
return False;
end if;
end loop;
return True;
end X_Equal_Region;
--\f
function X_Point_In_Region (Region : X_Region;
X : S_Short;
Y : S_Short) return Boolean is
begin
if Region.Num_Rects = 0 then
return False;
end if;
if not In_Box (Region.Extents, X, Y) then
return False;
end if;
for I in 1 .. Region.Num_Rects loop
if In_Box (Region.Rects (I), X, Y) then
return True;
end if;
end loop;
return False;
end X_Point_In_Region;
--\f
function X_Rect_In_Region
(Region : X_Region;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short) return X_Rect_In_Region_Returns is
Prect : X_Box_Rec;
Part_In : Boolean;
Part_Out : Boolean;
Lx : S_Short := X;
Ly : S_Short := Y;
begin
Prect.X1 := Lx;
Prect.Y1 := Ly;
Prect.X2 := S_Short (Width) + Lx;
Prect.Y2 := S_Short (Height) + Ly;
----This is (just) a useful optimization.
if Region.Num_Rects = 0 or else
not Extent_Check (Region.Extents, Prect) then
return Rectangle_Out;
end if;
Part_Out := False;
Part_In := False;
----Can stop when both part_Out and part_In are TRUE, or we reach prect.y2.
for Pbox in 1 .. Region.Num_Rects loop
declare
Box : X_Box_Rec renames Region.Rects (Pbox);
begin
if Box.Y2 <= Ly then
-- getting up to speed or skipping remainder of band
goto Continue_Loop;
end if;
if Box.Y1 > Ly then
Part_Out := True; -- missed part of rectangle above
if Part_In or else Box.Y1 >= Prect.Y2 then
exit;
end if;
Ly := Box.Y1; -- x guaranteed to be = prect.x1
end if;
if Box.X2 <= Lx then
goto Continue_Loop; -- not far enough over yet
end if;
if Box.X1 > Lx then
Part_Out := True; -- missed part of rectangle to left
if Part_In then
exit;
end if;
end if;
if Box.X1 < Prect.X2 then
Part_In := True; -- definitely overlap
if Part_Out then
exit;
end if;
end if;
if Box.X2 >= Prect.X2 then
Ly := Box.Y2; -- finished with this band
if Ly >= Prect.Y2 then
exit;
end if;
Lx := Prect.X1; -- reset x out to left again
else
----Because boxes in a band are maximal width, if the first box to overlap the
-- rectangle doesn't completely cover it in that band, the rectangle must be
-- partially out, since some of it will be uncovered in that band. part_In
-- will have been set true by now...
exit;
end if;
end;
<<Continue_Loop>> null;
end loop;
if Part_In then
if Ly < Prect.Y2 then
return Rectangle_Part;
else
return Rectangle_In;
end if;
else
return Rectangle_Out;
end if;
end X_Rect_In_Region;
end Xlbp_Region;