OS/2 Shareware BBS: 10 Tools/10-Tools.zip/pmos2002.zip/SRC/TILES.MOD

Text File | 1996-11-08 | 55KB | 1,520 lines

IMPLEMENTATION MODULE Tiles;

        (********************************************************)
        (*                                                      *)
        (*          Support module for screen graphics          *)
        (*                                                      *)
        (*  Programmer:         P. Moylan                       *)
        (*  Last edited:        8 November 1996                 *)
        (*  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
    (* type *)  Point, Rectangle,
    (* proc *)  Inside;

FROM Graphics IMPORT
    (* type *)  ColourType,
    (* proc *)  Fill, PlotDot, PlotLine, PlotRectangle, ClippedLine,
                ClippedString, ClippedUpString, ACopy;

FROM Queues IMPORT
    (* type *)  Queue,
    (* proc *)  CreateQueue, AddToQueue, TakeFromQueue, Empty, DestroyQueue;

FROM Storage IMPORT
    (* proc *)  ALLOCATE, DEALLOCATE;

FROM TaskControl IMPORT
    (* type *)  Lock,
    (* proc *)  CreateLock, Obtain, Release;

FROM Keyboard IMPORT    (* for testing *)
    (* proc *)  InKey;

(************************************************************************)

CONST testing = FALSE;          (* If TRUE, we display TileSlots *)

TYPE
    <* m2extensions+ *>
    TextPointer = POINTER TO ARRAY OF CHAR;
    <* m2extensions- *>

    (* 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;
            <* storage+ *>
            DISPOSE (SL^.textptr);
            <* storage- *>
            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;  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.           *)

    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;
                <* storage+ *>
                NEW (textptr, count);
                <* storage- *>
                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 (text, 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;
                <* storage+ *>
                NEW (textptr, count);
                <* storage- *>
                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 (text, 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*);
                <* storage+ *>
                DISPOSE (current^.textptr);
                <* storage- *>
                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. *)

    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*);
        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;
FINALLY
    Cleanup;
END Tiles.