i21sys/Mod/Cyrillic.odc

MODULE i21sysCyrillic;
(** This module is part of the educational versions of BlackBox 1.5 provided by the project "Informatika-21". 
It may be used together with i21sysCharacters. 
Or it can be used separately in the original BlackBox.
**)
(**
	project	= "Информатика-21 / Informatika-21"
	contributors	= "I.N.Goryachev, F.V.Tkachov"
	changes	= "
	- 20120423, F.V.Tkachov, derived from National by I.N.Goryachev.
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)
	
	CONST
		HostFontsCHARSET* = 1;

	CONST  uBase = 400H;  uRange = 100H;	

	VAR
		charSetName-: ARRAY 64 OF CHAR;
		ru1251, eastSlav1251, cyr1251: RECORD
			E, e, U, u: ARRAY 128 OF CHAR;
			name: ARRAY 64 OF CHAR;
		END;
	
	
	VAR
		ascii: ARRAY 256 OF RECORD
			isCap, isLetter, isFirstIdentChar, isIdentChar: BOOLEAN;
			cap, low, unicode: CHAR;
		END;
		
		unicode: ARRAY uRange OF RECORD
			isCap, isLetter: BOOLEAN;
			cap, low, ascii: CHAR;
		END;
		
	
	PROCEDURE IsCap* (ch: CHAR): BOOLEAN;
		VAR  res: BOOLEAN;  i: INTEGER;
	BEGIN
		IF  ORD(ch) < 256  THEN
			res := ascii[ORD(ch)].isCap
		ELSE
			i := ORD(ch) - uBase;
			IF  (0 <= i) & (i < uRange) THEN
				res := unicode[i].isCap
			ELSE
				res := FALSE
			END
		END;
		RETURN  res
	END IsCap;

	PROCEDURE IsDigit* (ch: CHAR): BOOLEAN;
	BEGIN
		RETURN ("0" <= ch) & (ch <= "9")
	END IsDigit;

	PROCEDURE IsLetter* (ch: CHAR): BOOLEAN;
		VAR  res: BOOLEAN;  i: INTEGER;
	BEGIN
		IF  ORD(ch) < 256  THEN
			res := ascii[ORD(ch)].isLetter
		ELSE
			i := ORD(ch) - uBase;
			IF  (0 <= i) & (i < uRange) THEN
				res := unicode[i].isLetter
			ELSE
				res := FALSE
			END
		END;
		RETURN  res
	END IsLetter;

	PROCEDURE IsFirstIdentChar* (ch: CHAR): BOOLEAN;
	BEGIN
		RETURN (ORD(ch) < 256) & ascii[ORD(ch)].isFirstIdentChar
	END IsFirstIdentChar;

	PROCEDURE IsIdentChar* (ch: CHAR): BOOLEAN;
	BEGIN
		RETURN (ORD(ch) < 256) & ascii[ORD(ch)].isIdentChar
	END IsIdentChar;

	
	PROCEDURE Cap* (ch: CHAR): CHAR;
		VAR  res: CHAR;  i: INTEGER;
	BEGIN
		IF  ORD(ch) < 256  THEN
			res := ascii[ORD(ch)].cap
		ELSE
			i := ORD(ch) - uBase;
			IF (0 <= i) & (i < uRange) THEN
				res := unicode[i].cap
			ELSE
				res := ch
			END
		END;
		RETURN  res
	END Cap;
	
	PROCEDURE Upper* (ch: CHAR): CHAR; (* as in Strings *)
	BEGIN  RETURN Cap(ch)
	END Upper;
	
	PROCEDURE Lower* (ch: CHAR): CHAR;  (* is used in Kernel *)
		VAR  res: CHAR;  i: INTEGER;
	BEGIN
		IF  ORD(ch) < 256  THEN
			res := ascii[ORD(ch)].low
		ELSE
			i := ORD(ch) - uBase;
			IF  (0 <= i) & (i < uRange) THEN
				res := unicode[i].low
			ELSE
				res := ch
			END
		END;
		RETURN  res
	END Lower;

	PROCEDURE UnicodeOf* (ch: CHAR): CHAR; (* unicode chars unaffected *)
		VAR  res: CHAR;
	BEGIN
		IF  ORD(ch) < 128  THEN
			res := ch
		ELSIF  ORD(ch) < 256 THEN
			res := ascii[ORD(ch)].unicode
		ELSE
			res := ch
		END;
		RETURN res
	END UnicodeOf;

	PROCEDURE ExtendedAsciiOf* (ch: CHAR): CHAR;
		VAR  res: CHAR;  i: INTEGER;
	BEGIN
		IF ORD(ch) < 256 THEN
			res := ch
		ELSE
			i := ORD(ch) - uBase;
			IF ( 0 <= i ) & ( i < uRange ) THEN
				res := unicode[i].ascii
			ELSE
				res := '?'
			END
		END;
		RETURN res
	END ExtendedAsciiOf;

	
	PROCEDURE ToUpper* (IN in: ARRAY OF CHAR;  OUT out: ARRAY OF CHAR);
		VAR  len, i: INTEGER;
	BEGIN
		len := LEN(in$);  i := 0;
		WHILE  i < len  DO  out[i] := Cap(in[i]);  INC(i)  END;
		out[i] := 0X
	END ToUpper;

	PROCEDURE ToLower* (IN in: ARRAY OF CHAR;  OUT out: ARRAY OF CHAR);
		VAR  len, i: INTEGER;
	BEGIN
		len := LEN(in$);  i := 0;
		WHILE  i < len  DO  out[i] := Lower(in[i]);  INC(i)  END;
		out[i] := 0X
	END ToLower;

	PROCEDURE ToUnicode* (IN in: ARRAY OF CHAR;  OUT out: ARRAY OF CHAR); (* used in (Host)Dialog *)
		VAR  len, i: INTEGER;
	BEGIN
		len := LEN(in$);  i := 0;
		WHILE  i < len  DO  out[i] := UnicodeOf(in[i]);  INC(i)  END;
		out[i] := 0X
	END ToUnicode;

	PROCEDURE ToExtendedAscii* (IN in: ARRAY OF CHAR;  OUT out: ARRAY OF CHAR);
		VAR  len, i: INTEGER;
	BEGIN
		len := LEN(in$);  i := 0;
		WHILE  i < len  DO  out[i] := ExtendedAsciiOf(in[i]);  INC(i)  END;
		out[i] := 0X
	END ToExtendedAscii;

	
	PROCEDURE Init;
		VAR  i: INTEGER;
	BEGIN
		(* Russian only *)
		ru1251.name := 'Russian subset of CP1251';
		ru1251.E := "АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ";
		ru1251.e := "абвгдежзийклмнопрстуфхцчшщъыьэюя";
		FOR i := 0 TO 31 DO
			ru1251.U[i] := CHR( 0410H + i );
			ru1251.u[i] := CHR( 0410H + 32 + i );
		END;
		
		(* CYRILLIC IO *)
		ru1251.E[i] := 0A8X;
		ru1251.e[i] := 0B8X;
		ru1251.U[i] := 0401X;
		ru1251.u[i] := 0451X;
		INC(i);

		ru1251.E[i] := 0X;
		ru1251.e[i] := 0X;
		ru1251.U[i] := 0X;
		ru1251.u[i] := 0X;

		(* East Slavic = Byelorussian + Russian + Ukrainian *)
		eastSlav1251 := ru1251;
		eastSlav1251.name := 'East Slavic subset of CP1251';
		
		i := LEN( eastSlav1251.U$ );
		
		(* CYRILLIC SHORT U *)
		eastSlav1251.E[i] := 0A1X;
		eastSlav1251.e[i] := 0A2X;
		eastSlav1251.U[i] := 040EX;
		eastSlav1251.u[i] := 045EX;
		INC(i);
		
		(* CYRILLIC BYELORUSSIAN-UKRAINIAN I *)
		eastSlav1251.E[i] := 0B2X;
		eastSlav1251.e[i] := 0B3X;
		eastSlav1251.U[i] := 0406X;
		eastSlav1251.u[i] := 0456X;
		INC(i);
		
		(* CYRILLIC UKRAINIAN IE *)
		eastSlav1251.E[i] := 0AAX;
		eastSlav1251.e[i] := 0BAX;
		eastSlav1251.U[i] := 0404X;
		eastSlav1251.u[i] := 0454X;
		INC(i);
		
		(* CYRILLIC YI *)
		eastSlav1251.E[i] := 0AFX;
		eastSlav1251.e[i] := 0BFX;
		eastSlav1251.U[i] := 0407X;
		eastSlav1251.u[i] := 0457X;
		INC(i);
		
		(* CYRILLIC GHE WITH UPTURN *)
		eastSlav1251.E[i] := 0A5X;
		eastSlav1251.e[i] := 0B4X;
		eastSlav1251.U[i] := 0490X;
		eastSlav1251.u[i] := 0491X;
		INC(i);
		
		eastSlav1251.E[i] := 0X;
		eastSlav1251.e[i] := 0X;
		eastSlav1251.U[i] := 0X;
		eastSlav1251.u[i] := 0X;

		(* complete Cyrillic CP1251 *)
		cyr1251 := eastSlav1251;
		cyr1251.name := "Cyrillic CP1251";
		i := LEN( cyr1251.U$ );

		(* CYRILLIC DJE *)
		cyr1251.E[i] := 080X;
		cyr1251.e[i] := 090X;
		cyr1251.U[i] := 0402X;
		cyr1251.u[i] := 0452X;
		INC(i);

		(* CYRILLIC GJE *)
		cyr1251.E[i] := 081X;
		cyr1251.e[i] := 083X;
		cyr1251.U[i] := 0403X;
		cyr1251.u[i] := 0453X;
		INC(i);

		(* CYRILLIC LJE *)
		cyr1251.E[i] := 08AX;
		cyr1251.e[i] := 09AX;
		cyr1251.U[i] := 0409X;
		cyr1251.u[i] := 0459X;
		INC(i);

		(* CYRILLIC NJE *)
		cyr1251.E[i] := 08CX;
		cyr1251.e[i] := 09CX;
		cyr1251.U[i] := 040AX;
		cyr1251.u[i] := 045AX;
		INC(i);

		(* CYRILLIC KJE *)
		cyr1251.E[i] := 08DX;
		cyr1251.e[i] := 09DX;
		cyr1251.U[i] := 40CX;
		cyr1251.u[i] := 45CX;
		INC(i);

		(* CYRILLIC TSHE *)
		cyr1251.E[i] := 08EX;
		cyr1251.e[i] := 09EX;
		cyr1251.U[i] := 40BX;
		cyr1251.u[i] := 45BX;
		INC(i);

		(* CYRILLIC DZHE *)
		cyr1251.E[i] := 08FX;
		cyr1251.e[i] := 09FX;
		cyr1251.U[i] := 40FX;
		cyr1251.u[i] := 45FX;
		INC(i);

		(* CYRILLIC JE *)
		cyr1251.E[i] := 0A3X;
		cyr1251.e[i] := 0BCX;
		cyr1251.U[i] := 408X;
		cyr1251.u[i] := 458X;
		INC(i);

		(* CYRILLIC DZE *)
		cyr1251.E[i] := 0BDX;
		cyr1251.e[i] := 0BEX;
		cyr1251.U[i] := 405X;
		cyr1251.u[i] := 455X;
		INC(i);

