(* CODING.PAS -- translate GEOS characters to IBM code page 437
** Copyright (c) 1995,1996 Jochen Metzinger
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2, or (at your option)
** any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

UNIT Coding;

INTERFACE

USES global;

TYPE CODE_TYPE = (uk_coding, ge_coding);

FUNCTION default_code: CODE_TYPE;
(* value of default coding style *)

FUNCTION country: STRING;
(* name of this style *)

PROCEDURE SetCoding(code: CODE_TYPE);
(* set coding style CODE *)

FUNCTION TransStr(s: STRING): STRING;
(* Translate S in a PC string *)

FUNCTION TransChr(ch: CHAR): STRING;
(* Translate CH in a PC string *)

IMPLEMENTATION

CONST
 CodeTable: ARRAY [CODE_TYPE, ' '..'~'] OF CHAR =
  ((* uk_coding: english *)
   (' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',
    '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
    '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
    'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',
    '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
    'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~'),
   (* ge_coding: german *)
   (' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',
    '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
    '','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
    'P','Q','R','S','T','U','V','W','X','Y','Z','�','�','�','^','_',
    '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
    'p','q','r','s','t','u','v','w','x','y','z','�','�','�','�'));

VAR used_code: CODE_TYPE;

FUNCTION default_code: CODE_TYPE;
BEGIN
 (*$IFNDEF GERMAN*)
  default_code := uk_coding;
 (*$ELSE*)
  default_code := ge_coding;
 (*$ENDIF*)
END; (* default_code *)

FUNCTION country: STRING;
BEGIN
 (*$IFNDEF GERMAN*)
  country := 'uk';
 (*$ELSE*)
  country := 'ge';
 (*$ENDIF*)
END; (* country *)

PROCEDURE SetCoding(code: CODE_TYPE);
BEGIN
 used_code := code;
END; (* SetCoding *)

FUNCTION TransChr(ch: CHAR): STRING;
BEGIN
 IF ch < ' ' THEN
  TransChr := '^^' + CHR(ORD(ch)+64)
 ELSE IF ch <= '~' THEN
  TransChr := CodeTable[used_code,ch]
 ELSE IF ch = #$79 THEN
  TransChr := '{C=}'
 ELSE
  TransChr := '{'+long2str(ORD(ch),2)+'}';
END; (* TransChr *)

FUNCTION TransStr(s: STRING): STRING;
 VAR i: INTEGER; r: STRING;
BEGIN
 r := '';
 FOR i := 1 TO Length(s) DO
  r := r + TransChr(s[i]);
 TransStr := r;
END; (* TransStr *)

BEGIN
 used_code := default_code;
END. (* coding *)