local Person = {}
Person.__index = Person

function Person.new(inName)
    local o = {
        name            = inName,
        prefs           = nil,
        fiance          = nil,
        _candidateIndex = 1,
    }
    return setmetatable(o, Person)
end

function Person:indexOf(other)
    for i, p in pairs(self.prefs) do
        if p == other then return i end
    end
    return 999
end

function Person:prefers(other)
    return self:indexOf(other) < self:indexOf(self.fiance)
end

function Person:nextCandidateNotYetProposedTo()
    if self._candidateIndex >= #self.prefs then return nil end
    local c = self.prefs[self._candidateIndex];
    self._candidateIndex = self._candidateIndex + 1
    return c;
end

function Person:engageTo(other)
    if other.fiance then
        other.fiance.fiance = nil
    end
    other.fiance = self
    if self.fiance then
        self.fiance.fiance = nil
    end
    self.fiance = other;
end

local function isStable(men)
    local women = men[1].prefs
    local stable = true
    for _, guy in pairs(men) do
        for _, gal in pairs(women) do
            if guy:prefers(gal) and gal:prefers(guy) then
                stable = false
                print(guy.name .. ' and ' .. gal.name ..
                      ' prefer each other over their partners ' ..
                      guy.fiance.name .. ' and ' .. gal.fiance.name)
            end
        end
    end
    return stable
end

local abe  = Person.new("Abe")
local bob  = Person.new("Bob")
local col  = Person.new("Col")
local dan  = Person.new("Dan")
local ed   = Person.new("Ed")
local fred = Person.new("Fred")
local gav  = Person.new("Gav")
local hal  = Person.new("Hal")
local ian  = Person.new("Ian")
local jon  = Person.new("Jon")

local abi  = Person.new("Abi")
local bea  = Person.new("Bea")
local cath = Person.new("Cath")
local dee  = Person.new("Dee")
local eve  = Person.new("Eve")
local fay  = Person.new("Fay")
local gay  = Person.new("Gay")
local hope = Person.new("Hope")
local ivy  = Person.new("Ivy")
local jan  = Person.new("Jan")

abe.prefs  = { abi,  eve,  cath, ivy,  jan,  dee,  fay,  bea,  hope, gay  }
bob.prefs  = { cath, hope, abi,  dee,  eve,  fay,  bea,  jan,  ivy,  gay  }
col.prefs  = { hope, eve,  abi,  dee,  bea,  fay,  ivy,  gay,  cath, jan  }
dan.prefs  = { ivy,  fay,  dee,  gay,  hope, eve,  jan,  bea,  cath, abi  }
ed.prefs   = { jan,  dee,  bea,  cath, fay,  eve,  abi,  ivy,  hope, gay  }
fred.prefs = { bea,  abi,  dee,  gay,  eve,  ivy,  cath, jan,  hope, fay  }
gav.prefs  = { gay,  eve,  ivy,  bea,  cath, abi,  dee,  hope, jan,  fay  }
hal.prefs  = { abi,  eve,  hope, fay,  ivy,  cath, jan,  bea,  gay,  dee  }
ian.prefs  = { hope, cath, dee,  gay,  bea,  abi,  fay,  ivy,  jan,  eve  }
jon.prefs  = { abi,  fay,  jan,  gay,  eve,  bea,  dee,  cath, ivy,  hope }

abi.prefs  = { bob,  fred, jon,  gav,  ian,  abe,  dan,  ed,   col,  hal  }
bea.prefs  = { bob,  abe,  col,  fred, gav,  dan,  ian,  ed,   jon,  hal  }
cath.prefs = { fred, bob,  ed,   gav,  hal,  col,  ian,  abe,  dan,  jon  }
dee.prefs  = { fred, jon,  col,  abe,  ian,  hal,  gav,  dan,  bob,  ed   }
eve.prefs  = { jon,  hal,  fred, dan,  abe,  gav,  col,  ed,   ian,  bob  }
fay.prefs  = { bob,  abe,  ed,   ian,  jon,  dan,  fred, gav,  col,  hal  }
gay.prefs  = { jon,  gav,  hal,  fred, bob,  abe,  col,  ed,   dan,  ian  }
hope.prefs = { gav,  jon,  bob,  abe,  ian,  dan,  hal,  ed,   col,  fred }
ivy.prefs  = { ian,  col,  hal,  gav,  fred, bob,  abe,  ed,   jon,  dan  }
jan.prefs  = { ed,   hal,  gav,  abe,  bob,  jon,  col,  ian,  fred, dan  }

local men = abi.prefs
local freeMenCount = #men
while freeMenCount > 0 do
    for _, guy in pairs(men) do
        if not guy.fiance then
            local gal = guy:nextCandidateNotYetProposedTo()
            if not gal.fiance then
                guy:engageTo(gal)
                freeMenCount = freeMenCount - 1
            elseif gal:prefers(guy) then
                guy:engageTo(gal)
            end
        end
    end
end

print(' ')
for _, guy in pairs(men) do
    print(guy.name .. ' is engaged to ' .. guy.fiance.name)
end
print('Stable: ', isStable(men))

print(' ')
print('Switching ' .. fred.name .. "'s & " .. jon.name .. "'s partners")
jon.fiance, fred.fiance = fred.fiance, jon.fiance
print('Stable: ', isStable(men))


#include <list>

template <typename T>
std::list<T> strandSort(std::list<T> lst) {
  if (lst.size() <= 1)
    return lst;
  std::list<T> result;
  std::list<T> sorted;
  while (!lst.empty()) {
    sorted.push_back(lst.front());
    lst.pop_front();
    for (typename std::list<T>::iterator it = lst.begin(); it != lst.end(); ) {
      if (sorted.back() <= *it) {
        sorted.push_back(*it);
        it = lst.erase(it);
      } else
        it++;
    }
    result.merge(sorted);
  }
  return result;
}


(ns rosettacode.strand-sort)

(defn merge-join
  "Produces a globally sorted seq from two sorted seqables"
  [[a & la :as all] [b & lb :as bll]]
  (cond (nil? a) bll
        (nil? b) all
        (< a b) (cons a (lazy-seq (merge-join la bll)))
        true    (cons b (lazy-seq (merge-join all lb)))))

(defn unbraid
  "Separates a sorted list from a sequence"
  [u]
  (when (seq u)
    (loop [[x & xs] u
           u []
           s []
           e x]
      (if (nil? x)
        [s u]
        (if (>= x e)
          (recur xs u (conj s x) x)
          (recur xs (conj u x) s e))))))

(defn strand-sort
  "http://en.wikipedia.org/wiki/Strand_sort"
  [s]
  (loop [[s u] (unbraid s)
         m nil]
    (if s
      (recur (unbraid u) (merge-join m s))
      m)))

(strand-sort [1, 6, 3, 2, 1, 7, 5, 3])
;;=> (1 1 2 3 3 5 6 7)


