[INHERIT('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES',
'SYS$LIBRARY:PASCAL$SMG_ROUTINES')]
PROGRAM VT240(OU,T);
(*****************************************************************************)
LABEL	1,2,3,4,5,6;
TYPE	FILE_NAME			=	PACKED ARRAY [1..17] OF CHAR;
	ASCI				=	PACKED ARRAY [1..95] OF CHAR;
	LLL				=	PACKED ARRAY [0..5] OF INTEGER;
CONST	C				=	ASCI[1:' ';2:'!';3:''(34);
4:'#';5:'$';6:'%';7:'&';8:''(39);9:'(';10:')';11:'*';12:'+';13:',';14:'-';
15:'.';16:'/';17:'0';18:'1';19:'2';20:'3';21:'4';22:'5';23:'6';24:'7';25:'8';
26:'9';27:':';28:';';29:'<';30:'=';31:'>';32:'?';33:'@';34:'A';35:'B';36:'C';
37:'D';38:'E';39:'F';40:'G';41:'H';42:'I';43:'J';44:'K';45:'L';46:'M';47:'N';
48:'O';49:'P';50:'Q';51:'R';52:'S';53:'T';54:'U';55:'V';56:'W';57:'X';58:'Y';
59:'Z';60:'[';61:'\';62:']';63:'^';64:'_';65:''(96);66:'a';67:'b';68:'c';
69:'d';70:'e';71:'f';72:'g';73:'h';74:'i';75:'j';76:'k';77:'l';78:'m';79:'n';
80:'o';81:'p';82:'q';83:'r';84:'s';85:'t';86:'u';87:'v';88:'w';89:'x';90:'y';
91:'z';92:'{';93:'|';94:'}';95:'~'];
	L				=	LLL[0:1;1:2;2:4;3:8;4:16;5:32];
	MODE				=	IO$_TTYREADALL+IO$M_NOECHO;
VAR	KEYBOARD,DIS,PASTEBOARD		:	[VOLATILE] UNSIGNED;
	W				:	CHAR;
	TT				:	[WORD] 0..65535;
	FILE_INPUT			:	FILE_NAME VALUE 'VT240.LIS'(0)
					''(0)''(0)''(0)''(0)''(0)''(0)''(0);
	FILE_OUTPUT			:	FILE_NAME VALUE 'VT240.LIS'(0)
					''(0)''(0)''(0)''(0)''(0)''(0)''(0);
	FILE_HELP			:	PACKED ARRAY [1..80] OF CHAR;
	S				:	[VOLATILE] ARRAY [0..94,0..1] OF
						PACKED ARRAY [1..8] OF CHAR;
	EI				:	INTEGER VALUE 4;
	EO				:	INTEGER VALUE 4;
	NI				:	INTEGER VALUE 10;
	NO 				:	INTEGER VALUE 10;
	NL				:	[VOLATILE] INTEGER VALUE 0;
	NR				:	[VOLATILE] INTEGER VALUE 1;
	K				:	[VOLATILE] INTEGER VALUE 0;
	M				:	[VOLATILE] INTEGER VALUE 0;
	N				:	[VOLATILE] INTEGER VALUE 0;
	I				:	INTEGER VALUE 80;
	J				:	INTEGER;
	OU,T				:	[VOLATILE] TEXT;
(*****************************************************************************)
PROCEDURE AUX(VAR NAME: FILE_NAME; VAR NUM,EXT: INTEGER);
VAR	A:	INTEGER;
BEGIN
IF EXT=0 THEN
	BEGIN
	NAME[NUM]:='.'; NAME[NUM+1]:='L'; NAME[NUM+2]:='I'; NAME[NUM+3]:='S';
	NUM:=NUM+4; EXT:=4
	END;
FOR A:=NUM TO 17 DO NAME[A]:=''(0)
END;
(*****************************************************************************)
PROCEDURE READ_NAME(VAR NAME: FILE_NAME; VAR NUM,EXT: INTEGER);
LABEL 1,2;
PROCEDURE TST(N1: INTEGER);
PROCEDURE AUX1(N2,N3: INTEGER);
BEGIN
IF NUM<N2 THEN
	BEGIN
	NAME[NUM]:=CHR(ORD(W)-N1); WRITELN(OU,NAME[NUM]);
	NUM:=NUM+1; EXT:=EXT+N3
	END
