const BARS: &'static str = "▁▂▃▄▅▆▇█";

fn print_sparkline(s: &str){
    let v = BARS.chars().collect::<Vec<char>>();
    let line: String = s.replace(",", " ").split(" ")
                            .filter(|x| !x.is_empty())
                            .map(|x| v[x.parse::<f64>().unwrap().ceil() as usize - 1])
                            .collect();
    println!("{:?}", line);
}

fn main(){
    let s1 = "1 2 3 4 5 6 7 8 7 6 5 4 3 2 1";
    print_sparkline(s1);
    let s2 = "1.5, 0.5 3.5, 2.5 5.5, 4.5 7.5, 6.5";
    print_sparkline(s2);
}


% Just to demonstrate alternate ways of defining unicode:
private variable spchrs = "\u{2581}\u{2582}\u{2583}\u{2584}\u{2585}\u{2586}\u{2587}\u{2588}";
private variable spchrs_alt = "▁▂▃▄▅▆▇█";

define sparkline(arrstr)
{
    variable a = strtok(arrstr, " \t,"), alen = length(a), out = "";
    a = atof(a);
    variable amin = min(a), amax = max(a), span = amax - amin, i, d;

    _for i (0, alen-1, 1)
        if (span != 0) {
            % int() truncates; adding .5 here to round:
            d = int((a[i] - amin) * 7.0 / span + 0.5);
            out += substr(spchrs, d+1, 1);
        }
        else
            out += substr(spchrs, 4, 1);

    print(out);
}

if (not _slang_utf8_ok) error("Sorry, UTF8 mode is not on.");
sparkline("1 2 3 4 5 6 7 8 7 6 5 4 3 2 1");
sparkline("1.5, 0.5 3.5, 2.5 5.5, 4.5 7.5, 6.5 ");


def mkSparks( numStr:String ) : String =
  numStr.split( "[\\s,]+" ).map(_.toFloat) match {
    case v if v.isEmpty => ""
    case v if v.length == 1 => "\u2581"
    case v =>
      (for( i <- v;
            s = "\u2581\u2582\u2583\u2584\u2585\u2586\u2587\u2588".toCharArray;
            d = (v.max - v.min) / (s.length - 1)
       ) yield s( ((i - v.min) / d).toInt)).mkString
  }

println( mkSparks( "1 2 3 4 5 6 7 8 7 6 5 4 3 2 1" ) )
println( mkSparks( "1.5, 0.5 3.5, 2.5 5.5, 4.5 7.5, 6.5" ) )

// A random test...
println( mkSparks( Stream.continually( math.abs(util.Random.nextInt % 8)).take(64).mkString(" ") ))


/*REXX program sorts  an  integer array   @.   [the first element starts at index zero].*/
parse arg N .                                    /*obtain an optional argument from C.L.*/
if N=='' | N==","  then N=19                     /*Not specified?  Then use the default.*/
call [email protected]                                        /*generate a type of scattered array.  */
call show    'before sort'                       /*show the   before   array elements.  */
say copies('▒', wN+wV+ 50)                       /*show a separator line (between shows)*/
call stoogeSort  0, N                            /*invoke the  Stooge Sort.             */
call show    ' after sort'                       /*show the    after   array elements.  */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
[email protected]: wV= 0;   do k=0  to N;      @.k= k*2 + k*-1**k;     if @.k//7==0  then @.k= -100 - k
               wV= max(wV, length(@.k) );  end;        wN=length(N);                return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: do j=0 to N; say right('element',22) right(j,wN) arg(1)":" right(@.j,wV); end;return
/*──────────────────────────────────────────────────────────────────────────────────────*/
stoogeSort: procedure expose @.;  parse arg i,j                  /*sort from  I ───► J. */
            if @.j<@.i  then parse value @.i @.j  with  @.j @.i  /*swap  @.i  with  @.j */
            if j-i>1    then do;   t=(j-i+1) % 3                 /*%:  integer division.*/
                                   call stoogeSort  i  ,  j-t    /*invoke recursively.  */
                                   call stoogeSort  i+t,  j      /*   "        "        */
                                   call stoogeSort  i  ,  j-t    /*   "        "        */
                             end
            return


test = [4, 65, 2, -31, 0, 99, 2, 83, 782, 1]
stoogeSort(test, 1, len(test))
for i = 1 to 10
    see "" + test[i] + " "
next
see nl

func stoogeSort list, i, j
     if list[j] < list[i]
        temp = list[i]
        list[i] = list[j]
        list[j] = temp ok
     if j - i > 1
        t = (j - i + 1)/3
        stoogeSort(list, i, j-t)
        stoogeSort(list, i+t, j)
        stoogeSort(list, i, j-t) ok
     return list


class Array
  def stoogesort
    self.dup.stoogesort!
  end

  def stoogesort!(i = 0, j = self.length-1)
    if self[j] < self[i]
      self[i], self[j] = self[j], self[i]
    end
    if j - i > 1
      t = (j - i + 1)/3
      stoogesort!(i, j-t)
      stoogesort!(i+t, j)
      stoogesort!(i, j-t)
    end
    self
  end
end

p [1,4,5,3,-6,3,7,10,-2,-5].stoogesort


// version 1.1.0

val gaps = listOf(701, 301, 132, 57, 23, 10, 4, 1)  // Marcin Ciura's gap sequence

fun shellSort(a: IntArray) {
    for (gap in gaps) {
        for (i in gap until a.size) {
            val temp = a[i]
            var j = i
            while (j >= gap && a[j - gap] > temp) {
                a[j] = a[j - gap]
                j -= gap
            }
            a[j] = temp
        }
    }
}

fun main(args: Array<String>) {
    val aa = arrayOf(
        intArrayOf(100, 2, 56, 200, -52, 3, 99, 33, 177, -199),
        intArrayOf(4, 65, 2, -31, 0, 99, 2, 83, 782, 1),
        intArrayOf(62, 83, 18, 53, 7, 17, 95, 86, 47, 69, 25, 28)
    )
    for (a in aa) {
        shellSort(a)
        println(a.joinToString(", "))
    }
}


siz = 100
dim a(siz)
for i = 1 to siz
 a(i) = int(rnd(1) * 1000)
next

' -------------------------------
' Shell Sort
' -------------------------------
   incr = int(siz / 2)
   WHILE incr > 0
         for i = 1 to siz
            j    = i
            temp = a(i)
               WHILE (j >= incr+1 and a(abs(j-incr)) > temp)
               a(j) = a(j-incr)
               j    = j - incr
               wend
            a(j) = temp
         next
         IF incr = 2 THEN
            incr = 1
         ELSE
            incr = int(incr * (5 / 11))
        end if
    WEND

for i = 1 to siz
print a(i)
next


$ include "seed7_05.s7i";
  include "scanfile.s7i";
  include "float.s7i";
  include "utf8.s7i";

const func array float: readDataLine is func
  result
    var array float: data is 0 times 0.0;
  begin
    write("Numbers separated by anything: ");
    IN.bufferChar := getc(IN);
    skipSpace(IN);
    while IN.bufferChar <> '\n' do
      data &:= float parse getNumber(IN);
      skipSpace(IN);
      if IN.bufferChar = ',' then
        IN.bufferChar := getc(IN);
      end if;
      skipSpace(IN);
    end while;
  end func;

const proc: main is func
  local
    const string: bars is "▁▂▃▄▅▆▇█";
    var array float: data is 0 times 0.0;
    var float: min is 0.0;
    var float: max is 0.0;
    var float: number is 0.0;
    var integer: index is 0;
  begin
    OUT := STD_UTF8_OUT;
    data  := readDataLine;
    while length(data) >= 1 do
      min := data[1];
      max := data[1];
      for number range data do
        if number < min then
          min := number;
        end if;
        if number > max then
          max := number;
        end if;
      end for;
      for number range data do
        index := succ(min(trunc((number - min) * 8.0 / max), 7));
        write(bars[index]);
      end for;
      writeln;
      data  := readDataLine;
    end while;
  end func;


put sparklineGraph of "1 2 3 4 5 6 7 8 7 6 5 4 3 2 1"
put sparklineGraph of "1.5, 0.5 3.5, 2.5 5.5, 4.5 7.5, 6.5"
put sparklineGraph of "0, 1, 19, 20"
put sparklineGraph of "0, 999, 4000, 4999, 7000, 7999"

to handle sparklineGraph of input
	put each word delimited by " ," of input into numbers
	put the lowestValue of numbers into bottom
	put the highestValue of numbers into top
	put top - bottom into range -- total range of values
	put range/8 into step -- the size of each incremental step in the graph

	repeat with each number in numbers
		put (trunc((number - bottom) / step) + 1) but no more than 8 into symbolNum
		put character symbolNum of "▁▂▃▄▅▆▇█" after graph
	end repeat
	put !" (range: [[bottom]] to [[top]])" after graph
	return graph
end sparklineGraph


var bar = @('▁'..'█');
loop {
    print 'Numbers, please, separated by space/commas: ';
    var numbers = read(String).trim.split(/[\s,]+/).map{.to_n};
    var (min, max) = numbers.minmax;
    say "min: %5f; max: %5f"%(min, max);
    var div = ((max - min) / bar.end);
    say (min == max ? bar.last*numbers.len : numbers.map{|num| bar[(num - min) / div]}.join);
}


package require Tcl 8.6

proc extractValues {series} {
    return [regexp -all -inline {\d+(?:\.\d*)?|\.\d+} $series]
}
proc renderValue {min max value} {
    set band [expr {int(8*($value-$min)/(($max-$min)*1.01))}]
    return [format "%c" [expr {0x2581 + $band}]]
}
proc sparkline {series} {
    set values [extractValues $series]
    set min [tcl::mathfunc::min {*}$values]
    set max [tcl::mathfunc::max {*}$values]
    return [join [lmap v $values {renderValue $min $max $v}] ""]
}


fn stoogesort<E>(a: &mut [E])
    where E: PartialOrd
{
    let len = a.len();

    if a.first().unwrap() > a.last().unwrap() {
        a.swap(0, len - 1);
    }
    if len - 1 > 1 {
        let t = len / 3;
        stoogesort(&mut a[..len - 1]);
        stoogesort(&mut a[t..]);
        stoogesort(&mut a[..len - 1]);
    }
}

fn main() {
    let mut numbers = vec![1_i32, 9, 4, 7, 6, 5, 3, 2, 8];
    println!("Before: {:?}", &numbers);
    stoogesort(&mut numbers);
    println!("After: {:?}", &numbers);
}


object StoogeSort extends App {
  def stoogeSort(a: Array[Int], i: Int, j: Int) {
    if (a(j) < a(i)) {
      val temp = a(j)
      a(j) = a(i)
      a(i) = temp
    }
    if (j - i > 1) {
      val t = (j - i + 1) / 3
      stoogeSort(a, i, j - t)
      stoogeSort(a, i + t, j)
      stoogeSort(a, i, j - t)
    }
  }

  val a = Array(100, 2, 56, 200, -52, 3, 99, 33, 177, -199)
  println(s"Original : ${a.mkString(", ")}")
  stoogeSort(a, 0, a.length - 1)
  println(s"Sorted   : ${a.mkString(", ")}")
}


func stooge(x, i, j) {
    if (x[j] < x[i]) {
        x.swap(i, j)
    }

    if (j-i > 1) {
        var t = ((j - i + 1) / 3)
        stooge(x, i,     j - t)
        stooge(x, i + t, j    )
        stooge(x, i,     j - t)
    }
}

var a = 10.of { 100.irand }

say "Before #{a}"
stooge(a, 0, a.end)
say "After  #{a}"


Section Header

+ name := SHELL_SORT;

- external := `#include <time.h>`;

Section Public

- main <- (
  + a : ARRAY[INTEGER];

  a := ARRAY[INTEGER].create 0 to 100;
  `srand(time(NULL))`;
  0.to 100 do { i : INTEGER;
    a.put `rand()`:INTEGER to i;
  };

  shell a;

  a.foreach { item : INTEGER;
    item.print;
    '\n'.print;
  };
);

- shell a : ARRAY[INTEGER] <- (
  + lower, length, increment, temp : INTEGER;

  lower := a.lower;
  length := a.upper - lower + 1;
  increment := length;
  {
    increment := increment / 2;
    increment > 0
  }.while_do {
    increment.to (length - 1) do { i : INTEGER; + j : INTEGER;
      temp := a.item(lower + i);
      j := i - increment;
      { (j >= 0) && { a.item(lower + j) > temp } }.while_do {
        a.put (a.item(lower + j)) to (lower + j + increment);
        j := j - increment;
      };
      a.put temp to (lower + j + increment);
    };
  };
);


