Anonymous user
NYSIIS: Difference between revisions
m
→{{header|REXX}}: added/changed whitespace and comments, changed some comments in the REXX section header.
(→{{header|Tcl}}: Added zkl) |
m (→{{header|REXX}}: added/changed whitespace and comments, changed some comments in the REXX section header.) |
||
Line 600:
=={{header|REXX}}==
This REXX version allows a blank to be inserted into names by using an underscore or underbar character [ <big><big>'''_'''</big></big> ].
<br>Any title ending in a period is ignored as well as some Roman numeral titles. ▼
<br>An "extra" '''RETURN''' statement (at the end of the '''NYSIIS''' subroutine) was included to show how to restrict the key to six characters.▼
▲
<lang rexx>/*REXX program implements the NYSIIS phonetic algorithm for names. */▼
▲
names="Bishop brown_sr browne_III browne_IV Carlson Carr Chapman D'Souza de_Sousa Franklin",
"Greene Harper Hoyle-Johnson Jacobs knight Larson Lawrence Lawson Louis_XVI Lynch",
"Mackenzie Marshall,ESQ Matthews McCormack McDaniel McDonald Mclaughlin mitchell Morrison",
"O'Banion O'Brien o'daniel Richards Silva Vaughan_Williams Watkins Wheeler Willis Xavier,MD."
arg z; if z='' then z=names /*get optional name list
do i=1 for words(z) /*process each name (word) in the list.
xx=translate(word(z,i),,'_') /*reconstitute any blanks
say right(xx,30) ' ──► ' nysiis(xx)
end /*i*/
exit /*stick a fork in it, we're all done. */
/*────────────────────────────────────────────────────────────────────────────*/
nysiis: procedure; arg x; x=space(x); x=translate(x,,','); w=words(x)
lw=word(x,words(x)) /*pick off the last word in name list. */
titles = 'ESQ JNR JR SNR SR' /* [↓]
if w\==1 then if pos('IL',lw)==0 then /*disallow IL as Roman#.*/
if right(lw,1)=='.'
datatype(left(lw,1),'W') |,
verify(lw,'IVXL')==0
wordpos(x,titles)\==0 then x=subword(x,1,w-1)
x=space(x,0) /*remove all whitespace from the name. */
if left(x,3)=='MAC'
if left(x,2)=='KN'
if left(x,1)=='K'
if left(x,2)=='PH' | left(x,2)=='PF'
if left(x,3)=='SCH'
r2=right(x, 2)
if wordpos(r2,'EE IE') \==0
if wordpos(r2,'DT RT RD NT ND')\==0
key=left(x,1)
do j=2 to length(x); c2=substr(x,j,2); c=left(c2,1)
if \datatype(c,'Upper') then iterate /*Not a Latin
if c2=='EV' then x=overlay("F",x,j+1)
else x=overlay(translate(c,'AAAAGSN',"EIOUQZM"),x,j)
if c2=='KN' then x=left(x,j-1)"N"substr(x,j+1)
else if
c3=substr(x,j,3)
if c3=='SCH' then x=overlay("SSS",x,j)
c2=substr(x,j,2)
if c2=='PH' then x=overlay("FF",x,j)
c=substr(x,j,1); p=substr(x,j-1,1); n=substr(x,j+1,1)
if c=='H' then if \vowel(p) | \vowel(n) then x=overlay(p,x,j)
c=substr(x,j,1); p=substr(x,j-1,1)
if c=='W' then if vowel(p) then x=overlay("A",x,j)
c=substr(x,j,1)
if c\==right(key,1) then key=key || c
end /*j*/
if right(key,1)=='S' then key=left(key, max(1, length(key)-1))
if right(key,2)=='AY' then key=left(key, length(key)-2)"Y"
if right(key,1)=='A' then key=left(key, max(1, length(key)-1))
return strip(key) /*return the whole key. */
return strip(left(key, 6)) /*return leftmost six
/*────────────────────────────────────────────────────────────────────────────*/
vowel: return pos(arg(1), '
'''output''' when using the default input(s):
<pre>
| |||