ELSE	WRITELN(OU,''(7))
END;
BEGIN	IF EXT>0 THEN	AUX1(18,1)	ELSE	AUX1(14,0)	END;
BEGIN
1: $QIOW(,TT,MODE,,,,W,1);
CASE W OF
''(0),''(10),''(13):	GOTO 2;
''(8),''(127):
	IF NUM>1 THEN
	 BEGIN
	 IF EXT>0 THEN EXT:=EXT-1;
	 NUM:=NUM-1; WRITELN(OU,''(8)''(155)'P')
	 END
	ELSE	WRITELN(OU,''(7));
''(1)..''(7),''(9),''(11),''(12),''(14)..' ',''(128)..''(255):
	WRITELN(OU,''(7));
'.':	IF NUM<18 THEN
		BEGIN
		NAME[NUM]:='.'; EXT:=1; NUM:=NUM+1; WRITELN(OU,'.')
		END
	ELSE	WRITELN(OU,''(7));
'a'..'z':	TST(32);
OTHERWISE	TST(0);
END;
GOTO 1;
2: AUX(NAME,NUM,EXT);	WRITE(OU,''(155)'M'(155)'0m')
END;
(*****************************************************************************)
PROCEDURE STATUS_INPUT; FORWARD;
(*****************************************************************************)
PROCEDURE INPUT_FILE;
BEGIN
WRITELN(OU,''(155)'24;1HInput Font File [.LIS]: '(155)'7m',FILE_INPUT,
''(27)'[?25h'); READ_NAME(FILE_INPUT,NI,EI); STATUS_INPUT
END;
(*****************************************************************************)
PROCEDURE STATUS_INPUT;
BEGIN
OPEN(T,FILE_INPUT,HISTORY:=OLD,RECORD_LENGTH:=1727,ERROR:=CONTINUE);
IF STATUS(T)=0
THEN	RESET(T)
ELSE	BEGIN
	WRITELN(OU,''(27)'[?25l'(7)'Error reading file <'(155)'7m',
	FILE_INPUT,''(155),UDEC(17-NI),'D'(155),UDEC(17-NI),'P'(155)'0m>');
	LIB$WAIT(2.0); WRITE(OU,''(27)'[?25h'); INPUT_FILE
	END
END;
(*****************************************************************************)
PROCEDURE OUT;
LABEL	1;
VAR	I	:	INTEGER;
BEGIN
WRITELN(OU,''(155)'24;1H'(15)'Output Font File [.LIS]: '(155)'7m',FILE_OUTPUT);
READ_NAME(FILE_OUTPUT,NO,EO);
OPEN(T,FILE_OUTPUT,HISTORY:=NEW,RECORD_LENGTH:=1727,CARRIAGE_CONTROL:=NONE,
ERROR:=CONTINUE);
IF STATUS(T)=0
THEN	REWRITE(T)
ELSE	BEGIN
	WRITELN(OU,''(7)'Error opening file <'(155)'7m',FILE_OUTPUT,''(155)'0m>');
	GOTO 1
	END;
WRITELN(OU,'Writing Font File...');
WRITE(T,''(27)'<'(27)'[62;1"p'(27)'[?67l'(0)''(0)''(0)''(0)''(144)';1;;4{ @');
FOR I:=1 TO 93 DO	WRITE(T,S[I,0],'/',S[I,1],';');
WRITE(T,S[94,0],'/',S[94,1],''(156)''(27)'* @'(27)'}');
CLOSE(T);
OPEN(T,'VT240.CFG',HISTORY:=NEW); REWRITE(T);
WRITELN(T,FILE_INPUT,'  ( Input font file )');
WRITELN(T,FILE_OUTPUT,'  ( Output font file )');
WRITELN(T,N,NL,NR); CLOSE(T); WRITE(OU,''(155)'M');
1: END;
(*****************************************************************************)
PROCEDURE ENVS;
BEGIN
WRITE(OU,''(27)'[?25l'(14)''(155)'2;60Hlqqqqqqqqqqqqqqqqqk'(155)'3;60Hx '
(15)''(155)'1mInput Font File'(14)''(155)'0m x'(155)'4;60Hx'(155)'17Cx'
(155)'5;60Hx'(155)'K'(15)''(155),UDEC(19-NI DIV 2,1,1),'C',FILE_INPUT,''(14)
''(155)'5;78Hx'(155)'6;60Hmqqqqqqqqqqqqqqqqqj'(155)'7;60Hlqqqqqqqqqqqqqqqqqk'
(155)'8;60Hx '(15)''(155)'1mOutput Font File'(14)''(155)'0mx'(155)'9;60Hx'
(155)'17Cx'(155)'10;60Hx'(155)'K'(15)''(155),UDEC(19-NO DIV 2,1,1),'C',
FILE_OUTPUT,''(14)''(155)'10;78Hx'(155)'11;60Hmqqqqqqqqqqqqqqqqqj'(155)
'12;60Hlqqqqqqqqqqqqqqqqqk'(155)'13;60Hx'(155)'5C'(15)''(155)'1mHot Keys:'
(155)'0m'(14)''(155)'3Cx'(155)'14;60Hx'(155)'17Cx'(155)'15;60Hx'(15)''(155)
'6C[H]elp'(14)''(155)'5Cx'(155)'16;60Hx  '(15)'[E]xit  [Q]uit '(14)'x'(155)
'17;60Hx'(15)''(155)'4C[SpaceBar]'(14)''(155)'3Cx'(155)'18;60Hx   '(15)
'[Arrow Keys]'(14)''(155)'2Cx'(155)'19;60Hx  '(15)'[Prev Screen]  '(14)'x'
(155)'20;60Hx  '(15)'[Next Screen]  '(14)'x'(155)'21;60Hx'(15)
'[R]ead Font File '(14)'x'(155)'22;60Hx'(15)'[W]rite Font File'(14)'x'(155)
'23;60Hmqqqqqqqqqqqqqqqqqj'(15))
END;
(*****************************************************************************)
PROCEDURE ENV;
BEGIN	WRITE(OU,''(155)'2J'); ENVS	END;
(*****************************************************************************)
PROCEDURE READ_CONFIG(VAR NAME: FILE_NAME; VAR NUM,EXT: INTEGER);
LABEL	1,2,3;
BEGIN
NUM:=1; EXT:=0;
1: CASE T^ OF
''(0),''(9),''(10),''(13),' ':	GOTO 2;
'!'..'-','/'..'~':
	BEGIN
	NAME[NUM]:=T^; NUM:=NUM+1;
	IF EXT>0 THEN
		IF NUM<18 THEN	EXT:=EXT+1	ELSE	GOTO 3
	ELSE	IF NUM>14	THEN	GOTO 2
	END;