function shellsort( a )
    local inc = math.ceil( #a / 2 )
    while inc > 0 do
        for i = inc, #a do
            local tmp = a[i]
            local j = i
            while j > inc and a[j-inc] > tmp do
                a[j] = a[j-inc]
                j = j - inc
            end
            a[j] = tmp
        end
        inc = math.floor( 0.5 + inc / 2.2 )
    end

    return a
end

a = { -12, 3, 0, 4, 7, 4, 8, -5, 9 }
a = shellsort( a )

for _, i in pairs(a) do
    print(i)
end


Module ShellSortExample {
      Module shellsort(&a()) {
            DEf h%, i%, j%, k, n%
            n%=LEN(a())
            h% = n%
            WHILE h% {
                    IF h% = 2  THEN {h% = 1 }ELSE h%= h% DIV 2.2
                    FOR i% = h% TO n% - 1
                      k = a(i%)
                      j% = i%
                      WHILE j% >= h% AND k < a(ABS(j% - h%)) {
                              a(j%) = a(j% - h%)
                              j% -= h%
                        }
                      a(j%) = k
                    NEXT i%
            }
      }

      Dim numbers(10)
      numbers(0)=4, 65, 2, -31, 0, 99, 2, 83, 782, 1
      shellsort &numbers()
      Print numbers()
}
ShellSortExample


import "io" for Stdin, Stdout
import "/pattern" for Pattern

var p = Pattern.new("[,+1/s|+1/s,|+1/s|,]")

var spark = Fn.new { |s0|
    var ss = p.splitAll(s0)
    var n = ss.count
    var vs = List.filled(n, 0)
    var min = 1/0
    var max = -min
    var i = 0
    for (s in ss) {
        var v = Num.fromString(s)
        if (v.isNan || v.isInfinity) Fiber.abort("Infinities and NaN not supported.")
        if (v < min) min = v
        if (v > max) max = v
        vs[i] = v
        i = i + 1
    }
    var sp
    if (min == max) {
        sp = "▄" * n
    } else {
        var rs = List.filled(n, null)
        var f = 8 / (max - min)
        var j = 0
        for (v in vs) {
            var i = (f * (v - min)).floor
            if (i > 7) i = 7
            rs[j] = String.fromCodePoint(0x2581 + i)
            j = j + 1
        }
        sp = rs.join()
    }
    return [sp, n, min, max]
}

while (true) {
    System.print("Numbers please separated by spaces/commas or just press return to quit:")
    Stdout.flush()
    var numbers = Stdin.readLine().trim()
    if (numbers == "") break
    var res = spark.call(numbers)
    var s = res[0]
    var n = res[1]
    var min = res[2]
    var max = res[3]
    if (n == 1) {
        System.print("1 value = %(min)")
    } else {
        System.print("%(n) values.  Min: %(min) Max: %(max)")
    }
    System.print(s)
    System.print()
}


OrderedCollection extend [
    stoogeSortFrom: i to: j [
	(self at: j) < (self at: i)
	  ifTrue: [ self swapElement: i with: j ].
	j - i > 1
          ifTrue: [
	      |t| t := (j - i + 1)//3.
	      self stoogeSortFrom: i to: (j-t).
	      self stoogeSortFrom: (i+t) to: j.
	      self stoogeSortFrom: i to: (j-t)
          ]
    ]
    stoogeSort [ self stoogeSortFrom: 1 to: (self size) ]
    swapElement: i with: j [
	|t| t := self at: i.
        self at: i put: (self at: j).
	self at: j put: t
    ]
].

|test|
test := #( 1 4 5 3 -6 3 7 10 -2 -5) asOrderedCollection.
test stoogeSort.
test printNl.


func stoogeSort(inout arr:[Int], _ i:Int = 0, var _ j:Int = -1) {
    if j == -1 {
        j = arr.count - 1
    }

    if arr[i] > arr[j] {
        swap(&arr[i], &arr[j])
    }

    if j - i > 1 {
        let t = (j - i + 1) / 3
        stoogeSort(&arr, i, j - t)
        stoogeSort(&arr, i + t, j)
        stoogeSort(&arr, i, j - t)
    }
}

var a = [-4, 2, 5, 2, 3, -2, 1, 100, 20]

stoogeSort(&a)

println(a)


package require Tcl 8.5

proc stoogesort {L {i 0} {j -42}} {
   if {$j == -42} {# Magic marker
      set j [expr {[llength $L]-1}]
   }
   set Li [lindex $L $i]
   set Lj [lindex $L $j]
   if {$Lj < $Li} {
      lset L $i $Lj
      lset L $j $Li
   }
   if {$j-$i > 1} {
      set t [expr {($j-$i+1)/3}]
      set L [stoogesort $L $i [expr {$j-$t}]]
      set L [stoogesort $L [expr {$i+$t}] $j]
      set L [stoogesort $L $i [expr {$j-$t}]]
   }
   return $L
}

stoogesort {1 4 5 3 -6 3 7 10 -2 -5}


shellsort := proc(arr)
	local n, gap, i, val, j;
	n := numelems(arr):
	gap := trunc(n/2):
	while (gap > 0) do #notice by 1 error
		for i from gap to n by 1 do
			val := arr[i];
			j := i;
			while (j > gap and arr[j-gap] > val) do
				arr[j] := arr[j-gap];
				j -= gap;
			end do;
			arr[j] := val;
		end do;
		gap := trunc(gap/2);
	end do;
end proc;
arr := Array([17,3,72,0,36,2,3,8,40,0]);
shellsort(arr);
arr;


shellSort[ lst_ ] := Module[ {list = lst, incr, temp, i, j},
 incr = Round[Length[list]/2];
 While[incr > 0,

  For[i = incr + 1, i <= Length[list], i++,

   temp = list[[i]]; j = i;

   While[(j >= (incr + 1)) && (list[[j - incr]] > temp) ,
    list[[j]] = list[[j - incr]];  j = j-incr;
   ];

   list[[j]] = temp;];
   If[incr == 2, incr = 1, incr = Round[incr/2.2]]
];  list
]


function list = shellSort(list)

    N = numel(list);
    increment = round(N/2);

    while increment > 0

        for i = (increment+1:N)
            temp = list(i);
            j = i;
            while (j >= increment+1) && (list(j-increment) > temp)
                list(j) = list(j-increment);
                j = j - increment;
            end

            list(j) = temp;

        end %for

        if increment == 2 %This case causes shell sort to become insertion sort
            increment = 1;
        else
            increment = round(increment/2.2);
        end
    end %while
end %shellSort


var sparks=[0x2581..0x2588].apply("toString",-8); // int.toString(-8)-->UTF-8
var sl=(sparks.len()-1);

fcn sparkLine(xs){
   min:=(0.0).min(xs); max:=(0.0).max(xs);  // min/max are float reguardless of xs
   range:=max-min;  // float
   println("Range [",min,"-",max,"]", xs);
   xs.pump(String,'wrap(x){ sparks[(x - min)*sl/range] }).println();
}


PRINT "Stooge sort:"
  n = FUNC (_InitArray)
  PROC _ShowArray (n)
  PROC _Stoogesort (n)
  PROC _ShowArray (n)
PRINT

END

_InnerStooge PARAM(2)                  ' Stoogesort
  LOCAL(1)

  IF @([email protected]) < @([email protected]) Then Proc _Swap ([email protected], [email protected])
  IF [email protected] - [email protected] > 1 THEN
    [email protected] = ([email protected] - [email protected] + 1)/3
    PROC _InnerStooge ([email protected], [email protected]@)
    PROC _InnerStooge ([email protected][email protected], [email protected])
    PROC _InnerStooge ([email protected], [email protected]@)
  ENDIF
RETURN

_Stoogesort PARAM(1)
  PROC _InnerStooge (0, [email protected] -  1)
RETURN

_Swap PARAM(2)                         ' Swap two array elements
  PUSH @([email protected])
  @([email protected]) = @([email protected])
  @([email protected]) = POP()
RETURN

_InitArray                             ' Init example array
  PUSH 4, 65, 2, -31, 0, 99, 2, 83, 782, 1

  FOR i = 0 TO 9
    @(i) = POP()
  NEXT

RETURN (i)

_ShowArray PARAM (1)                   ' Show array subroutine
  FOR i = 0 TO [email protected]
    PRINT @(i),
  NEXT

  PRINT
RETURN


var stoogeSort // recursive
stoogeSort = Fn.new { |a, i, j|
    if (a[j] < a[i]) {
        var t = a[i]
        a[i] = a[j]
        a[j] = t
    }
    if (j - i > 1) {
        var t = ((j - i + 1)/3).floor
        stoogeSort.call(a, i, j - t)
        stoogeSort.call(a, i + t, j)
        stoogeSort.call(a, i, j - t)
    }
}

var as = [ [4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in as) {
    System.print("Before: %(a)")
    stoogeSort.call(a, 0, a.count-1)
    System.print("After : %(a)")
    System.print()
}


/* NetRexx */
options replace format comments java crossref savelog symbols binary

placesList = [String -
    "UK  London",     "US  New York",   "US  Boston",     "US  Washington" -
  , "UK  Washington", "US  Birmingham", "UK  Birmingham", "UK  Boston"     -
]
sortedList = shellSort(String[] Arrays.copyOf(placesList, placesList.length))

lists = [placesList, sortedList]
loop ln = 0 to lists.length - 1
  cl = lists[ln]
  loop ct = 0 to cl.length - 1
    say cl[ct]
    end ct
    say
  end ln

return

method shellSort(a = String[]) public constant binary returns String[]

  n = a.length
  inc = int Math.round(double n / 2.0)
  loop label inc while inc > 0
    loop i_ = inc to n - 1
      temp = a[i_]
      j_ = i_
      loop label j_ while j_ >= inc
        if \(a[j_ - inc].compareTo(temp) > 0) then leave j_
        a[j_] = a[j_ - inc]
        j_ = j_ - inc
        end j_
      a[j_] = temp
      end i_
    inc = int Math.round(double inc / 2.2)
    end inc

  return a

method isTrue public constant binary returns boolean
  return 1 == 1

method isFalse public constant binary returns boolean
  return \isTrue


proc shellSort[T](a: var openarray[T]) =
  var h = a.len
  while h > 0:
    h = h div 2
    for i in h ..< a.len:
      let k = a[i]
      var j = i
      while j >= h and k < a[j-h]:
        a[j] = a[j-h]
        j -= h
      a[j] = k

var a = @[4, 65, 2, -31, 0, 99, 2, 83, 782]
shellSort a
echo a


code ChOut=8, IntOut=11;        \intrinsic routines

proc StoogeSort(L, I, J);       \Sort array L
int L, I, J;
int  T;
[if L(J) < L(I) then
    [T:= L(I);  L(I):= L(J);  L(J):= T]; \swap
if J-I > 1 then
    [T:= (J-I+1)/3;
    StoogeSort(L, I, J-T);
    StoogeSort(L, I+T, J);
    StoogeSort(L, I, J-T);
    ];
];

int A, I;
[A:= [3, 1, 4, 1, -5, 9, 2, 6, 5, 4];
StoogeSort(A, 0, 10-1);
for I:= 0 to 10-1 do [IntOut(0, A(I));  ChOut(0, ^ )];
]


func stoogesort(&L, i, j) {
  if(is_void(i)) i = 1;
  if(is_void(j)) j = numberof(L);
  if(L(j) < L(i))
    L([i,j]) = L([j,i]);
  if(j - i > 1) {
    t = (j - i + 1)/3;
    stoogesort, L, i, j-t;
    stoogesort, L, i+t, j;
    stoogesort, L, i, j-t;
  }
}


fcn stoogeSort(list,i=0,j=Void){ if(Void==j) j=list.len() - 1; // default parameters set before call
   if(list[j]<list[i]) list.swap(i,j);
   if(j - i >1){
      t:=(j - i + 1)/3;
      stoogeSort(list,i  , j-t);
      stoogeSort(list,i+t, j  );
      stoogeSort(list,i  , j-t);
   }
   list
}


let shellsort a =
  let len = Array.length a in
  let incSequence = [| 412771; 165103; 66041; 26417; 10567;
                       4231; 1693; 673; 269; 107; 43; 17; 7; 3; 1 |] in

  Array.iter (fun increment ->
    if (increment * 2) <= len then
      for i = increment to pred len do
        let temp = a.(i) in
        let rec loop j =
          if j < 0 || a.(j) <= temp then (j)
          else begin
            a.(j + increment) <- a.(j);
            loop (j - increment)
          end
        in
        let j = loop (i - increment) in
        a.(j + increment) <- temp;
      done;
  ) incSequence;
;;


shellSort(v)={
  my(inc=#v\2);
  while(inc,
    for(i=inc+1,#v,
      my(t=v[i],j=i);
      while(j>inc && v[j-inc]>t,
        v[j]=v[j-=inc]
      );
      v[j]=t
    );
    inc \= 2.2
  );
  v
};


Const
  MaxN = 100; { number of elements (my example is 100) }
Type
  TArray = Array [0..MaxN] of Integer;

Procedure ShellSort ( var A : TArray; N : Integer );
Var
  i, j, step, tmp : Integer;
Begin
  step:=N div 2;  // step:=step shr 1
  While step>0 Do Begin
    For i:=step to N Do Begin
      tmp:=A[i];
      j:=i;
      While (j>=step) and (A[j-step]>tmp) Do Begin
        A[j]:=A[j-step];
        dec(j,step);
      End;
      A[j]:=tmp;
    End;
    step:=step div 2;  // step:=step shr 1
  End;
End;


with javascript_semantics

function shell_sort(sequence s)
    integer gap = floor(length(s)/2), j
    while gap>0 do
        for i=gap to length(s) do
            object si = s[i]
            j = i-gap
            while j>=1 and si<=s[j] do
                s[j+gap] = s[j]
                j -= gap
            end while
            s[j+gap] = si
        end for
        gap = floor(gap/2)
    end while
    return s
end function

?shell_sort(shuffle(tagset(10)))


function shellSort($arr)
{
	$inc = round(count($arr)/2);
	while($inc > 0)
	{
		for($i = $inc; $i < count($arr);$i++){
			$temp = $arr[$i];
			$j = $i;
			while($j >= $inc && $arr[$j-$inc] > $temp)
			{
				$arr[$j] = $arr[$j - $inc];
				$j -= $inc;
			}
			$arr[$j] = $temp;
		}
		$inc = round($inc/2.2);
	}
	return $arr;
}


go =>
   A = [23, 76, 99, 58, 97, 57, 35, 89, 51, 38, 95, 92, 24, 46, 31, 24, 14, 12, 57, 78],
   println(A),
   shell_sort(A),
   println(A),
   nl.

% Inline sort
shell_sort(A) =>
  Inc = round(A.length/2),
  while (Inc > 0)
    foreach(I in Inc+1..A.length)
      Temp = A[I],
      J := I,
      while (J > Inc, A[J-Inc] > Temp)
        A[J] := A[J-Inc],
        J := J - Inc
      end,
      A[J] := Temp
    end,
    Inc := round(Inc/2.2)
  end.


(de shellSort (A)
   (for (Inc (*/ (length A) 2)  (gt0 Inc)  (*/ Inc 10 22))
      (for (I Inc  (get A I)  (inc I))
         (let (Tmp @  J I)
            (while (and (>= J Inc) (> (get A (- J Inc)) Tmp))
               (set (nth A J) (get A (- J Inc)))
               (dec 'J Inc) )
            (set (nth A J) Tmp) ) ) )
   A )


/* Based on Rosetta Fortran */
Shell_Sort: PROCEDURE (A);
   DECLARE A(*) FIXED;
   DECLARE ( i, j, increment) FIXED BINARY (31);
   DECLARE temp FIXED;

   increment = DIMENSION(a) / 2;
   DO WHILE (increment > 0);
         DO i = lbound(A,1)+increment TO hbound(a,1);
            j = i;
            temp = a(i);
            DO WHILE (j >= increment+1 & a(j-increment) > temp);
               a(j) = a(j-increment);
               j = j - increment;
            END;
            a(j) = temp;
         END;
         IF increment = 2 THEN
            increment = 1;
         ELSE
            increment = increment * 5 / 11;
      END;
END SHELL_SORT;


#STEP=2.2

Procedure Shell_sort(Array A(1))
  Protected l=ArraySize(A()), increment=Int(l/#STEP)
  Protected i, j, temp
  While increment
    For i= increment To l
      j=i
      temp=A(i)
      While j>=increment And A(j-increment)>temp
        A(j)=A(j-increment)
        j-increment
      Wend
      A(j)=temp
    Next i
    If increment=2
      increment=1
    Else
      increment*(5.0/11)
    EndIf
  Wend
EndProcedure


def shell(seq):
    inc = len(seq) // 2
    while inc:
        for i, el in enumerate(seq[inc:], inc):
            while i >= inc and seq[i - inc] > el:
                seq[i] = seq[i - inc]
                i -= inc
            seq[i] = el
        inc = 1 if inc == 2 else inc * 5 // 11


#lang racket
(define (shell-sort! xs)
  (define ref (curry vector-ref xs))
  (define (new Δ) (if (= Δ 2) 1 (quotient (* Δ 5) 11)))
  (let loop ([Δ (quotient (vector-length xs) 2)])
    (unless (= Δ 0)
      (for ([xᵢ (in-vector xs)] [i (in-naturals)])
        (let while ([i i])
          (cond [(and (>= i Δ) (> (ref (- i Δ)) xᵢ))
                 (vector-set! xs i (ref (- i Δ)))
                 (while (- i Δ))]
                [else (vector-set! xs i xᵢ)])))
      (loop (new Δ))))
  xs)


sub shell_sort ( @a is copy ) {
    loop ( my $gap = (@a/2).round; $gap > 0; $gap = ( $gap * 5 / 11 ).round ) {
        for $gap .. @a.end -> $i {
            my $temp = @a[$i];

            my $j;
            loop ( $j = $i; $j >= $gap; $j -= $gap ) {
                my $v = @a[$j - $gap];
                last if $v <= $temp;
                @a[$j] = $v;
            }

            @a[$j] = $temp;
        }
    }
    return @a;
}
my @data = 22, 7, 2, -5, 8, 4;
say 'input  = ' ~ @data;
say 'output = ' ~ @data.&shell_sort;


/*REXX program  sorts  a  stemmed array  using the  shell sort  (shellsort) algorithm.  */
call gen                                         /*generate the array elements.         */
call show           'before sort'                /*display the  before  array elements. */
                 say copies('▒', 75)             /*displat a separator line  (a fence). */
call shellSort       #                           /*invoke the  shell  sort.             */
call show           ' after sort'                /*display the   after  array elements. */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
gen: @.=                                         /*assign a default value to stem array.*/
     @.1= '3 character abbreviations for states of the USA'         /*predates ZIP code.*/
     @.2= '==============================================='
     @.3= 'RHO  Rhode Island and Providence Plantations'     ;  @.36= 'NMX  New Mexico'
     @.4= 'CAL  California'    ;   @.20= "NEV  Nevada"       ;  @.37= 'IND  Indiana'
     @.5= 'KAN  Kansas'        ;   @.21= "TEX  Texas"        ;  @.38= 'MOE  Missouri'
     @.6= 'MAS  Massachusetts' ;   @.22= "VGI  Virginia"     ;  @.39= 'COL  Colorado'
     @.7= 'WAS  Washington'    ;   @.23= "OHI  Ohio"         ;  @.40= 'CON  Connecticut'
     @.8= 'HAW  Hawaii'        ;   @.24= "NHM  New Hampshire";  @.41= 'MON  Montana'
     @.9= 'NCR  North Carolina';   @.25= "MAE  Maine"        ;  @.42= 'LOU  Louisiana'
    @.10= 'SCR  South Carolina';   @.26= "MIC  Michigan"     ;  @.43= 'IOW  Iowa'
    @.11= 'IDA  Idaho'         ;   @.27= "MIN  Minnesota"    ;  @.44= 'ORE  Oregon'
    @.12= 'NDK  North Dakota'  ;   @.28= "MIS  Mississippi"  ;  @.45= 'ARK  Arkansas'
    @.13= 'SDK  South Dakota'  ;   @.29= "WIS  Wisconsin"    ;  @.46= 'ARZ  Arizona'
    @.14= 'NEB  Nebraska'      ;   @.30= "OKA  Oklahoma"     ;  @.47= 'UTH  Utah'
    @.15= 'DEL  Delaware'      ;   @.31= "ALA  Alabama"      ;  @.48= 'KTY  Kentucky'
    @.16= 'PEN  Pennsylvania'  ;   @.32= "FLA  Florida"      ;  @.49= 'WVG  West Virginia'
    @.17= 'TEN  Tennessee'     ;   @.33= "MLD  Maryland"     ;  @.50= 'NWJ  New Jersey'
    @.18= 'GEO  Georgia'       ;   @.34= "ALK  Alaska"       ;  @.51= 'NYK  New York'
    @.19= 'VER  Vermont'       ;   @.35= "ILL  Illinois"     ;  @.52= 'WYO  Wyoming'
         do #=1  until @.#=='';  end;  #= #-1    /*determine number of entries in array.*/
    return
/*──────────────────────────────────────────────────────────────────────────────────────*/
shellSort: procedure expose @.;   parse arg n    /*obtain the  n  from the argument list*/
           i= n % 2                              /*%   is integer division in REXX.     */
                   do  while i\==0
                          do j=i+1  to n;    k= j;      p= k - i      /*P: previous item*/
                          _= @.j
                                 do  while k>=i+1 & @.p>_;    @.k= @.p;   k= k-i;   p= k-i
                                 end   /*while*/
                          @.k= _
                          end          /*j*/
                   if i==2  then i= 1
                            else i= i * 5 % 11
                   end                 /*while*/
           return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show:   do j=1  for #;  say 'element'  right(j, length(#) ) arg(1)": "  @.j;  end;  return


aList = [-12, 3, 0, 4, 7, 4, 8, -5, 9]
shellSort(aList)
for i=1 to len(aList)
    see "" + aList[i] + " "
next

func shellSort a
     inc = ceil( len(a) / 2 )
     while inc > 0
           for i = inc to len(a)
               tmp = a[i]
               j = i
               while j > inc and a[j-inc] > tmp
                     a[j] = a[j-inc]
                     j = j - inc
               end
               a[j] = tmp
           next
           inc = floor( 0.5 + inc / 2.2 )
     end
     return a


class Array
  def shellsort!
    inc = length / 2
    while inc != 0
      inc.step(length-1) do |i|
        el = self[i]
        while i >= inc and self[i - inc] > el
          self[i] = self[i - inc]
          i -= inc
        end
        self[i] = el
      end
      inc = (inc == 2 ? 1 : (inc * 5.0 / 11).to_i)
    end
    self
  end
end

data = [22, 7, 2, -5, 8, 4]
data.shellsort!
p data # [-5, 2, 4, 7, 8, 22]


siz = 100
dim a(siz)
for i = 1 to siz
 a(i) = rnd(1) * 1000
next i

' -------------------------------
' Shell Sort
' -------------------------------
incr = int(siz / 2)
WHILE incr > 0
  for i = 1 to siz
    j    = i
    temp = a(i)
    WHILE (j >= incr and a(abs(j-incr)) > temp)
      a(j) = a(j-incr)
      j    = j - incr
    WEND
    a(j) = temp
  next i
  incr = int(incr / 2.2)
WEND


fn shell_sort<T: Ord + Copy>(v: &mut [T]) {
    let mut gap = v.len() / 2;
    let len = v.len();
    while gap > 0 {
        for i in gap..len {
            let temp = v[i];
            let mut j = i;
            while j >= gap && v[j - gap] > temp {
                v[j] = v[j - gap];
                j -= gap;
            }
            v[j] = temp;
        }
        gap /= 2;
    }
}

fn main() {
    let mut numbers = [4i32, 65, 2, -31, 0, 99, 2, 83, 782, 1];
    println!("Before: {:?}", numbers);
    shell_sort(&mut numbers);
    println!("After: {:?}", numbers);
}


object ShellSort {
  def incSeq(len:Int)=new Iterator[Int]{
    private[this] var x:Int=len/2
    def hasNext=x>0
    def next()={x=if (x==2) 1 else x*5/11; x}
  }

  def InsertionSort(a:Array[Int], inc:Int)={
    for (i <- inc until a.length; temp=a(i)){
      var j=i;
      while (j>=inc && a(j-inc)>temp){
        a(j)=a(j-inc)
        j=j-inc
      }
      a(j)=temp
    }
  }

  def shellSort(a:Array[Int])=for(inc<-incSeq(a.length)) InsertionSort(a, inc)

  def main(args: Array[String]): Unit = {
    var a=Array(2, 5, 3, 4, 3, 9, 3, 2, 5, 4, 1, 3, 22, 7, 2, -5, 8, 4)
    println(a.mkString(","))
    shellSort(a)
    println(a.mkString(","))
  }
}


const proc: shellSort (inout array elemType: arr) is func
  local
    var integer: i is 0;
    var integer: j is 0;
    var integer: increment is 0;
    var elemType: help is elemType.value;
  begin
    increment := length(arr) div 2;
    while increment > 0 do
      for i range 1 to length(arr) do
        j := i;
        help := arr[i];
        while j > increment and arr[j - increment] > help do
          arr[j] := arr[j - increment];
          j -:= increment;
        end while;
        arr[j] := help;
      end for;
      increment := increment div 2;
    end while;
  end func;


func shell_sort(a) {
    var h = a.len;
    while (h >>= 1) {
        for i in (h .. a.end) {
            var k = a[i];
            for (var j = i; (j >= h) && (k < a[j - h]); j -= h) {
                a[j] = a[j - h];
            }
            a[j] = k;
        }
    }
    return a;
}

var a = 10.of {100.irand};
say a;
shell_sort(a);
say a;


func shellsort<T where T : Comparable>(inout seq: [T]) {
    var inc = seq.count / 2
    while inc > 0 {
        for (var i, el) in EnumerateSequence(seq) {
            while i >= inc && seq[i - inc] > el {
                seq[i] = seq[i - inc]
                i -= inc
            }
            seq[i] = el
        }
        if inc == 2 {
            inc = 1
        } else {
            inc = inc * 5 / 11
        }
    }
}


package require Tcl 8.5

proc shellsort {m} {
    set len [llength $m]
    set inc [expr {$len / 2}]
    while {$inc > 0} {
        for {set i $inc} {$i < $len} {incr i} {
            set j $i
            set temp [lindex $m $i]
            while {$j >= $inc && [set val [lindex $m [expr {$j - $inc}]]] > $temp} {
                lset m $j $val
                incr j -$inc
            }
            lset m $j $temp
        }
        set inc [expr {$inc == 2 ? 1 : $inc * 5 / 11}]
    }
    return $m
}

puts [shellsort {8 6 4 2 1 3 5 7 9}] ;# => 1 2 3 4 5 6 7 8 9


PRINT "Shell sort:"
  n = FUNC (_InitArray)
  PROC _ShowArray (n)
  PROC _Shellsort (n)
  PROC _ShowArray (n)
PRINT

END

_Shellsort PARAM (1)                   ' Shellsort subroutine
  LOCAL (4)
  [email protected] = [email protected]

  DO WHILE [email protected]
    [email protected] = [email protected] / 2
    FOR [email protected] = [email protected] TO [email protected] - 1
      [email protected] = @([email protected])
      [email protected] = [email protected]
      DO WHILE ([email protected] > [email protected]) * ([email protected] < @(ABS([email protected] - [email protected])))
        @([email protected]) = @([email protected] - [email protected])
        [email protected] = [email protected] - [email protected]
      LOOP
      @([email protected]) = [email protected]
    NEXT
  LOOP
RETURN

_Swap PARAM(2)                         ' Swap two array elements
  PUSH @([email protected])
  @([email protected]) = @([email protected])
  @([email protected]) = POP()
RETURN

_InitArray                             ' Init example array
  PUSH 4, 65, 2, -31, 0, 99, 2, 83, 782, 1

  FOR i = 0 TO 9
    @(i) = POP()
  NEXT

RETURN (i)

_ShowArray PARAM (1)                   ' Show array subroutine
  FOR i = 0 TO [email protected]
    PRINT @(i),
  NEXT

  PRINT
RETURN


Sub arrShellSort(ByVal arrData As Variant)
  Dim lngHold, lngGap As Long
  Dim lngCount, lngMin, lngMax As Long
  Dim varItem As Variant
  '
  lngMin = LBound(arrData)
  lngMax = UBound(arrData)
  lngGap = lngMin
  Do While (lngGap < lngMax)
    lngGap = 3 * lngGap + 1
  Loop
  Do While (lngGap > 1)
    lngGap = lngGap \ 3
    For lngCount = lngGap + lngMin To lngMax
      varItem = arrData(lngCount)
      lngHold = lngCount
      Do While ((arrData(lngHold - lngGap) > varItem))
        arrData(lngHold) = arrData(lngHold - lngGap)
        lngHold = lngHold - lngGap
        If (lngHold < lngMin + lngGap) Then Exit Do
      Loop
      arrData(lngHold) = varItem
    Next
  Loop
  arrShellSort = arrData
End Sub'


fn shell(mut arr []int, n int) {
	mut j := 0
	for h := n; h /= 2;  {
		for i := h; i < n; i++ {
			t := arr[i]
			for j = i; j >= h && t < arr[j - h]; j -= h {
				arr[j] = arr[j - h]
			}
			arr[j] = t
		}
	}
}

fn main() {
	mut arr := [4, 65, 2, -31, 0, 99, 2, 83, 782, 1]
	n := arr.len
	println('Input: ' + arr.str())
	shell(mut arr, n)
	println('Output: ' + arr.str())
}


var shellSort = Fn.new { |a|
    var n = a.count
    var gaps = [701, 301, 132, 57, 23, 10, 4, 1]
    for (gap in gaps) {
        if (gap < n) {
            for (i in gap...n) {
                var t = a[i]
                var j = i
                while (j >= gap && a[j-gap] > t) {
                    a[j] = a[j - gap]
                    j = j - gap
                }
                a[j] = t
            }
        }
    }
}

var as = [ [4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in as) {
    System.print("Before: %(a)")
    shellSort.call(a)
    System.print("After : %(a)")
    System.print()
}


include c:\cxpl\codes;          \intrinsic 'code' declarations
string 0;                       \use zero-terminated strings

proc    SSort(A, N);            \Shell sort array in ascending order
char    A;                      \address of array
int     N;                      \number of elements in array (size)
int     I, J, Gap, JG, T;
[Gap:= N>>1;
while Gap > 0 do
        [for I:= Gap to N-1 do
                [J:= I - Gap;
                loop    [JG:= J + Gap;
                        if A(J) <= A(JG) then quit;
                        T:= A(J);   A(J):= A(JG);   A(JG):= T;  \swap elements
                        J:= J - Gap;
                        if J < 0 then quit;
                        ];
                ];
        Gap:= Gap>>1;
        ];
];      \SSort

func    StrLen(Str);            \Return number of characters in an ASCIIZ string
char    Str;
int     I;
for I:= 0 to -1>>1-1 do
        if Str(I) = 0 then return I;

char    Str;
[Str:= "Pack my box with five dozen liquor jugs.";
SSort(Str, StrLen(Str));
Text(0, Str);  CrLf(0);
]


export sub shell_sort(x())
// Shell sort based on insertion sort

   local gap, i, j, first, last, tempi, tempj

   last = arraysize(x(),1)
   gap = int(last / 10) + 1
   while(TRUE)
	first = gap + 1
	for i = first to last
	   	tempi = x(i)
	    	j = i - gap
	    	while(TRUE)
			tempj = x(j)
			if tempi >= tempj then
		    		j = j + gap
		    		break
			end if
			x(j+gap) = tempj
			if j <= gap then
		    		break
			end if
			j = j - gap
	    	wend
	    	x(j) = tempi
	next i
	if gap = 1 then
	   	return
	else
	   	gap = int(gap / 3.5) + 1
	end if
   wend
end sub

if peek$("library") = "main" then

	clear screen

	ITEMS = 100
	dim numeros(ITEMS)

	for n = 1 to ITEMS
		numeros(n) = ran(ITEMS + 1)
	next n

	print time$
	shell_sort(numeros())
	print time$
	print "Press a key to see ordered numbers."
	inkey$

	for n = 1 to ITEMS
		print numeros(n),", ";
	next n

end if


    // Shell sort a sequence of objects in place
    // Requires mutiable list
fcn shellSort(sequence){
   n := sequence.len();
   gap := n / 2;
   while (0 < gap){
      i := gap;
      while (i < n){
	 j := i - gap;
	 while ((j >= 0) and (sequence[j] > sequence[j + gap])){
	    sequence.swap(j,j + gap);
	    j -= gap;
	 }
	 i += 1;
      }
      gap /= 2;
   }
   return(sequence);
}


V inv_code = [
   ‘1’ = [‘B’, ‘F’, ‘P’, ‘V’],
   ‘2’ = [‘C’, ‘G’, ‘J’, ‘K’, ‘Q’, ‘S’, ‘X’, ‘Z’],
   ‘3’ = [‘D’, ‘T’],
   ‘4’ = [‘L’],
   ‘5’ = [‘M’, ‘N’],
   ‘6’ = [‘R’]
]

[Char = Char] _code
L(k, arr) inv_code
   L(el) arr
      _code[el] = k

F soundex(s)
   V code = String(s[0].uppercase())
   V previous = :_code.get(s[0].uppercase(), Char("\0"))

   L(c) s[1..]
      V current = :_code.get(c.uppercase(), Char("\0"))
      I current != "\0" & current != previous
         code ‘’= current
      previous = current

   R (code‘0000’)[0.<4]

print(soundex(‘Soundex’))
print(soundex(‘Example’))
print(soundex(‘Sownteks’))
print(soundex(‘Ekzampul’))


*        Soundex                   02/04/2017
SOUNDEX  CSECT
         USING  SOUNDEX,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,=A(NTT))  do i=1 to hbound(tt)
         LR     R1,R6                i
         BCTR   R1,0                 -1
         MH     R1,=AL2(L'TT)        *length(tt)
         LA     R4,TT(R1)            @tt(i)
         MVC    S,0(R4)              s=tt(i)
         LA     R1,S                 @s
         LA     R2,L'S               length(s)
LOOP     OI     0(R1),C' '           loop s[l]=ucase(s[l])
         LA     R1,1(R1)               @s++
         BCT    R2,LOOP              endloop
         MVC    CODE,=C'0000'        code='0000'
         MVC    CODE(1),S            code[1]=s[1]
         LA     R8,1                 k=1
         LA     R7,1                 j=1
       DO WHILE=(C,R7,LE,=A(L'S))    do j=1 to length(s)
         LA     R4,S-1                 @s[0]
         AR     R4,R7                  +j
         MVC    CCUR,0(R4)             ccur=s[j]
         TR     CCUR,TABLE             ccur=translate(ccur,table)
       IF C,R7,EQ,=F'1' THEN           if j=1 then
         MVC    CPREV,CCUR               cprev=ccur
       ELSE     ,                      else
*                                        if ccur<>' ' and ccur<>'-'
       IF CLI,CCUR,NE,C' ',AND,CLI,CCUR,NE,C'-',                       *
               AND,CLC,CCUR,NE,CPREV THEN  and ccur<>cprev then
       IF C,R8,LT,=F'4' THEN               if k<4 then
         LA     R8,1(R8)                     k=k+1
         LA     R4,CODE-1(R8)                @code[k]
         MVC    0(1,R4),CCUR                 code[k]=ccur
       ENDIF    ,                          endif
       ENDIF    ,                        endif
       IF CLI,CCUR,NE,C'-' THEN          if ccur<>'-' then
         MVC    CPREV,CCUR                 cprev=ccur
       ENDIF    ,                        endif
       ENDIF    ,                      endif
         LA     R7,1(R7)               j++
       ENDDO    ,                    enddo j
         XDECO  R6,XDEC              edit i
         MVC    PG(2),XDEC+10        i
         MVC    PG+3(L'S),S          s
         MVC    PG+15(L'CODE),CODE   code
         XPRNT  PG,L'PG              print
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
TT       DC     CL12'ashcraft',CL12'ashcroft',CL12'gauss',CL12'ghosh'
         DC     CL12'hilbert',CL12'heilbronn',CL12'lee',CL12'lloyd'
         DC     CL12'moses',CL12'pfister',CL12'robert',CL12'rupert'
         DC     CL12'rubin',CL12'tymczak',CL12'soundex',CL12'example'
TTEND    EQU    *
NTT      EQU    (TTEND-TT)/L'TT    hbound(tt)
S        DS     CL12
CCUR     DS     CL1                current
CPREV    DS     CL1                previous
CODE     DS     CL4
PG       DC     CL80' '
XDEC     DS     CL12
TABLE    DC     CL256' '           translation table
         ORG    TABLE+C'A'
         DC     CL9' 123 12- '     ABCDEFGHI
         ORG    TABLE+C'J'
         DC     CL9'22455 126'     JKLMNOPQR
         ORG    TABLE+C'S'
         DC     CL9'23 1-2 2'      STUVWXYZ
         ORG
         YREGS
         END    SOUNDEX


with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Characters.Handling; use Ada.Characters.Handling;
procedure Soundex is
   type UStrings is array(Natural range <>) of Unbounded_String;
   function "+"(S:String) return Unbounded_String renames To_Unbounded_String;

   function toSoundex (instr : String) return String is
      str  : String := To_Upper(instr);
      output : String := "0000";
      spos : Integer := str'First+1;  opos : Positive := 2;
      map  : array(0..255) of Character := (others => ' ');
      last : Integer := str'First;
   begin
      map(65..90) := " 123 12- 22455 12623 1-2 2";
      for i in str'Range loop str(i) := map(Character'Pos(str(i))); end loop;
      output(1) := str(str'First);
      while (opos <= 4 and spos <= str'Last) loop
         if str(spos) /= '-' and str(spos) /= ' ' then
            if (str(spos-1) = '-' and last = spos-2) and then
              (str(spos) = str(spos-2)) then null;
            elsif (str(spos) = output(opos-1) and last = spos-1) then last := spos;
            else output(opos) := str(spos);  opos := opos + 1; last := spos;
            end if;
         end if;
         spos := spos + 1;
      end loop;
      output(1) := To_Upper(instr(instr'First));
      return output;
   end toSoundex;

   cases : constant UStrings := (+"Soundex", +"Example", +"Sownteks",
      +"Ekzampul", +"Euler", +"Gauss", +"Hilbert", +"Knuth", +"Lloyd",
      +"Lukasiewicz", +"Ellery", +"Ghosh", +"Heilbronn", +"Kant",
      +"Ladd", +"Lissajous", +"Wheaton", +"Burroughs", +"Burrows",
      +"O'Hara", +"Washington", +"Lee", +"Gutierrez", +"Pfister",
      +"Jackson", +"Tymczak", +"VanDeusen", +"Ashcraft");
begin
   for i in cases'Range loop
      Put_Line(To_String(cases(i))&" = "&toSoundex(To_String(cases(i))));
   end loop;
end Soundex;


    PROC soundex = (STRING s) STRING:
    BEGIN
        PROC encode = (CHAR c) CHAR:
        BEGIN
            # We assume the alphabet is contiguous. #
            "-123-12*-22455-12623-1*2-2"[ABS to lower(c) - ABS "a" + 1]
        END;
        INT soundex code length = 4;
        STRING result := soundex code length * "0";
        IF s /= "" THEN
            CHAR previous;
            INT  j;
            result[j := 1] := s[1];
            previous := encode(s[1]);
            FOR i FROM 2 TO UPB s WHILE j < soundex code length
            DO
                IF is alpha(s[i]) THEN
                    CHAR code = encode(s[i]);
                    IF is digit(code) AND code /= previous THEN
                        result[j +:= 1] := code;
                        previous := code
                    ELIF code = "-" THEN
                        # Only vowels (y counts here) hide the last-added character #
                        previous := code
                    FI
                FI
            OD
        FI;
        result
    END;

    # Test code to persuade one that it does work. #

    MODE TEST = STRUCT (STRING input, STRING expected output);

    [] TEST soundex test = (
        ("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"), ("Burroughs",   "B620"),
        ("Burrows",    "B620"), ("O'Hara",      "O600"),
        ("Washington", "W252"), ("Lee",         "L000"),
        ("Gutierrez",  "G362"), ("Pfister",     "P236"),
        ("Jackson",    "J250"), ("Tymczak",     "T522"),
        ("VanDeusen",  "V532"), ("Ashcraft",    "A261")
    );

    #
      Apologies for the magic number in the padding of the input
      and the wired-in heading.
    #

    print(("Test name   Code Got", newline, "----------------------", newline));
    FOR i FROM LWB soundex test TO UPB soundex test
    DO
        STRING output = soundex(input OF soundex test[i]);
        printf(($g, n (12 - UPB input OF soundex test[i]) x$, input OF soundex test[i]));
        printf(($g, 1x, g, 1x$, expected output OF soundex test[i], output));
        printf(($b("ok", "not ok"), 1l$, output = expected output OF soundex test[i]))
    OD


100 DECLARE EXTERNAL FUNCTION FNSoundex$
110
120 DATA Ashcraft, Ashcroft, Gauss, Ghosh, Hilbert, Heilbronn, Lee, Lloyd
130 DATA Moses, Pfister, Robert, Rupert, Rubin, Tymczak, Soundex, Example
140 FOR i = 1 TO 16
150    READ name$
160    PRINT """"; name$; """"; TAB(15); FNsoundex$(name$)
170 NEXT i
180 END
190
200 EXTERNAL FUNCTION FNsoundex$(name$)
210 LET name$ = UCASE$(name$)
220 LET n$ = "01230129022455012623019202"
230 LET s$ = name$(1:1)
240 LET p = VAL(n$(ORD(s$) - 64 : ORD(s$) - 64))
250 FOR i = 2 TO LEN(name$)
260    LET n = VAL(n$(ORD(name$(i:i)) - 64: ORD(name$(i:i)) - 64))
270    IF n <> 0 AND n <> 9 AND n <> p THEN LET s$ = s$ & STR$(n)
280    IF n <> 9 THEN LET p = n
290 NEXT i
300 LET s$ = s$ & "000"
310 LET FNSoundex$ = s$(1:4)
320 END FUNCTION


code: #[
    "aeiouy": `W`
    "bfpv": `1`
    "cgjkqsxz": `2`
    "dt": `3`
    "l": `4`
    "mn": `5`
    "r": `6`
]

getCode: function [ch][
    loop keys code 'k [
        if contains? k lower to :string ch -> return code\[k]
    ]
    return ` `
]

soundex: function [str][
    result: new to :string first str

    prev: getCode first str
    loop.with:'i str 'c [
        curr: getCode c
        if curr <> ` ` [
            if and? curr <> `W`
                    curr <> prev -> 'result ++ curr
            prev: curr
        ]
    ]

    if? 4 < size result ->
        result: new slice result 0 3
    else [
        do.times: 4-size result ->
            'result ++ `0`
    ]
    return result
]

loop ["Robert", "Rupert", "Rubin", "Ashcraft", "Ashcroft", "Tymczak",
      "Pfister", "Honeyman", "Moses", "O'Mally", "O'Hara", "D day"] 'name ->
    print [pad name 10 "->" soundex name]


getCode(c){
        If c in B,F,P,V
            return 1
        If c in C,G,J,K,Q,S,X,Z
            return 2
        If c in D,T
            return 3
        If c = L
            return 4
        If c in M,N
            return 5
        If c = R
            return 6
}

soundex(s){
    code := SubStr(s, 1, 1)
   ,previous := 7
   ,i := 1
    While ++i <= StrLen(s){
        current := getCode(SubStr(s, i, 1))
        If StrLen(current) > 0 And current <> previous
            code := code . current
        previous := current
    }
    soundex := SubStr(code, 1, 4)
    If StrLen(code) < 4
        soundex .= String(4 - StrLen(code), "0")
    return soundex
}

String(a, n){
   Loop n
      o .= a
   return a
}

MsgBox % Soundex("Soundex") "`n" Soundex("Sowndeks") "`n" Soundex("Ashcroft") "`n" Soundex("Ashkrofd")


#!/usr/bin/awk -f
BEGIN {
    subsep = ", "
    delete homs
}

/^[a-zA-Z]/ {
    sdx = strToSoundex($0)
    addHom(sdx, $0)
}

END {
    showHoms(3)
}

function strToSoundex(s,    sdx, i, ch, cd, lch) {
    if (length(s) == 0) return ""
    s = tolower(s)
    lch = substr(s, 1, 1);
    sdx = toupper(lch)
    lch = charToSoundex(lch)
    for (i = 2; i <= length(s); i++) {
        ch = substr(s, i, 1)
        cd = charToSoundex(ch)
        if (cd == 7) continue;
        if (cd && cd != lch) sdx = sdx cd
        lch = cd
    }
    sdx = substr(sdx "0000", 1, 4)
    return sdx
}

function charToSoundex(ch,   cd) {
    if      (ch ~ /[bfpv]/)     cd = 1
    else if (ch ~ /[cgjkqsxz]/) cd = 2
    else if (ch ~ /[dt]/)       cd = 3
    else if (ch == "l")         cd = 4
    else if (ch ~ /[mn]/)       cd = 5
    else if (ch == "r")         cd = 6
    else if (ch ~ /[hw]/)       cd = 7
    else                        cd = 0
    return cd;
}

function addHom(sdx, word) {
    if (!(homs[sdx])) homs[sdx] = ""
    homs[sdx] = homs[sdx] (homs[sdx] == "" ? "" : subsep) word
}

function showHoms(toShow,    i, n, wl, j) {
    for (i in homs) {
        printf i " "
        n = split(homs[i], wl, subsep)
        for (j = 1; j <= toShow && j <= n; j++) {
            printf wl[j] "  "
        }
        print (n > toShow ? "..." : "")
    }
}


      DATA Ashcraft, Ashcroft, Gauss, Ghosh, Hilbert, Heilbronn, Lee, Lloyd
      DATA Moses, Pfister, Robert, Rupert, Rubin, Tymczak, Soundex, Example
      FOR i% = 1 TO 16
        READ name$
        PRINT """" name$ """" TAB(15) FNsoundex(name$)
      NEXT
      END

      DEF FNsoundex(name$)
      LOCAL i%, n%, p%, n$, s$
      name$ = FNupper(name$)
      n$ = "01230129022455012623019202"
      s$ = LEFT$(name$,1)
      p% = VALMID$(n$, ASCs$ - 64, 1)
      FOR i% = 2 TO LEN(name$)
        n% = VALMID$(n$, ASCMID$(name$,i%,1) - 64, 1)
        IF n% IF n% <> 9 IF n% <> p% s$ += STR$(n%)
        IF n% <> 9 p% = n%
      NEXT
      = LEFT$(s$ + "000", 4)

      DEF FNupper(A$)
      LOCAL A%,C%
      FOR A% = 1 TO LEN(A$)
        C% = ASCMID$(A$,A%)
        IF C% >= 97 IF C% <= 122 MID$(A$,A%,1) = CHR$(C%-32)
      NEXT
      = A$


ToUpper ← -⟜(32×1="a{"⊸⍋)
Split ← ((⊢-˜+`×¬)∘=⊔⊢)
replace ← ⟨
  "AEIOUYHW"
  "BFPV"
  "CGJKQSXZ"
  "DT"
  "L"
  "MN"
  "R"
⟩

Soundex ← ⊑∾{'0'+»⟜0‿0‿0⊑¨0⊸≠⊸/(0≠⊑)⊸↓⊑¨(¯1+·+`1»≠⟜«)⊸⊔∾/¨<˘⍉>replace∊˜¨<ToUpper 𝕩}

names ← ' ' Split "Lloyd Woolcock Donnell Baragwanath Williams Ashcroft Euler Ellery Gauss Ghosh Hilbert Heilbronn Knuth Kant Ladd Lukasiewicz Lissajous"
vals ← ' ' Split "L300 W422 D540 B625 W452 A226 E460 E460 G200 G200 H416 H416 K530 K530 L300 L222 L222"

•Show >(⊢ ⋈ Soundex)¨names
•Show vals≡Soundex¨names


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

/* for ASCII only */
static char code[128] = { 0 };
void add_code(const char *s, int c)
{
	while (*s) {
		code[(int)*s] = code[0x20 ^ (int)*s] = c;
		s++;
	}
}

void init()
{
	static const char *cls[] =
		{ "AEIOU", "", "BFPV", "CGJKQSXZ", "DT", "L", "MN", "R", 0};
	int i;
	for (i = 0; cls[i]; i++)
		add_code(cls[i], i - 1);
}

/* returns a static buffer; user must copy if want to save
   result across calls */
const char* soundex(const char *s)
{
	static char out[5];
	int c, prev, i;

	out[0] = out[4] = 0;
	if (!s || !*s) return out;

	out[0] = *s++;

	/* first letter, though not coded, can still affect next letter: Pfister */
	prev = code[(int)out[0]];
	for (i = 1; *s && i < 4; s++) {
		if ((c = code[(int)*s]) == prev) continue;

		if (c == -1) prev = 0;	/* vowel as separator */
		else if (c > 0) {
			out[i++] = c + '0';
			prev = c;
		}
	}
	while (i < 4) out[i++] = '0';
	return out;
}

int main()
{
	int i;
	const char *sdx, *names[][2] = {
		{"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"},
		{"Burroughs",	"B620"},
		{"Burrows",	"B620"},
		{"O'Hara",	"O600"},
		{"Washington",	"W252"},
		{"Lee",		"L000"},
		{"Gutierrez",	"G362"},
		{"Pfister",	"P236"},
		{"Jackson",	"J250"},
		{"Tymczak",	"T522"},
		{"VanDeusen",	"V532"},
		{"Ashcraft",	"A261"},
		{0, 0}
	};

	init();

	puts("  Test name  Code  Got\n----------------------");
	for (i = 0; names[i][0]; i++) {
		sdx = soundex(names[i][0]);
		printf("%11s  %s  %s ", names[i][0], names[i][1], sdx);
		printf("%s\n", strcmp(sdx, names[i][1]) ? "not ok" : "ok");
	}

	return 0;
}


using System;
using System.Collections.Generic;
using System.Linq;

namespace Soundex
{
    internal static class Program
    {
        private static void Main()
        {
            var testWords = new TestWords
                                {
                                    {"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"},
                                    {"Burroughs", "B620"},
                                    {"Burrows", "B620"},
                                    {"O'Hara", "O600"},
                                    {"Washington", "W252"},
                                    {"Lee", "L000"},
                                    {"Gutierrez", "G362"},
                                    {"Pfister", "P236"},
                                    {"Jackson", "J250"},
                                    {"Tymczak", "T522"},
                                    {"VanDeusen", "V532"},
                                    {"Ashcraft", "A261"}
                                };

            foreach (var testWord in testWords)
                Console.WriteLine("{0} -> {1} ({2})", testWord.Word.PadRight(11), testWord.ActualSoundex,
                                  (testWord.ExpectedSoundex == testWord.ActualSoundex));
        }

        // List<TestWord> wrapper to make declaration simpler.
        private class TestWords : List<TestWord>
        {
            public void Add(string word, string expectedSoundex)
            {
                Add(new TestWord(word, expectedSoundex));
            }
        }

        private class TestWord
        {
            public TestWord(string word, string expectedSoundex)
            {
                Word = word;
                ExpectedSoundex = expectedSoundex;
                ActualSoundex = Soundex(word);
            }

            public string Word { get; private set; }
            public string ExpectedSoundex { get; private set; }
            public string ActualSoundex { get; private set; }
        }

        private static string Soundex(string word)
        {
            const string soundexAlphabet = "0123012#02245501262301#202";
            string soundexString = "";
            char lastSoundexChar = '?';
            word = word.ToUpper();

            foreach (var c in from ch in word
                              where ch >= 'A' &&
                                    ch <= 'Z' &&
                                    soundexString.Length < 4
                              select ch)
            {
                char thisSoundexChar = soundexAlphabet[c - 'A'];

                if (soundexString.Length == 0)
                    soundexString += c;
                else if (thisSoundexChar == '#')
                    continue;
                else if (thisSoundexChar != '0' &&
                         thisSoundexChar != lastSoundexChar)
                    soundexString += thisSoundexChar;

                lastSoundexChar = thisSoundexChar;
            }

            return soundexString.PadRight(4, '0');
        }
    }
}


#include <iostream> // required for debug code in main() only
#include <iomanip>  // required for debug code in main() only
#include <string>

std::string soundex( char const* s )
{
    static char const code[] = { 0, -1,  1,  2,  3, -1,  1,  2,  0, -1,  2,  2,  4,  5,  5, -1,  1,  2,  6,  2,  3, -1,  1,  0,  2,  0,  2,  0,  0,  0,  0,  0 };

    if( !s || !*s )
        return std::string();

    std::string out( "0000" );
    out[0] = (*s >= 'a' && *s <= 'z') ? *s - ('a' - 'A') : *s;
    ++s;

    char prev = code[out[0] & 0x1F]; // first letter, though not coded, can still affect next letter: Pfister
    for( unsigned i = 1; *s && i < 4; ++s )
    {
        if( (*s & 0xC0) != 0x40 ) // process only letters in range [0x40 - 0x7F]
            continue;
        auto const c = code[*s & 0x1F];
        if( c == prev )
            continue;

        if( c == -1 )
            prev = 0;    // vowel as separator
        else if( c )
        {
            out[i] = c + '0';
            ++i;
            prev = c;
        }
    }
    return out;
}

int main()
{
    static char const * const names[][2] =
    {
        {"Ashcraft",    "A261"},
        {"Burroughs",   "B620"},
        {"Burrows",     "B620"},
        {"Ekzampul",    "E251"},
        {"Ellery",      "E460"},
        {"Euler",       "E460"},
        {"Example",     "E251"},
        {"Gauss",       "G200"},
        {"Ghosh",       "G200"},
        {"Gutierrez",   "G362"},
        {"Heilbronn",   "H416"},
        {"Hilbert",     "H416"},
        {"Jackson",     "J250"},
        {"Kant",        "K530"},
        {"Knuth",       "K530"},
        {"Ladd",        "L300"},
        {"Lee",         "L000"},
        {"Lissajous",   "L222"},
        {"Lloyd",       "L300"},
        {"Lukasiewicz", "L222"},
        {"O'Hara",      "O600"},
        {"Pfister",     "P236"},
        {"Soundex",     "S532"},
        {"Sownteks",    "S532"},
        {"Tymczak",     "T522"},
        {"VanDeusen",   "V532"},
        {"Washington",  "W252"},
        {"Wheaton",     "W350"}
    };

    for( auto const& name : names )
    {
        auto const sdx = soundex( name[0] );
        std::cout << std::left << std::setw( 16 ) << name[0] << std::setw( 8 ) << sdx << (sdx == name[1] ? " ok" : " ERROR") << std::endl;
    }
    return 0;
}


Class Utils.Phonetic [ Abstract ]
{

ClassMethod ToSoundex(String As %String) As %String [ Language = mvbasic ]
{
	Return Soundex(String)
}

}


FUNCTION Soundex(cWord)

 /*

 This is a Clipper/XBase++ implementation of the standard American Soundex procedure.

 */
LOCAL cSoundex, i, nLast, cChar, nCode

cWord:=ALLTRIM(UPPER(cWord))
cSoundex:=LEFT(cWord, 1)        // first letter is first char
nLast:=-1
FOR i:=2 TO LEN(cWord)
   cChar:=SUBSTR(cWord, i, 1)   // get char
   nCode:=SoundexCode(cChar)    // get soundex code for char
   IF nCode=0                   // if 0, ignore
      LOOP
   ENDIF
   IF nCode#nLast               // if not same code, add to soundex
      nLast:=nCode              // and replace the last one
      cSoundex+=STR(nCode, 1)
   ENDIF
NEXT
cSoundex:=PADR(cSoundex, 4, "0")

RETURN(cSoundex)

*******************************************************************************
STATIC FUNCTION SoundexCode(cLetter)
LOCAL aCodes:={"BFPV", "CGJKQSXZ", "DT", "L", "MN", "R"}, i, nRet:=0

FOR i:=1 TO LEN(aCodes)
   IF cLetter $ aCodes[i]
      nRet:=i
      EXIT
   ENDIF
NEXT

RETURN(nRet)

*******************************************************************************
FUNCTION SoundexDifference(cSound1, cSound2)
LOCAL nMatch:=0, nLen1, nLen2, i

nLen1:=LEN(cSound1)
nLen2:=LEN(cSound2)

// make the two words the same length.  This is a safety.  They both should be 4 characters long.
IF nLen1 > nLen2
   cSound2:=PADR(cSound2, nLen1-nLen2, "0")
ELSEIF nLen1 < nLen2
   cSound1:=PADR(cSound1, nLen2-nLen1, "0")
ENDIF

// compare the corresponding characters between the two words
FOR i:=1 TO LEN(cSound1)
   IF SUBSTR(cSound1, i, 1) == SUBSTR(cSound2, i, 1)
      ++nMatch
   ENDIF
NEXT

RETURN(nMatch)

*******************************************************************************


(defn get-code [c]
  (case 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
    nil)) ;(\A \E \I \O \U \H \W \Y)

(defn soundex [s]
  (let [[f & s] (.toUpperCase s)]
    (-> (map get-code s)
	distinct
	(concat , "0000")
	(->> (cons f ,)
	     (remove nil? ,)
	     (take 4 ,)
	     (apply str ,)))))


lower = proc (c: char) returns (char)
    if c >= 'A' & c <= 'Z' then
        c := char$i2c(32 + char$c2i(c))
    end
    return(c)
end lower

soundex = proc (name: string) returns (string)
    own coding: array[string] := array[string]$
        [0:"aeiou","bfpv","cgjkqsxz","dt","l","mn","r"]

    nums: array[int] := array[int]$[]
    for i: int in int$from_to(1, string$size(name)) do
        c: char := lower(name[i])
        for n: int in array[string]$indexes(coding) do
            if string$indexc(c, coding[n]) ~= 0 then
                array[int]$addh(nums, n)
                break
            end
        end
    end

    filtered: array[int] := array[int]$[]
    for i: int in array[int]$indexes(nums) do
        if nums[i]=0 cor i=1 then continue end
        if nums[i]~=nums[i-1] then
            array[int]$addh(filtered,nums[i])
        end
    end

    code: string := string$c2s(name[1])
    for i: int in array[int]$elements(filtered) do
        if string$size(code) >= 4 then break end
        code := code || int$unparse(i)
    end

    while string$size(code) < 4 do
        code := code || "0"
    end
    return(code)
end soundex

start_up = proc ()
    test = struct[name, code: string]
    po: stream := stream$primary_output()

    tests: array[test] := array[test]$[
        test${name:"Ashcraft",      code:"A261"},
        test${name:"Burroughs",     code:"B620"},
        test${name:"Burrows",       code:"B620"},
        test${name:"Ekzampul",      code:"E251"},
        test${name:"Ellery",        code:"E460"},
        test${name:"Euler",         code:"E460"},
        test${name:"Example",       code:"E251"},
        test${name:"Gauss",         code:"G200"},
        test${name:"Ghosh",         code:"G200"},
        test${name:"Gutierrez",     code:"G362"},
        test${name:"Heilbronn",     code:"H416"},
        test${name:"Hilbert",       code:"H416"},
        test${name:"Jackson",       code:"J250"},
        test${name:"Kant",          code:"K530"},
        test${name:"Knuth",         code:"K530"},
        test${name:"Ladd",          code:"L300"},
        test${name:"Lee",           code:"L000"},
        test${name:"Lissajous",     code:"L222"},
        test${name:"Lloyd",         code:"L300"},
        test${name:"Lukasiewicz",   code:"L222"},
        test${name:"O'Hara",        code:"O600"},
        test${name:"Pfister",       code:"P236"},
        test${name:"Soundex",       code:"S532"},
        test${name:"Sownteks",      code:"S532"},
        test${name:"Tymczak",       code:"T522"},
        test${name:"VanDeusen",     code:"V532"},
        test${name:"Washington",    code:"W252"},
        test${name:"Wheaton",       code:"W350"}
    ]

    for t: test in array[test]$elements(tests) do
        stream$putleft(po, t.name, 12)
        stream$puts(po, " -> ")
        c: string := soundex(t.name)
        stream$puts(po, c)
        if c ~= t.code
            then stream$putl(po, " (Wrong!)")
            else stream$putl(po, " (OK)")
        end
    end
end start_up


      **** sndxtest *********************************************
      * Demonstrate the soundex encoding functions.
      ***************************************************************
       Identification division.
       Program-id. sndxtest.

       Data division.
       Working-storage section.
       01 sample-word-list.
           05 sample-words.
               10 filler pic x(15) value "soundex".
               10 filler pic x(15) value "example".
               10 filler pic x(15) value "sownteks".
               10 filler pic x(15) value "ekzampul".
               10 filler pic x(15) value "Euler".
               10 filler pic x(15) value "Gauss".
               10 filler pic x(15) value "Hilbert".
               10 filler pic x(15) value "Knuth".
               10 filler pic x(15) value "Lloyd".
               10 filler pic x(15) value "Lukasiewicz".
               10 filler pic x(15) value "Ellery".
               10 filler pic x(15) value "ghosh".
               10 filler pic x(15) value "Heilbronn".
               10 filler pic x(15) value "Kand".
               10 filler pic x(15) value "Ladd".
               10 filler pic x(15) value "lissajous".
               10 filler pic x(15) value "Wheaton".
               10 filler pic x(15) value "Burroughs".
               10 filler pic x(15) value "burrows".
               10 filler pic x(15) value "O'Hara".
               10 filler pic x(15) value "Washington".
               10 filler pic x(15) value "lee".
               10 filler pic x(15) value "Gutierrez".
               10 filler pic x(15) value "Phister".
               10 filler pic x(15) value "Jackson".
               10 filler pic x(15) value "tymczak".
               10 filler pic x(15) value "Vandeusen".
               10 filler pic x(15) value "Ashcraft".
           05 sample-word redefines sample-words
                         pic x(15) occurs 28 times indexed by wrd-idx.
       01 wrd-code       pic x999.

       Procedure division.
           Perform varying wrd-idx from 1 by 1
           until wrd-idx greater than 28
               call "sndxenc" using
                   by reference sample-word(wrd-idx)
                   by reference wrd-code
               display wrd-code " " sample-word(wrd-idx)
           end-perform.
           Stop run.

       End program sndxtest.

      *** sndxenc ********************************************
      * Given a string return its soundex encoding.
      ***************************************************************
       Identification division.
       Program-id. sndxenc.

       Data division.
       Local-storage section.
       01 str-idx            pic 99.
       01 let-code           pic  9.
       01 prv-let-code       pic  9.
       01 sdx-idx            pic  9  value 1.

       Linkage section.
       01 str-to-encode.
           05 str-first-let  pic x.
           05 str-rest-let   pic x  occurs 14 times.
       01 sdx-code.
           05 sdx-first-let  pic x.
           05 sdx-nums       pic 9  occurs  3 times.

       Procedure division using
           by reference str-to-encode
           by reference sdx-code.
           Perform encode-start thru encode-done.
           Goback.

       Encode-start.
           Move zeros to sdx-code.
           Move function upper-case(str-first-let) to sdx-first-let.
           Call "sndxchar" using
               by reference str-first-let
               by reference let-code.
           Move let-code to prv-let-code.

       Encode-string.
           Perform varying str-idx from 1 by 1
               until str-idx greater than 15
               or str-rest-let(str-idx) = space
               or sdx-idx greater than 3
               call "sndxchar" using
                   by reference str-rest-let(str-idx)
                   by reference let-code
               if let-code not equal 7 then
                   if let-code not equal 0
                   and let-code not equal prv-let-code
                       move let-code to sdx-nums(sdx-idx)
                       add 1 to sdx-idx
                   end-if
                   move let-code to prv-let-code
               end-if
           end-perform.

       Encode-done.
           continue.
       End program sndxenc.

      *** sndxchar **********************************************
      * Given a character, return its soundex encoding.
      * Code 7 is for h or w, which an encoder should ignore when
      * either one separates double letters.
      ***************************************************************
       Identification division.
       Program-id. sndxchar.

       Data division.
       Local-storage section.
       01 lc-chr pic x.
           88 code1 value "b", "f", "p", "v".
           88 code2 value "c", "g", "j", "k", "q", "s", "x", "z".
           88 code3 value "d", "t".
           88 code4 value "l".
           88 code5 value "m", "n".
           88 code6 value "r".
           88 code7 value "h", "w".

       Linkage section.
       01 char-to-encode pic x.
       01 char-sdx-code  pic 9.

       Procedure division using
           by reference char-to-encode
           by reference char-sdx-code.
           Move function lower-case(char-to-encode) to lc-chr.
           If          code1 then move 1 to char-sdx-code
               else if code2 then move 2 to char-sdx-code
               else if code3 then move 3 to char-sdx-code
               else if code4 then move 4 to char-sdx-code
               else if code5 then move 5 to char-sdx-code
               else if code6 then move 6 to char-sdx-code
               else if code7 then move 7 to char-sdx-code
               else               move 0 to char-sdx-code
           end-if.
       End program sndxchar.


(defun get-code (c)
  (case 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)))

(defun soundex (s)
  (if (zerop (length s))
    ""
    (let* ((l (coerce (string-upcase s) 'list))
           (o (list (first l))))
      (loop for c in (rest l)
            for cg = (get-code c) and
            for cp = #\Z then cg
            when (and cg (not (eql cg cp))) do
              (push cg o)
            finally
              (return (subseq (coerce (nreverse `(#\0 #\0 #\0 ,@o)) 'string) 0 4))))))


# version 0.21.1

def get_code(c : Char)
  case c
  when 'B', 'F', 'P', 'V'
    "1"
  when 'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z'
    "2"
  when 'D', 'T'
    "3"
  when 'L'
    "4"
  when 'M', 'N'
    "5"
  when 'R'
    "6"
  when 'H', 'W'
    "-"
  else
    ""
  end
end

def soundex(s : String)
  return "" if s == ""
  s = s.upcase
  result = s[0,1]
  prev = get_code s[0]
  s.lchop.each_char {|c|
    curr = get_code c
    result += curr if curr != "" && curr != "-" && curr != prev
    prev = curr unless curr == "-"
  }
  result.ljust(4, '0')[0, 4]
end

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"]
        ]

pairs.each { |pair|
  puts "#{pair[0].ljust(9)} -> #{pair[1]} -> #{soundex(pair[0]) == pair[1]}"
}


import std.stdio: writeln;
import std.string: soundex;

void main() {
    assert(soundex("soundex") == "S532");
    assert(soundex("example") == "E251");
    assert(soundex("ciondecks") == "C532");
    assert(soundex("ekzampul") == "E251");
    assert(soundex("Robert") == "R163");
    assert(soundex("Rupert") == "R163");
    assert(soundex("Rubin") == "R150");
    assert(soundex("Ashcraft") == "A261");
    assert(soundex("Ashcroft") == "A261");
    assert(soundex("Tymczak") == "T522");
}


program SoundexDemo;

{$APPTYPE CONSOLE}

uses
    System.StrUtils;

begin
    Writeln(Soundex('Ashcraft'));
    Writeln(Soundex('Tymczak'))
end.


defmodule Soundex do
  def soundex([]), do: []
  def soundex(str) do
    [head|tail] = String.upcase(str) |> to_char_list
    [head | isoundex(tail, [], todigit(head))]
  end

  defp isoundex([], acc, _) do
    case length(acc) do
      n when n == 3 -> Enum.reverse(acc)
      n when n <  3 -> isoundex([], [?0 | acc], :ignore)
      n when n >  3 -> isoundex([], Enum.slice(acc, n-3, n), :ignore)
    end
  end
  defp isoundex([head|tail], acc, lastn) do
    dig = todigit(head)
    if dig != ?0 and dig != lastn do
      isoundex(tail, [dig | acc], dig)
    else
      case head do
        ?H                 -> isoundex(tail, acc, lastn)
        ?W                 -> isoundex(tail, acc, lastn)
        n when n in ?A..?Z -> isoundex(tail, acc, dig)
        _                  -> isoundex(tail, acc, lastn)  # This clause handles non alpha characters
      end
    end
  end

  @digits  '01230120022455012623010202'
  defp todigit(chr) do
    if chr in ?A..?Z, do: Enum.at(@digits, chr - ?A),
                    else: ?0            # Treat non alpha characters as a vowel
  end
end

IO.puts Soundex.soundex("Soundex")
IO.puts Soundex.soundex("Example")
IO.puts Soundex.soundex("Sownteks")
IO.puts Soundex.soundex("Ekzampul")


-module(soundex).
-export([soundex/1]).

soundex([]) ->
    [];
soundex(Str) ->
    [Head|Tail] = string:to_upper(Str),
    [Head | isoundex(Tail, [], todigit(Head))].

isoundex([], Acc, _) ->
    case length(Acc) of
	N when N == 3 ->
	    lists:reverse(Acc);
	N when N < 3 ->
	    isoundex([], [$0 | Acc], ignore);
	N when N > 3 ->
	    isoundex([], lists:sublist(Acc, N-2, N), ignore)
    end;
isoundex([Head|Tail], Acc, Lastn) ->
    Dig = todigit(Head),
    case Dig of
	Dig when Dig /= $0, Dig /= Lastn ->
	    isoundex(Tail, [Dig | Acc], Dig);
	_ ->
	    case Head of
		$H ->
		    isoundex(Tail, Acc, Lastn);
		$W ->
		    isoundex(Tail, Acc, Lastn);
		N when N >= $A, N =< $Z ->
		    isoundex(Tail, Acc, Dig);
		_ ->
		    isoundex(Tail, Acc, Lastn)	% This clause handles non alpha characters
	    end
    end.

todigit(Chr) ->
    Digits = "01230120022455012623010202",
    HeadOff = Chr - $A + 1,
    case HeadOff of
	N when N > 0, N < 27 ->
	    lists:nth(HeadOff, Digits);
	_ ->					% Treat non alpha characters as a vowel
	    $0
    end.


module Soundex

let soundex (s : string) =
    let code c =
        match c with
        | 'B' | 'F' | 'P' | 'V' -> Some('1')
        | 'C' | 'G' | 'J' | 'K' | 'Q' | 'S' | 'X' | 'Z' -> Some('2')
        | 'D' | 'T' -> Some('3')
        | 'L' -> Some('4')
        | 'M' | 'N' -> Some('5')
        | 'R' -> Some('6')
        | _ -> None

    let rec p l =
        match l with
        | [] -> []
        | x :: y :: tail when (code x) = (code y) -> (p (y :: tail))
        | x :: 'W' :: y :: tail when (code x) = (code y) -> (p (y :: tail))
        | x :: 'H' :: y :: tail when (code x) = (code y) -> (p (y :: tail))
        | x :: tail -> (code x) :: (p tail)

    let chars =
        match (p (s.ToUpper() |> List.ofSeq)) with
        | [] -> ""
        | head :: tail -> new string((s.[0] :: (tail |> List.filter (fun x -> x.IsSome) |> List.map (fun x -> x.Value))) |> List.toArray)
    chars.PadRight(4, '0').Substring(0, 4)

let test (input, se) =
    printfn "%12s\t%s\t%s" input se (soundex input)

let testCases = [|
    ("Ashcraft", "A261"); ("Ashcroft", "A261"); ("Burroughs", "B620"); ("Burrows", "B620");
    ("Ekzampul", "E251"); ("Example", "E251"); ("Ellery", "E460"); ("Euler", "E460");
    ("Ghosh", "G200"); ("Gauss", "G200"); ("Gutierrez", "G362"); ("Heilbronn", "H416");
    ("Hilbert", "H416"); ("Jackson", "J250"); ("Kant", "K530"); ("Knuth", "K530");
    ("Lee", "L000"); ("Lukasiewicz", "L222"); ("Lissajous", "L222"); ("Ladd", "L300");
    ("Lloyd", "L300"); ("Moses", "M220"); ("O'Hara", "O600"); ("Pfister", "P236");
    ("Rubin", "R150"); ("Robert", "R163"); ("Rupert", "R163"); ("Soundex", "S532");
    ("Sownteks", "S532"); ("Tymczak", "T522"); ("VanDeusen", "V532"); ("Washington", "W252");
    ("Wheaton", "W350");
    |]

[<EntryPoint>]
let main args =
    testCases |> Array.sortBy (fun (_, x) -> x) |> Array.iter test
    System.Console.ReadLine() |> ignore

    0


USE: soundex
"soundex" soundex    ! S532
"example" soundex    ! E251
"ciondecks" soundex  ! C532
"ekzampul" soundex   ! E251


: alpha-table create does> swap 32 or [char] a - 0 max 26 min + 1+ [email protected] ;

alpha-table soundex-code
  ,"  123 12. 22455 12623 1.2 2 "
   \ ABCDEFGHIJKLMNOPQRSTUVWXYZ

: soundex ( name len -- pad len )
  over [email protected] pad c!                  \ First character verbatim
  pad 1+ 3 [char] 0 fill          \ Pad to four characters with zeros
  1 pad [email protected] soundex-code  ( count code )
  2swap bounds do
    i [email protected] soundex-code   ( count code next )
    2dup = if         drop else   \ runs are ignored
    dup [char] . = if drop else   \ W, H don't separate runs of consonants
    dup bl = if        nip else   \ vowels separate consonants but aren't coded
      nip
      2dup swap pad + c!
      swap 1+
      tuck 4 = if leave then
    then then then
  loop
  2drop pad 4 ;

\ Knuth's test cases
s" Euler"       soundex cr type   \ E460
s" Gauss"       soundex cr type   \ G200
s" Hilbert"     soundex cr type   \ H416
s" Knuth"       soundex cr type   \ K530
s" Lloyd"       soundex cr type   \ L300
s" Lukasiewicz" soundex cr type   \ L222 (W test)
s" Ellery"      soundex cr type   \ E460
s" Ghosh"       soundex cr type   \ G200
s" Heilbronn"   soundex cr type   \ H416
s" Kant"        soundex cr type   \ K530
s" Ladd"        soundex cr type   \ L300
s" Lissajous"   soundex cr type   \ L222

s" Wheaton"   soundex cr type   \ W350
s" Ashcraft"  soundex cr type   \ A261  (H tests)
s" Burroughs" soundex cr type   \ B620
s" Burrows"   soundex cr type   \ B620  (W test) (any Welsh names?)
s" O'Hara"    soundex cr type   \ O600  (punctuation test)


Function getCode(c As String) As String
    If Instr("BFPV", c)     Then Return "1"
    If Instr("CGJKQSXZ", c) Then Return "2"
    If Instr("DT", c)       Then Return "3"
    If "L" = c              Then Return "4"
    If Instr("MN", c)       Then Return "5"
    If "R" = c              Then Return "6"
    If Instr("HW", c)       Then Return "."
End Function

Function Soundex(palabra As String) As String
    palabra = Ucase(palabra)
    Dim As String code = Mid(palabra,1,1)
    Dim As String previo = getCode(Left(palabra, 1)) ''""
    Dim As String actual

    For i As Byte = 2 To (Len(palabra) + 1)
        actual = getCode(Mid(palabra, i, 1))
        If actual = "." Then Continue For
        If Len(actual) > 0 And actual <> previo Then code &= actual
        previo = actual
        If Len(code) = 4 Then Exit For
    Next i
    If Len(code) < 4 Then code &= String(4,"0")
    Return Left(code,4)
End Function

Dim As String nombre
For i As Byte = 1 To 20
    Read nombre
    Print """"; nombre; """"; Tab(15); Soundex(nombre)
Next i

Data "Aschraft", "Ashcroft", "Euler", "Gauss", "Ghosh", "Hilbert", "Heilbronn", "Lee", "Lissajous", "Lloyd"
Data "Moses", "Pfister", "Robert", "Rupert", "Rubin", "Tymczak", "VanDeusen", "Wheaton", "Soundex", "Example"
Sleep


include "NSLog.incl"

local fn SoundexCode( charCode as unsigned char ) as unsigned char
  select charCode
    case _"B", _"F", _"P", _"V"
      charCode = _"1"
    case _"C", _"G", _"J", _"K", _"Q", _"S", _"X", _"Z"
      charCode = _"2"
    case _"D", _"T"
      charCode = _"3"
    case _"L"
      charCode = _"4"
    case _"M", _"N"
      charCode = _"5"
    case _"R"
      charCode = _"6"
    case else
      charCode = 0
  end select
end fn = charCode

local fn SoundexCodeForWord( codeWord as CFStringRef ) as CFStringRef
  NSUInteger         i
  unsigned char      charCode, lastCode
  CFStringRef        outputStr = @"0000"
  CFMutableStringRef tempStr

  if ( len(codeWord) == 0 ) then exit fn

  tempStr = fn MutableStringWithCapacity(0)
  codeWord = ucase(fn StringByApplyingTransform( codeWord, NSStringTransformStripDiacritics, NO ))

  MutableStringAppendString( tempStr, left(codeWord,1) )
  charCode = fn StringCharacterAtIndex( codeWord, 0 )
  charCode = fn SoundexCode( charCode )
  lastCode = charCode
  i = 0
  while i < len(codeWord) - 1
    i++
    charCode = fn StringCharacterAtIndex( codeWord, i )
    charCode = fn SoundexCode( charCode )
    if ( charCode > 0 and lastCode != charCode )
      MutableStringAppendString( tempStr, fn StringWithFormat( @"%c",charCode ) )
      if ( len(tempStr) == 4 ) then break
    end if
    lastCode = charCode
  wend

  while ( len(tempStr) < 4 )
    MutableStringAppendString( tempStr, @"0" )
  wend

  outputStr = fn StringWithString( tempStr )
end fn = outputStr

CFArrayRef  names
CFStringRef name

names = @[
@"Smith",@"Johnson",@"Williams",@"Jones",@"Brown",@"Davis",@"Miller",@"Wilson",@"Moore",@"Taylor",
@"Anderson",@"Thomas",@"Jackson",@"White",@"Harris",@"Martin",@"Thompson",@"Garcia",@"Martinez",@"Robinson",
@"Clark",@"Rodriguez",@"Lewis",@"Lee",@"Walker",@"Hall",@"Allen",@"Young",@"Hernandez",@"King",
@"Wright",@"Lopez",@"Hill",@"Scott",@"Green",@"Adams",@"Baker",@"Gonzalez",@"Nelson",@"Carter",
@"Mitchell",@"Perez",@"Roberts",@"Turner",@"Phillips",@"Campbell",@"Parker",@"Evans",@"Edwards",@"Collins",
@"Stewart",@"Sanchez",@"Morris",@"Rogers",@"Reed",@"Cook",@"Morgan",@"Bell",@"Murphy",@"Bailey",
@"Rivera",@"Cooper",@"Richardson",@"Cox",@"Howard",@"Ward",@"Torres",@"Peterson",@"Gray",@"Ramirez",
@"James",@"Watson",@"Brooks",@"Kelly",@"Sanders",@"Price",@"Bennett",@"Wood",@"Barnes",@"Ross",
@"Henderson",@"Coleman",@"Jenkins",@"Perry",@"Powell",@"Long",@"Patterson",@"Hughes",@"Flores",@"Washington",
@"Butler",@"Simmons",@"Foster",@"Gonzales",@"Bryant",@"Alexander",@"Russell",@"Griffin",@"Diaz",@"Hayes"
]

NSLogSetTabInterval( 80 )
NSLog( @"Soundex codes for %ld popular American surnames:",fn ArrayCount(names) )
for name in names
  NSLog( @"%@\t= %@",name,fn SoundexCodeForWord(name) )
next

NSLog(@"")

NSLog( @"Soundex codes for similar sounding names:" )
NSLog( @"Stuart\t= %@" , fn SoundexCodeForWord( @"Stuart"  ) )
NSLog( @"Stewart\t= %@", fn SoundexCodeForWord( @"Stewart" ) )
NSLog( @"Steward\t= %@", fn SoundexCodeForWord( @"Steward" ) )
NSLog( @"Seward\t= %@" , fn SoundexCodeForWord( @"Seward"  ) )

HandleEvents


package main

import (
    "errors"
    "fmt"
    "unicode"
)

var code = []byte("01230127022455012623017202")

func soundex(s string) (string, error) {
    var sx [4]byte
    var sxi int
    var cx, lastCode byte
    for i, c := range s {
        switch {
        case !unicode.IsLetter(c):
            if c < ' ' || c == 127 {
                return "", errors.New("ASCII control characters disallowed")
            }
            if i == 0 {
                return "", errors.New("initial character must be a letter")
            }
            lastCode = '0'
            continue
        case c >= 'A' && c <= 'Z':
            cx = byte(c - 'A')
        case c >= 'a' && c <= 'z':
            cx = byte(c - 'a')
        default:
            return "", errors.New("non-ASCII letters unsupported")
        }
        // cx is valid letter index at this point
        if i == 0 {
            sx[0] = cx + 'A'
            sxi = 1
            continue
        }
        switch x := code[cx]; x {
        case '7', lastCode:
        case '0':
            lastCode = '0'
        default:
            sx[sxi] = x
            if sxi == 3 {
                return string(sx[:]), nil
            }
            sxi++
            lastCode = x
        }
    }
    if sxi == 0 {
        return "", errors.New("no letters present")
    }
    for ; sxi < 4; sxi++ {
        sx[sxi] = '0'
    }
    return string(sx[:]), nil
}

func main() {
    for _, s := range []string{
        "Robert",   // WP test case = R163
        "Rupert",   // WP test case = R163
        "Rubin",    // WP test case = R150
        "ashcroft", // WP test case = A261
        "ashcraft", // s and c combine across h, t not needed
        "moses",    // s's don't combine across e
        "O'Mally",  // apostrophe allowed, adjacent ll's combine
        "d jay",    // spaces allowed
        "R2-D2",    // digits, hyphen allowed
        "12p2",     // just not in leading position
        "naïve",    // non ASCII disallowed
        "",         // empty string disallowed
        "bump\t",   // ASCII control characters disallowed
    } {
        if x, err := soundex(s); err == nil {
            fmt.Println("soundex", s, "=", x)
        } else {
            fmt.Printf("\"%s\" fail. %s\n", s, err)
        }
    }
}


def soundex(s) {
    def code = ""
    def lookup = [
       B : 1, F : 1, P : 1, V : 1,
       C : 2, G : 2, J : 2, K : 2, Q : 2, S : 2, X : 2, Z : 2,
       D : 3, T : 3,
       L : 4,
       M : 5, N : 5,
       R : 6
    ]
    s[1..-1].toUpperCase().inject(7) { lastCode, letter ->
        def letterCode = lookup[letter]
        if(letterCode && letterCode != lastCode) {
            code += letterCode
        }
    }
    return "${s[0]}${code}0000"[0..3]
}

println(soundex("Soundex"))
println(soundex("Sownteks"))
println(soundex("Example"))
println(soundex("Ekzampul"))


import Text.PhoneticCode.Soundex

main :: IO ()
main =
  mapM_ print $
  ((,) <*> soundexSimple) <$> ["Soundex", "Example", "Sownteks", "Ekzampul"]


procedure main(arglist)             # computes soundex of each argument
every write(x := !arglist, " => ",soundex(x))
end

procedure soundex(name)
   local  dig,i,x
   static con
   initial {                                   # construct mapping x[i] => i all else .
      x := ["bfpv","cgjkqsxz","dt","l","mn","r"]
      every ( dig := con := "") ||:= repl(i := 1 to *x,*x[i]) do con ||:= x[i]
      con := map(map(&lcase,con,dig),&lcase,repl(".",*&lcase))
      }

   name := map(name)                           # lower case
   name[1] := map(name[1],&lcase,&ucase)       # upper case 1st
   name := map(name,&lcase,con)                # map cons
   every x := !"123456" do
       while name[find(x||x,name)+:2] := x     # kill duplicates
   while name[upto('.',name)] := ""            # kill .
   return left(name,4,"0")
end


100 PROGRAM "Soundex.bas"
110 FOR I=1 TO 20
120   READ NAME$
130   PRINT """";NAME$;"""";TAB(20);SOUNDEX$(NAME$)
140 NEXT
150 DEF SOUNDEX$(NAME$)
160   NUMERIC I,N,P
170   LET NAME$=UCASE$(NAME$):LET S$=NAME$(1)
180   LET N$="01230129022455012623019202"
190   LET P=VAL(N$(ORD(S$)-64))
200   FOR I=2 TO LEN(NAME$)
210     LET N=VAL(N$(ORD(NAME$(I))-64))
220     IF N<>0 AND N<>9 AND N<>P THEN LET S$=S$&STR$(N)
230     IF N<>9 THEN LET P=N
240   NEXT
250   LET S$=S$&"000"
260   LET SOUNDEX$=S$(1:4)
270 END DEF
280 DATA Aschraft,Ashcroft,Euler,Gauss,Ghosh,Hilbert,Heilbronn,Lee,Lissajous,Lloyd
290 DATA Moses,Pfister,Robert,Rupert,Rubin,Tymczak,VanDeusen,Wheaton,Soundex,Example


removeDups =: {.;.1~ (1 , }. ~: }: )
codes  =: ;: 'BFPV CGJKQSXZ DT L MN R HW'

soundex =: 3 : 0
 if. 0=# k=.toupper y do. '0' return. end.
 ({.k), ,": ,. 3 {. 0-.~ }. removeDups 7 0:`([email protected]:=)`]} , k >:@[email protected]:(e. &>)"0 _ codes
)


public static void main(String[] args){
    System.out.println(soundex("Soundex"));
    System.out.println(soundex("Example"));
    System.out.println(soundex("Sownteks"));
    System.out.println(soundex("Ekzampul"));
  }

private static String getCode(char c){
  switch(c){
    case 'B': case 'F': case 'P': case 'V':
      return "1";
    case 'C': case 'G': case 'J': case 'K':
    case 'Q': case 'S': case 'X': case 'Z':
      return "2";
    case 'D': case 'T':
      return "3";
    case 'L':
      return "4";
    case 'M': case 'N':
      return "5";
    case 'R':
      return "6";
    default:
      return "";
  }
}

public static String soundex(String s){
  String code, previous, soundex;
  code = s.toUpperCase().charAt(0) + "";

  // EDITED : previous = "7";
  previous = getCode(s.toUpperCase().charAt(0));

  for(int i = 1;i < s.length();i++){
    String current = getCode(s.toUpperCase().charAt(i));
    if(current.length() > 0 && !current.equals(previous)){
      code = code + current;
    }
    previous = current;
  }
  soundex = (code + "0000").substring(0, 4);
  return soundex;
}


var soundex = function (s) {
     var a = s.toLowerCase().split('')
         f = a.shift(),
         r = '',
         codes = {
             a: '', e: '', i: '', o: '', u: '',
             b: 1, f: 1, p: 1, v: 1,
             c: 2, g: 2, j: 2, k: 2, q: 2, s: 2, x: 2, z: 2,
             d: 3, t: 3,
             l: 4,
             m: 5, n: 5,
             r: 6
         };

     r = f +
         a
         .map(function (v, i, a) { return codes[v] })
         .filter(function (v, i, a) { return ((i === 0) ? v !== codes[f] : v !== a[i - 1]); })
         .join('');

     return (r + '000').slice(0, 4).toUpperCase();
};

var tests = {
  "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":    "A226",
  "Burroughs":   "B622",
  "Burrows":     "B620",
  "O'Hara":      "O600"
  };

for (var i in tests)
  if (tests.hasOwnProperty(i)) {
    console.log(
      i +
      '    \t' +
      tests[i] +
      '\t' +
      soundex(i) +
      '\t' +
      (soundex(i) === tests[i])
    );
}

// Soundex     S532  S532  true
// Example     E251  E251  true
// Sownteks    S532  S532  true
// Ekzampul    E251  E251  true
// Euler       E460  E460  true
// Gauss       G200  G200  true
// Hilbert     H416  H416  true
// Knuth       K530  K530  true
// Lloyd       L300  L300  true
// Lukasiewicz L222  L222  true
// Ellery      E460  E460  true
// Ghosh       G200  G200  true
// Heilbronn   H416  H416  true
// Kant        K530  K530  true
// Ladd        L300  L300  true
// Lissajous   L222  L222  true
// Wheaton     W350  W350  true
// Ashcraft    A226  A226  true
// Burroughs   B622  B622  true
// Burrows     B620  B620  true
// O'Hara      O600  O600  true


using Soundex
@assert soundex("Ashcroft") == "A261"  # true

# Too trivial? OK. Here is an example not using a package:
function soundex(s)
    char2num = Dict('B'=>1,'F'=>1,'P'=>1,'V'=>1,'C'=>2,'G'=>2,'J'=>2,'K'=>2,
        'Q'=>2,'S'=>2,'X'=>2,'Z'=>2,'D'=>3,'T'=>3,'L'=>4,'M'=>5,'N'=>5,'R'=>6)
    s = replace(s, r"[^a-zA-Z]", "")
    if s == ""
        return ""
    end
    ret = "$(uppercase(s[1]))"
    hadvowel = false
    lastletternum = haskey(char2num, ret[1]) ? char2num[ret[1]] : ""
    for c in s[2:end]
        c = uppercase(c)
        if haskey(char2num, c)
            letternum = char2num[c]
            if letternum != lastletternum || hadvowel
                ret = "$ret$letternum"
                lastletternum = letternum
                hadvowel = false
            end
        elseif c in ('A', 'E', 'I', 'O', 'U', 'Y')
            hadvowel = true
        end
    end
    while length(ret) < 4
        ret *= "0"
    end
    ret[1:4]
end
@assert soundex("Ascroft")     == "A261"
@assert soundex("Euler")       == "E460"
@assert soundex("Gausss")      == "G200"
@assert soundex("Hilbert")     == "H416"
@assert soundex("Knuth")       == "K530"
@assert soundex("Lloyd")       == "L300"
@assert soundex("Lukasiewicz") == "L222"
@assert soundex("Ellery")      == "E460"
@assert soundex("Ghosh")       == "G200"
@assert soundex("Heilbronn")   == "H416"
@assert soundex("Kant")        == "K530"
@assert soundex("Ladd")        == "L300"
@assert soundex("Lissajous")   == "L222"
@assert soundex("Wheaton")     == "W350"
@assert soundex("Ashcraft")    == "A261"
@assert soundex("Burroughs")   == "B620"
@assert soundex("Burrows")     == "B620"
@assert soundex("O'Hara")      == "O600"


// version 1.1.2

fun getCode(c: Char) = when (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"
    'H', 'W' -> "-"
    else -> ""
}

fun soundex(s: String): String {
    if (s == "") return ""
    val sb = StringBuilder().append(s[0].toUpperCase())
    var prev = getCode(sb[0])
    for (i in 1 until s.length) {
        val curr = getCode(s[i].toUpperCase())
        if (curr != "" && curr != "-" && curr != prev) sb.append(curr)
        if (curr != "-") prev = curr
    }
    return sb.toString().padEnd(4, '0').take(4)
}

fun main(args: Array<String>) {
    val pairs = arrayOf(
        "Ashcraft"  to "A261",
        "Ashcroft"  to "A261",
        "Gauss"     to "G200",
        "Ghosh"     to "G200",
        "Hilbert"   to "H416",
        "Heilbronn" to "H416",
        "Lee"       to "L000",
        "Lloyd"     to "L300",
        "Moses"     to "M220",
        "Pfister"   to "P236",
        "Robert"    to "R163",
        "Rupert"    to "R163",
        "Rubin"     to "R150",
        "Tymczak"   to "T522",
        "Soundex"   to "S532",
        "Example"   to "E251"
    )
    for (pair in pairs) {
        println("${pair.first.padEnd(9)} -> ${pair.second} -> ${soundex(pair.first) == pair.second}")
    }
}


local d, digits, alpha = '01230120022455012623010202', {}, ('A'):byte()
d:gsub(".",function(c)
  digits[string.char(alpha)] = c
  alpha = alpha + 1
end)

function soundex(w)
  local res = {}
  for c in w:upper():gmatch'.'do
    local d = digits[c]
    if d then
      if #res==0 then
        res[1] =  c
      elseif #res==1 or d~= res[#res] then
        res[1+#res] = d
      end
    end
  end
  if #res == 0 then
    return '0000'
  else
    res = table.concat(res):gsub("0",'')
    return (res .. '0000'):sub(1,4)
  end
end

-- tests
local tests = {
  {"",         "0000"}, {"12346",     "0000"},
  {"he",       "H000"}, {"soundex",   "S532"},
  {"example",  "E251"}, {"ciondecks", "C532"},
  {"ekzampul", "E251"}, {"rÃ©sumÃ©",  "R250"},
  {"Robert",   "R163"}, {"Rupert",    "R163"},
  {"Rubin",    "R150"}, {"Ashcraft",  "A226"},
  {"Ashcroft", "A226"}
}

for i=1,#tests do
  local itm = tests[i]
  assert( soundex(itm[1])==itm[2] )
end
print"all tests ok"


Soundex[ input_ ] := Module[{x = input, head, body},
{head, body} = {[email protected]#, [email protected]#}&@[email protected]@x;
body = (Select[body, FreeQ[Characters["aeiouyhw"],#]&] /. {("b"|"f"|"p"|"v")->1,
("c"|"g"|"j"|"k"|"q"|"s"|"x"|"z")->2, ("d"|"t")->3,"l"->4 ,("m"|"n")->5, "r"->6});
If[Length[body] < 3,
 body = PadRight[body, 3],
 body = DeleteDuplicates[body]
];
StringJoin @@ ToString /@ PrependTo[ body[[1 ;; 3]], [email protected]]]