
Sorting Algorithm

This is a sorting algorithm.   It may be applied to a set of data in order to sort it.    
For comparing various sorts, see compare sorts.  
For other sorting algorithms,   see sorting algorithms,   or:

O(n logn) sorts
Heap sort |
Merge sort |
Patience sort |
Quick sort
O(n log2n) sorts
Shell Sort
O(n2) sorts
Bubble sort |
Cocktail sort |
Cocktail sort with shifting bounds |
Comb sort |
Cycle sort |
Gnome sort |
Insertion sort |
Selection sort |
Strand sort
other sorts
Bead sort |
Bogo sort |
Common sorted list |
Composite structures sort |
Custom comparator sort |
Counting sort |
Disjoint sublist sort |
External sort |
Jort sort |
Lexicographical sort |
Natural sorting |
Order by pair comparisons |
Order disjoint list items |
Order two numerical lists |
Object identifier (OID) sort |
Pancake sort |
Quickselect |
Permutation sort |
Radix sort |
Ranking methods |
Remove duplicate elements |
Sleep sort |
Stooge sort |
[Sort letters of a string] |
Three variable sort |
Topological sort |
Tree sort


Given   M   as a list of items and another list   N   of items chosen from   M,   create   M'   as a list with the first occurrences of items from   N   sorted to be in one of the set of indices of their original occurrence in   M   but in the order given by their order in   N.

That is, items in   N   are taken from   M   without replacement, then the corresponding positions in   M'   are filled by successive items from   N.



For example

if   M   is   'the cat sat on the mat'
And   N   is   'mat cat' 
Then the result   M'   is   'the mat sat on the cat'. 
The words not in   N   are left in their original positions.



If there are duplications then only the first instances in   M   up to as many as are mentioned in   N   are potentially re-ordered.



For example

  M = 'A B C A B C A B C' 
  N = 'C A C A' 
Is ordered as:

 M' = 'C B A C B A A B C' 


Show the output, here, for at least the following inputs:

Data M: 'the cat sat on the mat' Order N: 'mat cat'
Data M: 'the cat sat on the mat' Order N: 'cat mat'
Data M: 'A B C A B C A B C'      Order N: 'C A C A'
Data M: 'A B C A B D A B E'      Order N: 'E A D A'
Data M: 'A B'                    Order N: 'B'      
Data M: 'A B'                    Order N: 'B A'    
Data M: 'A B B A'                Order N: 'B A'



Cf

 Sort disjoint sublist


---------------------- DISJOINT ORDER --------------------
 
-- disjointOrder :: String -> String -> String
on disjointOrder(m, n)
    set {ms, ns} to map(my |words|, {m, n})
 
    unwords(flatten(zip(segments(ms, ns), ns & "")))
end disjointOrder
 
 
-- segments :: [String] -> [String] -> [String]
on segments(ms, ns)
    script segmentation
        on |λ|(a, x)
            set wds to |words| of a
 
            if wds contains x then
                {parts:(parts of a) & ¬
                    [current of a], current:[], |words|:deleteFirst(x, wds)} ¬
 
            else
                {parts:(parts of a), current:(current of a) & x, |words|:wds}
            end if
        end |λ|
    end script
 
    tell foldl(segmentation, {|words|:ns, parts:[], current:[]}, ms)
        (parts of it) & [current of it]
    end tell
end segments
 
 
--------------------------- TEST -------------------------
on run
    script order
        on |λ|(rec)
            tell rec
                [its m, its n, my disjointOrder(its m, its n)]
            end tell
        end |λ|
    end script
 
 
    arrowTable(map(order, [¬
        {m:"the cat sat on the mat", n:"mat cat"}, ¬
        {m:"the cat sat on the mat", n:"cat mat"}, ¬
        {m:"A B C A B C A B C", n:"C A C A"}, ¬
        {m:"A B C A B D A B E", n:"E A D A"}, ¬
        {m:"A B", n:"B"}, {m:"A B", n:"B A"}, ¬
        {m:"A B B A", n:"B A"}]))
 
    -- the cat sat on the mat  ->  mat cat  ->  the mat sat on the cat 
    -- the cat sat on the mat  ->  cat mat  ->  the cat sat on the mat 
    -- A B C A B C A B C       ->  C A C A  ->  C B A C B A A B C      
    -- A B C A B D A B E       ->  E A D A  ->  E B C A B D A B A      
    -- A B                     ->  B        ->  A B                    
    -- A B                     ->  B A      ->  B A                    
    -- A B B A                 ->  B A      ->  B A B A                
 
