Trailing-Edge
-
PDP-10 Archives
-
decuslib20-04
-
decus/20-0135/comp/form.sim
There are 4 other files named form.sim in the archive. Click here to see a list.
00040 OPTIONS(/e/l);
00080 EXTERNAL CHARACTER PROCEDURE fetchar, insinglechar;
00120 EXTERNAL INTEGER PROCEDURE trmop, gettab, checkreal, checkint, iondx;
00160 EXTERNAL PROCEDURE depchar, echo, abort, outchr, forceout, outstring;
00180 EXTERNAL PROCEDURE outche;
00200 EXTERNAL TEXT PROCEDURE frontstrip, upcase, storbokstav, tmpin, scanto;
00220 EXTERNAL TEXT PROCEDURE maketext;
00240 EXTERNAL BOOLEAN PROCEDURE tmpout, meny;
00280 EXTERNAL CLASS vista, termty;
00320 vista CLASS form;
00360 NOT HIDDEN PROTECTED myinimage, show_page, ask_page, field,
00400 intfield, realfield, choicefield, alphafield, first_field,
00440 stopasking;
00480 NOT HIDDEN height, echon, echoff, terminaltype,
00520 resume_display, cancel_display, start_blink, stop_blink,
00560 cause_real_time_delay, get_char_from_screen,
00600 synchronize, restore_the_whole_screen,
00640 home_the_cursor, set_char_on_screen,
00680 outchar, blank_line, outimage, outtext, make_blank,
00720 outfix, outreal, outint,
00760 restore_one_char,
00800 insingle, inimage, inint, inreal,
00840 inword, inyes, move_the_cursor_to, blank_the_screen,
00880 stopblink, startblink,
00920 horizontalpos, verticalpos,
00960 up, down, left, right, altmode,
01000 carriagereturn, linefeed, home, fill,
01040 null, tab, formfeed, verttab,
01080 controlchar, screen, echoenabled;
01120 BEGIN
01160 REF (field) last_field, first_field, main_field,
01200 temp_field;
01240 BOOLEAN error_is_blinking, got_movechar, stopask,
01280 last_is_controlchar;
01320 INTEGER errmesslength, i, line, order, cover_length;
01360 CHARACTER c, movechar; TEXT temp_answer;
01400
01440 PROCEDURE stopasking; stopask:= TRUE;
01480
01520
01560 PROCEDURE myinimage(length, stopchar);
01600 INTEGER length; CHARACTER stopchar;
01640 BEGIN
01680 BOOLEAN nostopchar; INTEGER count, firstpos;
01720 firstpos:= horizontalpos;
01760 sysin.image:= NOTEXT;
01800 sysin.image.setpos(1);
01840 WHILE TRUE DO
01880 BEGIN
01920 IF count > length THEN GOTO out;
01960 c:= insingle(TRUE);
02000 IF NOT nostopchar THEN
02040 nostopchar:= stopchar NE c ELSE IF c = stopchar THEN
02080 GOTO out;
02120 IF NOT controlchar AND c NE fill THEN
02160 BEGIN
02200 sysin.image.putchar(c); count:= count+1;
02240 last_is_controlchar:= FALSE;
02280 IF c = '?' AND count = 1 THEN GOTO outfast;
02320 END ELSE
02360 BEGIN
02400 IF c =
02440 carriagereturn THEN
02480 BEGIN insingle(TRUE);
02520 GOTO outfast;
02560 END;
02600 last_is_controlchar:= TRUE;
02640 BEGIN
02680 IF c NE fill THEN GOTO out;
02720 last_is_controlchar:= FALSE;
02760 IF horizontalpos < firstpos THEN
02800 move_the_cursor_to(firstpos,verticalpos);
02840 IF sysin.pos > 1 THEN
02880 BEGIN
02920 IF echoenabled THEN
02960 BEGIN
03000 IF count <= 0 THEN outchar(' ');
03040 END ELSE
03080 BEGIN
03120 sysin.setpos(sysin.pos-1);
03160 sysin.image.putchar(' ');
03200 sysin.setpos(sysin.pos-1);
03240 END;
03280 END;
03320 END;
03360 END;
03400 END;
03440 out: IF c NE tab THEN
03480 sysin.image.putchar(c);
03520 outfast: sysin.image.setpos(1);
03560 END;
03600
03640 PROCEDURE show_page;
03680 BEGIN
03720 FOR temp_field:- first_field,
03760 temp_field.next WHILE temp_field =/= NONE DO
03800 INSPECT temp_field DO
03840 BEGIN
03880 putheader; answer:- NOTEXT;
03920 END;
03960 END;
04000
04040 PROCEDURE ask_page;
04080 BEGIN
04120 loop: IF stopask THEN stopask:= FALSE ELSE
04160 FOR temp_field:- first_field,
04200 temp_field.next WHILE temp_field =/= NONE DO
04240 IF temp_field.answer = NOTEXT THEN
04280 BEGIN
04320 resume(temp_field);
04360 GOTO loop;
04400 END;
04440 sysout.breakoutimage;
04480 END;
04520
04560 CLASS field(h,v,header,length,stopchar, helptext);
04600 VALUE header, helptext;
04640 INTEGER h, v, length; CHARACTER stopchar;
04680 TEXT header, helptext;
04720 VIRTUAL: PROCEDURE help;
04760 BEGIN
04800 TEXT answer; INTEGER orderinline;
04840 REF(field) next;
04880
04920 PROCEDURE help;
04960 BEGIN
05000 IF helptext == NOTEXT THEN helptext:-
05040 copy("There is no HELP available here");
05080 blank_line(18);
05120 move_the_cursor_to(0,18); outtext(helptext); breakoutimage;
05160 error_is_blinking:= TRUE;
05200 END;
05240
05280 PROCEDURE error(errmess); VALUE errmess; TEXT errmess;
05320 BEGIN
05360 move_the_cursor_to(0,18); start_blink;
05400 outtext("->"); stop_blink;
05440 outtext(errmess);
05480 error_is_blinking:= TRUE;
05520 errmesslength:= errmess.length;
05560 GOTO get_answer;
05600 END;
05640
05680 PROCEDURE putheader;
05720 IF header =/= NOTEXT THEN
05760 BEGIN
05800 move_the_cursor_to(h,v); outtext(header);
05840 END;
05880
05920 PROCEDURE screen_answer(answer);
05960 TEXT answer;
06000 COMMENT will put answer onto screen,
06040 covering cover_length chars;
06080 BEGIN
06120 move_the_cursor_to(h+header.length+1,v);
06160 outtext(answer);
06200 make_blank(length-answer.length);
06240 END;
06280
06320 PROCEDURE change_answer(new_answer);
06360 VALUE new_answer; TEXT new_answer;
06400 BEGIN
06440 i:= answer.length;
06480 answer:- new_answer;
06520 screen_answer(answer);
06560 END;
06600
06640 IF last_field =/= NONE THEN last_field.next:- THIS
06680 field;
06720 last_field:- THIS field;
06760 IF first_field == NONE THEN first_field:- THIS field;
06800 IF line NE v THEN
06840 BEGIN
06880 line:= v; order:= orderinline:= 1;
06920 END ELSE
06960 BEGIN orderinline:= order:= order+1;
07000 END;
07040 detach;
07080 get_answer:
07120 move_the_cursor_to(h+header.length+1,v);
07160 IF echoenabled THEN inimage ELSE
07200 myinimage(length,stopchar);
07240 temp_answer:- copy(frontstrip(sysin.image.strip));
07280 IF temp_answer = "?" THEN
07320 BEGIN help; GOTO get_answer;
07360 END;
07400 IF sysin.image.sub(1,1) = " " AND temp_answer =/= NOTEXT
07440 THEN screen_answer(temp_answer);
07480 movechar:= IF temp_answer == NOTEXT THEN ' ' ELSE
07520 temp_answer.sub(temp_answer.length,1).getchar;
07560 got_movechar:= IF last_is_controlchar THEN
07600 movechar = left OR movechar = right
07640 OR movechar = up OR movechar = down
07680 OR movechar = home ELSE FALSE;
07720 IF error_is_blinking THEN
07760 BEGIN
07800 blank_line(18); error_is_blinking:= FALSE;
07840 IF answer.length > temp_answer.length THEN
07880 BEGIN
07920 move_the_cursor_to(h+header.length+1
07960 +temp_answer.length-
08000 (IF got_movechar THEN 1 ELSE 0),v);
08040 cover_length:= answer.length-temp_answer.length
08080 +(IF got_movechar THEN 1 ELSE 0);
08120 FOR i:= 1 STEP 1 UNTIL cover_length DO outchar(' ');
08160 END;
08200 answer:- NOTEXT;
08240 END;
08280 IF answer.length > temp_answer.length AND
08320 NOT (NOT echoenabled AND got_movechar
08360 AND temp_answer.length = 1) THEN
08400 BEGIN
08440 move_the_cursor_to(h+header.length+1+temp_answer.
08480 length, v);
08520 cover_length:= answer.length;
08560 FOR i:= temp_answer.length+1 STEP 1 UNTIL
08600 cover_length DO outchar(' ');
08640 END;
08680 IF (IF temp_answer == NOTEXT THEN FALSE
08720 ELSE temp_answer.sub(1,1) = "^") THEN
08760 BEGIN
08800 TEXT searched; REF(field) test_field;
08840 screen_answer(answer);
08880 searched:- temp_answer.sub(2,temp_answer.length-1);
08920 test_field:- first_field;
08960 WHILE test_field =/= NONE DO
09000 BEGIN
09040 IF test_field.header.length >= searched.length
09080 THEN
09120 BEGIN
09160 IF test_field.header.sub(1,
09200 searched.length) = searched THEN
09240 BEGIN
09280 IF test_field =/= THIS field THEN
09320 BEGIN
09360 IF main_field == NONE THEN main_field:-
09400 THIS field;
09440 resume(test_field);
09480 END;
09520 GOTO get_answer;
09560 END;
09600 END;
09640 test_field:- test_field.next;
09680 END;
09720 error("No such header.");
09760 END;
09800 IF NOT echoenabled THEN
09840 BEGIN
09880 IF got_movechar THEN
09920 BEGIN
09960 INTEGER goalline, goalorder;
10000 BOOLEAN modified_goal;
10040 REF (field) test_field, back_field;
10080 IF movechar = home THEN
10120 BEGIN goalline:= 0; goalorder:= 1;
10160 END ELSE IF movechar = left THEN
10200 BEGIN goalline:= v; goalorder:= orderinline-1;
10240 IF goalorder < 1 THEN goalorder:= 1;
10280 END ELSE IF movechar = right THEN
10320 BEGIN goalline:= v; goalorder:= orderinline+1;
10360 END ELSE IF movechar = up THEN
10400 BEGIN goalline:= v-1; goalorder:= orderinline;
10440 END ELSE IF movechar = down THEN
10480 BEGIN goalline:= v+1; goalorder:= orderinline;
10520 END;
10560 test_field:- first_field;
10600 WHILE test_field =/= NONE DO
10640 BEGIN
10680 tryagain: IF test_field.v = goalline AND
10720 test_field.orderinline =
10760 goalorder THEN GOTO found;
10800 IF test_field.v > goalline THEN
10840 BEGIN
10880 IF back_field =/= NONE THEN
10920 BEGIN
10960 IF movechar = up AND NOT modified_goal THEN
11000 BEGIN
11040 modified_goal:= TRUE;
11080 goalline:= back_field.v;
11120 test_field:-first_field;
11160 GOTO tryagain;
11200 END ELSE IF movechar = down THEN
11240 BEGIN
11280 IF test_field.v-back_field.v>1 THEN
11320 goalline:=
11360 goalline+test_field.v-back_field.v-1;
11400 GOTO tryagain;
11440 END;
11480 END;
11520 GOTO backfound;
11560 END;
11600 back_field:- test_field;
11640 test_field:- test_field.next;
11680 END;
11720 IF movechar = down AND NOT modified_goal THEN
11760 BEGIN
11800 modified_goal:= TRUE;
11840 goalline:= goalline-1;
11880 test_field:- first_field;
11920 GOTO tryagain;
11960 END;
12000 backfound: IF back_field =/= NONE
12040 THEN test_field:- back_field;
12080 found: IF test_field =/= THIS field THEN
12120 BEGIN
12160 IF main_field == NONE THEN main_field:-
12200 THIS field;
12240 resume(test_field);
12280 END;
12320 GOTO get_answer;
12360 END;
12400 END;
12440 answer:- temp_answer;
12480 INNER; IF main_field == NONE THEN detach ELSE
12520 BEGIN temp_field:- main_field; main_field:- NONE;
12560 IF temp_field =/= THIS field AND
12600 temp_field.answer == NOTEXT THEN
12640 resume(temp_field) ELSE detach;
12680 END;
12720 GOTO get_answer;
12760 END of field;
12800
12840 field CLASS intfield(min,max,rangerror);
12880 VALUE rangerror; INTEGER min, max; TEXT rangerror;
12920 BEGIN
12960 INTEGER intvalue;
13000 answer.setpos(1);
13040 IF checkint(answer) >= 1 AND NOT answer.more THEN
13080 BEGIN
13120 answer.setpos(1); intvalue:= answer.getint;
13160 IF intvalue < min OR intvalue > max THEN
13200 error(rangerror);
13240 END ELSE error("Integer input was expected.");
13280 END;
13320
13360 field CLASS realfield(min,max,rangerror);
13400 VALUE rangerror; REAL min, max; TEXT rangerror;
13440 BEGIN
13480 REAL realvalue;
13520 answer.setpos(1);
13560 IF checkreal(answer) >= 1 AND NOT answer.more THEN
13600 BEGIN
13640 answer.setpos(1); realvalue:= answer.getreal;
13680 IF realvalue < min OR realvalue > max THEN
13720 error(rangerror);
13760 END ELSE error("Integer input was expected.");
13800 END;
13840
13880 field CLASS choicefield(nonemessage);
13920 VALUE nonemessage; TEXT nonemessage;
13960 BEGIN
14000 CLASS choice(choicetext);
14040 VALUE choicetext; TEXT choicetext;
14080 BEGIN
14120 REF (choice) nextchoice;
14160 upcase(choicetext);
14200 IF lastchoice =/= NONE THEN
14240 lastchoice.nextchoice:- THIS choice ELSE
14280 firstchoice:- THIS choice;
14320 lastchoice:- THIS choice;
14360 END;
14400 REF (choice) firstchoice, lastchoice, tempchoice;
14440 REF (choice) foundchoice;
14480 foundchoice:- NONE;
14520 upcase(answer);
14560 IF answer =/= NOTEXT THEN
14600 BEGIN
14640 tempchoice:- firstchoice;
14680 WHILE tempchoice =/= NONE DO
14720 BEGIN
14760 INSPECT tempchoice DO
14800 IF answer.length <= choicetext.length THEN
14840 BEGIN
14880 IF choicetext.sub(1,answer.length) = answer THEN
14920 BEGIN
14960 IF answer.length EQ choicetext.length THEN
15000 GOTO good;
15040 IF foundchoice =/= NONE THEN
15080 BEGIN
15120 error("Ambiguous entry, give more characters.");
15160 GOTO good;
15200 END;
15240 foundchoice:- tempchoice;
15280 END;
15320 END;
15360 tempchoice:- tempchoice.nextchoice;
15400 END;
15440 END;
15480 IF foundchoice == NONE THEN error(nonemessage)
15520 ELSE change_answer(foundchoice.choicetext);
15560 good:
15600 END of choicefield;
15640
15680 field CLASS alphafield;
15720 BEGIN
15760 answer.setpos(1);
15800 WHILE answer.more DO
15840 BEGIN
15880 c:= answer.getchar;
15920 IF NOT letter(c) AND c NE ' ' THEN
15960 error("Only letters accepted in answer.");
16000 END;
16040 END of alphafield;
16080 line:= -1;
16120 END of form;