(*
		(* CYRILLIC  *)
		cyr1251.E[i] := ;
		cyr1251.e[i] := ;
		cyr1251.U[i] := ;
		cyr1251.u[i] := ;
		INC(i);

*)
		cyr1251.E[i] := 0X;
		cyr1251.e[i] := 0X;
		cyr1251.U[i] := 0X;
		cyr1251.u[i] := 0X;
	END Init;

	PROCEDURE Set ( IN E, e, U, u: ARRAY OF CHAR;  name: ARRAY OF CHAR );
		VAR  i, icap, ilow, j: INTEGER; 
	BEGIN
		ASSERT( (LEN(E$)=LEN(e$)) & (LEN(E$)=LEN(U$)) & (LEN(E$)=LEN(u$)), 20 );
		
		FOR i := 0 TO LEN(E$)-1 DO
			ASSERT( (128 <= ORD(E[i])) & (ORD(E[i]) < 256), 21 );  
			ASSERT( (128 <= ORD(e[i])) & (ORD(e[i]) < 256), 22 );  
			ASSERT( ORD(U[i]) >= 128, 23 ); (* not >=256  to allow for U=E, u=e, etc.*)
			ASSERT( ORD(u[i]) >= 128, 24 );
		END;
		
		charSetName := name$;
		
		FOR j := 0 TO 255 DO
			ascii[j].cap := CHR(j); (* self *)
			ascii[j].low := CHR(j);  (* self *) 
			ascii[j].isCap := FALSE;
			ascii[j].isLetter := FALSE;
			ascii[j].isFirstIdentChar := FALSE;
			ascii[j].isIdentChar := FALSE;
		END;

		j := ORD('_');  
			ascii[j].isFirstIdentChar := TRUE;  
			ascii[j].isIdentChar := TRUE;
		
		FOR j := ORD("0") TO ORD("9") DO  
			ascii[j].isIdentChar := TRUE  
		END;
		
		FOR icap := ORD("A") TO ORD("Z") DO  ilow := icap+32;
			ascii[icap].low := CHR(ilow);
			ascii[ilow].cap := CHR(icap);  
			ascii[icap].isCap := TRUE;
			ascii[icap].isLetter := TRUE;
			ascii[ilow].isLetter := TRUE;
			ascii[icap].isFirstIdentChar := TRUE;
			ascii[ilow].isFirstIdentChar := TRUE;
			ascii[icap].isIdentChar := TRUE;
			ascii[ilow].isIdentChar := TRUE;
		END;

		FOR i := 0 TO 255 DO
			ascii[i].unicode := CHR(i) (* self by default *)
		END;
		
		FOR i := 0 TO uRange-1 DO
			unicode[i].ascii := '?';
			unicode[i].cap := CHR(i + uBase); (* self by default *)
			unicode[i].low := CHR(i + uBase); (* self by default *)
			unicode[i].isCap := FALSE;
			unicode[i].isLetter := TRUE;
		END;
		
		FOR i := 0 TO LEN(E$)-1 DO
			ascii[ORD( E[i] )].isLetter := TRUE;
			ascii[ORD( e[i] )].isLetter := TRUE;
			ascii[ORD( E[i] )].isCap := TRUE;
			ascii[ORD( E[i] )].low := e[i];  
			ascii[ORD( e[i] )].cap := E[i];
			
			ascii[ORD( E[i] )].unicode := U[i]; 
			ascii[ORD( e[i] )].unicode := u[i]; 

			unicode[ORD(U [i]) - uBase].ascii := E[i];
			unicode[ORD(u [i]) - uBase].ascii := e[i];
			
			unicode[ORD(u [i]) - uBase].cap       := U [i];
			unicode[ORD(U [i]) - uBase].low       := u [i];
			unicode[ORD(U [i]) - uBase].isCap    := TRUE;
			unicode[ORD(U [i]) - uBase].isLetter := TRUE;
			unicode[ORD(u [i]) - uBase].isLetter := TRUE;
		END;
	
		FOR i := 128 TO 255 DO
			ascii[i].isFirstIdentChar := ascii[i].isLetter;
			ascii[i].isIdentChar        := ascii[i].isLetter;
		END; 
	END Set;
	

