asPrelude.applescript

use AppleScript version "2.4"
use framework "Foundation"
use scripting additions

/* eslint-disable max-lines-per-function */
/* eslint-disable no-undef */
/* eslint-disable strict */
/* eslint-disable no-unused-vars */

-- Just :: a -> Maybe a
on Just(x)
    -- Constructor for an inhabited Maybe (option type) value.
    -- Wrapper containing the result of a computation.
    {type:"Maybe", Nothing:false, Just:x}
end Just

-- Left :: a -> Either a b
on |Left|(x)
    {type:"Either", |Left|:x, |Right|:missing value}
end |Left|

-- Node :: a -> [Tree a] -> Tree a
on Node(v, xs)
    {type:"Node", root:v, nest:xs}
end Node

-- Nothing :: Maybe a
on Nothing()
    -- Constructor for an empty Maybe (option type) value.
    -- Empty wrapper returned where a computation is not possible.
    {type: "Maybe", Nothing: true}
end Nothing

-- Right :: b -> Either a b
on |Right|(x)
    {type:"Either", |Left|:missing value, |Right|:x}
end |Right|

-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
    -- Constructor for a pair of values, possibly of two different types.
    {type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple

-- Tuple3 (,,) :: a -> b -> c -> (a, b, c)
on Tuple3(x, y, z)
    {type:"Tuple3", |1|:x, |2|:y, |3|:z, length:3}
end Tuple3

-- Requires N arguments to be wrapped as one list in AS 
-- (the JS version accepts N separate arguments)
-- TupleN :: a -> b ...  -> (a, b ... )
on TupleN(argv)
    tupleFromList(argv)
end TupleN

-- abs :: Num -> Num
on abs(x)
    -- Absolute value.
    if 0 > x then
        -x
    else
        x
    end if
end abs

-- add (+) :: Num a => a -> a -> a
on add(a)
    -- Curried addition.
    script
        on |λ|(b)
            a + b
        end |λ|
    end script
end add

-- all :: (a -> Bool) -> [a] -> Bool
on all(p, xs)
    -- True if p holds for every value in xs
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if not |λ|(item i of xs, i, xs) then return false
        end repeat
        true
    end tell
end all

-- allSame :: [a] -> Bool
on allSame(xs)
    if 2 > length of xs then
        true
    else
        script p
            property h : item 1 of xs
            on |λ|(x)
                h = x
            end |λ|
        end script
        all(p, rest of xs)
    end if
end allSame

-- allTree :: (a -> Bool) -> Tree a -> Bool
on allTree(p, tree)
    -- True if p holds for the value of every node in tree
    script go
        property mp : mReturn(p)'s |λ|
        on |λ|(oNode)
            if mp(root of oNode) then
                repeat with v in nest of oNode
                    if not (contents of |λ|(v)) then return false
                end repeat
                true
            else
                false
            end if
        end |λ|
    end script
    |λ|(tree) of go
end allTree

-- and :: [Bool] -> Bool
on |and|(xs)
    -- True if every value in the list is true.
    repeat with x in xs
        if not (contents of x) then return false
    end repeat
    return true
end |and|

-- any :: (a -> Bool) -> [a] -> Bool
on any(p, xs)
    -- Applied to a predicate and a list, 
    -- |any| returns true if at least one element of the 
    -- list satisfies the predicate.
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if |λ|(item i of xs) then return true
        end repeat
        false
    end tell
end any

-- anyTree :: (a -> Bool) -> Tree a -> Bool
on anyTree(p, tree)
    -- True if p holds for the value of any node in the tree.
    script go
        property mp : mReturn(p)'s |λ|
        on |λ|(oNode)
            if mp(root of oNode) then
                true
            else
                repeat with v in nest of oNode
                    if contents of |λ|(v) then return true
                end repeat
                false
            end if
        end |λ|
    end script
    |λ|(tree) of go
end anyTree

-- ap (<*>) :: Monad m => m (a -> b) -> m a -> m b
on ap(mf, mx)
    -- Applies wrapped functions to wrapped values, 
    -- for example applying a list of functions to a list of values
    -- or applying Just(f) to Just(x), Right(f) to Right(x), etc
    if class of mx is list then
        apList(mf, mx)
    else
        set t to typeName(mf)
        if "(a -> b)" = t then
            apFn(mf, mx)
        else if "Either" = t then
            apLR(mf, mx)
        else if "Maybe" = t then
            apMay(mf, mx)
        else if "Node" = t then
            apTree(mf, mx)
        else if "Tuple" = t then
            apTuple(mf, mx)
        else
            missing value
        end if
    end if
end ap

-- apFn :: (a -> b -> c) -> (a -> b) -> (a -> c)
on apFn(f, g)
    script go
        property mf : |λ| of mReturn(f)
        property mg : |λ| of mReturn(g)
        on |λ|(x)
            mf(x, mg(x))
        end |λ|
    end script
end apFn

-- apLR (<*>) :: Either e (a -> b) -> Either e a -> Either e b
on apLR(flr, lr)
    if missing value is |Left| of flr then
        if missing value is |Left| of lr then
            |Right|(|λ|(|Right| of lr) of mReturn(|Right| of flr))
        else
            lr
        end if
    else
        flr
    end if
end apLR

-- apList (<*>) :: [(a -> b)] -> [a] -> [b]
on apList(fs, xs)
    -- e.g. [(*2),(/2), sqrt] <*> [1,2,3]
    -- -->  ap([dbl, hlf, root], [1, 2, 3])
    -- -->  [2,4,6,0.5,1,1.5,1,1.4142135623730951,1.7320508075688772]
    -- Each member of a list of functions applied to
    -- each of a list of arguments, deriving a list of new values
    set lst to {}
    repeat with f in fs
        tell mReturn(contents of f)
            repeat with x in xs
                set end of lst to |λ|(contents of x)
            end repeat
        end tell
    end repeat
    return lst
end apList

-- apMay (<*>) :: Maybe (a -> b) -> Maybe a -> Maybe b
on apMay(mf, mx)
    -- Maybe f applied to Maybe x, deriving a Maybe y
    if Nothing of mf or Nothing of mx then
        Nothing()
    else
        Just(|λ|(Just of mx) of mReturn(Just of mf))
    end if
end apMay

-- apTree (<*>) :: Tree (a -> b) -> Tree a -> Tree b
on apTree(tf, tx)
    set fmap to curry(my fmapTree)
    script go
        on |λ|(t)
            set f to root of t
            Node(mReturn(f)'s |λ|(root of tx), ¬
                map(fmap's |λ|(f), nest of tx) & ¬
                map(go, nest of t))
        end |λ|
    end script
    
    return go's |λ|(tf)
end apTree

-- apTuple (<*>) :: Monoid m => (m, (a -> b)) -> (m, a) -> (m, b)
on apTuple(tf, tx)
    Tuple(mappend(|1| of tf, |1| of tx), |λ|(|2| of tx) of mReturn(|2| of tf))
end apTuple

-- append (<>) :: [a] -> [a] -> [a]
-- append (<>) :: String -> String -> String
on append(xs, ys)
    -- Append two lists.
    xs & ys
end append

-- appendFile :: FilePath -> String -> IO Bool
on appendFile(strPath, txt)
    -- Write a string to the end of a file. 
    -- Returns true if the path exists 
    -- and the write succeeded. 
    -- Otherwise returns false.
    set ca to current application
    set oFullPath to (ca's NSString's stringWithString:strPath)'s ¬
        stringByStandardizingPath
    set {blnExists, intFolder} to (ca's NSFileManager's defaultManager()'s ¬
        fileExistsAtPath:oFullPath isDirectory:(reference))
        
    if blnExists then
        if 0 = intFolder then
            set oData to (ca's NSString's stringWithString:txt)'s ¬
                dataUsingEncoding:(ca's NSUTF8StringEncoding)
            set h to ca's NSFileHandle's fileHandleForWritingAtPath:oFullPath
            h's seekToEndOfFile
            h's writeData:oData
            h's closeFile()
            true
        else
            -- text appended to folder is undefined
            false
        end if
    else
        if doesDirectoryExist(takeDirectory(oFullPath as string)) then
            writeFile(oFullPath, txt)
            true
        else
            false
        end if
    end if
end appendFile

-- appendFileMay :: FilePath -> String -> Maybe IO FilePath
on appendFileMay(strPath, txt)
    -- Write a string to the end of a file. 
    -- Returns a Just FilePath value if the 
    -- path exists and the write succeeded. 
    -- Otherwise returns Nothing.
    set ca to current application
    set oFullPath to (ca's NSString's stringWithString:strPath)'s ¬
        stringByStandardizingPath
    set strFullPath to oFullPath as string
    set {blnExists, intFolder} to (ca's NSFileManager's defaultManager()'s ¬
        fileExistsAtPath:oFullPath isDirectory:(reference))
    if blnExists then
        if 0 = intFolder then -- Not a directory
            set oData to (ca's NSString's stringWithString:txt)'s ¬
                dataUsingEncoding:(ca's NSUTF8StringEncoding)
            set h to ca's NSFileHandle's fileHandleForWritingAtPath:oFullPath
            h's seekToEndOfFile
            h's writeData:oData
            h's closeFile()
            Just(strFullPath)
        else
            Nothing()
        end if
    else
        if doesDirectoryExist(takeDirectory(strFullPath)) then
            writeFile(oFullPath, txt)
            Just(strFullPath)
        else
            Nothing()
        end if
    end if
end appendFileMay

-- appendGen (++) :: Gen [a] -> Gen [a] -> Gen [a]
on appendGen(xs, ys)
    script
        property vs : xs
        on |λ|()
            set v to |λ|() of vs
            if missing value is not v then
                v
            else
                set vs to ys
                |λ|() of ys
            end if
        end |λ|
    end script
end appendGen

-- apply ($) :: (a -> b) -> a -> b
on apply(f, x)
    mReturn(f)'s |λ|(x)
end apply

-- applyN :: Int -> (a -> a) -> a -> a
on applyN(n, f, x)
    script go
        on |λ|(a, g)
            |λ|(a) of mReturn(g)
        end |λ|
    end script
    foldl(go, x, replicate(n, f))
end applyN

-- approxRatio :: Float -> Float -> Ratio
on approxRatio(epsilon, n)
    if {real, integer} contains (class of epsilon) and 0 < epsilon then
        set e to epsilon
    else
        set e to 1 / 10000
    end if
    
    script gcde
        on |λ|(e, x, y)
            script _gcd
                on |λ|(a, b)
                    if b < e then
                        a
                    else
                        |λ|(b, a mod b)
                    end if
                end |λ|
            end script
            |λ|(abs(x), abs(y)) of _gcd
        end |λ|
    end script
    
    set c to |λ|(e, 1, n) of gcde
    Ratio((n div c), (1 div c))
end approxRatio

-- argvLength :: Function -> Int
on argvLength(h)
    try
        mReturn(h)'s |λ|()
        0
    on error errMsg
        set {dlm, my text item delimiters} to {my text item delimiters, ","}
        set xs to text items of errMsg
        set my text item delimiters to dlm
        length of xs
    end try
end argvLength

-- assocs :: Map k a -> [(k, a)]
on assocs(m)
    script go
        on |λ|(k)
            set mb to lookupDict(k, m)
            if true = |Nothing| of mb then
                {}
            else
                {{k, |Just| of mb}}
            end if
        end |λ|
    end script
    concatMap(go, keys(m))
end assocs

-- base64decode :: String -> String
on base64decode(s)
    tell current application
        set encoding to its NSUTF8StringEncoding
        set ignore to its NSDataBase64DecodingIgnoreUnknownCharacters
        
        (((alloc() of its NSString)'s initWithData:((its (NSData's alloc()'s ¬
            initWithBase64EncodedString:s ¬
                options:(ignore)))) encoding:encoding)) as text
    end tell
end base64decode

-- base64encode :: String -> String
on base64encode(s)
    tell current application
        set encodingOption to its NSUTF8StringEncoding
        base64EncodedStringWithOptions_(0) of ¬
            dataUsingEncoding_(encodingOption) of ¬
            (stringWithString_(s) of its NSString) as string
    end tell
end base64encode

-- bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
on bimap(f, g)
    -- Tuple instance of bimap.
    -- A tuple of the application of f and g to the
    -- first and second values of tpl respectively.
    script
        on |λ|(x)
            {|λ|(fst(x)) of mReturn(f), ¬
                |λ|(snd(x)) of mReturn(g)}
        end |λ|
    end script
end bimap

-- bimapLR :: (a -> b) -> (c -> d) -> ֵEither ֵֵa c -> Either b d
on bimapLR(f, g)
    script go
        on |λ|(e)
            if missing value is |Left| of e then
                tell mReturn(g) to |Right|(|λ|(|Right| of e))
            else
                tell mReturn(f) to |Left|(|λ|(|Left| of e))
            end if
        end |λ|
    end script
end bimapLR

-- bimapN :: (a -> b) -> (c -> d) -> TupleN -> TupleN
on bimapN(f, g, tplN)
    set z to length of tplN
    set k1 to (z - 1) as string
    set k2 to z as string
    
    insertDict(k2, mReturn(g)'s |λ|(Just of lookupDict(k2, tplN)), ¬
        insertDict(k1, mReturn(f)'s |λ|(Just of lookupDict(k1, tplN)), tplN))
end bimapN

-- bind (>>=) :: Monad m => m a -> (a -> m b) -> m b
on bind(m, mf)
    set c to class of m
    if list = c then
        bindList(m, mf)
    else if record = c then
        set ks to keys(m)
        if ks contains "type" then
            set t to type of m
            if "Maybe" = t then
                bindMay(m, mf)
            else if "Either" = t then
                bindLR(m, mf)
            else if "Tuple" = t then
                bindTuple(m, mf)
            else
                missing value
            end if
        else
            missing value
        end if
    else if handler is c or script is c then
        bindFn(m, mf)
    else
        missing value
    end if
end bind

-- bindFn (>>=) :: (a -> b) -> (b -> a -> c) -> a -> c
on bindFn(f, bop)
    -- Where either bop or f is a  binary operator.
    script
        property mf : mReturn(f)
        property mop : mReturn(bop)
        on |λ|(x)
            try
                curry(mop)'s |λ|(mf's |λ|(x))'s |λ|(x)
            on error
                mop's |λ|(curry(mf)'s |λ|(x))'s |λ|(x)
            end try
        end |λ|
    end script
end bindFn

-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
on bindLR(m, mf)
    if missing value is not |Left| of m then
        m
    else
        mReturn(mf)'s |λ|(|Right| of m)
    end if
end bindLR

-- bindList (>>=) :: [a] -> (a -> [b]) -> [b]
on bindList(xs, f)
    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 bindList

-- bindMay (>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b
on bindMay(mb, mf)
    -- bindMay provides the mechanism for composing a
    -- sequence of (a -> Maybe b) functions.
    -- If m is Nothing, it is passed straight through.
    -- If m is Just(x), the result is an application
    -- of the (a -> Maybe b) function (mf) to x.
    if Nothing of mb then
        mb
    else
        tell mReturn(mf) to |λ|(Just of mb)
    end if
end bindMay

-- bindTuple (>>=) :: Monoid a => (a, a) -> (a -> (a, b)) -> (a, b)
on bindTuple(tpl, f)
    set t2 to mReturn(f)'s |λ|(|2| of tpl)
    Tuple(mappend(|1| of tpl, |1| of t2), |2| of t2)
end bindTuple

-- bool :: a -> a -> Bool -> a
on bool(ff, tf)
    -- The evaluation of either tf or ff, 
    -- depending on a boolean value.
    script
        on |λ|(bln)
            if bln then
                set e to tf
            else
                set e to ff
            end if
            set c to class of e
            if {script, handler} contains c then
                |λ|() of mReturn(e)
            else
                e
            end if
        end |λ|
    end script
end bool

-- break :: (a -> Bool) -> [a] -> ([a], [a])
on break(p, xs)
    set bln to false
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if |λ|(item i of xs) then
                set bln to true
                exit repeat
            end if
        end repeat
    end tell
    if bln then
        if 1 < i then
            {items 1 thru (i - 1) of xs, items i thru -1 of xs}
        else
            {{}, xs}
        end if
    else
        {xs, {}}
    end if
end break

-- breakOn :: String -> String -> (String, String)
on breakOn(pat, src)
    -- non null needle -> haystack -> (prefix before match, match + rest)
    if pat ≠ "" then
        set {dlm, my text item delimiters} to {my text item delimiters, pat}
        
        set lstParts to text items of src
        set lngParts to length of lstParts
        
        if 1 < lngParts then
            set tpl to {item 1 of lstParts, pat & ¬
                ((items 2 thru -1 of lstParts) as text)}
        else
            set tpl to Tuple(src, "")
        end if
        
        set my text item delimiters to dlm
        return tpl
    else
        missing value
    end if
end breakOn

-- breakOnAll :: String -> String -> [(String, String)]
on breakOnAll(pat, src)
    -- breakOnAll "/" "a/b/c/"
    -- ==> [("a", "/b/c/"), ("a/b", "/c/"), ("a/b/c", "/")]
    if "" ≠ pat then
        script
            on |λ|(a, _, i, xs)
                if 1 < i then
                    a & {{intercalate(pat, take(i - 1, xs)), ¬
                        pat & intercalate(pat, drop(i - 1, xs))}}
                else
                    a
                end if
            end |λ|
        end script
        foldl(result, {}, splitOn(pat, src))
    else
        missing value
    end if
end breakOnAll

-- breakOnMay :: String -> String -> Maybe (String, String)
on breakOnMay(pat, src)
    -- needle -> haystack -> maybe (prefix before match, match + rest)
    if pat ≠ "" then
        set {dlm, my text item delimiters} to {my text item delimiters, pat}
        
        set lstParts to text items of src
        if length of lstParts > 1 then
            set mbTuple to Just({item 1 of lstParts, pat & ¬
                ((items 2 thru -1 of lstParts) as text)})
        else
            set mbTuple to Just({src, ""})
        end if
        
        set my text item delimiters to dlm
        return mbTuple
    else
        Nothing()
    end if
end breakOnMay

-- bulleted :: String -> String -> String
on bulleted(strIndent, s)
    script go
        on |λ|(x)
            if "" ≠ x then
                strIndent & "- " & x
            else
                x
            end if
        end |λ|
    end script
    unlines(map(go, paragraphs of s))
end bulleted

-- cartesianProduct :: [a] -> [b] -> [[a, b]]
on cartesianProduct(xs, ys)
    script
        on |λ|(x)
            script
                on |λ|(y)
                    {x, y}
                end |λ|
            end script
            concatMap(result, ys)
        end |λ|
    end script
    concatMap(result, xs)
end cartesianProduct

-- caseOf :: [(a -> Bool, b)] -> b -> a ->  b
on caseOf (pvs, otherwise, x)
    -- List of (Predicate, value) tuples -> Default value -> Value to test -> Output value
    repeat with tpl in pvs
        if mReturn(|1| of tpl)'s |λ|(x) then return |2| of tpl
    end repeat
    return otherwise
end caseOf

-- catMaybes :: [Maybe a] -> [a]
on catMaybes(mbs)
    script emptyOrListed
        on |λ|(m)
            if Nothing of m then
                {}
            else
                {Just of m}
            end if
        end |λ|
    end script
    concatMap(emptyOrListed, mbs)
end catMaybes

-- ceiling :: Num -> Int
on ceiling(x)
    set nr to properFraction(x)
    set n to |1| of nr
    if 0 < (|2| of nr) then
        n + 1
    else
        n
    end if
end ceiling

-- center :: Int -> Char -> String -> String
on |center|(n, cFiller, strText)
    set lngFill to n - (length of strText)
    if lngFill > 0 then
        set strPad to replicate(lngFill div 2, cFiller) as text
        set strCenter to strPad & strText & strPad
        if lngFill mod 2 > 0 then
            cFiller & strCenter
        else
            strCenter
        end if
    else
        strText
    end if
end |center|

-- chars :: String -> [Char]
on chars(s)
    characters of s
end chars

-- chop :: ([a] -> (b, [a])) -> [a] -> [b]
on chop(f, xs)
    script go
        property g : mReturn(f)
        on |λ|(xs)
            if 0 < length of xs then
                set {b, ys} to g's |λ|(xs)
                {b} & |λ|(ys)
            else
                {}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end chop

-- chr :: Int -> Char
on chr(n)
    character id n
end chr

-- chunksOf :: Int -> [a] -> [[a]]
on chunksOf(k, xs)
    script
        on go(ys)
            set ab to splitAt(k, ys)
            set a to item 1 of ab
            if {} ≠ a then
                {a} & go(item 2 of ab)
            else
                a
            end if
        end go
    end script
    result's go(xs)
end chunksOf

-- combine (</>) :: FilePath -> FilePath -> FilePath
on combine(fp, fp1)
    -- The concatenation of two filePath segments,
    -- without omission or duplication of "/".
    if "" = fp or "" = fp1 then
        fp & fp1
    else if "/" = item 1 of fp1 then
        fp1
    else if "/" = item -1 of fp then
        fp & fp1
    else
        fp & "/" & fp1
    end if
end combine

-- compare :: a -> a -> Ordering
on compare(a, b)
    if a < b then
        -1
    else if a > b then
        1
    else
        0
    end if
end compare

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

-- compose (<<<) :: (b -> c) -> (a -> b) -> a -> c
on compose(f, g)
    script
        property mf : mReturn(f)
        property mg : mReturn(g)
        on |λ|(x)
            mf's |λ|(mg's |λ|(x))
        end |λ|
    end script
end compose

-- composeList :: [(a -> a)] -> (a -> a)
on composeList(fs)
    script
        on |λ|(x)
            script go
                on |λ|(f, a)
                    mReturn(f)'s |λ|(a)
                end |λ|
            end script
            foldr(go, x, fs)
        end |λ|
    end script
end composeList

-- composeListR :: [(a -> a)] -> (a -> a)
on composeListR(fs)
    script
        on |λ|(x)
            script go
                on |λ|(a, f)
                    mReturn(f)'s |λ|(a)
                end |λ|
            end script
            
            foldl(go, x, fs)
        end |λ|
    end script
end composeListLR

-- composeR (>>>) :: (a -> b) -> (b -> c) -> a -> c
on composeR(f, g)
    script
        on |λ|(x)
            |λ|(|λ|(x) of mReturn(f)) of mReturn(g)
        end |λ|
    end script
end composeR

-- concat :: [[a]] -> [a]
on concat(xs)
    ((current application's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@unionOfArrays.self") as list
end concat

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    set lng to length of xs
    set acc to {}
    
    tell mReturn(f)
        repeat with i from 1 to lng
            set acc to acc & (|λ|(item i of xs, i, xs))
        end repeat
    end tell
    acc
end concatMap

-- cons :: a -> [a] -> [a]
on cons(x, xs)
    set c to class of xs
    if list is c then
        {x} & xs
    else if script is c then
        script
            property pRead : false
            on |λ|()
                if pRead then
                    |λ|() of xs
                else
                    set pRead to true
                    return x
                end if
            end |λ|
        end script
    else
        x & xs
    end if
end cons

-- constant :: a -> b -> a
on |constant|(k)
    script
        on |λ|(_)
            k
        end |λ|
    end script
end |constant|

-- createDirectoryIfMissingLR :: Bool -> FilePath -> Either String FilePath
on createDirectoryIfMissingLR(blnParents, fp)
    if doesPathExist(fp) then
        |Right|(fp)
    else
        set e to reference
        set ca to current application
        set oPath to (ca's NSString's stringWithString:(fp))'s ¬
            stringByStandardizingPath
        set {blnOK, e} to ca's NSFileManager's ¬
            defaultManager's createDirectoryAtPath:(oPath) ¬
            withIntermediateDirectories:(blnParents) ¬
            attributes:(missing value) |error|:(e)
        if blnOK then
            |Right|(fp)
        else
            |Left|((localizedDescription of e) as string)
        end if
    end if
end createDirectoryIfMissingLR

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

-- cycle :: [a] -> Generator [a]
on cycle(xs)
    script
        property lng : 1 + (length of xs)
        property i : missing value
        on |λ|()
            if missing value is i then
                set i to 1
            else
                set nxt to (1 + i) mod lng
                if 0 = ((1 + i) mod lng) then
                    set i to 1
                else
                    set i to nxt
                end if
            end if
            return item i of xs
        end |λ|
    end script
end cycle

-- decodedPath :: Percent Encoded String -> FilePath
on decodedPath(fp)
    -- use framework "Foundation"
    tell current application to ¬
        (stringByRemovingPercentEncoding ¬
            of stringWithString_(fp) ¬
            of its NSString) as string
end decodedPath

-- degrees :: Float x => Radians x -> Degrees x
on degrees(r)
    (180 / pi) * r
end degrees

-- delete :: Eq a => a -> [a] -> [a]
on |delete|(x, xs)
    set mbIndex to elemIndex(x, xs)
    set lng to length of xs
    
    if Nothing of mbIndex then
        xs
    else
        if 1 < lng then
            set i to Just of mbIndex
            if 1 = i then
                items 2 thru -1 of xs
            else if lng = i then
                items 1 thru -2 of xs
            else
                tell xs to items 1 thru (i - 1) & items (i + 1) thru -1
            end if
        else
            {}
        end if
    end if
end |delete|

-- deleteAt :: Int -> [a] -> [a]
on deleteAt(i, xs)
    set lr to splitAt(i, xs)
    set {l, r} to {|1| of lr, |2| of lr}
    if 1 < length of r then
        l & items 2 thru -1 of r
    else
        l
    end if
end deleteAt

-- deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
on deleteBy(fnEq, x, xs)
    script go
        property eq : mReturn(fnEq)'s |λ|
        on |λ|(xs)
            if 0 < length of xs then
                tell xs to set {h, t} to {item 1, rest}
                if eq(x, h) then
                    t
                else
                    {h} & |λ|(t)
                end if
            else
                {}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end deleteBy

-- deleteFirst :: a -> [a] -> [a]
on deleteFirst(x, xs)
    script go
        on |λ|(xs)
            if 0 < length of xs then
                tell xs to set {h, t} to {item 1, rest}
                if x = h then
                    t
                else
                    {h} & |λ|(t)
                end if
            else
                {}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end deleteFirst

-- deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
on deleteFirstsBy(fnEq, xs, ys)
    script
        on |λ|(x, y)
            deleteBy(fnEq, y, x)
        end |λ|
    end script
    foldl(result, xs, ys)
end deleteFirstsBy

-- deleteKey :: String -> Dict -> Dict
on deleteKey(k, rec)
    tell current application to set nsDct to ¬
        dictionaryWithDictionary_(rec) of its NSMutableDictionary
    removeObjectForKey_(k) of nsDct
    nsDct as record
end deleteKey

-- dictFromList :: [(k, v)] -> Dict
on dictFromList(kvs)
    set tpl to unzip(kvs)
    script go
        on |λ|(x)
            x as string
        end |λ|
    end script
    tell current application
        (its (NSDictionary's dictionaryWithObjects:(my snd(tpl)) ¬
            forKeys:(my map(go, my fst(tpl))))) as record
    end tell
end dictFromList

-- difference :: Eq a => [a] -> [a] -> [a]
on difference(xs, ys)
    script p
        on |λ|(x)
            x is not in ys
        end |λ|
    end script
    filter(p, xs)
end difference

-- differenceGen :: Gen [a] -> Gen [a] -> Gen [a]
on differenceGen(ga, gb)
    -- All values of ga except any
    -- already seen in gb.
    script
        property g : zipGen(ga, gb)
        property bs : {}
        property xy : missing value
        on |λ|()
            set xy to g's |λ|()
            if missing value is xy then
                xy
            else
                set x to |1| of xy
                set y to |2| of xy
                set bs to {y} & bs
                if bs contains x then
                    |λ|() -- Next in series.
                else
                    x
                end if
            end if
        end |λ|
    end script
end differenceGen

-- digitToInt :: Char -> Int
on digitToInt(c)
    set oc to id of c
    if 48 > oc or 102 < oc then
        missing value
    else
        set dec to oc - (id of "0")
        set hexu to oc - (id of "A")
        set hexl to oc - (id of "a")
        if 9 ≥ dec then
            dec
        else if 0 ≤ hexu and 5 ≥ hexu then
            10 + hexu
        else if 0 ≤ hexl and 5 ≥ hexl then
            10 + hexl
        else
            missing value
        end if
    end if
end digitToInt

-- div :: Int -> Int -> Int
on |div|(a, b)
    set v to (a / b)
    set i to round (v)
    if 0 < (i - v) then
        i - 1
    else
        i
    end if
end |div|

-- divMod :: Int -> Int -> (Int, Int)
on divMod(n, d)
    -- Integer division, truncated toward negative infinity,
    -- and integer modulus such that:
    -- (x `div` y)*y + (x `mod` y) == x
    set {q, r} to {n div d, n mod d}
    if signum(r) = signum(-d) then
        {q - 1, r + d}
    else
        {q, r}
    end if
end divMod

-- doesDirectoryExist :: FilePath -> IO Bool
on doesDirectoryExist(strPath)
    set ca to current application
    set oPath to (ca's NSString's stringWithString:strPath)'s ¬
        stringByStandardizingPath
    set {bln, v} to (ca's NSFileManager's defaultManager's ¬
        fileExistsAtPath:oPath isDirectory:(reference))
    bln and v
end doesDirectoryExist

-- doesFileExist :: FilePath -> IO Bool
on doesFileExist(strPath)
    set ca to current application
    set oPath to (ca's NSString's stringWithString:strPath)'s ¬
        stringByStandardizingPath
    set {bln, int} to (ca's NSFileManager's defaultManager's ¬
        fileExistsAtPath:oPath isDirectory:(reference))
    bln and (1 ≠ int)
end doesFileExist

-- doesPathExist :: FilePath -> IO Bool
on doesPathExist(strPath)
    set ca to current application
    ca's NSFileManager's defaultManager's ¬
        fileExistsAtPath:((ca's NSString's ¬
            stringWithString:strPath)'s ¬
            stringByStandardizingPath)
end doesPathExist

-- draw :: Tree String -> [String]
on draw(tree)
    
    -- shift :: String -> String -> [String] -> [String]
    script shift
        on |λ|(strFirst, strOther, xs)
            zipWith(my append, ¬
                cons(strFirst, replicate((length of xs) - 1, strOther)), xs)
        end |λ|
    end script
    
    -- drawSubTrees :: [Tree String] -> [String]
    script drawSubTrees
        on |λ|(xs)
            set lng to length of xs
            if 0 < lng then
                if 1 < lng then
                    cons("│", append(shift's |λ|("├─ ", "│  ", draw(item 1 of xs)), ¬
                        |λ|(items 2 thru -1 of xs)))
                else
                    cons("│", shift's |λ|("└─ ", "   ", draw(item 1 of xs)))
                end if
            else
                {}
            end if
        end |λ|
    end script
    
    paragraphs of (root of tree) & |λ|(nest of tree) of drawSubTrees
end draw

-- drawForest :: [Tree String] -> String
on drawForest(trees)
    intercalate("\n\n", map(my drawTree, trees))
end drawForest

-- drawTree :: Tree String -> String
on drawTree(tree)
    unlines(draw(tree))
end drawTree

-- drawTree2 :: Bool -> Bool -> Tree String -> String
on drawTree2(blnCompressed, blnPruned, tree)
    -- Tree design and algorithm inspired by the Haskell snippet at:
    -- https://doisinkidney.com/snippets/drawing-trees.html
    script measured
        on |λ|(t)
            script go
                on |λ|(x)
                    set s to " " & x & " "
                    Tuple(length of s, s)
                end |λ|
            end script
            fmapTree(go, t)
        end |λ|
    end script
    set measuredTree to |λ|(tree) of measured
    
    script levelMax
        on |λ|(a, level)
            a & maximum(map(my fst, level))
        end |λ|
    end script
    set levelWidths to foldl(levelMax, {}, ¬
        init(levels(measuredTree)))
    
    -- Lefts, Mid, Rights
    script lmrFromStrings
        on |λ|(xs)
            set {ls, rs} to items 2 thru -2 of ¬
                (splitAt((length of xs) div 2, xs) as list)
            Tuple3(ls, item 1 of rs, rest of rs)
        end |λ|
    end script
    
    script stringsFromLMR
        on |λ|(lmr)
            script add
                on |λ|(a, x)
                    a & x
                end |λ|
            end script
            foldl(add, {}, items 2 thru -2 of (lmr as list))
        end |λ|
    end script
    
    script fghOverLMR
        on |λ|(f, g, h)
            script
                property mg : mReturn(g)
                on |λ|(lmr)
                    set {ls, m, rs} to items 2 thru -2 of (lmr as list)
                    Tuple3(map(f, ls), |λ|(m) of mg, map(h, rs))
                end |λ|
            end script
        end |λ|
    end script
    
    script treeFix
        on cFix(x)
            script
                on |λ|(xs)
                    x & xs
                end |λ|
            end script
        end cFix
        
        on |λ|(l, m, r)
            compose(stringsFromLMR, ¬
                |λ|(cFix(l), cFix(m), cFix(r)) of ¬
                fghOverLMR)
        end |λ|
    end script

    script lmrBuild
        on leftPad(n)
            script
                on |λ|(s)
                    replicateString(n, space) & s
                end |λ|
            end script
        end leftPad
        
        -- lmrBuild main
        on |λ|(w, f)
            script
                property mf : mReturn(f)
                on |λ|(wsTree)
                    set xs to nest of wsTree
                    set lng to length of xs
                    set {nChars, x} to items 2 thru -2 of ¬
                        ((root of wsTree) as list)
                    set _x to replicateString(w - nChars, "─") & x
                    
                    script linked
                        on |λ|(s)
                            set c to text 1 of s
                            set t to tail(s)
                            if "┌" = c then
                                _x & "┬" & t
                            else if "│" = c then
                                _x & "┤" & t
                            else if "├" = c then
                                _x & "┼" & t
                            else
                                _x & "┴" & t
                            end if
                        end |λ|
                    end script
                    
                    -- LEAF NODE --------------------------------------
                    if 0 = lng then
                        Tuple3({}, _x, {})
                        
                    else if 1 = lng then
                        -- NODE WITH SINGLE CHILD ---------------------
                        set indented to leftPad(1 + w)
                        script lineLinked
                            on |λ|(z)
                                _x & "─" & z
                            end |λ|
                        end script
                        |λ|(|λ|(item 1 of xs) of mf) of ¬
                            (|λ|(indented, lineLinked, indented) of ¬
                                fghOverLMR)
                    else
                        -- NODE WITH CHILDREN -------------------------
                        set indented to leftPad(w)
                        set lmrs to map(f, xs)
                        if blnCompressed then
                            set sep to {}
                        else
                            set sep to {"│"}
                        end if
                        
                        tell lmrFromStrings
                            set tupleLMR to |λ|(intercalate(sep, ¬
                                {|λ|(item 1 of lmrs) of ¬
                                    (|λ|(" ", "┌", "│") of treeFix)} & ¬
                                map(|λ|("│", "├", "│") of treeFix, ¬
                                    init(tail(lmrs))) & ¬
                                {|λ|(item -1 of lmrs) of ¬
                                    (|λ|("│", "└", " ") of treeFix)}))
                        end tell
                        
                        |λ|(tupleLMR) of ¬
                            (|λ|(indented, linked, indented) of fghOverLMR)
                    end if
                end |λ|
            end script
        end |λ|
    end script
    
    set treeLines to |λ|(|λ|(measuredTree) of ¬
        foldr(lmrBuild, 0, levelWidths)) of stringsFromLMR
    if blnPruned then
        script notEmpty
            on |λ|(s)
                script isData
                    on |λ|(c)
                        "│ " does not contain c
                    end |λ|
                end script
                any(isData, characters of s)
            end |λ|
        end script
        set xs to filter(notEmpty, treeLines)
    else
        set xs to treeLines
    end if
    unlines(xs)
end drawTree2

-- drop :: Int -> [a] -> [a]
-- drop :: Int -> String -> String
on drop(n, xs)
    set c to class of xs
    if script is not c then
        if string is not c then
            if n < length of xs then
                items (1 + n) thru -1 of xs
            else
                {}
            end if
        else
            if n < length of xs then
                text (1 + n) thru -1 of xs
            else
                ""
            end if
        end if
    else
        take(n, xs) -- consumed
        return xs
    end if
end drop

-- dropAround :: (a -> Bool) -> [a] -> [a]
-- dropAround :: (Char -> Bool) -> String -> String
on dropAround(p, xs)
    dropWhile(p, dropWhileEnd(p, xs))
end dropAround

-- dropFileName :: FilePath -> FilePath
on dropFileName(strPath)
    if strPath ≠ "" then
        if character -1 of strPath = "/" then
            strPath
        else
            set xs to init(splitOn("/", strPath))
            if xs ≠ {} then
                intercalate("/", xs) & "/"
            else
                "./"
            end if
        end if
    else
        "./"
    end if
end dropFileName

-- dropLength :: [a] -> [b] -> [b]
on dropLength(xs, ys)
    script go
        on |λ|(x, y)
            if 0 < length of x then
                if 0 < length of y then
                    |λ|(tail(x), tail(y))
                else
                    {}
                end if
            else
                y
            end if
        end |λ|
    end script
    go's |λ|(xs, ys)
end dropLength

-- dropLengthMaybe :: [a] -> [b] -> Maybe [b]
on dropLengthMaybe(xs, ys)
    script go
        on |λ|(x, y)
            if 0 < length of x then
                if 0 < length of y then
                    |λ|(tail(x), tail(y))
                else
                    Nothing()
                end if
            else
                Just(y)
            end if
        end |λ|
    end script
    go's |λ|(xs, ys)
end dropLengthMaybe

-- dropWhile :: (a -> Bool) -> [a] -> [a]
-- dropWhile :: (Char -> Bool) -> String -> String
on dropWhile(p, xs)
    set lng to length of xs
    set i to 1
    tell mReturn(p)
        repeat while i ≤ lng and |λ|(item i of xs)
            set i to i + 1
        end repeat
    end tell
    if {} ≠ xs then
        items i thru -1 of xs
    else
        xs
    end if
end dropWhile

-- dropWhileEnd :: (a -> Bool) -> [a] -> [a]
-- dropWhileEnd :: (Char -> Bool) -> String -> String
on dropWhileEnd(p, xs)
    set i to length of xs
    tell mReturn(p)
        repeat while i > 0 and |λ|(item i of xs)
            set i to i - 1
        end repeat
    end tell
    take(i, xs)
end dropWhileEnd

-- dropWhileGen :: (a -> Bool) -> Gen [a] -> [a]
on dropWhileGen(p, xs)
    set v to |λ|() of xs
    tell mReturn(p)
        repeat while (|λ|(v))
            set v to xs's |λ|()
        end repeat
    end tell
    return cons(v, xs)
end dropWhileGen

-- either :: (a -> c) -> (b -> c) -> Either a b -> c
on either(lf, rf, e)
    if missing value is |Left| of e then
        tell mReturn(rf) to |λ|(|Right| of e)
    else
        tell mReturn(lf) to |λ|(|Left| of e)
    end if
end either

-- elem :: Eq a => a -> [a] -> Bool
on elem(x, xs)
    considering case
        xs contains x
    end considering
end elem

-- elemAtMay :: Int -> Dict -> Maybe (String, a)
-- elemAtMay :: Int -> [a] -> Maybe a
on elemAtMay(i, x)
    -- If x is a Dictionary then reads the Int as an index
    -- into the lexically sorted keys of the Dict, 
    -- returning a Maybe (Key, Value) pair.
    -- If x is a list, then return a Maybe a 
    -- (In either case, returns Nothing for an Int out of range)
    set bln to class of x is record
    if bln then
        set ks to keys(x)
        if i ≤ |length|(ks) then
            set k to item i of sort(ks)
            script pair
                on |λ|(v)
                    Just(Tuple(k, v))
                end |λ|
            end script
            bindMay(lookup(k, x), pair)
        end if
    else
        if i ≤ |length|(x) then
            Just(item i of x)
        else
            Nothing()
        end if
    end if
end elemAtMay

-- elemIndex :: Eq a => a -> [a] -> Maybe Int
on elemIndex(x, xs)
    -- Just the zero-based index of x in xs,
    -- or Nothing if x is not found in xs.
	set lng to length of xs
	repeat with i from 1 to lng
		if x = (item i of xs) then return Just(i - 1)
	end repeat
	return Nothing()
end elemIndex

-- elemIndices :: Eq a => a -> [a] -> [Int]
on elemIndices(x, xs)
    script
        on |λ|(y, i)
            if y = x then
                {i}
            else
                {}
            end if
        end |λ|
    end script
    concatMap(result, xs)
end elemIndices

-- elems :: Map k a -> [a]
-- elems :: Set a -> [a]
on elems(x)
    if record is class of x then -- Dict
        tell current application to allValues() ¬
            of dictionaryWithDictionary_(x) ¬
            of its NSDictionary as list
    else -- Set
        (allObjects() of x) as list
    end if
end elems

-- encodedPath :: FilePath -> Percent Encoded String
on encodedPath(fp)
    tell current application
        set charSet to URLPathAllowedCharacterSet of its NSCharacterSet
        (stringByAddingPercentEncodingWithAllowedCharacters_(charSet) of ¬
            stringWithString_(fp) of its NSString) as string
    end tell
end encodedPath

-- enumFrom :: Enum a => a -> [a]
on enumFrom(x)
    script
        property v : missing value
        property blnNum : class of x is not text
        on |λ|()
            if missing value is not v then
                if blnNum then
                    set v to 1 + v
                else
                    set v to succ(v)
                end if
            else
                set v to x
            end if
            return v
        end |λ|
    end script
end enumFrom

-- enumFromPairs :: String -> [(String, Int)] -> Dict
on enumFromPairs(strName, kvs)
    set iMax to item 1 of item -1 of kvs
    set iMin to item 1 of item 1 of kvs
    script go
        on |λ|(a, kv)
            set {k, v} to kv
            insertMap(insertMap(a, k, ¬
                {type:"enum", |name|:¬
                    strName, |key|:k, min:iMin, max:iMax, value:v}), v, k)
        end |λ|
    end script
    foldl(go, {|name|:strName, min:iMin, max:iMax}, kvs)
end enumFromPairs

-- enumFromThen :: Int -> Int -> Gen [Int]
on enumFromThen(m, n)
    -- A non-finite stream of integers,
    -- starting with m and n, and continuing
    -- with the same interval.
    script
        property d : n - m
        property v : m
        on |λ|()
            set x to v
            set v to d + v
            return x
        end |λ|
    end script
end enumFromThen

-- enumFromThenTo :: Int -> Int -> Int -> [Int]
on enumFromThenTo(x1, x2, y)
    set xs to {}
    set gap to x2 - x1
    set d to max(1, abs(gap)) * (signum(gap))
    repeat with i from x1 to y by d
        set end of xs to i
    end repeat
    return xs
end enumFromThenTo

-- enumFromThenToChar :: Char -> Char -> Char -> [Char]
on enumFromThenToChar(x1, x2, y)
    set {int1, int2, intY} to {id of x1, id of x2, id of y}
    set xs to {}
    repeat with i from int1 to intY by (int2 - int1)
        set end of xs to character id i
    end repeat
    return xs
end enumFromThenToChar

-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if m ≤ n then
        set xs to {}
        repeat with i from m to n
            set end of xs to i
        end repeat
        xs
    else
        {}
    end if
end enumFromTo

-- enumFromToChar :: Char -> Char -> [Char]
on enumFromToChar(m, n)
    set {intM, intN} to {id of m, id of n}
    if intM ≤ intN then
        set xs to {}
        repeat with i from intM to intN
            set end of xs to character id i
        end repeat
        return xs
    else
        {}
    end if
end enumFromToChar

-- enumFromTo_ :: Enum a => a -> a -> [a]
on enumFromTo_(m, n)
    if m ≤ n then
        set x to fromEnum(m)
        set y to fromEnum(n)
        set xs to {}
        repeat with i from x to y
            set end of xs to i
        end repeat
        map(toEnum(m), xs)
    else
        return {}
    end if
end enumFromTo

-- eq (==) :: Eq a => a -> a -> Bool
on eq(a, b)
    a = b
end eq

-- eqDate :: Date -> Date -> Bool
on eqDate(dte, dte1)
    -- True if the date parts of two date-time objects
    -- (ignoring the time parts) are the same.
    tell dte
        its year = year of dte1 ¬
            and its month = month of dte1 ¬
            and its day = day of dte1
    end tell
end eqDate

-- evalJSLR :: String -> Either String a
on evalJSLR(strJS)
    -- gJSC can be declared in the global namespace,
    -- but unless the reference is released before the 
    -- end of the script (e.g. `set gJSC to null`)
    -- it will persist, and
    -- Script Editor will be unable to save a .scpt file
    set gJSC to current application's JSContext's new()
    set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())
    if v is missing value then
        |Left|("JS evaluation error")
    else
        |Right|(v)
    end if
end evalJSLR

-- evalJSMay :: String -> Maybe a
on evalJSMay(strJS)
    -- use framework "Foundation"
    -- use framework "JavaScriptCore"
    -- gJSC can be declared in the global namespace,
    -- but unless the reference is released before the 
    -- end of the script (e.g. `set gJSC to null`)
    -- it will persist, and
    -- Script Editor will be unable to save a .scpt file
    try -- NB if gJSC is global it must be released 
        -- (e.g. set to null) at end of script
        gJSC's evaluateScript
    on error
        set gJSC to current application's JSContext's new()
        log ("new JSC")
    end try
    set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())
    if v is missing value then
        Nothing()
    else
        Just(v)
    end if
end evalJSMay

-- even :: Int -> Bool
on even(x)
    0 = x mod 2
end even

-- exp :: Float -> Float
on exp(n)
    Just of evalJSMay(("Math.exp(" & n as string) & ")")
end exp

-- fTable :: String -> (a -> String) -> (b -> String) -> (a -> b) -> [a] -> String
on fTable(s, xShow, fxShow, f, xs)
    set ys to map(xShow, xs)
    set w to maximum(map(my |length|, ys))
    script arrowed
        on |λ|(a, b)
            justifyRight(w, space, a) & " -> " & b
        end |λ|
    end script
    s & linefeed & unlines(zipWith(arrowed, ¬
        ys, map(compose(fxShow, f), xs)))
end fTable

-- fanArrow (&&&) :: (a -> b) -> (a -> c) -> (a -> (b, c))
on fanArrow(f, g)
    -- Compose a function from a simple value to a tuple of
    -- the separate outputs of two different functions
    script
        on |λ|(x)
            Tuple(mReturn(f)'s |λ|(x), mReturn(g)'s |λ|(x))
        end |λ|
    end script
end fanArrow

-- filePath :: String -> FilePath
on filePath(s)
    ((current application's ¬
        NSString's stringWithString:s)'s ¬
        stringByStandardizingPath()) as string
end filePath

-- filePathTree :: filePath -> [Tree String] -> Tree FilePath
on filePathTree(fpAnchor, trees)
    script go
        on |λ|(fp)
            script
                on |λ|(tree)
                    set strPath to fp & "/" & (root of tree)
                    
                    Node(strPath, map(go's |λ|(strPath), nest of tree))
                end |λ|
            end script
        end |λ|
    end script
    
    Node(fpAnchor, map(go's |λ|(fpAnchor), trees))
end filePathTree

-- fileSize :: FilePath -> Either String Int
on fileSize(fp)
    script fs
        on |λ|(rec)
            |Right|(NSFileSize of rec)
        end |λ|
    end script

    bindLR(my fileStatus(fp), fs)
end fileSize

-- fileStatus :: FilePath -> Either String Dict
on fileStatus(fp)
    set e to reference
    set {v, e} to current application's NSFileManager's defaultManager's ¬
        attributesOfItemAtPath:fp |error|:e

    if v is not missing value then
        |Right|(v as record)
    else
        |Left|((localizedDescription of e) as string)
    end if
end fileStatus

-- fileUTI :: FilePath -> Either String String
on fileUTI(fp)
    set {uti, e} to (current application's ¬
        NSWorkspace's sharedWorkspace()'s ¬
        typeOfFile:fp |error|:(reference)) as list
        
    if uti is missing value then
        |Left|(e's localizedDescription() as text)
    else
        |Right|(uti as text)
    end if
end fileUTI

-- filter :: (a -> Bool) -> [a] -> [a]
on filter(p, xs)
    tell mReturn(p)
        set n to length of xs
        set ys to {}
        
        repeat with i from 1 to n
            set v to item i of xs
            if |λ|(v, i, xs) then set end of ys to v
        end repeat
        ys
    end tell
end filter

-- filterGen :: (a -> Bool) -> Gen [a] -> Gen [a]
on filterGen(p, gen)
    -- Non-finite stream of values which are 
    -- drawn from gen, and satisfy p
    script
        property mp : mReturn(p)'s |λ|
        on |λ|()
            set v to gen's |λ|()
            repeat until mp(v)
                set v to gen's |λ|()
            end repeat
            return v
        end |λ|
    end script
end filterGen

-- filterTree (a -> Bool) -> Tree a -> [a]
on filterTree(p, tree)
    -- List of all values in the tree
    -- which match the predicate p.
    
    script go
        property q : mReturn(p)'s |λ|
        on |λ|(x, xs)
            if q(x) then
                {x} & concat(xs)
            else
                concat(xs)
            end if
        end |λ|
    end script
    
    foldTree(go, tree)
end filterTree

-- filteredTree (a -> Bool) -> Tree a -> Tree a
on filteredTree(p, tree)
    -- A tree including only those children
    -- which either match the predicate p, or have
    -- descendants which match the predicate p.
    
    script go
        property q : mReturn(p)
        on |λ|(x, xs)
            script test
                on |λ|(subTree)
                    {} ≠ (nest of subTree) or (|λ|(root of subTree) of q)
                end |λ|
            end script
            Node(x, filter(test, xs))
        end |λ|
    end script
    
    foldTree(go, tree)
end filteredTree

-- find :: (a -> Bool) -> [a] -> (missing value | a)
on find(p, xs)
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if |λ|(item i of xs) then return item i of xs
        end repeat
        missing value
    end tell
end find

-- findGen :: (a -> Bool) -> Gen [a] -> Maybe a
on findGen(p, gen)
    -- Just the first match for the predicate p
    -- in the generator stream gen, or Nothing
    -- if no match is found.
    set mp to mReturn(p)
    set v to gen's |λ|()
    repeat until missing value is v or (|λ|(v) of mp)
        set v to (|λ|() of gen)
    end repeat
    if missing value is v then
        Nothing()
    else
        Just(v)
    end if
end findGen

-- findIndex :: (a -> Bool) -> [a] -> Maybe Int
on findIndex(p, xs)
    -- Just the zero-based index of the first
    -- (left-to-right match) for for the predicate p in xs, 
    -- or Nothing if no match is found.
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if |λ|(item i of xs) then return Just(i - 1)
        end repeat
        return Nothing()
    end tell
end findIndex

-- findIndexR :: (a -> Bool) -> [a] -> Maybe Int
on findIndexR(p, xs)
    -- Just the zero-based index of the first
    -- (right-to-left match) for for the predicate p in xs, 
    -- or Nothing if no match is found.
    tell mReturn(p)
        set lng to length of xs
        repeat with i from lng to 1 by -1
            if |λ|(item i of xs) then return Just(i - 1)
        end repeat
        return Nothing()
    end tell
end findIndexR

-- findIndices :: (a -> Bool) -> [a] -> [Int]
on findIndices(p, xs)
    -- List of zero-based indices of 
    -- any matches for p in xs.
    script
        property f : mReturn(p)
        on |λ|(x, i, xs)
            if f's |λ|(x, i, xs) then
                {i - 1}
            else
                {}
            end if
        end |λ|
    end script
    concatMap(result, xs)
end findIndices

-- findTree :: (a -> Bool) -> Tree a -> Maybe Tree a
on findTree(p, tree)
    -- The first of any nodes in the tree which match the predicate p
    -- (For all matches, see treeMatches)
    script go
        property pf : mReturn(p)'s |λ|
        on |λ|(oNode)
            if pf(root of oNode) then
                Just(oNode)
            else
                set xs to nest of oNode
                set lng to length of xs
                
                script inNest
                    on |λ|(tpl)
                        lng < fst(tpl) or (not (Nothing of snd(tpl)))
                    end |λ|
                end script
                
                script nextPeer
                    on |λ|(tpl)
                        Tuple(1 + fst(tpl), go's |λ|(item (fst(tpl)) of xs))
                    end |λ|
                end script
                
                if 0 < lng then
                    snd(|until|(inNest, nextPeer, Tuple(1, Nothing())))
                else
                    Nothing()
                end if
            end if
        end |λ|
    end script
    
    go's |λ|(tree)
end findTree

-- first :: (a -> b) -> ((a, c) -> (b, c))
on |first|(f)
   -- A simple function lifted to one which applies to a tuple, 
   -- transforming only the first item of that tuple
    script
        on |λ|(xy)
            Tuple(mReturn(f)'s |λ|(|1| of xy), |2| of xy)
        end |λ|
    end script
end |first|

-- flatten :: NestedList a -> [a]
on flatten(t)
    -- A flat list derived from a nested list.
    if list is class of t then
        concatMap(my flatten, t)
    else
        t
    end if
end flatten

-- flattenTree :: Tree a -> [a]
on flattenTree(node)
    -- The root elements of a tree in pre-order.
    script go
        on |λ|(x, xs)
            {root of x} & foldr(go, xs, nest of x)
        end |λ|
    end script
    go's |λ|(node, {})
end flattenTree

-- flip :: (a -> b -> c) -> b -> a -> c
on flip(f)
    script
        property g : mReturn(f)
        on |λ|(x, y)
            g's |λ|(y, x)
        end |λ|
    end script
end flip

-- floor :: Num -> Int
on floor(x)
    if class of x is record then
        set nr to properFracRatio(x)
    else
        set nr to properFraction(x)
    end if
    set n to fst(nr)
    if 0 > snd(nr) then
        n - 1
    else
        n
    end if
end floor

-- fmap (<$>) :: Functor f => (a -> b) -> f a -> f b
on fmap(f, fa)
    set c to class of fa
    if c is record and keys(fa) contains "type" then
        set t to |type| of fa
        if "Either" = t then
            set fm to my fmapLR
        else if "Maybe" = t then
            set fm to my fmapMay
        else if "Node" = t then
            set fm to my fmapTree
        else if "Tuple" = t then
            set fm to my fmapTuple
        else
            set fm to my map
        end if
        |λ|(f, fa) of mReturn(fm)
    else if c is text then
        map(f, characters of fa)
    else if c is list then
        map(f, fa)
    else
        missing value
    end if
end fmap

-- fmapGen <$> :: (a -> b) -> Gen [a] -> Gen [b]
on fmapGen(f, gen)
    script
        property g : mReturn(f)
        on |λ|()
            set v to gen's |λ|()
            if v is missing value then
                v
            else
                g's |λ|(v)
            end if
        end |λ|
    end script
end fmapGen

-- fmapLR (<$>) :: (a -> b) -> Either a a -> Either a b
on fmapLR(f, lr)
    if |Left| of lr is missing value then
        |Right|(|λ|(|Right| of lr) of mReturn(f))
    else
        lr
    end if
end fmapLR

-- fmapMay (<$>) :: (a -> b) -> Maybe a -> Maybe b
on fmapMay(f, mb)
    if Nothing of mb then
        mb
    else
        Just(|λ|(Just of mb) of mReturn(f))
    end if
end fmapMay

-- fmapTree :: (a -> b) -> Tree a -> Tree b
on fmapTree(f, tree)
    script go
        property g : |λ| of mReturn(f)
        on |λ|(x)
            set xs to nest of x
            if xs ≠ {} then
                set ys to map(go, xs)
            else
                set ys to xs
            end if
            Node(g(root of x), ys)
        end |λ|
    end script
  |λ|(tree) of go
end fmapTree

-- fmapTuple (<$>) :: (a -> b) -> (a, a) -> (a, b)
on fmapTuple(f, tpl)
    Tuple(|1| of tpl, |λ|(|2| of tpl) of mReturn(f))
end fmapTuple

-- foldMapTree :: Monoid m => (a -> m) -> Tree a -> m
on foldMapTree(f, tree)
    script go
        property g : mReturn(f)'s |λ|
        on |λ|(x)
            if length of (nest of x) > 0 then
                mappend(g(root of x), ¬
                    foldl1(my mappend, (map(go, nest of x))))
            else
                g(root of x)
            end if
        end |λ|
    end script
    |λ|(tree) of go
end foldMapTree

-- foldTree :: (a -> [b] -> b) -> Tree a -> b
on foldTree(f, tree)
    script go
        property g : mReturn(f)
        on |λ|(oNode)
            tell g to |λ|(root of oNode, map(go, nest of oNode))
        end |λ|
    end script
    |λ|(tree) of go
end foldTree

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

-- foldl1 :: (a -> a -> a) -> [a] -> a
on foldl1(f, xs)
    if length of xs > 1 then
        tell mReturn(f)
            set v to {item 1 of xs}
            set lng to length of xs
            repeat with i from 2 to lng
                set v to |λ|(v, item i of xs, i, xs)
            end repeat
            return v
        end tell
    else
        item 1 of xs
    end if
end foldl1

-- foldl1May :: (a -> a -> a) -> [a] -> Maybe a
on foldl1May(f, xs)
    set lng to length of xs
    if lng > 0 then
        if lng > 1 then
            tell mReturn(f)
                set v to {item 1 of xs}
                set lng to length of xs
                repeat with i from 2 to lng
                    set v to |λ|(v, item i of xs, i, xs)
                end repeat
                return Just(v)
            end tell
        else
            Just(item 1 of xs)
        end if
    else
        Nothing()
    end if
end foldl1May

-- foldlTree :: (b -> a -> b) -> b -> Tree a -> b
on foldlTree(f, acc, tree)
    script go
        property mf : mReturn(f)
        on |λ|(a, x)
            foldl(go, |λ|(a, root of x) of mf, nest of x)
        end |λ|
    end script
    |λ|(acc, tree) of go
end foldlTree

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

-- foldr1 :: (a -> a -> a) -> [a] -> a
on foldr1(f, xs)
    if length of xs > 1 then
        tell mReturn(f)
            set v to item -1 of xs
            set lng to length of xs
            repeat with i from lng - 1 to 1 by -1
                set v to |λ|(item i of xs, v, i, xs)
            end repeat
            return v
        end tell
    else
        xs
    end if
end foldr1

-- foldr1May :: (a -> a -> a) -> [a] -> Maybe a
on foldr1May(f, xs)
    set lng to length of xs
    if lng > 0 then
        tell mReturn(f)
            set v to item -1 of xs
            repeat with i from lng - 1 to 1 by -1
                set v to |λ|(item i of xs, v, i, xs)
            end repeat
            return Just(v)
        end tell
    else
        Nothing()
    end if
end foldr1May

-- foldrTree :: (a -> b -> b) -> b -> Tree a -> b
on foldrTree(f, acc, tree)
    script go
        property mf : mReturn(f)
        on |λ|(x, a)
            foldr(go, |λ|(root of x, a) of mf, nest of x)
        end |λ|
    end script
    |λ|(tree, acc) of go
end foldrTree

-- forestFromJSON :: String -> [Tree a]
on forestFromJSON(strJSON)
    set lr to jsonParseLR(strJSON)
    if missing value is |Left| of lr then
        map(my treeFromNestedList, |Right| of lr)
    else
        {}
    end if
end forestFromJSON


-- fromEnum :: Enum a => a -> Int
on fromEnum(x)
    set c to class of x
    if c is boolean then
        if x then
            1
        else
            0
        end if
    else if c is text then
        if x ≠ "" then
            id of x
        else
            missing value
        end if
    else
        x as integer
    end if
end fromEnum

-- fromLeft :: a -> Either a b -> a
on fromLeft(def, lr)
    if isLeft(lr) then
        |Left| of lr
    else
        def
    end if
end fromLeft

-- fromMaybe :: a -> Maybe a -> a
on fromMaybe(default, mb)
    if Nothing of mb then
        default
    else
        Just of mb
    end if
end fromMaybe

-- fromRight :: b -> Either a b -> b
on fromRight(def, lr)
    if isRight(lr) then
        |Right| of lr
    else
        def
    end if
end fromRight

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

-- ft :: (Int, Int) -> [Int]
on ft(m, n)
    -- Abbreviation for quick testing
    if m ≤ n then
        set lst to {}
        repeat with i from m to n
            set end of lst to i
        end repeat
        return lst
    else
        return {}
    end if
end ft

-- gcd :: Int -> Int -> Int
on gcd(a, b)
    set x to abs(a)
    set y to abs(b)
    repeat until y = 0
        if x > y then
            set x to x - y
        else
            set y to y - x
        end if
    end repeat
    return x
end gcd

-- genericIndexMay :: [a] -> Int -> Maybe a
on genericIndexMay(xs, i)
    if i < (length of xs) and i ≥ 0 then
        Just(item (i + 1) of xs)
    else
        Nothing()
    end if
end genericIndexMay

-- getCurrentDirectory :: IO FilePath
on getCurrentDirectory()
    set ca to current application
    ca's NSFileManager's defaultManager()'s currentDirectoryPath as string
end getCurrentDirectory

-- getDirectoryContents :: FilePath -> IO [FilePath]
on getDirectoryContents(strPath)
    set ca to current application
    (ca's NSFileManager's defaultManager()'s ¬
        contentsOfDirectoryAtPath:(stringByStandardizingPath of (¬
            ca's NSString's stringWithString:(strPath))) ¬
            |error|:(missing value)) as list
end getDirectoryContents

-- getDirectoryContentsLR :: FilePath -> Either String IO [FilePath]
on getDirectoryContentsLR(strPath)
    set ca to current application
    set {xs, e} to (ca's NSFileManager's defaultManager()'s ¬
        contentsOfDirectoryAtPath:(stringByStandardizingPath of ¬
            (ca's NSString's stringWithString:(strPath))) ¬
            |error|:(reference))
    if xs is missing value then
        |Left|((localizedDescription of e) as string)
    else
        |Right|(xs as list)
    end if
end getDirectoryContentsLR

-- getFinderDirectory :: IO FilePath
on getFinderDirectory()
    tell application "Finder" to POSIX path of (insertion location as alias)
end getFinderDirectory

-- getHomeDirectory :: IO FilePath
on getHomeDirectory()
    current application's NSHomeDirectory() as string
end getHomeDirectory

-- getTemporaryDirectory :: IO FilePath
on getTemporaryDirectory()
    current application's NSTemporaryDirectory() as string
end getTemporaryDirectory

-- group :: Eq a => [a] -> [[a]]
on group(xs)
    script eq
        on |λ|(a, b)
            a = b
        end |λ|
    end script
    
    groupBy(eq, xs)
end group

-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
on groupBy(f, xs)
    -- Typical usage: groupBy(on(eq, f), xs)
    set mf to mReturn(f)
    
    script enGroup
        on |λ|(a, x)
            if length of (active of a) > 0 then
                set h to item 1 of active of a
            else
                set h to missing value
            end if
            
            if h is not missing value and mf's |λ|(h, x) then
                {active:(active of a) & {x}, sofar:sofar of a}
            else
                {active:{x}, sofar:(sofar of a) & {active of a}}
            end if
        end |λ|
    end script
    
    if length of xs > 0 then
        set dct to foldl(enGroup, {active:{item 1 of xs}, sofar:{}}, rest of xs)
        if length of (active of dct) > 0 then
            sofar of dct & {active of dct}
        else
            sofar of dct
        end if
    else
        {}
    end if
end groupBy

-- groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]]
-- groupSortOn :: Ord b => [((a -> b), Bool)]  -> [a] -> [[a]]
on groupSortOn(f, xs)
    -- Sort and group a list by comparing the results of a key function
    -- applied to each element. groupSortOn f is equivalent to
    -- groupBy eq $ sortBy (comparing f),
    -- but has the performance advantage of only evaluating f once for each
    -- element in the input list.
    -- This is a decorate-(group.sort)-undecorate pattern, as in the
    -- so-called 'Schwartzian transform'.
    -- Groups are arranged from from lowest to highest.
    script keyBool
        on |λ|(a, x)
            if class of x is boolean then
                {asc:x, fbs:fbs of a}
            else
                {asc:true, fbs:({Tuple(x, asc of a)} & fbs of a)}
            end if
        end |λ|
    end script
    set {fs, bs} to {|1|, |2|} of unzip(fbs of foldl(keyBool, ¬
        {asc:true, fbs:{}}, 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 grpUndec
        on |λ|(grp)
            script
                on |λ|(x)
                    val of x
                end |λ|
            end script
            map(result, grp)
        end |λ|
    end script
    
    script aEq
        on |λ|(p, q)
            (a of p) = (a of q)
        end |λ|
    end script
    
    -- Sorted, grouped, undecorated
    map(grpUndec, ¬
        groupBy(aEq, ((ca's NSArray's arrayWithArray:map(dec, xs))'s ¬
            sortedArrayUsingDescriptors:map(descrip, bs)) as list))
end groupSortOn

-- gt :: Ord a => a -> a -> Bool
on gt(x, y)
    set c to class of x
    if record is c or list is c then
        fst(x) > fst(y)
    else
        x > y
    end if
end gt

-- head :: [a] -> a
on head(xs)
    if xs = {} then
        missing value
    else
        item 1 of xs
    end if
end head

-- headMay :: [a] -> Maybe a
on headMay(xs)
    if xs = {} then
        Nothing()
    else
        Just(item 1 of xs)
    end if
end headMay

-- identity :: a -> a
on identity(x)
    -- The argument unchanged.
    x
end identity

-- if_ :: Bool -> a -> a -> a
on if_(bool, x, y)
    if bool then
        x
    else
        y
    end if
end if_

-- indented :: String -> String -> String
on indented(strIndent, s)
    script
        on |λ|(x)
            if x ≠ "" then
                strIndent & x
            else
                x
            end if
        end |λ|
    end script
    unlines(map(result, |lines|(s)))
end indented

-- index (!!) :: [a] -> Int -> Maybe a
-- index (!!) :: Gen [a] -> Int -> Maybe a
-- index (!!) :: String -> Int -> Maybe Char
on |index|(xs, i)
    if script is class of xs then
        repeat with j from 1 to i
            set v to |λ|() of xs
        end repeat
        if missing value is not v then
            Just(v)
        else
            Nothing()
        end if
    else
        if length of xs < i then
            Nothing()
        else
            Just(item i of xs)
        end if
    end if
end |index|

-- indexOf :: Eq a => [a] -> [a] -> Maybe Int
-- indexOf :: String -> String -> Maybe Int
on indexOf(pat, src)
    if class of src is text then
        set tpl to breakOn(pat, src)
        if 0 < length of (|2| of tpl) then
            Just((length of |1| of tpl) + 1)
        else
            Nothing()
        end if
    else
        script pfx
            on |λ|(xs)
                isPrefixOf(pat, xs)
            end |λ|
        end script
        findIndex(pfx, tails(src))
    end if
end indexOf

-- init :: [a] -> [a]
-- init :: [String] -> [String]
on init(xs)
    set blnString to class of xs = string
    set lng to length of xs
    
    if lng > 1 then
        if blnString then
            text 1 thru -2 of xs
        else
            items 1 thru -2 of xs
        end if
    else if lng > 0 then
        if blnString then
            ""
        else
            {}
        end if
    else
        missing value
    end if
end init


-- initMay :: [a] -> Maybe [a]
-- initMay :: [String] -> Maybe [String]
on initMay(xs)
    set blnString to class of xs = string
    set lng to length of xs
    if lng > 1 then
        if blnString then
            Just(text 1 thru -2 of xs)
        else
            Just(items 1 thru -2 of xs)
        end if
    else if lng > 0 then
        if blnString then
            Just("")
        else
            Just({})
        end if
    else
        Nothing()
    end if
end initMay

-- inits :: [a] -> [[a]]
-- inits :: String -> [String]
on inits(xs)
    script elemInit
        on |λ|(_, i, xs)
            items 1 thru i of xs
        end |λ|
    end script
    
    script charInit
        on |λ|(_, i, xs)
            text 1 thru i of xs
        end |λ|
    end script
    
    if class of xs is string then
        {""} & map(charInit, xs)
    else
        {{}} & map(elemInit, xs)
    end if
end inits

-- insert :: Ord a => a -> [a] -> [a]
on insert(x, ys)
    insertBy(my compare, x, ys)
end insert

-- insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
on insertBy(cmp, x, ys)
    set lng to length of ys
    if lng > 0 then
        tell mReturn(cmp)
            set bln to false
            repeat with i from 1 to lng
                if |λ|(item i of ys, x) > 0 then
                    set bln to true
                    exit repeat
                end if
            end repeat
        end tell
        if bln then
            if i > 1 then
                items 1 thru (i - 1) of ys & x & items i thru -1 of ys
            else
                {x} & ys
            end if
        else
            ys & x
        end if
    else
        {x}
    end if
end insertBy

-- insertDict :: String -> a -> Dict -> Dict
on insertDict(k, v, rec)
    tell current application
        tell dictionaryWithDictionary_(rec) of its NSMutableDictionary
            its setValue:v forKey:(k as string)
            it as record
        end tell
    end tell
end insertDict

-- insertSet :: Ord a => a -> Set a -> Set a
on insertSet(x, oSet)
    oSet's addObject:(x)
    return oSet
end insertSet

-- intToDigit :: Int -> Char
on intToDigit(n)
    if n ≥ 0 and n < 16 then
        character (n + 1) of "0123456789ABCDEF"
    else
        "?"
    end if
end intToDigit

-- intercalate :: [a] -> [[a]] -> [a]
-- intercalate :: String -> [String] -> String
on intercalate(sep, xs)
    if class of xs is text then
        set {dlm, my text item delimiters} to ¬
            {my text item delimiters, delim}
        set s to xs as text
        set my text item delimiters to dlm
    else
        concat(intersperse(sep, xs))
    end if
end intercalate

-- intercalateS :: String -> [String] -> String
on intercalateS(delim, xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, delim}
    set s to xs as text
    set my text item delimiters to dlm
    s
end intercalateS

-- intersect :: (Eq a) => [a] -> [a] -> [a]
on intersect(xs, ys)
    if length of xs < length of ys then
        set {shorter, longer} to {xs, ys}
    else
        set {longer, shorter} to {xs, ys}
    end if
    if shorter ≠ {} then
        set lst to {}
        repeat with x in shorter
            if longer contains x then set end of lst to contents of x
        end repeat
        lst
    else
        {}
    end if
end intersect

-- intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
on intersectBy(eq, xs, ys)
    if length of xs > 0 and length of ys > 0 then
        set p to curry(eq)
        script matchFound
            on |λ|(x)
                any(p's |λ|(x), ys)
            end |λ|
        end script
        
        filter(matchFound, xs)
    else
        {}
    end if
end intersectBy

-- intersectListsBy :: (a -> a -> Bool) -> [[a]] -> [a]
on intersectListsBy(fnEq, xs)
    script
        property eq : mReturn(fnEq)
        on |λ|(a, x)
            intersectBy(eq, a, x)
        end |λ|
    end script
    foldr1(result, xs)
end intersectionBy

-- intersection :: Ord a => Set a -> Set a -> Set a
on intersection(a, b)
    set s to current application's NSMutableSet's alloc's init()
    s's setSet:(a)
    s's intersectSet:(b)
    return s
end intersection

-- intersperse :: a -> [a] -> [a]
-- intersperse :: Char -> String -> String
on intersperse(sep, xs)
    -- intersperse(0, [1,2,3]) -> [1, 0, 2, 0, 3]
    set lng to length of xs
    if lng > 1 then
        set acc to {item 1 of xs}
        repeat with i from 2 to lng
            set acc to acc & {sep, item i of xs}
        end repeat
        if class of xs is string then
            concat(acc)
        else
            acc
        end if
    else
        xs
    end if
end intersperse

-- isAlpha :: Char -> Bool
on isAlpha(c)
    set ca to current application
    set oRgx to ca's NSRegularExpression's ¬
        regularExpressionWithPattern:("[A-Za-z\\u00C0-\\u00FF]") ¬
            options:(ca's NSRegularExpressionAnchorsMatchLines as integer) ¬
            |error|:(missing value)
    set oString to ca's NSString's stringWithString:c
    0 < (oRgx's numberOfMatchesInString:oString options:0 ¬
        range:{location:0, |length|:1})
end isAlpha

-- isChar :: a -> Bool
on isChar(x)
    class of x is string and length of x is 1
end isChar

-- isDigit :: Char -> Bool
on isDigit(c)
    set n to (id of c)
    48 ≤ n and 57 ≥ n
end isDigit

-- isInfixOf :: (Eq a) => [a] -> [a] -> Bool
-- isInfixOf :: String -> String -> Bool
on isInfixOf(needle, haystack)
    haystack contains needle
end isInfixOf

-- isLeft :: Either a b -> Bool
on isLeft(x)
    set dct to current application's ¬
        NSDictionary's dictionaryWithDictionary:x
    (dct's objectForKey:"type") as text = "Either" and ¬
        (dct's objectForKey:"Right") as list = {missing value}
end isLeft

-- isLower :: Char -> Bool
on isLower(c)
    set d to (id of c) - 97 -- id of "a"
    d ≥ 0 and d < 26
end isLower

-- isMaybe :: a -> Bool
on isMaybe(x)
    -- use framework "Foundation"
    -- use scripting additions
    if class of x is record then
        set ca to current application
        set v to ((ca's NSDictionary's ¬
            dictionaryWithDictionary:x)'s ¬
            objectForKey:"type")
        v is not missing value ¬
            and (v's isKindOfClass:(ca's NSString)) ¬
            and (v as string = "Maybe")
    else
      false
    end if
end isMaybe

-- isNull :: [a] -> Bool
-- isNull :: String -> Bool
on isNull(xs)
    if class of xs is string then
        "" = xs
    else
        {} = xs
    end if
end isNull

-- isPrefixOf :: [a] -> [a] -> Bool
-- isPrefixOf :: String -> String -> Bool
on isPrefixOf(xs, ys)
    -- isPrefixOf takes two lists or strings and returns 
    --  true if and only if the first is a prefix of the second.
    script go
        on |λ|(xs, ys)
            set intX to length of xs
            if intX < 1 then
                true
            else if intX > length of ys then
                false
            else if class of xs is string then
                (offset of xs in ys) = 1
            else
                set {xxt, yyt} to {Just of uncons(xs), Just of uncons(ys)}
                ((|1| of xxt) = (|1| of yyt)) and |λ|(|2| of xxt, |2| of yyt)
            end if
        end |λ|
    end script
    go's |λ|(xs, ys)
end isPrefixOf

-- isRight :: Either a b -> Bool
on isRight(x)
    set dct to current application's ¬
        NSDictionary's dictionaryWithDictionary:x
    (dct's objectForKey:"type") as text = "Either" and ¬
        (dct's objectForKey:"Left") as list = {missing value}
end isRight

-- isSortedBy :: (a -> a -> Bool) -> [a] -> Bool
on isSortedBy(cmp, xs)
    -- The 'isSortedBy' function returns true iff the predicate returns true
    -- for all adjacent pairs of elements in the list.
    script LE
        on |λ|(x)
            x < 1
        end |λ|
    end script
    (length of xs < 2) or all(LE, zipWith(cmp, xs, tail(xs)))
end isSortedBy

-- isSpace :: Char -> Bool
on isSpace(c)
    set i to id of c
    32 = i or (9 ≤ i and 13 ≥ i)
end isSpace

-- isSubsequenceOf :: Eq a => [a] -> [a] -> Bool
-- isSubsequenceOf :: String -> String -> Bool
on isSubsequenceOf(xs, ys)
    script iss
        on |λ|(a, b)
            if a ≠ {} then
                if b ≠ {} then
                    if item 1 of a = item 1 of b then
                        |λ|(rest of a, rest of b)
                    else
                        |λ|(a, rest of b)
                    end if
                else
                    false
                end if
            else
                true
            end if
        end |λ|
    end script
    
    if class of xs = string then
        tell iss to |λ|(characters of xs, characters of ys)
    else
        tell iss to |λ|(xs, ys)
    end if
end isSubsequenceOf

-- isSubsetOf :: Ord a => Set a -> Set a -> Bool
on isSubsetOf(objcSetA, objcSetB)
    objcSetA's isSubsetOfSet:(objcSetB)
end isSubsetOf

-- isSuffixOf :: Eq a => [a] -> [a] -> Bool
-- isSuffixOf :: String -> String -> Bool
on isSuffixOf(ns, hs)
    script go
        on |λ|(delta)
            ns = dropLength(delta, hs)
        end |λ|
    end script
    bindMay(dropLengthMaybe(ns, hs), go)
end isSuffixOf

-- isUpper :: Char -> Bool
on isUpper(c)
    set d to (id of c) - 65 -- id of "A"
    d ≥ 0 and d < 26
end isUpper

-- iso8601Local :: Date -> String
on iso8601Local(dte)
    (dte as «class isot» as string)
end iso8601Local

-- iterate :: (a -> a) -> a -> Gen [a]
on iterate(f, x)
    script
        property v : missing value
        property g : mReturn(f)
        on |λ|()
            if missing value is v then
                set v to x
            else
                set v to g's |λ|(v)
            end if
            return v
        end |λ|
    end script
end iterate

-- iterateUntil :: (a -> Bool) -> (a -> a) -> a -> [a]
on iterateUntil(p, f, x)
    script
        property mp : mReturn(p)'s |λ|
        property mf : mReturn(f)'s |λ|
        property lst : {x}
        on |λ|(v)
            repeat until mp(v)
                set v to mf(v)
                set end of lst to v
            end repeat
            return lst
        end |λ|
    end script
    |λ|(x) of result
end iterateUntil

-- join :: Monad m => m (m a) -> m a
on join(x)
    bind(x, my identity)
end join

-- jsonFromTree :: Tree a -> String
on jsonFromTree(tree)
    script go
        on |λ|(x)
            {root of x, map(go, nest of x)}
        end |λ|
    end script
    set ca to current application
    ca's (NSString's alloc()'s ¬
        initWithData:((ca's (NSJSONSerialization's ¬
            dataWithJSONObject:(|λ|(tree) of go) ¬
                options:0 |error|:(missing value)))) ¬
            encoding:(ca's NSUTF8StringEncoding)) as string
end jsonFromTree

-- jsonLog :: a -> IO ()
on jsonLog(e)
    log showJSON(e)
end jsonLog

-- jsonParseLR :: String -> Either String a
on jsonParseLR(s)
    set ca to current application
    set {x, e} to ca's NSJSONSerialization's ¬
        JSONObjectWithData:((ca's NSString's stringWithString:s)'s ¬
            dataUsingEncoding:(ca's NSUTF8StringEncoding)) ¬
            options:0 |error|:(reference)
    if x is missing value then
        |Left|(e's localizedDescription() as string)
    else
        if 1 = (x's isKindOfClass:(ca's NSArray)) as integer then
            |Right|(x as list)
        else
            |Right|(item 1 of (x as list))
        end if
    end if
end jsonParseLR

-- justifyLeft :: Int -> Char -> String -> String
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

-- justifyRight :: Int -> Char -> String -> String
on justifyRight(n, cFiller)
    script
        on |λ|(txt)
            if n > length of txt then
                text -n thru -1 of ((replicate(n, cFiller) as text) & txt)
            else
                txt
            end if
        end |λ|
    end script
end justifyRight

-- keys :: Dict -> [String]
on keys(rec)
    (current application's NSDictionary's dictionaryWithDictionary:rec)'s allKeys() as list
end keys

-- kleisliCompose (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
on kleisliCompose(f, g)
    script
        on |λ|(x)
            bind(mReturn(f)'s |λ|(x), g)
        end |λ|
    end script
end kleisliCompose

-- last :: [a] -> a
on |last|(xs)
        item -1 of xs
end |last|

-- lastMay :: [a] -> Maybe a
on lastMay(xs)
    if length of xs > 0 then
        Just(item -1 of xs)
    else
        Nothing()
    end if
end lastMay

-- lcm :: Int -> Int -> Int
on lcm(x, y)
    if (x = 0 or y = 0) then
        0
    else
        abs(floor(x / (gcd(x, y))) * y)
    end if
end lcm

-- lefts :: [Either a b] -> [a]
on lefts(xs)
    script go
        on |λ|(x)
            if class of x is record then
                set ks to keys(x)
                if ks contains "type" and ks contains "Left" then
                    {x}
                else
                    {}
                end if
            else
                {}
            end if
        end |λ|
    end script
    concatMap(go, xs)
end lefts

-- length :: [a] -> Int
on |length|(xs)
    set c to class of xs
    if list is c or string is c then
        length of xs
    else
        (2 ^ 29 - 1) -- (maxInt - simple proxy for non-finite)
    end if
end |length|

-- levelNodes :: Tree a -> [[Tree a]]
on levelNodes(tree)
    script p
        on |λ|(xs)
            length of xs < 1
        end |λ|
    end script
    
    script f
        on |λ|(xs)
            script nest
                on |λ|(Node)
                    nest of Node
                end |λ|
            end script
            concatMap(nest, xs)
        end |λ|
    end script
    
    iterateUntil(p, f, {tree})
end levelNodes

-- levels :: Tree a -> [[a]]
on levels(tree)
    -- A list of lists, grouping the root
    -- values of each level of the tree.
    script go
        on |λ|(node, a)
            if {} ≠ a then
                tell a to set {h, t} to {item 1, rest}
            else
                set {h, t} to {{}, {}}
            end if
            
            {{root of node} & h} & foldr(go, t, nest of node)
        end |λ|
    end script
    
    |λ|(tree, {}) of go
end levels

-- liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
on liftA2(f, a, b)
    -- Lift a binary function to actions.
    -- e.g.
    -- liftA2(mult, {1, 2, 3}, {4, 5, 6}) 
    --> {4, 5, 6, 8, 10, 12, 12, 15, 18}
    set c to class of a
    if c is list or c is text then
        liftA2List(f, a, b)
    else
        set t to typeName(a)
        if "(a -> b)" = t then
            liftA2Fn(f, a, b)
        else if "Either" = t then
            liftA2LR(f, a, b)
        else if "Maybe" = t then
            liftA2May(f, a, b)
        else if "Tuple" = t then
            liftA2Tuple(f, a, b)
        else if "Node" = t then
            liftA2Tree(f, a, b)
        else
            missing value
        end if
    end if
end liftA2

-- liftA2Fn :: (a0 -> b -> c) -> (a -> a0) -> (a -> b) -> a -> c
on liftA2Fn(op, f, g)
    -- Lift a binary function to a composition
    -- over two other functions.
    -- liftA2 (*) (+ 2) (+ 3) 7 == 90
    script go
        property mop : mReturn(op)
        property mf : mReturn(f)
        property mg : mReturn(g)
        on |λ|(x)
            |λ|(|λ|(x) of mf, |λ|(x) of mg) of mop
        end |λ|
    end script
end liftA2Fn

-- liftA2LR :: (a -> b -> c) -> Either d a -> Either d b -> Either d c
on liftA2LR(f, a, b)
    set x to |Right| of a
    if class of b is list then
        set y to {}
    else
        set y to |Right| of b
    end if
    
    if x is missing value then
        a
    else if y is missing value then
        b
    else
        |Right|(|λ|(x, y) of mReturn(f))
    end if
end liftA2LR

-- liftA2List :: (a -> b -> c) -> [a] -> [b] -> [c]
on liftA2List(f, xs, ys)
    script
        property g : mReturn(f)'s |λ|
        on |λ|(x)
            script
                on |λ|(y)
                    {g(x, y)}
                end |λ|
            end script
            concatMap(result, ys)
        end |λ|
    end script
    concatMap(result, xs)
end liftA2List

-- liftA2May :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
on liftA2May(f, a, b)
    if Nothing of a then
        a
    else if Nothing of b then
        b
    else
        Just(|λ|(Just of a, Just of b) of mReturn(f))
    end if
end liftA2May

-- liftA2Tree :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
on liftA2Tree(f, tx, ty)
    
    script fx
        on |λ|(y)
            mReturn(f)'s |λ|(root of tx, y)
        end |λ|
    end script
    
    script fmapT
        on |λ|(t)
            fmapTree(fx, t)
        end |λ|
    end script
    
    script liftA2T
        on |λ|(t)
            liftA2Tree(f, t, ty)
        end |λ|
    end script
    
    if class of ty is list then
        set rootLabel to {}
        set forest to {}
    else
        set rootLabel to root of ty
        set forest to map(fmapT, nest of ty) & map(liftA2T, nest of tx)
    end if
    
    Node(mReturn(f)'s |λ|(root of tx, rootLabel), forest)
end liftA2Tree

-- liftA2Tuple :: Monoid m => (a -> b -> c) -> (m, a) -> (m, b) -> (m, c)
on liftA2Tuple(f, a, b)
    if class of b is list then
        set b1 to {}
        set b2 to {}
    else
        set b1 to |1| of b
        set b2 to |2| of b
    end if
    Tuple(mappend(|1| of a, b1), mReturn(f)'s |λ|(|2| of a, b2))
end liftA2Tuple

-- lines :: String -> [String]
on |lines|(xs)
    paragraphs of xs
end |lines|

-- list :: Gen [a] -> [a]
on |list|(gen)
    -- A strict list derived from a lazy generator.    
    set xs to {}
    set x to |λ|() of gen
    repeat while missing value ≠ x
        set end of xs to x
        set x to |λ|() of gen
    end repeat
    return xs
end |list|

-- listDirectory :: FilePath -> [FilePath]
on listDirectory(strPath)
    set ca to current application
    unwrap(ca's NSFileManager's defaultManager()'s ¬
        contentsOfDirectoryAtPath:(unwrap(stringByStandardizingPath of ¬
            wrap(strPath))) |error|:(missing value))
end listDirectory

-- listFromMaybe :: Maybe a -> [a]
on listFromMaybe(mb)
    -- A singleton list derived from a Just value, 
    -- or an empty list derived from Nothing.
    if Nothing of mb then
        {}
    else
        {Just of mb}
    end if
end maybeToList

-- listFromTree :: Tree a -> [a]
on listFromTree(tree)
    script go
        on |λ|(x)
            {root of x} & concatMap(go, nest of x)
        end |λ|
    end script
    |λ|(tree) of go
end listFromTree

-- listFromTuple :: (a, a ...) -> [a]
on listFromTuple(tpl)
    items 2 thru -2 of (tpl as list)
end listFromTuple

-- listToMaybe :: [a] -> Maybe a
on listToMaybe(xs)
    -- The listToMaybe function returns Nothing on 
    -- an empty list or Just the head of the list.
    if xs ≠ {} then
        Just(item 1 of xs)
    else
        Nothing()
    end if
end listToMaybe

-- log :: Float -> Float
on |log|(n)
    Just of evalJSMay(("Math.log(" & n as string) & ")")
end |log|

-- lookup :: Eq a => a -> Container -> Maybe b
on lookup(k, m)
    set c to class of m
    if c is list then
        lookupTuples(k, m)
    else if c = record then
        lookupDict(k, m)
    else
        Nothing()
    end if
end lookup

-- lookupDict :: a -> Dict -> Maybe b
on lookupDict(k, dct)
    -- Just the value of k in the dictionary,
    -- or Nothing if k is not found.
    set ca to current application
    set v to (ca's NSDictionary's dictionaryWithDictionary:dct)'s objectForKey:k
    if missing value ≠ v then
        Just(item 1 of ((ca's NSArray's arrayWithObject:v) as list))
    else
        Nothing()
    end if
end lookupDict

-- lookupTuples :: Eq a => a -> [(a, b)] -> Maybe b
on lookupTuples(k, xs)
    script keyMatch
        on |λ|(x)
            k = fst(x)
        end |λ|
    end script
    
    script harvestMay
        on |λ|(kv)
            Just(snd(kv))
        end |λ|
    end script
    
    bindMay(find(keyMatch, xs), harvestMay)
end lookupTuples

-- lt (<) :: Ord a => a -> a -> Bool
on lt(x)
	script
		on |λ|(y)
			x < y
		end |λ|
	end script
end lt

-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    -- 2nd class handler function lifted into 1st class script wrapper. 
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    -- The list obtained by applying f
    -- to each element of 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

-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
on mapAccumL(f, acc, xs)
    -- 'The mapAccumL function behaves like a combination of map and foldl; 
    -- it applies a function to each element of a list, passing an 
    -- accumulating parameter from |Left| to |Right|, and returning a final 
    -- value of this accumulator together with the new list.' (see Hoogle)
    script
        on |λ|(a, x, i)
            tell mReturn(f) to set pair to |λ|(|1| of a, x, i)
            Tuple(|1| of pair, (|2| of a) & {|2| of pair})
        end |λ|
    end script
    
    foldl(result, Tuple(acc, []), xs)
end mapAccumL

-- mapAccumL_Tree :: (acc -> x -> (acc, y)) -> acc -> Tree -> (acc, Tree)
on mapAccumL_Tree(f, acc, tree)
    script go
        property mf : mReturn(f)'s |λ|
        on |λ|(a, x)
            set pair to f(a, root of x)
            set tpl to mapAccumL(go, item 1 of pair, nest of x)
            Tuple(item 1 of tpl, Node(item 2 of pair, item 2 of tpl))
        end |λ|
    end script
    |λ|(acc, tree) of go
end mapAccumL_Tree

-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
on mapAccumR(f, acc, xs)
    -- 'The mapAccumR function behaves like a combination of map and foldr; 
    --  it applies a function to each element of a list, passing an accumulating 
    --  parameter from |Right| to |Left|, and returning a final value of this 
    --  accumulator together with the new list.' (see Hoogle)
    script
        on |λ|(x, a, i)
            tell mReturn(f) to set pair to |λ|(|1| of a, x, i)
            Tuple(|1| of pair, (|2| of pair) & |2| of a)
        end |λ|
    end script
    foldr(result, Tuple(acc, []), xs)
end mapAccumR

-- mapKeys :: (Key -> Key) -> IntMap a -> IntMap a
on mapKeys(f, dct)
    script
        property g : mReturn(f)
        on |λ|(kv)
            set {k, v} to kv
            {g's |λ|(k), v}
        end |λ|
    end script
    map(result, zip(keys(dct), elems(dct)))
end mapKeys

-- mapMaybe :: (a -> Maybe b) -> [a] -> [b]
on mapMaybe(mf, xs)
    -- The mapMaybe function is a version of map which can throw out
    -- elements. In particular, the functional argument returns
    -- something of type Maybe b. If this is Nothing, no element is
    -- added on to the result list. If it just Just b, then b is
    -- included in the result list.
    script
        property g : mReturn(mf)
        on |λ|(a, x)
            set mb to g's |λ|(x)
            if Nothing of mb then
                a
            else
                a & (Just of mb)
            end if
        end |λ|
    end script
    foldl(result, {}, xs)
end mapMaybe

-- mapMaybeGen :: (a -> Maybe b) -> Gen [a] -> Gen [b]
on mapMaybeGen(mf, gen)
    script
        property mg : mReturn(mf)
        on |λ|()
            set v to gen's |λ|()
            if v is not missing value then
                set mb to mg's |λ|(v)
                repeat while (Nothing of mb) and not (missing value is v)
                    set v to gen's |λ|()
                    if missing value is not v then set mb to mg's |λ|(v)
                end repeat
                if not |Nothing| of mb then
                    |Just| of mb
                else
                    missing value
                end if
            else
                v
            end if
        end |λ|
    end script
end mapMaybeGen

-- mappend (<>) :: Monoid a => a -> a -> a
on mappend(a, b)
    set ca to class of a
    if record is ca then
        script instanceMay
            on |λ|(strType)
                set mb to lookup(strType, ¬
                    {Maybe:mappendMaybe, Ordering:mappendOrdering, Tuple:mappendTuple})
            end |λ|
        end script
        set mbi to bindMay(lookup("type", a), instanceMay)
        if Nothing of mbi then
            a & b
        else
            mReturn(Just of mbi)'s |λ|(a, b)
        end if
    else if handler is ca then
        mappendFn(a, b)
    else
        a & b
    end if
end mappend

-- mappendFn :: Monoid b => (a -> b) -> (a -> b) -> (a -> b)
on mappendFn(f, g)
    script
        property mf : mReturn(f)
        property mg : mReturn(g)
        on |λ|(x)
            mappend(mf's |λ|(x), mg's |λ|(x))
        end |λ|
    end script
end mappendFn

-- mappendMaybe (<>) :: Maybe a -> Maybe a -> Maybe a
on mappendMaybe(a, b)
    if Nothing of a then
        b
    else if Nothing of b then
        a
    else
        Just(mappend(Just of a, Just of b))
    end if
end mappendMaybe

-- mappendOrd (<>) :: Ordering -> Ordering -> Ordering
on mappendOrd(a, b)
    if 0 ≠ a then
        a
    else
        b
    end if
end mappendOrd

-- mappendTuple (<>) :: (a, b) -> (a, b) -> (a, b)
on mappendTuple(a, b)
    Tuple(mappend(|1| of a, |1| of b), mappend(|2| of a, |2| of b))
end mappendTuple

-- matching :: [a] -> (a -> Int -> [a] -> Bool)
-- matching :: String -> (Char -> Int -> String -> Bool)
on matching(pat)
    -- Returns a sequence-matching function for findIndices etc
    if class of pat is text then
        set xs to characters of pat
    else
        set xs to pat
    end if
    set lng to length of xs
    set bln to 0 < lng
    if bln then
        set h to item 1 of xs
    else
        set h to missing value
    end if
    script
        on |λ|(x, i, src)
            (h = x) and xs = ¬
                (items i thru min(length of src, -1 + lng + i) of src)
        end |λ|
    end script
end matching

-- matrix :: Int -> Int -> ((Int, Int) -> a) -> [[a]]
on matrix(nRows, nCols, f)
    -- A matrix of a given number of columns and rows,
    -- in which each value is a given function of its
    -- (zero-based) column and row indices.
    script go
        property g : mReturn(f)'s |λ|
        on |λ|(iRow)
            set xs to {}
            repeat with iCol from 1 to nCols
                set end of xs to g(iRow, iCol)
            end repeat
            xs
        end |λ|
    end script
    
    map(go, enumFromTo(1, nRows))
end matrix

-- max :: Ord a => a -> a -> a
on max(x, y)
    if gt(x, y) then
        x
    else
        y
    end if
end max

-- maxBound :: a -> a
on maxBound(x)
    set c to class of x
    if text is c then
        character id 65535
    else if integer is c then
        (2 ^ 29 - 1)
    else if real is c then
        1.797693E+308
    else if boolean is c then
        true
    end if
end maxBound

-- maximum :: Ord a => [a] -> a
on maximum(xs)
    set ca to current application
    unwrap((ca's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@max.self")
end maximum

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

-- maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
on maximumByMay(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
    
    foldl1May(max, xs)
end maximumByMay

-- maximumMay :: Ord a => [a] -> Maybe a
on maximumMay(xs)
    foldl1May(max, xs)
end maximumMay

-- maybe :: b -> (a -> b) -> Maybe a -> b
on maybe(v, f, mb)
    -- Either the default value v (if mb is Nothing),
    -- or the application of the function f to the 
    -- contents of the Just value in mb.
    if Nothing of mb then
        v
    else
        tell mReturn(f) to |λ|(Just of mb)
    end if
end maybe

-- mean :: [Num] -> Num
on mean(xs)
    set ca to current application
    ((ca's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@avg.self") as real
end mean

-- memberDict :: Key -> Dict -> Bool
on memberDict(k, dct)
    ((current application's ¬
        NSDictionary's dictionaryWithDictionary:dct)'s ¬
        objectForKey:k) is not missing value
end member

-- memberSet :: a -> Set a -> Bool
on memberSet(x, oSet)
    oSet's containsObject:(x)
end memberSet

-- min :: Ord a => a -> a -> a
on min(x, y)
    if y < x then
        y
    else
        x
    end if
end min

-- minBound :: a -> a
on minBound(x)
    set c to class of x
    if text is c then
        character id 1
    else if integer is c then
        -(2 ^ 29 - 1)
    else if real is c then
        -1.797693E+308
    else if boolean is c then
        false
    end if
end minBound

-- minimum :: Ord a => [a] -> a
on minimum(xs)
    set ca to current application
    unwrap((ca's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@min.self")
end minimum

-- minimumBy :: (a -> a -> Ordering) -> [a] -> a
on minimumBy(f, xs)
    set lng to length of xs
    if lng < 1 then
        missing value
    else if lng > 1 then
        tell mReturn(f)
            set v to item 1 of xs
            repeat with x in xs
                if |λ|(x, v) < 0 then set v to contents of x
            end repeat
            return v
        end tell
    else
        item 1 of xs
    end if
end minimumBy

-- minimumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
on minimumByMay(f, xs)
    set lng to length of xs
    if lng < 1 then
        Nothing()
    else if lng > 1 then
        tell mReturn(f)
            set v to item 1 of xs
            repeat with x in xs
                if |λ|(x, v) < 0 then set v to contents of x
            end repeat
            return Just(v)
        end tell
    else
        Just(item 1 of xs)
    end if
end minimumByMay

-- minimumMay :: [a] -> Maybe a
on minimumMay(xs)
    set lng to length of xs
    if lng < 1 then
        Nothing()
    else if lng > 1 then
        set m to item 1 of xs
        repeat with x in xs
            set v to contents of x
            if v < m then set m to v
        end repeat
        Just(m)
    else
        Just(item 1 of xs)
    end if
end minimumMay

-- mod :: Int -> Int -> Int
on |mod|(n, d)
    -- The built-in infix `mod` inherits the sign of the 
    -- *dividend* for non zero results. 
    -- (i.e. the 'rem' pattern in some languages).
    --
    -- This version inherits the sign of the *divisor*.
    -- (A more typical 'mod' pattern, and useful,
    -- for example with biredirectional list rotations).
    if signum(n) = signum(-d) then
        (n mod d) + d
    else
        (n mod d)
    end if
end |mod|

-- modificationTime :: FilePath -> Either String Date
on modificationTime(fp)
    script fs
        on |λ|(rec)
            |Right|(NSFileModificationDate of rec)
        end |λ|
    end script
    bindLR(my fileStatus(fp), fs)
end modificationTime

-- mul (*) :: Num a => a -> a -> a
on mul(a)
    -- Curried multiplication.
    script
        on |λ|(b)
            a * b
        end |λ|
    end script
end mul

-- ne :: a -> a -> Bool
on ne(a)
    script
        on |λ|(b)
            a ≠ b
        end |λ|
    end script
end ne

-- negate :: Num -> Num
on |negate|(n)
    -n
end |negate|

-- nest :: Tree a -> [a]
on nest(oTree)
    nest of oTree
end nest

-- newUUID :: () -> IO UUID String
on newUUID()
    current application's NSUUID's UUID's UUIDString as string
end newUUID

-- not :: Bool -> Bool
on |not|(p)
    -- `not` as a composable  and mappable function.
    not p
end |not|

-- notElem :: Eq a => a -> [a] -> Bool
on notElem(x, xs)
    xs does not contain x
end notElem

-- nub :: [a] -> [a]
on nub(xs)
    ((current application's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@distinctUnionOfObjects.self") as list
end nub

-- nubBy :: (a -> a -> Bool) -> [a] -> [a]
on nubBy(f, xs)
    set g to mReturn(f)'s |λ|
    
    script notEq
        property fEq : g
        on |λ|(a)
            script
                on |λ|(b)
                    not fEq(a, b)
                end |λ|
            end script
        end |λ|
    end script
    
    script go
        on |λ|(xs)
            if (length of xs) > 1 then
                set x to item 1 of xs
                {x} & go's |λ|(filter(notEq's |λ|(x), items 2 thru -1 of xs))
            else
                xs
            end if
        end |λ|
    end script
    
    go's |λ|(xs)
end nubBy

-- odd :: Int -> Bool
on odd(x)
    not even(x)
end odd

-- on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
on |on|(f, g)
    -- e.g. sortBy(|on|(compare, |length|), ["epsilon", "mu", "gamma", "beta"])
    script
        on |λ|(a, b)
            tell mReturn(g) to set {va, vb} to {|λ|(a), |λ|(b)}
            tell mReturn(f) to |λ|(va, vb)
        end |λ|
    end script
end |on|

-- or :: [Bool] -> Bool
on |or|(ps)
    repeat with p in ps
        if p then return true
    end repeat
    return false
end |or|

-- ord :: Char -> Int
on ord(c)
    id of c
end ord

-- orderedUnion :: [a] -> [a] -> [a]
on orderedUnion(xs, ys)
    (union(setFromList(xs), setFromList(ys))'s ¬
        allObjects()'s sortedArrayUsingSelector:"compare:") as list
end orderedUnion

-- ordering :: () -> Ordering
on ordering()
    enumFromPairs("Ordering", {{"LT", -1}, {"EQ", 0}, {"GT", 1}})
end ordering

-- All lines in the string outdented by the same amount
-- (just enough to ensure that the least indented lines 
--  have no remaining indent)
-- All relative indents are left unchanged
-- outdented :: String -> String
on outdented(s)
    set xs to |lines|(s)
    script dent
        on |λ|(x)
            script isSpace
                on |λ|(c)
                    id of c = 32
                end |λ|
            end script
            length of takeWhile(isSpace, x)
        end |λ|
    end script
    set n to |λ|(minimumBy(comparing(dent), xs)) of dent
    if n < 1 then
        s
    else
        unlines(map(|λ|(n) of curry(drop), xs))
    end if
end outdented

-- partition :: (a -> Bool) -> [a] -> ([a], [a])
on partition(f, xs)
    tell mReturn(f)
        set ys to {}
        set zs to {}
        repeat with x in xs
            set v to contents of x
            if |λ|(v) then
                set end of ys to v
            else
                set end of zs to v
            end if
        end repeat
    end tell
    Tuple(ys, zs)
end partition

-- partitionEithers :: [Either a b] -> ([a],[b])
on partitionEithers(xs)
    set ys to {}
    set zs to {}
    repeat with x in xs
        if isRight(x) then
            set end of zs to x
        else
            set end of ys to x
        end if
    end repeat
    Tuple(ys, zs)
end partitionEithers

-- permutations :: [a] -> [[a]]
on permutations(xs)
    script go
        on |λ|(x, a)
            script
                on |λ|(ys)
                    script infix
                        on |λ|(n)
                            if ys ≠ {} then
                                take(n, ys) & x & drop(n, ys)
                            else
                                {x}
                            end if
                        end |λ|
                    end script
                    map(infix, enumFromTo(0, (length of ys)))
                end |λ|
            end script
            concatMap(result, a)
        end |λ|
    end script
    foldr(go, {{}}, xs)
end permutations

-- permutationsWithRepetition :: Int -> [a] -> [[a]]
on permutationsWithRepetition(n, xs)
    if 0 < length of xs then
        foldl1(curry(my cartesianProduct)'s |λ|(xs), replicate(n, xs))
    else
        {}
    end if
end permutationsWithRepetition

-- pi :: Float
on |pi|()
    pi
end |pi|

-- plus :: Num -> Num -> Num
on plus(a, b)
    a + b
end plus

-- Root elements of tree flattened bottom-up
-- into a postorder list.
-- postorder :: Tree a -> [a]
on postorder(node)
    script go
        on |λ|(xs, x)
            foldl(go, xs, nest of x) & {root of x}
        end |λ|
    end script
    go's |λ|({}, node)
end postorder

-- pred :: Enum a => a -> a
on pred(x)
    if isChar(x) then
        chr(ord(x) - 1)
    else
        (-1) + x
    end if
end pred

-- predMay :: Enum a => a -> Maybe a
on predMay(x)
    if x is minBound(x) then
        Nothing()
    else
        Just(toEnum(x)'s |λ|(fromEnum(x) - 1))
    end if
end predMay

-- print :: a -> IO ()
on print (x)
    log x
    return x
end print

-- product :: [Num] -> Num
on product(xs)
    script multiply
        on |λ|(a, b)
            a * b
        end |λ|
    end script
    
    foldl(multiply, 1, xs)
end product

-- properFracRatio :: Ratio -> (Int, Ratio)
on properFracRatio(r)
    set n to n of r
    set d to d of r
    Tuple(n div d, ratio(n mod d, d))
end properFracRatio

-- properFraction :: Real -> (Int, Real)
on properFraction(n)
    set i to (n div 1)
    Tuple(i, n - i)
end properFraction

-- pureLR :: a -> Either e a
on pureLR(x)
    |Right|(x)
end pureLR

-- pureList :: a -> [a]
on pureList(x)
        {x}
end pure

-- pureMay :: a -> Maybe a
on pureMay(x)
    Just(x)
end pureMay

-- Given a type name string, returns a 
-- specialised 'pure', where
-- 'pure' lifts a value into a particular functor.
-- pureT :: String -> f a -> (a -> f a)
on pureT(t, x)
    if "List" = t then
        pureList(x)
    else if "Either" = t then
        pureLR(x)
    else if "Maybe" = t then
        pureMay(x)
    else if "Node" = t then
        pureTree(x)
    else if "Tuple" = t then
        pureTuple(x)
    else
        pureList(x)
    end if
end pureT

-- pureTree :: a -> Tree a
on pureTree(x)
    Node(x, {})
end pureTree

-- pureTuple :: a -> (a, a)
on pureTuple(x)
    Tuple("", x)
end pureTuple

-- quickSort :: (Ord a) => [a] -> [a]
on quickSort(xs)
    -- Adequate for small sorts, but sort (Ord a => [a] -> [a]), (which uses the ObjC
    -- sortedArrayUsingSelector) is the one to use
    if length of xs > 1 then
        set h to item 1 of xs
        script
            on |λ|(x)
                x ≤ h
            end |λ|
        end script
        set {less, more} to partition(result, rest of xs)
        quickSort(less) & h & quickSort(more)
    else
        xs
    end if
end quickSort

-- quickSortBy :: (a -> a -> Ordering) -> [a] -> [a]
on quickSortBy(cmp, xs)
    -- quickSortBy(comparing(my |length|), 
    -- {"alpha", "beta", "gamma", "delta", "epsilon", "zeta", 
    --  "eta", "theta", "iota", "kappa", "lambda", "mu"})
    if length of xs > 1 then
        set h to item 1 of xs
        script
            on |λ|(x)
                cmp's |λ|(x, h) ≠ 1
            end |λ|
        end script
        set {less, more} to partition(result, rest of xs)
        quickSortBy(cmp, less) & h & quickSortBy(cmp, more)
    else
        xs
    end if
end quickSortBy

-- quot :: Int -> Int -> Int
on quot(m, n)
    m div n
end quot

-- quotRem :: Int -> Int -> (Int, Int)
on quotRem(m, n)
    {m div n, m mod n}
end quotRem

-- quoted :: Char -> String -> String
on quoted(c)
    -- A string flanked on both sides
    -- by a specified quote character.
    script
        on |λ|(s)
            c & s & c
        end |λ|
    end script
end quoted

-- radians :: Float x => Degrees x -> Radians x
on radians(x)
    (pi / 180) * x
end radians

-- raise :: Num -> Int -> Num
on raise(m, n)
    m ^ n
end raise

-- e.g. map(randomRInt(1, 10), ft(1, 20))
-- randomRInt :: Int -> Int -> IO () -> Int
on randomRInt(low, high)
    script
        on |λ|(_)
            (low + ((random number) * (1 + (high - low)))) div 1
        end |λ|
    end script
end randomRInt

-- range :: Ix a => (a, a) -> [a]
on range(ab)
    set {a, b} to {|1| of ab, |2| of ab}
    if class of a is list then
        set {xs, ys} to {a, b}
    else
        set {xs, ys} to {{a}, {b}}
    end if
    set lng to length of xs
    
    if lng = length of ys then
        if lng > 1 then
            script
                on |λ|(_, i)
                    enumFromTo(item i of xs, item i of ys)
                end |λ|
            end script
            sequence(map(result, xs))
        else
            enumFromTo(a, b)
        end if
    else
        {}
    end if
end range

-- ratio :: Int -> Int -> Ratio Int
on ratio(x, y)
    script go
        on |λ|(x, y)
            if 0 ≠ y then
                if 0 ≠ x then
                    set d to gcd(x, y)
                    {type:"Ratio", n:(x div d), d:(y div d)}
                else
                    {type:"Ratio", n:0, d:0}
                end if
            else
                missing value
            end if
        end |λ|
    end script
    go's |λ|(x * (signum(y)), abs(y))
end ratio

-- ratioDiv :: Rational -> Rational -> Rational
on ratioDiv(n1, n2)
    set r1 to rational(n1)
    set r2 to rational(n2)
    ratio((n of r1) * (d of r2), (d of r1) * (n of r2))
end ratioDiv

-- ratioMinus :: Rational -> Rational -> Rational
on ratioMinus(n1, n2)
    set r1 to rational(n1)
    set r2 to rational(n2)
    set d to lcm(d of r1, d of r2)
    ratio((n of r1) * (d / (d of r1) - ¬
        ((n of r2) * (d / (d of r2)))), d)
end ratioMinus

-- ratioMult :: Rational -> Rational -> Rational
on ratioMult(n1, n2)
    set r1 to rational(n1)
    set r2 to rational(n2)
    ratio((n of r1) * (n of r2), (d of r1) * (d of r2))
end ratioMult

-- ratioPlus :: Rational -> Rational -> Rational
on ratioPlus(n1, n2)
    set r1 to rational(n1)
    set r2 to rational(n2)
    set d to lcm(d of r1, d of r2)
    ratio((n of r1) * (d / (d of r1) + ¬
        ((n of r2) * (d / (d of r2)))), d)
end ratioPlus

-- rational :: Num a => a -> Rational
on rational(x)
    set c to class of x
    if integer is c then
        ratio(x, 1)
    else if real is c then
        approxRatio(missing value, x)
    else
        x
    end if
end rational

-- read :: Read a => String -> a
on read (s)
    run script s
end read

-- readBinary :: String -> Int
on readBinary(s)
    -- The integer value of the binary string s
    script go
        on |λ|(c, en)
            set {e, n} to en
            set v to ((id of c) - 48)
            
            {2 * e, v * e + n}
        end |λ|
    end script
    
    item 2 of foldr(go, {1, 0}, s)
end readBinary

-- readFile :: FilePath -> IO String
on readFile(strPath)
    set ca to current application
    set e to reference
    set {s, e} to (ca's NSString's ¬
        stringWithContentsOfFile:((ca's NSString's ¬
            stringWithString:strPath)'s ¬
            stringByStandardizingPath) ¬
            encoding:(ca's NSUTF8StringEncoding) |error|:(e))
    if missing value is e then
        s as string
    else
        (localizedDescription of e) as string
    end if
end readFile

-- readFileLR :: FilePath -> Either String IO String
on readFileLR(strPath)
    set ca to current application
    set e to reference
    set {s, e} to (ca's NSString's ¬
        stringWithContentsOfFile:((ca's NSString's ¬
            stringWithString:strPath)'s ¬
            stringByStandardizingPath) ¬
            encoding:(ca's NSUTF8StringEncoding) |error|:(e))
    if s is missing value then
        |Left|((localizedDescription of e) as string)
    else
        |Right|(s as string)
    end if
end readFileLR

-- readHex :: String -> Int
on readHex(s)
    -- The integer value of the given hexadecimal string.
    set ds to "0123456789ABCDEF"
    script go
        on |λ|(c, a)
            set {v, e} to a
            set i to maybe(0, my identity, elemIndex(c, ds))
            {v + (i * e), 16 * e}
        end |λ|
    end script
    item 1 of foldr(go, {0, 1}, characters of s)
end readHex

-- readLR :: Read a => String -> Either String a
on readLR(s)
    try
        |Right|(run script s)
    on error e
        |Left|(e)
    end try
end readLR

-- recip :: Num -> Num
on recip(n)
    if n ≠ 0 then
        1 / n
    else
        missing value
    end if
end recip

-- recipMay :: Num -> Maybe Num
on recipMay(n)
    if n ≠ 0 then
        Just(1 / n)
    else
        Nothing()
    end if
end recipMay

-- regexMatches :: Regex String -> String -> [[String]]
on regexMatches(strRegex, strHay)
	set ca to current application
	-- NSNotFound handling and and High Sierra workaround due to @sl1974
	set NSNotFound to a reference to 9.22337203685477E+18 + 5807
	set oRgx to ca's NSRegularExpression's regularExpressionWithPattern:strRegex ¬
		options:((ca's NSRegularExpressionAnchorsMatchLines as integer)) ¬
		|error|:(missing value)
	set oString to ca's NSString's stringWithString:strHay
	
	script matchString
		on |λ|(m)
			script rangeMatched
				on |λ|(i)
					tell (m's rangeAtIndex:i)
						set intFrom to its location
						if NSNotFound ≠ intFrom then
							text (intFrom + 1) thru (intFrom + (its |length|)) of strHay
						else
							missing value
						end if
					end tell
				end |λ|
			end script
		end |λ|
	end script
	
	script asRange
		on |λ|(x)
			range() of x
		end |λ|
	end script
	map(asRange, (oRgx's matchesInString:oString ¬
		options:0 range:{location:0, |length|:oString's |length|()}) as list)
end regexMatches

-- rem :: Int -> Int -> Int
on rem(m, n)
    m mod n
end rem

-- removeFile :: FilePath -> Either String String
on removeFile(fp)
    set e to reference
    set {bln, obj} to current application's NSFileManager's ¬
        defaultManager's removeItemAtPath:(fp) |error|:(e)
    if bln then
        |Right|("Removed: " & fp)
    else
        |Left|(obj's localizedDescription as string)
    end if
end removeFile

-- renamedFile :: FilePath -> FilePath ->
-- Either IO String IO String
on renamedFile(fp, fp2)
    set e to reference
    set {bln, obj} to current application's NSFileManager's ¬
        defaultManager's moveItemAtPath:(fp) toPath:(fp2) |error|:(e)
    if bln then
        |Right|(fp2)
    else
        |Left|(obj's localizedDescription as string)
    end if
end renameFile

-- repeat :: a -> Generator [a]
on |repeat|(x)
    script
        on |λ|()
            return x
        end |λ|
    end script
end |repeat|

-- replace :: String -> String -> String -> String
on replace(strNeedle, strNew, strHayStack)
    set {dlm, my text item delimiters} to {my text item delimiters, strNeedle}
    set xs to text items of strHayStack
    set my text item delimiters to strNew
    set strReplaced to xs as text
    set my text item delimiters to dlm
    return strReplaced
end replace

-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary 
-- assembly of a target length
-- replicate :: Int -> String -> String
on replicate(n, s)
    -- Egyptian multiplication - progressively doubling a list, 
    -- appending stages of doubling to an accumulator where needed 
    -- for binary assembly of a target length
    script p
        on |λ|({n})
            n ≤ 1
        end |λ|
    end script
    
    script f
        on |λ|({n, dbl, out})
            if (n mod 2) > 0 then
                set d to out & dbl
            else
                set d to out
            end if
            {n div 2, dbl & dbl, d}
        end |λ|
    end script
    
    set xs to |until|(p, f, {n, s, ""})
    item 2 of xs & item 3 of xs
end replicate

-- Instance for lists only here

-- e.g. replicateM(3, {1, 2})) -> 
-- {{1, 1, 1}, {1, 1, 2}, {1, 2, 1}, {1, 2, 2}, {2, 1, 1}, 
--  {2, 1, 2}, {2, 2, 1}, {2, 2, 2}}
-- replicateM :: Int -> [a] -> [[a]]
on replicateM(n, xs)
    script go
        script cons
            on |λ|(a, bs)
                {a} & bs
            end |λ|
        end script
        on |λ|(x)
            if x ≤ 0 then
                {{}}
            else
                liftA2List(cons, xs, |λ|(x - 1))
            end if
        end |λ|
    end script
    
    go's |λ|(n)
end replicateM

-- replicateString :: Int -> String -> String
on replicateString(n, s)
    set out to ""
    if n < 1 then return out
    set dbl to s
 
    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 replicateS

-- reverse :: [a] -> [a]
on |reverse|(xs)
    if class of xs is text then
        (reverse of characters of xs) as text
    else
        reverse of xs
    end if
end |reverse|

-- rights :: [Either a b] -> [b]
on rights(xs)
    script
        on |λ|(x)
            if class of x is record then
                set ks to keys(x)
                if ks contains "type" and ks contains "Right" then
                    {|Right| of x}
                else
                    {}
                end if
            else
                {}
            end if
        end |λ|
    end script
    concatMap(result, xs)
end rights

-- root :: Tree a -> a
on root(oTree)
    root of oTree
end root

-- rotate :: Int -> [a] -> [a]
on rotate(n, xs)
    set lng to |length|(xs)
    if missing value is not lng then
        take(lng, drop(lng - n, cycle(xs)))
    else
        lng
    end if
end rotate

-- rotated :: Int -> [a] -> [a]
on rotated(n, xs)
    set lng to length of xs
    set m to |mod|(n, lng)
    
    if 0 ≠ n then
        (items (1 + m) thru -1 of xs) & ¬
            (items 1 thru m of xs)
    else
        xs
    end if
end rotated

-- round :: a -> Int
on |round|(n)
    round n
end |round|

-- Float x rounded to n decimals
-- roundTo :: Int -> Float -> Float
on roundTo(n, x)
	set d to 10 ^ n
	(round (x * d)) / d
end roundTo

-- runAction :: Action a -> a
on runAction(act)
    -- Evaluation of an action.
    tell act to |λ|(its arg) of my mReturn(its act)
end runAction

-- safeMay :: (a -> Bool) -> (a -> b) -> Maybe b
on safeMay(p, f, x)
    if p(x) then
        Just(f(x))
    else
        Nothing()
    end if
end safeMay

-- scanl :: (b -> a -> b) -> b -> [a] -> [b]
on scanl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        set lst to {startValue}
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
            set end of lst to v
        end repeat
        return lst
    end tell
end scanl

-- scanl1 :: (a -> a -> a) -> [a] -> [a]
on scanl1(f, xs)
    if 0 < length of xs then
        scanl(f, item 1 of xs, rest of xs)
    else
        {}
    end if
end scanl

-- scanr :: (b -> a -> b) -> b -> [a] -> [b]
on scanr(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        set lst to {startValue}
        repeat with i from lng to 1 by -1
            set v to |λ|(v, item i of xs, i, xs)
            set end of lst to v
        end repeat
        return reverse of lst
    end tell
end scanr

-- scanr1 :: (a -> a -> a) -> [a] -> [a]
on scanr1(f, xs)
    if length of xs > 0 then
        scanr(f, item -1 of xs, init(xs))
    else
        {}
    end if
end scanr1

-- second :: (a -> b) -> ((c, a) -> (c, b))
on |second|(f)
-- Lift a simple function to one which applies to a tuple, 
-- transforming only the second item of that tuple
    script
        on |λ|(xy)
            Tuple(|1| of xy, mReturn(f)'s |λ|(|2| of xy))
        end |λ|
    end script
end |second|

-- sequenceA :: (Applicative f, Traversable t) => t (f a) -> f (t a)
on sequenceA(tfa)
    script identity
        on |λ|(x)
            x
        end |λ|
    end script
    traverse(identity, tfa)
end sequenceA

-- setCurrentDirectory :: String -> IO ()
on setCurrentDirectory(strPath)
    if doesDirectoryExist(strPath) then
        set ca to current application
        set oPath to (ca's NSString's stringWithString:strPath)'s ¬
            stringByStandardizingPath
        ca's NSFileManager's defaultManager()'s ¬
            changeCurrentDirectoryPath:oPath
    end if
end setCurrentDirectory

-- setFromList :: Ord a => [a] -> Set a
on setFromList(xs)
    -- NB All names of NSMutableSets should be set to *missing value*
    -- before the script exits.
    -- ( scpt files can not be saved if they contain ObjC pointer values)
    set ca to current application
    ca's NSMutableSet's ¬
        setWithArray:(ca's NSArray's arrayWithArray:(xs))
end setFromList

-- setInsert :: Ord a => a -> Set a -> Set a
on setInsert(x, objcSet)
    objcSet's addObject:(x)
    objcSet
end setInsert

-- setMember :: Ord a => a -> Set a -> Bool
on setMember(x, objcSet)
    missing value is not (objcSet's member:(x))
end setMember

-- setSize :: Set a -> Int
on setSize(objcSet)
    objcSet's |count|() as integer
end setSize

-- shift :: Int -> [a] -> [a]
on shift(n, xs)
    set lng to |length|(xs)
    if missing value is not lng then
        take(lng, drop(n, cycle(xs)))
    else
        drop(n, xs)
    end if
end shift

-- show :: a -> String
on show(e)
    set c to class of e
    if c = list then
        showList(e)
    else if c = record then
        set mb to lookupDict("type", e)
        if Nothing of mb then
            showDict(e)
        else
            script
                on |λ|(t)
                    if "Either" = t then
                        set f to my showLR
                    else if "Maybe" = t then
                        set f to my showMaybe
                    else if "Ordering" = t then
                        set f to my showOrdering
                    else if "Ratio" = t then
                        set f to my showRatio
                    else if class of t is text and t begins with "Tuple" then
                        set f to my showTuple
                    else
                        set f to my showDict
                    end if
                    tell mReturn(f) to |λ|(e)
                end |λ|
            end script
            tell result to |λ|(Just of mb)
        end if
    else if c = date then
        "\"" & showDate(e) & "\""
    else if c = text then
        "'" & e & "'"
    else if (c = integer or c = real) then
        e as text
    else if c = class then
        "null"
    else
        try
            e as text
        on error
            ("«" & c as text) & "»"
        end try
    end if
end show

-- showBinary :: Int -> String
on showBinary(n)
    script binaryChar
        on |λ|(n)
            character id (48 + n)
        end |λ|
    end script
    
    showIntAtBase(2, binaryChar, n, "")
end showBinary

-- ISO 8601 UTC 
-- showDate :: Date -> String
on showDate(dte)
    ((dte - (time to GMT)) as «class isot» as string) & ".000Z"
end showDate

-- showDict :: Dict -> String
on showDict(dct)
  showJSON(dct)
end showDict

-- showForest :: [Tree a] -> String
on showForest(xs)
    unlines(map(my showTree, xs))
end showForest

-- showHex :: Int -> String
on showHex(n)
    showIntAtBase(16, mReturn(intToDigit), n, "")
end showHex

-- showIntAtBase :: Int -> (Int -> Char) -> Int -> String -> String
on showIntAtBase(base, toDigit, n, rs)
    script go
        property f : mReturn(toDigit)
        on |λ|(nd_, r)
            set {n, d} to nd_
            set r_ to f's |λ|(d) & r
            if n > 0 then
                |λ|(quotRem(n, base), r_)
            else
                r_
            end if
        end |λ|
    end script
    |λ|(quotRem(n, base), rs) of go
end showIntAtBase

-- showJSON :: a -> String
on showJSON(x)
    set c to class of x
    if (c is list) or (c is record) then
        set ca to current application
        set json to ca's NSJSONSerialization's dataWithJSONObject:x options:1 |error|:(missing value)
        if json is missing value then
            "Could not serialize as JSON"
        else
            (ca's NSString's alloc()'s initWithData:json encoding:(ca's NSUTF8StringEncoding)) as text
        end if
    else if c is date then
        "\"" & ((x - (time to GMT)) as «class isot» as string) & ".000Z" & "\""
    else if c is text then
        "\"" & x & "\""
    else if (c is integer or c is real) then
        x as text
    else if c is class then
        "null"
    else
        try
            x as text
        on error
            ("«" & c as text) & "»"
        end try
    end if
end showJSON

-- showLR :: Either a b -> String
on showLR(lr)
    if isRight(lr) then
        "Right(" & unQuoted(show(|Right| of lr)) & ")"
    else
        "Left(" & unQuoted(show(|Left| of lr)) & ")"
    end if
end showLR

-- showList :: [a] -> String
on showList(xs)
    "[" & intercalateS(", ", map(my show, xs)) & "]"
end showList

-- showLog :: a -> IO ()
on showLog(e)
    log show(e)
end showLog

-- showMatrix :: [[Maybe a]] -> String
on showMatrix(rows)
    -- String representation of rows
    -- as a matrix.
    
    script showRow
        on |λ|(a, row)
            set {maxWidth, prevRows} to a
            script showCell
                on |λ|(acc, cell)
                    set {w, xs} to acc
                    if missing value is cell then
                        {w, xs & ""}
                    else
                        set s to cell as string
                        {max(w, length of s), xs & s}
                    end if
                end |λ|
            end script
            
            set {rowMax, cells} to foldl(showCell, {0, {}}, row)
            {max(maxWidth, rowMax), prevRows & {cells}}
        end |λ|
    end script
    
    set {w, stringRows} to foldl(showRow, {0, {}}, rows)
    script go
        on |λ|(row)
            unwords(map(justifyRight(w, space), row))
        end |λ|
    end script
    
    unlines(map(go, stringRows))
end showMatrix

-- showMaybe :: Maybe a -> String
on showMaybe(mb)
    if Nothing of mb then
        "Nothing"
    else
        "Just " & unQuoted(show(Just of mb))
    end if
end showMaybe

-- showOrdering :: Ordering -> String
on showOrdering(e)
    set v to value of e
    if v > 0 then
        "GT"
    else if v < 0 then
        "LT"
    else
        "EQ"
    end if
end showOrdering

-- showOutline :: Tree String -> String
on showOutline(x)
    script go
        on |λ|(indent)
            script
                on |λ|(tree)
                    {indent & (root of tree)} & ¬
                        concatMap(go's |λ|(tab & indent), ¬
                            nest of tree)
                end |λ|
            end script
        end |λ|
    end script
    unlines((go's |λ|(""))'s |λ|(x))
end showOutline

-- showPrecision :: Int -> Float -> String
on showPrecision(n, x)
    set d to 10 ^ n
    ((round (x * d)) / d) as string
end showPrecision

-- showRatio :: Ratio -> String
on showRatio(r)
    set s to (n of r as string)
    set d to d of r
    if 1 ≠ d then
        s & "/" & (d as string)
    else
        s
    end if
end showRatio

-- showSet :: Set a -> String
on showSet(s)
    script str
        on |λ|(x)
            x as string
        end |λ|
    end script
    "{" & intercalate(", ", map(str, sort(elems(s)))) & "}"
end showSet

-- showTree :: Tree a -> String
on showTree(tree)
    script str
        on |λ|(x)
            x as string
        end |λ|
    end script
    drawTree2(false, true, fmapTree(str, tree))
end showTree

-- showTuple :: Tuple -> String
on showTuple(tpl)
    set ca to current application
    script
        on |λ|(n)
            set v to (ca's NSDictionary's dictionaryWithDictionary:tpl)'s objectForKey:(n as string)
            if v ≠ missing value then
                unQuoted(show(item 1 of ((ca's NSArray's arrayWithObject:v) as list)))
            else
                missing value
            end if
        end |λ|
    end script
    "(" & intercalateS(", ", map(result, enumFromTo(1, length of tpl))) & ")"
end showTuple

-- showUndefined :: () -> String
on showUndefined()
    "⊥"
end showUndefined

-- signum :: Num -> Num
on signum(x)
    if x < 0 then
        -1
    else if x = 0 then
        0
    else
        1
    end if
end signum

-- Abbreviation for quick testing
-- sj :: a -> String
on sj(x)
    showJSON(x)
end sj

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

-- Mirror image of cons
-- New copy of the list, with an atom added at the end
-- snoc :: [a] -> a -> [a]
on snoc(xs, x)
    xs & {x}
end snoc

-- sort :: Ord a => [a] -> [a]
on sort(xs)
    ((current application's NSArray's arrayWithArray:xs)'s ¬
        sortedArrayUsingSelector:"compare:") as list
end sort

-- sortBy :: (a -> a -> Ordering) -> [a] -> [a]
on sortBy(f, xs)
    -- Enough for small scale sorts.
    -- Use instead sortOn (Ord b => (a -> b) -> [a] -> [a])
    -- which is equivalent to the more flexible sortBy(comparing(f), xs)
    -- and uses a much faster ObjC NSArray sort method
    if length of xs > 1 then
        set h to item 1 of xs
        set f to mReturn(f)
        script
            on |λ|(x)
                f's |λ|(x, h) ≤ 0
            end |λ|
        end script
        set lessMore to partition(result, rest of xs)
        sortBy(f, |1| of lessMore) & {h} & ¬
            sortBy(f, |2| of lessMore)
    else
        xs
    end if
end sortBy

-- sortOn :: Ord b => (a -> b) -> [a] -> [a]
-- sortOn :: Ord b => [((a -> b), Bool)]  -> [a] -> [a]
on sortOn(f, xs)
	-- Sort a list by comparing the results of a key function applied to each
	-- element. sortOn f is equivalent to sortBy(comparing(f), xs), but has the
	-- performance advantage of only evaluating f once for each element in
	-- the input list. This is called the decorate-sort-undecorate paradigm,
	-- or Schwartzian transform.
	-- Elements are arranged from from lowest to highest.
	
	-- In this Applescript implementation, f can optionally be [(a -> b)]
	-- or [((a -> b), Bool)]) to specify a compound sort order
	
	--    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.
	script keyBool
		on |λ|(x, a)
			if boolean is class of x then
				{asc:x, fbs:fbs of a}
			else
				{asc:true, fbs:({Tuple(x, asc of a)} & fbs of a)}
			end if
		end |λ|
	end script
	set {fs, bs} to {|1|, |2|} of unzip(fbs of foldr(keyBool, ¬
		{asc:true, fbs:{}}, 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

-- span :: (a -> Bool) -> [a] -> ([a], [a])
on span(p, xs)
    -- The longest (possibly empty) prefix of xs
    -- that contains only elements satisfying p,
    -- tupled with the remainder of xs.
    -- span(p, xs) eq (takeWhile(p, xs), dropWhile(p, xs)) 
    script go
        property mp : mReturn(p)
        on |λ|(vs)
            if {} ≠ vs then
                set x to item 1 of vs
                if |λ|(x) of mp then
                    set {ys, zs} to |λ|(rest of vs)
                    {{x} & ys, zs}
                else
                    {{}, vs}
                end if
            else
                {{}, {}}
            end if
        end |λ|
    end script
    |λ|(xs) of go
end span

-- splitArrow (***) :: (a -> b) -> (c -> d) -> ((a, c) -> (b, d))
on splitArrow(f, g)
    -- Compose a function (from a tuple to a tuple), 
    -- (with separate transformations for fst and snd)
    script
        on |λ|(xy)
            Tuple(mReturn(f)'s |λ|(|1| of xy), mReturn(g)'s |λ|(|2| of xy))
        end |λ|
    end script
end splitArrow

-- splitAt :: Int -> [a] -> ([a], [a])
on splitAt(n, xs)
    if n > 0 and n < length of xs then
        if class of xs is text then
            {items 1 thru n of xs as text, ¬
                items (n + 1) thru -1 of xs as text}
        else
            {items 1 thru n of xs, items (n + 1) thru -1 of xs}
        end if
    else
        if n < 1 then
            {{}, xs}
        else
            {xs, {}}
        end if
    end if
end splitAt

-- splitBy :: (a -> a -> Bool) -> [a] -> [[a]]
-- splitBy :: (String -> String -> Bool) -> String -> [String]
on splitBy(p, xs)
    if 2 > length of xs then
        {xs}
    else
        script pairMatch
            property mp : mReturn(p)'s |λ|
            on |λ|(a, b)
                {mp(a, b), a, b}
            end |λ|
        end script
        
        script addOrSplit
            on |λ|(a, blnXY)
                set {bln, x, y} to blnXY
                if bln then
                    {item 1 of a & {item 2 of a}, {y}}
                else
                    {item 1 of a, (item 2 of a) & y}
                end if
            end |λ|
        end script
        set {a, r} to foldl(addOrSplit, ¬
            {{}, {item 1 of xs}}, ¬
            zipWith(pairMatch, xs, rest of xs))
        
        if list is class of xs then
            a & {r}
        else
            map(my concat, a & {r})
        end if
    end if
end splitBy

-- splitFileName :: FilePath -> (String, String)
on splitFileName(strPath)
    -- Split a filename into directory and file. combine is the inverse.
    if strPath ≠ "" then
        if last character of strPath ≠ "/" then
            set xs to splitOn("/", strPath)
            set stem to init(xs)
            if stem ≠ {} then
                Tuple(intercalate("/", stem) & "/", |last|(xs))
            else
                Tuple("./", |last|(xs))
            end if
        else
            Tuple(strPath, "")
        end if
    else
        Tuple("./", "")
    end if
end splitFileName

-- splitOn :: [a] -> [a] -> [[a]]
-- splitOn :: String -> String -> [String]
on splitOn(pat, src)
    -- splitOn("\r\n", "a\r\nb\r\nd\r\ne") --> ["a","b","d","e"]
    -- splitOn("aaa", "aaaXaaaXaaaXaaa") --> {"", "X", "X", "X", ""}
    -- splitOn("x", "x") --> {"", ""}
    -- splitOn([3, 1], [1, 2, 3, 1, 2, 3, 1, 2, 3])
    --> {{1, 2}, {2}, {2, 3}}
    if class of src is text then
        set {dlm, my text item delimiters} to ¬
            {my text item delimiters, pat}
        set xs to text items of src
        set my text item delimiters to dlm
        return xs
    else
        set lng to length of pat
        script residue
            on |λ|(a, i)
                Tuple(fst(a) & ¬
                    {init(items snd(a) thru (i) of src)}, lng + i)
            end |λ|
        end script
        set tpl to foldl(residue, ¬
            Tuple({}, 1), findIndices(matching(pat), src))
        return fst(tpl) & {drop(snd(tpl) - 1, src)}
    end if
end splitOn

-- splitRegex :: Regex -> String -> [String]
on splitRegex(strRegex, str)
    set lstMatches to regexMatches(strRegex, str)
    if length of lstMatches > 0 then
        script preceding
            on |λ|(a, x)
                set iFrom to start of a
                set iLocn to (location of x)
                
                if iLocn > iFrom then
                    set strPart to text (iFrom + 1) thru iLocn of str
                else
                    set strPart to ""
                end if
                {parts:parts of a & strPart, start:iLocn + (length of x) - 1}
            end |λ|
        end script
        
        set recLast to foldl(preceding, {parts:[], start:0}, lstMatches)
        
        set iFinal to start of recLast
        if iFinal < length of str then
            parts of recLast & text (iFinal + 1) thru -1 of str
        else
            parts of recLast & ""
        end if
    else
        {str}
    end if
end splitRegex

-- sqrt :: Num -> (missing value | Num)
on sqrt(n)
    if 0 <= n then
        n ^ (1 / 2)
    else
        missing value
    end if
end sqrt

-- sqrtLR :: Num -> Either String Num
on sqrtLR(n)
    if 0 ≤ n then
        |Right|(n ^ (1 / 2))
    else
        |Left|("Square root of negative number: " & n)
    end if
end sqrtLR

-- sqrtMay :: Num -> Maybe Num
on sqrtMay(n)
    if n ≥ 0 then
        Just(n ^ (1 / 2))
    else
        Nothing()
    end if
end sqrtMay

-- str :: a -> String
on str(x)
    x as string
end str

-- strip :: String -> String
on strip(s)
    script isSpace
        on |λ|(c)
            set i to id of c
            32 = i or (9 ≤ i and 13 ≥ i)
        end |λ|
    end script
    dropWhile(isSpace, dropWhileEnd(isSpace, s))
end strip

-- stripEnd :: String -> String
on stripEnd(s)
    dropWhileEnd(my isSpace, s)
end stripEnd

-- stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]
-- stripPrefix :: String -> String -> Maybe String
on stripPrefix(pfx, s)
    set blnString to class of pfx is text
    if blnString then
        set {xs, ys} to {characters of pfx, characters of s}
    else
        set {xs, ys} to {pfx, s}
    end if
    
    script
        on |λ|(xs, ys)
            if length of xs < 1 then
                if blnString then
                    set v to intercalate("", ys)
                else
                    set v to ys
                end if
                Just(v)
            else
                if (length of ys < 1) or (item 1 of xs ≠ item 1 of ys) then
                    Nothing()
                else
                    |λ|(tail(xs), tail(ys))
                end if
            end if
        end |λ|
    end script
    |λ|(xs, ys) of result
end stripPrefix

-- stripStart :: String -> String
on stripStart(s)
    dropWhile(my isSpace, s)
end stripStart

-- subTreeAtPath :: Tree String -> [String] -> Maybe Tree String
on subTreeAtPath(tree, pathSegments)
    script go
        on |λ|(children, xs)
            if {} ≠ children and {} ≠ xs then
                set h to item 1 of xs
                script parentMatch
                    on |λ|(t)
                        h = root of t
                    end |λ|
                end script
                script childMatch
                    on |λ|(t)
                        if 1 < length of xs then
                            |λ|(nest of t, rest of xs) of go
                        else
                            Just(t)
                        end if
                    end |λ|
                end script
                bindMay(find(parentMatch, children), childMatch)
            else
                Nothing()
            end if
        end |λ|
    end script
    |λ|({tree}, pathSegments) of go
end subTreeAtPath

-- subsequences :: [a] -> [[a]]
-- subsequences :: String -> [String]
on subsequences(xs)
    -- subsequences([1,2,3]) -> [[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]]
    -- subsequences("abc") -> ["","a","b","ab","c","ac","bc","abc"]
    script nonEmptySubsequences
        on |λ|(xxs)
            if length of xxs < 1 then
                {}
            else
                set {x, xs} to {item 1 of xxs, tail(xxs)}
        
                script f
                    on |λ|(ys, r)
                        cons(ys, cons(cons(x, ys), r))
                    end |λ|
                end script
                
                cons({x}, foldr(f, {}, |λ|(xs) of nonEmptySubsequences))
            end if
        end |λ|
    end script
    if class of xs is text then
        cons("", map(my concat, |λ|(characters of xs) of nonEmptySubsequences))
    else
        cons([], |λ|(xs) of nonEmptySubsequences)
    end if
end subsequences

-- subsets :: [a] -> [[a]]
on subsets(xs)
    script go
        on |λ|(ys)
            if 0 < length of ys then
                set h to item 1 of ys
                set zs to |λ|(rest of ys)
                script hcons
                    on |λ|(z)
                        {h} & z
                    end |λ|
                end script
                zs & map(hcons, zs)
            else
                {{}}
            end if
        end |λ|
    end script
    go's |λ|(xs)
end subsets

-- subtract :: Num -> Num -> Num
on subtract(x, y)
    y - x
end subtract

-- succ :: Enum a => a -> a
on succ(x)
    if isChar(x) then
        chr(1 + ord(x))
    else
        1 + x
    end if
end succ

-- succMay :: Enum a => a -> Maybe a
on succMay(x)
    if x is maxBound(x) then
        Nothing()
    else
        Just(toEnum(x)'s |λ|(fromEnum(x) + 1))
    end if
end succMay

-- sum :: [Num] -> Num
on sum(xs)
    set ca to current application
    ((ca's NSArray's arrayWithArray:xs)'s ¬
        valueForKeyPath:"@sum.self") as real
end sum

-- swap :: (a, b) -> (b, a)
on swap(ab)
    if class of ab is record then
        Tuple(|2| of ab, |1| of ab)
    else
        {item 2 of ab, item 1 of ab}
    end if
end swap

-- table :: Int -> [String] -> String
on table(n, xs)
    -- A list of strings formatted as
    -- right-justified rows of n columns.
    set w to length of last item of xs
    unlines(map(my unwords, ¬
        chunksOf(n, map(justifyRight(w, space), xs))))
end table

-- tail :: [a] -> [a]
on tail(xs)
    set blnText to text is class of xs
    if blnText then
        set unit to ""
    else
        set unit to {}
    end if
    set lng to length of xs
    if 1 > lng then
        missing value
    else if 2 > lng then
        unit
    else
        if blnText then
            text 2 thru -1 of xs
        else
            rest of xs
        end if
    end if
end tail

-- tailMay :: [a] -> Maybe [a]
on tailMay(xs)
    if xs = {} then
        Nothing()
    else
        Just(rest of xs)
    end if
end tailMay

-- tails :: [a] -> [[a]]
on tails(xs)
    if class of xs is text then
        set es to characters of xs
    else
        set es to xs
    end if
    script residue
        on |λ|(_, i)
            items i thru -1 of es
        end |λ|
    end script
    map(residue, es) & {{}}
end tails

-- take :: Int -> [a] -> [a]
-- take :: Int -> String -> String
on take(n, xs)
    set c to class of xs
    if list is c then
        set lng to length of xs
        if 0 < n and 0 < lng then
            items 1 thru min(n, lng) of xs
        else
            {}
        end if
    else if string is c then
        if 0 < n then
            text 1 thru min(n, length of xs) of xs
        else
            ""
        end if
    else if script is c then
        set ys to {}
        repeat with i from 1 to n
            set v to |λ|() of xs
            if missing value is v then
                return ys
            else
                set end of ys to v
            end if
        end repeat
        return ys
    else
        missing value
    end if
end take

-- takeAround :: (a -> Bool) -> [a] -> [a]
on takeAround(p, xs)
    set ys to takeWhile(p, xs)
    if length of ys < length of xs then
        ys & takeWhileR(p, xs)
    else
        ys
    end if
end takeAround

-- takeBaseName :: FilePath -> String
on takeBaseName(strPath)
    if "" ≠ strPath then
        if "/" = text -1 of strPath then
            ""
        else
            set fn to item -1 of splitOn("/", strPath)
            if fn contains "." then
                intercalate(".", items 1 thru -2 of splitOn(".", fn))
            else
                fn
            end if
        end if
    else
        ""
    end if
end takeBaseName

-- takeCycle :: Int -> [a] -> [a]
on takeCycle(n, xs)
    set lng to length of xs
    if lng ≥ n then
        set cycle to xs
    else
        set cycle to concat(replicate((n div lng) + 1, xs))
    end if
    
    if class of xs is string then
        items 1 thru n of cycle as string
    else
        items 1 thru n of cycle
    end if
end takeCycle

-- takeDirectory :: FilePath -> FilePath
on takeDirectory(fp)
    set strPath to filePath(fp)
    if "" ≠ strPath then
        if "/" = character -1 of strPath then
            text 1 thru -2 of strPath
        else
            set xs to init(splitOn("/", strPath))
            if {} ≠ xs then
                intercalateS("/", xs)
            else
                "."
            end if
        end if
    else
        "."
    end if
end takeDirectory

-- take N Members of an infinite cycle of xs, starting from index I
-- takeDropCycle :: Int -> [a] -> [a]
on takeDropCycle(n, i, xs)
    set lng to length of xs
    set m to n + i
    
    if lng ≥ m then
        set ys to xs
    else
        set ys to concat(replicate(ceiling(m / lng), xs))
    end if
    
    drop(i, take(m, ys))
end takeDropCycle

-- takeExtension :: FilePath -> String
on takeExtension(fp)
    set xs to splitOn(".", fp)
    if 1 < length of xs then
        "." & item -1 of xs
    else
        ""
    end if
end takeExtension

-- takeFileName :: FilePath -> FilePath
on takeFileName(strPath)
    if "" ≠ strPath and "/" ≠ character -1 of strPath then
        item -1 of splitOn("/", strPath)
    else
        ""
    end if
end takeFileName

-- takeFromThenTo :: Int -> Int -> Int -> [a] -> [a]
on takeFromThenTo(a, b, z, xs)
    script go
        on |λ|(i)
            item (1 + i) of xs
        end |λ|
    end script
    map(go, enumFromThenTo(a, b, z))
end takeFromThenTo

-- takeIterate n f x == [x, f x, f (f x), ...]
-- takeIterate :: Int -> (a -> a) -> a -> [a]
on takeIterate(n, f, x)
    set v to x
    set vs to {v}
    tell mReturn(f)
        repeat with i from 1 to n - 1
            set v to |λ|(v)
            set end of vs to v
        end repeat
    end tell
    return vs
end takeIterate

-- takeWhile :: (a -> Bool) -> [a] -> [a]
-- takeWhile :: (Char -> Bool) -> String -> String
on takeWhile(p, xs)
    if script is class of xs then
        takeWhileGen(p, xs)
    else
        tell mReturn(p)
            repeat with i from 1 to length of xs
                if not |λ|(item i of xs) then ¬
                    return take(i - 1, xs)
            end repeat
        end tell
        return xs
    end if
end takeWhile

-- takeWhileGen :: (a -> Bool) -> Gen [a] -> [a]
on takeWhileGen(p, xs)
    set ys to {}
    set v to |λ|() of xs
    tell mReturn(p)
        repeat while (|λ|(v))
            set end of ys to v
            set v to xs's |λ|()
        end repeat
    end tell
    return ys
end takeWhileGen

-- takeWhileR :: (a -> Bool) -> [a] -> [a]
on takeWhileR(p, xs)
    set bln to false
    set blnText to (class of xs) is text
    tell mReturn(p)
        set lng to length of xs
        repeat with i from lng to 1 by -1
            if not |λ|(item i of xs) then
                set bln to true
                exit repeat
            end if
        end repeat
    end tell
    if bln then
        if i > 1 then
            if blnText then
                text (1 + i) thru (-1) of xs
            else
                items (1 + i) thru (-1) of xs
            end if
        else
            if blnText then
                ""
            else
                {}
            end if
        end if
    else
        xs
    end if
end takeWhileR

-- taskPaperDateString :: Date -> String
on taskPaperDateString(dte)
    set {d, t} to splitOn("T", dte as «class isot» as string)
    d & space & text 1 thru 5 of t
end taskPaperDateString

-- tempFilePath :: String -> IO FilePath
on tempFilePath(template)
    (current application's ¬
        NSTemporaryDirectory() as string) & ¬
        takeBaseName(template) & ¬
        text 3 thru -1 of ((random number) as string) & ¬
        takeExtension(template)
end tempFilePath

-- toEnum :: a -> Int -> a
on toEnum(e)
    script
        property c : class of e
        on |λ|(x)
            if integer is c or real is c then
                x as number
            else if text is c then
                character id x
            else if boolean is c then
                if 0 ≠ x then
                    true
                else
                    false
                end if
            end if
        end |λ|
    end script
end toEnum

-- toLower :: String -> String
on toLower(str)
    -- String in lower case. 
    tell current application
        ((its (NSString's stringWithString:(str)))'s ¬
            lowercaseStringWithLocale:(its NSLocale's currentLocale())) as text
    end tell
end toLower

-- toRatio :: Real -> Ratio
on toRatio(n)
    approxRatio(1.0E-12, n)
end toRatio

-- Sentence case - initial string capitalized and rest lowercase
-- toSentence :: String -> String
on toSentence(str)
    set ca to current application
    if length of str > 0 then
        set locale to ca's NSLocale's currentLocale()
        set ws to ca's NSString
        (((ws's stringWithString:(text 1 of str))'s ¬
            uppercaseStringWithLocale:(locale)) as text) & ¬
            ((ws's stringWithString:(text 2 thru -1 of str))'s ¬
                lowercaseStringWithLocale:(locale)) as text
    else
        str
    end if
end toSentence

-- NB this does not model any regional or cultural conventions.
-- It simply simply capitalizes the first character of each word.
-- toTitle :: String -> String
on toTitle(str)
    set ca to current application
    ((ca's NSString's stringWithString:(str))'s ¬
        capitalizedStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toTitle

-- toUpper :: String -> String
on toUpper(str)
    tell current application
        ((its (NSString's stringWithString:(str)))'s ¬
            uppercaseStringWithLocale:(its NSLocale's currentLocale())) as text
    end tell
end toUpper

-- transpose :: [[a]] -> [[a]]
on transpose(xxs)
    -- If some of the rows are shorter than the following rows, 
    -- their elements are skipped:
    -- transpose({{10,11},{20},{},{30,31,32}}) -> {{10, 20, 30}, {11, 31}, {32}}
    set intMax to |length|(maximumBy(comparing(my |length|), xxs))
    set gaps to replicate(intMax, {})
    script padded
        on |λ|(xs)
            set lng to |length|(xs)
            if lng < intMax then
                xs & items (lng + 1) thru -1 of gaps
            else
                xs
            end if
        end |λ|
    end script
    set rows to map(padded, xxs)
    
    script cols
        on |λ|(_, iCol)
            script cell
                on |λ|(row)
                    item iCol of row
                end |λ|
            end script
            concatMap(cell, rows)
        end |λ|
    end script
    map(cols, item 1 of rows)
end transpose

-- Simplified version - assuming rows of unvarying length.
-- transpose_ :: [[a]] -> [[a]]
on transpose_(rows)
	script cols
		on |λ|(_, iCol)
			script cell
				on |λ|(row)
					item iCol of row
				end |λ|
			end script
			concatMap(cell, rows)
		end |λ|
	end script
	map(cols, item 1 of rows)
end transpose_

-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
on traverse(f, tx)
    if class of tx is list then
        traverseList(f, tx)
    else if class of tx is record and keys(tx) contains "type" then
        set t to type of tx
        if "Either" = t then
            traverseLR(f, tx)
        else if "Maybe" = t then
            traverseMay(f, tx)
        else if "Node" = t then
            traverseTree(f, tx)
        else if "Tuple" = t then
            traverseTuple(f, tx)
        else
            missing value
        end if
    else
        missing value
    end if
end traverse

-- traverseLR :: Applicative f => (t -> f b) -> Either a t -> f (Either a b)
on traverseLR(f, lr)
    if |Left| of lr is not missing value then
        {lr}
    else
        fmap(my |Right|, mReturn(f)'s |λ|(|Right| of lr))
    end if
end traverseLR

--    1. Map each element of a structure to an action,
--    2. evaluate these actions from left to right, and
--    3. collect the results.
-- 
--    traverse f = List.foldr cons_f (pure [])
--      where cons_f x ys = liftA2 (:) (f x) ys
-- traverseList :: (Applicative f) => (a -> f b) -> [a] -> f [b]
on traverseList(f, xs)
    set lng to length of xs
    if 0 < lng then
        set mf to mReturn(f)
        
        set vLast to mf's |λ|(item -1 of xs)
        if class of vLast is record and ¬
            keys(vLast) contains "type" then
            set t to type of vLast
        else
            set t to "List"
        end if
        
        script cons_f
            on |λ|(x, ys)
                liftA2(my cons, mf's |λ|(x), ys)
            end |λ|
        end script
        
        foldr(cons_f, ¬
            liftA2(my cons, vLast, pureT(t, [])), ¬
            init(xs))
    else
        {{}}
    end if
end traverseList

-- traverseMay :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)
on traverseMay(f, mb)
    if Nothing of mb then
        {mb}
    else
        fmap(my Just, mReturn(f)'s |λ|(Just of mb))
    end if
end traverseMay

-- traverseTree :: Applicative f => (a -> f b) -> Tree a -> f (Tree b)
on traverseTree(f, tree)
    -- traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts)
    script go
        on |λ|(x)
            liftA2(my Node, ¬
                mReturn(f)'s |λ|(root of x), ¬
                traverseList(go, nest of x))
        end |λ|
    end script
    go's |λ|(tree)
end traverseTree

-- traverseTuple :: Functor f => (t -> f b) -> (a, t) -> f (a, b)
on traverseTuple(f, tpl)
    fmap(curry(my Tuple)'s |λ|(|1| of tpl), ¬
        mReturn(f)'s |λ|(|2| of tpl))
end traverseTuple

-- treeFromDict :: String -> Dict -> Tree String
on treeFromDict(treeTitle, recDict)
    script go
        on |λ|(x)
            set c to class of x
            if list is c then
                script
                    on |λ|(v)
                        Node(v, {})
                    end |λ|
                end script
                map(result, x)
            else if record is c then
                script
                    on |λ|(k)
                        Node(k, go's |λ|(|Just| of lookupDict(k, x)))
                    end |λ|
                end script
                map(result, keys(x))
            else
                {}
            end if
        end |λ|
    end script
    Node(treeTitle, go's |λ|(recDict))
end treeFromDict

-- treeFromNestedList :: NestedList a -> Tree a
on treeFromNestedList(vxs)
    script go
        on |λ|(pair)
            Node(item 1 of pair, map(go, item 2 of pair))
        end |λ|
    end script
    |λ|(vxs) of go
end treeFromPairNest

-- treeLeaves :: Tree -> [Tree]
on treeLeaves(oNode)
    script go
        on |λ|(x)
            set lst to nest of x
            if 0 < length of lst then
                concatMap(my treeLeaves, lst)
            else
                {x}
            end if
        end |λ|
    end script
    |λ|(oNode) of go
end treeLeaves

-- A list of all nodes in the tree which match 
-- a predicate p.
-- For the first match only, see findTree.
-- treeMatches :: (a -> Bool) -> Tree a -> [Tree a]
on treeMatches(p, tree)
    script go
        property pf : mReturn(p)'s |λ|
        on |λ|(x)
            if pf(root of x) then
                {x}
            else
                concatMap(go, nest of x)
            end if
        end |λ|
    end script
    go's |λ|(tree)
end treeMatches

-- treeMenu :: Tree String -> IO [String]
on treeMenu(tree)
    script go
        on |λ|(tree)
            set menuTitle to root of tree
            set subTrees to nest of tree
            set menuItems to map(my root, subTrees)
            set blnNoSubMenus to {} = concatMap(my nest, subTrees)
            
            script menuCancelledOrChoiceMade
                on |λ|(statusAndChoices)
                    (not my fst(statusAndChoices)) or ({} ≠ my snd(statusAndChoices))
                end |λ|
            end script
            
            script choicesOrSubMenu
                on |λ|(choices)
                    set k to item 1 of choices
                    script match
                        on |λ|(x)
                            k = root of x
                        end |λ|
                    end script
                    set chosenSubTree to (Just of find(match, subTrees))
                    if {} ≠ (nest of chosenSubTree) then
                        |Right|(|λ|(chosenSubTree) of go)
                    else
                        |Right|(choices)
                    end if
                end |λ|
            end script
            
            script nothingFromThisMenu
                on |λ|(_)
                    Tuple(false, {})
                end |λ|
            end script
            
            script selectionsFromThisMenu
                on |λ|(xs)
                    Tuple(true, xs)
                end |λ|
            end script
            
            script nextStepInNestedMenu
                on |λ|(statusAndChoice)
                    either(nothingFromThisMenu, selectionsFromThisMenu, ¬
                        bindLR(showMenuLR(blnNoSubMenus, menuTitle, menuItems), ¬
                            choicesOrSubMenu))
                end |λ|
            end script
            
            snd(|until|(menuCancelledOrChoiceMade, ¬
                nextStepInNestedMenu, ¬
                Tuple(true, {}))) -- (Status, Choices) pair
        end |λ|
    end script
    |λ|(tree) of go
end treeMenu

-- truncate :: Num -> Int
on truncate(x)
    item 1 of properFraction(x)
end truncate

-- tupleFromList :: [a] -> (a, a ...)
on tupleFromList(xs)
    set lng to length of xs
    if 1 < lng then
        if 2 < lng then
            set strSuffix to lng as string
        else
            set strSuffix to ""
        end if
        script kv
            on |λ|(a, x, i)
                insertDict((i as string), x, a)
            end |λ|
        end script
        foldl(kv, {type:"Tuple" & strSuffix}, xs) & {length:lng}
    else
        missing value
    end if
end tupleFromList

-- typeName :: a -> String
on typeName(x)
    set mb to lookupDict((class of x) as string, ¬
        {|list|:"List", |integer|:"Int", |real|:"Float", |text|:¬
            "String", |string|:"String", |record|:¬
            "Record", |boolean|:"Bool", |handler|:"(a -> b)", |script|:"(a -> b"})
    if Nothing of mb then
        "Bottom"
    else
        set k to Just of mb
        if k = "Record" then
            if keys(x) contains "type" then
                type of x
            else
                "Dict"
            end if
        else
            k
        end if
    end if
end typeName

-- unDigits :: [Int] -> Int
on unDigits(ds)
    -- The integer with the given digits.
    script go
        on |λ|(a, x)
            10 * a + x
        end |λ|
    end script
    foldl(go, 0, ds)
end unDigits

-- unQuoted :: String -> String
on unQuoted(s)
    script p
        on |λ|(x)
            --{34, 39} contains id of x
            34 = id of x
        end |λ|
    end script
    dropAround(p, s)
end unQuoted

-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    set lng to |length|(xs)
    if 0 = lng then
        Nothing()
    else
        if (2 ^ 29 - 1) as integer > lng then
            if class of xs is string then
                set cs to text items of xs
                Just(Tuple(item 1 of cs, rest of cs))
            else
                Just(Tuple(item 1 of xs, rest of xs))
            end if
        else
            set nxt to take(1, xs)
            if {} is nxt then
                Nothing()
            else
                Just(Tuple(item 1 of nxt, xs))
            end if
        end if
    end if
end uncons

-- Given a curried/default function, returns an
-- equivalent function on a tuple or list pair.
-- A function over a pair, derived from
-- a function over two arguments.
-- uncurry :: (a -> b -> c) -> ((a, b) -> c)
on uncurry(f)
    if 1 < argvLength(f) then
        script
            on |λ|(ab)
                if class of ab is list then
                    mReturn(f)'s |λ|(item 1 of ab, item 2 of ab)
                else
                    mReturn(f)'s |λ|(|1| of ab, |2| of ab)
                end if
            end |λ|
        end script
    else
        script
            on |λ|(ab)
                if class of ab is list then
                    f's |λ|(item 1 of ab)'s |λ|(item 2 of ab)
                else
                    f's |λ|(|1| of ab)'s |λ|(|2| of ab)
                end if
            end |λ|
        end script
    end if
end uncurry


-- unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree]
on unfoldForest(f, xs)
    -- | Build a forest from a list of seed values
    set g to mReturn(f)
    script
        on |λ|(x)
            unfoldTree(g, x)
        end |λ|
    end script
    map(result, xs)
end unfoldForest

-- | Build a tree from a seed value
-- unfoldTree :: (b -> (a, [b])) -> b -> Tree a
on unfoldTree(f, b)
    set g to mReturn(f)
    set tpl to g's |λ|(b)
    Node(|1| of tpl, unfoldForest(g, |2| of tpl))
end unfoldTree

-- unfoldl :: (b -> Maybe (b, a)) -> b -> [a]
on unfoldl(f, v)
    -- > unfoldl (\b -> if b == 0 then Nothing else Just (b, b-1)) 10
    -- > [1,2,3,4,5,6,7,8,9,10]
    set xr to Tuple(v, v) -- (value, remainder)
    set xs to {}
    tell mReturn(f)
        repeat -- Function applied to remainder.
            set mb to |λ|(|2| of xr)
            if Nothing of mb then
                exit repeat
            else -- New (value, remainder) tuple,
                set xr to Just of mb
                -- and value appended to output list.
                set xs to ({|1| of xr} & xs)
            end if
        end repeat
    end tell
    return xs
end unfoldl

-- unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
on unfoldr(f, v)
    -- A lazy (generator) list unfolded from a seed value
    -- by repeated application of f to a value until no
    -- residue remains. Dual to fold/reduce.
    -- f returns either nothing (missing value) 
    -- or just (value, residue).
    script
        property valueResidue : {v, v}
        property g : mReturn(f)
        on |λ|()
            set valueResidue to g's |λ|(item 2 of (valueResidue))
            if missing value ≠ valueResidue then
                item 1 of (valueResidue)
            else
                missing value
            end if
        end |λ|
    end script
end unfoldr

-- union :: [a] -> [a] -> [a]
on union(xs, ys)
    script flipDelete
        on |λ|(xs, x)
            my |delete|(x, xs)
        end |λ|
    end script
    
    set sx to nub(xs)
    sx & foldl(flipDelete, nub(ys), sx)
end union

-- unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
on unionBy(fnEq, xs, ys)
    script flipDeleteByEq
        on |λ|(xs, x)
            deleteBy(fnEq, x, xs)
        end |λ|
    end script
    xs & foldl(flipDeleteByEq, nubBy(fnEq, ys), xs)
end unionBy

-- unionSet :: Ord a => Set a -> Set a -> Set a
on unionSet(s, s1)
    set sUnion to current application's NSMutableSet's alloc's init()
    sUnion's setSet:(s)
    sUnion's unionSet:(s1)
    return sUnion
end unionSet

-- unlines :: [String] -> String
on unlines(xs)
    -- A single string formed by the intercalation
    -- of a list of strings with the newline character.
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, linefeed}
    set s to xs as text
    set my text item delimiters to dlm
    s
end unlines

-- If the list is empty returns Nothing, otherwise returns 
-- Just the init and the last.
-- unsnoc :: [a] -> Maybe ([a], a)
on unsnoc(xs)
    set blnString to class of xs is string
    set lng to length of xs
    if lng = 0 then
        Nothing()
    else
        set h to item -1 of xs
        if lng > 1 then
            if blnString then
                Just(Tuple(text 1 thru -2 of xs, h))
            else
                Just(Tuple(items 1 thru -2 of xs, h))
            end if
        else
            if blnString then
                Just(Tuple("", h))
            else
                Just(Tuple({}, h))
            end if
        end if
    end if
end unsnoc

-- until :: (a -> Bool) -> (a -> a) -> a -> a
on |until|(p, f, x)
	set v to x
	set mp to mReturn(p)
	set mf to mReturn(f)
	repeat until mp's |λ|(v)
		set v to mf's |λ|(v)
	end repeat
	v
end |until|

-- unwords :: [String] -> String
on unwords(xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, space}
    set s to xs as text
    set my text item delimiters to dlm
    return s
end unwords

-- unwrap :: NSValue -> a
on unwrap(nsValue)
    if nsValue is missing value then
        missing value
    else
        set ca to current application
        item 1 of ((ca's NSArray's arrayWithObject:nsValue) as list)
    end if
end unwrap

-- unzip :: [(a,b)] -> ([a],[b])
on unzip(xys)
    set xs to {}
    set ys to {}
    repeat with xy in xys
        set end of xs to |1| of xy
        set end of ys to |2| of xy
    end repeat
    return Tuple(xs, ys)
end unzip

-- unzip3 :: [(a,b,c)] -> ([a],[b],[c])
on unzip3(xyzs)
    set xs to {}
    set ys to {}
    set zs to {}
    repeat with xyz in xyzs
        set end of xs to |1| of xyz
        set end of ys to |2| of xyz
        set end of zs to |3| of xyz
    end repeat
    return TupleN({xs, ys, zs})
end unzip3

-- unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
on unzip4(wxyzs)
    set ws to {}
    set xs to {}
    set ys to {}
    set zs to {}
    repeat with wxyz in wxyzs
        set end of ws to |1| of wxyz
        set end of xs to |2| of wxyz
        set end of ys to |3| of wxyz
        set end of zs to |4| of wxyz
    end repeat
    return TupleN({ws, xs, ys, zs})
end unzip4

-- unzipN :: [(a,b,...)] -> ([a],[b],...)
on unzipN(tpls)
    if 0 < length of tpls then
        set xs to replicate(length of item 1 of tpls, {})
        script go
            on |λ|(a, tpl)
                script inner
                    on |λ|(x, i)
                        x & Just of lookupDict(i as string, tpl)
                    end |λ|
                end script
                map(inner, a)
            end |λ|
        end script
        foldl(go, xs, tpls)
    else
        missing value
    end if
end unzipN

-- variance :: [Num] -> Num
on variance(xs)
    set m to mean(xs)
    script
        on |λ|(a, x)
            a + (x - m) ^ 2
        end |λ|
    end script
    foldl(result, 0, xs) / ((length of xs) - 1)
end variance

-- words :: String -> [String]
on |words|(s)
    set ca to current application
    (((ca's NSString's stringWithString:(s))'s ¬
        componentsSeparatedByCharactersInSet:(ca's ¬
            NSCharacterSet's whitespaceAndNewlineCharacterSet()))'s ¬
        filteredArrayUsingPredicate:(ca's ¬
            NSPredicate's predicateWithFormat:"0 < length")) as list
end |words|

-- wrap :: a -> NSObject
on wrap(v)
    set ca to current application
    ca's (NSArray's arrayWithObject:v)'s objectAtIndex:0
end wrap

-- use framework "Foundation"
-- writeFile :: FilePath -> String -> IO ()
on writeFile(strPath, strText)
    set ca to current application
    (ca's NSString's stringWithString:strText)'s ¬
        writeToFile:(stringByStandardizingPath of ¬
            (ca's NSString's stringWithString:strPath)) atomically:true ¬
            encoding:(ca's NSUTF8StringEncoding) |error|:(missing value)
end writeFile

-- writeFileLR :: FilePath -> Either String IO FilePath
on writeFileLR(strPath, strText)
    set ca to current application
    set fp to stringByStandardizingPath of ¬
        (ca's NSString's stringWithString:strPath)
    set {bln, e} to (ca's NSString's stringWithString:strText)'s ¬
        writeToFile:(fp) atomically:true ¬
            encoding:(ca's NSUTF8StringEncoding) |error|:(reference)
    if bln and (missing value is e) then
        |Right|(fp as string)
    else
        |Left|(e's localizedDescription() as string)
    end if
end writeFileLR

use framework "Foundation"
-- File name template -> string data -> temporary path
-- (Random digit sequence inserted between template base and extension)
-- writeTempFile :: String -> String -> IO FilePath
on writeTempFile(template, txt)
    set strPath to (current application's ¬
        NSTemporaryDirectory() as string) & ¬
        takeBaseName(template) & ¬
        text 3 thru -1 of ((random number) as string) & ¬
        takeExtension(template)
    -- Effect
    writeFile(strPath, txt)
    -- Value
    strPath
end writeTempFile

-- zip :: [a] -> [b] -> [(a, b)]
on zip(xs, ys)
    set n to min(length of xs, length of ys)
    
    set lst to {}
    repeat with i from 1 to n
        set end of lst to {item i of xs, item i of ys}
    end repeat
    return lst
end zip

-- zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]
on zip3(xs, ys, zs)
    script
        on |λ|(x, i)
            TupleN({x, item i of ys, item i of zs})
        end |λ|
    end script
    map(result, items 1 thru ¬
        minimum({length of xs, length of ys, length of zs}) of xs)
end zip3

-- zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
on zip4(ws, xs, ys, zs)
    script
        on |λ|(w, i)
            TupleN({w, item i of xs, item i of ys, item i of zs})
        end |λ|
    end script
    map(result, items 1 thru ¬
        minimum({length of xs, length of ys, length of zs}) of xs)
end zip4

-- zipGen :: Gen [a] -> Gen [b] -> Gen [(a, b)]
on zipGen(ga, gb)
    script
        property ma : missing value
        property mb : missing value
        on |λ|()
            if missing value is ma then
                set ma to uncons(ga)
                set mb to uncons(gb)
            end if
            if Nothing of ma or Nothing of mb then
                missing value
            else
                set ta to Just of ma
                set tb to Just of mb
                set x to Tuple(|1| of ta, |1| of tb)
                set ma to uncons(|2| of ta)
                set mb to uncons(|2| of tb)
                return x
            end if
        end |λ|
    end script
end zipGen

-- zipList :: [a] -> [b] -> [(a, b)]
on zipList(xs, ys)
    set lng to min(length of xs, length of ys)
    script go
        on |λ|(x, i)
            {x, item i of ys}
        end |λ|
    end script
    map(go, items 1 thru lng of xs)
end zipList

-- Arbitrary number of lists to zip
-- all enclosed in an argument vector list
-- zipN :: [a] -> [b] -> ... -> [(a, b ...)]
on zipN(argv)
    if 1 < length of argv then
        script go
            on |λ|(x, i)
                script peers
                    on |λ|(y)
                        item i of y
                    end |λ|
                end script
                tupleFromList(map(peers, argv))
            end |λ|
        end script
        map(go, take(minimum(map(my |length|, argv)), ¬
            item 1 of argv))
    else
        argv
    end if
end zipN

-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWith(f, xs, ys)
    set lng to min(|length|(xs), |length|(ys))
    if 1 > lng then return {}
    set xs_ to take(lng, xs) -- Allow for non-finite
    set ys_ to take(lng, ys) -- generators like cycle etc
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs_, item i of ys_)
        end repeat
        return lst
    end tell
end zipWith

-- zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
on zipWith3(f, xs, ys, zs)
    set lng to minimum({length of xs, length of ys, length of zs})
    if 1 > lng then return {}
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, item i of ys, item i of zs)
        end repeat
        return lst
    end tell
end zipWith3

-- zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
on zipWith4(f, ws, xs, ys, zs)
    set lng to minimum({length of ws, length of xs, length of ys, length of zs})
    if 1 > lng then return {}
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of ws, item i of xs, item i of ys, item i of zs)
        end repeat
        return lst
    end tell
end zipWith4

-- zipWithGen :: (a -> b -> c) -> Gen [a] -> Gen [b] -> Gen [c]
on zipWithGen(f, ga, gb)
    script
        property ma : missing value
        property mb : missing value
        property mf : mReturn(f)
        on |λ|()
            if missing value is ma then
                set ma to uncons(ga)
                set mb to uncons(gb)
            end if
            if Nothing of ma or Nothing of mb then
                missing value
            else
                set ta to Just of ma
                set tb to Just of mb
                set ma to uncons(|2| of ta)
                set mb to uncons(|2| of tb)
                |λ|(|1| of ta, |1| of tb) of mf
            end if
        end |λ|
    end script
end zipWithGen

-- zipWithList :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWithList(f, xs, ys)
    set lng to min(length of xs, length of ys)
    set lst to {}
    if 1 > lng then
        return {}
    else
        tell mReturn(f)
            repeat with i from 1 to lng
                set end of lst to |λ|(item i of xs, item i of ys)
            end repeat
            return lst
        end tell
    end if
end zipWithList

-- zipWithM :: Applicative m => (a -> b -> m c) -> [a] -> [b] -> m [c]
on zipWithM(fm, xs, ys)
    -- A functor of the type to which fm lifts its result.
    -- For example, Nothing/Left if any of the zip applications failed,
    -- or Just/Right a list of the results, when all succeeded.
    traverseList(my identity, zipWith(fm, xs, ys))
end zipWithM

-- zipWithN :: (a -> b -> ... -> c) -> ([a], [b] ...) -> [c]
on zipWithN(f, rows)
    -- f applied to each tuple formed by the
    -- zipping together of each list in rows
    script go
        property mf : mReturn(f)
        on |λ|(i)
            script nth
                on |λ|(row)
                    item i of row
                end |λ|
            end script
            mf's |λ|(map(nth, rows))
        end |λ|
    end script
    map(go, enumFromTo(1, minimum(map(my |length|, rows))))
end zipWithN