Crawly Crypt Collection 2/crawlyvol2.bin/program/pascal/pdial/source/tools.pas

Pascal/Delphi Source File | 1993-07-09 | 4.8 KB | 231 lines

unit tools;

interface

uses gem;

type
    GRECT            =    record
                            g_x, g_y, g_w, g_h    :    integer;
                        end;
type
    CALLProc    =    procedure(dial: AESTreePtr; obj: integer);
    MAPProc    =    function(tree: AESTreePtr; obj: integer): boolean;

function min(a, b: integer): integer;
function max(a, b: integer): integer;

function hiword(l: longint): word;
function loword(l: longint): word;

function  get_cookie(cookie: longint): pointer;

procedure set_state  (var obj: AESObject; state: integer);
procedure unset_state(var obj: AESObject; state: integer);
function  is_state   (var obj: AESObject; state: integer): boolean;

procedure set_flag  (var obj: AESObject; flag: integer);
procedure unset_flag(var obj: AESObject; flag: integer);
function  is_flag   (var obj: AESObject; flag: integer): boolean;

procedure deselect(var obj: AESObject);
procedure draw_object(tree: AESTreePtr; obj: integer);
function  is_enabled(var obj: AESObject): boolean;

procedure maptree(tree: AESTreePtr; this, last: integer;
                        routine: MAPProc);

function isspace(c: char): boolean;


(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)

implementation

uses tos;

function min(a, b: integer): integer;
begin
   if a < b then
       min := a
   else
      min := b;
end;

function max(a, b: integer): integer;
begin
   if a > b then
       max := a
   else
      max := b;
end;

function hiword(l: longint): word;
begin
    hiword := (l shr 16) and $ffff;
end;

function loword(l: longint): word;
begin
    loword := l and $ffff;
end;

function get_cookie(cookie: longint): pointer;
type
    COOKJAR    =    record
                        id        :    longint;
                        ptr    :    ^longint;
                    end;
    COOKTAB    =    array [0..255] of COOKJAR;
    CTABPtr    =    ^COOKTAB;
var
    oldstack        :    longint;
    cookiejar    :    COOKTAB;
    p_cookies    :    CTABPtr absolute $5a0;
    lpcookies    :    longint absolute $5a0;
    lpcval        :    longint;
    i                :    integer;
begin
    oldstack  := Super(pointer(0));
    cookiejar := p_cookies^;
    lpcval     := lpcookies;
    Super(pointer(oldstack));

    if lpcval = 0 then
    begin
        get_cookie := NIL;
        exit;
    end;

    i := 0;
    while cookiejar[i].id <> 0 do
    begin
        if cookiejar[i].id = cookie then
        begin
            get_cookie := cookiejar[i].ptr;
            exit;
        end
        else
            inc(i);
    end;
    get_cookie := NIL;
end;

procedure set_state(var obj: AESObject; state: integer);
begin
    with obj do
        ob_state := ob_state or state;
end;

procedure unset_state(var obj: AESObject; state: integer);
begin
    with obj do
        ob_state := ob_state and not(state);
end;

function  is_state(var obj: AESObject; state: integer): boolean;
begin
    if (obj.ob_state and state) <> 0 then
        is_state := TRUE
    else
        is_state := FALSE;
end;

procedure set_flag(var obj: AESObject; flag: integer);
begin
    with obj do
        ob_flags := ob_flags or flag;
end;

procedure unset_flag(var obj: AESObject; flag: integer);
begin
    with obj do
        ob_flags := ob_flags and not(flag);
end;

function  is_flag  (var obj: AESObject; flag: integer): boolean;
begin
    if (obj.ob_flags and flag) <> 0 then
        is_flag := TRUE
    else
        is_flag := FALSE;
end;

procedure deselect(var obj: AESObject);
begin
    with obj do
        ob_state    := ob_state and (not SELECTED);
end;

procedure draw_object(tree: AESTreePtr; obj: integer);
var
    x, y    :    integer;
begin
    (*
    objc_offset(tree, obj, x, y);
    objc_draw(tree, obj, MAX_DEPTH, x, y, tree^[obj].ob_width,
              tree^[obj].ob_height);
    *)
    with tree^[ROOT] do
        objc_draw(tree, obj, MAX_DEPTH, ob_x, ob_y, ob_width, ob_height);
end;


function is_enabled(var obj: AESObject): boolean;
begin
    is_enabled := TRUE;
    if is_state(obj, DISABLED) = TRUE then
        is_enabled := FALSE;
    if is_flag(obj, SELECTABLE) = FALSE then
        is_enabled := FALSE;
end;

procedure tree_walk(dial: AESTreePtr; start: integer;
                    callrout: CALLProc);
var
    i    :    integer;
begin
    i := dial^[start].ob_head;
    while (i <> start) and (i <> -1) do
    begin
        callrout(dial, i);
        tree_walk(dial, i, callrout);
        i := dial^[i].ob_next;
    end;
end;

(* Non-cursive traverse of an object tree.        *)
(* Adapted from: Tim Oren, Professional GEM      *)
procedure maptree(tree: AESTreePtr; this, last: integer;
                        routine: MAPProc);
var
    tmp1    :    integer;
begin
    tmp1 := this;
    while (this <> last) and (this <> -1) do
        if tree^[this].ob_tail <> tmp1 then
        begin
            tmp1 := this;
            this := -1;
            if routine(tree, tmp1) then
                this := tree^[tmp1].ob_head;
            if this = -1 then
                this := tree^[tmp1].ob_next;
        end
        else
        begin
            tmp1 := this;
            this := tree^[tmp1].ob_next;
        end;
end;

function isspace(c: char): boolean;
begin
    if c in [#9, #13, #32] then
        isspace := TRUE
    else
        isspace := FALSE;
end;


end.