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


class Soundex

  method get_soundex(in_) static
    in = in_.upper()
    old_alphabet= 'AEIOUYHWBFPVCGJKQSXZDTLMNR'
    new_alphabet= '@@@@@@**111122222222334556'
    word=''
    loop i=1 for in.length()
      tmp_=in.substr(i, 1) /*obtain a character from word*/
      if tmp_.datatype('M')  then word=word||tmp_
    end

    value=word.strip.left(1)                       /*1st character is left alone.*/
    word=word.translate(new_alphabet, old_alphabet) /*define the current  word.   */
    prev=value.translate(new_alphabet, old_alphabet) /*   "    "  previous   "     */

    loop j=2  to word.length()                      /*process remainder of word.  */
      q=word.substr(j, 1)
      if q\==prev & q.datatype('W')  then do
	value=value || q;  prev=q
      end
      else if q=='@'  then prev=q
    end   /*j*/

    return value.left(4,0)                           /*padded value with zeroes.   */

  method main(args=String[]) static

    test=''; result_=''
    test['1']= "12346"         ;        result_['1']= '0000'
    test['4']= "4-H"           ;        result_['4']= 'H000'
    test['11']= "Ashcraft"      ;        result_['11']= 'A261'
    test['12']= "Ashcroft"      ;        result_['12']= 'A261'
    test['18']= "auerbach"      ;        result_['18']= 'A612'
    test['20']= "Baragwanath"   ;        result_['20']= 'B625'
    test['22']= "bar"           ;        result_['22']= 'B600'
    test['23']= "barre"         ;        result_['23']= 'B600'
    test['20']= "Baragwanath"   ;        result_['20']= 'B625'
    test['28']= "Burroughs"     ;        result_['28']= 'B620'
    test['29']= "Burrows"       ;        result_['29']= 'B620'
    test['30']= "C.I.A."        ;        result_['30']= 'C000'
    test['37']= "coöp"          ;        result_['37']= 'C100'
    test['43']= "D-day"         ;        result_['43']= 'D000'
    test['44']= "d jay"         ;        result_['44']= 'D200'
    test['45']= "de la Rosa"    ;        result_['45']= 'D462'
    test['46']= "Donnell"       ;        result_['46']= 'D540'
    test['47']= "Dracula"       ;        result_['47']= 'D624'
    test['48']= "Drakula"       ;        result_['48']= 'D624'
    test['49']= "Du Pont"       ;        result_['49']= 'D153'
    test['50']= "Ekzampul"      ;        result_['50']= 'E251'
    test['51']= "example"       ;        result_['51']= 'E251'
    test['55']= "Ellery"        ;        result_['55']= 'E460'
    test['59']= "Euler"         ;        result_['59']= 'E460'
    test['60']= "F.B.I."        ;        result_['60']= 'F000'
    test['70']= "Gauss"         ;        result_['70']= 'G200'
    test['71']= "Ghosh"         ;        result_['71']= 'G200'
    test['72']= "Gutierrez"     ;        result_['72']= 'G362'
    test['80']= "he"            ;        result_['80']= 'H000'
    test['81']= "Heilbronn"     ;        result_['81']= 'H416'
    test['84']= "Hilbert"       ;        result_['84']= 'H416'
    test['100']= "Jackson"       ;        result_['100']= 'J250'
    test['104']= "Johnny"        ;        result_['104']= 'J500'
    test['105']= "Jonny"         ;        result_['105']= 'J500'
    test['110']= "Kant"          ;        result_['110']= 'K530'
    test['116']= "Knuth"         ;        result_['116']= 'K530'
    test['120']= "Ladd"          ;        result_['120']= 'L300'
    test['124']= "Llyod"         ;        result_['124']= 'L300'
    test['125']= "Lee"           ;        result_['125']= 'L000'
    test['126']= "Lissajous"     ;        result_['126']= 'L222'
    test['128']= "Lukasiewicz"   ;        result_['128']= 'L222'
    test['130']= "naïve"         ;        result_['130']= 'N100'
    test['141']= "Miller"        ;        result_['141']= 'M460'
    test['143']= "Moses"         ;        result_['143']= 'M220'
    test['146']= "Moskowitz"     ;        result_['146']= 'M232'
    test['147']= "Moskovitz"     ;        result_['147']= 'M213'
    test['150']= "O'Conner"      ;        result_['150']= 'O256'
    test['151']= "O'Connor"      ;        result_['151']= 'O256'
    test['152']= "O'Hara"        ;        result_['152']= 'O600'
    test['153']= "O'Mally"       ;        result_['153']= 'O540'
    test['161']= "Peters"        ;        result_['161']= 'P362'
    test['162']= "Peterson"      ;        result_['162']= 'P362'
    test['165']= "Pfister"       ;        result_['165']= 'P236'
    test['180']= "R2-D2"         ;        result_['180']= 'R300'
    test['182']= "rÄ≈sumÅ∙"      ;        result_['182']= 'R250'
    test['184']= "Robert"        ;        result_['184']= 'R163'
    test['185']= "Rupert"        ;        result_['185']= 'R163'
    test['187']= "Rubin"         ;        result_['187']= 'R150'
    test['191']= "Soundex"       ;        result_['191']= 'S532'
    test['192']= "sownteks"      ;        result_['192']= 'S532'
    test['199']= "Swhgler"       ;        result_['199']= 'S460'
    test['202']= "'til"          ;        result_['202']= 'T400'
    test['208']= "Tymczak"       ;        result_['208']= 'T522'
    test['216']= "Uhrbach"       ;        result_['216']= 'U612'
    test['221']= "Van de Graaff" ;        result_['221']= 'V532'
    test['222']= "VanDeusen"     ;        result_['222']= 'V532'
    test['230']= "Washington"    ;        result_['230']= 'W252'
    test['233']= "Wheaton"       ;        result_['233']= 'W350'
    test['234']= "Williams"      ;        result_['234']= 'W452'
    test['236']= "Woolcock"      ;        result_['236']= 'W422'

    loop i over test
      say test[i].left(10) get_soundex(test[i]) '=' result_[i]
    end


import strutils

const
  Wovel = 'W'   # Character code used to specify a wovel.
  Ignore = ' '  # Character code used to specify a character to ignore ('h', 'w' or non-letter).

proc code(ch: char): char =
  ## Return the soundex code for a character.
  case ch.toLowerAscii()
  of 'b', 'f', 'p', 'v': '1'
  of 'c', 'g', 'j', 'k', 'q', 's', 'x', 'z': '2'
  of 'd', 't': '3'
  of 'l': '4'
  of 'm', 'n': '5'
  of 'r': '6'
  of 'a', 'e', 'i', 'o', 'u', 'y': Wovel
  else: Ignore

proc soundex(str: string): string =
  ## Return the soundex for the given string.

  result.add str[0]   # Store the first letter.

  # Process characters.
  var prev = code(str[0])
  for i in 1..str.high:
    let curr = code(str[i])
    if curr != Ignore:
      if curr != Wovel and curr != prev:
        result.add curr
      prev = curr

  # Make sure the result has four characters.
  if result.len > 4:
    result.setLen(4)
  else:
    for _ in result.len..3:
      result.add '0'

for name in ["Robert", "Rupert", "Rubin", "Ashcraft", "Ashcroft", "Tymczak",
             "Pfister", "Honeyman", "Moses", "O'Mally", "O'Hara", "D day"]:
  echo name.align(8), " ", soundex(name)


class SoundEx {
  function : Main(args : String[]) ~ Nil {
    SoundEx("Soundex")->PrintLine();
      SoundEx("Example")->PrintLine();
      SoundEx("Sownteks")->PrintLine();
      SoundEx("Ekzampul")->PrintLine();
  }

  function : SoundEx(s : String) ~ String {
    input := s->ToUpper()->Get(0);
    code := input->ToString();
    previous := GetCode(input);

    for(i := 1; i < s->Size(); i += 1;) {
      current := GetCode(s->ToUpper()->Get(i));
      if(current->Size() > 0 & <>current->Equals(previous)) {
        code += current;
      };
      previous := current;
    };

    soundex := String->New(code);
    soundex += "0000";
    return soundex->SubString(4);
  }

  function : GetCode(c : Char) ~ String {
    select(c) {
        label 'B': label 'F':
        label 'P': label 'V': {
        return "1";
      }

      label 'C': label 'G':
      label 'J': label 'K':
      label 'Q': label 'S':
      label 'X': label 'Z': {
        return "2";
      }

      label 'D': label 'T': {
        return "3";
      }

      label 'L': {
        return "4";
      }

      label 'M': label 'N': {
        return "5";
      }

      label 'R': {
        return "6";
      }

      other: {
        return "";
      }
    };
  }
}


let c2d = function
  | 'B' | 'F' | 'P' | 'V' -> "1"
  | 'C' | 'G' | 'J' | 'K' | 'Q' | 'S' | 'X' | 'Z' -> "2"
  | 'D' | 'T' -> "3"
  | 'L' -> "4"
  | 'M' | 'N' -> "5"
  | 'R' -> "6"
  | _ -> ""

let rec dbl acc = function
  | [] -> (List.rev acc)
  | [c] -> List.rev(c::acc)
  | c1::(c2::_ as tl) ->
      if c1 = c2
      then dbl acc tl
      else dbl (c1::acc) tl

let pad s =
  match String.length s with
  | 0 -> s ^ "000"
  | 1 -> s ^ "00"
  | 2 -> s ^ "0"
  | 3 -> s
  | _ -> String.sub s 0 3

let soundex_aux rem =
  pad(String.concat "" (dbl [] (List.map c2d rem)))

let soundex s =
  let s = String.uppercase s in
  let cl = ref [] in
  String.iter (fun c -> cl := c :: !cl) s;
  match dbl [] (List.rev !cl) with
  | c::rem -> (String.make 1 c) ^ (soundex_aux rem)
  | [] -> invalid_arg "soundex"


program Soundex;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
   SysUtils;

type
  TLang=(en,fr,de);

const
   Examples : array[1..16, 1..2] of string =
     (('Ashcraft', 'A261')
     ,('Ashcroft', 'A261')
     ,('Gauss', 'G200')
     ,('Ghosh', 'G200')
     ,('Hilbert', 'H416')
     ,('Heilbronn', 'H416')
     ,('Lee', 'L000')
     ,('Lloyd', 'L300')
     ,('Moses', 'M220')
     ,('Pfister', 'P236')
     ,('Robert', 'R163')
     ,('Rupert', 'R163')
     ,('Rubin', 'R150')
     ,('Tymczak', 'T522')
     ,('Soundex', 'S532')
     ,('Example', 'E251')
     );

// For Ansi Str
function Soundex(Value: String; Lang: TLang) : String;
const
  // Thx to WP.
  Map: array[TLang, 0..2] of String =(
    // Deals with accented, to improve
    ('abcdefghijklmnopqrstuvwxyz'
    ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    ,' 123 12- 22455 12623 1-2 2'),
    ('aàâäbcçdeéèêëfghiîjklmnoöôpqrstuùûüvwxyz' // all chars with accented
    ,'AAAABCCDEEEEEFGHIIJKLMNOOOPQRSTUUUUVWXYZ' // uppercased
    ,' 123 97- 72455 12683 9-8 8'),             // coding
    ('abcdefghijklmnopqrstuvwxyz'
    ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
    ,' 123 12- 22455 12623 1-2 2')
    );
