Таблица 7.
const	HIMEM:lnteger=$75FF;	(Верхняя граница области) 
				(пользователя в ОЗУ "Радио-86РК.)
	EDBUF:integer=$1900;	( Начальный адрес буфера текста) 
				(редактора ED.МИКРОН.) 
var 	В,COUT,L,H,N,D1,D2,D3,D4:byte;
	А0,ADR,ADRBEG,ADREND,ER,I,I1,J,J1,CCTR:Integer; 
	LCTR,LC,SL,SH,CSUM:Integer; 
	LINE,SNAME:string[64]; 
	С,C1,C2:char;
	INTD,ENDBLK:boolean;
	T:text; 
	BUF:array[1.. $7600] of byte;
procedure HEXBYTE(B:byte);
	function HEXCHAR(B:byte):char;
	var B1: byte;
	begin
		B1:=B AND $F;IF B1>9 THEN B1:=B1+7; 
		HEXCHAR:=CHR(B1+48);
	end; 
	begin
		WRITE(HEXCHAR(B shr 4)); 
		WRITE(HEXCHAR(B)); 
	end;
procedure HEXINT(I:integer);
begin 	HEXBYTE(HI(I)); 
	HEXBYTE(LO(I)) 
end;
function YES: boolean; 
var C: char; 
begin
	WRITE(' (Д/Н) ? ');
	repeat READ(KBD,C)
	until С in ['Y', 'y', 'N', 'n', 'Д', 'д', 'H', 'н');
	WRITELN(C);YES:=(C in ['Y', 'y','Д','д')); 
end;
procedure START; 
	procedure INIT(K:byte);
	(приводится описание процедуры настройки порта СОM1) 
	(ЕС-1640. Об изменениях в процедуре для компьютеров) 
	(других типов см. в тексте статьи. при выводе через) 
	(параллельный порт процедура INIT и ее вызов исключаются) 
	(из программы.                                     )
const	H1:real=2.16; 
	КЗ:real=6.61; 
	S9600:integer=8; 
	CTRL:lnteger=$3FC; 
	CW53:lnteger=$3FB; 
	CTR:integer=$3F8; 
	CW51:lnteger=$3F9; 
	DАТ51:integer=$3F8; 
	TMODE:byte=$36; 
var 	S:integer; 
begin
	PORT[CTRL]:=$88; 
	PORT[CW33]:=TMODE; 
	S:=ROUND(S9600*(K*N1+N2)); 
	PORT[CTR]:=LO(S); 
	PORT[CTR]:=HI(S); 
	PORT[CTRL]:=$48; 
	PORT[CTRL]:=8; 
	PORT[CW51]:=$OC; 
	PORT[CW51]:=0; 
	PORT[CW51]:=0; 
	PORT[CW51]:=$27; 
end; 
begin
	WIHDOW(1,18,80,25);GOTOXY(13,1);
	WRITE('Подготовьте магнитофон к записи '); 
	WRITELN('и нажмите любую клавишу. '); 
	repeat until keypressed;
	INIT($1D); 		( Только для последоват. интерфейса. )
	WRITE(' Идет запись... ');
end;
procedure OUTMAG(B:byte);
	(Процедура OUTMAG должна соответствовать используемому) 
	(интерфейсу (см. табл.1 и 2 в тексте статьи). приводится) 
	(описание процедуры вывода байта через последовательный) 
	(порт СОM1 ЕС-1840.                                    )
const	phm: array[0.. 15] of integer;
		($55,$99,$65,$А5,$59,$99,$69,$А9,
		$56,$96,$65,$А6,$5А,$9А,$6А,$АА); 
procedure SEND(C:byte);
const	CW51:lnteger=$3F9;
	DAT5l:lnteger=$3F8; 
begin
	repeat until(PORT[CW51] and 1)<>0;
	PORT[DAT51]:=C; 
end;
begin
	SEND(PHM[(B shr 4) and $0F]);
	SEND(PHM[B and $0F]);
end;
procedure QRX: 
begin
	WINDOW(1,18,80,25);CLRSCR:GOTOXV(35,3);
	WRITELN('Ждитe, читаю ',SNAME); 
end;
procedure LDBUF(C:char: var I,CCTR,CSUM:integer); 
const	LINELEN:integer=62;		( Максимальная длина строки )
					( редактора ED. МИКРОН) 
var	В:byte; 
begin 
	B:=ORD(C); 
	repeat
		BUF[I]:=B;CSUM:=CSUM+B;I:=I+1; 
		If B=$0D then CCTR:=0 else CCTR:=CCTR+1; 
		B:=$0D; 
	until CCTR<LINELEN;
end;
function TRANSTEXT (C:char;D1,D2,D3,D4:byte):char;
var	J:byte;
begin
	J:=POS(C,'@ABCDEFGHIJKLMHOPQRSTUVWXYZ[\1'); 
	If J<>0 then TRANSTEXT:=CHR(J+D1) 
	else begin
		J:=POS(C,'•abcdefghljklmnopqrstuvwxyz{|}" '); 
		If J<>0 then TRANSTEXT:=CHR(J+D2) 
		else begin
			J:=POS(C,'юабпдефгхийклмнопярстужвьызшэшчь'); 
			If J<>0 then TRANSTEXT:=CHR(J+D3) 
			else begin
				J:=POS(C,'ЮАБЦДЕФГХИИКЛ1ШОПЯРСТУЖВЬЫЭЖЭШЧЪ'); 
				If J<>0 then TRANSTEXT:=CHR(J+D4) 
				else TRANSTEXT:='_' 
			end 
		end 
	end 
end;
procedure TRANSDUMP; 
begin 
	саse J1 of 
		1:A0:=M;
		2,3:A0:=(A0 shl 4)+H; 
		4:begin
			A0:=(A0 shl 4)+H; 
			If I=5 then begin 
				ADR:=А0; ADRBEG:=А0: 
				BUF[1]:=HI(ADRBEG);BUF12):=LO(ADRBEG) 
			end else If ADR<>A0 then begin
				ENDBLK:=true; ADREND:=ADR-1; I1:=I-1 
			end; 
		end: 
		5..255:if not ODD(J1) then begin
			BUF[I]:=(N shl 4)+M;I:=I+1;ADR:=ADR+1; 
		end else N:=M; 
	end 
