Vectronix 2/VECTRONIX2.iso/FILES_01/LATTIC_3.LZH/WTEST/WTEST.PAS

Pascal/Delphi Source File | 1988-08-31 | 5KB | 259 lines

{ a WERCS test program for Personal Pascal from OSS }
{      (also known as Atari Pascal Plus in Germany) }

PROGRAM WERCTEST;

    {$I GEMSUBS.PAS }

    {$I WRSC.INC }

CONST
    WF_NEWDESK = 14;
    FMD_FINISH = 3;
    WF_WorkXYWH=4;


TYPE
    Object_Type = RECORD
        ob_next: Short_Integer;
        ob_head: Short_Integer;
        ob_tail: Short_Integer;
        ob_type: Short_Integer;
        ob_flags:Short_Integer;
        ob_state: Short_Integer;
        ob_spec: LONG_INTEGER;
        ob_x: Short_Integer;
        ob_y: Short_Integer;
        ob_width: Short_Integer;
        ob_height: Short_Integer;
        END;

    Object_Ptr = ^Object_Type;

    ObjectArr=ARRAY [0..500] OF Object_Type;
    ObjectArrPtr=^ObjectArr;

VAR    menu:Menu_Ptr;
    junk:integer;
    screenx,screeny,screenw,screenh:integer;
    radio:integer;
    checkflag,deskflag:boolean;
    edittext:Str255;


{ this is a C-type AES call not built-in to the standard library }
PROCEDURE Form_Dial(fo_diflag,fo_dilittlx,fo_dilittly,fo_dilittlw,
    fo_dilittlh,fo_dibigx,fo_dibigy,fo_dibigw,fo_dibigh:Short_Integer);
VAR    int_in: Int_In_Parms;
    int_out: Int_Out_Parms;
    addr_in: Addr_In_Parms;
    addr_out: Addr_Out_Parms;
BEGIN
    int_in[0]:=fo_diflag; int_in[1]:=fo_dilittlx;
    int_in[2]:=fo_dilittly; int_in[3]:=fo_dilittlw;
    int_in[4]:=fo_dilittlh; int_in[5]:=fo_dibigx;
    int_in[6]:=fo_dibigy; int_in[7]:=fo_dibigw;
    int_in[8]:=fo_dibigh;
    AES_Call(51,int_in,int_out,addr_in,addr_out);
END;


PROCEDURE SETDESK(desk:Dialog_Ptr);

    FUNCTION Addr(VAR what:Dialog_Ptr): Long_Integer;
        EXTERNAL;
    FUNCTION WPeek(what:Long_Integer): Short_Integer;
        EXTERNAL;

BEGIN
{$P-}
Wind_Set(0,WF_NEWDESK,Wpeek(Addr(desk)),
    Wpeek(Addr(desk)+2),0,0);
{$P+}
{ now cause the AES to re-draw the whole screen }
Form_Dial(FMD_FINISH,0,0,0,0,screenx,screeny,screenw,screenh);
END;


PROCEDURE Initialise;

BEGIN
IF NOT Load_Resource('WRSC.RSC') THEN
    BEGIN
    junk:=Do_Alert('[3][Resource error][ Quit ]',1);
    Exit_Gem;
    Halt;
    END;
Init_Mouse;
Find_Menu(MENU1,menu);
Draw_Menu(menu);

Wind_Get(0,WF_WorkXYWH,screenx,screeny,screenw,screenh);

edittext:='';
deskflag:=FALSE;
radio:=DRadio1;
END;

PROCEDURE DeInitialise;

BEGIN
IF deskflag THEN SETDESK(NIL);
Free_Resource;
END;

{$P-}
PROCEDURE SetButton(DialogPtr:Dialog_Ptr; parent,button:Short_integer);
VAR Cur:Short_integer;
    fudge: RECORD
        CASE BOOLEAN OF
        TRUE:    ( D1: Dialog_Ptr );
        FALSE:    ( D2: ObjectArrPtr )
        END;
    Dialog:ObjectArrPtr;
