language-Modula2-0.1: examples/Modula-2_Libraries/PMOS/sources/general/tiles.mod
IMPLEMENTATION MODULE Tiles;
(********************************************************)
(* *)
(* Support module for screen graphics *)
(* *)
(* Programmer: P. Moylan *)
(* Last edited: 21 February 1995 *)
(* Status: Working *)
(* The logic for forcing a restart when checking *)
(* for things to merge could be made less *)
(* conservative - is this worth the extra effort? *)
(* Still have to check for missing features. *)
(* Text implemented inefficiently. *)
(* *)
(* Now adding a scrolling mechanism. Procedure *)
(* ScrollContents is basically working but is *)
(* still missing the mechanism to fix up *)
(* scrolled points. *)
(* *)
(********************************************************)
FROM ScreenGeometry IMPORT
(* proc *) Inside;
FROM Graphics IMPORT
(* proc *) Fill, PlotDot, PlotLine, PlotRectangle, ClippedLine,
ClippedString, ClippedUpString, ACopy;
FROM Screen IMPORT
(* proc *) RestoreOriginalMode;
FROM Queues IMPORT
(* type *) Queue,
(* proc *) CreateQueue, AddToQueue, TakeFromQueue, Empty, DestroyQueue;
FROM Storage1 IMPORT
(* proc *) ALLOCATE, DEALLOCATE;
FROM TaskControl IMPORT
(* type *) Lock,
(* proc *) CreateLock, Obtain, Release;
FROM TerminationControl IMPORT
(* proc *) SetTerminationProcedure;
FROM Keyboard IMPORT (* for testing *)
(* proc *) InKey;
(************************************************************************)
CONST testing = FALSE; (* If TRUE, we display TileSlots *)
CONST BigNumber = MAX(CARDINAL) - 1;
TYPE
TextPointer = POINTER TO ARRAY [0..BigNumber] OF CHAR;
(* A PointList is a set of Points. *)
PointList = POINTER TO PointListRecord;
PointListRecord =
RECORD
next: PointList;
datum: Point;
colour: ColourType;
END (*RECORD*);
(* A LineList is a set of Lines defined by their endpoints. *)
LineList = POINTER TO LineListRecord;
LineListRecord =
RECORD
next: LineList;
end1, end2: Point;
colour: ColourType;
END (*RECORD*);
(* A StringList is a set of text strings. *)
StringList = POINTER TO StringListRecord;
StringListRecord =
RECORD
next: StringList;
location: Point;
colour: ColourType;
length: CARDINAL;
textptr: TextPointer;
END (*RECORD*);
(* A TileSlot is defined later - see the TileSlotInfo declaration. *)
TileSlot = POINTER TO TileSlotInfo;
(* A Tile is an object holding graphic data to be displayed on the *)
(* screen. Each Tile matches exactly one TileSlot, but multiple *)
(* Tiles can occupy the same TileSlot. The field "under" shows the *)
(* next Tile which occupies the same TileSlot, "next" shows the *)
(* next Tile in the same TileSet, and "set" is the TileSet itself. *)
Tile = POINTER TO TileRecord;
TileRecord = RECORD
under: Tile;
next: Tile;
set: TileSet;
slot: TileSlot;
points: PointList;
END (*RECORD*);
(* A TileSet - which is the only data type of interest to clients *)
(* of this module - is a set of Tiles, plus a set of lines and text *)
(* strings to be plotted. The background field gives the common *)
(* background colour for all the tiles in the set. The retain *)
(* field specifies whether to save newly plotted data for future *)
(* refreshing. *)
TileSet = POINTER TO TileSetRecord;
TileSetRecord = RECORD
head, tail: Tile;
background: ColourType;
retain: BOOLEAN;
lines: LineList;
strings, upstrings: StringList;
END (*RECORD*);
(* A TileStack is a stack of tiles - each belonging to a distinct *)
(* TileSet - occupying the same position on the screen. *)
TileStack = Tile;
(* A TileSlot represents a rectangular region on the screen, which *)
(* can contain zero or more Tiles. This module maintains a master *)
(* list of TileSlots, showing how the screen is currently tiled. *)
(* Initially there is just one TileSlot covering the whole screen. *)
(* Each time CreateTileSet is called there is a likelihood that *)
(* existing TileSlots will have to be broken up, so the master list *)
(* of TileSlots changes with time. When a TileSlot is broken up, *)
(* the corresponding Tiles must of course also be broken up. *)
(* The nextslot field in a TileSlot record points to the next *)
(* TileSlot in the master list, and the stacktop field points to a *)
(* a stack of tiles which occupy this TileSlot. The mark field is *)
(* normally FALSE; we set it to indicate a candidate for merging *)
(* with adjacent slots. *)
(* So far I haven't given enough thought as to the most desirable *)
(* ordering of the TileSlot list. It should possibly be ordered *)
(* to make searching faster. *)
TileSlotInfo = RECORD
shape: Rectangle;
nextslot: TileSlot;
stacktop: TileStack;
mark: BOOLEAN;
END (*RECORD*);
(************************************************************************)
VAR
(* SlotListHead is the head of the master list of TileSlots. *)
SlotListHead: TileSlot;
(* MainLock protects all entry points to this module. Because of *)
(* the heavily interlocked nature of the data structures maintained *)
(* by this module, and in particular because operations on one *)
(* TileSet can affect the internal structure of other TileSets, *)
(* there is little point in trying for finer granularity in the *)
(* critical section protection. *)
MainLock: Lock;
(************************************************************************)
(*
PROCEDURE DebugPause (message: ARRAY OF CHAR);
(* For testing - can remove from production version. *)
VAR dummy: CHAR;
BEGIN
GlassTTY.SetCursor (24, 0);
GlassTTY.WriteString (message);
dummy := InKey();
END DebugPause;
*)
(************************************************************************)
(* OPERATIONS ON TYPES PointList, LineList, AND StringList *)
(************************************************************************)
PROCEDURE DiscardPointList (VAR (*INOUT*) PL: PointList);
(* Destroys a PointList. *)
VAR following: PointList;
BEGIN
WHILE PL <> NIL DO
following := PL^.next;
DISPOSE (PL);
PL := following;
END (*WHILE*);
END DiscardPointList;
(************************************************************************)
PROCEDURE DiscardLineList (VAR (*INOUT*) LL: LineList);
(* Destroys a LineList. *)
VAR following: LineList;
BEGIN
WHILE LL <> NIL DO
following := LL^.next;
DISPOSE (LL);
LL := following;
END (*WHILE*);
END DiscardLineList;
(************************************************************************)
PROCEDURE PlotLineListClipped (LL: LineList; R: Rectangle);
(* Plots all lines in LL, clipping them on the display such that *)
(* only the part inside R is shown. *)
BEGIN
WHILE LL <> NIL DO
WITH LL^ DO
WITH R DO
ClippedLine (end1.x, end1.y, end2.x, end2.y, colour,
left, right, bottom, top);
END (*WITH*);
END (*WITH*);
LL := LL^.next;
END (*WHILE*);
END PlotLineListClipped;
(************************************************************************)
PROCEDURE DiscardStringList (VAR (*INOUT*) SL: StringList);
(* Destroys a StringList. *)
VAR following: StringList;
BEGIN
WHILE SL <> NIL DO
following := SL^.next;
DEALLOCATE (SL^.textptr, SL^.length);
DISPOSE (SL);
SL := following;
END (*WHILE*);
END DiscardStringList;
(************************************************************************)
PROCEDURE PlotStringListClipped (SL: StringList; R: Rectangle);
(* Plots all strings in SL, clipping them on the display such that *)
(* only the part inside R is shown. *)
BEGIN
WHILE SL <> NIL DO
WITH SL^ DO
WITH R DO
ClippedString (textptr^, location.x, location.y,
length, colour,
left, right, bottom, top);
END (*WITH*);
END (*WITH*);
SL := SL^.next;
END (*WHILE*);
END PlotStringListClipped;
(************************************************************************)
PROCEDURE PlotUpStringListClipped (USL: StringList; R: Rectangle);
(* Plots all strings in USL, clipping them on the display such *)
(* that only the part inside R is shown. *)
BEGIN
WHILE USL <> NIL DO
WITH USL^ DO
WITH R DO
ClippedUpString (textptr^, location.x, location.y,
length, colour,
left, right, bottom, top);
END (*WITH*);
END (*WITH*);
USL := USL^.next;
END (*WHILE*);
END PlotUpStringListClipped;
(************************************************************************)
(* OPERATIONS ON TYPE Tile *)
(************************************************************************)
PROCEDURE Unlink (tile: Tile);
(* Removes the tile from its stack, without otherwise changing it. *)
VAR slot: TileSlot; current, above: Tile;
BEGIN
slot := tile^.slot;
current := slot^.stacktop; above := NIL;
WHILE current <> tile DO
above := current; current := current^.under;
END (*WHILE*);
IF above = NIL THEN
slot^.stacktop := current^.under;
ELSE
above^.under := current^.under;
END (*IF*);
current^.under := NIL;
END Unlink;
(************************************************************************)
PROCEDURE Display (slot: TileSlot);
(* Displays the contents of the tile on top of the stack for the *)
(* given slot. If the slot is empty, clears the screen area *)
(* described by slot^.shape. *)
(* Remark: should perhaps include a parameter to say whether the *)
(* entire TileSet is being redisplayed - in which case it would be *)
(* more efficient to skip displaying lines and strings in this *)
(* procedure, and let the caller display the unclipped versions. *)
VAR PL: PointList; LL: LineList; toptile: Tile;
background: ColourType; R: Rectangle;
BEGIN
WITH slot^ DO
R := shape;
toptile := stacktop;
IF toptile = NIL THEN background := 0;
ELSE background := toptile^.set^.background;
END (*IF*);
END (*WITH*);
(* Fill in the background *)
WITH R DO
Fill (left, bottom, right, top, background);
END (*WITH*);
(* Is there a tile present? *)
IF toptile = NIL THEN
RETURN;
END (*IF*);
(* Yes, display its contents. *)
PL := toptile^.points;
WHILE PL <> NIL DO
WITH PL^ DO
WITH datum DO
PlotDot (x, y, colour);
END (*WITH*);
END (*WITH*);
PL := PL^.next;
END (*WHILE*);
WITH toptile^.set^ DO
PlotLineListClipped (lines, R);
PlotStringListClipped (strings, R);
PlotUpStringListClipped (upstrings, R);
END (*WITH*);
END Display;
(************************************************************************)
PROCEDURE CreateTile (VAR (*OUT*) T: Tile; Slot: TileSlot);
(* Creates a new tile T on top of the stack for the given slot. *)
(* The tile is not attached to any set. *)
BEGIN
NEW (T);
WITH T^ DO
under := Slot^.stacktop; next := NIL; set := NIL;
slot := Slot; points := NIL;
END (*WITH*);
Slot^.stacktop := T;
END CreateTile;
(************************************************************************)
PROCEDURE DiscardTile (tile: Tile);
(* Destroys a tile. This includes removing the tile from its stack *)
(* and updating the screen display if necessary. *)
VAR wasontop: BOOLEAN;
BEGIN
WITH tile^ DO
wasontop := tile = slot^.stacktop;
Unlink (tile);
IF wasontop THEN Display (slot) END(*IF*);
DiscardPointList (points);
END (*WITH*);
DISPOSE (tile);
END DiscardTile;
(************************************************************************)
PROCEDURE ClearTileData (tile: Tile);
(* Removes all points from the tile, and displays the blanked *)
(* region if the tile is on top of its stack. *)
BEGIN
WITH tile^ DO
DiscardPointList (points);
IF tile = slot^.stacktop THEN
Display (slot);
END (*IF*);
END (*WITH*);
END ClearTileData;
(************************************************************************)
PROCEDURE TileSetMemory (T: TileSet; memory: BOOLEAN);
(* Specifying a FALSE value for the memory parameter means that *)
(* subsequent data sent to this TileSet will be written to the *)
(* screen but not remembered. This saves time and memory, the only *)
(* penalty being that data covered by an overlapping TileSet will *)
(* be lost. Specifying TRUE restores the default condition, where *)
(* all data are retained for refreshing the screen when necessary. *)
BEGIN
T^.retain := memory;
END TileSetMemory;
(************************************************************************)
PROCEDURE PutTileOnTop (tile: Tile);
(* Puts a tile on the top of its stack and displays it. (Does *)
(* nothing if the tile is already on top of its stack.) *)
VAR slot: TileSlot;
BEGIN
slot := tile^.slot;
IF slot^.stacktop <> tile THEN
Unlink (tile);
tile^.under := slot^.stacktop;
slot^.stacktop := tile;
Display (slot);
END (*IF*);
END PutTileOnTop;
(************************************************************************)
PROCEDURE FindTile (TS: TileSet; p: Point): Tile;
(* Returns the tile in TS whose TileSlot contains p. Also puts *)
(* this tile on the top of its stack and displays it. NOTE: we *)
(* assume that the caller has checked that p lies in the region *)
(* covered by TS. *)
VAR current: Tile; x, y: CARDINAL;
BEGIN
x := p.x; y := p.y;
current := TS^.head;
LOOP
IF Inside (x, y, current^.slot^.shape) THEN
PutTileOnTop (current);
RETURN current;
END (*IF*);
current := current^.next;
END (*LOOP*);
END FindTile;
(************************************************************************)
PROCEDURE AddPointToTile (p: Point; colour: ColourType; T: Tile);
(* Appends p to the list of points in T. *)
VAR PL: PointList;
BEGIN
NEW (PL);
WITH PL^ DO
next := T^.points; datum := p;
END (*WITH*);
PL^.colour := colour;
T^.points := PL;
END AddPointToTile;
(************************************************************************)
PROCEDURE SplitTile (VAR (*INOUT*) T: Tile; VAR (*OUT*) T2: Tile;
S2: TileSlot; bound: CARDINAL; Xsplit: BOOLEAN);
(* Creates a new tile T2, to fit into slot S2 and in the same *)
(* TileSet as T; and moves some of the data from T to T2. The data *)
(* moved are those with horizontal coordinate >= bound in the case *)
(* Xsplit = TRUE, or those with vertical coordinate >= bound in the *)
(* case Xsplit = FALSE. T2 is left on the top of the S2 stack. *)
(* Remark: the order of the points in their PointList is altered *)
(* as they are shifted, but this shouldn't matter since the list *)
(* is not being used as an ordered set. *)
VAR pcurrent, pprevious, pfollowing: PointList;
test: CARDINAL;
BEGIN
CreateTile (T2, S2); T2^.set := T^.set;
T2^.next := T^.next; T^.next := T2;
(* Work through the points in T^.points, shifting them to *)
(* T2^.points as necessary. *)
pcurrent := T^.points; pprevious := NIL;
WHILE pcurrent <> NIL DO
pfollowing := pcurrent^.next;
WITH pcurrent^.datum DO
IF Xsplit THEN test := x ELSE test := y END(*IF*);
END (*WITH*);
IF test >= bound THEN
(* Remove the point from T^.points. *)
IF pprevious = NIL THEN T^.points := pfollowing
ELSE pprevious^.next := pfollowing;
END (*IF*);
(* Put the point into T2^.points. *)
pcurrent^.next := T2^.points; T2^.points := pcurrent;
ELSE
pprevious := pcurrent;
END (*IF*);
pcurrent := pfollowing;
END (*WHILE*);
END SplitTile;
(************************************************************************)
PROCEDURE MergeTiles (VAR (*INOUT*) T1, T2: Tile);
(* The opposite operation to SplitTile: all data from T2 are moved *)
(* into T1, and T2 is destroyed. *)
VAR previous, current: Tile; plast: PointList;
BEGIN
(* Find the predecessor of T2 in its TileSet. *)
previous := NIL; current := T2^.set^.head;
WHILE current <> T2 DO
previous := current; current := current^.next;
END (*WHILE*);
(* Remove T2 from the set. *)
IF previous = NIL THEN T2^.set^.head := T2^.next
ELSE previous^.next := T2^.next
END (*IF*);
IF T2 = T2^.set^.tail THEN
T2^.set^.tail := previous;
END (*IF*);
(* Move T2's PointList into T1. *)
plast := T1^.points;
IF plast = NIL THEN
T1^.points := T2^.points;
ELSE
WHILE plast^.next <> NIL DO
plast := plast^.next;
END (*WHILE*);
plast^.next := T2^.points;
END (*IF*);
(* All done, discard T2. *)
DISPOSE (T2);
END MergeTiles;
(************************************************************************)
PROCEDURE MatchingStack (stack1, stack2: TileStack): BOOLEAN;
(* The input parameters each point to the top of a stack of tiles. *)
(* We return TRUE if the two stacks are equal in the following *)
(* sense: for each tile in stack1, there is a corresponding tile in *)
(* stack2 (and vice versa) belonging to the same TileSet. *)
VAR copy: TileStack;
BEGIN
(* Simplification: if the tiles on the two stacks really do *)
(* belong to the same TileSet, then they have gone through the *)
(* same history, and therefore should be stacked in the same *)
(* order. *)
LOOP
IF stack1 = NIL THEN
RETURN (stack2 = NIL);
END (*IF*);
IF stack2 = NIL THEN
RETURN FALSE;
END (*IF*);
IF stack1^.set <> stack2^.set THEN
RETURN FALSE;
END (*IF*);
stack1 := stack1^.under;
stack2 := stack2^.under;
END (*LOOP*);
END MatchingStack;
(************************************************************************)
PROCEDURE MergeStacks (VAR (*OUT*) stack1: TileStack; stack2: TileStack);
(* The input parameters each point to the top of a stack of tiles. *)
(* On exit all data from tiles in stack2 have been moved into the *)
(* corresponding tiles in stack1, and the tiles in stack2 have been *)
(* destroyed. *)
VAR T1, T2: Tile;
BEGIN
T1 := stack1;
WHILE stack2 <> NIL DO
T2 := stack2; stack2 := stack2^.under;
MergeTiles (T1, T2);
T1 := T1^.under;
END (*WHILE*);
END MergeStacks;
(************************************************************************)
(* OPERATIONS ON TYPE TileSlot *)
(************************************************************************)
PROCEDURE DisplayAllSlots (S: TileSlot; colour: ColourType);
(* For testing: draws the boundaries of all TileSlots, pauses a *)
(* while, and then erases the drawing. Because this procedure is *)
(* used only during module testing, we're not particularly fussy *)
(* about leaving the screen picture in a completely clean state. *)
(* The parameters specify the slot we're currently working on - we *)
(* display S in colour "colour". *)
VAR dummy: CHAR;
PROCEDURE DrawSlotOutlines (colour: ColourType);
VAR current: TileSlot;
BEGIN
current := SlotListHead;
WHILE current <> NIL DO
PlotRectangle (current^.shape, colour);
current := current^.nextslot;
END (*WHILE*);
END DrawSlotOutlines;
(********************************************************************)
BEGIN
DrawSlotOutlines (1);
IF S <> NIL THEN
PlotRectangle (S^.shape, colour);
END (*IF*);
Release (MainLock);
dummy := InKey();
Obtain (MainLock);
DrawSlotOutlines (0);
END DisplayAllSlots;
(************************************************************************)
PROCEDURE FindSlot (x, y: CARDINAL): TileSlot;
(* Returns a slot containing the point (x,y). *)
VAR p: TileSlot;
BEGIN
p := SlotListHead;
LOOP
IF Inside (x, y, p^.shape) THEN
RETURN p;
END (*IF*);
p := p^.nextslot;
END (*LOOP*);
END FindSlot;
(************************************************************************)
PROCEDURE SplitSlot (VAR (*INOUT*) S: TileSlot; bound: CARDINAL;
Xsplit: BOOLEAN);
(* Breaks S into two adjacent tile slots - side by side in the case *)
(* Xsplit = TRUE, or one on top of the other when Xsplit = FALSE. *)
(* On return S is the leftmost or bottommost, as appropriate, and *)
(* S^.nextslot is the other. *)
VAR S2: TileSlot; T, T2, bottom: Tile;
BEGIN
NEW (S2);
S2^ := S^;
S^.nextslot := S2;
IF Xsplit THEN
S^.shape.right := bound - 1;
S2^.shape.left := bound;
ELSE
S^.shape.top := bound - 1;
S2^.shape.bottom := bound;
END (*IF*);
S2^.stacktop := NIL;
(* This completes the splitting of the TileSlot itself. Now we *)
(* must also split every Tile in the stack for the original *)
(* TileSlot, and construct a stack for the S2 TileSlot. Note *)
(* that, because a newly created tile goes on top of the stack *)
(* for its slot, we need to shuffle stack elements to avoid a *)
(* situation where the stack constructed for S2 would be upside *)
(* down relative to the stack for S. *)
T := S^.stacktop;
IF T <> NIL THEN
SplitTile (T, bottom, S2, bound, Xsplit);
LOOP
T := T^.under;
IF T = NIL THEN EXIT(*LOOP*) END(*IF*);
SplitTile (T, T2, S2, bound, Xsplit);
(* Move the newly created tile T2 and move it from the *)
(* top to the bottom of S2's stack. This ensures that *)
(* the new stack is built in the same order as the *)
(* original stack. *)
S2^.stacktop := T2^.under; T2^.under := NIL;
bottom^.under := T2; bottom := T2;
END (*LOOP*);
END (*IF*);
IF testing THEN
DisplayAllSlots (S, 4);
END (*IF*);
END SplitSlot;
(************************************************************************)
(* COMBINING ADJACENT SLOTS *)
(************************************************************************)
PROCEDURE Join (VAR (*INOUT*) S1, S2: TileSlot; preS2: TileSlot;
newshape: Rectangle);
(* On entry, S1 and S2 have already been found to be suitable for *)
(* combining, preS2 is the predecessor of S2 in the master list of *)
(* TileSlots, and newshape is the shape of the union of S1 and S2. *)
(* On exit, S1 is the union, the old S2 has been destroyed, and *)
(* S2 is the successor of the old S2 in the master list. *)
VAR following: TileSlot;
BEGIN
(* Remove S2 from the master list of TileSlots. *)
following := S2^.nextslot;
IF preS2 = NIL THEN SlotListHead := following
ELSE preS2^.nextslot := following
END (*IF*);
(* Combine corresponding tiles in S1 and S2, *)
(* leaving the result in S1. *)
S1^.shape := newshape;
MergeStacks (S1^.stacktop, S2^.stacktop);
DISPOSE (S2);
S2 := following;
IF testing THEN
DisplayAllSlots (S1, 3);
END (*IF*);
END Join;
(************************************************************************)
PROCEDURE UpDownMatch (R1, R2: Rectangle;
VAR (*OUT*) union: Rectangle): BOOLEAN;
(* If R1 and R2 are vertically adjacent rectangles, returns TRUE *)
(* and sets "union" to be the combined rectangle. Otherwise *)
(* returns FALSE, and the "union" result is meaningless. *)
BEGIN
union := R1;
IF (R1.left = R2.left) AND (R1.right = R2.right) THEN
(* Possible above/below adjacency *)
IF R2.bottom = R1.top + 1 THEN
union.top := R2.top;
RETURN TRUE;
ELSIF R1.bottom = R2.top + 1 THEN
union.bottom := R2.bottom;
RETURN TRUE;
ELSE
RETURN FALSE;
END (*IF*);
ELSE
RETURN FALSE;
END (*IF*);
END UpDownMatch;
(************************************************************************)
PROCEDURE SideMatch (VAR (*INOUT*) S1, S2, preS2: TileSlot;
VAR (*OUT*) union: Rectangle;
VAR (*OUT*) HaveSplit: BOOLEAN): BOOLEAN;
(* Like UpDownMatch, but checks for left/right adjacency. However *)
(* we're more generous in this case about the meaning of "adjacent" *)
(* since we're prepared to split S1 and/or S2 to make the heights *)
(* match. (This is why the first two parameters have to specify *)
(* TileSlots rather than simply their shapes.) If a split occurs *)
(* the pieces split off have their "mark" fields set - since those *)
(* pieces will have to be re-evaluated for possible further *)
(* combinations - and we return with "HaveSplit" set to TRUE. *)
(* Exception: if we can guarantee that the slots needing to be *)
(* rechecked come after S1 in the master list of slots, then we *)
(* don't set HaveSplit. *)
(* Note: parameter preS2 is the predecessor of S2 in the master *)
(* list of tile slots; it's updated appropriately if we have to *)
(* modify that list. *)
VAR R1, R2: Rectangle; adjacent: BOOLEAN;
BEGIN
HaveSplit := FALSE;
R1 := S1^.shape; R2 := S2^.shape;
union := R1;
IF (R1.bottom > R2.top) OR (R1.top < R2.bottom) THEN
adjacent := FALSE;
ELSIF R2.left = R1.right + 1 THEN
union.right := R2.right;
adjacent := TRUE;
ELSIF R1.left = R2.right + 1 THEN
union.left := R2.left;
adjacent := TRUE;
ELSE
adjacent := FALSE;
END (*IF*);
IF adjacent THEN
(* The two rectangles are adjacent, but we haven't yet *)
(* checked their heights. Perform one or two splits, as *)
(* necessary, to get the heights to line up. *)
IF R1.top > R2.top THEN
S1^.mark := TRUE;
SplitSlot (S1, R2.top+1, FALSE);
union.top := R2.top;
IF preS2 = S1 THEN
preS2 := S1^.nextslot;
END (*IF*);
ELSIF R1.top < R2.top THEN
S2^.mark := TRUE;
SplitSlot (S2, R1.top+1, FALSE);
HaveSplit := TRUE;
END (*IF*);
IF R1.bottom < R2.bottom THEN
S1^.mark := TRUE;
SplitSlot (S1, R2.bottom, FALSE);
HaveSplit := TRUE;
IF preS2 = S1 THEN
preS2 := S1^.nextslot;
END (*IF*);
S1 := S1^.nextslot;
union.bottom := R2.bottom;
ELSIF R1.bottom > R2.bottom THEN
S2^.mark := TRUE;
SplitSlot (S2, R1.bottom, FALSE);
preS2 := S2; S2 := S2^.nextslot;
HaveSplit := TRUE;
END (*IF*);
END (*IF*);
RETURN adjacent;
END SideMatch;
(************************************************************************)
PROCEDURE MergeWithNeighbours (VAR (*INOUT*) S: TileSlot): BOOLEAN;
(* Combines S with its neighbours if this turns out to be possible. *)
(* The condition for combining slots is that the tiles in the two *)
(* slots belong to the same TileSets, and that the union of their *)
(* shapes is again a rectangular region. A function result of *)
(* TRUE indicates that all recombinations (if any) involving S *)
(* have already been taken care of by this procedure, and further *)
(* that no slots preceding S in the master list of TileSlots have *)
(* been modified. A result of FALSE indicates that this procedure *)
(* may have created the conditions for further recombinations, i.e. *)
(* that the caller needs to rescan the master list of TileSlots. *)
VAR NoChange, HaveSplit, NoRescanNeeded: BOOLEAN;
previous, S2: TileSlot; union: Rectangle;
BEGIN
NoRescanNeeded := TRUE;
REPEAT
NoChange := TRUE;
(* Search for a candidate S2 to be merged with S. *)
previous := NIL; S2 := SlotListHead;
WHILE S2 <> NIL DO
(* Check for adjacency. In the above/below case we *)
(* simply merge. In the left/right case we merge when *)
(* an exact match is found, but we also allow for the *)
(* possibility of a left or right neighbour which is *)
(* taller or shorter than S. In the latter case, we *)
(* perform a split followed by a join. *)
IF (S2 <> S) AND MatchingStack (S^.stacktop, S2^.stacktop) AND
(UpDownMatch (S^.shape, S2^.shape, union) OR
SideMatch (S, S2, previous, union, HaveSplit)) THEN
Join (S, S2, previous, union);
NoChange := FALSE;
IF HaveSplit THEN
NoRescanNeeded := FALSE; S2 := NIL;
END (*IF*);
ELSE
previous := S2;
S2 := S2^.nextslot;
END (*IF*);
END (*WHILE S2 <> NIL*);
UNTIL NoChange;
S^.mark := FALSE;
RETURN NoRescanNeeded;
END MergeWithNeighbours;
(************************************************************************)
PROCEDURE RecombineSlots;
(* Goes through the master list of slots, checking all slots which *)
(* have their "mark" field set, and combining adjacent slots where *)
(* possible. Note: in the process of doing this we sometimes have *)
(* to mark previously unmarked slots, so we have to keep looping *)
(* until we are sure we have cleared all marks. *)
VAR slot: TileSlot; scanned: BOOLEAN;
BEGIN
REPEAT
scanned := TRUE;
slot := SlotListHead;
WHILE slot <> NIL DO
IF slot^.mark THEN
scanned := scanned AND MergeWithNeighbours (slot);
END (*IF*);
slot := slot^.nextslot;
END (*WHILE*);
UNTIL scanned;
END RecombineSlots;
(************************************************************************)
(* OPERATIONS ON TYPE TileSet *)
(************************************************************************)
PROCEDURE CreateEmptyTileSet (VAR (*OUT*) TS: TileSet; colour: ColourType);
(* Creates a TileSet containing no tiles. *)
BEGIN
NEW (TS);
WITH TS^ DO
head := NIL; tail := NIL; lines := NIL; strings := NIL;
upstrings := NIL; background := colour; retain := TRUE;
END (*WITH*);
END CreateEmptyTileSet;
(************************************************************************)
PROCEDURE AddToTileSet (VAR (*INOUT*) TS: TileSet; S: TileSlot);
(* Creates a new tile in slot S, adds it to set TS, and displays it.*)
VAR p: Tile;
BEGIN
CreateTile (p, S); p^.set := TS;
Display (S);
WITH TS^ DO
IF tail = NIL THEN head := p
ELSE tail^.next := p
END (*IF*);
tail := p;
END (*WITH*);
END AddToTileSet;
(************************************************************************)
PROCEDURE PutTileSetOnTop (TS: TileSet);
(* Ensures that TS is fully displayed on the screen. *)
VAR tile: Tile;
BEGIN
tile := TS^.head;
WHILE tile <> NIL DO
PutTileOnTop (tile);
tile := tile^.next;
END (*WHILE*);
END PutTileSetOnTop;
(************************************************************************)
PROCEDURE Redraw (TS: TileSet);
(* Refreshes the visible parts of TS on the screen. This procedure *)
(* is for use in the case where the TileSet contents have been *)
(* changed and what is already on the screen is obsolete. (For the *)
(* case where we are simply adding to the existing contents there *)
(* are faster methods than calling this procedure.) *)
VAR tile: Tile;
BEGIN
tile := TS^.head;
WHILE tile <> NIL DO
WITH tile^ DO
IF tile = slot^.stacktop THEN
Display (slot);
END (*IF*);
END (*WITH*);
tile := tile^.next;
END (*WHILE*);
END Redraw;
(************************************************************************)
(* THE MAIN EXTERNALLY CALLABLE PROCEDURES *)
(************************************************************************)
PROCEDURE CreateTileSet (border: Rectangle; background: ColourType): TileSet;
(* Creates a TileSet which covers the given rectangular region. *)
(* The second parameter specifies the background colour. *)
(* This will usually require breaking up tiles of previously *)
(* created TileSets, but since the caller does not have access to *)
(* the internal structure of a TileSet this restructuring is *)
(* transparent to the caller. *)
VAR result: TileSet; S: TileSlot;
StillToHandle: Queue;
RLptr: POINTER TO Rectangle;
BEGIN
Obtain (MainLock);
(* Start by creating an empty tile set, and a list of *)
(* rectangles still to be dealt with. *)
CreateEmptyTileSet (result, background);
CreateQueue (StillToHandle);
NEW (RLptr); RLptr^ := border;
AddToQueue (StillToHandle, RLptr);
(* The following loop breaks the rectangle into tiles by *)
(* gradually breaking up the rectangle. The loop body has two *)
(* phases: (a) find a tile slot which matches or is contained *)
(* in the desired rectangle; (b) break off any parts of the *)
(* rectangle which do not fit into that slot, to be dealt with *)
(* in subsequent passes through the loop. *)
REPEAT
RLptr := TakeFromQueue (StillToHandle);
border := RLptr^; DISPOSE (RLptr);
(* Find a tile slot containing the bottom left corner. *)
S := FindSlot (border.left, border.bottom);
(* Break up S, if necessary, so that no part of S lies *)
(* outside the rectangular region. The order of these *)
(* operations is significant: we work on the bottom and top *)
(* edges before looking at the left and right edges, to *)
(* ensure that horizontal cuts are done before vertical *)
(* cuts. *)
IF S^.shape.bottom < border.bottom THEN
SplitSlot (S, border.bottom, FALSE);
S := S^.nextslot;
END (*IF*);
IF S^.shape.top > border.top THEN
SplitSlot (S, border.top+1, FALSE);
END (*IF*);
IF S^.shape.left < border.left THEN
SplitSlot (S, border.left, TRUE);
S := S^.nextslot;
END (*IF*);
IF S^.shape.right > border.right THEN
SplitSlot (S, border.right+1, TRUE);
END (*IF*);
(* We have now split TileSlots to the point where the lower *)
(* left corner of S is aligned with the lower left corner *)
(* of border, and the whole of S either matches or is *)
(* contained within the desired rectangle; so we have a *)
(* slot we can use in the final result. All that remains *)
(* is to separate out those parts of the rectangle which *)
(* don't fit inside S, and which will be dealt with in *)
(* subsequent passes through the loop. *)
IF border.right > S^.shape.right THEN
NEW (RLptr);
RLptr^ := border; RLptr^.left := S^.shape.right + 1;
border.right := S^.shape.right;
AddToQueue (StillToHandle, RLptr);
END (*IF*);
IF border.top > S^.shape.top THEN
NEW (RLptr);
RLptr^ := border; RLptr^.bottom := S^.shape.top + 1;
border.top := S^.shape.top;
AddToQueue (StillToHandle, RLptr);
END (*IF*);
AddToTileSet (result, S);
UNTIL Empty (StillToHandle);
DestroyQueue (StillToHandle);
Release (MainLock);
RETURN result;
END CreateTileSet;
(************************************************************************)
PROCEDURE DiscardTileSet (VAR (*INOUT*) TS: TileSet);
(* Destroys TileSet TS. *)
VAR current, following: Tile;
BEGIN
Obtain (MainLock);
DiscardLineList (TS^.lines);
DiscardStringList (TS^.strings);
DiscardStringList (TS^.upstrings);
current := TS^.head;
WHILE current <> NIL DO
current^.slot^.mark := TRUE;
following := current^.next;
DiscardTile (current);
current := following;
END (*WHILE*);
DISPOSE (TS);
RecombineSlots;
Release (MainLock);
END DiscardTileSet;
(************************************************************************)
PROCEDURE ClearTileSet (T: TileSet);
(* Removes all points, lines, and text from T, and re-displays *)
(* the visible parts of T. *)
VAR current: Tile;
BEGIN
Obtain (MainLock);
DiscardLineList (T^.lines);
DiscardStringList (T^.strings);
DiscardStringList (T^.upstrings);
current := T^.head;
WHILE current <> NIL DO
ClearTileData (current);
current := current^.next;
END (*WHILE*);
Release (MainLock);
END ClearTileSet;
(************************************************************************)
PROCEDURE AddPoint (T: TileSet; p: Point; colour: ColourType);
(* Adds a new point to TileSet T, and displays it on the screen. *)
VAR tile: Tile;
BEGIN
Obtain (MainLock);
tile := FindTile (T, p);
IF T^.retain THEN
AddPointToTile (p, colour, tile);
END (*IF*);
PlotDot (p.x, p.y, colour);
Release (MainLock);
END AddPoint;
(************************************************************************)
PROCEDURE AddLine (T: TileSet; start, finish: Point; colour: ColourType);
(* Adds a new line to TileSet T, and displays it on the screen. *)
VAR LL: LineList;
BEGIN
Obtain (MainLock);
PutTileSetOnTop (T);
IF T^.retain THEN
NEW (LL);
WITH LL^ DO
next := T^.lines; end1 := start; end2 := finish;
END (*WITH*);
LL^.colour := colour;
T^.lines := LL;
END (*IF*);
PlotLine (start.x, start.y, finish.x, finish.y, colour);
Release (MainLock);
END AddLine;
(************************************************************************)
PROCEDURE AddRectangle (T: TileSet; R: Rectangle; colour: ColourType);
(* Draws a rectangular shape. A shorthand for four AddLine calls. *)
VAR start, end: Point;
BEGIN
WITH R DO
WITH start DO
x := left; y := bottom;
END (*WITH*);
WITH end DO
x := right; y := bottom;
END (*WITH*);
END (*WITH*);
AddLine (T, start, end, colour);
end.x := R.left; end.y := R.top;
AddLine (T, start, end, colour);
start.x := R.right; start.y := R.top;
AddLine (T, start, end, colour);
end.x := R.right; end.y := R.bottom;
AddLine (T, start, end, colour);
END AddRectangle;
(************************************************************************)
PROCEDURE AddString (T: TileSet; place: Point;
VAR (*IN*) text: ARRAY OF CHAR;
count: CARDINAL; colour: ColourType; R: Rectangle);
(* Adds a string of count characters to tileset T, and displays it. *)
(* Points outside rectangle R are not displayed. *)
VAR SL: StringList; j: CARDINAL;
BEGIN
Obtain (MainLock);
PutTileSetOnTop (T);
IF T^.retain THEN
NEW (SL);
WITH SL^ DO
next := T^.strings; location := place;
length := count;
ALLOCATE (textptr, count);
FOR j := 0 TO count-1 DO
textptr^[j] := text[j];
END (*FOR*);
END (*WITH*);
SL^.colour := colour;
T^.strings := SL;
END (*IF*);
WITH R DO
ClippedString (SL^.textptr^, place.x, place.y, count, colour,
left, right, bottom, top);
END (*WITH*);
Release (MainLock);
END AddString;
(************************************************************************)
PROCEDURE AddRotatedString (T: TileSet; place: Point;
VAR (*IN*) text: ARRAY OF CHAR;
count: CARDINAL; colour: ColourType; R: Rectangle);
(* Like AddString, but writes in the +Y direction. *)
VAR USL: StringList; j: CARDINAL;
BEGIN
Obtain (MainLock);
PutTileSetOnTop (T);
IF T^.retain THEN
NEW (USL);
WITH USL^ DO
next := T^.upstrings; location := place;
length := count;
ALLOCATE (textptr, count);
FOR j := 0 TO count-1 DO
textptr^[j] := text[j];
END (*FOR*);
END (*WITH*);
USL^.colour := colour;
T^.upstrings := USL;
END (*IF*);
WITH R DO
ClippedUpString (USL^.textptr^, place.x, place.y, count, colour,
left, right, bottom, top);
END (*WITH*);
Release (MainLock);
END AddRotatedString;
(************************************************************************)
PROCEDURE ShiftTextUp (VAR (*INOUT*) List: StringList;
amount: CARDINAL; limit: INTEGER);
(* Moves all character strings up by "amount" rows, discarding what *)
(* falls above the limit. *)
(* Layout fault: this procedure should be moved higher up in the *)
(* module after I have completed implemented scrolling. *)
VAR previous, current, following: StringList;
felloff: BOOLEAN;
BEGIN
previous := NIL; current := List;
WHILE current <> NIL DO
following := current^.next;
WITH current^.location DO
INC (y, amount);
felloff := y > limit
END (*WITH*);
IF felloff THEN
IF previous = NIL THEN List := following
ELSE previous^.next := following;
END (*IF*);
DEALLOCATE (current^.textptr, current^.length);
DISPOSE (current);
ELSE
previous := current;
END (*IF*);
current := following;
END (*WHILE*);
END ShiftTextUp;
(************************************************************************)
PROCEDURE ShiftLinesUp (List: LineList; amount: CARDINAL; limit: INTEGER);
(* Moves all lines up by "amount" rows, discarding what falls above *)
(* the limit. *)
(* Layout fault: this procedure should be moved higher up in the *)
(* module after I have completed implemented scrolling. *)
VAR previous, current, following: LineList;
felloff: BOOLEAN;
BEGIN
previous := NIL; current := List;
WHILE current <> NIL DO
following := current^.next;
WITH current^.end1 DO
INC (y, amount);
felloff := y > limit;
END (*WITH*);
WITH current^.end2 DO
INC (y, amount);
felloff := felloff AND (y > limit);
END (*WITH*);
IF felloff THEN
IF previous = NIL THEN List := following
ELSE previous^.next := following;
END (*IF*);
DISPOSE (current);
ELSE
previous := current;
END (*IF*);
current := following;
END (*WHILE*);
END ShiftLinesUp;
(************************************************************************)
PROCEDURE ScrollContents (TS: TileSet; amount: INTEGER; R: Rectangle);
(* Moves all data within R up by "amount" rows, discarding what *)
(* falls outside the rectangle. *)
BEGIN
Obtain (MainLock);
PutTileSetOnTop (TS);
WITH R DO
(* Physically move the data on the screen. *)
ACopy (left, top-amount, right-left+1,
top-amount-bottom+1, 0, amount);
(* Clear the vacated section at the bottom. *)
Fill (left, bottom, right, bottom+amount-1,
TS^.background);
END (*WITH*);
(* Modify our records of where everything is. *)
(* The shifting of points is not yet properly implemented. *)
(*
ShiftPointsUp (TS, amount, R.top);
*)
ShiftLinesUp (TS^.lines, amount, R.top);
ShiftTextUp (TS^.strings, amount, R.top);
ShiftTextUp (TS^.upstrings, amount, R.top);
Release (MainLock);
END ScrollContents;
(************************************************************************)
(* CLEANUP ON TERMINATION *)
(************************************************************************)
PROCEDURE Cleanup;
(* Tidies up all the leftover data on program termination, and *)
(* restores the original display mode. *)
VAR current: TileSlot;
BEGIN
Obtain (MainLock);
WHILE SlotListHead <> NIL DO
IF SlotListHead^.stacktop = NIL THEN
current := SlotListHead;
SlotListHead := SlotListHead^.nextslot;
DISPOSE (current);
ELSE
DiscardTileSet (SlotListHead^.stacktop^.set);
END (*IF*);
END (*WHILE*);
RestoreOriginalMode;
Release (MainLock);
END Cleanup;
(************************************************************************)
(* MODULE INITIALISATION *)
(************************************************************************)
PROCEDURE SetUpInitialTileSlot;
(* Creates the master list of TileSlots. Since we don't yet know *)
(* what video mode will be used, we assume a very large screen. *)
(* The fact that the initial tile is certainly too large is not a *)
(* problem, since it will be split as new TileSets are created, *)
(* and the overhead of holding TileSlots for the unusable parts is *)
(* minor. *)
CONST Large = MAX(INTEGER)-1;
BEGIN
Obtain (MainLock);
NEW (SlotListHead);
WITH SlotListHead^ DO
WITH shape DO
left := 0; bottom := 0;
top := Large; right := Large;
END (*WITH*);
nextslot := NIL; stacktop := NIL; mark := FALSE;
END (*WITH*);
Release (MainLock);
END SetUpInitialTileSlot;
(************************************************************************)
BEGIN
CreateLock (MainLock);
SetUpInitialTileSlot;
SetTerminationProcedure (Cleanup);
END Tiles.