'.':	BEGIN
	NAME[NUM]:='.'; NUM:=NUM+1; EXT:=1;
	IF NUM>14 THEN	GOTO 2
	END;
OTHERWISE;
END;
GET(T); GOTO 1;
2: AUX(NAME,NUM,EXT);
3: READLN(T)
END;
(*****************************************************************************)
[ASYNCHRONOUS] PROCEDURE AST;
VAR	MSG:	PACKED ARRAY [1..80] OF CHAR;
BEGIN
SMG$GET_BROADCAST_MESSAGE(PASTEBOARD,MSG);
WRITELN(OU,''(155)'24;1H'(155)'M'(15),MSG,''(155),UDEC(NL+6*K+7,2,2),';',
UDEC(4+NR+11*(N-M),2,2),'H'(14))
END;
(*****************************************************************************)
PROCEDURE UPD(X: CHAR; Y: INTEGER);
BEGIN
S[N,K][NR]:=CHR(ORD(S[N,K][NR])+Y);
WRITELN(OU,X,''(8)''(144)';',UDEC(N,2,2),';1;4{ @',S[N,0],'/',S[N,1],''(156))
END;
(*****************************************************************************)
PROCEDURE BOXES(X,Y: INTEGER);
VAR I,J,R:	INTEGER;
BEGIN
FOR J:=0 TO X DO
  BEGIN
  FOR I:=M TO 4+M DO
    BEGIN
    WRITE(OU,' x');
    FOR R:=1 TO 8 DO
IF ODD((ORD(S[I,Y][R])-63) DIV L[J]) THEN WRITE(OU,'a') ELSE WRITE(OU,'~');
    WRITE(OU,'x')
    END;
  WRITE(OU,''(13)''(10)'  ')
  END
END;
(*****************************************************************************)
BEGIN
$ASSIGN('TT:',TT);
LIB$GETJPI(JPI$_IMAGNAME,,,,FILE_HELP);
WHILE FILE_HELP[I]<>']' DO BEGIN FILE_HELP[I]:=''(0); I:=I-1 END;
FILE_HELP[I+1]:='F'; FILE_HELP[I+2]:='O'; FILE_HELP[I+3]:='N';
FILE_HELP[I+4]:='T'; FILE_HELP[I+5]:='.'; FILE_HELP[I+6]:='H';
FILE_HELP[I+7]:='L'; FILE_HELP[I+8]:='B';
OPEN(OU,'TT:',RECORD_LENGTH:=6000,CARRIAGE_CONTROL:=NONE); REWRITE(OU);
OPEN(T,'VT240.CFG',HISTORY:=OLD,ERROR:=CONTINUE);
IF STATUS(T)=0	THEN
	BEGIN
	RESET(T);
	READ_CONFIG(FILE_INPUT,NI,EI);	READ_CONFIG(FILE_OUTPUT,NO,EO);
	READLN(T,N,NL,NR); M:=5*(N DIV 5);
	CLOSE(T)
	END
