|
DataMuseum.dkPresents historical artifacts from the history of: RegneCentralen RC759 "Piccoline" |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RegneCentralen RC759 "Piccoline" Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 16547 (0x40a3)
Types: TextFile
Names: »CPIMENU.PAS«
└─⟦d4ddf50a0⟧ Bits:30004478 CPI-graf 2.5 til Piccoline/Partner
└─⟦this⟧ »CPIMENU.PAS«
æ$A+,B-,D+,E-,F-,I-,L-,N-,O-,R-,S-,V-å
UNIT cpimenu;
(*------------------------------------------------------------------------*)
(* CPI-menu 2.5 *)
(* (November 1988) *)
(* Copyright Dansk Center For P▶91◀dagogik og Informatik 1986 *)
(* Peter Ferdinand *)
(* Version til TUBO PASCAL version 5.0 *)
(* *)
(* En r▶91◀kke procedurer i PolyPascal beregnet til AT inds▶91◀tte i et pro- *)
(* gram. Procedurerne betyder AT brugeren f▶86◀r en ensartet grafisk gr▶91◀- *)
(* seflade uanset typen af datamat. Der kan defineres vinduer i b▶86◀de *)
(* grafik- og teksttilstand i disse vinduer kan der udskrives til *)
(* sk▶91◀rmen meget hurtigt og udenom styresystemet. *)
(* *)
(* Datamater som underst▶9b◀ttes er: *)
(* IBM PC med Color Graphic Apapter (640 * 200 pixels) *)
(* IBM PC med Enhanced Color Adapter (640 * 350 pixels) *)
(* IBM PC med Hercules adapter (720 * 350 pixels) *)
(* IBM PS2/30 med MCGA adapter (640 * 480 pixels) *)
(* Regnecentralen Partner (720 * 352 pixels) *)
(* Regnecentralen Piccoline (560 * 256 pixels) *)
(* *)
(* Procedurerne vil let kunne tilpasses alle datamater, hvor brugeren *)
(* har adgang til lageret for det grafiske sk▶91◀rmbillede. *)
(* *)
(*------------------------------------------------------------------------*)
INTERFACE
uses dos, cpigraf;
CONST
Men_max = 8;
Men_lgt = 19;
Men_OnOff : ARRAY(.BOOLEAN.) OF STRING(.3.) = ('TIL','FRA');
TYPE
Men_ArtType =
(artnone,horizontal,vertical,Men_rea,Men_st,men_int,men_bool,Men_help,dialog,proc);
Men_selectype = STRING(.Men_lgt.);
Men_arr2 = ^Men_arr;
MenuType = RECORD
C : CHAR;
S : Men_selectype;
no1,no2 : INTEGER;
x1,y1 : INTEGER;
art : Men_ArtType;
next : men_arr2;
subrout : pointer;
END;
Men_arr = ARRAY(.1..men_max.) OF MenuType;
ResourceType1 = record
Men_root : Men_arr2;
men_x1, men_y1 : INTEGER;
men_no1,men_no2 : INTEGER;
Men_art : Men_Arttype;
Men_Hdr : Str80;
Men_fcolor, Men_bcolor : INTEGER;
Men_fcolorTxt, Men_bcolorTxt : INTEGER;
END;
ResourceType =^ResourceType1;
VAR
Men_actual : ResourceType;
Men_dept : INTEGER;
Men_selec : Men_selectype;
Men_END : BOOLEAN;
Men_result : INTEGER;
newnode : men_arr2;
Men_proc : pointer;
PROCEDURE Addproc(w: pointer; c: Men_selectype);
PROCEDURE newresource(VAR res: ResourceType; x,y: INTEGER; hdr:str80);
PROCEDURE SetResourceColor(VAR res: ResourceType; fcolor, bcolor: INTEGER);
PROCEDURE SetResourceTextColor(VAR res: ResourceType; fcolor, bcolor: INTEGER);
PROCEDURE selectresource(VAR res:ResourceType);
PROCEDURE Addmenu(antal: INTEGER;VAR where; c:Men_selectype; hor1: Men_ArtType);
PROCEDURE Addreal(xlgt:INTEGER;VAR re: REAL; c: Men_selecType);
PROCEDURE Addinteger(xlgt:INTEGER;VAR int: INTEGER; c: Men_selecType);
PROCEDURE Addboolean(VAR bool: BOOLEAN; c: Men_selecType);
PROCEDURE Addstr(xlgt: INTEGER;VAR str: str80; c: Men_selecType);
PROCEDURE Addhelp(xlgt,no2: INTEGER;VAR helpstr; c: men_selectype);
PROCEDURE Dlg_Addreal(x,y,xlgt:INTEGER;VAR re: REAL; c: Men_selecType);
PROCEDURE Dlg_Addinteger(x,y,xlgt:INTEGER;VAR int: INTEGER; c: Men_selecType);
PROCEDURE Dlg_Addboolean(x,y: INTEGER;VAR bool: BOOLEAN; c: Men_selecType);
PROCEDURE Dlg_Addstr(x,y,xlgt: INTEGER;VAR str: str80; c: Men_selecType);
PROCEDURE Dlg_Addtext(x,y,xlgt,no2: INTEGER;VAR helpstr; c: men_selectype);
PROCEDURE Addialog(x1,y1,noobj: INTEGER; c: men_selectype);
PROCEDURE ResourceDisplay;
IMPLEMENTATION
PROCEDURE Men_inset(node: men_arr2; antal: INTEGER;art1: men_arttype);
VAR
i : INTEGER;
BEGIN
FOR i:=1 TO antal DO
WITH node^(.i.) DO BEGIN
no1:=0;
art:=artnone;
next:=NIL;
subrout:=nil;
if art1=dialog then c:=chr(i-1+48) else
IF c in (.'a'..'å'.) THEN c:=chr(ord(c)-32);
END;
END;
PROCEDURE men_submenu(x,y,antal, leng: INTEGER;VAR where; selec:Men_selectype; hor1: Men_ArtType);
VAR
i : INTEGER;
PROCEDURE Men_seach(node:Men_arr2;procno: INTEGER);
VAR
i :INTEGER;
BEGIN
FOR i:=1 TO procno DO BEGIN
WITH node^(.i.) DO
IF (c=selec(.Men_dept.)) THEN BEGIN
if (hor1=proc) and (length(selec)=men_dept) then BEGIN
subrout:=men_proc;
exit;
END;
IF next=NIL THEN BEGIN
next:=Addr(where);
art:=hor1;
no1:=antal;
no2:=leng;
x1:=x; y1:=y;
IF hor1 in (.horizontal,vertical,dialog.) THEN
Men_inset(next,antal,hor1);
exit;
END;
Men_dept:=Men_dept+1;
Men_seach(next,no1);
exit;
END;
END;
error(5);
END;
BEGIN
if men_actual=nil then error(9);
with Men_actual^ do BEGIN
if selec='' then BEGIN
men_art:=hor1;
men_no1:=antal;
men_no2:=leng;
men_root:=@where;
if hor1 in (.horizontal, vertical, dialog.) then
men_inset(men_root,antal,hor1);
END else BEGIN
Men_dept:=1;
Men_seach(Men_root,men_no1);
END;
END;
END;
PROCEDURE Addproc(w:pointer; c: Men_selectype);
VAR dum :men_arr2;
BEGIN
dum:=nil;
men_proc:=w;
men_submenu(0,0,0,0,dum,c,proc);
END;
PROCEDURE newresource(VAR res: ResourceType; x,y: INTEGER; hdr:str80);
BEGIN
if maxavail> SIZEOF(ResourceType1) then
getmem(res,SIZEOF(ResourceType1))
else
error(8);
with res^ do BEGIN
men_root:=nil;
Men_art:=artnone;
men_no1:=0;
men_x1:=x;
men_y1:=y;
men_hdr:=hdr;
Men_fcolor:=black;
Men_bcolor:=white;
Men_fcolorTxt:=BlackTxt;
Men_bcolorTxt:=WhiteTxt;
END;
men_actual:=res;
END;
PROCEDURE SetResourceColor(VAR res: ResourceType; fcolor, bcolor: INTEGER);
BEGIN
if res= nil then error(9);
with res^ do BEGIN
men_fcolor:=fcolor;
men_bcolor:=bcolor;
END;
END;
PROCEDURE SetResourceTextColor(VAR res: ResourceType; fcolor, bcolor: INTEGER);
BEGIN
if res= nil then error(9);
with res^ do BEGIN
men_fcolorTxt:=fcolor;
men_bcolorTxt:=bcolor;
END;
END;
PROCEDURE selectresource(VAR res:ResourceType);
BEGIN
Men_actual:=res;
END;
PROCEDURE Addmenu(antal: INTEGER;VAR where; c:Men_selectype; hor1: Men_ArtType);
BEGIN
Men_submenu(0,0,antal,0,where,c,hor1);
END;
PROCEDURE Addreal(xlgt:INTEGER;VAR re: REAL; c: Men_selecType);
BEGIN
Men_submenu(0,0,xlgt,2,re,c,Men_rea);
END;
PROCEDURE Addinteger(xlgt:INTEGER;VAR int: INTEGER; c: Men_selecType);
BEGIN
Men_submenu(0,0,xlgt,0,int,c,Men_int);
END;
PROCEDURE Addboolean(VAR bool: BOOLEAN; c: Men_selecType);
BEGIN
Men_submenu(0,0,3,0,bool,c,Men_bool);
END;
PROCEDURE Addstr(xlgt: INTEGER;VAR str: str80; c: Men_selecType);
BEGIN
Men_submenu(0,0,xlgt,0,str,c,Men_st);
END;
PROCEDURE Addhelp(xlgt,no2: INTEGER;VAR helpstr; c: men_selectype);
BEGIN
men_submenu(0,0,xlgt,no2,helpstr,c,men_help);
END;
PROCEDURE Dlg_Addreal(x,y,xlgt:INTEGER;VAR re: REAL; c: Men_selecType);
BEGIN
Men_submenu(x,y,xlgt,2,re,c,Men_rea);
END;
PROCEDURE Dlg_Addinteger(x,y,xlgt:INTEGER;VAR int: INTEGER; c: Men_selecType);
BEGIN
Men_submenu(x,y,xlgt,0,int,c,Men_int);
END;
PROCEDURE Dlg_Addboolean(x,y: INTEGER;VAR bool: BOOLEAN; c: Men_selecType);
BEGIN
Men_submenu(x,y,3,0,bool,c,Men_bool);
END;
PROCEDURE Dlg_Addstr(x,y,xlgt: INTEGER;VAR str: str80; c: Men_selecType);
BEGIN
Men_submenu(x,y,xlgt,0,str,c,Men_st);
END;
PROCEDURE Dlg_Addtext(x,y,xlgt,no2: INTEGER;VAR helpstr; c: men_selectype);
BEGIN
men_submenu(x,y,xlgt,no2,helpstr,c,men_help);
END;
PROCEDURE Addialog(x1,y1,noobj: INTEGER; c: men_selectype);
VAR
n: INTEGER;
BEGIN
n:=SIZEOF(menutype)*(noobj+1);
if maxavail>n then
getmem(newnode,n)
else
error(8);
men_submenu(x1,y1,noobj,0,newnode^,c,dialog);
END;
PROCEDURE dummy;
BEGIN
Inline(
$FF/$1E/>MEN_PROC æ call far Æ>men_procÅå);
END;
PROCEDURE ResourceDisplay;
CONST
stopchars : SET OF CHAR = (.#27,#13,#9.);
VAR
st : str80;
strlgt : byte ABSOLUTE st;
stptr : ^str80;
reptr : ^REAL;
boolptr : ^BOOLEAN;
intptr : ^INTEGER;
oldch : CHAR;
j, k, lgtselect : INTEGER;
inset,changed, bool : BOOLEAN;
select : ARRAY(.1..men_max.) OF CHAR;
fromrow : ARRAY(.1..men_max.) OF INTEGER;
PROCEDURE showmenu(xpos,ypos,procno,procno2: INTEGER;
hor1: Men_ArtType; node: Men_arr2; show: BOOLEAN; proc: pointer);
VAR
i,j,xy,lastxy : INTEGER;
ch : CHAR;
found : BOOLEAN;
wind : wnd_id;
PROCEDURE swapb(VAR b:byte);
BEGIN
b:=(b MOD 16) SHL 4 + (b SHR 4);
swapi(wnd_pencolor,wnd_backcolor);
END;
PROCEDURE opdater;
BEGIN
CASE hor1 OF
horizontal:
BEGIN
writetext(fromrow(.lastxy.),0,node^(.lastxy.).s);
swapb(wnd_palette(.wnd_actual^.paletteno.));
WriteText(fromrow(.xy.),0,node^(.xy.).s)
END;
vertical:
BEGIN
WriteText(0,lastxy-1,node^(.lastxy.).s);
swapb(wnd_palette(.wnd_actual^.paletteno.));
WriteText(0,xy-1,node^(.xy.).s);
END
END;
swapb(wnd_palette(.wnd_actual^.paletteno.));
lastxy:=xy;
END;
PROCEDURE men_open(x1,x2,y1,y2: INTEGER);
BEGIN
if show then exit;
newtextviewport(wind,x1,x2,y1,y2);
with men_actual^ do BEGIN
setviewportcolor(wind,Men_Fcolor,Men_bcolor);
setpalette(2,Men_fcolorTxt,Men_bcolorTxt);
END;
settextviewportcolor(wind,2);
if men_dept=0 then setviewportheader(wind,men_actual^.men_hdr);
selectviewport(wind);
writeframe;
END;
PROCEDURE men_close;
BEGIN
closeviewport(wind);
END;
BEGIN
i:=0; Men_result:=0;
CASE hor1 OF
Men_rea: BEGIN
Men_Open(xpos,xpos+procno+2,ypos,ypos+2);
reptr:=Addr(node^);
str(reptr^:procno:procno2,st);
WHILE st(.1.)=' ' DO delete(st,1,1);
if show then BEGIN
WriteText(xpos,ypos,st+spc(procno,' ')); exit;
END;
REPEAT;
inputstr(st,stopchars,i,0,0,procno,changed,inset);
IF (char1=esc) and (char2=#13) THEN val(st,reptr^,men_result);
UNTIL (men_result=0) OR (char2=esc) or (char2=#9);
END;
Men_int: BEGIN
Men_Open(xpos,xpos+procno+2,ypos,ypos+2);
intptr:=Addr(node^);
str(intptr^:procno,st);
WHILE st(.1.)=' ' DO delete(st,1,1);
if show then BEGIN
WriteText(xpos,ypos,st+spc(procno,' ')); exit;
END;
REPEAT;
inputstr(st,stopchars,i,0,0,procno,changed,inset);
IF (char1=esc) and (char2=#13) THEN val(st,intptr^,men_result);
UNTIL (men_result=0) OR (char2=esc) or (char2=#9);
END;
Men_bool: BEGIN
Men_Open(xpos,xpos+procno+2,ypos,ypos+2);
boolptr:=Addr(node^);
bool:=boolptr^;
if show then BEGIN
WriteText(xpos,ypos,men_OnOff(.NOT bool.)); exit;
END;
REPEAT
WriteText(0,0,men_OnOff(.NOT bool.));
REPEAT readchar UNTIL char2 in stopchars+(.#32.);
IF char2=#32 THEN BEGIN bool:=NOT bool;changed:=true END;
if char2=#13 then boolptr^:=bool;
UNTIL char2 in stopchars;
END;
Men_st: BEGIN
Men_Open(xpos,xpos+procno+2,ypos,ypos+2);
stptr:=Addr(node^);
st:=stptr^;
if show then BEGIN
WriteText(xpos,ypos,st+spc(procno,' ')); exit;
END;
inputstr(st,stopchars,i,0,0,procno,changed,inset);
IF char2=#13 THEN stptr^:=st;
END;
Men_help:
BEGIN
Men_Open(xpos,xpos+procno+1,ypos,ypos+procno2+1);
k:=0;
FOR i:=1 TO procno2 DO BEGIN
strlgt:=mem(.seg(node^):ofs(node^)+k.);
FOR j:=1 TO strlgt DO
st(.j.):=CHAR(mem(.seg(node^):ofs(node^)+k+j.));
k:=k+procno+1;
if show then WriteText(xpos,ypos+i-1,st) else WriteText(0,i-1,st);
END;
if show then exit;
REPEAT readchar UNTIL char2 in stopchars+(.fup,fdown.);
END;
dialog:
BEGIN
changed:=false;
with node^(.1.) do
men_open(xpos,xpos+no1+2,ypos,ypos+no2+2);
for i:=1 to procno do
with node^(.i.) do
if next<>nil then showmenu(x1,y1,no1,no2,art,next,true,subrout);
i:=2;
repeat
if i>procno then i:=2;
if i<2 then i:=procno;
with node^(.i.) do
if next<>nil then BEGIN
Men_dept:=Men_dept+1;
select(.men_dept.):=c;
lgtselect:=men_dept;
showmenu(xpos+x1,ypos+y1,no1,no2,art,next,false,subrout);
if changed then showmenu(x1,y1,no1,no2,art,next,true, subrout);
END;
j:=i;
if (char2=fdown) or (char2=#13) then i:=i+1 else
if char2=fup then i:=i-1;
until (char2=esc) or ((node^(.j.).art=men_help) and (char2=#13));
men_END:=true;
END;
horizontal,vertical:
BEGIN
IF hor1=horizontal THEN BEGIN
j:=0;
Men_Open(0,txt_maxx,ypos,ypos+2);
FOR i:=1 TO procno DO BEGIN
WriteText(j,0,node^(.i.).s);
fromrow(.i.):=j;
j:=j+length(node^(.i.).s)+1
END;
END
ELSE BEGIN
Men_Open(xpos,xpos+men_lgt+1,ypos,ypos+procno+1);
FOR i:=1 TO procno DO WriteText(0,i-1,node^(.i.).s);
END;
xy:=1; lastxy:=1; oldch:=' ';
REPEAT
opdater;
if oldch=' ' then BEGIN
readchar;
ch:=char2;
if (hor1=vertical) and (char1=esc) and (ch in (.Fleft,Fright.)) then
BEGIN oldch:=ch; ch:=#27 END;
END
else
BEGIN ch:=oldch; if oldch=#13 then oldch:=' ' else oldch:=#13 END;
found:=false;
IF ch in (.'a'..'å'.) THEN ch:=chr(ord(ch)-32);
if (char1<>esc) and (ch in (.' '..'Å'.)) then
BEGIN
i:=1;
WHILE (node^(.i.).c<>ch) AND (i<=procno) DO i:=i+1;
IF i<=procno THEN BEGIN found:=true; xy:=i;END;
END else
case ch of
Fup,Fleft:
BEGIN
xy:=xy-1;
IF xy<1 THEN xy:=procno;
END;
Fdown,Fright:
BEGIN
xy:=xy+1;
IF xy>procno THEN xy:=1;
END;
#13: found:=true;
#27: BEGIN
men_close; Men_dept:=Men_dept-1; exit END;
END;
IF found THEN
WITH node^(.xy.) DO
BEGIN
opdater;
Men_dept:=Men_dept+1;
select(.men_dept.):=c;
IF (next<>NIL) THEN
if art=dialog then
showmenu(x1,y1,no1,no2,art,next,false,subrout) else
if hor1=horizontal then
showmenu(xpos+fromrow(.xy.),ypos+2,no1,no2,art,next,false,subrout)
else showmenu(xpos+3,ypos+xy+1,no1,no2,art,next,false,subrout)
ELSE
BEGIN
Men_END:=true;lgtselect:=men_dept;
END;
END;
UNTIL Men_END;
END
END;
men_close;
if proc<>nil then BEGIN men_proc:=proc; dummy; END;
Men_dept:=Men_dept-1;
END;
BEGIN
if men_actual=nil then error(9);
Men_END:=false;
Men_dept:=0;
select:=' ';
inset:=false; changed:=false;
with Men_actual^ do showmenu(men_x1,men_y1,men_no1,men_no2,Men_Art,Men_root,false,nil);
men_selec:=copy(select,1,lgtselect);
END;
begin
men_actual:=nil;
end.
«eof»