var
  i: Integer;
  c, cOld: Char;

  function Normalize(const s: string): string;
  var
    c: Char;
    p: Integer;
  begin
    result := '';
    for c in LowerCase(s) do
    begin
      p := Pos(c, Map[Lang,0]);
      // unmapped chars are ignored
      if p > 0 then
        Result := Result + Map[Lang, 1][p];
    end;
  End;

  function GetCode(c: Char): Char;
  begin
    Result := Map[Lang, 2][Ord(c)-Ord('A')+1];
  End;

begin
  Value := Trim(Value);
  if Value = '' then
  begin
    Result := '0000';
    exit;
  end;
  Value := Normalize(Value);
  Result := Value[1];
  cOld := GetCode(Value[1]);
  for i := 2 to length(Value) do
  begin
    c := GetCode(Value[i]);
    if (c <> ' ') and (c <> '-') and (c <> cOld) then
      Result := Result + c;
    if c <> '-' then
      cOld := c;
  end;
  Result := Copy(Result+'0000', 1, 4);
End;

const
  Status : array[boolean] of string = ('KO', 'OK');
var
  Found: String;
  tab: array[1..2] of String;
begin
  WriteLn('Word                : Code   Found   Status');
  for tab in Examples do
  begin
    Found := Soundex(tab[1], en);
    WriteLn(Format('%-20s: %s   %s    %s',[tab[1], tab[2], Found, Status[Found = tab[2]]]))
  end;
  ReadLn;
End.


use Text::Soundex;
print soundex("Soundex"), "\n"; # S532
print soundex("Example"), "\n"; # E251
print soundex("Sownteks"), "\n"; # S532
print soundex("Ekzampul"), "\n"; # E251


with javascript_semantics
constant soundex_alphabet = "0123012#02245501262301#202"
                        --   ABCDEFGHIJKLMNOPQRSTUVWXYZ

function soundex(string name)
    string res = "0000"
    integer rdx = 1, ch, curr, prev
    for i=1 to length(name) do
        ch = upper(name[i])
        if ch>='A' and ch<='Z' then
            curr = soundex_alphabet[ch-'A'+1]
            if rdx=1 then
                res[1] = ch
                rdx = 2
                prev = curr
            elsif curr!='#' then
                if curr!='0' and curr!=prev then
                    res[rdx] = curr
                    if rdx=4 then exit end if
                    rdx += 1
                end if
                prev = curr
            end if
        end if
    end for
    return res
end function

constant tests = {
                    {"Ashcraft",    "A261"},    -- not "A226"
                    {"Ashcroft",    "A261"},    -- not "A226"
                    {"Ashkrofd",    "A261"},    -- not "A226"
                    {"Burroughs",   "B620"},
                    {"Burrows",     "B620"},
                    {"ciondecks",   "C532"},
                    {"Example",     "E251"},
                    {"Ekzampul",    "E251"},
                    {"Ellery",      "E460"},
                    {"Euler",       "E460"},
                    {"Gauss",       "G200"},
                    {"Ghosh",       "G200"},
                    {"Gutierrez",   "G362"},
                    {"He",          "H000"},
                    {"Heilbronn",   "H416"},
                    {"Hilbert",     "H416"},
                    {"Honeyman",    "H555"},    -- not "H500"
                    {"Jackson",     "J250"},
                    {"Kant",        "K530"},
                    {"Knuth",       "K530"},
                    {"Lee",         "L000"},
                    {"Ladd",        "L300"},
                    {"Lloyd",       "L300"},
                    {"Lissajous",   "L222"},
                    {"Lukasiewicz", "L222"},
                    {"Moses",       "M220"},
                    {"O'Hara",      "O600"},
                    {"Pfister",     "P236"},    -- not "P123"
                    {"Robert",      "R163"},
                    {"Rupert",      "R163"},
                    {"Rubin",       "R150"},
                    {"[email protected][email protected]",    "R250"},
                    {"Soundex",     "S532"},
                    {"Sownteks",    "S532"},
                    {"Tymczak",     "T522"},    -- not "T520"
                    {"VanDeusen",   "V532"},
                    {"Washington",  "W252"},
                    {"Wheaton",     "W350"},
                    {"Weeton",      "W350"},
                    {"",            "0000"},
                    {"  ",          "0000"},
                    {"12346",       "0000"},
                    {"aaa a",       "A000"}
                }

for i=1 to length(tests) do
    string {name,expected} = tests[i],
           res = soundex(name),
           ok = iff(res=expected?"":"*** ERROR ***")
    printf(1,"%-12s -> %s %s\n",{name,res,ok})
end for


<?php
echo soundex("Soundex"), "\n"; // S532
echo soundex("Example"), "\n"; // E251
echo soundex("Sownteks"), "\n"; // S532
echo soundex("Ekzampul"), "\n"; // E251
?>