(*
	PROCEDURE Show ( IN cs: Charset );
	BEGIN
		Log.Ln;
		Log.String(cs.name);  Log.Ln;
		Log.String(cs.E);  Log.Ln;
		Log.String(cs.e);  Log.Ln;
		Log.String(cs.U);  Log.Ln;
		Log.String(cs.u);  Log.Ln;
	END Show;
	
	PROCEDURE Tests*;
		VAR  j: INTEGER;  ch: CHAR;
	BEGIN
		Show(Ru1251);
		Show(EastSlav1251);
(*
		Show(Cyr1251);
*)
		Log.Ln; 
		Log.String('active charset:');  Log.Ln;
		Log.Ln;
		Show(active);
		
		Log.String('Characters allowed in identifiers:');  Log.Ln;
		FOR j := 128 TO 255 DO
			ch := CHR(j);
			IF IsLetter( ch ) THEN
				Log.Char( ch );  Log.Char('-');
			END;
		END;
		
		FOR j := 0 TO 255 DO
			ch := CHR(j);
			ASSERT( ExtendedAsciiOf( UnicodeOf(ch) ) = ch )
		END;

		FOR j := uBase TO uBase + uRange - 1 DO
			ch := ExtendedAsciiOf( CHR(j) );
			ASSERT( (ch = '?') OR ( UnicodeOf(ch) = CHR(j) ) )
		END;
	END Tests;
*)	
BEGIN
	Init;
(*	Set( ru1251.E, ru1251.e, ru1251.U, ru1251.u, ru1251.name ); *)

	Set( eastSlav1251.E, eastSlav1251.e, eastSlav1251.U, eastSlav1251.u, eastSlav1251.name );

(*	Set( cyr1251.E, cyr1251.e, cyr1251.U, cyr1251.u, cyr1251.name ); *)
END i21sysCyrillic.

**************************************
**************************************
**************************************
**************************************
**************************************
**************************************



MODULE y;
	IMPORT  Log := StdLog,  In := i21sysIn,  Math,  i21sysCyrillics;
	
	PROCEDURE Do*;
		VAR  ch: CHAR;
	BEGIN
		ch := "ё";
		Log.Char( ch );

		ch := i21sysCyrillics.UnicodeOf( ch );
		Log.Char( ch );

		ch := i21sysCyrillics.Cap( ch );
		Log.Char( ch );
		
		(* сербская строчная буковка, при включенной поддержке вост-слав. букв должна давать Cap, равный себе: *)
		
		ch := CHR( 459H ); 
		Log.Char( ch );
		
		ch := i21sysCyrillics.Cap( ch );
		Log.Char( ch );
		
		Log.Ln;
		
	END Do;
	
END y.Do