MODULE translit; (* DEE 2015-03-02/2015-12-18 *)
  FROM ST IMPORT error, getarg, getc, putc;
  FROM STchars IMPORT CARET, ENDFILE, character;
  FROM STstrings IMPORT ENDSTR, MAXSTR, addstr, index, length, string;
  FROM TF IMPORT dodash;
  TYPE S = [0..MAXSTR];

  PROCEDURE makeset (VAR inset: string; k: INTEGER;
    VAR outset: string; maxset: INTEGER): BOOLEAN;
      VAR j: INTEGER;
  BEGIN j := 1;
    dodash(ENDSTR, inset, k, outset, j, maxset);
    RETURN addstr(ENDSTR, outset, j, maxset)
  END makeset;

  PROCEDURE xindex (VAR inset: string; c: character;
    allbut: BOOLEAN; lastto: INTEGER): INTEGER;
  BEGIN
    IF (c = ENDFILE) THEN
      RETURN 0
    ELSIF ~allbut THEN
      RETURN index(inset, c)
    ELSIF (index(inset, c) > 0) THEN
      RETURN 0
    ELSE
      RETURN lastto + 1
    END
  END xindex;

  PROCEDURE xlength(VAR s: string): S;
  BEGIN RETURN length(s)
  END xlength;

  PROCEDURE translit; (*Map characters*)
    CONST
      NEGATE = CARET; (* ^ *)
    VAR
      arg, fromset, toset: string;
      c: character;
      allbut, squash: BOOLEAN;
      i, lastto: S;
  BEGIN
    IF (NOT getarg(1, arg, MAXSTR)) THEN
      error('usage: translit [^]src [dest]')
    END;
    allbut := (arg[1] = NEGATE);
    IF (allbut) THEN
      i := 2
    ELSE
      i := 1
    END;
    IF (NOT makeset(arg, i, fromset, MAXSTR)) THEN
      error('translit: "from" set too large')
    END;

    IF (NOT getarg(2, arg, MAXSTR)) THEN
      toset[1] := ENDSTR
    ELSIF (NOT makeset(arg, 1, toset, MAXSTR)) THEN
      error('translit: "to" set too large')
    ELSIF (xlength(fromset) < xlength(toset)) THEN
      error('translit: "from" shorter than "to"')
    END;

    lastto := xlength(toset);
    squash := (xlength(fromset) > lastto) OR (allbut);
    REPEAT
      i := xindex(fromset, getc(c), allbut, lastto);
      IF (squash) AND (i >= lastto) AND (lastto > 0) THEN
        putc(toset[lastto]);
        REPEAT
          i := xindex(fromset, getc(c), allbut, lastto)
        UNTIL (i < lastto)
      END;
      IF (c # ENDFILE) THEN
        IF (i > 0) AND (lastto > 0) THEN (*translate*)
          putc(toset[i])
        ELSIF (i = 0) THEN
          putc(c) (*copy*)
        (*ELSE delete*)
        END
      END
    UNTIL (c = ENDFILE)
  END translit;

BEGIN (* main program *)
  translit
END translit.