|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 16640 (0x4100)
Types: TextFile
Names: »STEFHEJ.PAS«
└─⟦4fbcde1e4⟧ Bits:30003931/GEM_Development-A.imd Disketter indleveret af Steffen Jensen (Piccolo/Piccoline)
└─⟦this⟧ »STEFHEJ.PAS«
(************************************************************************)
(* File: hello.pas *)
(************************************************************************)
(* *)
(* GGGGG EEEEEEEE MM MM *)
(* GG EE MMMM MMMM *)
(* GG GGG EEEEE MM MM MM *)
(* GG GG EE MM MM *)
(* GGGGG EEEEEEEE MM MM *)
(* *)
(************************************************************************)
(* *)
(* +--------------------------+ *)
(* ø Digital Research, Inc. ø *)
(* ø 60 Garden Court ø *)
(* ø Monterey, CA. 93940 ø *)
(* +--------------------------+ *)
(* *)
(* The source code contained in this listing is a non-copyrighted *)
(* work which can be freely used. In applications of this source *)
(* code you are requested to acknowledge Digital Research, Inc. as *)
(* the originator of this code. *)
(* *)
(* Author: Tom Rolander *)
(* PRODUCT: GEM Sample Desk Top Accessory *)
(* Module: HELLO *)
(* Version: February 15, 1985 *)
(* *)
(************************************************************************)
(*
\f
Page*)
(*------------------------------*)
(* includes *)
(*------------------------------*)
(*$Igempcon.i*)
(*$Igemptype.i*)
(*$Igempvar.i*)
(*$Ivdibnd.pas*)
(*$Igempatyp.i*)
(*$Igempavar.i*)
(*$Iaesbnd.pas*)
(*$Icstring.pas*)
(*------------------------------*)
(* defines *)
(*------------------------------*)
CONST
ARROW= 0;
HOUR_GLASS= 2;
DESK= 0;
END_UPDATE= 0;
BEG_UPDATE= 1;
LONG0:ADDRESS = (lo:0;hi:0);
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Data Structures ****)
(**** ****)
(************************************************************************)
(************************************************************************)
TYPE
GRECT = Record
g_x,g_y,g_w,g_h : integer;
End;
VAR
(*------------------------------*)
(* Local *)
(*------------------------------*)
gl_wchar:integer; (* character width *)
gl_hchar:integer; (* character height *)
gl_wbox:integer; (* box (cell) width *)
gl_hbox:integer; (* box (cell) height *)
gem_handle:integer; (* GEM vdi handle *)
vdi_handle:integer; (* hello vdi handle *)
work_out:ARRAY_57; (* open virt workstation values *)
work_area:GRECT; (* current window work area *)
gl_apid:integer; (* application ID *)
gl_rmsg:ARRAY_8; (* message buffer *)
ad_rmsg:ADDRESS; (* LONG pointer to message bfr *)
gl_itemhello:integer; (* hello menu item *)
gl_xfull:integer; (* full window 'x' *)
gl_yfull:integer; (* full window 'y' *)
gl_wfull:integer; (* full window 'w' width *)
gl_hfull:integer; (* full window 'h' height *)
ev_which:integer; (* event message returned value *)
hello_whndl :integer; (* hello window handle *)
type_size:integer; (* system font cell size *)
dummy:integer;
b:boolean;
CONST
MESS_NLINES=3; (* maximum lines in message *)
MESS_WIDTH=20; (* maximum width of message *)
TYPE
MESS = array(.0..MESS_NLINES.) OF CharString;
VAR
message: MESS; (* message for window *)
wdw_title: CharString; (* blank window title *)
cs : CharString;
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Local Procedures ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* min *)
(*------------------------------*)
FUNCTION
min(a, b:integer):integer; (* return min of two values *)
begin
if a<b then min:=a else min:=b;
end;
(*------------------------------*)
(* max *)
(*------------------------------*)
FUNCTION
max(a, b:integer):integer; (* return max of two values *)
Begin
if a>b then max:=a else max:=b;
End;
(*------------------------------*)
(* rc_intersect *)
(*------------------------------*)
FUNCTION
rc_intersect(VAR p1, p2:GRECT):BOOLEAN; (* compute inter of two rectangles *)
VAR
tx, ty, tw, th:integer;
Begin
tw := min(p2.g_x + p2.g_w, p1.g_x + p1.g_w);
th := min(p2.g_y + p2.g_h, p1.g_y + p1.g_h);
tx := max(p2.g_x, p1.g_x);
ty := max(p2.g_y, p1.g_y);
p2.g_x := tx;
p2.g_y := ty;
p2.g_w := tw - tx;
p2.g_h := th - ty;
rc_intersect:=( (tw > tx) AND (th > ty) );
End;
(*------------------------------*)
(* grect_to_array *)
(*------------------------------*)
PROCEDURE grect_to_array(area:GRECT;VAR arrayy:ARRAY_4);
(* convert x,y,w,h to upr lt x,y and *)
(* lwr rt x,y *)
Begin
arrayy(.0.) := area.g_x;
arrayy(.1.) := area.g_y;
arrayy(.2.) := area.g_x + area.g_w - 1;
arrayy(.3.) := area.g_y + area.g_h - 1;
End;
(*------------------------------*)
(* do_open *)
(*------------------------------*)
FUNCTION
do_open(wh, org_x, org_y, x, y, w, h:integer):integer;
(* grow and open specified wdw *)
VAR
ret_code:integer;
Begin
dummy:=graf_mouse(2,LONG0);
dummy:=graf_growbox(org_x, org_y, 21, 21, x, y, w, h);
ret_code := wind_open(wh, x, y, w, h);
dummy:=graf_mouse(ARROW,LONG0);
do_open:=ret_code;
End;
(*------------------------------*)
(* do_close *)
(*------------------------------*)
FUNCTION
do_close(wh, org_x, org_y:integer):integer;
(* close and shrink specified window *)
VAR
x, y, w, h: Integer;
a : ADDRESS;
Begin
a.hi:=0;a.lo:=0;
dummy:=graf_mouse(2,a);
dummy:=wind_get(wh, 5 (*WF_CXYWH*), x, y, w, h);
dummy:=wind_close(wh);
dummy:=graf_shrinkbox(org_x, org_y, 21, 21, x, y, w, h);
dummy:=graf_mouse(ARROW,a);
End;
(*------------------------------*)
(* set_clip *)
(*------------------------------*)
FUNCTION
set_clip(clip_flag:integer; VAR s_area:GRECT):integer;
(* set clip to specified area *)
VAR
pxy: ARRAY_4;
Begin
grect_to_array(s_area, pxy);
dummy:=vs_clip(vdi_handle, clip_flag, pxy);
End;
(*------------------------------*)
(* align_x *)
(*------------------------------*)
FUNCTION
align_x(x:INTEGER):INTEGER; (* forces word alignment for column positon, *)
(* rounding to nearest word *)
Begin
if (x AND $000c) >0 then align_x:=(x and $fff0)+$0010
else align_x:= (x and $fff0);
End;
(*------------------------------*)
(* wdw_size *)
(*------------------------------*)
FUNCTION
wdw_size(VAR box:GRECT; w, h:integer):integer;
(* compute window size for given w * h chars *)
VAR
pw, ph:integer;
Begin
dummy:=vst_height(vdi_handle, type_size,
gl_wchar,gl_hchar,gl_wbox,gl_hbox);
pw := w * gl_wbox + 1;
ph := h * gl_hbox + 1;
dummy:=wind_calc(0 (*WC_BORDER*), $000B,
gl_wfull div 2-pw div 2, gl_hfull div 2-ph div 2,
pw, ph, box.g_x, box.g_y, box.g_w, box.g_h);
box.g_x := align_x(box.g_x) - 1;
End;
(*------------------------------*)
(* disp_message *)
(*------------------------------*)
FUNCTION
disp_mesag(strptr:mess; clip_area:GRECT):integer; (* display message applying input clip *)
VAR
pxy : ARRAY_4;
ycurr : integer;
i : integer;
Begin
dummy:=set_clip(1 (*TRUE*), clip_area);
dummy:=vsf_interior(vdi_handle, 1);
dummy:=vsf_color(vdi_handle, WHITE);
grect_to_array(work_area, pxy);
dummy:=graf_mouse(256 (*M_OFF*), LONG0);
dummy:=vr_recfl(vdi_handle, pxy); (* clear entire message area *)
dummy:=vsl_color(vdi_handle,BLACK);
dummy:=vswr_mode(vdi_handle,1 (*MD_REPLACE*));
dummy:=vsl_type (vdi_handle,1 (*FIS_SOLID*));
dummy:=vswr_mode(vdi_handle, 1);
ycurr := work_area.g_y - 1;
i:=0;
while (strptr(.i.)<>'')do (* loop through text strings *)
Begin
ycurr := ycurr + gl_hbox;
dummy:=v_gtext(vdi_handle, work_area.g_x, ycurr, strptr(.i.));
i:=i+1;
End;
dummy:=graf_mouse(257 (*M_ON*), LONG0);
dummy:=set_clip(0 (*FALSE*), clip_area);
End;
(*------------------------------*)
(* do_redraw *)
(*------------------------------*)
FUNCTION
do_redraw(wh:integer;area:GRECT):integer; (* redraw message applying area clip *)
VAR
box: GRECT;
Begin
dummy:=graf_mouse(256 (*M_OFF*), LONG0);
dummy:=wind_get(wh,11 (* WF_FIRSTXYWH*)
,box.g_x,box.g_y,box.g_w,box.g_h);
while ( box.g_w<>0) AND (box.g_h<>0) do
Begin
if (rc_intersect(area, box)) THEN
Begin
if (wh = hello_whndl) THEN
Begin
dummy:=disp_mesag(message, box);
End;
End;
dummy:=wind_get(wh, 12 (*WF_NEXTXYWH*),
box.g_x,box.g_y,box.g_w,box.g_h);
End;
dummy:=graf_mouse(257 (*M_ON*), LONG0);
End;
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Message Handling ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* hndl_mesag *)
(*------------------------------*)
FUNCTION hndl_mesag:boolean;
VAR
box: GRECT;
done: BOOLEAN;
wdw_hndl: INTEGER;
a: ADDRESS;
g: GRECT;
CONST
mm:CharString =
'Æ3ÅÆFatal Error !øWindow not availableøfor Hello.ÅÆ Abort Å'@0;
Begin
done := FALSE;
wdw_hndl := gl_rmsgÆ3Å; (* wdw handle of mesag *)
Case ( gl_rmsgÆ0Å ) of (* switch on type of msg*)
40 (*AC_OPEN*): (* do accessory open *)
Begin
if ( (gl_rmsgÆ4Å = gl_itemhello) AND
(hello_whndl=0) ) then (* unless already open *)
Begin
dummy:=graf_mouse(HOUR_GLASS, LONG0);
(* 0x0B = NAME ø CLOSER ø MOVER *)
hello_whndl := wind_create($000B, align_x(gl_xfull)-1, gl_yfull, gl_wfull, gl_hfull);
if (hello_whndl = -1) then
Begin
dummy:=graf_mouse(ARROW, LONG0);
a.hi:=seg(mm);a.lo:=ofs(mm)+1;
dummy:=form_alert(1,a);
hello_whndl := 0;
hndl_mesag:=TRUE;
End;
a.hi:=seg(cs);a.lo:=ofs(cs);
dummy:=wind_set(hello_whndl, 2 (*WF_NAME*), a.lo,a.hi, 0, 0);
dummy:=wdw_size(box, MESS_WIDTH, MESS_NLINES);
dummy:=do_open(hello_whndl, gl_wfull div 2,
gl_hfull div 2, box.g_x, box.g_y, box.g_w, box.g_h);
dummy:=wind_get(hello_whndl, 4 (*WF_WXYWH*),
work_area.g_x, work_area.g_y,
work_area.g_w, work_area.g_h);
dummy:=disp_mesag(message, work_area);
dummy:=graf_mouse(ARROW,LONG0);
End
else
Begin
dummy:=graf_mouse(ARROW,LONG0);
dummy:=wind_set(hello_whndl, 10 (*WF_TOP*),
0, 0, 0, 0);
End;
End;
41 (*AC_CLOSE*): (* do accessory close *)
Begin
if ( (gl_rmsgÆ3Å = gl_itemhello) AND
(hello_whndl<>0) ) then
Begin
hello_whndl := 0; (* reset window handle *)
End;
End;
20 (*WM_REDRAW*): (* do redraw wdw contnts*)
Begin
g.g_x:=gl_rmsgÆ4Å;
g.g_y:=gl_rmsgÆ5Å;
g.g_w:=gl_rmsgÆ6Å;
g.g_h:=gl_rmsgÆ7Å;
dummy:=do_redraw(wdw_hndl, g);
End;
21 (*WM_TOPPED*): (* do window topped *)
Begin
dummy:=wind_set(wdw_hndl, 10 (*WF_TOP*), 0, 0, 0, 0);
End;
22 (*WM_CLOSED*): (* do window closed *)
Begin
dummy:=do_close(hello_whndl, gl_wfull div 2, gl_hfull div 2);
dummy:=wind_delete(hello_whndl);
hello_whndl := 0;
done := TRUE;
End;
28 (*WM_MOVED*): (* do window move *)
Begin
dummy:=wind_set(wdw_hndl,5 (*WF_CXYWH*),
align_x(gl_rmsgÆ4Å)-1, gl_rmsgÆ5Å, gl_rmsgÆ6Å, gl_rmsgÆ7Å);
dummy:=wind_get(hello_whndl,4 (*WF_WXYWH*),
work_area.g_x, work_area.g_y, work_area.g_w, work_area.g_h);
End;
OTHERWISE
(**);
End; (* switch *)
hndl_mesag:=done;
End; (* hndl_mesag *)
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Hello Event Handler ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* hello *)
(*------------------------------*)
Procedure hello;
VAR
done: BOOLEAN;
Begin
(**) (* loop handling user *)
(**) (* input until done *)
done := FALSE; (* -or- if DESKACC *)
while(NOT done) do (* then forever *)
Begin
ev_which := evnt_mesag(ad_rmsg);(* wait for message *)
dummy:=wind_update(BEG_UPDATE); (* begin window update *)
done := hndl_mesag; (* handle event message *)
dummy:=wind_update(END_UPDATE); (* end window update *)
End;
End;
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Termination ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* hello_term *)
(*------------------------------*)
Procedure hello_term;
Begin
dummy:=v_clsvwk( vdi_handle ); (* close virtual work station *)
dummy:=appl_exit; (* application exit *)
End;
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Initialization ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* hello_init *)
(*------------------------------*)
FUNCTION hello_init:BOOLEAN;
VAR
i : INTEGER;
work_in: intin_ARRAY;
attributes: ARRAY_10;
Begin
gl_itemhello := 0;
hello_whndl := 0;
messageÆ0Å := 'Hej !'; (* message for window *)
messageÆ1Å := 'verden !';
messageÆ2Å := 'Hilsen Steffen';
messageÆ3Å := ''; (* null pointer terminates input*)
wdw_title := ''; (* blank window title *)
MakeCString(wdw_title,cs);
gl_apid := appl_init; (* initialize libraries *)
for i:=0 TO 9 do
Begin
work_inÆiÅ:=1;
End;
work_inÆ10Å:=2;
gem_handle := graf_handle(gl_wchar,gl_hchar,gl_wbox,gl_hbox);
vdi_handle := gem_handle;
dummy:=v_opnvwk(work_in,vdi_handle,work_out); (* open virtual work stn*)
dummy:=vqt_attributes(vdi_handle, attributes); (* get text attributes *)
type_size := attributesÆ7Å; (* get system font hbox *)
if (vdi_handle = 0) then
hello_init:=FALSE;
(**) (* init. message address*)
ad_rmsg.hi := seg(gl_rmsgÆ0Å);
ad_rmsg.lo := ofs(gl_rmsgÆ0Å);
dummy:=wind_get(DESK,4 (*WF_WXYWH*), gl_xfull, gl_yfull, gl_wfull, gl_hfull);
hello_init:=TRUE;
End;
(*
\f
Page*)
(************************************************************************)
(************************************************************************)
(**** ****)
(**** Main Program ****)
(**** ****)
(************************************************************************)
(************************************************************************)
(*------------------------------*)
(* GEMAIN *)
(*------------------------------*)
Begin
if (hello_init) then (* initialization *)
Begin
gl_rmsgÆ0Å := 40 (*AC_OPEN*);
gl_rmsgÆ4Å := gl_itemhello;
b:=hndl_mesag;
hello;
hello_term; (* termination *)
End;
End.«eof»