ELSE	BEGIN
	WRITELN(OU,'Error reading start-up file <'(155)'7mVT240.CFG'(155)'0m>'
	(13)''(10)'Using default values...'); LIB$WAIT(4.0)
	END;
SMG$CREATE_VIRTUAL_KEYBOARD(KEYBOARD);
SMG$CREATE_PASTEBOARD(PASTEBOARD);
SMG$CREATE_VIRTUAL_DISPLAY(24,80,DIS);
SMG$PASTE_VIRTUAL_DISPLAY(DIS,PASTEBOARD,1,1);
SMG$SET_BROADCAST_TRAPPING(PASTEBOARD,AST);
WRITELN(OU,''(27)'[?25l'(155)'2J'(155)'4l'(144)';;2{ @'(156)''(155)'8;20H'
(155)'1;7m'(27)')0'(14)'lqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqk'(155)'9;20Hx'
(155)'40Cx'(155)'10;20Hx'(155)'5C'(155)'0m'(15)'Baby Font Designer for VAX/VMS'
(14)''(155)'5C'(155)'1;7mx'(155)'11;20Hx'(155)'40Cx'(155)'12;20Hx'(155)'15C'
(15)''(155)'0m2.8 Version'(155)'14C'(14)''(155)'1;7mx'(155)'13;20Hx'(155)
'40Cx'(155)'14;20Hx'(155)'3C'(15)''(155)'0mCopyright S.A.Viznyuk (C) July 1992'
(155)'2C'(14)''(155)'1;7mx'(155)'15;20Hx'(155)'40Cx'(155)
'16;20Hmqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqj'(155)'0m'(15));
INPUT_FILE; ENV; 

1: WRITELN(OU,''(155)'24;1HReading Font File...'(27)'[?25h'(144)';1;;4{ @');
FOR I:=1 TO 29 DO	GET(T);
FOR I:=1 TO 94 DO
	FOR J:=0 TO 1 DO
		BEGIN
		READ(T,S[I,J]); WRITE(OU,S[I,J]); WRITE(OU,T^); GET(T)
		END;
CLOSE(T);
WRITE(OU,''(155)'M'(27)'* @'(27)'}');

2: WRITE(OU,''(27)'[?23l'(155)'5;6H'(15)''(155)'7m',C[1+M],
''(155)'0m -> '(155)'7m',CHR(160+M),''(155)'5C',C[2+M],
''(155)'0m -> '(155)'7m',CHR(161+M),''(155)'5C',C[3+M],
''(155)'0m -> '(155)'7m',CHR(162+M),''(155)'5C',C[4+M],
''(155)'0m -> '(155)'7m',CHR(163+M),''(155)'5C',C[5+M],
''(155)'0m -> '(155)'7m',CHR(164+M),''(155)'0m'(14)''(155)
'6;4Hlqqqqqqqqk lqqqqqqqqk lqqqqqqqqk lqqqqqqqqk lqqqqqqqqk'(13)''(10)'  ');
BOXES(5,0); BOXES(3,1);
WRITELN(OU,' mqqqqqqqqj mqqqqqqqqj mqqqqqqqqj mqqqqqqqqj mqqqqqqqqj'(27)'[?25h');

3: WRITELN(OU,''(155),UDEC(NL+6*K+7,2,2),';',UDEC(4+NR+11*(N-M),2,2),'H');
4: $QIOW(,TT,MODE,,,,W,1);
CASE W OF
' ':	IF ODD((ORD(S[N,K][NR])-63) DIV L[NL]) THEN
		UPD('~',-L[NL])
	ELSE	UPD('a',L[NL]);
