home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / PASCAL / PT03.ZIP / TRANSLIT.AR < prev    next >
Encoding:
Text File  |  1983-09-01  |  3.4 KB  |  135 lines
  1. -h- dodash.tra 818
  2. { dodash - expand set at src[i] into dest[j], stop at delim }
  3. procedure dodash (delim : character; var src : string;
  4.   var i : integer; var dest : string;
  5.   var j : integer; maxset : integer);
  6. var
  7.  k : integer;
  8.  junk : boolean;
  9. begin
  10.  while (src[i] <> delim) and (src[i] <> ENDSTR) do begin
  11.   if (src[i] = ESCAPE) then
  12.    junk := addstr(esc(src, i), dest, j, maxset)
  13.   else if (src[i] <> DASH) then
  14.    junk := addstr(src[i], dest, j, maxset)
  15.   else if (j <= 1) or (src[i+1] = ENDSTR) then
  16.    junk := addstr(DASH,dest,j,maxset) { literal - }
  17.   else if (isalphanum(src[i-1]))
  18.     and (isalphanum(src[i+1]))
  19.     and (src[i-1] <= src[i+1]) then begin
  20.    for k := src[i-1]+1 to src[i+1] do
  21.     junk := addstr(k, dest, j, maxset);
  22.    i := i + 1
  23.   end
  24.   else
  25.    junk := addstr(DASH, dest, j, maxset);
  26.   i := i + 1
  27.  end
  28. end;
  29.  
  30. -h- makeset.tra 306
  31. { makeset -- make set from inset[k] in outset }
  32. function makeset (var inset : string; k : integer;
  33.   var outset : string; maxset : integer) : boolean;
  34. var
  35.  j : integer;
  36. {$include:'dodash.tra'}
  37. begin
  38.  j := 1;
  39.  dodash(ENDSTR, inset, k, outset, j, maxset);
  40.  makeset := addstr(ENDSTR, outset, j, maxset)
  41. end;
  42.  
  43. -h- translit.tra 1224
  44. { translit -- map characters }
  45. procedure translit;
  46. const
  47.  NEGATE = CARET; { ^ }
  48. var
  49.  arg, fromset, toset : string;
  50.  c : character;
  51.  i, lastto : 0..MAXSTR;
  52.  allbut, squash : boolean;
  53. {$include:'makeset.tra'}
  54. {$include:'xindex.tra' }
  55. begin
  56.  if (not getarg(1, arg, MAXSTR)) then
  57.   error('usage: translit from to');
  58.  allbut := (arg[1] = NEGATE);
  59.  if (allbut) then
  60.   i := 2
  61.  else
  62.   i := 1;
  63.  if (not makeset(arg, i, fromset, MAXSTR)) then
  64.   error('translit: "from" set too large');
  65.  if (not getarg(2, arg, MAXSTR)) then
  66.   toset[1] := ENDSTR
  67.  else if (not makeset(arg, 1, toset, MAXSTR)) then
  68.   error('translit: "to" set too large')
  69.  else if (length(fromset) < length(toset)) then
  70.   error('translit: "from" shorter than "to"');
  71.  
  72.  lastto := length(toset);
  73.  squash := (length(fromset) > lastto) or (allbut);
  74.  repeat
  75.   i := xindex(fromset, getc(c), allbut, lastto);
  76.   if (squash) and (i>=lastto) and (lastto>0) then begin
  77.    putc(toset[lastto]);
  78.    repeat
  79.     i := xindex(fromset, getc(c), allbut, lastto)
  80.    until (i < lastto)
  81.   end;
  82.   if (c <> ENDFILE) then begin
  83.    if (i > 0) and (lastto > 0) then  { translate }
  84.     putc(toset[i])
  85.    else if (i = 0) then  { copy }
  86.     putc(c)
  87.    { else delete }
  88.   end
  89.  until (c = ENDFILE)
  90. end;
  91.  
  92. -h- xindex.tra 335
  93. { xindex -- conditionally invert value from index }
  94. function xindex (var inset : string; c : character;
  95.   allbut : boolean; lastto : integer) : integer;
  96. begin
  97.  if (c = ENDFILE) then
  98.   xindex := 0
  99.  else if (not allbut) then
  100.   xindex := index(inset, c)
  101.  else if (index(inset, c) > 0) then
  102.   xindex := 0
  103.  else
  104.   xindex := lastto + 1
  105. end;
  106. -h- translit.pas 461
  107. {$debug-}
  108. program outer (input,output);
  109.  
  110. {$include:'globcons.inc'}
  111. {$include:'globtyps.inc'}
  112.  
  113. {$include:'initio.dcl'}
  114. {$include:'flush.dcl' }
  115.  
  116. {$include:'isalphan.dcl'}
  117. {$include:'error.dcl'   }
  118. {$include:'getc.dcl'    }
  119. {$include:'putc.dcl'    }
  120. {$include:'getarg.dcl'  }
  121. {$include:'length.dcl'  }
  122. {$include:'addstr.dcl'  }
  123. {$include:'index.dcl'   }
  124. {$include:'esc.dcl'     }
  125.  
  126. {$include:'translit.tra'   }
  127. BEGIN
  128.   minitio; initio;
  129.   translit;
  130.   flush(0);
  131. END.
  132. -h- translit.mak 98
  133. translit+initio+getfcb+error+getarg+nargs+length+isalphan+
  134. getc+putc+addstr+index+esc+flush+putcf
  135.