end:
procedure TRANSHEX; 
begin
	case J1 of 
		1:L:=M;
		2:L:=(L shl 4)+H; 
		3:A0:=M;
		4,5: А0:=(А0 shl 4)+M; 
		6:begin
			A0:=(А0 shl 4)+M; 
			if I=5 then begin 
				ADR:=A0;ADRBEG:=A0;
				BUF[1]:=HI(ADRBEG);BUF[2]:=LO(ADRBEG) 
			end else if ADR<>A0 then begin
				ENDBLK:=true:ADREND:=ADR-1: I1:=I-1 
			end; 
		end; 
		7,8:;
		9..255:if not ODD(J1) then begin 
			if L>0 then begin
				BUF[I]:=(N shl 4>+M;I:=I+1;ADR:=ADR+1:L:=L-1 
				end
		end else N:=M; 
	end 
end:
procedure OUTBLOCK; 
begin
	CLRSCR;WIHDOW(41,11,80,17);CLRSCR;
	WRITELN;WRITELN;
	WRITE(' Начало блока : ') ;HEXINT(ADRBEG);
	WRITELN;
	WRITE(' Конец блока : ');HEXINT(ADREND);
	WRITELN;
	WRITE (' контр, сумма : ');
	SL:=0;SH:=0;
	for I:=5 to I1-1 do begin
		SL:=SL+BUF[I]; SH:=SH+BUF[I]+HI(SL); SL:=LO(SL) 
	end;
	SL:=LO(SL+BUF[I1]):BUF[I1+1]:=0;BUF[I1+2]:=0; 
	BUF[I1+3]:=$E0:BUF[I1+4]:=LO(SH);BUF[I1+5]:=LO(SL) 
	HEXBYTE(LO(SH)):HEXBYTE(LO(SL));WRITELN; 
	START:
	(Если используется параллельный интерфейс и необходимо) 
	(во время записи на магнитофон запретить прерывания,) 
	(здесь вставить оператор INLINE(*FA): )
	for I:=1 to 256 do OUTMAG(0);
	OUTMAG($E6);
	for I:=1 to I1+5 do OUTMAG(BUF[I]);
	( Если прерывания были запрещены, здесь разрешить их )
	( вновь, вставив оператор INLINE($FB);  )
	WRITE(' готово, повторить ') 
end;
function NEXTBLOCK:boolean; 
begin
	If EOF(T) or (ER>0) then NEXTBLOCK:=false 
	else begin
		CLKSCR;GOTOXY(6,3);
		WRITE('В Файле ',SNAME.' имеются еше данные.', 
			' продолжить вывод ');NEXTBLOCK:=YES 
	end 
end; 
begin
	CLRSCR;WINDOW(5,1,80,10);
	WRITELN(' r-ASD-90--------------------------------------------------|');
	WRITELN('                                          I');
	WRITELN('| Запись данных на магнитофон', 
		' в Формате РАДИО-86РК |'); 
	WRITELN('|');   
	WRITELN('------------------•------', '----------------------');
	WRITELN;
	WRITE('Имя Файла, содержашего данные : ');
	READLN(SNAME);ASSIGN(T,SNAME);RESET(Т);INTD:=false;
	WINDOW(1,11,80,25);
	WRITELN(' Тип данных :');
	WRITELN;
	WRITELN(' Текст. ................. 1');
	WRITELN(' Таблица кодов (dump).... 2'); 
	WRITELN(' НЕХ-ФаИЛ. .............. 3');
	WINDOW(1,18,80,25);CLRSCR;
	WRITELN(' Введите цифру, соответствующую'); 
	WRITE(' типу данных в Файле ',SNAME); 
	repeat READ(KBD,C) until С in ['1','2','3']; 
	CLRSCR;WIHDOW(34,0RD(C)-36,35,23);WRITE '+'); 
	саsе С of 
		'1':begin
			ER:=0;WINDOW(41,11,80,17);CLRSCR;
			WRITELN(' Преобразование текста :');
			WRITELN;
			WRITELN(' ABCdef АБВгде в ABCDEF АБВГДЕ. . . . 1');
			WRITELN(' ABCdef АБВгде в АВСДЕФ АБВГДЕ. . . . 2');
			WRITELN(' ABCdef АБВгде в ABCdef abwGDE. . . . 3');
			WRITELN(' ABCdef АБВгде в абцДЕФ АБВгде. . . . 4');
			WINDOW(1,18,80,25);
			WRITE('Введите цифру, соответствуютщую ');
			WRITE(' нужному преобразованию. ');
			repeat READ(KBD,C1) until C1 in ['1'..'4');
			CLRSCR;WINDOW(79,ORD(C1)-36,80,23);WRITE ('+');
			case C1 of
				'1':begin D1:=$3F;D2:=$3F;D3:=$5F;D4:=$5F end;
				'2':begin D1:=$3F;D2:=$5F;D3:=$5F;D4:=$5F end;
				'3':begin D1:=$3F;D2:=$5F:D3:=$3F;D4:=$5F end; 
				'4':begin D1:=$5F;D2:=$3F;D3:=$5F;D4:=$3F end; 
			end; 
			repeat
				QRX;I:=3;CCTR:=0;CSUM:=0;
				while not(EOF(T)or(I>HIMEM-EDBUF-*FF)) do
				begin
					READ(T,C);B:=ORD(C); 
					case В of
						$00..$08, $0B,$0C,$0E..$1F:
						LDBUF('.',I,CCTR,CSUM);
						$09:
						repeat LDBUF(' ',I,CCTR,CSUM)
						until (CCTR mod 8)=0;
						$0A:;
						$0D,$20..$3F: 
						LDBUF(C,I,CCTR,CSUM); 
						else
						LDBUF(TRANSTEXT(C,D1,D2,D3,D4),I,CCTR,CSUM);  
					end; 
				end:
				LDBUF(#$0D,I,CCTR,CSUM); BUF[I]:=$FF; 
				BUF[I+1]:=LO(CSUM);BUF[I+2]:=HI(CSUM); 
				I1:=I+2;I:=2-I;BUF[1]:=LO(I); BUF[2]:=HI(I); 
				repeat
					CLRSCR;START;
	(Ecли используется параллельный интерфейс и необхо-) 
	(димо во время записи на магнитофон запретить прерывания,) 
	(здесь вставить оператор INLINE(*FA); )
					for I:=1 to 64 do OUTMAG($55); 
					for I:=1 to 64 do OUTMAG(0); 
					for I:=1 to 64 do OUTHAG($55); 
					for I:=1 to 64 do OUTMAG(0); 
					for I:=1 to 5 do OUTMAG($E6); 
					for I:=1 to LENGTH(SNAME) do OUTMAG(ORD(SNAME[I]) and $7F); 
					for I:=1 to 512 do OUTMAG(0); OUTMAG($E6); 
					for I:=1 to I1 do OUTMAG(BUF[I]);
	(Если прерывания были запрещены, здесь разрешить их )
	(вновь, вставив оператор INLINE(*FB); )
					WRITE(' готово. Повторить '); 
				until not YES; 
			until not NEXTBLOCK: 
		end;
		'2','3':begin 
			LCTR:=0; 
			repeat
				ER:=0;ENDBLK:=false;I:=5;QRX;
				while not(EOF(T) or (I>HIMEM+4) or ENDBLK) do
				begin
					READLN(T,LINE); LCTR:=LCTR+1; 
					J1:=1;
					for J:=1 to LENGTH(LINE) do begin 
						C2:=LINE[J]: 
						саse C2 of
						' ':; 
						':':if C='2' then ER:=ER+1; 
						'0'..'9','A'..'F':begin 
							M:=ORD(C2)-$30;if M>9 then M:=M-7; 
							If C='2' then TRANSDUMP else TRANSHEX; 
							J1:=J1+1						
						end else ER:=ER+1; 
					end 
				end 
			end;
			if ER=0 then begin
				If not ENDBLK then begin
					ADREND:=ADR-1;I1:=I-1 
				end; 
				BUF[3]:=HI(ADREND);BUF[4]:=LO(ADREND); 
				repeat OUTBLOCK until not YES; 
			end else begin
				WINDOW(1,20,80,25);CLRSCR;GOTOXY(20, 3); 
				WRITE(' исправьте ошибк'); 
				if ER=1 then WRITE('у') else WRITE('и'); 
					WRITE(' в Файле ',SNAME); 
			end;
			if ENDBLK and (POS(':00',LINE)=0) then begin 
				RESET (T);LC:=LCTR;
				while LC>1 do begin READLN(T);LC:=LC-1 end; 
			end:
			until not NEXTBLOCK; 
		end; 
	end; 
end.