{****************************************************************************}
{*                           > T E X T O P I A                              *}
{*    Eine Toolbox fuer die Programmierung von Textadventures in Pascal     *}
{*      Fuer Turbo Pascal ab 6.0, Free Pascal ab 0.99.10 und Delphi 4       *}
{*                 Geschrieben von Oliver Berse 1998-1999                   *}
{*                              Version 1.0                                 *}
{****************************************************************************}
{* TString liefert alle Stringfunktionen                                    *}
{****************************************************************************}
UNIT TSTRING;
{$DEFINE fpc}

{$IFNDEF fpc}
  {$B-} {$L-}
{$ENDIF}
  {$D-} {$I-} {$R-} {$S-} {$V-} {$X+}
{$IFDEF delphi}
  {$H-}
{$ENDIF}

INTERFACE
{$IFNDEF delphi}
  USES CRT,OBJECTS;
{$ELSE}
  USES DCRT;
{$ENDIF}

CONST
  {$IFNDEF fpc}       { Umlaute unter Dos/Windows }
  lae_kc   = #132;
  loe_kc   = #148;
  lue_kc   = #129;
  ss_kc    = #225;
  uae_kc   = #142;
  uoe_kc   = #153;
  uue_kc   = #154;
  {$ELSE}             { Umlaute unter Linux }
  lae_kc   = #228;
  loe_kc   = #246;
  lue_kc   = #252;
  ss_kc    = #223;
  uae_kc   = #196;
  uoe_kc   = #214;
  uue_kc   = #220;
{$ENDIF}
  maxbuf   = 10; { Max. Zwischenspeicher fuer Woerter }
  boolstr  : ARRAY[BOOLEAN] OF STRING = ('Nein','Ja  ');
  {
    Abkuerzungen fuer True/False
  }
  t  = TRUE;
  f  = FALSE;

TYPE
  TAdress = (du,sie,ihr);       { Anrede Spieler }
  TGender = (male,female);      { Geschlecht Spieler/in }
  TCasus  = (nom,acc,gen,dat);  { Grammatische Faelle }
  TBuffer = ARRAY[1..maxbuf] OF STRING;

FUNCTION  Adject(sub : STRING; casus : TCasus; def : BOOLEAN; num : BYTE) : STRING;
FUNCTION  CmpName(n1,n2 : STRING; adj : BOOLEAN) : BOOLEAN;
PROCEDURE DelStr(VAR str : STRING; sub : STRING);
FUNCTION  Ext(g : TGender) : STRING;
FUNCTION  GenChar(g : TGender) : CHAR;
FUNCTION  InterPron(str : STRING; c : TCasus) : STRING;
FUNCTION  LowCase(a : CHAR) : CHAR;
FUNCTION  Lower(s1 : STRING) : STRING;
FUNCTION  Noun(n1 : STRING; casus : TCasus; def : BOOLEAN; num : BYTE) : STRING;
FUNCTION  Numeral(n : BYTE) : STRING;
FUNCTION  NumToStr(n : WORD) : STRING;
FUNCTION  PerPron(adress : TAdress; casus : TCasus) : STRING;
FUNCTION  RandStr(line : STRING) : STRING;
PROCEDURE Separate(line : STRING; mark : CHAR; VAR buffer : TBuffer; VAR max : BYTE);
FUNCTION  ShortName(str : STRING; mode : BYTE) : STRING;
PROCEDURE SwpStr(VAR str : STRING; oldstr,newstr : STRING);
FUNCTION  UpChar(a : CHAR) : CHAR;
FUNCTION  Upper(s1 : STRING) : STRING;
FUNCTION  WithAdj(str,name : STRING; c : TCasus; def : BOOLEAN; n : BYTE) : STRING;
PROCEDURE WithUpcase(VAR line : STRING);

IMPLEMENTATION

PROCEDURE Separate(line : STRING; mark : CHAR; VAR buffer : TBuffer; VAR max : BYTE);
VAR
  i     : BYTE;
  quote : BOOLEAN;
