aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

48
Task/Soundex/MUMPS/soundex.mumps Normal file
View file

@ -0,0 +1,48 @@
SOUNDEX(X,NARA=0)
;Converts a string to its Soundex value.
;Empty strings return "0000". Non-alphabetic ASCII characters are ignored.
;X is the name to be converted to Soundex
;NARA is a flag, defaulting to zero, for which implementation to perform.
;If NARA is 0, do what seems to be the Knuth implementation
;If NARA is a positive integer, do the NARA implementation.
; This varies the soundex rule for "W" and "H", and adds variants for prefixed names separated by carets.
; http://www.archives.gov/publications/general-info-leaflets/55-census.html
;Y is the string to be returned
;UP is the list of upper case letters
;LO is the list of lower case letters
;PREFIX is a list of prefixes to be stripped off
;X1 is the upper case version of X
;X2 is the name without a prefix
;Y2 is the soundex of a name without a prefix
;C is a loop variable
;DX is a list of Soundex values, in alphabetical order. Underscores are used for the NARA variation letters
;XD is a partially processed translation of X into soundex values
NEW Y,UP,LO,PREFIX,X1,X2,Y2,C,DX,XD
SET UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ" ;Upper case characters
SET LO="abcdefghijklmnopqrstuvwxyz" ;Lower case characters
SET DX=" 123 12_ 22455 12623 1_2 2" ;Soundex values
SET PREFIX="VAN^CO^DE^LA^LE" ;Prefixes that could create an alternate soundex value
SET Y="" ;Y is the value to be returned
SET X1=$TRANSLATE(X,LO,UP) ;Make local copy, and force all letters to be upper case
SET XD=$TRANSLATE(X1,UP,DX) ;Soundex values for string
;
SET Y=$EXTRACT(X1,1,1) ;Get first character
FOR C=2:1:$LENGTH(X1) QUIT:$L(Y)>=4 DO
. ;ignore doubled letters OR and side-by-side soundex values OR same soundex on either side of "H" or "W"
. QUIT:($EXTRACT(X1,C,C)=$EXTRACT(X1,C-1,C-1))
. QUIT:($EXTRACT(XD,C,C)=$EXTRACT(XD,C-1,C-1))
. ;ignore non-alphabetic characters
. QUIT:UP'[($EXTRACT(X1,C,C))
. QUIT:NARA&(($EXTRACT(XD,C-1,C-1)="_")&(C>2))&($EXTRACT(XD,C,C)=$EXTRACT(XD,C-2,C-2))
. QUIT:" _"[$EXTRACT(XD,C,C)
. SET Y=Y_$EXTRACT(XD,C,C)
; Pad with "0" so string length is 4
IF $LENGTH(Y)<4 FOR C=$L(Y):1:3 SET Y=Y_"0"
IF NARA DO
. FOR C=1:1:$LENGTH(PREFIX,"^") DO
. . IF $EXTRACT(X1,1,$LENGTH($PIECE(PREFIX,"^",C)))=$PIECE(PREFIX,"^",C) DO
. . . ;Take off the prefix, and any leading spaces
. . . SET X2=$EXTRACT(X1,$LENGTH($PIECE(PREFIX,"^",C))+1,$LENGTH(X1)-$PIECE(PREFIX,"^",C)) FOR QUIT:UP[$E(X2,1,1) SET X2=$E(X2,2,$L(X2))
. . . SET Y2=$$SOUNDEX(X2,NARA) SET Y=Y_"^"_Y2
KILL UP,LO,PREFIX,X1,X2,Y2,C,DX,XD
QUIT Y