Or, generalising a little for sorting by the nth item:

```
use framework "Foundation"
use scripting additions
-- nth :: Int -> [a] -> a
script nth
on |λ|(i)
script
on |λ|(xs)
item i of xs
end |λ|
end script
end |λ|
end script
on run
set listOfLists to {{"a", "b", "y", "q"}, {"b", "b", "y", "q"}, {"a", "a", "x", "p"}, {"b", "a", "x", "m"}}
sortOn({|λ|(2) of nth, |λ|(4) of nth}, listOfLists)
-- Or, for **descending*** sort by second items then fourth items:
--sortOn({{|λ|(2) of nth, false}, {|λ|(4) of nth, false}}, listOfLists)
end run
-- REUSABLE GENERIC FUNCTIONS ---------------------------------------------------------
-- comparing :: (a -> b) -> (a -> a -> Ordering)
on comparing(f)
script
on |λ|(a, b)
tell mReturn(f)
set fa to |λ|(a)
set fb to |λ|(b)
if fa < fb then
-1
else if fa > fb then
1
else
0
end if
end tell
end |λ|
end script
end comparing
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
set acc to {}
tell mReturn(f)
repeat with x in xs
set acc to acc & |λ|(contents of x)
end repeat
end tell
return acc
end concatMap
-- curry :: ((a, b) -> c) -> a -> b -> c
on curry(f)
script
on |λ|(a)
script
on |λ|(b)
|λ|(a, b) of mReturn(f)
end |λ|
end script
end |λ|
end script
end curry
-- flatten :: Tree a -> [a]
on flatten(t)
if class of t is list then
my concatMap(my flatten, t)
else
t
end if
end flatten
-- foldr :: (a -> b -> b) -> b -> [a] -> b
on foldr(f, startValue, xs)
tell mReturn(f)
set v to startValue
set lng to length of xs
repeat with i from lng to 1 by -1
set v to |λ|(item i of xs, v, i, xs)
end repeat
return v
end tell
end foldr
-- fst :: (a, b) -> a
on fst(tpl)
if class of tpl is record then
|1| of tpl
else
item 1 of tpl
end if
end fst
-- 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
-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
if class of f is script then
f
else
script
property |λ| : f
end script
end if
end mReturn
-- SORT ON ANY PROPERTY (VALUES OF RECORD KEYS,
-- STRING LENGTH, DERIVED PROPERTIES)
-- ARGUMENTS:
-- xs: List of items to be sorted.
-- (The items can be records, lists, or simple values).
--
-- f: A single (a -> b) function (Applescript handler),
-- or a list of such functions.
-- if the argument is a list, any function can
-- optionally be followed by a bool.
-- (False -> descending sort)
--
-- (Subgrouping in the list is optional and ignored)
-- Each function (Item -> Value) in the list should
-- take an item (of the type contained by xs)
-- as its input and return a simple orderable value
-- (Number, String, or Date).
--
-- The sequence of key functions and optional
-- direction bools defines primary to N-ary sort keys.
-- sortOn :: Ord b => ((a -> b) | [((a -> b), Bool)]) -> [a] -> [a]
on sortOn(f, xs)
script keyBool
on |λ|(x, a)
if class of x is boolean then
{asc:x, lst:lst of a}
else
{asc:true, lst:({{x, asc of a}} & lst of a)}
end if
end |λ|
end script
set {fs, bs} to unzip(lst of foldr(keyBool, {asc:true, lst:{}}, flatten({f})))
set intKeys to length of fs
set ca to current application
script dec
property gs : map(my mReturn, fs)
on |λ|(x)
set nsDct to (ca's NSMutableDictionary's ¬
dictionaryWithDictionary:{val:x})
repeat with i from 1 to intKeys
(nsDct's setValue:((item i of gs)'s |λ|(x)) ¬
forKey:(character id (96 + i)))
end repeat
nsDct as record
end |λ|
end script
script descrip
on |λ|(bool, i)
ca's NSSortDescriptor's ¬
sortDescriptorWithKey:(character id (96 + i)) ¬
ascending:bool
end |λ|
end script
script undec
on |λ|(x)
val of x
end |λ|
end script
map(undec, ((ca's NSArray's arrayWithArray:map(dec, xs))'s ¬
sortedArrayUsingDescriptors:map(descrip, bs)) as list)
end sortOn
-- snd :: (a, b) -> b
on snd(tpl)
if class of tpl is record then
|2| of tpl
else
item 2 of tpl
end if
end snd
-- unzip :: [(a,b)] -> ([a],[b])
on unzip(xys)
set xs to {}
set ys to {}
repeat with xy in xys
set {x, y} to xy
set end of xs to x
set end of ys to y
end repeat
return {xs, ys}
end unzip
```