BEGIN
  FILLCHAR(buffer,SIZEOF(buffer),#0);
  quote:=FALSE;
  IF line<>'' THEN
  BEGIN
    max:=1;
    FOR i:=1 TO LENGTH(line) DO
    BEGIN
      IF line[i]=#34 THEN quote:=NOT(quote);
      IF (line[i]<>mark) OR (quote) THEN buffer[max]:=buffer[max]+line[i]
                                    ELSE IF max<maxbuf THEN INC(max);
    END;
  END ELSE max:=0;
END;

FUNCTION UpChar(a : CHAR) : CHAR;
VAR
  b : CHAR;
BEGIN
  IF NOT(a IN [lae_kc,loe_kc,lue_kc]) THEN b:=UPCASE(a)
                                      ELSE BEGIN
                                             CASE a OF
                                               lae_kc : b:=uae_kc;
                                               loe_kc : b:=uoe_kc;
                                               lue_kc : b:=uue_kc;
                                             END;
                                           END;
  UpChar:=b;
END;

FUNCTION LowCase(a : CHAR) : CHAR;
VAR
  b : CHAR;
BEGIN
  IF a IN ['A'..'Z'] THEN b:=CHR(ORD(a)+32)
                     ELSE BEGIN
                            IF a IN [uae_kc,uoe_kc,uue_kc] THEN
                            BEGIN
                              CASE a OF
                                uae_kc : b:=lae_kc;
                                uoe_kc : b:=loe_kc;
                                uue_kc : b:=lue_kc;
                              END;
                            END ELSE b:=a;
                          END;
  LowCase:=b;
END;

FUNCTION Upper(s1 : STRING) : STRING;
VAR
  s2 : STRING;
  i  : BYTE;
BEGIN
  s2:='';
  FOR i:=1 TO LENGTH(s1) DO s2:=s2+UpChar(s1[i]);
  WHILE POS(ss_kc,s2)>0 DO
  BEGIN
    i:=POS(ss_kc,s2);
    DELETE(s2,i,1);
    INSERT('SS',s2,i);
  END;
  upper:=s2;
END;

FUNCTION Lower(s1 : STRING) : STRING;
VAR
  s2 : STRING;
  i  : BYTE;
BEGIN
  s2:='';
  FOR i:=1 TO LENGTH(s1) DO s2:=s2+LowCase(s1[i]);
  lower:=s2;
END;

PROCEDURE WithUpcase(VAR line : STRING);
VAR
  i : BYTE;
BEGIN
  line[1]:=UPCASE(line[1]);
  FOR i:=1 TO LENGTH(line) DO
  BEGIN
    IF (line[i] IN ['.','!','?']) AND (i+2<=LENGTH(line)) THEN line[i+2]:=UPCASE(line[i+2]);
  END;
END;

FUNCTION NumToStr(n : WORD) : STRING;
VAR
  s : STRING;
BEGIN
  STR(n,s);
  NumToStr:=s;
END;

FUNCTION Numeral(n : BYTE) : STRING;
VAR
  s : STRING;
BEGIN
  CASE n OF
    2 : s:='zwei';
    3 : s:='drei';
    4 : s:='vier';
    5 : s:='f'+lue_kc+'nf';
    6 : s:='sechs';
    7 : s:='sieben';
    8 : s:='acht';
    9 : s:='neun';
   10 : s:='zehn';
   ELSE s:='';
  END;
  Numeral:=s;
END;

{
  Vergleicht Objektnamen. Wenn in der Eingabe kein Adjektiv vorkommt,
  werden Substantive, die sich nur im Adjektiv unterscheiden nicht
  unterschieden
}

FUNCTION CmpName(n1,n2 : STRING; adj : BOOLEAN) : BOOLEAN;
VAR
  x1,x2 : BYTE;
BEGIN
  x1:=POS('*',n1);
  x2:=POS('*',n2);
  IF (NOT(adj)) AND (x1>0) AND (x2>0) THEN
  BEGIN
    DELETE(n1,1,x1+1);
    DELETE(n2,1,x2+1);
  END;
  CmpName:=n1=n2;
END;

FUNCTION Adject(sub : STRING; casus : TCasus; def : BOOLEAN; num : BYTE) : STRING;
VAR
  x   : BYTE;
  ext : STRING[3];
BEGIN
  x:=POS('*',sub);
  ext:='';
  IF num=1 THEN
  BEGIN
    IF def THEN
    BEGIN
      CASE casus OF
        nom : ext:='e';
        acc : IF sub[1]='+' THEN ext:='en'
                            ELSE ext:='e';
        gen : ext:='en';
        dat : ext:='en';
      END;
    END ELSE BEGIN
               CASE casus OF
                 nom : IF sub[1] IN ['+','-'] THEN
                       BEGIN
                         IF sub[1]='+' THEN ext:='er'
                                       ELSE ext:='e';
                       END ELSE ext:='es';
                 acc : IF sub[1] IN ['+','-'] THEN
                       BEGIN
                         IF sub[1]='+' THEN ext:='en'
                                       ELSE ext:='e';
                       END ELSE ext:='es';
                 gen : ext:='en';
                 dat : ext:='en';
               END;
             END;
  END ELSE IF def THEN ext:='en'
                  ELSE IF casus<>dat THEN ext:='e'
                                     ELSE ext:='en';
  DELETE(sub,x,1);
  INSERT(ext,sub,x);
  IF COPY(sub,x-1,2)='ee' THEN DELETE(sub,x,1);
  Adject:=sub;
END;

FUNCTION ShortName(str : STRING; mode : BYTE) : STRING;
BEGIN
  IF POS('*',str)>0 THEN str:=Adject(str,nom,f,1);
  IF POS(';',str)>0 THEN DELETE(str,POS(';',str),255);
  IF POS('#',str)>0 THEN DELETE(str,POS('#',str),255);
  IF POS('%',str)>0 THEN DELETE(str,POS('%',str),1);
  IF str[1] IN ['+','-','$'] THEN DELETE(str,1,1);
  CASE mode OF
    0 : ShortName:=str;
    1 : ShortName:=Lower(str);
    2 : ShortName:=Upper(str);
    ELSE Shortname:='';
  END;
END;

FUNCTION Noun(n1 : STRING; casus : TCasus; def : BOOLEAN; num : BYTE) : STRING;
CONST
  art : ARRAY[1..2,nom..dat,1..3] OF STRING[6]
      = ((('der ','die ','das '),('den ','die ','das '),
          ('des ','der ','des '),('dem ','der ','dem ')),
         (('ein ','eine ','ein '),('einen ','eine ','ein '),
          ('eines ','einer ','eines '),('einem ','einer ','einem ')));
VAR
  s,k   : BYTE;
  p1,p2 : CHAR;
  n2    : STRING;
BEGIN
  WHILE POS('*',n1)>0 DO n1:=Adject(n1,casus,def,num);
  IF POS(';',n1)>0 THEN DELETE(n1,POS(';',n1),255);
  IF n1[1]<>'$' THEN
  BEGIN
    IF num=1 THEN   { Singular }
    BEGIN
      IF POS('#',n1)>0 THEN DELETE(n1,POS('#',n1),255);
      IF POS('%',n1)>0 THEN DELETE(n1,POS('%',n1),1);
      IF n1[1] IN ['+','-'] THEN
      BEGIN
        IF n1[1]='+' THEN s:=1   { Maskulin }
                     ELSE s:=2;  { Feminin }
        DELETE(n1,1,1);
      END ELSE s:=3;             { Neutra }
      p1:=n1[LENGTH(n1)];
      p2:=n1[LENGTH(n1)-1];
      IF def THEN k:=1
             ELSE k:=2;
      CASE casus OF
        nom : n2:=art[k,casus,s]+n1;
        acc : IF s=1 THEN
              BEGIN
                CASE p1 OF
                  'e' : IF p2<>'i' THEN n1:=n1+'n';
                  'r' : IF POS(p2,'eo')=0 THEN n1:=n1+'en';
                  'h' : n1:=n1+'en';
                  't' : IF p2<>'i' THEN n1:=n1+'en';
                END;
                n2:=art[k,casus,s]+n1;
              END ELSE n2:=art[k,casus,s]+n1;
        gen : CASE s OF
                1 : BEGIN
                      CASE p1 OF
                        'n','b' : n1:=n1+'es';
                        'e'     : IF p2<>'i' THEN n1:=n1+'n';
                        'r'     : IF POS(p2,'eo')=0 THEN n1:=n1+'en'
                                                    ELSE n1:=n1+'s';
                        'h' : n1:=n1+'en';
                        't' : IF p2<>'i' THEN n1:=n1+'en'
                                         ELSE n1:=n1+'s';
                      END;
                      IF p1=n1[LENGTH(n1)] THEN n1:=n1+'s';
                      n2:=art[k,casus,s]+n1;
                    END;
                2 : n2:=art[k,casus,s]+n1;
                3 : BEGIN
                      IF POS(p1,'ms')=0 THEN n1:=n1+'s'
                                        ELSE n1:=n1+'es';
                      n2:=art[k,casus,s]+n1;
                    END;
              END;
        dat : BEGIN
                IF s=1 THEN
                BEGIN
                  CASE p1 OF
                    'e': IF p2<>'i' THEN n1:=n1+'n';
                    'r' : IF (p1='r') AND (POS(p2,'eo')=0) THEN n1:=n1+'en';
                    'h' : n1:=n1+'en';
                    't' : IF p2<>'i' THEN n1:=n1+'en';
                  END;
                END;
                n2:=art[k,casus,s]+n1;
              END;
      END;
    END ELSE BEGIN
               IF POS('#',n1)>0 THEN DELETE(n1,POS('#',n1),1);
               IF (NOT (n1[LENGTH(n1)] IN ['n','s'])) AND (casus=dat) THEN n1:=n1+'n';
               s:=POS('%',n1); { % markiert Vokalaenderung }
               IF s>0 THEN
               BEGIN
                 DELETE(n1,s,1);
                 CASE n1[s] OF
                   'a' : p1:=lae_kc;
                   'A' : p1:=uae_kc;
                   'u' : p1:=lue_kc;
                   'U' : p1:=uue_kc;
                   'o' : p1:=loe_kc;
                   'O' : p1:=uoe_kc;
                 END;
                 n1[s]:=p1;
               END;
               IF n1[1] IN ['+','-'] THEN DELETE(n1,1,1);
               IF def THEN
               BEGIN
                 CASE casus OF
                   nom : n2:='die';
                   acc : n2:='die';
                   gen : n2:='der';
                   dat : n2:='den';
                 END;
                 INSERT(n2+' ',n1,1);
               END;
               n2:=n1;
             END;
  END ELSE BEGIN              { Eigennamen }
             DELETE(n1,1,1);
             IF casus=gen THEN IF POS(n1[LENGTH(n1)],'sx'+ss_kc)>0 THEN n1:=n1+#39
                                                                   ELSE n1:=n1+'s';
             n2:=n1;
           END;
  Noun:=n2;
END;

FUNCTION InterPron(str : STRING; c : TCasus) : STRING;
CONST
  w : ARRAY[TCasus,1..3] OF STRING =
      ((('welcher'),('welche'),('welches')),
       (('welchen'),('welche'),('welches')),
       (('welches'),('welcher'),('welches')),
       (('welchem'),('welcher'),('welchem')));
VAR
  s : BYTE;
BEGIN
  CASE str[1] OF
    '+' : s:=1;
    '-' : s:=2;
    ELSE  s:=3;
  END;
  InterPron:=w[c,s];
END;

{
  Gibt einen Objektnamen dekliniert mit dem in str
  angegebenen Adjektiv zurueck. Ein bereits vorhandenes
  Adjektiv im Namen wird gel”scht.
}

FUNCTION WithAdj(str,name : STRING; c : TCasus; def : BOOLEAN; n : BYTE) : STRING;
VAR
  i : BYTE;
BEGIN
  IF POS('*',name)>0 THEN DELETE(name,1,POS('*',name)+1);
  IF name[1] IN ['+','-','$'] THEN i:=2
                              ELSE i:=1;
  INSERT(str+'* ',name,i);
  WithAdj:=Noun(name,c,def,n);
END;

{
  Gibt ein Personalpronomen fuer den Spieler abhaengig
  von der Anrede und dem Kasus zurueck
}

FUNCTION PerPron(adress : TAdress; casus : TCasus) : STRING;
CONST
  pp : ARRAY[TAdress,TCasus] OF STRING
     = ((('du'),('dich'),('deiner'),('dir')),
        (('Sie'),('sich'),('ihrer'),('Ihnen')),
        (('Ihr'),('Euch'),('Eurer'),('Euch')));
BEGIN
  PerPron:=pp[adress,casus];
END;

FUNCTION Ext(g : TGender) : STRING;
BEGIN
  IF g=female THEN ext:='in'
              ELSE ext:='';
END;

FUNCTION GenChar(g : TGender) : CHAR;
BEGIN
  IF g=male THEN GenChar:='+'
            ELSE GenChar:='-';
END;

FUNCTION RandStr(line : STRING) : STRING;
VAR
  buffer : TBuffer;
  i,max  : BYTE;
BEGIN
  Separate(line,';',buffer,max);
  i:=RANDOM(max)+1;
  RandStr:=buffer[i];
END;

{
  Tauscht in str alle oldstr gegen newstr
}
PROCEDURE SwpStr(VAR str : STRING; oldstr,newstr : STRING);
VAR
  i : BYTE;
BEGIN
  WHILE POS(oldstr,str)>0 DO
  BEGIN
    i:=POS(oldstr,str);
    DELETE(str,i,LENGTH(oldstr));
    INSERT(newstr,str,i);
  END;
END;

{
  Loescht einen Substring
}
PROCEDURE DelStr(VAR str : STRING; sub : STRING);
VAR
  i : BYTE;
BEGIN
  WHILE POS(sub,str)>0 DO
  BEGIN
    i:=POS(sub,str);
    DELETE(str,i,LENGTH(sub));
  END;
END;

BEGIN
END.
