NYSIIS: Difference between revisions
tidy up task description, tidy up current implementation (conventionally, example goes after implementation) |
Thundergnat (talk | contribs) →{{header|Perl 6}}: Added a Perl 6 entry |
||
Line 193:
USER>Write code
MCLAGLAN
</pre>
=={{header|Perl 6}}==
This implementation removes common name suffixes similar to the reference implementation, even though it is not specified in the task description or on the linked [[wp:New York State Identification and Intelligence System|NYSIIS]] page. This algorithm isn't too friendly to certain French kings. :)
<lang perl6>
sub no_suffix ($name is copy) {
$name .= uc;
$name.subst( /\h (<[JS]>R) | (<[IVX]>+) $/, '' );
}
sub nysiis ($name is copy) {
$name .= uc;
$name.=subst( /<-[A..Z]>/, '', :g )\
.=subst( /^MAC/, 'MCC' )\
.=subst( /^P<[FH]>/, 'FF' )\
.=subst( /^SCH/, 'SSS' )\
.=subst( /^KN/, 'N' )\
.=subst( /<[IE]>E$/, 'Y' )\
.=subst( /<[DRN]>T$/, 'D' )\
.=subst( /<[RN]>D$/, 'D' );
my $first = substr-rw( $name, 0, 1 ) = '';
$name.=subst( /EV/, 'AF', :g )\
.=subst( /<[AEIOU]>+/, 'A', :g )\
.=subst( /Q/, 'G', :g )\
.=subst( /Z/, 'S', :g )\
.=subst( /M/, 'N', :g )\
.=subst( /KN/, 'N', :g )\
.=subst( /K/, 'C', :g )\
.=subst( /SCH/, 'S', :g )\
.=subst( /PF/, 'F', :g )\
.=subst( /K/ , 'C', :g )\
.=subst( /H(<-[AEIOU]>)/, -> $/ {$0}, :g );
$name = $first ~ $name;
$name.subst( /(<-[AEIOU]>)H/, -> $/ {$0}, :g )\
.subst( /(<[AEIOU]>)W/, -> $/ {$0}, :g )\
.subst( /AY$/, 'Y', :g )\
.subst( /S$/ , '' )\
.subst( /A$/ , '' )\
.subst( /(.)$0+/, -> $/ {$0}, :g );
}
my $nysiis;
printf "%10s, %s\n", $_,
( $nysiis = nysiis no_suffix $_ ).chars > 6
?? $nysiis.subst( / (.**6) /, -> $/ { $0 ~ '[' } ) ~ ']'
!! $nysiis
for (
"knight", "mitchell", "o'daniel", "brown sr", "browne III",
"browne IV", "O'Banion", "Mclaughlin", "McCormack", "Chapman",
"Silva", "McDonald", "Lawson", "Jacobs", "Greene",
"O'Brien", "Morrison", "Larson", "Willis", "Mackenzie",
"Carr", "Lawrence", "Matthews", "Richards", "Bishop",
"Franklin", "McDaniel", "Harper", "Lynch", "Watkins",
"Carlson", "Wheeler" , "Louis XVI"
);
</lang>
Output:
<pre>
knight, NAGT
mitchell, MATCAL
o'daniel, ODANAL
brown sr, BRAN
browne III, BRAN
browne IV, BRAN
O'Banion, OBANAN
Mclaughlin, MCLAGL[AN]
McCormack, MCARNA[C]
Chapman, CAPNAN
Silva, SALV
McDonald, MCDANA[LD]
Lawson, LASAN
Jacobs, JACAB
Greene, GRAN
O'Brien, OBRAN
Morrison, MARASA[N]
Larson, LARSAN
Willis, WAL
Mackenzie, MCANSY
Carr, CAR
Lawrence, LARANC
Matthews, MAT
Richards, RACARD
Bishop, BASAP
Franklin, FRANCL[AN]
McDaniel, MCDANA[L]
Harper, HARPAR
Lynch, LYNC
Watkins, WATCAN
Carlson, CARLSA[N]
Wheeler, WALAR
Louis XVI, L
</pre>
|
Revision as of 00:27, 20 March 2013
![Task](http://static.miraheze.org/rosettacodewiki/thumb/b/ba/Rcode-button-task-crushed.png/64px-Rcode-button-task-crushed.png)
You are encouraged to solve this task according to the task description, using any language you may know.
This page uses content from Wikipedia. The original article was at NYSIIS. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance) |
The New York State Identification and Intelligence System phonetic code, commonly known as NYSIIS, is a phonetic algorithm for creating indices for words based on their pronunciation. The goal is for homophones to be encoded to the same representation so that they can be matched despite minor differences in spelling.
- See also
Caché ObjectScript
<lang cache>Class Utils.Phonetic [ Abstract ] {
ClassMethod UnitTest() As %Status { // define test list Set testlist=$ListBuild( $ListBuild("knight", "NAGT"), $ListBuild("mitchell", "MATCAL"), $ListBuild("o'daniel", "ODANAL"), $ListBuild("brown sr", "BRAN"), $ListBuild("browne III", "BRAN"), $ListBuild("browne IV", "BRAN"), $ListBuild("O'Banion", "OBANAN"), $ListBuild("Mclaughlin", "MCLAGL[AN]"), $ListBuild("McCormack", "MCARNA[C]"), $ListBuild("Chapman", "CHAPNA[N]"), $ListBuild("Silva", "SALV"), $ListBuild("McDonald", "MCDANA[LD]"), $ListBuild("Lawson", "LASAN"), $ListBuild("Jacobs", "JACAB"), $ListBuild("Greene", "GRAN"), $ListBuild("O'Brien", "OBRAN"), $ListBuild("Morrison", "MARASA[N]"), $ListBuild("Larson", "LARSAN"), $ListBuild("Willis", "WAL"), $ListBuild("Mackenzie", "MCANSY"), $ListBuild("Carr", "CAR"), $ListBuild("Lawrence", "LARANC"), $ListBuild("Matthews", "MAT"), $ListBuild("Richards", "RACARD"), $ListBuild("Bishop", "BASAP"), $ListBuild("Franklin", "FRANCL[AN]"), $ListBuild("McDaniel", "MCDANA[L]"), $ListBuild("Harper", "HARPAR"), $ListBuild("Lynch", "LYNC"), $ListBuild("Watkins", "WATCAN"), $ListBuild("Carlson", "CARLSA[N]"), $ListBuild("Wheeler", "WHALAR") )
// order through test list Set ptr=0, sc=$$$ERROR($$$GeneralError, "No entries found.") While $ListNext(testlist, ptr, val) { Set sc=##class(Utils.Phonetic).Encode("nysiis", $List(val), .code,, 6) If $$$ISERR(sc) Quit If code'=$List(val, 2) Set sc=$$$ERROR($$$GeneralError, "Encoding did not match.") Quit }
// finished If $$$ISERR(sc) Quit sc Quit $$$OK }
ClassMethod Encode(pAlgorithm As %String = "", pName As %String = "", ByRef pCode As %String, pSuffixRem As %Boolean = 1, pTruncate As %Integer = 0) As %Status { // check algorithm Set pAlgorithm=$ZConvert(pAlgorithm, "l") If pAlgorithm="" Quit $$$ERROR($$$GeneralError, "No algorithm specified.") If $Case(pAlgorithm, "nysiis":1, :0)=0 Quit $$$ERROR($$$GeneralError, "Unknown algorithm specified.")
// check name If $Match(pName, ".*\d.*# no numbers") Quit $$$ERROR($$$GeneralError, "Name cannot contain numerics.")
// remove apostrophes Set pName=$Translate(pName, "'")
// find punctuation and replace with spaces (exclude hyphens) Set pun=$ZStrip(pName, "*E'P", "-") Set pName=$Translate(pName, pun, $Justify(" ", $Length(pun)))
// convert name(s) to uppercase and remove all white space Set pName=$ZStrip($ZConvert(pName, "U"), "<=>W")
// remove suffixes (e.g. 'Jnr', 'OBE', 'DSC', etc), including roman numerals (e.g. 'II', 'VIII') // - http://en.wikipedia.org/wiki/List_of_post-nominal_letters_(United_Kingdom) If pSuffixRem { Set ords=$ListBuild("KG", "LG", "KT", "LT", "GCB", "KCB", "DCB", "CB", "GCMG", "KCMG", "DCMG", "CMG", "DSO", "GCVO", "KCVO", "DCVO", "CVO", "LVO", "MVO", "OM", "ISO", "GBE", "KBE", "DBE", "CBE", "OBE", "MBE", "CH") Set decs=$ListBuild("VC", "GC", "CGC", "RRC", "DSC", "MC", "DFC", "AFC", "ARRC", "OBI", "IOM") Set regexp="( )(SNR$|SR$|JNR$|JR$|ESQ$|"_$ListToString(ords, "$|")_"$|"_$ListToString(decs, "$|")_"$|[IV]+$)" For { Set locn=$Locate(pName, regexp) If 'locn Quit Set pName=$Extract(pName, 1, locn-1) } }
// lastly replace hyphen with space Set pName=$ZStrip($Translate(pName, "-", " "), "<=>W")
// some final validation If $Length($Piece(pName, " "))<2 Quit $$$ERROR($$$GeneralError, "Invalid name.")
// begin algorithm Set pCode="" For piece=1:1:$Length(pName, " ") { If pAlgorithm="nysiis" Set pCode=pCode_..NYSIIS(pName) }
// truncate string, if necessary If pTruncate { Set pName=pCode Set pCode=$Extract(pCode, 1, pTruncate) Set $Extract(pName, 1, pTruncate)="" If $Length(pName) Set pCode=pCode_"["_pName_"]" }
// finished Quit $$$OK }
ClassMethod NYSIIS(pName As %String) As %String { /* New York State Identification and Intelligence System (NYSIIS) Phonetic Encoder - http://en.wikipedia.org/wiki/New_York_State_Identification_and_Intelligence_System - http://www.dropby.com/indexLF.html?content=/NYSIIS.html */
// translate first characters of name: // => MAC->MCC, KN->N, K->C, PH/PF->FF, SCH->SSS Set pName1=$Extract(pName, 1) Set pName2=$Extract(pName, 1, 2) Set pName3=$Extract(pName, 1, 3) If pName3="MAC" { Set $Extract(pName, 1, 3)="MCC" } ElseIf pName2="KN" { Set $Extract(pName, 1, 2)="N" } ElseIf pName1="K" { Set $Extract(pName, 1)="C" } ElseIf pName2="PH" { Set $Extract(pName, 1, 2)="FF" } ElseIf pName2="PF" { Set $Extract(pName, 1, 2)="FF" } ElseIf pName3="SCH" { Set $Extract(pName, 1, 3)="SSS" }
// translate last characters of name: // => EE/IE->Y, DT/RT/RD/NT/ND->D Set pNamexx=$Case($Extract(pName, *-1, *), "EE": "Y", "IE": "Y", "DT": "D", "RT": "D", "RD": "D", "NT": "D", "ND": "D", :"") If $Length(pNamexx) Set pName=$Extract(pName, 1, *-2)_pNamexx
// first character of key = first character of name Set pName1=$Extract(pName, 1) Set $Extract(pName, 1)=""
// translate remaining characters by following rules, incrementing by one character each time: // => EV->AF else A,E,I,O,U->A // => Q->G, Z->S, M->N // => KN->N else K->C // => SCH->SSS, PH->FF // => H->if previous or next is non-vowel, previous // => W->if previous is vowel, A (A is the only vowel left) // => add current to key if current is not same as the last key character Set pName=$Replace(pName, "EV", "AF") Set pName=$Translate(pName, "EIOU", "AAAA") Set pName=$Translate(pName, "QZM", "GSN") Set pName=$Replace(pName, "KN", "N") Set pName=$Translate(pName, "K", "C") Set pName=$Replace(pName, "SCH", "SSS") Set pName=$Replace(pName, "PH", "FF") Set locn=$Locate(pName, "H[^A]") If locn Set $Extract(pName, locn)="" Set locn=$Locate(pName, "[^A]H") If locn Set $Extract(pName, locn+1)="" Set pName=$Replace(pName, "AW", "A") Set pName=$ZStrip(pName,"=U") // remove duplicates
// if last character is S, remove it If $Extract(pName, *)="S" Set pName=$Extract(pName, 1, *-1)
// if last characters are AY, replace with Y If $Extract(pName, *-1, *)="AY" Set pName=$Extract(pName, 1, *-2)_"Y"
// if last character is A, remove it If $Extract(pName, *)="A" Set pName=$Extract(pName, 1, *-1)
// append translated key to removed first character Quit pName1_pName }
}</lang>
- Examples:
USER>Do ##class(Utils.Phonetic).Encode("nysiis", "Mclaughlin", .code) USER>Write code MCLAGLAN
Perl 6
This implementation removes common name suffixes similar to the reference implementation, even though it is not specified in the task description or on the linked NYSIIS page. This algorithm isn't too friendly to certain French kings. :)
<lang perl6> sub no_suffix ($name is copy) {
$name .= uc; $name.subst( /\h (<[JS]>R) | (<[IVX]>+) $/, );
}
sub nysiis ($name is copy) {
$name .= uc; $name.=subst( /<-[A..Z]>/, , :g )\ .=subst( /^MAC/, 'MCC' )\ .=subst( /^P<[FH]>/, 'FF' )\ .=subst( /^SCH/, 'SSS' )\ .=subst( /^KN/, 'N' )\ .=subst( /<[IE]>E$/, 'Y' )\ .=subst( /<[DRN]>T$/, 'D' )\ .=subst( /<[RN]>D$/, 'D' ); my $first = substr-rw( $name, 0, 1 ) = ; $name.=subst( /EV/, 'AF', :g )\ .=subst( /<[AEIOU]>+/, 'A', :g )\ .=subst( /Q/, 'G', :g )\ .=subst( /Z/, 'S', :g )\ .=subst( /M/, 'N', :g )\ .=subst( /KN/, 'N', :g )\ .=subst( /K/, 'C', :g )\ .=subst( /SCH/, 'S', :g )\ .=subst( /PF/, 'F', :g )\ .=subst( /K/ , 'C', :g )\ .=subst( /H(<-[AEIOU]>)/, -> $/ {$0}, :g ); $name = $first ~ $name; $name.subst( /(<-[AEIOU]>)H/, -> $/ {$0}, :g )\ .subst( /(<[AEIOU]>)W/, -> $/ {$0}, :g )\ .subst( /AY$/, 'Y', :g )\ .subst( /S$/ , )\ .subst( /A$/ , )\ .subst( /(.)$0+/, -> $/ {$0}, :g );
}
my $nysiis;
printf "%10s, %s\n", $_,
( $nysiis = nysiis no_suffix $_ ).chars > 6 ?? $nysiis.subst( / (.**6) /, -> $/ { $0 ~ '[' } ) ~ ']' !! $nysiis for ( "knight", "mitchell", "o'daniel", "brown sr", "browne III", "browne IV", "O'Banion", "Mclaughlin", "McCormack", "Chapman", "Silva", "McDonald", "Lawson", "Jacobs", "Greene", "O'Brien", "Morrison", "Larson", "Willis", "Mackenzie", "Carr", "Lawrence", "Matthews", "Richards", "Bishop", "Franklin", "McDaniel", "Harper", "Lynch", "Watkins", "Carlson", "Wheeler" , "Louis XVI" );
</lang>
Output:
knight, NAGT mitchell, MATCAL o'daniel, ODANAL brown sr, BRAN browne III, BRAN browne IV, BRAN O'Banion, OBANAN Mclaughlin, MCLAGL[AN] McCormack, MCARNA[C] Chapman, CAPNAN Silva, SALV McDonald, MCDANA[LD] Lawson, LASAN Jacobs, JACAB Greene, GRAN O'Brien, OBRAN Morrison, MARASA[N] Larson, LARSAN Willis, WAL Mackenzie, MCANSY Carr, CAR Lawrence, LARANC Matthews, MAT Richards, RACARD Bishop, BASAP Franklin, FRANCL[AN] McDaniel, MCDANA[L] Harper, HARPAR Lynch, LYNC Watkins, WATCAN Carlson, CARLSA[N] Wheeler, WALAR Louis XVI, L