BEGIN
    WITH fudge DO
    BEGIN
        D1:=DialogPtr;
        Dialog:=D2;
    END;
    Cur:=Dialog^[parent].ob_head;
    WHILE Cur<>parent DO
        WITH Dialog^[Cur] DO
            BEGIN
            IF Cur=button THEN
                ob_state:=ob_state | SELECTED
                ELSE
                   ob_state:=ob_state & (-SELECTED-1);
            Cur:=ob_next;
            END;
END;

FUNCTION GetButton(DialogPtr:Dialog_Ptr; parent:Short_integer):Short_integer;
VAR Cur:INTEGER;
    fudge: RECORD
        CASE BOOLEAN OF
        TRUE:    ( D1: Dialog_Ptr );
        FALSE:    ( D2: ObjectArrPtr )
        END;
    Dialog:ObjectArrPtr;
BEGIN
    WITH fudge DO
    BEGIN
        D1:=DialogPtr;
        Dialog:=D2;
    END;
    Cur:=Dialog^[parent].ob_head;
    WHILE    (Cur<>parent)  AND ( (Dialog^[Cur].ob_state & SELECTED)=0) DO
            Cur:=Dialog^[Cur].ob_next;
GetButton:=Cur;
END;
{$P+}

PROCEDURE test_dialog;
VAR    result:integer;
    dlog:Dialog_Ptr;
BEGIN
Find_Dialog(TestDialog,dlog);
Center_Dialog(dlog);
Set_DText(dlog,DEditable,edittext,System_Font,TE_Left);
SetButton(dlog,DParent,radio);
result:=Do_Dialog(dlog,DEditable);
IF result=DOK THEN
    BEGIN
    Get_DEdit(dlog,DEditable,edittext);
    radio:=GetButton(dlog,DParent);
    END;
Obj_Setstate(dlog,result,Obj_State(dlog,result)&$FFFE,FALSE);
End_Dialog(dlog);
END;


PROCEDURE Update_Desk;
VAR

{ this type is needed to allow direct ob_ access while keeping
 compatiblity for Dialog routines }

    Desk_Ptr:RECORD CASE BOOLEAN OF
        TRUE:(D: Dialog_Ptr );
        FALSE:(O:Object_Ptr )
        END;

BEGIN
IF deskflag THEN
    BEGIN
    deskflag:=FALSE;
    SETDESK(NIL);
    END
ELSE
    BEGIN
    deskflag:=TRUE;
    Find_Dialog(NewDesktop,Desk_Ptr.D);
    {$P-}
    WITH Desk_Ptr.O^ DO
        BEGIN
        ob_x:=screenx; ob_y:=screeny;
        ob_width:=screenw;
        ob_height:=screenh;
        END;
    SETDESK(Desk_Ptr.D);
    {$P=}
    END;
END;


FUNCTION handle_menu(title:integer;item:integer):boolean;
VAR alertstr:Str255;

BEGIN
handle_menu:=FALSE;
CASE item OF
    MAbout:    BEGIN
        Find_Alert(AAlert,alertstr);
        junk:=Do_Alert(alertstr,1);
        END;
    MQuit:    handle_menu:=TRUE;
    MCheckme:BEGIN
        checkflag:=NOT checkflag;
        Menu_Check(menu,MCheckme,checkflag);
        END;
    MDialog:test_dialog;
    MInstall:update_desk;
END;
Menu_Normal(menu,title);
END;

PROCEDURE Main;
VAR    mess:Message_Buffer;
    finished:boolean;
    result:integer;

BEGIN
finished:=FALSE; checkflag:=FALSE;
WHILE NOT finished DO
BEGIN
    result:=Get_Event(E_Message,0,0,0,
            0,
            FALSE,0,0,0,0,FALSE,0,0,0,0,
            mess,
            junk,junk,junk,junk,junk,junk);
    IF result=E_Message THEN
        IF mess[0]=MN_Selected THEN
            finished:=handle_menu(mess[3],mess[4]);
END; {while}
END;

{ main program }
BEGIN
IF Init_Gem >= 0 THEN
    BEGIN
    Initialise;
    Main;
    DeInitialise;
    Exit_Gem;
    END;
END.