end run
 
 
------------------------ FORMATTING ----------------------
 
-- arrowTable :: [[String]] -> String
on arrowTable(rows)
 
    script leftAligned
        script width
            on |λ|(a, b)
                (length of a) - (length of b)
            end |λ|
        end script
 
        on |λ|(col)
            set widest to length of maximumBy(width, col)
 
            script padding
                on |λ|(s)
                    justifyLeft(widest, space, s)
                end |λ|
            end script
 
            map(padding, col)
        end |λ|
    end script
 
    script arrows
        on |λ|(row)
            intercalate("  ->  ", row)
        end |λ|
    end script
 
    intercalate(linefeed, ¬
        map(arrows, ¬
            transpose(map(leftAligned, transpose(rows)))))
end arrowTable
 
 
-------------------- GENERIC FUNCTIONS -------------------
 
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    script append
        on |λ|(a, b)
            a & b
        end |λ|
    end script
 
    foldl(append, {}, map(f, xs))
end concatMap
 
 
-- deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
on deleteBy(fnEq, x, xs)
    if length of xs > 0 then
        set {h, t} to uncons(xs)
        if |λ|(x, h) of mReturn(fnEq) then
            t
        else
            {h} & deleteBy(fnEq, x, t)
        end if
    else
        {}
    end if
end deleteBy
 
 
-- deleteFirst :: a -> [a] -> [a]
on deleteFirst(x, xs)
    script Eq
        on |λ|(a, b)
            a = b
        end |λ|
    end script
 
    deleteBy(Eq, x, xs)
end deleteFirst
 
 
-- flatten :: Tree a -> [a]
on flatten(t)
    if class of t is list then
        concatMap(my flatten, t)
    else
        t
    end if
end flatten
 
 
-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl
 
 
-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
    set {dlm, my text item delimiters} to {my text item delimiters, strText}
    set strJoined to lstText as text
    set my text item delimiters to dlm
    return strJoined
end intercalate
 
 
-- justifyLeft :: Int -> Char -> Text -> Text
on justifyLeft(n, cFiller, strText)
    if n > length of strText then
        text 1 thru n of (strText & replicate(n, cFiller))
    else
        strText
    end if
end justifyLeft
 
 
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map
 
 
-- maximumBy :: (a -> a -> Ordering) -> [a] -> a 
on maximumBy(f, xs)
    set cmp to mReturn(f)
    script max
        on |λ|(a, b)
            if a is missing value or cmp's |λ|(a, b) < 0 then
                b
            else
                a
            end if
        end |λ|
    end script
 
    foldl(max, missing value, xs)
end maximumBy
 
 
-- minimum :: [a] -> a 
on minimum(xs)
    script min
        on |λ|(a, x)
            if x < a or a is missing value then
                x
            else
                a
            end if
        end |λ|
    end script
 
    foldl(min, missing value, xs)
end minimum
 
 
-- Lift 2nd class handler function into 1st class script wrapper 
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn
 
 
-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary 
-- assembly of a target length
 
-- replicate :: Int -> a -> [a]
on replicate(n, a)
    set out to {}
    if n < 1 then return out
    set dbl to {a}
 
    repeat while (n > 1)
        if (n mod 2) > 0 then set out to out & dbl
        set n to (n div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate
 
 
-- transpose :: [[a]] -> [[a]]
on transpose(xss)
    script column
        on |λ|(_, iCol)
            script row
                on |λ|(xs)
                    item iCol of xs
                end |λ|
            end script
 
            map(row, xss)
        end |λ|
    end script
 
    map(column, item 1 of xss)
end transpose
 
 
-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    if length of xs > 0 then
        {item 1 of xs, rest of xs}
    else
        missing value
    end if
end uncons
 
 
-- unwords :: [String] -> String
on unwords(xs)
    intercalate(space, xs)
end unwords
 
 
-- words :: String -> [String]
on |words|(s)
    words of s
end |words|
 
 
-- zip :: [a] -> [b] -> [(a, b)]
on zip(xs, ys)
    script pair
        on |λ|(x, i)
            [x, item i of ys]
        end |λ|
    end script
 
    map(pair, items 1 thru minimum([length of xs, length of ys]) of xs)
end zip