home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Vectronix 2
/
VECTRONIX2.iso
/
FILES_07
/
LATTIC_3.ZIP
/
WTEST
/
WTEST.PAS
< prev
next >
Wrap
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.