<<Combinatorica`;
ClearAll[CheckStability]
CheckStabilityHelp[male_, female_, ml_List, fl_List, pairing_List] := Module[{prefs, currentmale},
  prefs = fl[[female]];
  currentmale = Sort[Reverse /@ pairing][[female, 2]];
  FirstPosition[prefs, currentmale][[1]] < FirstPosition[prefs, male][[1]]
 ]
CheckStabilityHelp[male_, ml_List, fl_List, pairing_List] := Module[{prefs, m, f, p, otherf, reversepair, pos, othermen},
  prefs = ml[[male]];
  {m, f} = pairing[[male]];
  p = FirstPosition[prefs, f][[1]];
  otherf = Take[prefs, p - 1];
  AllTrue[otherf, CheckStabilityHelp[male, #, ml, fl, pairing] &]
 ]
CheckStability[ml_List, fl_List, pairing_List] := AllTrue[pairing[[All, 1]], CheckStabilityHelp[#, ml, fl, pairing] &]
males = {"abe", "bob", "col", "dan", "ed", "fred", "gav", "hal",
   "ian", "jon"};
females = {"abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope",
   "ivy", "jan"};
ml = {{"abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea",
    "hope", "gay"}, {"cath", "hope", "abi", "dee", "eve", "fay",
    "bea", "jan", "ivy", "gay"}, {"hope", "eve", "abi", "dee", "bea",
    "fay", "ivy", "gay", "cath", "jan"}, {"ivy", "fay", "dee", "gay",
    "hope", "eve", "jan", "bea", "cath", "abi"}, {"jan", "dee", "bea",
     "cath", "fay", "eve", "abi", "ivy", "hope", "gay"}, {"bea",
    "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope",
    "fay"}, {"gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope",
     "jan", "fay"}, {"abi", "eve", "hope", "fay", "ivy", "cath",
    "jan", "bea", "gay", "dee"}, {"hope", "cath", "dee", "gay", "bea",
     "abi", "fay", "ivy", "jan", "eve"}, {"abi", "fay", "jan", "gay",
    "eve", "bea", "dee", "cath", "ivy", "hope"}};
fl = {{"bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col",
    "hal"}, {"bob", "abe", "col", "fred", "gav", "dan", "ian", "ed",
    "jon", "hal"}, {"fred", "bob", "ed", "gav", "hal", "col", "ian",
    "abe", "dan", "jon"}, {"fred", "jon", "col", "abe", "ian", "hal",
    "gav", "dan", "bob", "ed"}, {"jon", "hal", "fred", "dan", "abe",
    "gav", "col", "ed", "ian", "bob"}, {"bob", "abe", "ed", "ian",
    "jon", "dan", "fred", "gav", "col", "hal"}, {"jon", "gav", "hal",
    "fred", "bob", "abe", "col", "ed", "dan", "ian"}, {"gav", "jon",
    "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred"}, {"ian",
    "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon",
    "dan"}, {"ed", "hal", "gav", "abe", "bob", "jon", "col", "ian",
    "fred", "dan"}};
ml = ml /. Thread[females -> Range[Length[males]]];
fl = fl /. Thread[males -> Range[Length[females]]];
pairing = StableMarriage[ml, fl];
pairing = {Range[Length[pairing]], pairing} // Transpose;
pairing
CheckStability[ml, fl, pairing]
pairing[[{2, 7}, 2]] //= Reverse;
pairing
CheckStability[ml, fl, pairing]


import sequtils, random, strutils

const
  Pairs = 10
  MNames = ["abe", "bob", "col", "dan", "ed", "fred", "gav", "hal", "ian", "jon"]
  FNames = ["abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope", "ivy", "jan"]
  MPreferences = [
    ["abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea", "hope", "gay"],
    ["cath", "hope", "abi", "dee", "eve", "fay", "bea", "jan", "ivy", "gay"],
    ["hope", "eve", "abi", "dee", "bea", "fay", "ivy", "gay", "cath", "jan"],
    ["ivy", "fay", "dee", "gay", "hope", "eve", "jan", "bea", "cath", "abi"],
    ["jan", "dee", "bea", "cath", "fay", "eve", "abi", "ivy", "hope", "gay"],
    ["bea", "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope", "fay"],
    ["gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope", "jan", "fay"],
    ["abi", "eve", "hope", "fay", "ivy", "cath", "jan", "bea", "gay", "dee"],
    ["hope", "cath", "dee", "gay", "bea", "abi", "fay", "ivy", "jan", "eve"],
    ["abi", "fay", "jan", "gay", "eve", "bea", "dee", "cath", "ivy", "hope"]
  ]
  FPreferences = [
    ["bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col", "hal"],
    ["bob", "abe", "col", "fred", "gav", "dan", "ian", "ed", "jon", "hal"],
    ["fred", "bob", "ed", "gav", "hal", "col", "ian", "abe", "dan", "jon"],
    ["fred", "jon", "col", "abe", "ian", "hal", "gav", "dan", "bob", "ed"],
    ["jon", "hal", "fred", "dan", "abe", "gav", "col", "ed", "ian", "bob"],
    ["bob", "abe", "ed", "ian", "jon", "dan", "fred", "gav", "col", "hal"],
    ["jon", "gav", "hal", "fred", "bob", "abe", "col", "ed", "dan", "ian"],
    ["gav", "jon", "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred"],
    ["ian", "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon", "dan"],
    ["ed", "hal", "gav", "abe", "bob", "jon", "col", "ian", "fred", "dan"]
  ]

# recipient's preferences hold the preference score for each contender's id
func getRecPreferences[N: static int](prefs: array[N, array[N, string]],
    names: openArray[string]): array[N, array[N, int]] {.compileTime.} =
  for r, prefArray in pairs(prefs):
    for c, contender in pairs(prefArray):
      result[r][c] = prefArray.find(MNames[c])

# contender's preferences hold the recipient ids in descending order of preference
func getContPreferences[N: static int](prefs: array[N, array[N, string]],
     names: openArray[string]): array[N, array[N, int]] {.compileTime.} =
  for c, pref_seq in pairs(prefs):
    for r, pref in pairs(pref_seq):
      result[c][r] = names.find(pref)

const
  RecipientPrefs = getRecPreferences(FPreferences, MNames)
  ContenderPrefs = getContPreferences(MPreferences, FNames)

proc printCoupleNames(contPairs: seq[int]) =
  for c, r in pairs(contPairs):
    echo MNames[c] & " 💑 " & FNames[contPairs[c]]

func pair(): (seq[int], seq[int]) =
  # double booking to avoid inverse lookup using find
  var
    recPairs = newSeqWith(10, -1)
    contPairs = newSeqWith(10, -1)
  template engage(c, r: int) =
    #echo FNames[r] & " accepted " & MNames[c]
    contPairs[c] = r
    recPairs[r] = c
  var contQueue = newSeqWith(10, 0)
  while contPairs.contains(-1):
    for c in 0..<Pairs:
      if contPairs[c] == -1:
        let r = ContenderPrefs[c][contQueue[c]] #proposing to first in queue
        contQueue[c] += 1 #increment contender's queue for following iterations
        let curPair = recPairs[r] # current pair's index or -1 = vacant
        if curPair == -1:
          engage(c, r)
        # contender is more preferable than current
        elif RecipientPrefs[r][c] < RecipientPrefs[r][curPair]:
          contPairs[curPair] = -1 # vacate current pair
          #echo MNames[curPair] & " was dumped by " & FNames[r]
          engage(c, r)
  result = (contPairs, recPairs)

proc randomPair(max: int): (int, int) =
  let a = rand(max)
  var b = rand(max - 1)
  if b == a:
    b = max
  result = (a, b)

proc perturbPairs(contPairs, recPairs: var seq[int]) =
  randomize()
  let (a, b) = randomPair(Pairs-1)
  echo("Swapping ", MNames[a], " & ", MNames[b], " partners")
  swap(contPairs[a], contPairs[b])
  swap(recPairs[contPairs[a]], recPairs[contPairs[b]])

proc checkPairStability(contPairs, recPairs: seq[int]): bool =
  for c in 0..<Pairs: # each contender
    let curPairScore = ContenderPrefs[c].find(contPairs[c]) # pref. score for current pair
    for preferredRec in 0..<curPairScore: # try every recipient with higher score
      let
        checkedRec = ContenderPrefs[c][preferredRec]
        curRecPair = recPairs[checkedRec] # current pair of checked recipient
      # if score of the curRecPair is worse (>) than score of checked contender
      if RecipientPrefs[checkedRec][curRecPair] > RecipientPrefs[checkedRec][c]:
        echo("💔 ", MNames[c], " prefers ", FNames[checkedRec], " over ", FNames[contPairs[c]])
        echo("💔 ", FNames[checkedRec], " prefers ", MNames[c], " over ", MNames[curRecPair])
        echo "✗ Unstable"
        return false # unstable
  echo "✓ Stable"
  result = true

when isMainModule:
  var (contPairs, recPairs) = pair()
  printCoupleNames(contPairs)
  echo "Current pair analysis:"
  discard checkPairStability(contPairs, recPairs)
  perturbPairs(contPairs, recPairs)
  printCoupleNames(contPairs)
  echo "Current pair analysis:"
  discard checkPairStability(contPairs, recPairs)


# strand_sort(<output variable> [<value>...]) sorts a list of integers.
function(strand_sort var)
  # Strand sort moves elements from _ARGN_ to _answer_.
  set(answer)                   # answer: a sorted list
  while(DEFINED ARGN)
    # Split _ARGN_ into two lists, _accept_ and _reject_.
    set(accept)                 # accept: elements in sorted order
    set(reject)                 # reject: all other elements
    set(p)
    foreach(e ${ARGN})
      if(DEFINED p AND p GREATER ${e})
        list(APPEND reject ${e})
      else()
        list(APPEND accept ${e})
        set(p ${e})
      endif()
    endforeach(e)

    # Prepare to merge _accept_ into _answer_. First, convert both lists
    # into arrays, for better indexing: set(e ${answer${i}}) is faster
    # than list(GET answer ${i} e).
    set(la 0)
    foreach(e ${answer})
      math(EXPR la "${la} + 1")
      set(answer${la} ${e})
    endforeach(e)
    set(lb 0)
    foreach(e ${accept})
      math(EXPR lb "${lb} + 1")
      set(accept${lb} ${e})
    endforeach(e)

    # Merge _accept_ into _answer_.
    set(answer)
    set(ia 1)
    set(ib 1)
    while(NOT ia GREATER ${la})         # Iterate elements of _answer_.
      set(ea ${answer${ia}})
      while(NOT ib GREATER ${lb})       # Take elements from _accept_,
        set(eb ${accept${ib}})          #   while they are less than
        if(eb LESS ${ea})               #   next element of _answer_.
          list(APPEND answer ${eb})
          math(EXPR ib "${ib} + 1")
        else()
          break()
        endif()
      endwhile()
      list(APPEND answer ${ea})         # Take next from _answer_.
      math(EXPR ia "${ia} + 1")
    endwhile()
    while(NOT ib GREATER ${lb})         # Take rest of _accept_.
      list(APPEND answer ${accept${ib}})
      math(EXPR ib "${ib} + 1")
    endwhile()

    # This _reject_ becomes next _ARGN_. If _reject_ is empty, then
    # set(ARGN) undefines _ARGN_, breaking the loop.
    set(ARGN ${reject})
  endwhile(DEFINED ARGN)

  set("${var}" ${answer} PARENT_SCOPE)
endfunction(strand_sort)


//--------------------------------------------------------------------
// Person class

@interface Person : NSObject {
    NSUInteger _candidateIndex;
}
@property (nonatomic, strong)   NSString*   name;
@property (nonatomic, strong)   NSArray*    prefs;
@property (nonatomic, weak)     Person*     fiance;
@end

@implementation Person
+ (instancetype)named:(NSString *)name {
    return [[self alloc] initWithName:name];
}
- (instancetype)initWithName:(NSString *)name {
    if ((self = [super init])) {
        _name = name;
        _prefs = nil;
        _fiance = nil;
        _candidateIndex = 0;
    }
    return self;
}
- (BOOL)prefers:(Person *)p {
    return [_prefs indexOfObject:p] < [_prefs indexOfObject:_fiance];
}
- (Person *)nextCandidateNotYetProposedTo {
    if (_candidateIndex >= _prefs.count) return nil;
    return _prefs[_candidateIndex++];
}
- (void)engageTo:(Person *)p {
    if (p.fiance) p.fiance.fiance = nil;
    p.fiance = self;
    if (self.fiance) self.fiance.fiance = nil;
    self.fiance = p;
}
- (NSString *)description {
    return _name;
}
@end

//--------------------------------------------------------------------

BOOL isStable(NSArray *men) {
    NSArray *women = ((Person *)men[0]).prefs;
    for (Person *guy in men) {
        for (Person *gal in women) {
            if ([guy prefers:gal] && [gal prefers:guy])
                return NO;
        }
    }
    return YES;
}

//--------------------------------------------------------------------

void doMarriage() {
    Person *abe  = [Person named:@"abe"];
    Person *bob  = [Person named:@"bob"];
    Person *col  = [Person named:@"col"];
    Person *dan  = [Person named:@"dan"];
    Person *ed   = [Person named:@"ed"];
    Person *fred = [Person named:@"fred"];
    Person *gav  = [Person named:@"gav"];
    Person *hal  = [Person named:@"hal"];
    Person *ian  = [Person named:@"ian"];
    Person *jon  = [Person named:@"jon"];
    Person *abi  = [Person named:@"abi"];
    Person *bea  = [Person named:@"bea"];
    Person *cath = [Person named:@"cath"];
    Person *dee  = [Person named:@"dee"];
    Person *eve  = [Person named:@"eve"];
    Person *fay  = [Person named:@"fay"];
    Person *gay  = [Person named:@"gay"];
    Person *hope = [Person named:@"hope"];
    Person *ivy  = [Person named:@"ivy"];
    Person *jan  = [Person named:@"jan"];

    abe.prefs  = @[ abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay ];
    bob.prefs  = @[ cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay ];
    col.prefs  = @[ hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan ];
    dan.prefs  = @[ ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi ];
    ed.prefs   = @[ jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay ];
    fred.prefs = @[ bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay ];
    gav.prefs  = @[ gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay ];
    hal.prefs  = @[ abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee ];
    ian.prefs  = @[ hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve ];
    jon.prefs  = @[ abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope ];
    abi.prefs  = @[ bob, fred, jon, gav, ian, abe, dan, ed, col, hal ];
    bea.prefs  = @[ bob, abe, col, fred, gav, dan, ian, ed, jon, hal ];
    cath.prefs = @[ fred, bob, ed, gav, hal, col, ian, abe, dan, jon ];
    dee.prefs  = @[ fred, jon, col, abe, ian, hal, gav, dan, bob, ed ];
    eve.prefs  = @[ jon, hal, fred, dan, abe, gav, col, ed, ian, bob ];
    fay.prefs  = @[ bob, abe, ed, ian, jon, dan, fred, gav, col, hal ];
    gay.prefs  = @[ jon, gav, hal, fred, bob, abe, col, ed, dan, ian ];
    hope.prefs = @[ gav, jon, bob, abe, ian, dan, hal, ed, col, fred ];
    ivy.prefs  = @[ ian, col, hal, gav, fred, bob, abe, ed, jon, dan ];
    jan.prefs  = @[ ed, hal, gav, abe, bob, jon, col, ian, fred, dan ];

    NSArray *men = abi.prefs;

    NSUInteger freeMenCount = men.count;
    while (freeMenCount > 0) {
        for (Person *guy in men) {
            if (guy.fiance == nil) {
                Person *gal = [guy nextCandidateNotYetProposedTo];
                if (gal.fiance == nil) {
                    [guy engageTo:gal];
                    freeMenCount--;
                } else if ([gal prefers:guy]) {
                    [guy engageTo:gal];
                }
            }
        }
    }

    for (Person *guy in men) {
        printf("%s is engaged to %s\n", [guy.name UTF8String], [guy.fiance.name UTF8String]);
    }
    printf("Stable = %d\n", (int)isStable(men));

    printf("\nSwitching fred & jon's partners\n");
    [fred engageTo:abi];
    [jon engageTo:bea];
    printf("Stable = %d\n", (int)isStable(men));
}

//--------------------------------------------------------------------

int main(int argc, const char * argv[])
{
    @autoreleasepool {
        doMarriage();
    }
    return 0;
}


(defun strand-sort (l cmp)
  (if l
    (let* ((l (reverse l))
	   (o (list (car l))) n)
      (loop for i in (cdr l) do
	    (push i (if (funcall cmp (car o) i) n o)))
      (merge 'list o (strand-sort n cmp) #'<))))

(let ((r (loop repeat 15 collect (random 10))))
  (print r)
  (print (strand-sort r #'<)))


import std.stdio, std.container;

DList!T strandSort(T)(DList!T list) {
    static DList!T merge(DList!T left, DList!T right) {
        DList!T result;
        while (!left.empty && !right.empty) {
            if (left.front <= right.front) {
                result.insertBack(left.front);
                left.removeFront();
            } else {
                result.insertBack(right.front);
                right.removeFront();
            }
        }
        result.insertBack(left[]);
        result.insertBack(right[]);
        return result;
    }

    DList!T result, sorted, leftover;

    while (!list.empty) {
        leftover.clear();
        sorted.clear();
        sorted.insertBack(list.front);
        list.removeFront();
        foreach (item; list) {
            if (sorted.back <= item)
                sorted.insertBack(item);
            else
                leftover.insertBack(item);
        }
        result = merge(sorted, result);
        list = leftover;
    }

    return result;
}

void main() {
    auto lst = DList!int([-2,0,-2,5,5,3,-1,-3,5,5,0,2,-4,4,2]);
    foreach (e; strandSort(lst))
        write(e, " ");
}


let men = [
  "abe",  ["abi";"eve";"cath";"ivy";"jan";"dee";"fay";"bea";"hope";"gay"];
  "bob",  ["cath";"hope";"abi";"dee";"eve";"fay";"bea";"jan";"ivy";"gay"];
  "col",  ["hope";"eve";"abi";"dee";"bea";"fay";"ivy";"gay";"cath";"jan"];
  "dan",  ["ivy";"fay";"dee";"gay";"hope";"eve";"jan";"bea";"cath";"abi"];
  "ed",   ["jan";"dee";"bea";"cath";"fay";"eve";"abi";"ivy";"hope";"gay"];
  "fred", ["bea";"abi";"dee";"gay";"eve";"ivy";"cath";"jan";"hope";"fay"];
  "gav",  ["gay";"eve";"ivy";"bea";"cath";"abi";"dee";"hope";"jan";"fay"];
  "hal",  ["abi";"eve";"hope";"fay";"ivy";"cath";"jan";"bea";"gay";"dee"];
  "ian",  ["hope";"cath";"dee";"gay";"bea";"abi";"fay";"ivy";"jan";"eve"];
  "jon",  ["abi";"fay";"jan";"gay";"eve";"bea";"dee";"cath";"ivy";"hope"];
]

let women = [
  "abi",  ["bob";"fred";"jon";"gav";"ian";"abe";"dan";"ed";"col";"hal"];
  "bea",  ["bob";"abe";"col";"fred";"gav";"dan";"ian";"ed";"jon";"hal"];
  "cath", ["fred";"bob";"ed";"gav";"hal";"col";"ian";"abe";"dan";"jon"];
  "dee",  ["fred";"jon";"col";"abe";"ian";"hal";"gav";"dan";"bob";"ed"];
  "eve",  ["jon";"hal";"fred";"dan";"abe";"gav";"col";"ed";"ian";"bob"];
  "fay",  ["bob";"abe";"ed";"ian";"jon";"dan";"fred";"gav";"col";"hal"];
  "gay",  ["jon";"gav";"hal";"fred";"bob";"abe";"col";"ed";"dan";"ian"];
  "hope", ["gav";"jon";"bob";"abe";"ian";"dan";"hal";"ed";"col";"fred"];
  "ivy",  ["ian";"col";"hal";"gav";"fred";"bob";"abe";"ed";"jon";"dan"];
  "jan",  ["ed";"hal";"gav";"abe";"bob";"jon";"col";"ian";"fred";"dan"];
]

type woman_name = string
type man_name = string

type man =
  { m_name: man_name;
    mutable free: bool;
    women_rank: woman_name list;
    has_proposed: (woman_name, unit) Hashtbl.t (* a set *)
  }

type woman =
  { w_name: woman_name;
    men_rank: man_name list;
    mutable engaged: man_name option
  }

let prefers w m1 m2 =
  (* returns true if w has a lower (better) rank for m1 than m2 *)
  let rec aux = function
  | [] -> invalid_arg "rank_cmp"
  | x::_ when x = m1 -> true
  | x::_ when x = m2 -> false
  | _::xs -> aux xs
  in
  aux w.men_rank

let take_while f lst =
  let rec aux acc = function
  | x::xs when f x -> aux (x::acc) xs
  | _ -> List.rev acc
  in
  aux [] lst

let more_ranked_than name =
  take_while ((<>) name)

let build_structs ~men ~women =
  List.map (fun (name, rank) ->
    { m_name = name;
      women_rank = rank;
      free = true;
      has_proposed = Hashtbl.create 42 }
  ) men,
  List.map (fun (name, rank) ->
    { w_name = name;
      men_rank = rank;
      engaged = None }
  ) women

let _stable_matching ms ws =
  let men_by_name = Hashtbl.create 42 in
  List.iter (fun m -> Hashtbl.add men_by_name m.m_name m) ms;
  let women_by_name = Hashtbl.create 42 in
  List.iter (fun w -> Hashtbl.add women_by_name w.w_name w) ws;
  try
    while true do
      (*TODO free men who still has some w to propose to *)
      let m = List.find (fun m -> m.free) ms in
      (* highest ranked woman who the man has not proposed to yet *)
      let w_name =
        List.find (fun w -> not (Hashtbl.mem m.has_proposed w)) m.women_rank in
      Hashtbl.add m.has_proposed w_name ();
      let w = Hashtbl.find women_by_name w_name in
      match w.engaged with
      | None -> (* w is free *)
          (* (m, w) become engaged *)
          w.engaged <- Some m.m_name;
          m.free <- false
      | Some m'_name -> (* some pair (m', w) already exists *)
          if prefers w m.m_name m'_name
          then begin (* w prefers m to m' *)
            w.engaged <- Some m.m_name;
            let m' = Hashtbl.find men_by_name m'_name in
            m'.free <- true;
            m.free <- false
          end
    done;
    assert false
  with Not_found -> ()

let stable_matching ~men ~women =
  let ms, ws = build_structs ~men ~women in
  _stable_matching ms ws;
  let some = function Some v -> v | None -> "" in
  List.map (fun w -> w.w_name, some w.engaged) ws

let is_stable ~men ~women eng =
  let ms, ws = build_structs ~men ~women in
  not (List.exists (fun (wn, mn) ->
      let m = List.find (fun m -> m.m_name = mn) ms in
      let prefered_women = more_ranked_than wn m.women_rank in
      List.exists (fun pref_w ->
        let w = List.find (fun w -> w.w_name = pref_w) ws in
        let eng_m = List.assoc pref_w eng in
        let prefered_men = more_ranked_than eng_m w.men_rank in
        List.mem m.m_name prefered_men (* exists unstable engagement *)
      ) prefered_women
    ) eng)

let perturb_engagements eng =
  Random.self_init();
  let eng = Array.of_list eng in
  let len = Array.length eng in
  for n = 1 to 3 do
    let i = Random.int len
    and j = Random.int len in
    let w1, m1 = eng.(i)
    and w2, m2 = eng.(j) in
    eng.(i) <- (w1, m2);
    eng.(j) <- (w2, m1);
  done;
  Array.to_list eng

let print engs =
  List.iter (fun (w,m) ->
    Printf.printf " %4s is engaged with %s\n" w m) engs;
  Printf.printf "# Engagements %s stable\n"
    (if is_stable ~men ~women engs then "are" else "are not")

let () =
  let engagements = stable_matching ~men ~women in
  print engagements;
  print_endline "========================";
  let engagements = perturb_engagements engagements in
  print engagements;
;;


defmodule Sort do
  def strand_sort(args), do: strand_sort(args, [])

  defp strand_sort([], result), do: result
  defp strand_sort(a, result) do
    {_, sublist, b} = Enum.reduce(a, {hd(a),[],[]}, fn val,{v,l1,l2} ->
                        if v <= val, do: {val, [val | l1], l2},
                                   else: {v,   l1, [val | l2]}
                      end)
    strand_sort(b, :lists.merge(Enum.reverse(sublist), result))
  end
end

IO.inspect Sort.strand_sort [7, 17, 6, 20, 20, 12, 1, 1, 9]


function merge(sequence left, sequence right)
    sequence result
    result = {}
    while length(left) > 0 and length(right) > 0 do
        if left[$] <= right[1] then
            exit
        elsif right[$] <= left[1] then
            return result & right & left
        elsif left[1] < right[1] then
            result = append(result,left[1])
            left = left[2..$]
        else
            result = append(result,right[1])
            right = right[2..$]
        end if
    end while
    return result & left & right
end function

function strand_sort(sequence s)
    integer j
    sequence result
    result = {}
    while length(s) > 0 do
        j = length(s)
        for i = 1 to length(s)-1 do
            if s[i] > s[i+1] then
                j = i
                exit
            end if
        end for

        result = merge(result,s[1..j])
        s = s[j+1..$]
    end while
    return result
end function

constant s = rand(repeat(1000,10))
puts(1,"Before: ")
? s
puts(1,"After:  ")
? strand_sort(s)


with Ada.Text_IO;
with Ada.Command_Line; use Ada.Command_Line;
procedure SleepSort is
   task type PrintTask (num : Integer);
   task body PrintTask is begin
      delay Duration (num) / 100.0;
      Ada.Text_IO.Put(num'Img);
   end PrintTask;
   type TaskAcc is access PrintTask;
   TaskList : array (1 .. Argument_Count) of TaskAcc;
begin
   for i in TaskList'Range loop
      TaskList(i) := new PrintTask(Integer'Value(Argument(i)));
   end loop;
end SleepSort;


#!/usr/bin/env perl
use strict;
use warnings;
use feature qw/say/;
use List::Util qw(first);

my %Likes = (
  M => {
    abe  => [qw/ abi eve cath ivy jan dee fay bea hope gay /],
    bob  => [qw/ cath hope abi dee eve fay bea jan ivy gay /],
    col  => [qw/ hope eve abi dee bea fay ivy gay cath jan /],
    dan  => [qw/ ivy fay dee gay hope eve jan bea cath abi /],
    ed   => [qw/ jan dee bea cath fay eve abi ivy hope gay /],
    fred => [qw/ bea abi dee gay eve ivy cath jan hope fay /],
    gav  => [qw/ gay eve ivy bea cath abi dee hope jan fay /],
    hal  => [qw/ abi eve hope fay ivy cath jan bea gay dee /],
    ian  => [qw/ hope cath dee gay bea abi fay ivy jan eve /],
    jon  => [qw/ abi fay jan gay eve bea dee cath ivy hope /],
  },

  W => {
    abi  => [qw/ bob fred jon gav ian abe dan ed col hal /],
    bea  => [qw/ bob abe col fred gav dan ian ed jon hal /],
    cath => [qw/ fred bob ed gav hal col ian abe dan jon /],
    dee  => [qw/ fred jon col abe ian hal gav dan bob ed /],
    eve  => [qw/ jon hal fred dan abe gav col ed ian bob /],
    fay  => [qw/ bob abe ed ian jon dan fred gav col hal /],
    gay  => [qw/ jon gav hal fred bob abe col ed dan ian /],
    hope => [qw/ gav jon bob abe ian dan hal ed col fred /],
    ivy  => [qw/ ian col hal gav fred bob abe ed jon dan /],
    jan  => [qw/ ed hal gav abe bob jon col ian fred dan /],
  },
);

my %Engaged;
my %Proposed;

match_them();
check_stability();
perturb();
check_stability();

sub match_them {
    say 'Matchmaking:';
    while(my $man = unmatched_man()) {
        my $woman = preferred_choice($man);
        $Proposed{$man}{$woman} = 1;
        if(! $Engaged{W}{$woman}) {
            engage($man, $woman);
            say "\t$woman and $man";
        }
        else {
            if(woman_prefers($woman, $man)) {
                my $engaged_man = $Engaged{W}{$woman};
                engage($man, $woman);
                undef $Engaged{M}{$engaged_man};
                say "\t$woman dumped $engaged_man for $man";
            }
        }
    }
}

sub check_stability {
    say 'Stablility:';
    my $stable = 1;
    foreach my $m (men()) {
        foreach my $w (women()) {
            if(man_prefers($m, $w) && woman_prefers($w, $m)) {
                say "\t$w prefers $m to $Engaged{W}{$w} and $m prefers $w to $Engaged{M}{$m}";
                $stable = 0;
            }
        }
    }
    if($stable) {
        say "\t(all marriages stable)";
    }
}

sub unmatched_man {
    return first { ! $Engaged{M}{$_} } men();
}

sub preferred_choice {
    my $man = shift;
    return first { ! $Proposed{$man}{$_} } @{ $Likes{M}{$man} };
}

sub engage {
    my ($man, $woman) = @_;
    $Engaged{W}{$woman} = $man;
    $Engaged{M}{$man} = $woman;
}

sub prefers {
    my $sex = shift;
    return sub {
        my ($person, $prospect) = @_;

        my $choices = join ' ', @{ $Likes{$sex}{$person} };
        return index($choices, $prospect) < index($choices, $Engaged{$sex}{$person});
    }
}

BEGIN {
    *woman_prefers = prefers('W');
    *man_prefers   = prefers('M');
}

sub perturb {
    say 'Perturb:';
    say "\tengage abi with fred and bea with jon";
    engage('fred' => 'abi');
    engage('jon'  => 'bea');
}

sub men   { keys %{ $Likes{M} } }
sub women { keys %{ $Likes{W} } }


package main

import "fmt"

type link struct {
    int
    next *link
}

func linkInts(s []int) *link {
    if len(s) == 0 {
        return nil
    }
    return &link{s[0], linkInts(s[1:])}
}

func (l *link) String() string {
    if l == nil {
        return "nil"
    }
    r := fmt.Sprintf("[%d", l.int)
    for l = l.next; l != nil; l = l.next {
        r = fmt.Sprintf("%s %d", r, l.int)
    }
    return r + "]"
}

func main() {
    a := linkInts([]int{170, 45, 75, -90, -802, 24, 2, 66})
    fmt.Println("before:", a)
    b := strandSort(a)
    fmt.Println("after: ", b)
}

func strandSort(a *link) (result *link) {
    for a != nil {
        // build sublist
        sublist := a
        a = a.next
        sTail := sublist
        for p, pPrev := a, a; p != nil; p = p.next {
            if p.int > sTail.int {
                // append to sublist
                sTail.next = p
                sTail = p
                // remove from a
                if p == a {
                    a = p.next
                } else {
                    pPrev.next = p.next
                }
            } else {
                pPrev = p
            }
        }
        sTail.next = nil // terminate sublist
        if result == nil {
            result = sublist
            continue
        }
        // merge
        var m, rr *link
        if sublist.int < result.int {
            m = sublist
            sublist = m.next
            rr = result
        } else {
            m = result
            rr = m.next
        }
        result = m
        for {
            if sublist == nil {
                m.next = rr
                break
            }
            if rr == nil {
                m.next = sublist
                break
            }
            if sublist.int < rr.int {
                m.next = sublist
                m = sublist
                sublist = m.next
            } else {
                m.next = rr
                m = rr
                rr = m.next
            }
        }
    }
    return
}


items := [1,5,4,9,3,4]
for i, v in SleepSort(items)
    result .= v ", "
MsgBox, 262144, , % result := "[" Trim(result, ", ") "]"
return

SleepSort(items){
    global Sorted := []
    slp := 50
    for i, v in items{
        fn := Func("PushFn").Bind(v)
        SetTimer, %fn%, % v * -slp
    }
    Sleep % Max(items*) * slp
    return Sorted
}

PushFn(v){
    global Sorted
    Sorted.Push(v)
}


function sleep_and_echo {
  sleep "$1"
  echo "$1"
}

for val in "[email protected]"; do
  sleep_and_echo "$val" &
done

wait


constant men = {"abe","bob","col","dan","ed","fred","gav","hal","ian","jon"}
enum             abe , bob , col , dan , ed , fred , gav , hal , ian , jon
constant hen = {"abi","bea","cath","dee","eve","fay","gay","hope","ivy","jan"}
enum             abi , bea , cath , dee , eve , fay , gay , hope , ivy , jan

-- Given a complete list of ranked preferences, where the most liked is to the left:
sequence mpref = repeat(0,length(men))
    mpref[abe]  = {abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay}
    mpref[bob]  = {cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay}
    mpref[col]  = {hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan}
    mpref[dan]  = {ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi}
    mpref[ed]   = {jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay}
    mpref[fred] = {bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay}
    mpref[gav]  = {gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay}
    mpref[hal]  = {abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee}
    mpref[ian]  = {hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve}
    mpref[jon]  = {abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope}

sequence hpref = repeat(0,length(hen))
    hpref[abi]  = {bob, fred, jon, gav, ian, abe, dan, ed, col, hal}
    hpref[bea]  = {bob, abe, col, fred, gav, dan, ian, ed, jon, hal}
    hpref[cath] = {fred, bob, ed, gav, hal, col, ian, abe, dan, jon}
    hpref[dee]  = {fred, jon, col, abe, ian, hal, gav, dan, bob, ed}
    hpref[eve]  = {jon, hal, fred, dan, abe, gav, col, ed, ian, bob}
    hpref[fay]  = {bob, abe, ed, ian, jon, dan, fred, gav, col, hal}
    hpref[gay]  = {jon, gav, hal, fred, bob, abe, col, ed, dan, ian}
    hpref[hope] = {gav, jon, bob, abe, ian, dan, hal, ed, col, fred}
    hpref[ivy]  = {ian, col, hal, gav, fred, bob, abe, ed, jon, dan}
    hpref[jan]  = {ed, hal, gav, abe, bob, jon, col, ian, fred, dan}

sequence engagements := repeat(0,length(hen))
sequence freemen = tagset(length(men))
printf(1,"Engagements:\n")

-- use the Gale Shapley algorithm to find a stable set of engagements:
while length(freemen) do
    integer man = freemen[1]
    freemen = freemen[2..$]
    integer fem, dumpee
    -- each male loops through all females in order of his preference until one accepts him
    for j=1 to length(mpref[man]) do
        fem = mpref[man][j]
        dumpee = engagements[fem]
        if dumpee=0
        or find(man,hpref[fem])<find(dumpee,hpref[fem]) then
            exit
        end if
    end for
    if dumpee!=0 then       -- if she was previously engaged
        freemen &= dumpee   -- he goes to the bottom of the list
        printf(1,"%s dumped %s and accepted %s\n",{hen[fem],men[dumpee],men[man]})
    else
        printf(1,"%s accepted %s\n",{hen[fem],men[man]})
    end if
    engagements[fem] := man -- the new engagement is registered
end while

printf(1,"\nCouples:\n")
for fem=1 to length(hen) do
    printf(1,"%s is engaged to %s\n",{hen[fem],men[engagements[fem]]})
end for

procedure stable()
bool unstable = false
    for fem=1 to length(hen) do
        integer man = engagements[fem]
        for j=1 to length(hen) do
            if find(fem,mpref[man])>find(j,mpref[man])
            and find(engagements[j],hpref[j])>find(man,hpref[j]) then
                if unstable=false then
                    printf(1,"\nThese couples are not stable.\n")
                    unstable = true
                end if
                printf(1,"%s is engaged to %s but would prefer %s and %s is engaged to %s but would prefer %s\n",
                         {men[man],hen[fem],hen[j],hen[j],men[engagements[j]],men[man]})
            end if
        end for
    end for
    if not unstable then
        printf(1,"\nThese couples are stable.\n")
    end if
end procedure

stable()
printf(1,"\nWhat if cath and ivy swap?\n")
engagements[cath]:=abe; engagements[ivy]:=bob
stable()


-- Same merge as in Merge Sort
merge :: (Ord a) => [a] -> [a] -> [a]
merge [] ys = ys
merge xs [] = xs
merge (x : xs) (y : ys)
	| x <= y = x : merge xs (y : ys)
	| otherwise = y : merge (x : xs) ys

strandSort :: (Ord a) => [a] -> [a]
strandSort [] = []
strandSort (x : xs) = merge strand (strandSort rest) where
	(strand, rest) = extractStrand x xs
	extractStrand x [] = ([x], [])
	extractStrand x (x1 : xs)
		| x <= x1 = let (strand, rest) = extractStrand x1 xs in (x : strand, rest)
		| otherwise = let (strand, rest) = extractStrand x xs in (strand, x1 : rest)


import java.util.Arrays;
import java.util.LinkedList;

public class Strand{
	// note: the input list is destroyed
	public static <E extends Comparable<? super E>>
	LinkedList<E> strandSort(LinkedList<E> list){
		if(list.size() <= 1) return list;

		LinkedList<E> result = new LinkedList<E>();
		while(list.size() > 0){
			LinkedList<E> sorted = new LinkedList<E>();
			sorted.add(list.removeFirst()); //same as remove() or remove(0)
			for(Iterator<E> it = list.iterator(); it.hasNext(); ){
				E elem = it.next();
				if(sorted.peekLast().compareTo(elem) <= 0){
					sorted.addLast(elem); //same as add(elem) or add(0, elem)
					it.remove();
				}
			}
			result = merge(sorted, result);
		}
		return result;
	}

	private static <E extends Comparable<? super E>>
	LinkedList<E> merge(LinkedList<E> left, LinkedList<E> right){
		LinkedList<E> result = new LinkedList<E>();
		while(!left.isEmpty() && !right.isEmpty()){
			//change the direction of this comparison to change the direction of the sort
			if(left.peek().compareTo(right.peek()) <= 0)
				result.add(left.remove());
			else
				result.add(right.remove());
		}
		result.addAll(left);
		result.addAll(right);
		return result;
	}

	public static void main(String[] args){
		System.out.println(strandSort(new LinkedList<Integer>(Arrays.asList(3,1,2,4,5))));
		System.out.println(strandSort(new LinkedList<Integer>(Arrays.asList(3,3,1,2,4,5))));
		System.out.println(strandSort(new LinkedList<Integer>(Arrays.asList(3,3,1,2,4,3,5,6))));
	}
}


      INSTALL @lib$+"TIMERLIB"

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

      FOR i% = 0 TO DIM(test%(),1)
        p% = EVAL("!^PROCtask" + STR$(i%))
        tid% = FN_ontimer(100 + test%(i%), p%, 0)
      NEXT

      REPEAT
        WAIT 0
      UNTIL FALSE

      DEF PROCtask0 : PRINT test%(0) : ENDPROC
      DEF PROCtask1 : PRINT test%(1) : ENDPROC
      DEF PROCtask2 : PRINT test%(2) : ENDPROC
      DEF PROCtask3 : PRINT test%(3) : ENDPROC
      DEF PROCtask4 : PRINT test%(4) : ENDPROC
      DEF PROCtask5 : PRINT test%(5) : ENDPROC
      DEF PROCtask6 : PRINT test%(6) : ENDPROC
      DEF PROCtask7 : PRINT test%(7) : ENDPROC
      DEF PROCtask8 : PRINT test%(8) : ENDPROC
      DEF PROCtask9 : PRINT test%(9) : ENDPROC


#include <stdlib.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/wait.h>

int main(int c, char **v)
{
        while (--c > 1 && !fork());
        sleep(c = atoi(v[c]));
        printf("%d\n", c);
        wait(0);
        return 0;
}


(setq
   *Boys (list
      (de abe  abi eve cath ivy jan dee fay bea hope gay)
      (de bob  cath hope abi dee eve fay bea jan ivy gay)
      (de col  hope eve abi dee bea fay ivy gay cath jan)
      (de dan  ivy fay dee gay hope eve jan bea cath abi)
      (de ed   jan dee bea cath fay eve abi ivy hope gay)
      (de fred bea abi dee gay eve ivy cath jan hope fay)
      (de gav  gay eve ivy bea cath abi dee hope jan fay)
      (de hal  abi eve hope fay ivy cath jan bea gay dee)
      (de ian  hope cath dee gay bea abi fay ivy jan eve)
      (de jon  abi fay jan gay eve bea dee cath ivy hope) )
   *Girls (list
      (de bi   bob fred jon gav ian abe dan ed col hal)
      (de bea  bob abe col fred gav dan ian ed jon hal)
      (de cath fred bob ed gav hal col ian abe dan jon)
      (de dee  fred jon col abe ian hal gav dan bob ed)
      (de eve  jon hal fred dan abe gav col ed ian bob)
      (de fay  bob abe ed ian jon dan fred gav col hal)
      (de gay  jon gav hal fred bob abe col ed dan ian)
      (de hope gav jon bob abe ian dan hal ed col fred)
      (de ivy  ian col hal gav fred bob abe ed jon dan)
      (de jan  ed hal gav abe bob jon col ian fred dan) )
   *Couples NIL )

(bind *Boys
   (while
      (find
         '((Boy) (and (val Boy) (not (asoq Boy *Couples))))
         *Boys )
      (let (Boy @  Girl (pop Boy)  Pair (find '((P) (== Girl (cdr P))) *Couples))
         (nond
            (Pair (push '*Couples (cons Boy Girl)))   # Girl is free
            ((memq Boy (memq (car Pair) (val Girl)))  # Girl prefers Boy
               (set Pair Boy) ) ) ) ) )

(for Pair *Couples
   (prinl (cdr Pair) " is engaged to " (car Pair)) )

(de checkCouples ()
   (unless
      (filter
         '((Pair)
            (let (Boy (car Pair)  Girl (cdr Pair))
               (find
                  '((B)
                     (and
                        (memq Boy (cdr (memq B (val Girl))))  # Girl prefers B
                        (memq
                           (cdr (asoq B *Couples))            # and B prefers Girl
                           (cdr (memq Girl (val B))) )
                        (prinl
                           Girl " likes " B " better than " Boy " and "
                           B " likes " Girl " better than "
                           (cdr (asoq B *Couples)) ) ) )
                  (val Girl) ) ) )
         *Couples )
      (prinl "All marriages are stable") ) )

(checkCouples)
(prinl)
(prinl "Engage fred with abi and jon with bea")
(con (asoq 'fred *Couples) 'abi)
(con (asoq 'jon *Couples) 'bea)
(checkCouples)


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% facts
prefere(abe,[ abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay]).
prefere(  bob,[ cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay]).
prefere(  col,[ hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan]).
prefere(  dan,[ ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi]).
prefere(   ed,[ jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay]).
prefere( fred,[ bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay]).
prefere(  gav,[ gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay]).
prefere(  hal,[ abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee]).
prefere(  ian,[ hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve]).
prefere(  jon,[ abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope]).

prefere(  abi,[ bob, fred, jon, gav, ian, abe, dan, ed, col, hal]).
prefere(  bea,[ bob, abe, col, fred, gav, dan, ian, ed, jon, hal]).
prefere( cath,[ fred, bob, ed, gav, hal, col, ian, abe, dan, jon]).
prefere(  dee,[ fred, jon, col, abe, ian, hal, gav, dan, bob, ed]).
prefere(  eve,[ jon, hal, fred, dan, abe, gav, col, ed, ian, bob]).
prefere(  fay,[ bob, abe, ed, ian, jon, dan, fred, gav, col, hal]).
prefere(  gay,[ jon, gav, hal, fred, bob, abe, col, ed, dan, ian]).
prefere( hope,[ gav, jon, bob, abe, ian, dan, hal, ed, col, fred]).
prefere(  ivy,[ ian, col, hal, gav, fred, bob, abe, ed, jon, dan]).
prefere(  jan,[ ed, hal, gav, abe, bob, jon, col, ian, fred, dan]).

man(abe).
man(bob).
man(col).
man(dan).
man(ed).
man(fred).
man(gav).
man(hal).
man(ian).
man(jon).

woman(abi).
woman(bea).
woman(cath).
woman(dee).
woman(eve).
woman(fay).
woman(gay).
woman(hope).
woman(ivy).
woman(jan).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% rules

stable_mariage :-
	new(LstMan, chain),
	forall(man(X),
	       (   prefere(X, Lst),
		   new(P, man(X, Lst)),
		   send(LstMan, append, P))),

	new(LstWoman, chain),
	forall(woman(X),
	       (   prefere(X, Lst),
		   new(P, woman(X, Lst)),
		   send(LstWoman, append, P))),
	send(LstMan, for_all, message(@arg1, init_liste, LstWoman)),
	send(LstWoman, for_all, message(@arg1, init_liste, LstMan)),

	round(LstMan, LstWoman),
	new(LstCouple, chain),
	% creation of the couple.
	send(LstWoman, for_all, and(message(@prolog, create_couple, @arg1, LstCouple),
				   message(@pce, write_ln, @arg1?name, with, @arg1?elu?name))),

	nl,

	% test of the stability of couples
	stability(LstCouple),
	nl,

	% Perturbation of couples
	get(LstCouple, size, Len),
	get_two_random_couples(Len, V1, V2),

	get(LstCouple, nth0, V1, C1),
	get(LstCouple, nth0, V2, C2),
	new(NC1, tuple(C1?first, C2?second)),
	new(NC2, tuple(C2?first, C1?second)),
	send(LstCouple, nth0, V1, NC1),
	send(LstCouple, nth0, V2, NC2),

	send(@pce, write_ln, 'perturbation of couples'),
	send(@pce, write_ln, NC1?second, with, NC1?first),
	send(@pce, write_ln, NC2?second, with, NC2?first),
	nl,

	stability(LstCouple).

get_two_random_couples(Len, C1, C2) :-
	C1 is random(Len),
	repeat,
	C2 is random(Len),
	C1 \= C2.

create_couple(Woman, LstCouple ) :-
	send(LstCouple, append, new(_, tuple(Woman?elu?name, Woman?name))).

% iterations of the algorithm
round(LstMan, LstWoman) :-
	send(LstMan, for_some, message(@arg1, propose)),
	send(LstWoman, for_some, message(@arg1, dispose)),
	(   \+send(LstWoman, for_all, @arg1?status == maybe)
	->
	    round(LstMan, LstWoman)
	;
	    true
	).

:-pce_begin_class(person, object, "description of a person").
variable(name, object, both, "name of the person").
variable(preference, chain, both, "list of priority").
variable(status, object, both, "statut of engagement : maybe / free").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise),
	send(P, slot, name, Name),
	send(P, slot, preference, Pref),
	send(P, slot, status, free).

% reception of the list of partners
init_liste(P, Lst) :->
	% we replace the list of name of partners
	% with the list of persons partners.
	new(NLP, chain),
	get(P, slot, preference, LP),
	send(LP, for_all, message(@prolog, find_person,@arg1, Lst, NLP)),
	send(P, slot, preference, NLP).

:- pce_end_class(person).

find_person(Name, LstPerson, LstPref) :-
	get(LstPerson, find, @arg1?name == Name, Elem),
	send(LstPref, append, Elem).

:-pce_begin_class(man, person, "description of a man").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise, Name, Pref).

% a man propose "la botte" to a woman
propose(P) :->
	get(P, slot, status, free),
	get(P, slot, preference, XPref),
	get(XPref, delete_head, Pref),
	send(P, slot, preference, XPref),
	send(Pref, proposition, P).

refuse(P) :->
	send(P, slot, status, free).

accept(P) :->
	send(P, slot, status, maybe).

:- pce_end_class(man).

:-pce_begin_class(woman, person, "description of a woman").
variable(elu, object, both, "name of the elu").
variable(contact, chain, both, "men that have contact this woman").

initialise(P, Name, Pref) :->
	send(P, send_super, initialise, Name, Pref),
	send(P, slot, contact, new(_, chain)),
	send(P, slot, elu, @nil).

% a woman decide Maybe/No
dispose(P) :->
	get(P, slot, contact, Contact),
	get(P, slot, elu, Elu),

	(   Elu \= @nil
	->
	    send(Contact, append, Elu)
	;
	    true),

	new(R, chain),
	send(Contact, for_all, message(P, fetch, @arg1, R)),
	send(R, sort, ?(@arg1?first, compare, @arg2?first)),
	get(R, delete_head, Tete),
	send(Tete?second, accept),
	send(P, slot, status, maybe),
	send(P, slot, elu, Tete?second),
	send(R, for_some, message(@arg1?second, refuse)),
	send(P, slot, contact, new(_, chain)) .

% looking for the person of the given name  Contact
% Adding it in the chain Chain
fetch(P, Contact, Chain) :->
	get(P, slot, preference, Lst),
	get(Lst, find, @arg1?name == Contact?name, Elem),
	get(Lst, index, Elem, Ind),
	send(Chain, append, new(_, tuple(Ind, Contact))).

% a woman receive a proposition from a man
proposition(P, Name) :->
	get(P, slot, contact, C),
	send(C, append, Name),
	send(P, slot, contact, C).

:- pce_end_class(woman).

% computation of the stability od couple
stability(LstCouple) :-
	chain_list(LstCouple, LstPceCouple),
	maplist(transform, LstPceCouple, PrologLstCouple),
	study_couples(PrologLstCouple, [], UnstableCouple),
	(   UnstableCouple = []
	->
	    writeln('Couples are stable')
	;
	    sort(UnstableCouple, SortUnstableCouple),
	    writeln('Unstable couples are'),
	    maplist(print_unstable_couple, SortUnstableCouple),
	    nl
	).

print_unstable_couple((C1, C2)) :-
	format('~w and ~w~n', [C1, C2]).

transform(PceCouple, couple(First, Second)):-
	get(PceCouple?first, value, First),
	get(PceCouple?second, value, Second).

study_couples([], UnstableCouple, UnstableCouple).

study_couples([H | T], CurrentUnstableCouple, UnstableCouple):-
	include(unstable_couple(H), T, Lst),
	(   Lst \= []
	->
	    maplist(build_one_couple(H), Lst, Lst1),
	    append(CurrentUnstableCouple, Lst1,CurrentUnstableCouple1)
	;
	    CurrentUnstableCouple1 = CurrentUnstableCouple
	),
	study_couples(T, CurrentUnstableCouple1, UnstableCouple).

build_one_couple(C1, C2, (C1, C2)).

unstable_couple(couple(X1, Y1), couple(X2, Y2)) :-
	prefere(X1, PX1),
	prefere(X2, PX2),
	prefere(Y1, PY1),
	prefere(Y2, PY2),

	% index of women for X1
	nth0(IY12, PX1, Y2),
	nth0(IY11, PX1, Y1),
	% index of men for Y2
	nth0(IX21, PY2, X1),
	nth0(IX22, PY2, X2),

	% index of women for X2
	nth0(IY21, PX2, Y1),
	nth0(IY22, PX2, Y2),
	% index of men for Y1
	nth0(IX11, PY1, X1),
	nth0(IX12, PY1, X2),

	% A couple is unstable
	( (IY12 < IY11 , IX21 < IX22);
	  (IY21 < IY22 , IX12 < IX11)).


# merge input array with array x by comparing the heads of the arrays
# in turn; # if both arrays are sorted, the result will be sorted:
def merge(x):
  length as $length
  | (x|length) as $xl
  | if $length == 0 then x
    elif $xl == 0 then .
    else
      . as $in
      | reduce range(0; $xl + $length) as $z
         # state [ix, xix, ans]
         ( [0, 0, []];
           if .[0] < $length and
              ((.[1] < $xl and $in[.[0]] <= x[.[1]]) or .[1] == $xl)
           then [(.[0] + 1), .[1], (.[2] + [$in[.[0]]]) ]
           else [.[0], (.[1] + 1), (.[2] + [x[.[1]]]) ]
           end
         ) | .[2]
    end ;

def strand_sort:
  # The inner function emits [strand, remainder]
  def strand:
    if length <= 1 then .
    else
      reduce .[] as $x
      # state: [strand, remainder]
      ([ [], [] ];
       if ((.[0]|length) == 0) or .[0][-1] <= $x
       then [ (.[0] + [$x]), .[1] ]
       else [ .[0], (.[1] + [$x]) ]
       end )
    end ;

  if length <= 1 then .
  else strand as $s
    | ($s[0] | merge( $s[1] | strand_sort))
  end ;


function mergelist(a, b)
    out = Vector{Int}()
    while !isempty(a) && !isempty(b)
        if a[1] < b[1]
            push!(out, popfirst!(a))
        else
            push!(out, popfirst!(b))
        end
    end
    append!(out, a)
    append!(out, b)
    out
end

function strand(a)
    i, s = 1, [popfirst!(a)]
    while i < length(a) + 1
        if a[i] > s[end]
            append!(s, splice!(a, i))
        else
            i += 1
        end
    end
    s
end

strandsort(a) = (out = strand(a); while !isempty(a) out = mergelist(out, strand(a)) end; out)

println(strandsort([1, 6, 3, 2, 1, 7, 5, 3]))


// version 1.1.2

fun <T : Comparable<T>> strandSort(l: List<T>): List<T> {
    fun merge(left: MutableList<T>, right: MutableList<T>): MutableList<T> {
        val res = mutableListOf<T>()
        while (!left.isEmpty() && !right.isEmpty()) {
            if (left[0] <= right[0]) {
                res.add(left[0])
                left.removeAt(0)
            }
            else {
                res.add(right[0])
                right.removeAt(0)
            }
        }
        res.addAll(left)
        res.addAll(right)
        return res
    }

    var list = l.toMutableList()
    var result = mutableListOf<T>()
    while (!list.isEmpty()) {
        val sorted = mutableListOf(list[0])
        list.removeAt(0)
        val leftover = mutableListOf<T>()
        for (item in list) {
            if (sorted.last() <= item)
                sorted.add(item)
            else
                leftover.add(item)
        }
        result = merge(sorted, result)
        list = leftover
    }
    return result
}

fun main(args: Array<String>) {
    val l = listOf(-2, 0, -2, 5, 5, 3, -1, -3, 5, 5, 0, 2, -4, 4, 2)
    println(strandSort(l))
}


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

class Program
{
    static void ThreadStart(object item)
    {
        Thread.Sleep(1000 * (int)item);
        Console.WriteLine(item);
    }

    static void SleepSort(IEnumerable<int> items)
    {
        foreach (var item in items)
        {
            new Thread(ThreadStart).Start(item);
        }
    }

    static void Main(string[] arguments)
    {
        SleepSort(arguments.Select(int.Parse));
    }
}


#include <chrono>
#include <iostream>
#include <thread>
#include <vector>

int main(int argc, char* argv[]) {
  std::vector<std::thread> threads;

  for (int i = 1; i < argc; ++i) {
    threads.emplace_back([i, &argv]() {
      int arg = std::stoi(argv[i]);
      std::this_thread::sleep_for(std::chrono::seconds(arg));
      std::cout << argv[i] << std::endl;
    });
  }

  for (auto& thread : threads) {
    thread.join();
  }
}


(ns sleepsort.core
  (require [clojure.core.async :as async :refer [chan go <! <!! >! timeout]]))

(defn sleep-sort [l]
  (let [c (chan (count l))]
    (doseq [i l]
      (go (<! (timeout (* 1000 i)))
          (>! c i)))
    (<!! (async/into [] (async/take (count l) c)))))


#coupleCount = 10

DataSection
  ;guys
  Data.s "abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay"
  Data.s "bob: cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay"
  Data.s "col: hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan"
  Data.s "dan: ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi"
  Data.s "ed: jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay"
  Data.s "fred: bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay"
  Data.s "gav: gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay"
  Data.s "hal: abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee"
  Data.s "ian: hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve"
  Data.s "jon: abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope"
  ;gals
  Data.s "abi: bob, fred, jon, gav, ian, abe, dan, ed, col, hal"
  Data.s "bea: bob, abe, col, fred, gav, dan, ian, ed, jon, hal"
  Data.s "cath: fred, bob, ed, gav, hal, col, ian, abe, dan, jon"
  Data.s "dee: fred, jon, col, abe, ian, hal, gav, dan, bob, ed"
  Data.s "eve: jon, hal, fred, dan, abe, gav, col, ed, ian, bob"
  Data.s "fay: bob, abe, ed, ian, jon, dan, fred, gav, col, hal"
  Data.s "gay: jon, gav, hal, fred, bob, abe, col, ed, dan, ian"
  Data.s "hope: gav, jon, bob, abe, ian, dan, hal, ed, col, fred"
  Data.s "ivy: ian, col, hal, gav, fred, bob, abe, ed, jon, dan"
  Data.s "jan: ed, hal, gav, abe, bob, jon, col, ian, fred, dan"
EndDataSection

Structure message
  source.s ;person that message is from
  dest.s   ;person that message is for
  action.s ;{'P', 'A', 'D', 'B'} for proposal, accept, decline, break-up
EndStructure

Structure person
  name.s
  isEngagedTo.s
  List prefs.s()
EndStructure

Global NewList messages.message()

Procedure setupPersons(List persons.person(), count)
  Protected i, j, start, pref$
  For i = 1 To count
    Read.s pref$
    pref$ = LCase(pref$)
    start = FindString(pref$, ":", 1)
    AddElement(persons())
    persons()\name = Left(pref$, start - 1)
    pref$ = Trim(Right(pref$, Len(pref$) - start))
    For j = 1 To count
      AddElement(persons()\prefs())
      persons()\prefs() = Trim(StringField(pref$, j, ","))
    Next
  Next
EndProcedure

Procedure sendMessage(source.s, dest.s, action.s)
  LastElement(messages())
  AddElement(messages())
  With messages()
    \source = source
    \dest = dest
    \action = action
  EndWith
  ResetList(messages())
EndProcedure

Procedure selectPerson(name.s, List persons.person())
  ForEach persons()
    If persons()\name = name
      Break
    EndIf
  Next
EndProcedure

Procedure rankPerson(name.s, List prefs.s())
  ForEach prefs()
    If prefs() = name
      ProcedureReturn #coupleCount - ListIndex(prefs()) ;higher is better
    EndIf
  Next
  ProcedureReturn -1 ;no rank, shouldn't occur
EndProcedure

Procedure stabilityCheck(List guys.person(), List gals.person())
  Protected isStable = #True
  ForEach guys()
    rankPerson(guys()\isEngagedTo, guys()\prefs())
    While PreviousElement(guys()\prefs())
      selectPerson(guys()\prefs(), gals())
      If rankPerson(guys()\name, gals()\prefs()) > rankPerson(gals()\isEngagedTo, gals()\prefs())
        Print("  " + gals()\name + " loves " + guys()\name + " more than " + gals()\isEngagedTo + ",")
        PrintN(" And " + guys()\name + " loves " + gals()\name + " more than " + guys()\isEngagedTo + ".")
        isStable = #False
      EndIf
    Wend
  Next
  If isStable
    PrintN(#CRLF$ + "Marriage stability check PASSED.")
  Else
    PrintN(#CRLF$ + "Marriage stability check FAILED.")
  EndIf
EndProcedure

NewList guys.person()
NewList gals.person()
setupPersons(guys(), #coupleCount)
setupPersons(gals(), #coupleCount)

;make initial round of proposals
ForEach guys()
  FirstElement(guys()\prefs())
  sendMessage(guys()\name, guys()\prefs(), "P")
Next

;dispatch messages
Define source.s, dest.s, action.s
ForEach messages()
  source = messages()\source
  dest = messages()\dest
  action = messages()\action

  DeleteElement(messages())
  Select action
    Case "P" ;propose ;only message received by gals
      selectPerson(dest, gals())
      selectPerson(source, guys())
      If rankPerson(guys()\name, gals()\prefs()) < rankPerson(gals()\isEngagedTo, gals()\prefs())
        sendMessage(dest, source, "D") ;decline proposal
      ElseIf rankPerson(guys()\name, gals()\prefs()) > rankPerson(gals()\isEngagedTo, gals()\prefs())
        If gals()\isEngagedTo
          sendMessage(dest, gals()\isEngagedTo, "B")  ;break-up engagement
        EndIf
        gals()\isEngagedTo = source
        sendMessage(dest, source, "A") ;accept proposal
      EndIf
    Case "A", "D", "B" ;messages received by guys
      selectPerson(dest, guys())
      If action = "A" ;proposal accepted
        guys()\isEngagedTo = source
      Else
        If action = "B" ;broke-up
          guys()\isEngagedTo = ""
        EndIf
        NextElement(guys()\prefs())
        sendMessage(dest, guys()\prefs(),"P") ;propose to next pref
      EndIf
  EndSelect
Next

If OpenConsole()
  PrintN("Marriages:")
  ForEach guys()
    PrintN("  " + guys()\name + " And " + guys()\isEngagedTo + ".")
  Next
  stabilityCheck(guys(), gals())

  Define *person_1.person, *person_2.person
  PrintN(#CRLF$ + "Introducing an error by swapping partners of abi and bea.")
  selectPerson("abi", gals()): *person_1 = @gals()
  selectPerson("bea", gals()): *person_2 = @gals()
  Swap *person_1\isEngagedTo, *person_2\isEngagedTo
  selectPerson(*person_1\isEngagedTo, guys()): *person_1 = @guys()
  selectPerson(*person_1\isEngagedTo, guys()): *person_2 = @guys()
  Swap *person_1\isEngagedTo, *person_2\isEngagedTo
  PrintN("  " + *person_1\name + " is now with " + *person_1\isEngagedTo + ".")
  PrintN("  " + *person_2\name + " is now with " + *person_2\isEngagedTo + ".")
  PrintN("")
  stabilityCheck(guys(), gals())

  Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
  CloseConsole()
EndIf


StrandSort[ input_ ] := Module[ {results = {}, A = input},
While[[email protected] > 0,
 sublist = {A[[1]]}; A = A[[2;;All]];
  For[i = 1, i < [email protected], i++,
   If[ A[[i]] > [email protected], AppendTo[sublist, A[[i]]]; A = Delete[A, i];]
  ];
 results = #[[[email protected]#]]&@Join[sublist, results];];
results ]
StrandSort[{2, 3, 7, 5, 1, 4, 7}]


fn strandSort arr =
(
	arr = deepcopy arr
	local sub = #()
	local results = #()
	while arr.count > 0 do
	(
		sub = #()
		append sub (amax arr)
		deleteitem arr (for i in 1 to arr.count where arr[i] == amax arr collect i)[1]
		local i = 1
		while i <= arr.count do
		(
			if arr[i] > sub[sub.count] do
			(
				append sub arr[i]
				deleteitem arr i
			)
			i += 1
		)
		results = join sub results
	)
	return results

)


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

import java.util.List

placesList = [String -
    "UK  London",     "US  New York",   "US  Boston",     "US  Washington" -
  , "UK  Washington", "US  Birmingham", "UK  Birmingham", "UK  Boston"     -
]

lists = [ -
    placesList -
  , strandSort(String[] Arrays.copyOf(placesList, placesList.length)) -
]

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 strandSort(A = String[]) public constant binary returns String[]

  rl = String[A.length]
  al = List strandSort(Arrays.asList(A))
  al.toArray(rl)

  return rl

method strandSort(Alst = List) public constant binary returns ArrayList

  A = ArrayList(Alst)
  result = ArrayList()
  loop label A_ while A.size > 0
    sublist = ArrayList()
    sublist.add(A.get(0))
    A.remove(0)
    loop i_ = 0 while i_ < A.size - 1
      if (Comparable A.get(i_)).compareTo(Comparable sublist.get(sublist.size - 1)) > 0 then do
        sublist.add(A.get(i_))
        A.remove(i_)
        end
      end i_
      result = merge(result, sublist)
    end A_

  return result

method merge(left = List, right = List) public constant binary returns ArrayList

  result = ArrayList()
  loop label mx while left.size > 0 & right.size > 0
    if (Comparable left.get(0)).compareTo(Comparable right.get(0)) <= 0 then do
      result.add(left.get(0))
      left.remove(0)
      end
    else do
      result.add(right.get(0))
      right.remove(0)
      end
    end mx
    if left.size > 0 then do
      result.addAll(left)
      end
    if right.size > 0 then do
      result.addAll(right)
      end

  return result


after = (s, f) -> setTimeout f, s*1000

# Setting Computer Science back at least a century, maybe more,
# this algorithm sorts integers using a highly parallelized algorithm.
sleep_sort = (arr) ->
  for n in arr
    do (n) -> after n, -> console.log n

do ->
  input = (parseInt(arg) for arg in process.argv[2...])
  sleep_sort input


(defun sleeprint(n)
    (sleep (/ n 10))
    (format t "~a~%" n))

(loop for arg in (cdr sb-ext:*posix-argv*) doing
      (sb-thread:make-thread (lambda() (sleeprint (parse-integer arg)))))

(loop while (not (null (cdr (sb-thread:list-all-threads)))))


void main(string[] args)
{
    import core.thread, std;
    args.drop(1).map!(a => a.to!uint).parallel.each!((a)
    {
        Thread.sleep(dur!"msecs"(a));
        write(a, " ");
    });
}


import copy

guyprefers = {
 'abe':  ['abi', 'eve', 'cath', 'ivy', 'jan', 'dee', 'fay', 'bea', 'hope', 'gay'],
 'bob':  ['cath', 'hope', 'abi', 'dee', 'eve', 'fay', 'bea', 'jan', 'ivy', 'gay'],
 'col':  ['hope', 'eve', 'abi', 'dee', 'bea', 'fay', 'ivy', 'gay', 'cath', 'jan'],
 'dan':  ['ivy', 'fay', 'dee', 'gay', 'hope', 'eve', 'jan', 'bea', 'cath', 'abi'],
 'ed':   ['jan', 'dee', 'bea', 'cath', 'fay', 'eve', 'abi', 'ivy', 'hope', 'gay'],
 'fred': ['bea', 'abi', 'dee', 'gay', 'eve', 'ivy', 'cath', 'jan', 'hope', 'fay'],
 'gav':  ['gay', 'eve', 'ivy', 'bea', 'cath', 'abi', 'dee', 'hope', 'jan', 'fay'],
 'hal':  ['abi', 'eve', 'hope', 'fay', 'ivy', 'cath', 'jan', 'bea', 'gay', 'dee'],
 'ian':  ['hope', 'cath', 'dee', 'gay', 'bea', 'abi', 'fay', 'ivy', 'jan', 'eve'],
 'jon':  ['abi', 'fay', 'jan', 'gay', 'eve', 'bea', 'dee', 'cath', 'ivy', 'hope']}
galprefers = {
 'abi':  ['bob', 'fred', 'jon', 'gav', 'ian', 'abe', 'dan', 'ed', 'col', 'hal'],
 'bea':  ['bob', 'abe', 'col', 'fred', 'gav', 'dan', 'ian', 'ed', 'jon', 'hal'],
 'cath': ['fred', 'bob', 'ed', 'gav', 'hal', 'col', 'ian', 'abe', 'dan', 'jon'],
 'dee':  ['fred', 'jon', 'col', 'abe', 'ian', 'hal', 'gav', 'dan', 'bob', 'ed'],
 'eve':  ['jon', 'hal', 'fred', 'dan', 'abe', 'gav', 'col', 'ed', 'ian', 'bob'],
 'fay':  ['bob', 'abe', 'ed', 'ian', 'jon', 'dan', 'fred', 'gav', 'col', 'hal'],
 'gay':  ['jon', 'gav', 'hal', 'fred', 'bob', 'abe', 'col', 'ed', 'dan', 'ian'],
 'hope': ['gav', 'jon', 'bob', 'abe', 'ian', 'dan', 'hal', 'ed', 'col', 'fred'],
 'ivy':  ['ian', 'col', 'hal', 'gav', 'fred', 'bob', 'abe', 'ed', 'jon', 'dan'],
 'jan':  ['ed', 'hal', 'gav', 'abe', 'bob', 'jon', 'col', 'ian', 'fred', 'dan']}

guys = sorted(guyprefers.keys())
gals = sorted(galprefers.keys())

def check(engaged):
    inverseengaged = dict((v,k) for k,v in engaged.items())
    for she, he in engaged.items():
        shelikes = galprefers[she]
        shelikesbetter = shelikes[:shelikes.index(he)]
        helikes = guyprefers[he]
        helikesbetter = helikes[:helikes.index(she)]
        for guy in shelikesbetter:
            guysgirl = inverseengaged[guy]
            guylikes = guyprefers[guy]
            if guylikes.index(guysgirl) > guylikes.index(she):
                print("%s and %s like each other better than "
                      "their present partners: %s and %s, respectively"
                      % (she, guy, he, guysgirl))
                return False
        for gal in helikesbetter:
            girlsguy = engaged[gal]
            gallikes = galprefers[gal]
            if gallikes.index(girlsguy) > gallikes.index(he):
                print("%s and %s like each other better than "
                      "their present partners: %s and %s, respectively"
                      % (he, gal, she, girlsguy))
                return False
    return True

def matchmaker():
    guysfree = guys[:]
    engaged  = {}
    guyprefers2 = copy.deepcopy(guyprefers)
    galprefers2 = copy.deepcopy(galprefers)
    while guysfree:
        guy = guysfree.pop(0)
        guyslist = guyprefers2[guy]
        gal = guyslist.pop(0)
        fiance = engaged.get(gal)
        if not fiance:
            # She's free
            engaged[gal] = guy
            print("  %s and %s" % (guy, gal))
        else:
            # The bounder proposes to an engaged lass!
            galslist = galprefers2[gal]
            if galslist.index(fiance) > galslist.index(guy):
                # She prefers new guy
                engaged[gal] = guy
                print("  %s dumped %s for %s" % (gal, fiance, guy))
                if guyprefers2[fiance]:
                    # Ex has more girls to try
                    guysfree.append(fiance)
            else:
                # She is faithful to old fiance
                if guyslist:
                    # Look again
                    guysfree.append(guy)
    return engaged

print('\nEngagements:')
engaged = matchmaker()

print('\nCouples:')
print('  ' + ',\n  '.join('%s is engaged to %s' % couple
                          for couple in sorted(engaged.items())))
print()
print('Engagement stability check PASSED'
      if check(engaged) else 'Engagement stability check FAILED')

print('\n\nSwapping two fiances to introduce an error')
engaged[gals[0]], engaged[gals[1]] = engaged[gals[1]], engaged[gals[0]]
for gal in gals[:2]:
    print('  %s is now engaged to %s' % (gal, engaged[gal]))
print()
print('Engagement stability check PASSED'
      if check(engaged) else 'Engagement stability check FAILED')


proc mergeList[T](a, b: var seq[T]): seq[T] =
  result = @[]
  while a.len > 0 and b.len > 0:
    if a[0] < b[0]:
      result.add a[0]
      a.delete 0
    else:
      result.add b[0]
      b.delete 0
  result.add a
  result.add b

proc strand[T](a: var seq[T]): seq[T] =
  var i = 0
  result = @[a[0]]
  a.delete 0
  while i < a.len:
    if a[i] > result[result.high]:
      result.add a[i]
      a.delete i
    else:
      inc i

proc strandSort[T](a: seq[T]): seq[T] =
  var a = a
  result = a.strand
  while a.len > 0:
    var s = a.strand
    result = mergeList(result, s)

var a = @[1, 6, 3, 2, 1, 7, 5, 3]
echo a.strandSort


let rec strand_sort (cmp : 'a -> 'a -> int) : 'a list -> 'a list = function
   []    -> []
 | x::xs ->
   let rec extract_strand x = function
      [] -> [x], []
    | x1::xs when cmp x x1 <= 0 ->
      let strand, rest = extract_strand x1 xs in x::strand, rest
    | x1::xs ->
      let strand, rest = extract_strand x xs in strand, x1::rest
   in
   let strand, rest = extract_strand x xs in
   List.merge cmp strand (strand_sort cmp rest)


strandSort(v)={
	my(sorted=[],unsorted=v,remaining,working);
	while(#unsorted,
		remaining=working=List();
		listput(working, unsorted[1]);
		for(i=2,#unsorted,
			if(unsorted[i]<working[#working],
				listput(remaining, unsorted[i])
			,
				listput(working, unsorted[i])
			)
		);
		unsorted=Vec(remaining);
		sorted=merge(sorted, Vec(working))
	);
	sorted
};
merge(u,v)={
	my(ret=vector(#u+#v),i=1,j=1);
	for(k=1,#ret,
		if(i<=#u & (j>#v | u[i]<v[j]),
			ret[k]=u[i];
			i++
		,
			ret[k]=v[j];
			j++
		)
	);
	ret
};


void main() async {
  Future<void> sleepsort(Iterable<int> input) => Future.wait(input
      .map((i) => Future.delayed(Duration(milliseconds: i), () => print(i))));

  await sleepsort([3, 10, 2, 120, 122, 121, 54]);
}


program SleepSortDemo;

{$APPTYPE CONSOLE}

uses
  Windows, SysUtils, Classes;

type
  TSleepThread = class(TThread)
  private
    FValue: Integer;
    FLock: PRTLCriticalSection;
  protected
    constructor Create(AValue: Integer; ALock: PRTLCriticalSection);
    procedure Execute; override;
  end;

constructor TSleepThread.Create(AValue: Integer; ALock: PRTLCriticalSection);
begin
  FValue:= AValue;
  FLock:= ALock;
  inherited Create(False);
end;

procedure TSleepThread.Execute;
begin
  Sleep(1000 * FValue);
  EnterCriticalSection(FLock^);
  Write(FValue:3);
  LeaveCriticalSection(FLock^);
end;

var
  A: array[0..15] of Integer;
  Handles: array[0..15] of THandle;
  Threads: array[0..15] of TThread;
  Lock: TRTLCriticalSection;
  I: Integer;

begin
  for I:= Low(A) to High(A) do
    A[I]:= Random(15);
  for I:= Low(A) to High(A) do
    Write(A[I]:3);
  Writeln;

  InitializeCriticalSection(Lock);
  for I:= Low(A) to High(A) do begin
    Threads[I]:= TSleepThread.Create(A[I], @Lock);
    Handles[I]:= Threads[I].Handle;
  end;
  WaitForMultipleObjects(Length(A), @Handles, True, INFINITE);
  for I:= Low(A) to High(A) do
    Threads[I].Free;
  DeleteCriticalSection(Lock);

  Writeln;
  ReadLn;
end.


#lang racket

(define MEN
  '([abe  abi  eve  cath ivy  jan  dee  fay  bea  hope gay ]
    [bob  cath hope abi  dee  eve  fay  bea  jan  ivy  gay ]
    [col  hope eve  abi  dee  bea  fay  ivy  gay  cath jan ]
    [dan  ivy  fay  dee  gay  hope eve  jan  bea  cath abi ]
    [ed   jan  dee  bea  cath fay  eve  abi  ivy  hope gay ]
    [fred bea  abi  dee  gay  eve  ivy  cath jan  hope fay ]
    [gav  gay  eve  ivy  bea  cath abi  dee  hope jan  fay ]
    [hal  abi  eve  hope fay  ivy  cath jan  bea  gay  dee ]
    [ian  hope cath dee  gay  bea  abi  fay  ivy  jan  eve ]
    [jon  abi  fay  jan  gay  eve  bea  dee  cath ivy  hope]))
(define WOMEN
  '([abi  bob  fred jon  gav  ian  abe  dan  ed   col  hal ]
    [bea  bob  abe  col  fred gav  dan  ian  ed   jon  hal ]
    [cath fred bob  ed   gav  hal  col  ian  abe  dan  jon ]
    [dee  fred jon  col  abe  ian  hal  gav  dan  bob  ed  ]
    [eve  jon  hal  fred dan  abe  gav  col  ed   ian  bob ]
    [fay  bob  abe  ed   ian  jon  dan  fred gav  col  hal ]
    [gay  jon  gav  hal  fred bob  abe  col  ed   dan  ian ]
    [hope gav  jon  bob  abe  ian  dan  hal  ed   col  fred]
    [ivy  ian  col  hal  gav  fred bob  abe  ed   jon  dan ]
    [jan  ed   hal  gav  abe  bob  jon  col  ian  fred dan ]))

;; x is better than y according to the l order
(define (better? x y l) (memq y (cdr (memq x l))))

(define (stable-matching Mprefs Wprefs)
  (define M (map car Mprefs))
  (define engagements (make-hasheq))
  (define preferences (make-hasheq))
  (define (engage! m w)
    (hash-set! engagements m w)
    (hash-set! engagements w m))
  (for ([m Mprefs]) (hash-set! preferences (car m) (cdr m)))
  (for ([w Wprefs]) (hash-set! preferences (car w) (cdr w)))
  (let loop ()
    (define m+w
      (for/or ([m M])
        (and (not (hash-ref engagements m #f))   ; m is free
             (let ([p (hash-ref preferences m)]) ; can propose
               (and (pair? p)
                    (let ([w (car p)])
                      (hash-set! preferences m (cdr p)) ; drop w from m
                      (cons m w)))))))
    (when m+w
      (define m (car m+w))
      (define w (cdr m+w))
      (define m* (hash-ref engagements w #f))    ; m* is w's prev engagement
      (cond [(not m*) (engage! m w)]             ; w is free
            [(better? m m* (hash-ref preferences w)) ; w prefers m over m*
             (engage! m w)
             (hash-set! engagements m* #f)])     ; m* becomes free
      (loop)))
  engagements)

(define (find-unstable Mprefs Wprefs matches)
  (for*/or ([m (map car Mprefs)] [w (map car Wprefs)])
    (define w* (hash-ref matches m))
    (define m* (hash-ref matches w))
    (and (not (eq? m m*))
         (better? w w* (cdr (assq m Mprefs)))
         (better? m m* (cdr (assq w Wprefs)))
         (cons m w))))

(define (check-stability)
  (let ([u (find-unstable MEN WOMEN matches)])
    (if u
      (printf "Unstable: ~a and ~a prefer each other over partners.\n"
              (car u) (cdr u))
      (printf "The match is stable.\n"))))
(define matches (stable-matching MEN WOMEN))
(printf "Found matches:\n")
(for ([m (map car MEN)]) (printf "  ~a, ~a\n" m (hash-ref matches m)))
(check-stability)
(let ([M (map car (take (shuffle MEN) 2))])
  (printf "Swapping wives of ~a and ~a\n" (car M) (cadr M))
  (define (swap! x y)
    (define t (hash-ref matches x))
    (hash-set! matches x (hash-ref matches y))
    (hash-set! matches y t))
  (swap! (car M) (cadr M))
  (swap! (hash-ref matches (car M)) (hash-ref matches (cadr M))))
(check-stability)


my %he-likes =
    abe  => < abi eve cath ivy jan dee fay bea hope gay >,
    bob  => < cath hope abi dee eve fay bea jan ivy gay >,
    col  => < hope eve abi dee bea fay ivy gay cath jan >,
    dan  => < ivy fay dee gay hope eve jan bea cath abi >,
    ed   => < jan dee bea cath fay eve abi ivy hope gay >,
    fred => < bea abi dee gay eve ivy cath jan hope fay >,
    gav  => < gay eve ivy bea cath abi dee hope jan fay >,
    hal  => < abi eve hope fay ivy cath jan bea gay dee >,
    ian  => < hope cath dee gay bea abi fay ivy jan eve >,
    jon  => < abi fay jan gay eve bea dee cath ivy hope >,
;

my %she-likes =
    abi  => < bob fred jon gav ian abe dan ed col hal >,
    bea  => < bob abe col fred gav dan ian ed jon hal >,
    cath => < fred bob ed gav hal col ian abe dan jon >,
    dee  => < fred jon col abe ian hal gav dan bob ed >,
    eve  => < jon hal fred dan abe gav col ed ian bob >,
    fay  => < bob abe ed ian jon dan fred gav col hal >,
    gay  => < jon gav hal fred bob abe col ed dan ian >,
    hope => < gav jon bob abe ian dan hal ed col fred >,
    ivy  => < ian col hal gav fred bob abe ed jon dan >,
    jan  => < ed hal gav abe bob jon col ian fred dan >,
;

my %fiancé;
my %fiancée;
my %proposed;

sub she-prefers ($her, $hottie) { .index($hottie) < .index(%fiancé{$her}) given ~%she-likes{$her} }
sub he-prefers  ($him, $hottie) { .index($hottie) < .index(%fiancée{$him}) given ~%he-likes{$him} }

match'em;
check-stability;

perturb'em;
check-stability;

sub match'em {                                          #'
    say 'Matchmaking:';
    while unmatched-guy() -> $guy {
        my $gal = preferred-choice($guy);
        %proposed{"$guy $gal"} = '❤';
        if not %fiancé{$gal} {
            engage($guy, $gal);
            say "\t$gal and $guy";
        }
        elsif she-prefers($gal, $guy) {
	    my $engaged-guy = %fiancé{$gal};
	    engage($guy, $gal);
	    %fiancée{$engaged-guy} = '';
	    say "\t$gal dumped $engaged-guy for $guy";
	}
    }
}

sub check-stability {
    my @instabilities = gather for flat %he-likes.keys X %she-likes.keys -> $m, $w {
	if he-prefers($m, $w) and she-prefers($w, $m) {
	    take "\t$w prefers $m to %fiancé{$w} and $m prefers $w to %fiancée{$m}";
	}
    }

    say 'Stablility:';
    if @instabilities {
	.say for @instabilities;
    }
    else {
        say "\t(all marriages stable)";
    }
}

sub unmatched-guy { %he-likes.keys.first: { not %fiancée{$_} } }

sub preferred-choice($guy) { %he-likes{$guy}.first: { not %proposed{"$guy $_" } } }

sub engage($guy, $gal) {
    %fiancé{$gal} = $guy;
    %fiancée{$guy} = $gal;
}

sub perturb'em {                                            #'
    say 'Perturb:';
    say "\tengage abi with fred and bea with jon";
    engage('fred', 'abi');
    engage('jon', 'bea');
}


program StrandSortDemo;

type
  TIntArray = array of integer;

function merge(left: TIntArray; right: TIntArray): TIntArray;
  var
    i, j, k: integer;
  begin
    setlength(merge, length(left) + length(right));
    i := low(merge);
    j := low(left);
    k := low(right);
    repeat
      if ((left[j] <= right[k]) and (j <= high(left))) or (k > high(right)) then
      begin
        merge[i] := left[j];
        inc(j);
      end
      else
      begin
        merge[i] := right[k];
        inc(k);
      end;
      inc(i);
    until i > high(merge);
  end;

function StrandSort(s: TIntArray): TIntArray;
  var
    strand: TIntArray;
    i, j: integer;
  begin
    setlength(StrandSort, length(s));
    setlength(strand, length(s));
    i := low(s);
    repeat
      StrandSort[i] := s[i];
      inc(i);
    until (s[i] < s[i-1]);
    setlength(StrandSort, i);
    repeat
      setlength(strand, 1);
      j := low(strand);
      strand[j] := s[i];
      while (s[i+1] > s[i]) and (i < high(s)) do
      begin
        inc(i);
        inc(j);
	setlength(strand, length(strand) + 1);
        Strand[j] := s[i];
      end;
      StrandSort := merge(StrandSort, strand);
      inc(i);
    until (i > high(s));
  end;

var
  data: TIntArray;
  i: integer;

begin
  setlength(data, 8);
  Randomize;
  writeln('The data before sorting:');
  for i := low(data) to high(data) do
  begin
    data[i] := Random(high(data));
    write(data[i]:4);
  end;
  writeln;
  data := StrandSort(data);
  writeln('The data after sorting:');
  for i := low(data) to high(data) do
  begin
    write(data[i]:4);
  end;
  writeln;
end.


import extensions;
import system'routines;
import extensions'threading;
import system'threading;

static sync = new object();

extension op
{
    sleepSort()
    {
        self.forEach:(n)
        {
            threadControl.start(
            {
                threadControl.sleep(1000 * n);

                lock(sync)
                {
                    console.printLine(n)
                }
            })
        }
    }
}

public program()
{
    program_arguments.skipping:1.selectBy(mssgconst toInt<convertorOp>[1]).toArray().sleepSort();

    console.readChar()
}


defmodule Sort do
  def sleep_sort(args) do
    Enum.each(args, fn(arg) -> Process.send_after(self, arg, 5 * arg) end)
    loop(length(args))
  end

  defp loop(0), do: :ok
  defp loop(n) do
    receive do
        num -> IO.puts num
               loop(n - 1)
    end
  end
end

Sort.sleep_sort [2, 4, 8, 12, 35, 2, 12, 1]


#!/usr/bin/env escript
%% -*- erlang -*-
%%! -smp enable -sname sleepsort

main(Args) ->
    lists:foreach(fun(Arg) ->
                          timer:send_after(5 * list_to_integer(Arg), self(), Arg)
                  end, Args),
    loop(length(Args)).

loop(0) ->
    ok;
loop(N) ->
    receive
        Num ->
            io:format("~s~n", [Num]),
            loop(N - 1)
    end.


/*- REXX --------------------------------------------------------------
* pref.b  Preferences of boy b
* pref.g  Preferences of girl g
* boys    List of boys
* girls   List of girls
* plist   List of proposals
* mlist   List of (current) matches
* glist   List of girls to be matched
* glist.b List of girls that proposed to boy b
* blen    maximum length of boys' names
* glen    maximum length of girls' names
---------------------------------------------------------------------*/

pref.Charlotte=translate('Bingley Darcy Collins Wickham ')
pref.Elisabeth=translate('Wickham Darcy Bingley Collins ')
pref.Jane     =translate('Bingley Wickham Darcy Collins ')
pref.Lydia    =translate('Bingley Wickham Darcy Collins ')

pref.Bingley  =translate('Jane Elisabeth Lydia Charlotte')
pref.Collins  =translate('Jane Elisabeth Lydia Charlotte')
pref.Darcy    =translate('Elisabeth Jane Charlotte Lydia')
pref.Wickham  =translate('Lydia Jane Elisabeth Charlotte')

pref.ABE='ABI EVE CATH IVY JAN DEE FAY BEA HOPE GAY'
pref.BOB='CATH HOPE ABI DEE EVE FAY BEA JAN IVY GAY'
pref.COL='HOPE EVE ABI DEE BEA FAY IVY GAY CATH JAN'
pref.DAN='IVY FAY DEE GAY HOPE EVE JAN BEA CATH ABI'
pref.ED='JAN DEE BEA CATH FAY EVE ABI IVY HOPE GAY'
pref.FRED='BEA ABI DEE GAY EVE IVY CATH JAN HOPE FAY'
pref.GAV='GAY EVE IVY BEA CATH ABI DEE HOPE JAN FAY'
pref.HAL='ABI EVE HOPE FAY IVY CATH JAN BEA GAY DEE'
pref.IAN='HOPE CATH DEE GAY BEA ABI FAY IVY JAN EVE'
pref.JON='ABI FAY JAN GAY EVE BEA DEE CATH IVY HOPE'

pref.ABI='BOB FRED JON GAV IAN ABE DAN ED COL HAL'
pref.BEA='BOB ABE COL FRED GAV DAN IAN ED JON HAL'
pref.CATH='FRED BOB ED GAV HAL COL IAN ABE DAN JON'
pref.DEE='FRED JON COL ABE IAN HAL GAV DAN BOB ED'
pref.EVE='JON HAL FRED DAN ABE GAV COL ED IAN BOB'
pref.FAY='BOB ABE ED IAN JON DAN FRED GAV COL HAL'
pref.GAY='JON GAV HAL FRED BOB ABE COL ED DAN IAN'
pref.HOPE='GAV JON BOB ABE IAN DAN HAL ED COL FRED'
pref.IVY='IAN COL HAL GAV FRED BOB ABE ED JON DAN'
pref.JAN='ED HAL GAV ABE BOB JON COL IAN FRED DAN'

If arg(1)>'' Then Do
  Say 'Input from task description'
  boys='ABE BOB COL DAN ED FRED GAV HAL IAN JON'
  girls='ABI BEA CATH DEE EVE FAY GAY HOPE IVY JAN'
  End
Else Do
  Say 'Input from link'
  girls=translate('Charlotte Elisabeth Jane  Lydia')
  boys =translate('Bingley   Collins   Darcy Wickham')
  End

debug=0
blen=0
Do i=1 To words(boys)
  blen=max(blen,length(word(boys,i)))
  End
glen=0
Do i=1 To words(girls)
  glen=max(glen,length(word(girls,i)))
  End
glist=girls
mlist=''
Do ri=1 By 1 Until glist=''            /* as long as there are girls */
  Call dbg 'Round' ri
  plist=''                             /* no proposals in this round */
  glist.=''
  Do gi=1 To words(glist)              /* loop over free girls       */
    gg=word(glist,gi)                  /* an unmathed girl           */
    b=word(pref.gg,1)                  /* her preferred boy          */
    plist=plist gg'-'||b               /* remember this proposal     */
    glist.b=glist.b gg                 /* add girl to the boy's list */
    Call dbg left(gg,glen) 'proposes to' b  /* tell the user              */
    End
  Do bi=1 To words(boys)               /* loop over all boys         */
    b=word(boys,bi)                    /* one of them                */
    If glist.b>'' Then                 /* if he's got proposals      */
      Call dbg b 'has these proposals' glist.b /* show them               */
    End
  Do bi=1 To words(boys)               /* loop over all boys         */
    b=word(boys,bi)                    /* one of them                */
    bm=pos(b'*',mlist)                 /* has he been matched yet?   */
    Select
      When words(glist.b)=1 Then Do    /* one girl proposed for him  */
        gg=word(glist.b,1)             /* the proposing girl         */
        If bm=0 Then Do                /* no, he hasn't              */
          Call dbg b 'accepts' gg           /* is accepted                */
          Call set_mlist 'A',mlist b||'*'||gg /* add match to mlist  */
          Call set_glist 'A',remove(gg,glist) /* remove gg from glist*/
          pref.gg=remove(b,pref.gg)    /* remove b from gg's preflist*/
          End
        Else Do                        /* boy has been matched       */
          Parse Var mlist =(bm) '*' go ' ' /* to girl go             */
          If wordpos(gg,pref.b)<wordpos(go,pref.b) Then Do
               /* the proposing girl is preferred to the current one */
                                       /* so we replace go by gg     */
            Call set_mlist 'B',repl(mlist,b||'*'||gg,b||'*'||go)
            Call dbg b 'releases' go
            Call dbg b 'accepts ' gg
            Call set_glist 'B',glist go  /* add go to list of girls  */
            Call set_glist 'C',remove(gg,glist) /* and remove gg     */
            End
          pref.gg=remove(b,pref.gg)    /* remove b from gg's preflist*/
          End
        End
      When words(glist.b)>1 Then
        Call pick_1
      Otherwise Nop
      End
    End
  Call dbg 'Matches   :' mlist
  Call dbg 'free girls:' glist
  Call check 'L'
  End
Say 'Success at round' (ri-1)
Do While mlist>''
  Parse Var mlist boy '*' girl mlist
  Say left(boy,blen) 'matches' girl
  End
Exit

pick_1:
  If bm>0 Then Do                /* boy has been matched       */
    Parse Var mlist =(bm) '*' go ' ' /* to girl go             */
    pmin=wordpos(go,pref.b)
    End
  Else Do
    go=''
    pmin=99
    End
  Do gi=1 To words(glist.b)
    gt=word(glist.b,gi)
    gp=wordpos(gt,pref.b)
    If gp<pmin Then Do
      pmin=gp
      gg=gt
      End
    End
  If bm=0 Then Do
    Call dbg b 'accepts' gg           /* is accepted                */
    Call set_mlist 'A',mlist b||'*'||gg /* add match to mlist  */
    Call set_glist 'A',remove(gg,glist) /* remove gg from glist*/
    pref.gg=remove(b,pref.gg)    /* remove b from gg's preflist*/
    End
  Else Do
    If gg<>go Then Do
      Call set_mlist 'B',repl(mlist,b||'*'||gg,b||'*'||go)
      Call dbg b 'releases' go
      Call dbg b 'accepts ' gg
      Call set_glist 'B',glist go  /* add go to list of girls  */
      Call set_glist 'C',remove(gg,glist) /* and remove gg     */
      pref.gg=remove(b,pref.gg)  /* remove b from gg's preflist*/
      End
    End
  Return

remove:
  Parse Arg needle,haystack
  pp=pos(needle,haystack)
  If pp>0 Then
    res=left(haystack,pp-1) substr(haystack,pp+length(needle))
  Else
    res=haystack
  Return space(res)

set_mlist:
  Parse Arg where,new_mlist
  Call dbg 'set_mlist' where':' mlist
  mlist=space(new_mlist)
  Call dbg 'set_mlist ->' mlist
  Call dbg ''
  Return

set_glist:
  Parse Arg where,new_glist
  Call dbg 'set_glist' where':' glist
  glist=new_glist
  Call dbg 'set_glist ->' glist
  Call dbg ''
  Return

check:
  If words(mlist)+words(glist)<>words(boys) Then Do
    Call dbg 'FEHLER bei' arg(1) (words(mlist)+words(glist))'<>10'
    say 'match='mlist'<'
    say '   glist='glist'<'
    End
  Return

dbg:
  If debug Then
    Call dbg arg(1)
  Return
repl: Procedure
  Parse Arg s,new,old
  Do i=1 To 100 Until p=0
    p=pos(old,s)
    If p>0 Then
      s=left(s,p-1)||new||substr(s,p+length(old))
    End
  Return s


use strict;
use warnings;
use feature 'say';

sub merge {
    my ($x, $y) = @_;
    my @out;
    while (@$x and @$y) {
        my $t = $x->[-1] <=> $y->[-1];
        if    ($t == 1)  { unshift @out, pop @$x }
        elsif ($t == -1) { unshift @out, pop @$y }
        else             { splice @out, 0, 0, pop(@$x), pop(@$y) }
    }
    @$x, @$y, @out
}

sub strand {
    my $x = shift;
    my @out = shift @$x // return;
    for (-@$x .. -1) {
        push @out, splice @$x, $_, 1 if $x->[$_] >= $out[-1];
    }
    @out
}

sub strand_sort {
    my @x = @_;
    my(@out, @strand);
    @out = merge \@out, \@strand while @strand = strand(\@x);
    @out
}

my @a = map (int rand(100), 1 .. 10);
say "Before @a";
@a = strand_sort(@a);
say "After  @a";


include get.e

integer count

procedure sleeper(integer key)
    ? key
    count -= 1
end procedure

sequence s, val
atom task

s = command_line()
s = s[3..$]
if length(s)=0 then
    puts(1,"Nothing to sort.\n")
else
    count = 0
    for i = 1 to length(s) do
        val = value(s[i])
        if val[1] = GET_SUCCESS then
            task = task_create(routine_id("sleeper"),{val[2]})
            task_schedule(task,{val[2],val[2]}/10)
            count += 1
        end if
    end for

    while count do
        task_yield()
    end while
end if


let sleepSort (values: seq<int>) =
    values
    |> Seq.map (fun x -> async {
        do! Async.Sleep x
        Console.WriteLine x
    })
    |> Async.Parallel
    |> Async.Ignore
    |> Async.RunSynchronously


USING: threads calendar concurrency.combinators ;

: sleep-sort ( seq -- ) [ dup seconds sleep . ] parallel-each ;


class Person
  def initialize(name)
    @name = name
    @fiance = nil
    @preferences = []
    @proposals = []
  end
  attr_reader :name, :proposals
  attr_accessor :fiance, :preferences

  def to_s
    @name
  end

  def free
    @fiance = nil
  end

  def single?
    @fiance == nil
  end

  def engage(person)
    self.fiance = person
    person.fiance = self
  end

  def better_choice?(person)
    @preferences.index(person) < @preferences.index(@fiance)
  end

  def propose_to(person)
    puts "#{self} proposes to #{person}" if $DEBUG
    @proposals << person
    person.respond_to_proposal_from(self)
  end

  def respond_to_proposal_from(person)
    if single?
      puts "#{self} accepts proposal from #{person}" if $DEBUG
      engage(person)
    elsif better_choice?(person)
      puts "#{self} dumps #{@fiance} for #{person}" if $DEBUG
      @fiance.free
      engage(person)
    else
      puts "#{self} rejects proposal from #{person}" if $DEBUG
    end
  end
end

########################################################################
# initialize data

prefs = {
  'abe'  => %w[abi eve cath ivy jan dee fay bea hope gay],
  'bob'  => %w[cath hope abi dee eve fay bea jan ivy gay],
  'col'  => %w[hope eve abi dee bea fay ivy gay cath jan],
  'dan'  => %w[ivy fay dee gay hope eve jan bea cath abi],
  'ed'   => %w[jan dee bea cath fay eve abi ivy hope gay],
  'fred' => %w[bea abi dee gay eve ivy cath jan hope fay],
  'gav'  => %w[gay eve ivy bea cath abi dee hope jan fay],
  'hal'  => %w[abi eve hope fay ivy cath jan bea gay dee],
  'ian'  => %w[hope cath dee gay bea abi fay ivy jan eve],
  'jon'  => %w[abi fay jan gay eve bea dee cath ivy hope],
  'abi'  => %w[bob fred jon gav ian abe dan ed col hal],
  'bea'  => %w[bob abe col fred gav dan ian ed jon hal],
  'cath' => %w[fred bob ed gav hal col ian abe dan jon],
  'dee'  => %w[fred jon col abe ian hal gav dan bob ed],
  'eve'  => %w[jon hal fred dan abe gav col ed ian bob],
  'fay'  => %w[bob abe ed ian jon dan fred gav col hal],
  'gay'  => %w[jon gav hal fred bob abe col ed dan ian],
  'hope' => %w[gav jon bob abe ian dan hal ed col fred],
  'ivy'  => %w[ian col hal gav fred bob abe ed jon dan],
  'jan'  => %w[ed hal gav abe bob jon col ian fred dan],
}

@men = Hash[
  %w[abe bob col dan ed fred gav hal ian jon].collect do |name|
    [name, Person.new(name)]
  end
]

@women = Hash[
  %w[abi bea cath dee eve fay gay hope ivy jan].collect do |name|
    [name, Person.new(name)]
  end
]

@men.each {|name, man| man.preferences = @women.values_at(*prefs[name])}
@women.each {|name, woman| woman.preferences = @men.values_at(*prefs[name])}

########################################################################
# perform the matching

def match_couples(men, women)
  men.each_value {|man| man.free}
  women.each_value {|woman| woman.free}

  while m = men.values.find {|man| man.single?} do
    puts "considering single man #{m}" if $DEBUG
    w = m.preferences.find {|woman| not m.proposals.include?(woman)}
    m.propose_to(w)
  end
end

match_couples @men, @women

@men.each_value.collect {|man| puts "#{man} + #{man.fiance}"}

########################################################################
# check for stability

class Person
  def more_preferable_people
    ( @preferences.partition {|p| better_choice?(p)} ).first
  end
end

require 'set'

def stability(men)
  unstable = Set.new
  men.each_value do |man|
    woman = man.fiance
    puts "considering #{man} and #{woman}" if $DEBUG

    man.more_preferable_people.each do |other_woman|
      if other_woman.more_preferable_people.include?(man)
        puts "an unstable pairing: #{man} and #{other_woman}" if $DEBUG
        unstable << [man, other_woman]
      end
    end
    woman.more_preferable_people.each do |other_man|
      if other_man.more_preferable_people.include?(woman)
        puts "an unstable pairing: #{woman} and #{other_man}" if $DEBUG
        unstable << [other_man, woman]
      end
    end
  end

  if unstable.empty?
    puts "these couples are stable"
  else
    puts "uh oh"
    unstable.each do |a,b|
      puts "#{a} is engaged to #{a.fiance} but would prefer #{b}, and #{b} is engaged to #{b.fiance} but would prefer #{a}"
    end
  end
end

stability @men

########################################################################
# perturb

puts "\nwhat if abe and bob swap..."

def swap(m1, m2)
  w1 = m1.fiance
  w2 = m2.fiance
  m1.fiance = w2
  w1.fiance = m2
  m2.fiance = w1
  w2.fiance = m1
end

swap *@men.values_at('abe','bob')

@men.each_value.collect {|man| puts "#{man} + #{man.fiance}"}
stability @men


with javascript_semantics

function merge(sequence left, right)
    sequence result = {}
    while length(left)>0
      and length(right)>0 do
        if left[$]<=right[1] then
            exit
        elsif right[$]<=left[1] then
            return result & right & left
        elsif left[1]<right[1] then
            result = append(result,left[1])
            left = left[2..$]
        else
            result = append(result,right[1])
            right = right[2..$]
        end if
    end while
    return result & left & right
end function

function strand_sort(sequence s)
    sequence result = {}
    while length(s)>0 do
        integer j = length(s)
        for i=1 to length(s)-1 do
            if s[i]>s[i+1] then
                j = i
                exit
            end if
        end for
        result = merge(result,s[1..j])
        s = s[j+1..$]
    end while
    return result
end function

?strand_sort(shuffle(tagset(10)))


$lst = new SplDoublyLinkedList();
foreach (array(1,20,64,72,48,75,96,55,42,74) as $v)
    $lst->push($v);
foreach (strandSort($lst) as $v)
    echo "$v ";

function strandSort(SplDoublyLinkedList $lst) {
    $result = new SplDoublyLinkedList();
    while (!$lst->isEmpty()) {
        $sorted = new SplDoublyLinkedList();
        $remain = new SplDoublyLinkedList();
        $sorted->push($lst->shift());
        foreach ($lst as $item) {
            if ($sorted->top() <= $item) {
                $sorted->push($item);
            } else {
                $remain->push($item);
            }
        }
        $result = _merge($sorted, $result);
        $lst = $remain;
    }
    return $result;
}

function _merge(SplDoublyLinkedList $left, SplDoublyLinkedList $right) {
    $res = new SplDoublyLinkedList();
    while (!$left->isEmpty() && !$right->isEmpty()) {
        if ($left->bottom() <= $right->bottom()) {
            $res->push($left->shift());
        } else {
            $res->push($right->shift());
        }
    }
    foreach ($left as $v)  $res->push($v);
    foreach ($right as $v) $res->push($v);
    return $res;
}


program sleepSort
    use omp_lib
    implicit none
    integer::nArgs,myid,i,stat
    integer,allocatable::intArg(:)
    character(len=5)::arg

    !$omp master
    nArgs=command_argument_count()
    if(nArgs==0)stop ' : No argument is given !'
    allocate(intArg(nArgs))
    do i=1,nArgs
        call get_command_argument(i, arg)
	read(arg,'(I5)',iostat=stat)intArg(i)
	if(intArg(i)<0 .or. stat/=0) stop&
        &' :Only 0 or positive integer allowed !'
    end do
    call omp_set_num_threads(nArgs)
    !$omp end master

    !$omp parallel private(myid)
    myid =omp_get_thread_num()
    call sleepNprint(intArg(myid+1))
    !$omp end parallel

  contains
	subroutine sleepNprint(nSeconds)
	    integer::nSeconds
            call sleep(nSeconds)
	    print*,nSeconds
	end subroutine sleepNprint
end program sleepSort


' version 21-10-2016
' compile with: fbc -s console
' compile with: fbc -s console -exx (for bondry check on the array's)
' not very well suited for large numbers and large array's
' positive numbers only

Sub sandman(sleepy() As ULong)
    Dim As Long lb = LBound(sleepy)
    Dim As Long ub = UBound(sleepy)
    Dim As Long i, count = ub
    Dim As Double wakeup(lb To ub)
    Dim As Double t = Timer

    For i = lb To ub
        wakeup(i) = sleepy(i) +1 + t
    Next

    Do
        t = Timer
        For i = lb To ub
            If wakeup(i) <= t Then
                Print Using "####";sleepy(i);
                wakeup(i) = 1e9 ' mark it as used
                count = count -1
            End If
        Next
        Sleep (1 - (Timer - t)) * 300, 1 ' reduce CPU load
    Loop Until count < lb

End Sub

' ------=< MAIN >=------

Dim As ULong i, arr(10)
Dim As ULong lb = LBound(arr)
Dim As ULong ub = UBound(arr)

Randomize Timer
For i = lb To ub -1 ' leave last one zero
    arr(i) = Int(Rnd * 10) +1
Next

Print "unsorted  ";
For i = lb To ub
    Print Using "####";arr(i);
Next
Print : Print

Print "  sorted  ";
sandman(arr())

Print : Print

' empty keyboard buffer
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End