''(27):	BEGIN
	$QIOW(,TT,MODE,,,,W,1);
	IF W<>'[' THEN	BEGIN	WRITELN(OU,''(7)); GOTO 4	END;
	$QIOW(,TT,MODE,,,,W,1);
	CASE W OF
	'A':	CASE NL OF
		0:	IF K=0	THEN	WRITELN(OU,''(7))
			ELSE	BEGIN
				WRITELN(OU,''(155)'A'); NL:=5; K:=0
				END;
		1..5:	BEGIN	WRITELN(OU,''(155)'A'); NL:=NL-1	END;
		END;
	'B':	CASE NL OF
		0..2,4:	BEGIN	WRITELN(OU,''(10)); NL:=NL+1	END;
		3:	IF K=1	THEN	WRITELN(OU,''(7))
			ELSE	BEGIN	WRITELN(OU,''(10)); NL:=4	END;
		5:	BEGIN	WRITELN(OU,''(10)); NL:=0; K:=1	END;
		END;
	'C':	IF NR<8 THEN	BEGIN WRITELN(OU,''(155)'C'); NR:=NR+1	END
		ELSE	IF N-M<4 THEN
			BEGIN	N:=N+1; NR:=1; WRITELN(OU,''(155)'4C')	END
			ELSE	WRITELN(OU,''(7)); 
	'D':	IF NR>1	THEN	BEGIN WRITELN(OU,''(155)'D'); NR:=NR-1	END
		ELSE	IF N>M	THEN
			BEGIN	N:=N-1; NR:=8; WRITELN(OU,''(155)'4D')	END
			ELSE	WRITELN(OU,''(7));
	'2':	BEGIN
		$QIOW(,TT,MODE,,,,W,1);
		IF W<>'8' THEN	BEGIN	WRITELN(OU,''(7)); GOTO 4	END;
		$QIOW(,TT,MODE,,,,W,1);
		IF W<>'~' THEN	BEGIN	WRITELN(OU,''(7)); GOTO 4	END;
		WRITELN(OU,''(155)'2J'(15));
		SMG$PUT_HELP_TEXT(DIS,KEYBOARD); ENV; GOTO 2
		END;
	'5':	BEGIN
		$QIOW(,TT,MODE,,,,W,1);
		IF W<>'~' THEN	BEGIN	WRITELN(OU,''(7)); GOTO 4	END;
                IF M>2	THEN	BEGIN	M:=M-5; N:=N-5; GOTO 2	END
		ELSE	WRITELN(OU,''(7))
		END;
	'6':	BEGIN
		$QIOW(,TT,MODE,,,,W,1);
		IF W<>'~' THEN	BEGIN	WRITELN(OU,''(7)); GOTO 4	END;
		IF M<90	THEN	BEGIN	M:=M+5; N:=N+5; GOTO 2	END
		ELSE	WRITELN(OU,''(7))
		END;
	OTHERWISE	WRITELN(OU,''(7));
	END
	END;
'E','e':BEGIN
	WRITELN(OU,''(15)''(155)'24;1H'(155)'MExit ? ');
	$QIOW(,TT,MODE,,,,W,1);
        IF W IN ['Y','y'] THEN	GOTO 5
	ELSE	BEGIN	WRITE(OU,''(155)'M'(7)''(14));	GOTO 3	END
	END;
'Q','q':BEGIN
	WRITELN(OU,''(15)''(155)'24;1H'(155)'MQuit ? ');
	$QIOW(,TT,MODE,,,,W,1);
        IF W IN ['Y','y'] THEN	GOTO 6
	ELSE	BEGIN	WRITE(OU,''(155)'M'(7)''(14));	GOTO 3	END
	END;
'W','w':BEGIN	OUT; ENVS; WRITE(OU,''(14)''(27)'[?25h'); GOTO 3	END;
'R','r':BEGIN
	WRITELN(OU,''(15)''(155)'24;1H'(155)'MSave the Current File ? ');
	$QIOW(,TT,MODE,,,,W,1);
        IF NOT (W IN ['N','n']) THEN	OUT;
	INPUT_FILE; ENVS; GOTO 1
	END;
''(18):	BEGIN	ENV; GOTO 2	END;
'0'..'9':BEGIN
	WRITELN(OU,''(15)''(155)'24;1H'(155)'MCharacter '(155)'7m#'); I:=0;
	REPEAT
	IF W IN ['0'..'9'] THEN
		BEGIN	WRITELN(OU,W); I:=10*I+ORD(W)-48	END
	ELSE	WRITELN(OU,''(7));
	$QIOW(,TT,MODE,,,,W,1)
	UNTIL W IN [''(10),''(13)];
	WRITE(OU,''(155)'0m'(155)'M'(14));
	IF I IN [32..126] THEN	BEGIN	N:=I-32; M:=5*(N DIV 5); GOTO 2	END
	ELSE	BEGIN	WRITE(OU,''(7));	GOTO 3	END
	END;	
'H','h':BEGIN
	WRITELN(OU,''(155)'2J'(15));
	SMG$PUT_HELP_TEXT(DIS,KEYBOARD,,FILE_HELP); ENV; GOTO 2
	END;
OTHERWISE	WRITELN(OU,''(7));
END;
GOTO 4;
5: OUT; ENVS; WRITE(OU,''(10)''(27)'[?25h');
6: WRITE(OU,''(155)'M'(155)'A'); SMG$DISABLE_BROADCAST_TRAPPING(PASTEBOARD)
END.
