Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-08 - 43,50463/10/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;