go =>
   Names = split("Lloyd Woolcock Donnell Baragwanath Williams Ashcroft Ashcraft Euler
Ellery Gauss Ghosh Hilbert Heilbronn Knuth Kant Ladd Lukasiewicz Lissajous O'Hara"),
   SoundexNames = split("L300 W422 D540 B625 W452 A261 A261 E460
E460 G200 G200 H416 H416 K530 K530 L300 L222 L222 O600"),

   foreach({Name,Correct} in zip(Names, SoundexNames))
     S = soundex(Name),
     printf("%s: %s ",Name,S),
     if S == Correct then
       println("ok")
     else
       printf("not correct! Should be: %s\n", Correct)
     end
   end,
   nl.

soundex("", _) = "" => true.
soundex(Word) = Soundex =>
  SoundexAlphabet = "0123012#02245501262301#202",
  Soundex = "",
  LastC = '?',
  foreach(Ch in Word.to_uppercase,
             C = ord(Ch), C >= 0'A', C <= 0'Z',
             Soundex.len < 4)
     ThisC := SoundexAlphabet[C-0'A'+1],
     Skip = false, % to handle '#'
     if Soundex.len == 0 then
       Soundex := Soundex ++ [Ch]
     elseif ThisC == '#' then
       Skip := true
     elseif ThisC != '0', ThisC != LastC then
       Soundex := Soundex ++ [ThisC]
     end,
     if Skip == false then
       LastC := ThisC
     end
  end,
  Soundex := Soundex.padRight(4,'0').

padRight(S,Len,PadChar) = S ++ [PadChar : _ in 1..Len-S.len].


(de soundex (Str)
   (pack
      (pad -4
         (cons
            (uppc (char (char Str)))
            (head 3
               (let Last NIL
                  (extract
                     '((C)
                        (and
                           (setq C
                              (case (uppc C)
                                 (`(chop "BFPV") "1")
                                 (`(chop "CGJKQSXZ") "2")
                                 (("D" "T") "3")
                                 ("L" "4")
                                 (("M" "N") "5")
                                 ("R" "6") ) )
                           (<> Last C)
                           (setq Last C) ) )
                     (cdr (chop Str)) ) ) ) ) ) ) )


Soundex: procedure (pword) returns (character(4));
   declare pword character (*) varying, value character (length(pword)) varying;
   declare word character (length(pword));
   declare (prevCode, currCode) character (1);
   declare alphabet CHARACTER (26) STATIC INITIAL ('AEIOUHWYBFPVCGJKQSXZDTLMNR');
   declare replace  character (26) static initial ('00000000111122222222334556');
   declare i fixed binary;

   word = pword;

   /* Buffer to build up with character codes */
   value = '';

   /* Make sure the word is at least two characters in length. */
   if length(word) <= 1 then return (word);

   word = uppercase(word); /* Convert to uppercase. */

   /* The current and previous character codes */
   prevCode = '0';

   value = substr(word, 1, 1); /* The first character is unchanged. */

   word = Translate (word, replace, alphabet);

   /* Loop through the remaining characters ... */
   do i = 2 to length(word);
      currCode = substr(word, i, 1);
      /* Check to see if the current code is the same as the last one */
      if currCode ^= prevCode & currCode ^= '0' then
         /* If the current code is a vowel, ignore it. */
         value = value || currCode;
      /* Set the new previous character code */
      prevCode = currCode;
   end; /* of do i = ... */

   return ( left(value, 4, '0') ); /* Pad, if necessary. */

end Soundex;


function Get-Soundex
{
    [CmdletBinding()]
    [OutputType([PSCustomObject])]
    Param
    (
        [Parameter(Mandatory=$true,
                   ValueFromPipeline=$true,
                   ValueFromPipelineByPropertyName=$true,
                   Position=0)]
        [string[]]
        $InputObject
    )

    Begin
    {
        $characterGroup = [PSCustomObject]@{
            1 = @('B','F','P','V')
            2 = @('C','G','J','K','Q','S','X','Z')
            3 = @('D','T')
            4 = @('L')
            5 = @('M','N')
            6 = @('R')
        }

        function ConvertTo-SoundexDigit ([char]$Character)
        {
            switch ($Character)
            {
                {$_ -in $characterGroup.1} {return 1}
                {$_ -in $characterGroup.2} {return 2}
                {$_ -in $characterGroup.3} {return 3}
                {$_ -in $characterGroup.4} {return 4}
                {$_ -in $characterGroup.5} {return 5}
                {$_ -in $characterGroup.6} {return 6}
                Default                    {return 0}
            }
        }
    }
    Process
    {
        foreach ($String in $InputObject)
        {
            $originalString = $String
            $String = $String.ToUpper()
            $isHorWcharacter = $false
            $soundex = New-Object -TypeName System.Text.StringBuilder

            $soundex.Append($String[0]) | Out-Null

            for ($i = 1; $i -lt $String.Length; $i++)
            {
                $currentCharacterDigit = ConvertTo-SoundexDigit $String[$i]

                if ($currentCharacterDigit -ne 0)
                {
                    if ($i -eq (ConvertTo-SoundexDigit $String[$i-1]))
                    {
                        continue
                    }

                    if (($i -gt 2) -and ($isHorWcharacter) -and ($currentCharacterDigit -eq (ConvertTo-SoundexDigit $String[$i-2])))
                    {
                        continue
                    }

                    $soundex.Append($currentCharacterDigit) | Out-Null
                }

                $isHorWcharacter = $String[$i] -in @('H','W')
            }

            $soundexTail = ($soundex.ToString().Substring(1)).TrimStart((ConvertTo-SoundexDigit $String[0]).ToString())

            [PSCustomObject]@{
                String  = $originalString
                Soundex = ($soundex[0] + $soundexTail).PadRight(4,"0").Substring(0,4)
            }
        }
    }
}


%____________________________________________________________________
% Implements the American soundex algorithm
%   as described at https://en.wikipedia.org/wiki/Soundex
%  In SWI Prolog, a 'string' is specified in 'single quotes',
%    while a "list of codes" may be specified in "double quotes".
%  So, "abc" is equivalent to [97, 98, 99], while
%    'abc' = abc  (an atom), and 'Abc' is also an atom.  There are
%    conversion methods that can produce lists of characters:
%        ?- atom_chars('Abc', X).
%	 X = ['A', b, c].
%    or lists of codes (mapping to unicode code points):
%        ?- atom_codes('Abc', X).
%        X = [65, 98, 99].
%    and the conversion predicates are bidirectional.
%        ?- atom_codes(A, [65, 98, 99]).
%        A = 'Abc'.
%  A single character code may be specified as 0'C, where C is the
%    character you want to convert to a code.
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

%  Relates groups of consonants to representative digits
creplace(Ch, 0'1) :- member(Ch, "bfpv").
creplace(Ch, 0'2) :- member(Ch, "cgjkqsxz").
creplace(Ch, 0'3) :- member(Ch, "dt").
creplace(0'l, 0'4).
creplace(Ch, 0'5) :- member(Ch, "mn").
creplace(0'r, 0'6).

% strips elements contained in <Set> from a string
strip(Set, [H|T], Tr) :- memberchk(H, Set), !, strip(Set, T, Tr).
strip(Set, [H|T], [H|Tr]) :- !, strip(Set, T, Tr).
strip(_, [], []).

% Replace consonants with appropriate digits
consonants([H|T], [Ch|Tr]) :- creplace(H, Ch), !, consonants(T, Tr).
consonants([H|T], [H|Tr]) :- !, consonants(T, Tr).
consonants([], []).

% Replace adjacent digits with single digit
adjacent([Ch, Ch|T], [Ch|Tr]) :- between(0'0, 0'9, Ch), !, adjacent(T, Tr).
adjacent([H|T], [H|Tr]) :- !, adjacent(T, Tr).
adjacent([], []).

% Replace first character with original one if its a digit
chk_digit([H,D|T], [H|T]) :- between(0'0, 0'9, D), !.
chk_digit([_,H|T], [H|T]).

% Faithul representation of soundex rules:
%   1: Save 1st letter, strip "hw"
%   2: Replace consonants with appropriate digits
%   3: Replace adjacent digits with single occurrence
%   4: Remove vowels except 1st letter
%   5: If 1st symbol is a digit, replace it with saved 1st letter
%   6: Ensure trailing zeroes
do_soundex([H|T], Res) :-
	strip("hw", T, Ts), consonants([H|Ts], Tc),
	adjacent(Tc, [C|Ta]), strip("aeiouy", Ta, Tv),
	chk_digit([H,C|Tv], Td), append(Td, "0000", Tr),
	atom_codes(Tf, Tr), sub_string(Tf, 0, 4, _, Res).

% Prepare string, convert to lower case and do the soundex alogorithm
soundex(Text, Res) :-
	downcase_atom(Text, Lower), atom_codes(Lower, T),
	do_soundex(T, Res).

% Perform tests to check that the right values are produced
test(S,V) :- not(soundex(S,V)), writef('%w failed\n', [S]).
test :- test('Robert', 'r163'), !, fail.
test :- test('Rupert', 'r163'), !, fail.
test :- test('Rubin', 'r150'), !, fail.
test :- test('Ashcroft', 'a261'), !, fail.
test :- test('Ashcraft', 'a261'), !, fail.
test :- test('Tymczak', 't522'), !, fail.
test :- test('Pfister', 'p236'), !, fail.
test.  % Succeeds only if all the tests succeed


Procedure.s getCode(c.s)
    Protected  getCode.s = ""

    If FindString("BFPV", c ,1)     : getCode = "1" : EndIf
    If FindString("CGJKQSXZ", c ,1) : getCode = "2" : EndIf
    If FindString("DT", c ,1)       : getCode = "3" : EndIf
    If "L" = c                      : getCode = "4" : EndIf
    If FindString("MN", c ,1)       : getCode = "5" : EndIf
    If "R" = c                      : getCode = "6" : EndIf
    If FindString("HW", c ,1)       : getCode = "." : EndIf
    ProcedureReturn getCode
EndProcedure

Procedure.s soundex(word.s)
    Protected.s previous.s = "" , code.s , current , soundex
    Protected.i i

    word = UCase(word)
    code = Mid(word,1,1)
    previous = getCode(Left(word, 1))
    For i = 2 To (Len(word) + 1)
        current = getCode(Mid(word, i, 1))
        If current = "." : Continue : EndIf
        If Len(current) > 0 And current <> previous
            code + current
        EndIf
        previous = current
        If Len(code) = 4
          Break
        EndIf
    Next
    If Len(code) < 4
        code = LSet(code, 4,"0")
    EndIf
    ProcedureReturn code
EndProcedure

OpenConsole()

PrintN (soundex("Lukasiewicz"))
PrintN("Press any key to exit"): Repeat: Until Inkey() <> ""


from itertools import groupby

def soundex(word):
   codes = ("bfpv","cgjkqsxz", "dt", "l", "mn", "r")
   soundDict = dict((ch, str(ix+1)) for ix,cod in enumerate(codes) for ch in cod)
   cmap2 = lambda kar: soundDict.get(kar, '9')
   sdx =  ''.join(cmap2(kar) for kar in word.lower())
   sdx2 = word[0].upper() + ''.join(k for k,g in list(groupby(sdx))[1:] if k!='9')
   sdx3 = sdx2[0:4].ljust(4,'0')
   return sdx3


sub soundex ($name --> Str) {
    my $first = substr($name,0,1).uc;
    gather {
        take $first;
        my $fakefirst = '';
        $fakefirst = "de " if $first ~~ /^ <[AEIOUWH]> /;
        "$fakefirst$name".lc.trans('wh' => '') ~~ /
            ^
            [
                [
                | <[ bfpv     ]>+ { take 1 }
                | <[ cgjkqsxz ]>+ { take 2 }
                | <[ dt       ]>+ { take 3 }
                | <[ l        ]>+ { take 4 }
                | <[ mn       ]>+ { take 5 }
                | <[ r        ]>+ { take 6 }
                ]
            || .
            ]+
            $ { take 0,0,0 }
        /;
    }.flat.[0,2,3,4].join;
}

for < Soundex     S532
      Example     E251
      Sownteks    S532
      Ekzampul    E251
      Euler       E460
      Gauss       G200
      Hilbert     H416
      Knuth       K530
      Lloyd       L300
      Lukasiewicz L222
      Ellery      E460
      Ghosh       G200
      Heilbronn   H416
      Kant        K530
      Ladd        L300
      Lissajous   L222
      Wheaton     W350
      Ashcraft    A261
      Burroughs   B620
      Burrows     B620
      O'Hara      O600 >
-> $n, $s {
    my $s2 = soundex($n);
    say $n.fmt("%16s "), $s, $s eq $s2 ?? " OK" !! " NOT OK $s2";
}


# Project: Soundex

name = ["Ashcraf", "Ashcroft", "Gauss", "Ghosh", "Hilbert", "Heilbronn", "Lee", "Lloyd",
              "Moses", "Pfister", "Robert", "Rupert", "Rubin","Tymczak", "Soundex", "Example"]
for i = 1 to 16
     sp = 10 - len(name[i])
     see '"' + name[i] + '"' + copy(" ", sp) + " " + soundex(name[i]) + nl
next

func soundex(name2)
name2 = upper(name2)
n = "01230129022455012623019202"
s = left(name2,1)
p = number(substr(n, ascii(s) - 64, 1))
for i = 2 to len(name2)
     n2 = number(substr(n, ascii(name2[i]) - 64, 1))
     if n2 > 0 and n2 != 9 and n2 != p s = s + string(n2) ok
     if n2 != 9 p = n2 ok
next
return left(s + "000", 4)


class String

  SoundexChars = 'BFPVCGJKQSXZDTLMNR'
  SoundexNums  = '111122222222334556'
  SoundexCharsEx = '^' + SoundexChars
  SoundexCharsDel = '^A-Z'

  # desc: http://en.wikipedia.org/wiki/Soundex
  def soundex(census = true)
    str = self.upcase.delete(SoundexCharsDel)
    str[0,1] + str[1..-1].delete(SoundexCharsEx).
                          tr_s(SoundexChars, SoundexNums)\
                          [0 .. (census ? 2 : -1)].
                          ljust(3, '0') rescue ''
  end

  def sounds_like(other)
    self.soundex == other.soundex
  end
end

%w(Soundex Sownteks Example Ekzampul foo bar).each_slice(2) do |word1, word2|
  [word1, word2].each {|word| puts '%-8s -> %s' % [word, word.soundex]}

  print "'#{word1}' "
  print word1.sounds_like(word2) ? "sounds" : "does not sound"
  print " like '#{word2}'\n"
end


def soundex(s:String)={
   var code=s.head.toUpper.toString
   var previous=getCode(code.head)
   for(ch <- s.drop(1); current=getCode(ch.toUpper)){
      if (!current.isEmpty && current!=previous)
         code+=current
      previous=current
   }
   code+="0000"
   code.slice(0,4)
}

def getCode(c:Char)={
   val code=Map("1"->List('B','F','P','V'),
      "2"->List('C','G','J','K','Q','S','X','Z'),
      "3"->List('D', 'T'),
      "4"->List('L'),
      "5"->List('M', 'N'),
      "6"->List('R'))

   code.find(_._2.exists(_==c)) match {
      case Some((k,_)) => k
      case _ => ""
   }
}


;; The American Soundex System
;;
;; The soundex code consist of the first letter of the name followed
;; by three digits. These three digits are determined by dropping the
;; letters a, e, i, o, u, h, w and y and adding three digits from the
;; remaining letters of the name according to the table below. There
;; are only two additional rules. (1) If two or more consecutive
;; letters have the same code, they are coded as one letter. (2) If
;; there are an insufficient numbers of letters to make the three
;; digits, the remaining digits are set to zero.

;; Soundex Table

;;  1 b,f,p,v
;;  2 c,g,j,k,q,s,x,z
;;  3 d, t
;;  4 l
;;  5 m, n
;;  6 r

;; Examples:

;;  Miller M460
;;  Peterson P362
;;  Peters P362
;;  Auerbach A612
;;  Uhrbach U612
;;  Moskowitz M232
;;  Moskovitz M213

(define (char->soundex c)
  (case (char-upcase c)
    ((#\B #\F #\P #\V) #\1)
    ((#\C #\G #\J #\K #\Q #\S #\X #\Z) #\2)
    ((#\D #\T) #\3)
    ((#\L) #\4)
    ((#\M #\N) #\5)
    ((#\R) #\6)
    (else #\nul)))

(define (collapse-dups lst)
  (if (= (length lst) 1) lst
      (if (equal? (car lst) (cadr lst))
	  (collapse-dups (cdr lst))
	  (cons (car lst) (collapse-dups (cdr lst))))))

(define (remove-nul lst)
  (filter (lambda (c)
	    (not (equal? c #\nul)))
	  lst))

(define (force-len n lst)
  (cond ((= n 0) '())
	((null? lst) (force-len n (list #\0)))
	(else (cons (car lst) (force-len (- n 1) (cdr lst))))))

(define (soundex s)
  (let ((slst (string->list s)))
    (force-len 4 (cons (char-upcase (car slst))
		       (remove-nul
			(collapse-dups
			 (map char->soundex (cdr slst))))))))

(soundex "miller")
(soundex "Peterson")
(soundex "PETERS")
(soundex "auerbach")
(soundex "Uhrbach")
(soundex "Moskowitz")
(soundex "Moskovitz")


set names to ["Aschraft","Ashcroft","DiBenedetto","Euler","Gauss","Ghosh","Gutierrez",
	"Heilbronn","Hilbert","Honeyman","Jackson","Lee","LeGrand","Lissajous","Lloyd",
	"Moses","Pfister","Robert","Rupert","Rubin","Tymczak","VanDeusen","Van de Graaff","Wheaton"]

repeat with each name in names
	put !"[[name]] --> [[name's soundex]]"
end repeat

to handle soundex of aName
	delete space from aName -- remove spaces
	put the first character of aName into soundex
	replace every occurrence of <{letter:char},{:letter}> with "{:letter}" in aName -- collapse double letters
	delete "H" from aName
	delete "W" from aName

	set prevCode to 0
	repeat with each character ch in aName
		if ch is in ...
			... "BFPV" then set code to 1
			... "CGJKQSXZ" then set code to 2
			... "DT" then set code to 3
			... "L" then set code to 4
			... "MN" then set code to 5
			... "R" then set code to 6
			... else set code to 0
		end if
		if code isn't 0 and the counter > 1 and code isn't prevCode then put code after soundex
		put code into prevCode
	end repeat
	set soundex to the first 4 chars of (soundex & "000") -- fill in with 0's as needed

	set prefix to <("Van" or "Con" or "De" or "Di" or "La" or "Le") followed by a capital letter>
	if aName begins with prefix then
		put aName into nameWithoutPrefix
		delete the first occurrence of prefix in nameWithoutPrefix
		return [soundex, soundex of nameWithoutPrefix]
	end if

	return soundex
end soundex


func soundex(word, length=3) {

    # Uppercase the argument passed in to normalize it
    # and drop any non-alphabetic characters
    word.uc!.tr!('A-Z', '', 'cd')

    # Return if word does not contain 'A-Z'
    return(nil) if (word.is_empty)

    var firstLetter = word.char(0)

    # Replace letters with corresponding number values
    word.tr!('BFPV',     '1', 's')
    word.tr!('CGJKQSXZ', '2', 's')
    word.tr!('DT',       '3', 's')
    word.tr!('L',        '4', 's')
    word.tr!('MN',       '5', 's')
    word.tr!('R',        '6', 's')

    # Discard the first letter
    word.ft!(1)

    # Remove A, E, H, I, O, U, W, and Y
    word.tr!('AEHIOUWY', '', 'd')

    # Return the soundex code
    firstLetter + (word.chars + length.of('0') -> first(length).join)
}

func testSoundex {

    # Key-value pairs of names and corresponding Soundex codes
    var sndx = Hash(
                "Euler"                => "E4600",
                "Gauss"                => "G2000",
                "Hilbert"              => "H4163",
                "Knuth"                => "K5300",
                "Lloyd"                => "L3000",
                "Lukasieicz"           => "L2220",
                'fulkerson'            => 'F4262',
                'faulkersuhn'          => 'F4262',
                'fpfffffauhlkkersssin' => 'F4262',
                'Aaeh'                 => 'A0000',
               )

    sndx.keys.sort.each { |name|
        var findSdx = soundex(name, 4)
        say "The soundex for #{name} should be #{sndx{name}} and is #{findSdx}"
        if (findSdx != sndx{name}) {
            say "\tHowever, that is incorrect!\n"
        }
    }
}

testSoundex()


PhoneticStringUtilities soundexCodeOf: 'Soundex' "-> S532"


*       # Soundex coding
*       # ABCDEFGHIJKLMNOPQRSTUVWXYZ
*       # 01230127022455012623017202

        define('soundex(str)init,ch') :(soundex_end)
soundex sdxmap = '01230127022455012623017202'
        str = replace(str,&lcase,&ucase)
sdx1    str notany(&ucase) = :s(sdx1)
        init = substr(str,1,1)
        str = replace(str,&ucase,sdxmap)
sdx2    str len(1) $ ch span(*ch) = ch :s(sdx2)
*       # Omit next line for Knuth's simple Soundex
sdx3    str len(1) $ ch ('7' *ch) = ch :s(sdx3)
        str len(1) = init
sdx4    str any('07') = :s(sdx4)
        str = substr(str,1,4)
        str = lt(size(str),4) str dupl('0',4 - size(str))
        soundex = str :(return)
soundex_end

*       # Test and display
        test = " Washington Lee Gutierrez Pfister Jackson Tymczak"
+              " Ashcroft Swhgler O'Connor Rhys-Davies"
loop    test span(' ') break(' ') . name = :f(end)
        output = soundex(name) ' ' name :(loop)
end


(* There are 3 kinds of letters:
 *   h and w are ignored completely (letters separated by h or w are considered
 *     adjacent, or merged together)
 *   vowels are ignored, but letters separated by a vowel are split apart.
 *   All consonants but h and w map to a digit *)
datatype code =
         Merge
       | Split
       | Digit of char

(* Encodes which characters map to which codes *)
val codeTable =
 [([#"H", #"W"], Merge),
  ([#"A",#"E",#"I", #"O",#"U",#"Y"], Split),
  ([#"B",#"F",#"P",#"V"], Digit #"1"),
  ([#"C",#"G",#"J",#"K",#"Q",#"S",#"X",#"Z"], Digit #"2"),
  ([#"D",#"T"], Digit #"3"),
  ([#"L"], Digit #"4"),
  ([#"M",#"N"], Digit #"5"),
  ([#"R"], Digit #"6")]

(* Find the code that matches a given character *)
fun codeOf (c : char) =
    #2 (valOf (List.find (fn (L,_) => isSome(List.find (fn c' => c = c') L)) codeTable))

(* Remove all the non-digit codes, combining like digits when appropriate. *)
fun collapse (c :: Merge :: cs) = collapse (c :: cs)
  | collapse (Digit d :: Split :: cs) = Digit d :: collapse cs
  | collapse (Digit d :: (cs' as Digit d' :: cs)) =
    if d = d' then collapse (Digit d :: cs)
    else Digit d :: collapse cs'
  | collapse [Digit d] = [Digit d]
  | collapse (c::cs) = collapse cs
  | collapse _ = []

(* dropWhile f L removes the initial elements of L that satisfy f and returns
 * the rest *)
fun dropWhile f [] = []
  | dropWhile f (x::xs) =
    if f x then dropWhile f xs
    else x::xs

fun soundex (s : string) =
    let
      (* Normalize the string to uppercase letters only *)
      val c::cs = map (Char.toUpper) (filter Char.isAlpha(String.explode s))
      fun first3 L = map (fn Digit c => c) (List.take(L,3))
      val padding = [Digit #"0", Digit #"0", Digit #"0"]
      (* Remove any initial section that has the same code as the first character.
       * This comes up in the "Pfister" test case. *)
      val codes = dropWhile (fn Merge => true | Digit d => Digit d = codeOf c | Split => false)
                            (map codeOf (c::cs))
    in
      String.implode(c::first3(collapse [email protected]))
    end

(* Some test cases from Wikipedia *)
fun test input output =
    if soundex input = output then ()
    else raise Fail ("Soundex of " ^ input ^ " should be " ^ output ^ ", not " ^ soundex input)

val () = test "Rupert" "R163"
val () = test "Robert" "R163"
val () = test "Rubin" "R150"
val () = test "Tymczak" "T522"
val () = test "Pfister" "P236"


. display soundex_nara("Ashcraft")
A261

. display soundex_nara("Tymczak")
T522


package require soundex

foreach string {"Soundex" "Example" "Sownteks" "Ekzampul"} {
    set soundexCode [soundex::knuth $string]
    puts "\"$string\" has code $soundexCode"
}


// library: string: get: soundex <description></description> <version>1.0.0.0.35</version> <version control></version control> (filenamemacro=getstgso.s) [kn, ri, sa, 15-10-2011 18:23:04]
STRING PROC FNStringGetSoundexS( STRING inS )
 // Except the first character, you replace each character in the string with its corresponding mapping number
 // Idea is that you give characters with the same sound the same mapping number (e.g. 'c' is replaced by '2'. And 'k' which might sound the same as a 'c' is also replaced by the same '2'
 STRING map1S[255] = "AEHIOUWYBFPVCGJKQSXZDTLMNR"
 STRING map2S[255] = "00000000111122222222334556"
 STRING s[255] = Upper( inS )
 STRING soundexS[255] = ""
 STRING characterCurrentS[255] = ""
 STRING characterPreviousS[255] = "?"
 STRING characterMapS[255] = ""
 INTEGER mapPositionI = 0
 INTEGER minI = 1
 INTEGER I = minI
 INTEGER maxI = Length( s )
 I = minI
 characterCurrentS = SubStr( s, I, 1 )
 mapPositionI = Pos( characterCurrentS, map1S )
 WHILE ( ( I <= maxI ) AND ( Length( soundexS ) < 4 ) AND ( NOT ( mapPositionI == 0 ) ) )
  // Skip double letters, like CC, KK, PP, ...
  IF ( NOT ( mapPositionI == 0 ) ) AND ( NOT ( characterCurrentS == characterPreviousS ) )
   characterPreviousS = characterCurrentS
   // First character is extracted unchanged, for sorting purposes.
   IF ( I == minI )
    soundexS = Format( soundexS, characterCurrentS )
   ELSE
    mapPositionI = Pos( characterCurrentS, map1S )
    IF ( NOT ( mapPositionI == 0 ) )
     characterMapS = SubStr( map2S, mapPositionI, 1 )
     // skip vowels A, E, I, O, U, further also H, W and Y. In general all characters which have a mapping value of "0"
     IF ( NOT ( characterMapS == "0" ) )
      soundexS = Format( soundexS, characterMapS )
     ENDIF
    ENDIF
   ENDIF
  ENDIF
  I = I + 1
  characterCurrentS = SubStr( s, I, 1 )
 ENDWHILE
 IF ( NOT ( soundexS == "" ) )
  WHILE ( Length( soundexS ) < 4 )
   soundexS = Format( soundexS, "0" )
  ENDWHILE
 ENDIF
 RETURN( soundexS )
END

PROC Main()
 STRING s1[255] = "John Doe"
 // Warn( Format( FNStringGetSoundexS( "Ashcraft" ) ) ) // gives e.g. "A226" // using another rule the value might be "A261" (see Wikipedia, soundex)
 // Warn( Format( FNStringGetSoundexS( "Ashcroft" ) ) ) // gives e.g. "A226" // using another rule the value might be "A261" (see Wikipedia, soundex)
 // Warn( Format( FNStringGetSoundexS( "Davidson, Greg" ) ) ) // gives e.g. "D132"
 // Warn( Format( FNStringGetSoundexS( "Dracula" ) ) ) // gives e.g. "D624"
 // Warn( Format( FNStringGetSoundexS( "Drakula" ) ) ) // gives e.g. "D624"
 // Warn( Format( FNStringGetSoundexS( "Darwin" ) ) ) // gives e.g. "D650"
 // Warn( Format( FNStringGetSoundexS( "Darwin, Daemon" ) ) ) // gives e.g. "D650"
 // Warn( Format( FNStringGetSoundexS( "Darwin, Ian" ) ) ) // gives e.g. "D650"
 // Warn( Format( FNStringGetSoundexS( "Derwin" ) ) ) // gives e.g. "D650"
 // Warn( Format( FNStringGetSoundexS( "Darwent, William" ) ) ) // gives e.g. "D653"
 // Warn( Format( FNStringGetSoundexS( "Ellery" ) ) ) // gives e.g. "E460"
 // Warn( Format( FNStringGetSoundexS( "Euler" ) ) ) // gives e.g. "E460"
 // Warn( Format( FNStringGetSoundexS( "Ghosh" ) ) ) // gives e.g. "G200"
 // Warn( Format( FNStringGetSoundexS( "Gauss" ) ) ) // gives e.g. "G200"
 // Warn( Format( FNStringGetSoundexS( "Heilbronn" ) ) ) // gives e.g. "H416"
 // Warn( Format( FNStringGetSoundexS( "Hilbert" ) ) ) // gives e.g. "H416"
 // Warn( Format( FNStringGetSoundexS( "Johnny" ) ) ) // gives e.g. "J500"
 // Warn( Format( FNStringGetSoundexS( "Jonny" ) ) ) // gives e.g. "J500"
 // Warn( Format( FNStringGetSoundexS( "Kant" ) ) ) // gives e.g. "K530"
 // Warn( Format( FNStringGetSoundexS( "Knuth" ) ) ) // gives e.g. "K530"
 // Warn( Format( FNStringGetSoundexS( "Lissajous" ) ) ) // gives e.g. "L222"
 // Warn( Format( FNStringGetSoundexS( "Lukasiewicz" ) ) ) // gives e.g. "L222"
 // Warn( Format( FNStringGetSoundexS( "Ladd" ) ) ) // gives e.g. "L300"
 // Warn( Format( FNStringGetSoundexS( "Lloyd" ) ) ) // gives e.g. "L300"
 // Warn( Format( FNStringGetSoundexS( "Rubin" ) ) ) // gives e.g. "R150"
 // Warn( Format( FNStringGetSoundexS( "Robert" ) ) ) // gives e.g. "R163"
 // Warn( Format( FNStringGetSoundexS( "Rupert" ) ) ) // gives e.g. "R163"
 REPEAT
  IF ( NOT ( Ask( "string: get: soundex = ", s1, _EDIT_HISTORY_ ) ) AND ( Length( s1 ) > 0 ) ) RETURN() ENDIF
  Warn( Format( FNStringGetSoundexS( s1 ) ) )
 UNTIL FALSE
END


$$ MODE DATA

$$ BUILD X_TABLE soundex = *
:b:1:f:1:p:1:v:1:
:c:2:g:2:j:2:k:2:1:2:s:2:x:2:z:2:
:d:3:t:3:
:l:4:
:m:5:n:5:
:r:6:

$$ names="Christiansen'Kris Jenson'soundex'Lloyd'Woolcock'Donnell'Baragwanath'Williams'Ashcroft'Euler'Ellery'Gauss'Ghosh'Hilbert'Heilbronn'Knuth'Kant'Ladd'Lukasiewicz'Lissajous'Wheaton'Burroughs'Burrows"

$$ MODE TUSCRIPT,{}
LOOP/CLEAR n=names
 first=EXTRACT (n,1,2),second=EXTRACT (n,2,3)
 IF (first==second) THEN
  rest=EXTRACT (n,3,0)
 ELSE
  rest=EXTRACT (n,2,0)
 ENDIF

 soundex=EXCHANGE (rest,soundex)
 soundex=STRINGS  (soundex,":{\0}:a:e:i:o:u:")
 soundex=REDUCE   (soundex)
 soundex=STRINGS  (soundex,":{\0}:",0,0,1,0,"")
 soundex=CONCAT   (soundex,"000")
 soundex=EXTRACT  (soundex,0,4)

 PRINT first,soundex,"=",n
ENDLOOP


@(next :args)
@###
@# soundex-related filters
@###
@(deffilter remdbl ("AA" "A") ("BB" "B") ("CC" "C") ("DD" "D") ("EE" "E")
                   ("FF" "F") ("GG" "G") ("HH" "H") ("II" "I") ("JJ" "J")
                   ("KK" "K") ("LL" "L") ("MM" "M") ("NN" "N") ("OO" "O")
                   ("PP" "P") ("QQ" "Q") ("RR" "R") ("SS" "S") ("TT" "T")
                   ("UU" "U") ("VV" "V") ("WW" "W") ("XX" "X") ("YY" "Y")
                   ("ZZ" "Z"))
@(deffilter code ("B" "F" "P" "V" "1")
                 ("C" "G" "J" "K" "Q" "S" "X" "Z" "2")
                 ("D" "T" "3") ("L" "4") ("M" "N" "5")
                 ("R" "6") ("A" "E" "I" "O" "U" "Y" "0") ("H" "W" ""))
@(deffilter squeeze ("11" "111" "1111" "11111" "1")
                    ("22" "222" "2222" "22222" "2")
                    ("33" "333" "3333" "33333" "3")
                    ("44" "444" "4444" "44444" "4")
                    ("55" "555" "5555" "55555" "5")
                    ("66" "666" "6666" "66666" "6"))
@(bind prefix ("VAN" "CON" "DE" "DI" "LA" "LE"))
@(deffilter remzero ("0" ""))
@###
@# soundex function
@###
@(define soundex (in out))
@  (local nodouble letters remainder first rest coded)
@  (next :string in)
@  (coll)@{letters /[A-Za-z]+/}@(end)
@  (cat letters "")
@  (output :into nodouble :filter (:upcase remdbl))
@letters
@  (end)
@  (next :list nodouble)
@  (maybe)
@[email protected]
@    (output :into nodouble)
@nodouble
@remainder
@    (end)
@  (end)
@  (next :list nodouble)
@  (collect)
@{first 1}@rest
@    (output :filter (code squeeze remzero) :into coded)
@{rest}000
@    (end)
@    (next :list coded)
@{digits 3}@(skip)
@  (end)
@  (output :into out)
@    (rep):@[email protected]@(first)@[email protected]@(end)
@  (end)
@  (cat out)
@(end)
@###
@# process arguments and list soundex codes
@###
@(collect :vars ())
@input
@  (output :filter (:fun soundex))
@input
@  (end)
@(end)
@###
@# compare first and second argument under soundex
@###
@(bind (first_arg second_arg . rest_args) input)
@(cases)
@  (bind first_arg second_arg :filter (:fun soundex))
@  (output)
"@first_arg" and "@second_arg" match under soundex
@  (end)
@(end)


' Soundex
    tt=array( _
      "Ashcraft","Ashcroft","Gauss","Ghosh","Hilbert","Heilbronn","Lee","Lloyd", _
      "Moses","Pfister","Robert","Rupert","Rubin","Tymczak","Soundex","Example")
    tv=array( _
      "A261","A261","G200","G200","H416","H416","L000","L300", _
      "M220","P236","R163","R163","R150","T522","S532","E251")
    For i=lbound(tt) To ubound(tt)
        ts=soundex(tt(i))
        If ts<>tv(i) Then ok=" KO "& tv(i) Else ok=""
        Wscript.echo right(" "& i ,2) & " " & left( tt(i) &space(12),12) & " " & ts & ok
    Next 'i

Function getCode(c)
    Select Case c
        Case "B", "F", "P", "V"
            getCode = "1"
        Case "C", "G", "J", "K", "Q", "S", "X", "Z"
            getCode = "2"
        Case "D", "T"
            getCode = "3"
        Case "L"
            getCode = "4"
        Case "M", "N"
            getCode = "5"
        Case "R"
            getCode = "6"
        Case "W","H"
            getCode = "-"
    End Select
End Function 'getCode

Function soundex(s)
    Dim code, previous, i
    code = UCase(Mid(s, 1, 1))
    previous = getCode(UCase(Mid(s, 1, 1)))
    For i = 2 To Len(s)
        current = getCode(UCase(Mid(s, i, 1)))
        If current <> "" And current <> "-" And current <> previous Then code = code & current
        If current <> "-" Then previous = current
    Next 'i
    soundex = Mid(code & "000", 1, 4)
End Function 'soundex


import "/str" for Char
import "/fmt" for Fmt

var getCode = Fn.new { |c|
    return "BFPV".contains(c)     ? "1" :
           "CGJKQSXZ".contains(c) ? "2" :
            c == "D" || c == "T"  ? "3" :
            c == "L"              ? "4" :
            c == "M" || c == "N"  ? "5" :
            c == "R"              ? "6" :
            c == "H" || c == "W"  ? "-" : ""
}

var soundex = Fn.new { |s|
    if (s == "") return ""
    var sb = Char.upper(s[0])
    var prev = getCode.call(sb[0])
    for (c in s.skip(1)) {
        var curr = getCode.call(Char.upper(c))
        if (curr != "" && curr != "-" && curr != prev) sb = sb + curr
        if (curr != "-") prev = curr
    }
    return Fmt.ljust(4, sb, "0")[0..3]
}

var pairs = [
    ["Ashcraft",  "A261"],
    ["Ashcroft",  "A261"],
    ["Gauss",     "G200"],
    ["Ghosh",     "G200"],
    ["Hilbert",   "H416"],
    ["Heilbronn", "H416"],
    ["Lee",       "L000"],
    ["Lloyd",     "L300"],
    ["Moses",     "M220"],
    ["Pfister",   "P236"],
    ["Robert",    "R163"],
    ["Rupert",    "R163"],
    ["Rubin",     "R150"],
    ["Tymczak",   "T522"],
    ["Soundex",   "S532"],
    ["Example",   "E251"]
]

for (pair in pairs) {
    Fmt.print("$-9s -> $s -> $s", pair[0], pair[1], soundex.call(pair[0]) == pair[1])
}


code CrLf=9, Text=12;
string 0;               \use zero-terminated strings

func Soundex(S1);       \Convert name to Soundex string (e.g: Rubin = R150)
char S1;
char S2(80), Tbl;
int  I, J, Char, Dig, Dig0;
[     \abcdefghijklmnopqrstuvwxyz
Tbl:= "01230120022455012623010202";
I:= 0;  J:= 0;                                  \convert all letters to digits
repeat  Char:= S1(I);  I:= I+1;
        if Char>=^A & Char<=^Z then             \convert letter to lowercase
            Char:= Char + $20;
        if Char>=^a & Char<=^z &                \eliminate non letters
           Char#^h & Char#^w then               \eliminate h and w
            [Dig:= Tbl(Char-^a);                \convert letter to digit
            if Dig#^0 & Dig#Dig0 ! J=0 then     \filter out zeros and doubles
                [S2(J):= Dig;  J:= J+1];        \ but always store first digit
            Dig0:= Dig;                         \save digit to detect doubles
            ];
until   S1(I) = 0;
while J<4 do [S2(J):= ^0;  J:= J+1];            \pad with zeros to get 3 digits
S2(0):= S1(0) & ~$20;  S2(4):= 0;               \insert first letter & terminate
return S2;                                      \BEWARE: very temporary string
];

int I, Name;
[Name:=["Ashcraft", "Ashcroft", "de la Rosa", "Gauss", "Ghosh", "Heilbronn",
        "Hilbert", "Knuth", "Lee", "Lloyd", "Moses", "O'Hara", "Pfister",
        "R2-D2", "Robert", "Rubin", "Rupert", "Tymczak", "Soundex", "Example"];
for I:= 0 to 20-1 do
        [Text(0, Soundex(Name(I)));  Text(0, " ");
        Text(0, Name(I));  CrLf(0);
        ];
]


F selection_sort(&lst)
   L(e) lst
      V mn = min(L.index .< lst.len, key' x -> @lst[x])
      (lst[L.index], lst[mn]) = (lst[mn], e)

V arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
selection_sort(&arr)
print(arr)


*        Selection sort            26/06/2016
SELECSRT CSECT
         USING  SELECSRT,R13       base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         LA     RJ,1               j=1
         DO WHILE=(C,RJ,LE,N)      do j=1 to n
         LR     RK,RJ                k=j
         LR     R1,RJ                j
         SLA    R1,2                 .
         LA     R3,A-4(R1)           @a(j)
         L      RT,0(R3)             temp=a(j)
         LA     RI,1(RJ)             i=j+1
         DO WHILE=(C,RI,LE,N)        do i=j+1 to n
         LR     R1,RI                  i
         SLA    R1,2                   .
         L      R2,A-4(R1)             a(i)
         IF CR,RT,GT,R2 THEN           if temp>a(i) then
         LR     RT,R2                    temp=a(i)
         LR     RK,RI                    k=i
         ENDIF  ,                      end if
         LA     RI,1(RI)               i=i+1
         ENDDO  ,                    end do
		 L      R0,0(R3)             a(j)
         LR     R1,RK                k
         SLA    R1,2                 .
         ST     R0,A-4(R1)           a(k)=a(j)
         ST     RT,0(R3)             a(j)=temp;
         LA     RJ,1(RJ)             j=j+1
         ENDDO  ,                  end do
         LA     R3,PG              pgi=0
         LA     RI,1               i=1
         DO     WHILE=(C,RI,LE,N)  do i=1 to n
         LR     R1,RI                i
         SLA    R1,2                 .
         L      R2,A-4(R1)           a(i)
         XDECO  R2,XDEC              edit a(i)
         MVC    0(4,R3),XDEC+8       output a(i)
         LA     R3,4(R3)             pgi=pgi+4
         LA     RI,1(RI)             i=i+1
         ENDDO  ,                  end do
         XPRNT  PG,L'PG            print buffer
         L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                exit
A     DC F'4',F'65',F'2',F'-31',F'0',F'99',F'2',F'83',F'782',F'1'
      DC F'45',F'82',F'69',F'82',F'104',F'58',F'88',F'112',F'89',F'74'
N        DC     A((N-A)/L'A)       number of items of a
PG       DC     CL80' '            buffer
XDEC     DS     CL12               temp for xdeco
         YREGS
RI       EQU    6                  i
RJ       EQU    7                  j
RK       EQU    8                  k
RT       EQU    9                  temp
         END    SELECSRT


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program selectionSort64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeConstantesARM64.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"

.align 4
#TableNumber:      .quad   1,3,6,2,5,9,10,8,4,7
TableNumber:     .quad   10,9,8,7,6,5,4,3,2,1
                 .equ NBELEMENTS, (. - TableNumber) / 8
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:       .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              // entry of program
    ldr x0,qAdrTableNumber                         // address number table
    mov x1,0
    mov x2,NBELEMENTS                              // number of élements
    bl selectionSort
    ldr x0,qAdrTableNumber                         // address number table
    bl displayTable

    ldr x0,qAdrTableNumber                         // address number table
    mov x1,NBELEMENTS                              // number of élements
    bl isSorted                                    // control sort
    cmp x0,1                                       // sorted ?
    beq 1f
    ldr x0,qAdrszMessSortNok                       // no !! error sort
    bl affichageMess
    b 100f
1:                                                 // yes
    ldr x0,qAdrszMessSortOk
    bl affichageMess
100:                                               // standard end of the program
    mov x0,0                                       // return code
    mov x8,EXIT                                    // request to exit program
    svc 0                                          // perform the system call

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!              // save  registers
    stp x3,x4,[sp,-16]!              // save  registers
    mov x2,0
    ldr x4,[x0,x2,lsl 3]
1:
    add x2,x2,1
    cmp x2,x1
    bge 99f
    ldr x3,[x0,x2, lsl 3]
    cmp x3,x4
    blt 98f
    mov x4,x3
    b 1b
98:
    mov x0,0                       // not sorted
    b 100f
99:
    mov x0,1                       // sorted
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*         selection sort                                              */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the first element    */
/* x2 contains the number of element */
selectionSort:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    stp x4,x5,[sp,-16]!              // save  registers
    stp x6,x7,[sp,-16]!              // save  registers
    mov x3,x1                        // start index i
    sub x7,x2,1                      // compute n - 1
1:                                   // start loop
    mov x4,x3
    add x5,x3,1                      // init index 2
2:
    ldr x1,[x0,x4,lsl 3]             // load value A[mini]
    ldr x6,[x0,x5,lsl 3]             // load value A[j]
    cmp x6,x1                        // compare value
    csel x4,x5,x4,lt                 // j -> mini
    add x5,x5,1                      // increment index j
    cmp x5,x2                        // end ?
    blt 2b                           // no -> loop
    cmp x4,x3                        // mini <> j ?
    beq 3f                           // no
    ldr x1,[x0,x4,lsl 3]             // yes swap A[i] A[mini]
    ldr x6,[x0,x3,lsl 3]
    str x1,[x0,x3,lsl 3]
    str x6,[x0,x4,lsl 3]
3:
    add x3,x3,1                      // increment i
    cmp x3,x7                        // end ?
    blt 1b                           // no -> loop

100:
    ldp x6,x7,[sp],16                // restaur  2 registers
    ldp x4,x5,[sp],16                // restaur  2 registers
    ldp x2,x3,[sp],16                // restaur  2 registers
    ldp x1,lr,[sp],16                // restaur  2 registers
    ret                              // return to address lr x30

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10                  // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc            // insert result at @ character
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
100:
    ldp x2,x3,[sp],16               // restaur  2 registers
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


PROC PrintArray(INT ARRAY a INT size)
  INT i

  Put('[)
  FOR i=0 TO size-1
  DO
    IF i>0 THEN Put(' ) FI
    PrintI(a(i))
  OD
  Put(']) PutE()
RETURN

PROC SelectionSort(INT ARRAY a INT size)
  INT i,j,minpos,tmp

  FOR i=0 TO size-2
  DO
    minpos=i
    FOR j=i+1 TO size-1
    DO
      IF a(minpos)>a(j) THEN
        minpos=j
      FI
    OD

    IF minpos#i THEN
      tmp=a(i)
      a(i)=a(minpos)
      a(minpos)=tmp
    FI
  OD
RETURN

PROC Test(INT ARRAY a INT size)
  PrintE("Array before sort:")
  PrintArray(a,size)
  SelectionSort(a,size)
  PrintE("Array after sort:")
  PrintArray(a,size)
  PutE()
RETURN

PROC Main()
  INT ARRAY
    a(10)=[1 4 65535 0 3 7 4 8 20 65530],
    b(21)=[10 9 8 7 6 5 4 3 2 1 0
      65535 65534 65533 65532 65531
      65530 65529 65528 65527 65526],
    c(8)=[101 102 103 104 105 106 107 108],
    d(12)=[1 65535 1 65535 1 65535 1
      65535 1 65535 1 65535]

  Test(a,10)
  Test(b,21)
  Test(c,8)
  Test(d,12)
RETURN


F is_sorted(arr)
   L(i) 1..arr.len-1
      I arr[i-1] > arr[i]
         R 0B
   R 1B

F permutation_sort(&arr)
   L !is_sorted(arr)
      arr.next_permutation()

V arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
permutation_sort(&arr)
print(arr)


function selectionSort(input: Array):Array {
	//find the i'th element
	for (var i:uint = 0; i < input.length; i++) {
		//set minIndex to an arbitrary value
		var minIndex:uint=i;
		//find the smallest number
		for (var j:uint = i; j < input.length; j++) {
			if (input[j]<input[minIndex]) {
				minIndex=j;
			}
		}
		//swap the smallest number into place
		var tmp:Number=input[i];
		input[i]=input[minIndex];
		input[minIndex]=tmp;
	}
	return input;
}


with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Selection_Sort is

   type Integer_Array is array (Positive range <>) of Integer;
   procedure Sort (A : in out Integer_Array) is
      Min  : Positive;
      Temp : Integer;
   begin
      for I in A'First..A'Last - 1 loop
         Min := I;
         for J in I + 1..A'Last loop
            if A (Min) > A (J) then
               Min := J;
            end if;
         end loop;
         if Min /= I then
            Temp    := A (I);
            A (I)   := A (Min);
            A (Min) := Temp;
         end if;
      end loop;
   end Sort;

   A : Integer_Array := (4, 9, 3, -2, 0, 7, -5, 1, 6, 8);
begin
   Sort (A);
   for I in A'Range loop
      Put (Integer'Image (A (I)) & " ");
   end loop;
end Test_Selection_Sort;


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program permutationSort64.s  */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeConstantesARM64.inc"

/*******************************************/
/* Structures                               */
/********************************************/
/* structure permutations  */
    .struct  0
perm_adrtable:                    // table value address
    .struct  perm_adrtable + 8
perm_size:                        // elements number
    .struct  perm_size + 8
perm_adrheap:                     // Init to zéro at the first call
    .struct  perm_adrheap + 8
perm_end:
/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessCounter:       .asciz "sorted in  @ permutations \n"
sMessResult:        .asciz "Value  : @ \n"

szCarriageReturn:   .asciz "\n"

.align 4
#TableNumber:      .quad   1,3,6,2,5,9,10,8,4,7,11
TableNumber:     .quad   10,9,8,7,6,-5,4,3,2,1
                 .equ NBELEMENTS, (. - TableNumber) / 8
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:       .skip 24
stPermutation:   .skip perm_end
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              // entry of program
    ldr x0,qAdrstPermutation                       // address structure permutation
    ldr x1,qAdrTableNumber                         // address number table
    str x1,[x0,perm_adrtable]
    mov x1,NBELEMENTS                              // elements number
    str x1,[x0,perm_size]
    mov x1,0                                       // first call
    str x1,[x0,perm_adrheap]
    mov x20,0                                      // counter
1:
    ldr x0,qAdrstPermutation                       // address structure permutation
    bl newPermutation                              // call for each permutation
    cmp x0,0                                       // end ?
    blt 99f                                        // yes -> error
    //bl displayTable                              // for display after each permutation
    add x20,x20,1                                  // increment counter
    ldr x0,qAdrTableNumber                         // address number table
    mov x1,NBELEMENTS                              // number of élements
    bl isSorted                                    // control sort
    cmp x0,1                                       // sorted ?
    bne 1b                                         // no -> loop

    ldr x0,qAdrTableNumber                         // address number table
    bl displayTable
    ldr x0,qAdrszMessSortOk                        // address OK message
    bl affichageMess
    mov x0,x20                                     // display counter
    ldr x1,qAdrsZoneConv
    bl conversion10S                               // décimal conversion
    ldr x0,qAdrsMessCounter
    ldr x1,qAdrsZoneConv                           // insert conversion
    bl strInsertAtCharInc
    bl affichageMess                               // display message
    b 100f
99:
    ldr x0,qAdrTableNumber                         // address number table
    bl displayTable
    ldr x0,qAdrszMessSortNok                       // address not OK message
    bl affichageMess
100:                                               // standard end of the program
    mov x0,0                                       // return code
    mov x8,EXIT                                    // request to exit program
    svc 0                                          // perform the system call

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrstPermutation:        .quad stPermutation
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
qAdrsMessCounter:         .quad sMessCounter
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!             // save  registers
    stp x3,x4,[sp,-16]!             // save  registers
    mov x2,0
    ldr x4,[x0,x2,lsl 3]
1:
    add x2,x2,1
    cmp x2,x1
    bge 99f
    ldr x3,[x0,x2, lsl 3]
    cmp x3,x4
    blt 98f
    mov x4,x3
    b 1b
98:
    mov x0,0                       // not sorted
    b 100f
99:
    mov x0,1                       // sorted
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/***************************************************/
/*   return permutation one by one                 */
/* sur une idée de vincent Moresmau                */
/* use algorytm heap iteratif see wikipedia        */
/***************************************************/
/* x0 contains the address of structure permutations */
/* x0 return address  of value table or zéro if end */
newPermutation:
    stp x1,lr,[sp,-16]!             // save  registers
    stp x2,x3,[sp,-16]!             // save  registers
    stp x4,x5,[sp,-16]!             // save  registers
    stp x6,x7,[sp,-16]!             // save  registers
    ldr x2,[x0,perm_adrheap]
    cmp x2,0
    bne 2f
                                    // first call -> init area on heap
    mov x7,x0
    ldr x1,[x7,perm_size]
    lsl x3,x1,3                     // 8 bytes by count table
    add x3,x3,8                     // 8 bytes for current index
    mov x0,0                        // allocation place heap
    mov x8,BRK                      // call system 'brk'
    svc 0
    mov x2,x0                       // save address heap
    add x0,x0,x3                    // reservation place
    mov x8,BRK                      // call system 'brk'
    svc #0
    cmp x0,-1                       // allocation error
    beq 100f
    add x8,x2,8                     // address begin area counters
    mov x3,0
1:                                  // loop init
    str xzr,[x8,x3,lsl 3]           // init to zéro area heap
    add x3,x3,1
    cmp x3,x1
    blt 1b
    str xzr,[x2]                    // store zero to index
    str x2,[x7,perm_adrheap]        // store heap address on structure permutation
    ldr x0,[x7,perm_adrtable]       // return first permutation
    b 100f

2:                                  // other calls x2 contains heap address
    mov x7,x0                       // structure address
    ldr x1,[x7,perm_size]           // elements number
    ldr x0,[x7,perm_adrtable]
    add x8,x2,8                     // begin address area count
    ldr x3,[x2]                     // load current index
3:
    ldr x4,[x8,x3,lsl 3]            // load count [i]
    cmp x4,x3                       // compare with i
    bge 6f
    tst x3,#1                       // even ?
    bne 4f
    ldr x5,[x0]                     // yes load value A[0]
    ldr x6,[x0,x3,lsl 3]            // and swap with value A[i]
    str x6,[x0]
    str x5,[x0,x3,lsl 3]
    b 5f
4:
    ldr x5,[x0,x4,lsl 3]            // no load value A[count[i]]
    ldr x6,[x0,x3,lsl 3]            // and swap with value A[i]
    str x6,[x0,x4,lsl 3]
    str x5,[x0,x3,lsl 3]
5:
    add x4,x4,1
    str x4,[x8,x3,lsl 3]            // store new count [i]
    str xzr,[x2]                    // store new index
    b 100f                          // and return new permutation in x0
6:
    str xzr,[x8,x3,lsl 3]           // store zero in count [i]
    add x3,x3,1                     // increment index
    cmp x3,x1                       // end
    blt 3b                          // loop
    mov x0,0                        // if end -> return zero

 100:                               // end function
    ldp x6,x7,[sp],16               // restaur  1 register
    ldp x4,x5,[sp],16               // restaur  1 register
    ldp x2,x3,[sp],16               // restaur  2 registers
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10S                  // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc            // insert result at // character
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
    mov x0,x2
100:
    ldp x2,x3,[sp],16               // restaur  2 registers
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


//recursively builds the permutations of permutable, appended to front, and returns the first sorted permutation it encounters
function permutations(front:Array, permutable:Array):Array {
	//If permutable has length 1, there is only one possible permutation. Check whether it's sorted
	if (permutable.length==1)
		return isSorted(front.concat(permutable));
	else
		//There are multiple possible permutations. Generate them.
		var i:uint=0,tmp:Array=null;
		do
		{
			tmp=permutations(front.concat([permutable[i]]),remove(permutable,i));
			i++;
		}while (i< permutable.length && tmp == null);
		//If tmp != null, it contains the sorted permutation. If it does not contain the sorted permutation, return null. Either way, return tmp.
		return tmp;
}
//returns the array if it's sorted, or null otherwise
function isSorted(data:Array):Array {
	for (var i:uint = 1; i < data.length; i++)
		if (data[i]<data[i-1])
			return null;
	return data;
}
//returns a copy of array with the i'th element removed
function remove(array:Array, i:uint):Array {
	return array.filter(function(item,index,array){return(index !=i)}) ;
}
//wrapper around the permutation function to provide a more logical interface
function permutationSort(array:Array):Array {
	return permutations([],array);
}


/* ARM assembly Raspberry PI  */
/*  program permutationSort.s  */

 /* REMARK 1 : this program use routines in a include file
   see task Include a file language arm assembly
   for the routine affichageMess conversion10
   see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes                       */
/************************************/
.include "../constantes.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"

.align 4
#TableNumber:      .int   1,3,6,2,5,9,10,8,5,7       @ for test 2 sames values
TableNumber:       .int   10,9,8,7,6,5,4,3,2,1
#TableNumber:       .int   1,2,3
                   .equ NBELEMENTS, (. - TableNumber) / 4
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              @ entry of program
    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements
    bl heapIteratif
    ldr r0,iAdrTableNumber                         @ address number table
    bl displayTable

    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements
    bl isSorted                                    @ control sort
    cmp r0,#1                                      @ sorted ?
    beq 2f
    ldr r0,iAdrszMessSortNok                       @ no !! error sort
    bl affichageMess
    b 100f
2:                                                 @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
100:                                               @ standard end of the program
    mov r0, #0                                     @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call

iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     permutation by heap iteratif (wikipedia)                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the eléments number  */
heapIteratif:
    push {r3-r9,lr}                @ save registers
    mov r8,r0                      @ save table address
    lsl r9,r1,#2                   @ four bytes by count
    sub sp,sp,r9
    mov fp,sp
    mov r3,#0
    mov r4,#0                      @ index
1:                                 @ init area counter
    str r4,[fp,r3,lsl #2]
    add r3,r3,#1
    cmp r3,r1
    blt 1b

    //bl displayTable
    bl isSorted                     @ control sort
    cmp r0,#1                       @ sorted ?
    beq 99f
    mov r0,r8                       @ restaur table address

    mov r3,#0                       @ index
2:
    ldr r4,[fp,r3,lsl #2]           @ load count [i]
    cmp r4,r3                       @ compare with i
    bge 5f
    tst r3,#1                       @ even ?
    bne 3f
    ldr r5,[r0]                     @ yes load value A[0]
    ldr r6,[r0,r3,lsl #2]           @ ans swap with value A[i]
    str r6,[r0]
    str r5,[r0,r3,lsl #2]
    b 4f
3:
    ldr r5,[r0,r4,lsl #2]         @ load value A[count[i]]
    ldr r6,[r0,r3,lsl #2]         @ and swap with value A[i]
    str r6,[r0,r4,lsl #2]
    str r5,[r0,r3,lsl #2]
4:
    //bl displayTable
    bl isSorted                     @ control sort
    cmp r0,#1                       @ sorted ?
    beq 99f                         @ yes
    mov r0,r8                       @ restaur table address
    add r4,r4,#1                    @ increment count i
    str r4,[fp,r3,lsl #2]           @ and store on stack
    mov r3,#0                       @ raz index
    b 2b                            @ and loop
5:
    mov r4,#0                       @ raz count [i]
    str r4,[fp,r3,lsl #2]
    add r3,r3,#1                    @ increment index
    cmp r3,r1                       @ end ?
    blt 2b                          @ no -> loop

99:
    add sp,sp,r9                    @ stack alignement
100:
    pop {r3-r9,lr}
    bx lr                           @ return
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}                 @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]
1:
    add r2,#1
    cmp r2,r1
    movge r0,#1
    bge 100f
    ldr r3,[r0,r2, lsl #2]
    cmp r3,r4
    movlt r0,#0
    blt 100f
    mov r4,r3
    b 1b
100:
    pop {r2-r4,lr}
    bx lr                            @ return

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsZoneConv                               @
    bl conversion10S                                    @ décimal conversion
    ldr r0,iAdrsMessResult
    ldr r1,iAdrsZoneConv                               @ insert conversion
    bl strInsertAtCharInc
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    mov r0,r2
100:
    pop {r0-r3,lr}
    bx lr
iAdrsZoneConv:           .int sZoneConv
/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"


MODE DATA = REF CHAR;

PROC in place selection sort = (REF[]DATA a)VOID:
BEGIN
   INT min;
   DATA temp;
   FOR i FROM LWB a TO UPB a DO
      min := i;
      FOR j FROM i + 1 TO UPB a DO
         IF a [min] > a [j] THEN
            min := j
         FI
      OD;
      IF min /= i THEN
         temp    := a [i];
         a [i]   := a [min];
         a [min] := temp
      FI
   OD
END # in place selection sort #;

[32]CHAR data := "big fjords vex quick waltz nymph";
[UPB data]DATA ref data;  FOR i TO UPB data DO ref data[i] := data[i] OD;
in place selection sort(ref data);
FOR i TO UPB ref data DO print(ref data[i]) OD; print(new line);
print((data))


on selectionSort(theList, l, r) -- Sort items l thru r of theList in place.
    set listLength to (count theList)
    if (listLength < 2) then return
    -- Convert negative and/or transposed range indices.
    if (l < 0) then set l to listLength + l + 1
    if (r < 0) then set r to listLength + r + 1
    if (l > r) then set {l, r} to {r, l}

    script o
        property lst : theList
    end script

    repeat with i from l to (r - 1)
        set iVal to o's lst's item i
        set minVal to iVal
        set minPos to i
        repeat with j from (i + 1) to r
            set jVal to o's lst's item j
            if (minVal > jVal) then
                set minVal to jVal
                set minPos to j
            end if
        end repeat
        set o's lst's item minPos to iVal
        set o's lst's item i to minVal
    end repeat

    return -- nothing.
end selectionSort
property sort : selectionSort

on demo()
    set theList to {988, 906, 151, 71, 712, 177, 945, 558, 31, 627}
    sort(theList, 1, -1)
    return theList
end demo

demo()


sorted?: function [arr][
    previous: first arr

    loop slice arr 1 (size arr)-1 'item [
        if not? item > previous -> return false
        previous: item
    ]
    return true
]

permutationSort: function [items][
    loop permutate items 'perm [
        if sorted? perm -> return perm
    ]
]

print permutationSort [3 1 2 8 5 7 9 4 6]


MsgBox % PermSort("")
MsgBox % PermSort("xxx")
MsgBox % PermSort("3,2,1")
MsgBox % PermSort("dog,000000,xx,cat,pile,abcde,1,cat")

PermSort(var) {                          ; SORT COMMA SEPARATED LIST
   Local i, sorted
   StringSplit a, var, `,                ; make array, size = a0

   v0 := a0                              ; auxiliary array for permutations
   Loop %v0%
      v%A_Index% := A_Index

   While unSorted("a","v")               ; until sorted
      NextPerm("v")                      ; try new permutations

   Loop % a0                             ; construct string from sorted array
      i := v%A_Index%, sorted .= "," . a%i%
   Return SubStr(sorted,2)               ; drop leading comma
}

unSorted(a,v) {
   Loop % %a%0-1 {
      i := %v%%A_Index%, j := A_Index+1, j := %v%%j%
      If (%a%%i% > %a%%j%)
         Return 1
   }
}

NextPerm(v) { ; the lexicographically next LARGER permutation of v1..v%v0%
   Local i, i1, j, t
   i := %v%0, i1 := i-1
   While %v%%i1% >= %v%%i% {
      --i, --i1
      IfLess i1,1, Return 1 ; Signal the end
   }
   j := %v%0
   While %v%%j% <= %v%%i1%
      --j
   t := %v%%i1%, %v%%i1% := %v%%j%, %v%%j% := t,  j := %v%0
   While i < j
      t := %v%%i%, %v%%i% := %v%%j%, %v%%j% := t, ++i, --j
}


/* ARM assembly Raspberry PI  */
/*  program selectionSort.s   */

/************************************/
/* Constantes                       */
/************************************/
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall
/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .ascii "Value  : "
sMessValeur:        .fill 11, 1, ' '            @ size => 11
szCarriageReturn:  .asciz "\n"

.align 4
iGraine:  .int 123456
.equ NBELEMENTS,      10
#TableNumber:      .int   1,3,6,2,5,9,10,8,4,7
TableNumber:     .int   10,9,8,7,6,5,4,3,2,1
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                              @ entry of program

1:
    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#0
    mov r2,#NBELEMENTS                             @ number of élements
    bl selectionSort
    ldr r0,iAdrTableNumber                         @ address number table
    bl displayTable

    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements
    bl isSorted                                    @ control sort
    cmp r0,#1                                      @ sorted ?
    beq 2f
    ldr r0,iAdrszMessSortNok                       @ no !! error sort
    bl affichageMess
    b 100f
2:                                                 @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
100:                                               @ standard end of the program
    mov r0, #0                                     @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call

iAdrsMessValeur:          .int sMessValeur
iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     control sorted table                                   */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}                                    @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]
1:
    add r2,#1
    cmp r2,r1
    movge r0,#1
    bge 100f
    ldr r3,[r0,r2, lsl #2]
    cmp r3,r4
    movlt r0,#0
    blt 100f
    mov r4,r3
    b 1b
100:
    pop {r2-r4,lr}
    bx lr                                              @ return
/******************************************************************/
/*         selection sort                                              */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the first element    */
/* r2 contains the number of element */
selectionSort:
    push {r1-r7,lr}                                        @ save registers
    mov r3,r1                                              @ start index i
    sub r7,r2,#1                                           @ compute n - 1
1:                                                         @ start loop
    mov r4,r3
    add r5,r3,#1                                           @ init index 2
2:
    ldr r1,[r0,r4,lsl #2]                                  @ load value A[mini]
    ldr r6,[r0,r5,lsl #2]                                  @ load value A[j]
    cmp r6,r1                                              @ compare value
    movlt r4,r5                                            @ j -> mini
    add r5,#1                                              @ increment index j
    cmp r5,r2                                              @ end ?
    blt 2b                                                 @ no -> loop
    cmp r4,r3                                              @ mini <> j ?
    beq 3f                                                 @ no
    ldr r1,[r0,r4,lsl #2]                                  @ yes swap A[i] A[mini]
    ldr r6,[r0,r3,lsl #2]
    str r1,[r0,r3,lsl #2]
    str r6,[r0,r4,lsl #2]
3:
    add r3,#1                                              @ increment i
    cmp r3,r7                                              @ end ?
    blt 1b                                                 @ no -> loop

100:
    pop {r1-r7,lr}
    bx lr                                                  @ return

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsMessValeur                             @ display value
    bl conversion10                                    @ call function
    ldr r0,iAdrsMessResult
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
100:
    pop {r0-r3,lr}
    bx lr
/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                          @ save  registres
    mov r2,#0                                      @ counter length
1:                                                 @ loop length calculation
    ldrb r1,[r0,r2]                                @ read octet start position + index
    cmp r1,#0                                      @ if 0 its over
    addne r2,r2,#1                                 @ else add 1 in the length
    bne 1b                                         @ and loop
                                                   @ so here r2 contains the length of the message
    mov r1,r0                                      @ address message in r1
    mov r0,#STDOUT                                 @ code to write to the standard output Linux
    mov r7, #WRITE                                 @ code call system "write"
    svc #0                                         @ call systeme
    pop {r0,r1,r2,r7,lr}                           @ restaur des  2 registres */
    bx lr                                          @ return
/******************************************************************/
/*     Converting a register to a decimal unsigned                */
/******************************************************************/
/* r0 contains value and r1 address area   */
/* r0 return size of result (no zero final in area) */
/* area size => 11 bytes          */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                                 @ save registers
    mov r3,r1
    mov r2,#LGZONECAL

1:	                                            @ start loop
    bl divisionpar10U                               @ unsigned  r0 <- dividende. quotient ->r0 reste -> r1
    add r1,#48                                      @ digit
    strb r1,[r3,r2]                                 @ store digit on area
    cmp r0,#0                                       @ stop if quotient = 0
    subne r2,#1                                     @ else previous position
    bne 1b	                                    @ and loop
                                                    @ and move digit from left of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]
    add r2,#1
    add r4,#1
    cmp r2,#LGZONECAL
    ble 2b
                                                      @ and move spaces in end on area
    mov r0,r4                                         @ result length
    mov r1,#' '                                       @ space
3:
    strb r1,[r3,r4]                                   @ store space in area
    add r4,#1                                         @ next position
    cmp r4,#LGZONECAL
    ble 3b                                            @ loop if r4 <= area size

100:
    pop {r1-r4,lr}                                    @ restaur registres
    bx lr                                             @return

/***************************************************/
/*   division par 10   unsigned                    */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */
/* r1 remainder  */
divisionpar10U:
    push {r2,r3,r4, lr}
    mov r4,r0                                          @ save value
    //mov r3,#0xCCCD                                   @ r3 <- magic_number lower  raspberry 3
    //movt r3,#0xCCCC                                  @ r3 <- magic_number higter raspberry 3
    ldr r3,iMagicNumber                                @ r3 <- magic_number    raspberry 1 2
    umull r1, r2, r3, r0                               @ r1<- Lower32Bits(r1*r0) r2<- Upper32Bits(r1*r0)
    mov r0, r2, LSR #3                                 @ r2 <- r2 >> shift 3
    add r2,r0,r0, lsl #2                               @ r2 <- r0 * 5
    sub r1,r4,r2, lsl #1                               @ r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10)
    pop {r2,r3,r4,lr}
    bx lr                                              @ leave function
iMagicNumber:  	.int 0xCCCCCCCD


      DIM test(9)
      test() = 4, 65, 2, 31, 0, 99, 2, 83, 782, 1

      perms% = 0
      WHILE NOT FNsorted(test())
        perms% += 1
        PROCnextperm(test())
      ENDWHILE
      PRINT ;perms% " permutations required to sort "; DIM(test(),1)+1 " items."
      END

      DEF PROCnextperm(a())
      LOCAL last%, maxindex%, p%
      maxindex% = DIM(a(),1)
      IF maxindex% < 1 THEN ENDPROC
      p% = maxindex%-1
      WHILE a(p%) >= a(p%+1)
        p% -= 1
        IF p% < 0 THEN
          PROCreverse(a(), 0, maxindex%)
          ENDPROC
        ENDIF
      ENDWHILE
      last% = maxindex%
      WHILE a(last%) <= a(p%)
        last% -= 1
      ENDWHILE
      SWAP a(p%), a(last%)
      PROCreverse(a(), p%+1, maxindex%)
      ENDPROC

      DEF PROCreverse(a(), first%, last%)
      WHILE first% < last%
        SWAP a(first%), a(last%)
        first% += 1
        last% -= 1
      ENDWHILE
      ENDPROC

      DEF FNsorted(d())
      LOCAL I%
      FOR I% = 1 TO DIM(d(),1)
        IF d(I%) < d(I%-1) THEN = FALSE
      NEXT
      = TRUE


#include <stdio.h>
#include <stdlib.h>
#include <string.h>

typedef int(*cmp_func)(const void*, const void*);

void perm_sort(void *a, int n, size_t msize, cmp_func _cmp)
{
	char *p, *q, *tmp = malloc(msize);
#	define A(i) ((char *)a + msize * (i))
#	define swap(a, b) {\
		memcpy(tmp, a, msize);\
		memcpy(a, b, msize);\
		memcpy(b, tmp, msize);	}
	while (1) {
		/* find largest k such that a[k - 1] < a[k] */
		for (p = A(n - 1); (void*)p > a; p = q)
			if (_cmp(q = p - msize, p) > 0)
				break;

		if ((void*)p <= a) break;

		/* find largest l such that a[l] > a[k - 1] */
		for (p = A(n - 1); p > q; p-= msize)
			if (_cmp(q, p) > 0) break;

		swap(p, q); /* swap a[k - 1], a[l] */
		/* flip a[k] through a[end] */
		for (q += msize, p = A(n - 1); q < p; q += msize, p -= msize)
			swap(p, q);
	}
	free(tmp);
}

int scmp(const void *a, const void *b) { return strcmp(*(const char *const *)a, *(const char *const *)b); }

int main()
{
	int i;
	const char *strs[] = { "spqr", "abc", "giant squid", "stuff", "def" };
	perm_sort(strs, 5, sizeof(*strs), scmp);

	for (i = 0; i < 5; i++)
		printf("%s\n", strs[i]);
	return 0;
}


selectionSort: function [items][
    sorted: new []
    tmp: new items
    while [not? empty? tmp][
        minIndex: index tmp min tmp
        'sorted ++ tmp\[minIndex]
        remove 'tmp .index minIndex
    ]
    return sorted
]

print selectionSort [3 1 2 8 5 7 9 4 6]


MsgBox % SelecSort("")
MsgBox % SelecSort("xxx")
MsgBox % SelecSort("3,2,1")
MsgBox % SelecSort("dog,000000,xx,cat,pile,abcde,1,cat,zz,xx,z")

SelecSort(var) {                         ; SORT COMMA SEPARATED LIST
   StringSplit a, var, `,                ; make array, size = a0

   Loop % a0-1 {
      i := A_Index, mn := a%i%, j := m := i
      Loop % a0-i {                      ; find minimum
          j++
          If (a%j% < mn)
             mn := a%j%, m := j
      }
      t := a%i%, a%i% := a%m%, a%m% := t ; swap first with minimum
   }
   Loop % a0                             ; construct string from sorted array
      sorted .= "," . a%A_Index%
   Return SubStr(sorted,2)               ; drop leading comma
}


public static class PermutationSorter
{
    public static void Sort<T>(List<T> list) where T : IComparable
    {
        PermutationSort(list, 0);
    }
    public static bool PermutationSort<T>(List<T> list, int i) where T : IComparable
    {
        int j;
        if (issorted(list, i))
        {
            return true;
        }
        for (j = i + 1; j < list.Count; j++)
        {
            T temp = list[i];
            list[i] = list[j];
            list[j] = temp;
            if (PermutationSort(list, i + 1))
            {
                return true;
            }
            temp = list[i];
            list[i] = list[j];
            list[j] = temp;
        }
        return false;
    }
    public static bool issorted<T>(List<T> list, int i) where T : IComparable
    {
	    for (int j = list.Count-1; j > 0; j--)
        {
	        if(list[j].CompareTo(list[j-1])<0)
            {
		        return false;
	        }
	    }
	    return true;
    }
}


#include <algorithm>

template<typename ForwardIterator>
 void permutation_sort(ForwardIterator begin, ForwardIterator end)
{
  while (std::next_permutation(begin, end))
  {
    // -- this block intentionally left empty --
  }
}


function getminindex(gl, gi, gs)
{
  min = gl[gi]
  gm = gi
  for(gj=gi; gj <= gs; gj++) {
    if ( gl[gj] < min ) {
      min = gl[gj]
      gm = gj
    }
  }
  return gm
}

{
  line[NR] = $0
}
END { # sort it with selection sort
  for(i=1; i <= NR; i++) {
    mi = getminindex(line, i, NR)
    t = line[i]
    line[i] = line[mi];
    line[mi] = t
  }
  #print it
  for(i=1; i <= NR; i++) {
    print line[i]
  }
}


DEF PROC_SelectionSort(Size%)
FOR I% = 1 TO Size%-1
   lowest% = I%
   FOR J% = (I% + 1) TO Size%
      IF data%(J%) < data%(lowest%) lowest% = J%
   NEXT J%
   IF I%<>lowest% SWAP data%(I%),data%(lowest%)
NEXT I%
ENDPROC


(use '[clojure.contrib.combinatorics :only (permutations)])

(defn permutation-sort [s]
  (first (filter (partial apply <=) (permutations s))))

(permutation-sort [2 3 5 3 5])