-
Notifications
You must be signed in to change notification settings - Fork 0
/
asPreludeMenu.json
508 lines (508 loc) · 189 KB
/
asPreludeMenu.json
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
{
"Just": "-- Just :: a -> Maybe a\non Just(x)\n -- Constructor for an inhabited Maybe (option type) value.\n -- Wrapper containing the result of a computation.\n {type:\"Maybe\", Nothing:false, Just:x}\nend Just",
"Left": "-- Left :: a -> Either a b\non |Left|(x)\n {type:\"Either\", |Left|:x, |Right|:missing value}\nend |Left|",
"Node": "-- Node :: a -> [Tree a] -> Tree a\non Node(v, xs)\n {type:\"Node\", root:v, nest:xs}\nend Node",
"Nothing": "-- Nothing :: Maybe a\non Nothing()\n -- Constructor for an empty Maybe (option type) value.\n -- Empty wrapper returned where a computation is not possible.\n {type: \"Maybe\", Nothing: true}\nend Nothing",
"Right": "-- Right :: b -> Either a b\non |Right|(x)\n {type:\"Either\", |Left|:missing value, |Right|:x}\nend |Right|",
"Tuple": "-- Tuple (,) :: a -> b -> (a, b)\non Tuple(a, b)\n -- Constructor for a pair of values, possibly of two different types.\n {type:\"Tuple\", |1|:a, |2|:b, length:2}\nend Tuple",
"Tuple3": "-- Tuple3 (,,) :: a -> b -> c -> (a, b, c)\non Tuple3(x, y, z)\n {type:\"Tuple3\", |1|:x, |2|:y, |3|:z, length:3}\nend Tuple3",
"TupleN": "-- Requires N arguments to be wrapped as one list in AS \n-- (the JS version accepts N separate arguments)\n-- TupleN :: a -> b ... -> (a, b ... )\non TupleN(argv)\n tupleFromList(argv)\nend TupleN",
"abs": "-- abs :: Num -> Num\non abs(x)\n -- Absolute value.\n if 0 > x then\n -x\n else\n x\n end if\nend abs",
"add": "-- add (+) :: Num a => a -> a -> a\non add(a)\n -- Curried addition.\n script\n on |λ|(b)\n a + b\n end |λ|\n end script\nend add",
"all": "-- all :: (a -> Bool) -> [a] -> Bool\non all(p, xs)\n -- True if p holds for every value in xs\n tell mReturn(p)\n set lng to length of xs\n repeat with i from 1 to lng\n if not |λ|(item i of xs, i, xs) then return false\n end repeat\n true\n end tell\nend all",
"allSame": "-- allSame :: [a] -> Bool\non allSame(xs)\n if 2 > length of xs then\n true\n else\n script p\n property h : item 1 of xs\n on |λ|(x)\n h = x\n end |λ|\n end script\n all(p, rest of xs)\n end if\nend allSame",
"allTree": "-- allTree :: (a -> Bool) -> Tree a -> Bool\non allTree(p, tree)\n -- True if p holds for the value of every node in tree\n script go\n property mp : mReturn(p)'s |λ|\n on |λ|(oNode)\n if mp(root of oNode) then\n repeat with v in nest of oNode\n if not (contents of |λ|(v)) then return false\n end repeat\n true\n else\n false\n end if\n end |λ|\n end script\n |λ|(tree) of go\nend allTree",
"and": "-- and :: [Bool] -> Bool\non |and|(xs)\n -- True if every value in the list is true.\n repeat with x in xs\n if not (contents of x) then return false\n end repeat\n return true\nend |and|",
"any": "-- any :: (a -> Bool) -> [a] -> Bool\non any(p, xs)\n -- Applied to a predicate and a list, \n -- |any| returns true if at least one element of the \n -- list satisfies the predicate.\n tell mReturn(p)\n set lng to length of xs\n repeat with i from 1 to lng\n if |λ|(item i of xs) then return true\n end repeat\n false\n end tell\nend any",
"anyTree": "-- anyTree :: (a -> Bool) -> Tree a -> Bool\non anyTree(p, tree)\n -- True if p holds for the value of any node in the tree.\n script go\n property mp : mReturn(p)'s |λ|\n on |λ|(oNode)\n if mp(root of oNode) then\n true\n else\n repeat with v in nest of oNode\n if contents of |λ|(v) then return true\n end repeat\n false\n end if\n end |λ|\n end script\n |λ|(tree) of go\nend anyTree",
"ap (<*>)": "-- ap (<*>) :: Monad m => m (a -> b) -> m a -> m b\non ap(mf, mx)\n -- Applies wrapped functions to wrapped values, \n -- for example applying a list of functions to a list of values\n -- or applying Just(f) to Just(x), Right(f) to Right(x), etc\n if class of mx is list then\n apList(mf, mx)\n else\n set t to typeName(mf)\n if \"(a -> b)\" = t then\n apFn(mf, mx)\n else if \"Either\" = t then\n apLR(mf, mx)\n else if \"Maybe\" = t then\n apMay(mf, mx)\n else if \"Node\" = t then\n apTree(mf, mx)\n else if \"Tuple\" = t then\n apTuple(mf, mx)\n else\n missing value\n end if\n end if\nend ap",
"apFn (<*>)": "-- apFn :: (a -> b -> c) -> (a -> b) -> (a -> c)\non apFn(f, g)\n script go\n property mf : |λ| of mReturn(f)\n property mg : |λ| of mReturn(g)\n on |λ|(x)\n mf(x, mg(x))\n end |λ|\n end script\nend apFn",
"apLR (<*>)": "-- apLR (<*>) :: Either e (a -> b) -> Either e a -> Either e b\non apLR(flr, lr)\n if missing value is |Left| of flr then\n if missing value is |Left| of lr then\n |Right|(|λ|(|Right| of lr) of mReturn(|Right| of flr))\n else\n lr\n end if\n else\n flr\n end if\nend apLR",
"apList (<*>)": "-- apList (<*>) :: [(a -> b)] -> [a] -> [b]\non apList(fs, xs)\n -- e.g. [(*2),(/2), sqrt] <*> [1,2,3]\n -- --> ap([dbl, hlf, root], [1, 2, 3])\n -- --> [2,4,6,0.5,1,1.5,1,1.4142135623730951,1.7320508075688772]\n -- Each member of a list of functions applied to\n -- each of a list of arguments, deriving a list of new values\n set lst to {}\n repeat with f in fs\n tell mReturn(contents of f)\n repeat with x in xs\n set end of lst to |λ|(contents of x)\n end repeat\n end tell\n end repeat\n return lst\nend apList",
"apMay (<*>)": "-- apMay (<*>) :: Maybe (a -> b) -> Maybe a -> Maybe b\non apMay(mf, mx)\n -- Maybe f applied to Maybe x, deriving a Maybe y\n if Nothing of mf or Nothing of mx then\n Nothing()\n else\n Just(|λ|(Just of mx) of mReturn(Just of mf))\n end if\nend apMay",
"apTree (<*>)": "-- apTree (<*>) :: Tree (a -> b) -> Tree a -> Tree b\non apTree(tf, tx)\n set fmap to curry(my fmapTree)\n script go\n on |λ|(t)\n set f to root of t\n Node(mReturn(f)'s |λ|(root of tx), ¬\n map(fmap's |λ|(f), nest of tx) & ¬\n map(go, nest of t))\n end |λ|\n end script\n \n return go's |λ|(tf)\nend apTree",
"apTuple (<*>)": "-- apTuple (<*>) :: Monoid m => (m, (a -> b)) -> (m, a) -> (m, b)\non apTuple(tf, tx)\n Tuple(mappend(|1| of tf, |1| of tx), |λ|(|2| of tx) of mReturn(|2| of tf))\nend apTuple",
"append (<>)": "-- append (<>) :: [a] -> [a] -> [a]\n-- append (<>) :: String -> String -> String\non append(xs, ys)\n -- Append two lists.\n xs & ys\nend append",
"appendFile": "-- appendFile :: FilePath -> String -> IO Bool\non appendFile(strPath, txt)\n -- Write a string to the end of a file. \n -- Returns true if the path exists \n -- and the write succeeded. \n -- Otherwise returns false.\n set ca to current application\n set oFullPath to (ca's NSString's stringWithString:strPath)'s ¬\n stringByStandardizingPath\n set {blnExists, intFolder} to (ca's NSFileManager's defaultManager()'s ¬\n fileExistsAtPath:oFullPath isDirectory:(reference))\n \n if blnExists then\n if 0 = intFolder then\n set oData to (ca's NSString's stringWithString:txt)'s ¬\n dataUsingEncoding:(ca's NSUTF8StringEncoding)\n set h to ca's NSFileHandle's fileHandleForWritingAtPath:oFullPath\n h's seekToEndOfFile\n h's writeData:oData\n h's closeFile()\n true\n else\n -- text appended to folder is undefined\n false\n end if\n else\n if doesDirectoryExist(takeDirectory(oFullPath as string)) then\n writeFile(oFullPath, txt)\n true\n else\n false\n end if\n end if\nend appendFile",
"appendFileMay": "-- appendFileMay :: FilePath -> String -> Maybe IO FilePath\non appendFileMay(strPath, txt)\n -- Write a string to the end of a file. \n -- Returns a Just FilePath value if the \n -- path exists and the write succeeded. \n -- Otherwise returns Nothing.\n set ca to current application\n set oFullPath to (ca's NSString's stringWithString:strPath)'s ¬\n stringByStandardizingPath\n set strFullPath to oFullPath as string\n set {blnExists, intFolder} to (ca's NSFileManager's defaultManager()'s ¬\n fileExistsAtPath:oFullPath isDirectory:(reference))\n if blnExists then\n if 0 = intFolder then -- Not a directory\n set oData to (ca's NSString's stringWithString:txt)'s ¬\n dataUsingEncoding:(ca's NSUTF8StringEncoding)\n set h to ca's NSFileHandle's fileHandleForWritingAtPath:oFullPath\n h's seekToEndOfFile\n h's writeData:oData\n h's closeFile()\n Just(strFullPath)\n else\n Nothing()\n end if\n else\n if doesDirectoryExist(takeDirectory(strFullPath)) then\n writeFile(oFullPath, txt)\n Just(strFullPath)\n else\n Nothing()\n end if\n end if\nend appendFileMay",
"appendGen": "-- appendGen (++) :: Gen [a] -> Gen [a] -> Gen [a]\non appendGen(xs, ys)\n script\n property vs : xs\n on |λ|()\n set v to |λ|() of vs\n if missing value is not v then\n v\n else\n set vs to ys\n |λ|() of ys\n end if\n end |λ|\n end script\nend appendGen",
"apply ($)": "-- apply ($) :: (a -> b) -> a -> b\non apply(f, x)\n mReturn(f)'s |λ|(x)\nend apply",
"applyN": "-- applyN :: Int -> (a -> a) -> a -> a\non applyN(n, f, x)\n script go\n on |λ|(a, g)\n |λ|(a) of mReturn(g)\n end |λ|\n end script\n foldl(go, x, replicate(n, f))\nend applyN",
"approxRatio": "-- approxRatio :: Float -> Float -> Ratio\non approxRatio(epsilon, n)\n if {real, integer} contains (class of epsilon) and 0 < epsilon then\n set e to epsilon\n else\n set e to 1 / 10000\n end if\n \n script gcde\n on |λ|(e, x, y)\n script _gcd\n on |λ|(a, b)\n if b < e then\n a\n else\n |λ|(b, a mod b)\n end if\n end |λ|\n end script\n |λ|(abs(x), abs(y)) of _gcd\n end |λ|\n end script\n \n set c to |λ|(e, 1, n) of gcde\n Ratio((n div c), (1 div c))\nend approxRatio",
"argvLength": "-- argvLength :: Function -> Int\non argvLength(h)\n try\n mReturn(h)'s |λ|()\n 0\n on error errMsg\n set {dlm, my text item delimiters} to {my text item delimiters, \",\"}\n set xs to text items of errMsg\n set my text item delimiters to dlm\n length of xs\n end try\nend argvLength",
"assocs": "-- assocs :: Map k a -> [(k, a)]\non assocs(m)\n script go\n on |λ|(k)\n set mb to lookupDict(k, m)\n if true = |Nothing| of mb then\n {}\n else\n {{k, |Just| of mb}}\n end if\n end |λ|\n end script\n concatMap(go, keys(m))\nend assocs",
"base64decode": "-- base64decode :: String -> String\non base64decode(s)\n tell current application\n set encoding to its NSUTF8StringEncoding\n set ignore to its NSDataBase64DecodingIgnoreUnknownCharacters\n \n (((alloc() of its NSString)'s initWithData:((its (NSData's alloc()'s ¬\n initWithBase64EncodedString:s ¬\n options:(ignore)))) encoding:encoding)) as text\n end tell\nend base64decode",
"base64encode": "-- base64encode :: String -> String\non base64encode(s)\n tell current application\n set encodingOption to its NSUTF8StringEncoding\n base64EncodedStringWithOptions_(0) of ¬\n dataUsingEncoding_(encodingOption) of ¬\n (stringWithString_(s) of its NSString) as string\n end tell\nend base64encode",
"bimap": "-- bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)\non bimap(f, g)\n -- Tuple instance of bimap.\n -- A tuple of the application of f and g to the\n -- first and second values of tpl respectively.\n script\n on |λ|(x)\n {|λ|(fst(x)) of mReturn(f), ¬\n |λ|(snd(x)) of mReturn(g)}\n end |λ|\n end script\nend bimap",
"bimapLR": "-- bimapLR :: (a -> b) -> (c -> d) -> ֵEither ֵֵa c -> Either b d\non bimapLR(f, g)\n script go\n on |λ|(e)\n if missing value is |Left| of e then\n tell mReturn(g) to |Right|(|λ|(|Right| of e))\n else\n tell mReturn(f) to |Left|(|λ|(|Left| of e))\n end if\n end |λ|\n end script\nend bimapLR",
"bimapN": "-- bimapN :: (a -> b) -> (c -> d) -> TupleN -> TupleN\non bimapN(f, g, tplN)\n set z to length of tplN\n set k1 to (z - 1) as string\n set k2 to z as string\n \n insertDict(k2, mReturn(g)'s |λ|(Just of lookupDict(k2, tplN)), ¬\n insertDict(k1, mReturn(f)'s |λ|(Just of lookupDict(k1, tplN)), tplN))\nend bimapN",
"bind (>>=)": "-- bind (>>=) :: Monad m => m a -> (a -> m b) -> m b\non bind(m, mf)\n set c to class of m\n if list = c then\n bindList(m, mf)\n else if record = c then\n set ks to keys(m)\n if ks contains \"type\" then\n set t to type of m\n if \"Maybe\" = t then\n bindMay(m, mf)\n else if \"Either\" = t then\n bindLR(m, mf)\n else if \"Tuple\" = t then\n bindTuple(m, mf)\n else\n missing value\n end if\n else\n missing value\n end if\n else if handler is c or script is c then\n bindFn(m, mf)\n else\n missing value\n end if\nend bind",
"bindFn (>>=)": "-- bindFn (>>=) :: (a -> b) -> (b -> a -> c) -> a -> c\non bindFn(f, bop)\n -- Where either bop or f is a binary operator.\n script\n property mf : mReturn(f)\n property mop : mReturn(bop)\n on |λ|(x)\n try\n curry(mop)'s |λ|(mf's |λ|(x))'s |λ|(x)\n on error\n mop's |λ|(curry(mf)'s |λ|(x))'s |λ|(x)\n end try\n end |λ|\n end script\nend bindFn",
"bindLR (>>=)": "-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b\non bindLR(m, mf)\n if missing value is not |Left| of m then\n m\n else\n mReturn(mf)'s |λ|(|Right| of m)\n end if\nend bindLR",
"bindList (>>=)": "-- bindList (>>=) :: [a] -> (a -> [b]) -> [b]\non bindList(xs, f)\n set acc to {}\n tell mReturn(f)\n repeat with x in xs\n set acc to acc & |λ|(contents of x)\n end repeat\n end tell\n return acc\nend bindList",
"bindMay (>>=)": "-- bindMay (>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b\non bindMay(mb, mf)\n -- bindMay provides the mechanism for composing a\n -- sequence of (a -> Maybe b) functions.\n -- If m is Nothing, it is passed straight through.\n -- If m is Just(x), the result is an application\n -- of the (a -> Maybe b) function (mf) to x.\n if Nothing of mb then\n mb\n else\n tell mReturn(mf) to |λ|(Just of mb)\n end if\nend bindMay",
"bindTuple (>>=)": "-- bindTuple (>>=) :: Monoid a => (a, a) -> (a -> (a, b)) -> (a, b)\non bindTuple(tpl, f)\n set t2 to mReturn(f)'s |λ|(|2| of tpl)\n Tuple(mappend(|1| of tpl, |1| of t2), |2| of t2)\nend bindTuple",
"bool": "-- bool :: a -> a -> Bool -> a\non bool(ff, tf)\n -- The evaluation of either tf or ff, \n -- depending on a boolean value.\n script\n on |λ|(bln)\n if bln then\n set e to tf\n else\n set e to ff\n end if\n set c to class of e\n if {script, handler} contains c then\n |λ|() of mReturn(e)\n else\n e\n end if\n end |λ|\n end script\nend bool",
"break": "-- break :: (a -> Bool) -> [a] -> ([a], [a])\non break(p, xs)\n set bln to false\n tell mReturn(p)\n set lng to length of xs\n repeat with i from 1 to lng\n if |λ|(item i of xs) then\n set bln to true\n exit repeat\n end if\n end repeat\n end tell\n if bln then\n if 1 < i then\n {items 1 thru (i - 1) of xs, items i thru -1 of xs}\n else\n {{}, xs}\n end if\n else\n {xs, {}}\n end if\nend break",
"breakOn": "-- breakOn :: String -> String -> (String, String)\non breakOn(pat, src)\n -- non null needle -> haystack -> (prefix before match, match + rest)\n if pat ≠ \"\" then\n set {dlm, my text item delimiters} to {my text item delimiters, pat}\n \n set lstParts to text items of src\n set lngParts to length of lstParts\n \n if 1 < lngParts then\n set tpl to {item 1 of lstParts, pat & ¬\n ((items 2 thru -1 of lstParts) as text)}\n else\n set tpl to Tuple(src, \"\")\n end if\n \n set my text item delimiters to dlm\n return tpl\n else\n missing value\n end if\nend breakOn",
"breakOnAll": "-- breakOnAll :: String -> String -> [(String, String)]\non breakOnAll(pat, src)\n -- breakOnAll \"/\" \"a/b/c/\"\n -- ==> [(\"a\", \"/b/c/\"), (\"a/b\", \"/c/\"), (\"a/b/c\", \"/\")]\n if \"\" ≠ pat then\n script\n on |λ|(a, _, i, xs)\n if 1 < i then\n a & {{intercalate(pat, take(i - 1, xs)), ¬\n pat & intercalate(pat, drop(i - 1, xs))}}\n else\n a\n end if\n end |λ|\n end script\n foldl(result, {}, splitOn(pat, src))\n else\n missing value\n end if\nend breakOnAll",
"breakOnMay": "-- breakOnMay :: String -> String -> Maybe (String, String)\non breakOnMay(pat, src)\n -- needle -> haystack -> maybe (prefix before match, match + rest)\n if pat ≠ \"\" then\n set {dlm, my text item delimiters} to {my text item delimiters, pat}\n \n set lstParts to text items of src\n if length of lstParts > 1 then\n set mbTuple to Just({item 1 of lstParts, pat & ¬\n ((items 2 thru -1 of lstParts) as text)})\n else\n set mbTuple to Just({src, \"\"})\n end if\n \n set my text item delimiters to dlm\n return mbTuple\n else\n Nothing()\n end if\nend breakOnMay",
"bulleted": "-- bulleted :: String -> String -> String\non bulleted(strIndent, s)\n script go\n on |λ|(x)\n if \"\" ≠ x then\n strIndent & \"- \" & x\n else\n x\n end if\n end |λ|\n end script\n unlines(map(go, paragraphs of s))\nend bulleted",
"cartesianProduct": "-- cartesianProduct :: [a] -> [b] -> [[a, b]]\non cartesianProduct(xs, ys)\n script\n on |λ|(x)\n script\n on |λ|(y)\n {x, y}\n end |λ|\n end script\n concatMap(result, ys)\n end |λ|\n end script\n concatMap(result, xs)\nend cartesianProduct",
"caseOf": "-- caseOf :: [(a -> Bool, b)] -> b -> a -> b\non caseOf (pvs, otherwise, x)\n -- List of (Predicate, value) tuples -> Default value -> Value to test -> Output value\n repeat with tpl in pvs\n if mReturn(|1| of tpl)'s |λ|(x) then return |2| of tpl\n end repeat\n return otherwise\nend caseOf",
"catMaybes": "-- catMaybes :: [Maybe a] -> [a]\non catMaybes(mbs)\n script emptyOrListed\n on |λ|(m)\n if Nothing of m then\n {}\n else\n {Just of m}\n end if\n end |λ|\n end script\n concatMap(emptyOrListed, mbs)\nend catMaybes",
"ceiling": "-- ceiling :: Num -> Int\non ceiling(x)\n set nr to properFraction(x)\n set n to |1| of nr\n if 0 < (|2| of nr) then\n n + 1\n else\n n\n end if\nend ceiling",
"center": "-- center :: Int -> Char -> String -> String\non |center|(n, cFiller, strText)\n set lngFill to n - (length of strText)\n if lngFill > 0 then\n set strPad to replicate(lngFill div 2, cFiller) as text\n set strCenter to strPad & strText & strPad\n if lngFill mod 2 > 0 then\n cFiller & strCenter\n else\n strCenter\n end if\n else\n strText\n end if\nend |center|",
"chars": "-- chars :: String -> [Char]\non chars(s)\n characters of s\nend chars",
"chop": "-- chop :: ([a] -> (b, [a])) -> [a] -> [b]\non chop(f, xs)\n script go\n property g : mReturn(f)\n on |λ|(xs)\n if 0 < length of xs then\n set {b, ys} to g's |λ|(xs)\n {b} & |λ|(ys)\n else\n {}\n end if\n end |λ|\n end script\n go's |λ|(xs)\nend chop",
"chr": "-- chr :: Int -> Char\non chr(n)\n character id n\nend chr",
"chunksOf": "-- chunksOf :: Int -> [a] -> [[a]]\non chunksOf(k, xs)\n script\n on go(ys)\n set ab to splitAt(k, ys)\n set a to item 1 of ab\n if {} ≠ a then\n {a} & go(item 2 of ab)\n else\n a\n end if\n end go\n end script\n result's go(xs)\nend chunksOf",
"combine": "-- combine (</>) :: FilePath -> FilePath -> FilePath\non combine(fp, fp1)\n -- The concatenation of two filePath segments,\n -- without omission or duplication of \"/\".\n if \"\" = fp or \"\" = fp1 then\n fp & fp1\n else if \"/\" = item 1 of fp1 then\n fp1\n else if \"/\" = item -1 of fp then\n fp & fp1\n else\n fp & \"/\" & fp1\n end if\nend combine",
"compare": "-- compare :: a -> a -> Ordering\non compare(a, b)\n if a < b then\n -1\n else if a > b then\n 1\n else\n 0\n end if\nend compare",
"comparing": "-- comparing :: (a -> b) -> (a -> a -> Ordering)\non comparing(f)\n script\n on |λ|(a, b)\n tell mReturn(f)\n set fa to |λ|(a)\n set fb to |λ|(b)\n if fa < fb then\n -1\n else if fa > fb then\n 1\n else\n 0\n end if\n end tell\n end |λ|\n end script\nend comparing",
"compose (<<<)": "-- compose (<<<) :: (b -> c) -> (a -> b) -> a -> c\non compose(f, g)\n script\n property mf : mReturn(f)\n property mg : mReturn(g)\n on |λ|(x)\n mf's |λ|(mg's |λ|(x))\n end |λ|\n end script\nend compose",
"composeList": "-- composeList :: [(a -> a)] -> (a -> a)\non composeList(fs)\n script\n on |λ|(x)\n script go\n on |λ|(f, a)\n mReturn(f)'s |λ|(a)\n end |λ|\n end script\n foldr(go, x, fs)\n end |λ|\n end script\nend composeList",
"composeListR": "-- composeListR :: [(a -> a)] -> (a -> a)\non composeListR(fs)\n script\n on |λ|(x)\n script go\n on |λ|(a, f)\n mReturn(f)'s |λ|(a)\n end |λ|\n end script\n \n foldl(go, x, fs)\n end |λ|\n end script\nend composeListLR",
"composeR (>>>)": "-- composeR (>>>) :: (a -> b) -> (b -> c) -> a -> c\non composeR(f, g)\n script\n on |λ|(x)\n |λ|(|λ|(x) of mReturn(f)) of mReturn(g)\n end |λ|\n end script\nend composeR",
"concat": "-- concat :: [[a]] -> [a]\non concat(xs)\n ((current application's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@unionOfArrays.self\") as list\nend concat",
"concatMap": "-- concatMap :: (a -> [b]) -> [a] -> [b]\ron concatMap(f, xs)\r set lng to length of xs\r set acc to {}\r \r tell mReturn(f)\r repeat with i from 1 to lng\r set acc to acc & (|λ|(item i of xs, i, xs))\r end repeat\r end tell\r acc\rend concatMap",
"cons": "-- cons :: a -> [a] -> [a]\non cons(x, xs)\n set c to class of xs\n if list is c then\n {x} & xs\n else if script is c then\n script\n property pRead : false\n on |λ|()\n if pRead then\n |λ|() of xs\n else\n set pRead to true\n return x\n end if\n end |λ|\n end script\n else\n x & xs\n end if\nend cons",
"constant": "-- constant :: a -> b -> a\non |constant|(k)\n script\n on |λ|(_)\n k\n end |λ|\n end script\nend |constant|",
"createDirectoryIfMissingLR": "-- createDirectoryIfMissingLR :: Bool -> FilePath -> Either String FilePath\non createDirectoryIfMissingLR(blnParents, fp)\n if doesPathExist(fp) then\n |Right|(fp)\n else\n set e to reference\n set ca to current application\n set oPath to (ca's NSString's stringWithString:(fp))'s ¬\n stringByStandardizingPath\n set {blnOK, e} to ca's NSFileManager's ¬\n defaultManager's createDirectoryAtPath:(oPath) ¬\n withIntermediateDirectories:(blnParents) ¬\n attributes:(missing value) |error|:(e)\n if blnOK then\n |Right|(fp)\n else\n |Left|((localizedDescription of e) as string)\n end if\n end if\nend createDirectoryIfMissingLR",
"curry": "-- curry :: ((a, b) -> c) -> a -> b -> c\non curry(f)\n script\n on |λ|(a)\n script\n on |λ|(b)\n |λ|(a, b) of mReturn(f)\n end |λ|\n end script\n end |λ|\n end script\nend curry",
"cycle": "-- cycle :: [a] -> Generator [a]\non cycle(xs)\n script\n property lng : 1 + (length of xs)\n property i : missing value\n on |λ|()\n if missing value is i then\n set i to 1\n else\n set nxt to (1 + i) mod lng\n if 0 = ((1 + i) mod lng) then\n set i to 1\n else\n set i to nxt\n end if\n end if\n return item i of xs\n end |λ|\n end script\nend cycle",
"decodedPath": "-- decodedPath :: Percent Encoded String -> FilePath\non decodedPath(fp)\n -- use framework \"Foundation\"\n tell current application to ¬\n (stringByRemovingPercentEncoding ¬\n of stringWithString_(fp) ¬\n of its NSString) as string\nend decodedPath",
"degrees": "-- degrees :: Float x => Radians x -> Degrees x\non degrees(r)\n (180 / pi) * r\nend degrees",
"delete": "-- delete :: Eq a => a -> [a] -> [a]\non |delete|(x, xs)\n set mbIndex to elemIndex(x, xs)\n set lng to length of xs\n \n if Nothing of mbIndex then\n xs\n else\n if 1 < lng then\n set i to Just of mbIndex\n if 1 = i then\n items 2 thru -1 of xs\n else if lng = i then\n items 1 thru -2 of xs\n else\n tell xs to items 1 thru (i - 1) & items (i + 1) thru -1\n end if\n else\n {}\n end if\n end if\nend |delete|",
"deleteAt": "-- deleteAt :: Int -> [a] -> [a]\non deleteAt(i, xs)\n set lr to splitAt(i, xs)\n set {l, r} to {|1| of lr, |2| of lr}\n if 1 < length of r then\n l & items 2 thru -1 of r\n else\n l\n end if\nend deleteAt",
"deleteBy": "-- deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]\non deleteBy(fnEq, x, xs)\n script go\n property eq : mReturn(fnEq)'s |λ|\n on |λ|(xs)\n if 0 < length of xs then\n tell xs to set {h, t} to {item 1, rest}\n if eq(x, h) then\n t\n else\n {h} & |λ|(t)\n end if\n else\n {}\n end if\n end |λ|\n end script\n go's |λ|(xs)\nend deleteBy",
"deleteFirst": "-- deleteFirst :: a -> [a] -> [a]\non deleteFirst(x, xs)\n script go\n on |λ|(xs)\n if 0 < length of xs then\n tell xs to set {h, t} to {item 1, rest}\n if x = h then\n t\n else\n {h} & |λ|(t)\n end if\n else\n {}\n end if\n end |λ|\n end script\n go's |λ|(xs)\nend deleteFirst",
"deleteFirstsBy": "-- deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]\non deleteFirstsBy(fnEq, xs, ys)\n script\n on |λ|(x, y)\n deleteBy(fnEq, y, x)\n end |λ|\n end script\n foldl(result, xs, ys)\nend deleteFirstsBy",
"deleteKey": "-- deleteKey :: String -> Dict -> Dict\non deleteKey(k, rec)\n tell current application to set nsDct to ¬\n dictionaryWithDictionary_(rec) of its NSMutableDictionary\n removeObjectForKey_(k) of nsDct\n nsDct as record\nend deleteKey",
"dictFromList": "-- dictFromList :: [(k, v)] -> Dict\non dictFromList(kvs)\n set tpl to unzip(kvs)\n script go\n on |λ|(x)\n x as string\n end |λ|\n end script\n tell current application\n (its (NSDictionary's dictionaryWithObjects:(my snd(tpl)) ¬\n forKeys:(my map(go, my fst(tpl))))) as record\n end tell\nend dictFromList",
"difference": "-- difference :: Eq a => [a] -> [a] -> [a]\non difference(xs, ys)\n script p\n on |λ|(x)\n x is not in ys\n end |λ|\n end script\n filter(p, xs)\nend difference",
"differenceGen": "-- differenceGen :: Gen [a] -> Gen [a] -> Gen [a]\non differenceGen(ga, gb)\n -- All values of ga except any\n -- already seen in gb.\n script\n property g : zipGen(ga, gb)\n property bs : {}\n property xy : missing value\n on |λ|()\n set xy to g's |λ|()\n if missing value is xy then\n xy\n else\n set x to |1| of xy\n set y to |2| of xy\n set bs to {y} & bs\n if bs contains x then\n |λ|() -- Next in series.\n else\n x\n end if\n end if\n end |λ|\n end script\nend differenceGen",
"digitToInt": "-- digitToInt :: Char -> Int\non digitToInt(c)\n set oc to id of c\n if 48 > oc or 102 < oc then\n missing value\n else\n set dec to oc - (id of \"0\")\n set hexu to oc - (id of \"A\")\n set hexl to oc - (id of \"a\")\n if 9 ≥ dec then\n dec\n else if 0 ≤ hexu and 5 ≥ hexu then\n 10 + hexu\n else if 0 ≤ hexl and 5 ≥ hexl then\n 10 + hexl\n else\n missing value\n end if\n end if\nend digitToInt",
"div": "-- div :: Int -> Int -> Int\non |div|(a, b)\n set v to (a / b)\n set i to round (v)\n if 0 < (i - v) then\n i - 1\n else\n i\n end if\nend |div|",
"divMod": "-- divMod :: Int -> Int -> (Int, Int)\non divMod(n, d)\n -- Integer division, truncated toward negative infinity,\n -- and integer modulus such that:\n -- (x `div` y)*y + (x `mod` y) == x\n set {q, r} to {n div d, n mod d}\n if signum(r) = signum(-d) then\n {q - 1, r + d}\n else\n {q, r}\n end if\nend divMod",
"doesDirectoryExist": "-- doesDirectoryExist :: FilePath -> IO Bool\ron doesDirectoryExist(strPath)\r set ca to current application\r set oPath to (ca's NSString's stringWithString:strPath)'s ¬\r stringByStandardizingPath\r set {bln, v} to (ca's NSFileManager's defaultManager's ¬\r fileExistsAtPath:oPath isDirectory:(reference))\r bln and v\rend doesDirectoryExist",
"doesFileExist": "-- doesFileExist :: FilePath -> IO Bool\non doesFileExist(strPath)\n set ca to current application\n set oPath to (ca's NSString's stringWithString:strPath)'s ¬\n stringByStandardizingPath\n set {bln, int} to (ca's NSFileManager's defaultManager's ¬\n fileExistsAtPath:oPath isDirectory:(reference))\n bln and (1 ≠ int)\nend doesFileExist",
"doesPathExist": "-- doesPathExist :: FilePath -> IO Bool\non doesPathExist(strPath)\n set ca to current application\n ca's NSFileManager's defaultManager's ¬\n fileExistsAtPath:((ca's NSString's ¬\n stringWithString:strPath)'s ¬\n stringByStandardizingPath)\nend doesPathExist",
"draw": "-- draw :: Tree String -> [String]\non draw(tree)\n \n -- shift :: String -> String -> [String] -> [String]\n script shift\n on |λ|(strFirst, strOther, xs)\n zipWith(my append, ¬\n cons(strFirst, replicate((length of xs) - 1, strOther)), xs)\n end |λ|\n end script\n \n -- drawSubTrees :: [Tree String] -> [String]\n script drawSubTrees\n on |λ|(xs)\n set lng to length of xs\n if 0 < lng then\n if 1 < lng then\n cons(\"│\", append(shift's |λ|(\"├─ \", \"│ \", draw(item 1 of xs)), ¬\n |λ|(items 2 thru -1 of xs)))\n else\n cons(\"│\", shift's |λ|(\"└─ \", \" \", draw(item 1 of xs)))\n end if\n else\n {}\n end if\n end |λ|\n end script\n \n paragraphs of (root of tree) & |λ|(nest of tree) of drawSubTrees\nend draw",
"drawForest": "-- drawForest :: [Tree String] -> String\non drawForest(trees)\n intercalate(\"\\n\\n\", map(my drawTree, trees))\nend drawForest",
"drawTree": "-- drawTree :: Tree String -> String\non drawTree(tree)\n unlines(draw(tree))\nend drawTree",
"drawTree2": "-- drawTree2 :: Bool -> Bool -> Tree String -> String\non drawTree2(blnCompressed, blnPruned, tree)\n -- Tree design and algorithm inspired by the Haskell snippet at:\n -- https://doisinkidney.com/snippets/drawing-trees.html\n script measured\n on |λ|(t)\n script go\n on |λ|(x)\n set s to \" \" & x & \" \"\n Tuple(length of s, s)\n end |λ|\n end script\n fmapTree(go, t)\n end |λ|\n end script\n set measuredTree to |λ|(tree) of measured\n \n script levelMax\n on |λ|(a, level)\n a & maximum(map(my fst, level))\n end |λ|\n end script\n set levelWidths to foldl(levelMax, {}, ¬\n init(levels(measuredTree)))\n \n -- Lefts, Mid, Rights\n script lmrFromStrings\n on |λ|(xs)\n set {ls, rs} to items 2 thru -2 of ¬\n (splitAt((length of xs) div 2, xs) as list)\n Tuple3(ls, item 1 of rs, rest of rs)\n end |λ|\n end script\n \n script stringsFromLMR\n on |λ|(lmr)\n script add\n on |λ|(a, x)\n a & x\n end |λ|\n end script\n foldl(add, {}, items 2 thru -2 of (lmr as list))\n end |λ|\n end script\n \n script fghOverLMR\n on |λ|(f, g, h)\n script\n property mg : mReturn(g)\n on |λ|(lmr)\n set {ls, m, rs} to items 2 thru -2 of (lmr as list)\n Tuple3(map(f, ls), |λ|(m) of mg, map(h, rs))\n end |λ|\n end script\n end |λ|\n end script\n \n script treeFix\n on cFix(x)\n script\n on |λ|(xs)\n x & xs\n end |λ|\n end script\n end cFix\n \n on |λ|(l, m, r)\n compose(stringsFromLMR, ¬\n |λ|(cFix(l), cFix(m), cFix(r)) of ¬\n fghOverLMR)\n end |λ|\n end script\n\n script lmrBuild\n on leftPad(n)\n script\n on |λ|(s)\n replicateString(n, space) & s\n end |λ|\n end script\n end leftPad\n \n -- lmrBuild main\n on |λ|(w, f)\n script\n property mf : mReturn(f)\n on |λ|(wsTree)\n set xs to nest of wsTree\n set lng to length of xs\n set {nChars, x} to items 2 thru -2 of ¬\n ((root of wsTree) as list)\n set _x to replicateString(w - nChars, \"─\") & x\n \n script linked\n on |λ|(s)\n set c to text 1 of s\n set t to tail(s)\n if \"┌\" = c then\n _x & \"┬\" & t\n else if \"│\" = c then\n _x & \"┤\" & t\n else if \"├\" = c then\n _x & \"┼\" & t\n else\n _x & \"┴\" & t\n end if\n end |λ|\n end script\n \n -- LEAF NODE --------------------------------------\n if 0 = lng then\n Tuple3({}, _x, {})\n \n else if 1 = lng then\n -- NODE WITH SINGLE CHILD ---------------------\n set indented to leftPad(1 + w)\n script lineLinked\n on |λ|(z)\n _x & \"─\" & z\n end |λ|\n end script\n |λ|(|λ|(item 1 of xs) of mf) of ¬\n (|λ|(indented, lineLinked, indented) of ¬\n fghOverLMR)\n else\n -- NODE WITH CHILDREN -------------------------\n set indented to leftPad(w)\n set lmrs to map(f, xs)\n if blnCompressed then\n set sep to {}\n else\n set sep to {\"│\"}\n end if\n \n tell lmrFromStrings\n set tupleLMR to |λ|(intercalate(sep, ¬\n {|λ|(item 1 of lmrs) of ¬\n (|λ|(\" \", \"┌\", \"│\") of treeFix)} & ¬\n map(|λ|(\"│\", \"├\", \"│\") of treeFix, ¬\n init(tail(lmrs))) & ¬\n {|λ|(item -1 of lmrs) of ¬\n (|λ|(\"│\", \"└\", \" \") of treeFix)}))\n end tell\n \n |λ|(tupleLMR) of ¬\n (|λ|(indented, linked, indented) of fghOverLMR)\n end if\n end |λ|\n end script\n end |λ|\n end script\n \n set treeLines to |λ|(|λ|(measuredTree) of ¬\n foldr(lmrBuild, 0, levelWidths)) of stringsFromLMR\n if blnPruned then\n script notEmpty\n on |λ|(s)\n script isData\n on |λ|(c)\n \"│ \" does not contain c\n end |λ|\n end script\n any(isData, characters of s)\n end |λ|\n end script\n set xs to filter(notEmpty, treeLines)\n else\n set xs to treeLines\n end if\n unlines(xs)\nend drawTree2",
"drop": "-- drop :: Int -> [a] -> [a]\n-- drop :: Int -> String -> String\non drop(n, xs)\n set c to class of xs\n if script is not c then\n if string is not c then\n if n < length of xs then\n items (1 + n) thru -1 of xs\n else\n {}\n end if\n else\n if n < length of xs then\n text (1 + n) thru -1 of xs\n else\n \"\"\n end if\n end if\n else\n take(n, xs) -- consumed\n return xs\n end if\nend drop",
"dropAround": "-- dropAround :: (a -> Bool) -> [a] -> [a]\n-- dropAround :: (Char -> Bool) -> String -> String\non dropAround(p, xs)\n dropWhile(p, dropWhileEnd(p, xs))\nend dropAround",
"dropFileName": "-- dropFileName :: FilePath -> FilePath\non dropFileName(strPath)\n if strPath ≠ \"\" then\n if character -1 of strPath = \"/\" then\n strPath\n else\n set xs to init(splitOn(\"/\", strPath))\n if xs ≠ {} then\n intercalate(\"/\", xs) & \"/\"\n else\n \"./\"\n end if\n end if\n else\n \"./\"\n end if\nend dropFileName",
"dropLength": "-- dropLength :: [a] -> [b] -> [b]\non dropLength(xs, ys)\n script go\n on |λ|(x, y)\n if 0 < length of x then\n if 0 < length of y then\n |λ|(tail(x), tail(y))\n else\n {}\n end if\n else\n y\n end if\n end |λ|\n end script\n go's |λ|(xs, ys)\nend dropLength",
"dropLengthMaybe": "-- dropLengthMaybe :: [a] -> [b] -> Maybe [b]\non dropLengthMaybe(xs, ys)\n script go\n on |λ|(x, y)\n if 0 < length of x then\n if 0 < length of y then\n |λ|(tail(x), tail(y))\n else\n Nothing()\n end if\n else\n Just(y)\n end if\n end |λ|\n end script\n go's |λ|(xs, ys)\nend dropLengthMaybe",
"dropWhile": "-- dropWhile :: (a -> Bool) -> [a] -> [a]\n-- dropWhile :: (Char -> Bool) -> String -> String\non dropWhile(p, xs)\n set lng to length of xs\n set i to 1\n tell mReturn(p)\n repeat while i ≤ lng and |λ|(item i of xs)\n set i to i + 1\n end repeat\n end tell\n if {} ≠ xs then\n items i thru -1 of xs\n else\n xs\n end if\nend dropWhile",
"dropWhileEnd": "-- dropWhileEnd :: (a -> Bool) -> [a] -> [a]\n-- dropWhileEnd :: (Char -> Bool) -> String -> String\non dropWhileEnd(p, xs)\n set i to length of xs\n tell mReturn(p)\n repeat while i > 0 and |λ|(item i of xs)\n set i to i - 1\n end repeat\n end tell\n take(i, xs)\nend dropWhileEnd",
"dropWhileGen": "-- dropWhileGen :: (a -> Bool) -> Gen [a] -> [a]\non dropWhileGen(p, xs)\n set v to |λ|() of xs\n tell mReturn(p)\n repeat while (|λ|(v))\n set v to xs's |λ|()\n end repeat\n end tell\n return cons(v, xs)\nend dropWhileGen",
"either": "-- either :: (a -> c) -> (b -> c) -> Either a b -> c\non either(lf, rf, e)\n if missing value is |Left| of e then\n tell mReturn(rf) to |λ|(|Right| of e)\n else\n tell mReturn(lf) to |λ|(|Left| of e)\n end if\nend either",
"elem": "-- elem :: Eq a => a -> [a] -> Bool\non elem(x, xs)\n considering case\n xs contains x\n end considering\nend elem",
"elemAtMay": "-- elemAtMay :: Int -> Dict -> Maybe (String, a)\n-- elemAtMay :: Int -> [a] -> Maybe a\non elemAtMay(i, x)\n -- If x is a Dictionary then reads the Int as an index\n -- into the lexically sorted keys of the Dict, \n -- returning a Maybe (Key, Value) pair.\n -- If x is a list, then return a Maybe a \n -- (In either case, returns Nothing for an Int out of range)\n set bln to class of x is record\n if bln then\n set ks to keys(x)\n if i ≤ |length|(ks) then\n set k to item i of sort(ks)\n script pair\n on |λ|(v)\n Just(Tuple(k, v))\n end |λ|\n end script\n bindMay(lookup(k, x), pair)\n end if\n else\n if i ≤ |length|(x) then\n Just(item i of x)\n else\n Nothing()\n end if\n end if\nend elemAtMay",
"elemIndex": "-- elemIndex :: Eq a => a -> [a] -> Maybe Int\ron elemIndex(x, xs)\r -- Just the zero-based index of x in xs,\r -- or Nothing if x is not found in xs.\r\tset lng to length of xs\r\trepeat with i from 1 to lng\r\t\tif x = (item i of xs) then return Just(i - 1)\r\tend repeat\r\treturn Nothing()\rend elemIndex",
"elemIndices": "-- elemIndices :: Eq a => a -> [a] -> [Int]\non elemIndices(x, xs)\n script\n on |λ|(y, i)\n if y = x then\n {i}\n else\n {}\n end if\n end |λ|\n end script\n concatMap(result, xs)\nend elemIndices",
"elems": "-- elems :: Map k a -> [a]\n-- elems :: Set a -> [a]\non elems(x)\n if record is class of x then -- Dict\n tell current application to allValues() ¬\n of dictionaryWithDictionary_(x) ¬\n of its NSDictionary as list\n else -- Set\n (allObjects() of x) as list\n end if\nend elems",
"encodedPath": "-- encodedPath :: FilePath -> Percent Encoded String\non encodedPath(fp)\n tell current application\n set charSet to URLPathAllowedCharacterSet of its NSCharacterSet\n (stringByAddingPercentEncodingWithAllowedCharacters_(charSet) of ¬\n stringWithString_(fp) of its NSString) as string\n end tell\nend encodedPath",
"enumFrom": "-- enumFrom :: Enum a => a -> [a]\non enumFrom(x)\n script\n property v : missing value\n property blnNum : class of x is not text\n on |λ|()\n if missing value is not v then\n if blnNum then\n set v to 1 + v\n else\n set v to succ(v)\n end if\n else\n set v to x\n end if\n return v\n end |λ|\n end script\nend enumFrom",
"enumFromPairs": "-- enumFromPairs :: String -> [(String, Int)] -> Dict\non enumFromPairs(strName, kvs)\n set iMax to item 1 of item -1 of kvs\n set iMin to item 1 of item 1 of kvs\n script go\n on |λ|(a, kv)\n set {k, v} to kv\n insertMap(insertMap(a, k, ¬\n {type:\"enum\", |name|:¬\n strName, |key|:k, min:iMin, max:iMax, value:v}), v, k)\n end |λ|\n end script\n foldl(go, {|name|:strName, min:iMin, max:iMax}, kvs)\nend enumFromPairs",
"enumFromThen": "-- enumFromThen :: Int -> Int -> Gen [Int]\non enumFromThen(m, n)\n -- A non-finite stream of integers,\n -- starting with m and n, and continuing\n -- with the same interval.\n script\n property d : n - m\n property v : m\n on |λ|()\n set x to v\n set v to d + v\n return x\n end |λ|\n end script\nend enumFromThen",
"enumFromThenTo": "-- enumFromThenTo :: Int -> Int -> Int -> [Int]\non enumFromThenTo(x1, x2, y)\n set xs to {}\n set gap to x2 - x1\n set d to max(1, abs(gap)) * (signum(gap))\n repeat with i from x1 to y by d\n set end of xs to i\n end repeat\n return xs\nend enumFromThenTo",
"enumFromThenToChar": "-- enumFromThenToChar :: Char -> Char -> Char -> [Char]\non enumFromThenToChar(x1, x2, y)\n set {int1, int2, intY} to {id of x1, id of x2, id of y}\n set xs to {}\n repeat with i from int1 to intY by (int2 - int1)\n set end of xs to character id i\n end repeat\n return xs\nend enumFromThenToChar",
"enumFromTo": "-- enumFromTo :: Int -> Int -> [Int]\ron enumFromTo(m, n)\r if m ≤ n then\r set xs to {}\r repeat with i from m to n\r set end of xs to i\r end repeat\r xs\r else\r {}\r end if\rend enumFromTo",
"enumFromToChar": "-- enumFromToChar :: Char -> Char -> [Char]\non enumFromToChar(m, n)\n set {intM, intN} to {id of m, id of n}\n if intM ≤ intN then\n set xs to {}\n repeat with i from intM to intN\n set end of xs to character id i\n end repeat\n return xs\n else\n {}\n end if\nend enumFromToChar",
"enumFromTo_": "-- enumFromTo_ :: Enum a => a -> a -> [a]\non enumFromTo_(m, n)\n if m ≤ n then\n set x to fromEnum(m)\n set y to fromEnum(n)\n set xs to {}\n repeat with i from x to y\n set end of xs to i\n end repeat\n map(toEnum(m), xs)\n else\n return {}\n end if\nend enumFromTo",
"eq (==)": "-- eq (==) :: Eq a => a -> a -> Bool\non eq(a, b)\n a = b\nend eq",
"eqDate": "-- eqDate :: Date -> Date -> Bool\non eqDate(dte, dte1)\n -- True if the date parts of two date-time objects\n -- (ignoring the time parts) are the same.\n tell dte\n its year = year of dte1 ¬\n and its month = month of dte1 ¬\n and its day = day of dte1\n end tell\nend eqDate",
"evalJSLR": "-- evalJSLR :: String -> Either String a\non evalJSLR(strJS)\n -- gJSC can be declared in the global namespace,\n -- but unless the reference is released before the \n -- end of the script (e.g. `set gJSC to null`)\n -- it will persist, and\n -- Script Editor will be unable to save a .scpt file\n set gJSC to current application's JSContext's new()\n set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())\n if v is missing value then\n |Left|(\"JS evaluation error\")\n else\n |Right|(v)\n end if\nend evalJSLR",
"evalJSMay": "-- evalJSMay :: String -> Maybe a\non evalJSMay(strJS)\n -- use framework \"Foundation\"\n -- use framework \"JavaScriptCore\"\n -- gJSC can be declared in the global namespace,\n -- but unless the reference is released before the \n -- end of the script (e.g. `set gJSC to null`)\n -- it will persist, and\n -- Script Editor will be unable to save a .scpt file\n try -- NB if gJSC is global it must be released \n -- (e.g. set to null) at end of script\n gJSC's evaluateScript\n on error\n set gJSC to current application's JSContext's new()\n log (\"new JSC\")\n end try\n set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())\n if v is missing value then\n Nothing()\n else\n Just(v)\n end if\nend evalJSMay",
"even": "-- even :: Int -> Bool\non even(x)\n 0 = x mod 2\nend even",
"exp": "-- exp :: Float -> Float\non exp(n)\n Just of evalJSMay((\"Math.exp(\" & n as string) & \")\")\nend exp",
"fTable": "-- fTable :: String -> (a -> String) -> (b -> String) -> (a -> b) -> [a] -> String\non fTable(s, xShow, fxShow, f, xs)\n set ys to map(xShow, xs)\n set w to maximum(map(my |length|, ys))\n script arrowed\n on |λ|(a, b)\n justifyRight(w, space, a) & \" -> \" & b\n end |λ|\n end script\n s & linefeed & unlines(zipWith(arrowed, ¬\n ys, map(compose(fxShow, f), xs)))\nend fTable",
"fanArrow (&&&)": "-- fanArrow (&&&) :: (a -> b) -> (a -> c) -> (a -> (b, c))\non fanArrow(f, g)\n -- Compose a function from a simple value to a tuple of\n -- the separate outputs of two different functions\n script\n on |λ|(x)\n Tuple(mReturn(f)'s |λ|(x), mReturn(g)'s |λ|(x))\n end |λ|\n end script\nend fanArrow",
"filePath": "-- filePath :: String -> FilePath\non filePath(s)\n ((current application's ¬\n NSString's stringWithString:s)'s ¬\n stringByStandardizingPath()) as string\nend filePath",
"filePathTree": "-- filePathTree :: filePath -> [Tree String] -> Tree FilePath\non filePathTree(fpAnchor, trees)\n script go\n on |λ|(fp)\n script\n on |λ|(tree)\n set strPath to fp & \"/\" & (root of tree)\n \n Node(strPath, map(go's |λ|(strPath), nest of tree))\n end |λ|\n end script\n end |λ|\n end script\n \n Node(fpAnchor, map(go's |λ|(fpAnchor), trees))\nend filePathTree",
"fileSize": "-- fileSize :: FilePath -> Either String Int\non fileSize(fp)\n script fs\n on |λ|(rec)\n |Right|(NSFileSize of rec)\n end |λ|\n end script\n\n bindLR(my fileStatus(fp), fs)\nend fileSize",
"fileStatus": "-- fileStatus :: FilePath -> Either String Dict\non fileStatus(fp)\n set e to reference\n set {v, e} to current application's NSFileManager's defaultManager's ¬\n attributesOfItemAtPath:fp |error|:e\n\n if v is not missing value then\n |Right|(v as record)\n else\n |Left|((localizedDescription of e) as string)\n end if\nend fileStatus",
"fileUTI": "-- fileUTI :: FilePath -> Either String String\non fileUTI(fp)\n set {uti, e} to (current application's ¬\n NSWorkspace's sharedWorkspace()'s ¬\n typeOfFile:fp |error|:(reference)) as list\n \n if uti is missing value then\n |Left|(e's localizedDescription() as text)\n else\n |Right|(uti as text)\n end if\nend fileUTI",
"filter": "-- filter :: (a -> Bool) -> [a] -> [a]\ron filter(p, xs)\r tell mReturn(p)\r set n to length of xs\r set ys to {}\r \r repeat with i from 1 to n\r set v to item i of xs\r if |λ|(v, i, xs) then set end of ys to v\r end repeat\r ys\r end tell\rend filter",
"filterGen": "-- filterGen :: (a -> Bool) -> Gen [a] -> Gen [a]\non filterGen(p, gen)\n -- Non-finite stream of values which are \n -- drawn from gen, and satisfy p\n script\n property mp : mReturn(p)'s |λ|\n on |λ|()\n set v to gen's |λ|()\n repeat until mp(v)\n set v to gen's |λ|()\n end repeat\n return v\n end |λ|\n end script\nend filterGen",
"filterTree": "-- filterTree (a -> Bool) -> Tree a -> [a]\non filterTree(p, tree)\n -- List of all values in the tree\n -- which match the predicate p.\n \n script go\n property q : mReturn(p)'s |λ|\n on |λ|(x, xs)\n if q(x) then\n {x} & concat(xs)\n else\n concat(xs)\n end if\n end |λ|\n end script\n \n foldTree(go, tree)\nend filterTree",
"filteredTree": "-- filteredTree (a -> Bool) -> Tree a -> Tree a\non filteredTree(p, tree)\n -- A tree including only those children\n -- which either match the predicate p, or have\n -- descendants which match the predicate p.\n \n script go\n property q : mReturn(p)\n on |λ|(x, xs)\n script test\n on |λ|(subTree)\n {} ≠ (nest of subTree) or (|λ|(root of subTree) of q)\n end |λ|\n end script\n Node(x, filter(test, xs))\n end |λ|\n end script\n \n foldTree(go, tree)\nend filteredTree",
"find": "-- find :: (a -> Bool) -> [a] -> (missing value | a)\non find(p, xs)\n tell mReturn(p)\n set lng to length of xs\n repeat with i from 1 to lng\n if |λ|(item i of xs) then return item i of xs\n end repeat\n missing value\n end tell\nend find",
"findGen": "-- findGen :: (a -> Bool) -> Gen [a] -> Maybe a\non findGen(p, gen)\n -- Just the first match for the predicate p\n -- in the generator stream gen, or Nothing\n -- if no match is found.\n set mp to mReturn(p)\n set v to gen's |λ|()\n repeat until missing value is v or (|λ|(v) of mp)\n set v to (|λ|() of gen)\n end repeat\n if missing value is v then\n Nothing()\n else\n Just(v)\n end if\nend findGen",
"findIndex": "-- findIndex :: (a -> Bool) -> [a] -> Maybe Int\non findIndex(p, xs)\n -- Just the zero-based index of the first\n -- (left-to-right match) for for the predicate p in xs, \n -- or Nothing if no match is found.\n tell mReturn(p)\n set lng to length of xs\n repeat with i from 1 to lng\n if |λ|(item i of xs) then return Just(i - 1)\n end repeat\n return Nothing()\n end tell\nend findIndex",
"findIndexR": "-- findIndexR :: (a -> Bool) -> [a] -> Maybe Int\non findIndexR(p, xs)\n -- Just the zero-based index of the first\n -- (right-to-left match) for for the predicate p in xs, \n -- or Nothing if no match is found.\n tell mReturn(p)\n set lng to length of xs\n repeat with i from lng to 1 by -1\n if |λ|(item i of xs) then return Just(i - 1)\n end repeat\n return Nothing()\n end tell\nend findIndexR",
"findIndices": "-- findIndices :: (a -> Bool) -> [a] -> [Int]\non findIndices(p, xs)\n -- List of zero-based indices of \n -- any matches for p in xs.\n script\n property f : mReturn(p)\n on |λ|(x, i, xs)\n if f's |λ|(x, i, xs) then\n {i - 1}\n else\n {}\n end if\n end |λ|\n end script\n concatMap(result, xs)\nend findIndices",
"findTree": "-- findTree :: (a -> Bool) -> Tree a -> Maybe Tree a\non findTree(p, tree)\n -- The first of any nodes in the tree which match the predicate p\n -- (For all matches, see treeMatches)\n script go\n property pf : mReturn(p)'s |λ|\n on |λ|(oNode)\n if pf(root of oNode) then\n Just(oNode)\n else\n set xs to nest of oNode\n set lng to length of xs\n \n script inNest\n on |λ|(tpl)\n lng < fst(tpl) or (not (Nothing of snd(tpl)))\n end |λ|\n end script\n \n script nextPeer\n on |λ|(tpl)\n Tuple(1 + fst(tpl), go's |λ|(item (fst(tpl)) of xs))\n end |λ|\n end script\n \n if 0 < lng then\n snd(|until|(inNest, nextPeer, Tuple(1, Nothing())))\n else\n Nothing()\n end if\n end if\n end |λ|\n end script\n \n go's |λ|(tree)\nend findTree",
"first": "-- first :: (a -> b) -> ((a, c) -> (b, c))\non |first|(f)\n -- A simple function lifted to one which applies to a tuple, \n -- transforming only the first item of that tuple\n script\n on |λ|(xy)\n Tuple(mReturn(f)'s |λ|(|1| of xy), |2| of xy)\n end |λ|\n end script\nend |first|",
"flatten": "-- flatten :: NestedList a -> [a]\non flatten(t)\n -- A flat list derived from a nested list.\n if list is class of t then\n concatMap(my flatten, t)\n else\n t\n end if\nend flatten",
"flattenTree": "-- flattenTree :: Tree a -> [a]\non flattenTree(node)\n -- The root elements of a tree in pre-order.\n script go\n on |λ|(x, xs)\n {root of x} & foldr(go, xs, nest of x)\n end |λ|\n end script\n go's |λ|(node, {})\nend flattenTree",
"flip": "-- flip :: (a -> b -> c) -> b -> a -> c\non flip(f)\n script\n property g : mReturn(f)\n on |λ|(x, y)\n g's |λ|(y, x)\n end |λ|\n end script\nend flip",
"floor": "-- floor :: Num -> Int\non floor(x)\n if class of x is record then\n set nr to properFracRatio(x)\n else\n set nr to properFraction(x)\n end if\n set n to fst(nr)\n if 0 > snd(nr) then\n n - 1\n else\n n\n end if\nend floor",
"fmap (<$>)": "-- fmap (<$>) :: Functor f => (a -> b) -> f a -> f b\non fmap(f, fa)\n set c to class of fa\n if c is record and keys(fa) contains \"type\" then\n set t to |type| of fa\n if \"Either\" = t then\n set fm to my fmapLR\n else if \"Maybe\" = t then\n set fm to my fmapMay\n else if \"Node\" = t then\n set fm to my fmapTree\n else if \"Tuple\" = t then\n set fm to my fmapTuple\n else\n set fm to my map\n end if\n |λ|(f, fa) of mReturn(fm)\n else if c is text then\n map(f, characters of fa)\n else if c is list then\n map(f, fa)\n else\n missing value\n end if\nend fmap",
"fmapGen (<$>)": "-- fmapGen <$> :: (a -> b) -> Gen [a] -> Gen [b]\non fmapGen(f, gen)\n script\n property g : mReturn(f)\n on |λ|()\n set v to gen's |λ|()\n if v is missing value then\n v\n else\n g's |λ|(v)\n end if\n end |λ|\n end script\nend fmapGen",
"fmapLR (<$>)": "-- fmapLR (<$>) :: (a -> b) -> Either a a -> Either a b\non fmapLR(f, lr)\n if |Left| of lr is missing value then\n |Right|(|λ|(|Right| of lr) of mReturn(f))\n else\n lr\n end if\nend fmapLR",
"fmapMay (<$>)": "-- fmapMay (<$>) :: (a -> b) -> Maybe a -> Maybe b\non fmapMay(f, mb)\n if Nothing of mb then\n mb\n else\n Just(|λ|(Just of mb) of mReturn(f))\n end if\nend fmapMay",
"fmapTree (<$>)": "-- fmapTree :: (a -> b) -> Tree a -> Tree b\non fmapTree(f, tree)\n script go\n property g : |λ| of mReturn(f)\n on |λ|(x)\n set xs to nest of x\n if xs ≠ {} then\n set ys to map(go, xs)\n else\n set ys to xs\n end if\n Node(g(root of x), ys)\n end |λ|\n end script\n |λ|(tree) of go\nend fmapTree",
"fmapTuple (<$>)": "-- fmapTuple (<$>) :: (a -> b) -> (a, a) -> (a, b)\non fmapTuple(f, tpl)\n Tuple(|1| of tpl, |λ|(|2| of tpl) of mReturn(f))\nend fmapTuple",
"foldMapTree": "-- foldMapTree :: Monoid m => (a -> m) -> Tree a -> m\non foldMapTree(f, tree)\n script go\n property g : mReturn(f)'s |λ|\n on |λ|(x)\n if length of (nest of x) > 0 then\n mappend(g(root of x), ¬\n foldl1(my mappend, (map(go, nest of x))))\n else\n g(root of x)\n end if\n end |λ|\n end script\n |λ|(tree) of go\nend foldMapTree",
"foldTree": "-- foldTree :: (a -> [b] -> b) -> Tree a -> b\non foldTree(f, tree)\n script go\n property g : mReturn(f)\n on |λ|(oNode)\n tell g to |λ|(root of oNode, map(go, nest of oNode))\n end |λ|\n end script\n |λ|(tree) of go\nend foldTree",
"foldl": "-- foldl :: (a -> b -> a) -> a -> [b] -> a\non foldl(f, startValue, xs)\n tell mReturn(f)\n set v to startValue\n set lng to length of xs\n repeat with i from 1 to lng\n set v to |λ|(v, item i of xs, i, xs)\n end repeat\n return v\n end tell\nend foldl",
"foldl1": "-- foldl1 :: (a -> a -> a) -> [a] -> a\non foldl1(f, xs)\n if length of xs > 1 then\n tell mReturn(f)\n set v to {item 1 of xs}\n set lng to length of xs\n repeat with i from 2 to lng\n set v to |λ|(v, item i of xs, i, xs)\n end repeat\n return v\n end tell\n else\n item 1 of xs\n end if\nend foldl1",
"foldl1May": "-- foldl1May :: (a -> a -> a) -> [a] -> Maybe a\non foldl1May(f, xs)\n set lng to length of xs\n if lng > 0 then\n if lng > 1 then\n tell mReturn(f)\n set v to {item 1 of xs}\n set lng to length of xs\n repeat with i from 2 to lng\n set v to |λ|(v, item i of xs, i, xs)\n end repeat\n return Just(v)\n end tell\n else\n Just(item 1 of xs)\n end if\n else\n Nothing()\n end if\nend foldl1May",
"foldlTree": "-- foldlTree :: (b -> a -> b) -> b -> Tree a -> b\non foldlTree(f, acc, tree)\n script go\n property mf : mReturn(f)\n on |λ|(a, x)\n foldl(go, |λ|(a, root of x) of mf, nest of x)\n end |λ|\n end script\n |λ|(acc, tree) of go\nend foldlTree",
"foldr": "-- foldr :: (a -> b -> b) -> b -> [a] -> b\non foldr(f, startValue, xs)\n tell mReturn(f)\n set v to startValue\n set lng to length of xs\n repeat with i from lng to 1 by -1\n set v to |λ|(item i of xs, v, i, xs)\n end repeat\n return v\n end tell\nend foldr",
"foldr1": "-- foldr1 :: (a -> a -> a) -> [a] -> a\non foldr1(f, xs)\n if length of xs > 1 then\n tell mReturn(f)\n set v to item -1 of xs\n set lng to length of xs\n repeat with i from lng - 1 to 1 by -1\n set v to |λ|(item i of xs, v, i, xs)\n end repeat\n return v\n end tell\n else\n xs\n end if\nend foldr1",
"foldr1May": "-- foldr1May :: (a -> a -> a) -> [a] -> Maybe a\non foldr1May(f, xs)\n set lng to length of xs\n if lng > 0 then\n tell mReturn(f)\n set v to item -1 of xs\n repeat with i from lng - 1 to 1 by -1\n set v to |λ|(item i of xs, v, i, xs)\n end repeat\n return Just(v)\n end tell\n else\n Nothing()\n end if\nend foldr1May",
"foldrTree": "-- foldrTree :: (a -> b -> b) -> b -> Tree a -> b\non foldrTree(f, acc, tree)\n script go\n property mf : mReturn(f)\n on |λ|(x, a)\n foldr(go, |λ|(root of x, a) of mf, nest of x)\n end |λ|\n end script\n |λ|(tree, acc) of go\nend foldrTree",
"forestFromJSON": "-- forestFromJSON :: String -> [Tree a]\non forestFromJSON(strJSON)\n set lr to jsonParseLR(strJSON)\n if missing value is |Left| of lr then\n map(my treeFromNestedList, |Right| of lr)\n else\n {}\n end if\nend forestFromJSON\n",
"fromEnum": "-- fromEnum :: Enum a => a -> Int\non fromEnum(x)\n set c to class of x\n if c is boolean then\n if x then\n 1\n else\n 0\n end if\n else if c is text then\n if x ≠ \"\" then\n id of x\n else\n missing value\n end if\n else\n x as integer\n end if\nend fromEnum",
"fromLeft": "-- fromLeft :: a -> Either a b -> a\non fromLeft(def, lr)\n if isLeft(lr) then\n |Left| of lr\n else\n def\n end if\nend fromLeft",
"fromMaybe": "-- fromMaybe :: a -> Maybe a -> a\non fromMaybe(default, mb)\n if Nothing of mb then\n default\n else\n Just of mb\n end if\nend fromMaybe",
"fromRight": "-- fromRight :: b -> Either a b -> b\non fromRight(def, lr)\n if isRight(lr) then\n |Right| of lr\n else\n def\n end if\nend fromRight",
"fst": "-- fst :: (a, b) -> a\non fst(tpl)\n if class of tpl is record then\n |1| of tpl\n else\n item 1 of tpl\n end if\nend fst",
"ft": "-- ft :: (Int, Int) -> [Int]\non ft(m, n)\n -- Abbreviation for quick testing\n if m ≤ n then\n set lst to {}\n repeat with i from m to n\n set end of lst to i\n end repeat\n return lst\n else\n return {}\n end if\nend ft",
"gcd": "-- gcd :: Int -> Int -> Int\non gcd(a, b)\n set x to abs(a)\n set y to abs(b)\n repeat until y = 0\n if x > y then\n set x to x - y\n else\n set y to y - x\n end if\n end repeat\n return x\nend gcd",
"genericIndexMay": "-- genericIndexMay :: [a] -> Int -> Maybe a\non genericIndexMay(xs, i)\n if i < (length of xs) and i ≥ 0 then\n Just(item (i + 1) of xs)\n else\n Nothing()\n end if\nend genericIndexMay",
"getCurrentDirectory": "-- getCurrentDirectory :: IO FilePath\non getCurrentDirectory()\n set ca to current application\n ca's NSFileManager's defaultManager()'s currentDirectoryPath as string\nend getCurrentDirectory",
"getDirectoryContents": "-- getDirectoryContents :: FilePath -> IO [FilePath]\non getDirectoryContents(strPath)\n set ca to current application\n (ca's NSFileManager's defaultManager()'s ¬\n contentsOfDirectoryAtPath:(stringByStandardizingPath of (¬\n ca's NSString's stringWithString:(strPath))) ¬\n |error|:(missing value)) as list\nend getDirectoryContents",
"getDirectoryContentsLR": "-- getDirectoryContentsLR :: FilePath -> Either String IO [FilePath]\non getDirectoryContentsLR(strPath)\n set ca to current application\n set {xs, e} to (ca's NSFileManager's defaultManager()'s ¬\n contentsOfDirectoryAtPath:(stringByStandardizingPath of ¬\n (ca's NSString's stringWithString:(strPath))) ¬\n |error|:(reference))\n if xs is missing value then\n |Left|((localizedDescription of e) as string)\n else\n |Right|(xs as list)\n end if\nend getDirectoryContentsLR",
"getFinderDirectory": "-- getFinderDirectory :: IO FilePath\non getFinderDirectory()\n tell application \"Finder\" to POSIX path of (insertion location as alias)\nend getFinderDirectory",
"getHomeDirectory": "-- getHomeDirectory :: IO FilePath\non getHomeDirectory()\n current application's NSHomeDirectory() as string\nend getHomeDirectory",
"getTemporaryDirectory": "-- getTemporaryDirectory :: IO FilePath\non getTemporaryDirectory()\n current application's NSTemporaryDirectory() as string\nend getTemporaryDirectory",
"group": "-- group :: Eq a => [a] -> [[a]]\non group(xs)\n script eq\n on |λ|(a, b)\n a = b\n end |λ|\n end script\n \n groupBy(eq, xs)\nend group",
"groupBy": "-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]\non groupBy(f, xs)\n -- Typical usage: groupBy(on(eq, f), xs)\n set mf to mReturn(f)\n \n script enGroup\n on |λ|(a, x)\n if length of (active of a) > 0 then\n set h to item 1 of active of a\n else\n set h to missing value\n end if\n \n if h is not missing value and mf's |λ|(h, x) then\n {active:(active of a) & {x}, sofar:sofar of a}\n else\n {active:{x}, sofar:(sofar of a) & {active of a}}\n end if\n end |λ|\n end script\n \n if length of xs > 0 then\n set dct to foldl(enGroup, {active:{item 1 of xs}, sofar:{}}, rest of xs)\n if length of (active of dct) > 0 then\n sofar of dct & {active of dct}\n else\n sofar of dct\n end if\n else\n {}\n end if\nend groupBy",
"groupSortOn": "-- groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]]\n-- groupSortOn :: Ord b => [((a -> b), Bool)] -> [a] -> [[a]]\non groupSortOn(f, xs)\n -- Sort and group a list by comparing the results of a key function\n -- applied to each element. groupSortOn f is equivalent to\n -- groupBy eq $ sortBy (comparing f),\n -- but has the performance advantage of only evaluating f once for each\n -- element in the input list.\n -- This is a decorate-(group.sort)-undecorate pattern, as in the\n -- so-called 'Schwartzian transform'.\n -- Groups are arranged from from lowest to highest.\n script keyBool\n on |λ|(a, x)\n if class of x is boolean then\n {asc:x, fbs:fbs of a}\n else\n {asc:true, fbs:({Tuple(x, asc of a)} & fbs of a)}\n end if\n end |λ|\n end script\n set {fs, bs} to {|1|, |2|} of unzip(fbs of foldl(keyBool, ¬\n {asc:true, fbs:{}}, flatten({f})))\n \n set intKeys to length of fs\n set ca to current application\n script dec\n property gs : map(my mReturn, fs)\n on |λ|(x)\n set nsDct to (ca's NSMutableDictionary's ¬\n dictionaryWithDictionary:{val:x})\n repeat with i from 1 to intKeys\n (nsDct's setValue:((item i of gs)'s |λ|(x)) ¬\n forKey:(character id (96 + i)))\n end repeat\n nsDct as record\n end |λ|\n end script\n \n script descrip\n on |λ|(bool, i)\n ca's NSSortDescriptor's ¬\n sortDescriptorWithKey:(character id (96 + i)) ¬\n ascending:bool\n end |λ|\n end script\n \n script grpUndec\n on |λ|(grp)\n script\n on |λ|(x)\n val of x\n end |λ|\n end script\n map(result, grp)\n end |λ|\n end script\n \n script aEq\n on |λ|(p, q)\n (a of p) = (a of q)\n end |λ|\n end script\n \n -- Sorted, grouped, undecorated\n map(grpUndec, ¬\n groupBy(aEq, ((ca's NSArray's arrayWithArray:map(dec, xs))'s ¬\n sortedArrayUsingDescriptors:map(descrip, bs)) as list))\nend groupSortOn",
"gt": "-- gt :: Ord a => a -> a -> Bool\non gt(x, y)\n set c to class of x\n if record is c or list is c then\n fst(x) > fst(y)\n else\n x > y\n end if\nend gt",
"head": "-- head :: [a] -> a\non head(xs)\n if xs = {} then\n missing value\n else\n item 1 of xs\n end if\nend head",
"headMay": "-- headMay :: [a] -> Maybe a\non headMay(xs)\n if xs = {} then\n Nothing()\n else\n Just(item 1 of xs)\n end if\nend headMay",
"identity": "-- identity :: a -> a\non identity(x)\n -- The argument unchanged.\n x\nend identity",
"if_": "-- if_ :: Bool -> a -> a -> a\non if_(bool, x, y)\n if bool then\n x\n else\n y\n end if\nend if_",
"indented": "-- indented :: String -> String -> String\non indented(strIndent, s)\n script\n on |λ|(x)\n if x ≠ \"\" then\n strIndent & x\n else\n x\n end if\n end |λ|\n end script\n unlines(map(result, |lines|(s)))\nend indented",
"index": "-- index (!!) :: [a] -> Int -> Maybe a\n-- index (!!) :: Gen [a] -> Int -> Maybe a\n-- index (!!) :: String -> Int -> Maybe Char\non |index|(xs, i)\n if script is class of xs then\n repeat with j from 1 to i\n set v to |λ|() of xs\n end repeat\n if missing value is not v then\n Just(v)\n else\n Nothing()\n end if\n else\n if length of xs < i then\n Nothing()\n else\n Just(item i of xs)\n end if\n end if\nend |index|",
"indexOf": "-- indexOf :: Eq a => [a] -> [a] -> Maybe Int\n-- indexOf :: String -> String -> Maybe Int\non indexOf(pat, src)\n if class of src is text then\n set tpl to breakOn(pat, src)\n if 0 < length of (|2| of tpl) then\n Just((length of |1| of tpl) + 1)\n else\n Nothing()\n end if\n else\n script pfx\n on |λ|(xs)\n isPrefixOf(pat, xs)\n end |λ|\n end script\n findIndex(pfx, tails(src))\n end if\nend indexOf",
"init": "-- init :: [a] -> [a]\n-- init :: [String] -> [String]\non init(xs)\n set blnString to class of xs = string\n set lng to length of xs\n \n if lng > 1 then\n if blnString then\n text 1 thru -2 of xs\n else\n items 1 thru -2 of xs\n end if\n else if lng > 0 then\n if blnString then\n \"\"\n else\n {}\n end if\n else\n missing value\n end if\nend init\n",
"initMay": "-- initMay :: [a] -> Maybe [a]\n-- initMay :: [String] -> Maybe [String]\non initMay(xs)\n set blnString to class of xs = string\n set lng to length of xs\n if lng > 1 then\n if blnString then\n Just(text 1 thru -2 of xs)\n else\n Just(items 1 thru -2 of xs)\n end if\n else if lng > 0 then\n if blnString then\n Just(\"\")\n else\n Just({})\n end if\n else\n Nothing()\n end if\nend initMay",
"inits": "-- inits :: [a] -> [[a]]\n-- inits :: String -> [String]\non inits(xs)\n script elemInit\n on |λ|(_, i, xs)\n items 1 thru i of xs\n end |λ|\n end script\n \n script charInit\n on |λ|(_, i, xs)\n text 1 thru i of xs\n end |λ|\n end script\n \n if class of xs is string then\n {\"\"} & map(charInit, xs)\n else\n {{}} & map(elemInit, xs)\n end if\nend inits",
"insert": "-- insert :: Ord a => a -> [a] -> [a]\non insert(x, ys)\n insertBy(my compare, x, ys)\nend insert",
"insertBy": "-- insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]\non insertBy(cmp, x, ys)\n set lng to length of ys\n if lng > 0 then\n tell mReturn(cmp)\n set bln to false\n repeat with i from 1 to lng\n if |λ|(item i of ys, x) > 0 then\n set bln to true\n exit repeat\n end if\n end repeat\n end tell\n if bln then\n if i > 1 then\n items 1 thru (i - 1) of ys & x & items i thru -1 of ys\n else\n {x} & ys\n end if\n else\n ys & x\n end if\n else\n {x}\n end if\nend insertBy",
"insertDict": "-- insertDict :: String -> a -> Dict -> Dict\ron insertDict(k, v, rec)\r tell current application\r tell dictionaryWithDictionary_(rec) of its NSMutableDictionary\r its setValue:v forKey:(k as string)\r it as record\r end tell\r end tell\rend insertDict",
"insertSet": "-- insertSet :: Ord a => a -> Set a -> Set a\non insertSet(x, oSet)\n oSet's addObject:(x)\n return oSet\nend insertSet",
"intToDigit": "-- intToDigit :: Int -> Char\non intToDigit(n)\n if n ≥ 0 and n < 16 then\n character (n + 1) of \"0123456789ABCDEF\"\n else\n \"?\"\n end if\nend intToDigit",
"intercalate": "-- intercalate :: [a] -> [[a]] -> [a]\n-- intercalate :: String -> [String] -> String\non intercalate(sep, xs)\n if class of xs is text then\n set {dlm, my text item delimiters} to ¬\n {my text item delimiters, delim}\n set s to xs as text\n set my text item delimiters to dlm\n else\n concat(intersperse(sep, xs))\n end if\nend intercalate",
"intercalateS": "-- intercalateS :: String -> [String] -> String\non intercalateS(delim, xs)\n set {dlm, my text item delimiters} to ¬\n {my text item delimiters, delim}\n set s to xs as text\n set my text item delimiters to dlm\n s\nend intercalateS",
"intersect": "-- intersect :: (Eq a) => [a] -> [a] -> [a]\non intersect(xs, ys)\n if length of xs < length of ys then\n set {shorter, longer} to {xs, ys}\n else\n set {longer, shorter} to {xs, ys}\n end if\n if shorter ≠ {} then\n set lst to {}\n repeat with x in shorter\n if longer contains x then set end of lst to contents of x\n end repeat\n lst\n else\n {}\n end if\nend intersect",
"intersectBy": "-- intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]\non intersectBy(eq, xs, ys)\n if length of xs > 0 and length of ys > 0 then\n set p to curry(eq)\n script matchFound\n on |λ|(x)\n any(p's |λ|(x), ys)\n end |λ|\n end script\n \n filter(matchFound, xs)\n else\n {}\n end if\nend intersectBy",
"intersectListsBy": "-- intersectListsBy :: (a -> a -> Bool) -> [[a]] -> [a]\non intersectListsBy(fnEq, xs)\n script\n property eq : mReturn(fnEq)\n on |λ|(a, x)\n intersectBy(eq, a, x)\n end |λ|\n end script\n foldr1(result, xs)\nend intersectionBy",
"intersection": "-- intersection :: Ord a => Set a -> Set a -> Set a\non intersection(a, b)\n set s to current application's NSMutableSet's alloc's init()\n s's setSet:(a)\n s's intersectSet:(b)\n return s\nend intersection",
"intersperse": "-- intersperse :: a -> [a] -> [a]\n-- intersperse :: Char -> String -> String\non intersperse(sep, xs)\n -- intersperse(0, [1,2,3]) -> [1, 0, 2, 0, 3]\n set lng to length of xs\n if lng > 1 then\n set acc to {item 1 of xs}\n repeat with i from 2 to lng\n set acc to acc & {sep, item i of xs}\n end repeat\n if class of xs is string then\n concat(acc)\n else\n acc\n end if\n else\n xs\n end if\nend intersperse",
"isAlpha": "-- isAlpha :: Char -> Bool\non isAlpha(c)\n set ca to current application\n set oRgx to ca's NSRegularExpression's ¬\n regularExpressionWithPattern:(\"[A-Za-z\\\\u00C0-\\\\u00FF]\") ¬\n options:(ca's NSRegularExpressionAnchorsMatchLines as integer) ¬\n |error|:(missing value)\n set oString to ca's NSString's stringWithString:c\n 0 < (oRgx's numberOfMatchesInString:oString options:0 ¬\n range:{location:0, |length|:1})\nend isAlpha",
"isChar": "-- isChar :: a -> Bool\non isChar(x)\n class of x is string and length of x is 1\nend isChar",
"isDigit": "-- isDigit :: Char -> Bool\non isDigit(c)\n set n to (id of c)\n 48 ≤ n and 57 ≥ n\nend isDigit",
"isInfixOf": "-- isInfixOf :: (Eq a) => [a] -> [a] -> Bool\n-- isInfixOf :: String -> String -> Bool\non isInfixOf(needle, haystack)\n haystack contains needle\nend isInfixOf",
"isLeft": "-- isLeft :: Either a b -> Bool\non isLeft(x)\n set dct to current application's ¬\n NSDictionary's dictionaryWithDictionary:x\n (dct's objectForKey:\"type\") as text = \"Either\" and ¬\n (dct's objectForKey:\"Right\") as list = {missing value}\nend isLeft",
"isLower": "-- isLower :: Char -> Bool\non isLower(c)\n set d to (id of c) - 97 -- id of \"a\"\n d ≥ 0 and d < 26\nend isLower",
"isMaybe": "-- isMaybe :: a -> Bool\non isMaybe(x)\n -- use framework \"Foundation\"\n -- use scripting additions\n if class of x is record then\n set ca to current application\n set v to ((ca's NSDictionary's ¬\n dictionaryWithDictionary:x)'s ¬\n objectForKey:\"type\")\n v is not missing value ¬\n and (v's isKindOfClass:(ca's NSString)) ¬\n and (v as string = \"Maybe\")\n else\n false\n end if\nend isMaybe",
"isNull": "-- isNull :: [a] -> Bool\n-- isNull :: String -> Bool\non isNull(xs)\n if class of xs is string then\n \"\" = xs\n else\n {} = xs\n end if\nend isNull",
"isPrefixOf": "-- isPrefixOf :: [a] -> [a] -> Bool\n-- isPrefixOf :: String -> String -> Bool\non isPrefixOf(xs, ys)\n -- isPrefixOf takes two lists or strings and returns \n -- true if and only if the first is a prefix of the second.\n script go\n on |λ|(xs, ys)\n set intX to length of xs\n if intX < 1 then\n true\n else if intX > length of ys then\n false\n else if class of xs is string then\n (offset of xs in ys) = 1\n else\n set {xxt, yyt} to {Just of uncons(xs), Just of uncons(ys)}\n ((|1| of xxt) = (|1| of yyt)) and |λ|(|2| of xxt, |2| of yyt)\n end if\n end |λ|\n end script\n go's |λ|(xs, ys)\nend isPrefixOf",
"isRight": "-- isRight :: Either a b -> Bool\non isRight(x)\n set dct to current application's ¬\n NSDictionary's dictionaryWithDictionary:x\n (dct's objectForKey:\"type\") as text = \"Either\" and ¬\n (dct's objectForKey:\"Left\") as list = {missing value}\nend isRight",
"isSortedBy": "-- isSortedBy :: (a -> a -> Bool) -> [a] -> Bool\non isSortedBy(cmp, xs)\n -- The 'isSortedBy' function returns true iff the predicate returns true\n -- for all adjacent pairs of elements in the list.\n script LE\n on |λ|(x)\n x < 1\n end |λ|\n end script\n (length of xs < 2) or all(LE, zipWith(cmp, xs, tail(xs)))\nend isSortedBy",
"isSpace": "-- isSpace :: Char -> Bool\non isSpace(c)\n set i to id of c\n 32 = i or (9 ≤ i and 13 ≥ i)\nend isSpace",
"isSubsequenceOf": "-- isSubsequenceOf :: Eq a => [a] -> [a] -> Bool\n-- isSubsequenceOf :: String -> String -> Bool\non isSubsequenceOf(xs, ys)\n script iss\n on |λ|(a, b)\n if a ≠ {} then\n if b ≠ {} then\n if item 1 of a = item 1 of b then\n |λ|(rest of a, rest of b)\n else\n |λ|(a, rest of b)\n end if\n else\n false\n end if\n else\n true\n end if\n end |λ|\n end script\n \n if class of xs = string then\n tell iss to |λ|(characters of xs, characters of ys)\n else\n tell iss to |λ|(xs, ys)\n end if\nend isSubsequenceOf",
"isSubsetOf": "-- isSubsetOf :: Ord a => Set a -> Set a -> Bool\non isSubsetOf(objcSetA, objcSetB)\n objcSetA's isSubsetOfSet:(objcSetB)\nend isSubsetOf",
"isSuffixOf": "-- isSuffixOf :: Eq a => [a] -> [a] -> Bool\n-- isSuffixOf :: String -> String -> Bool\non isSuffixOf(ns, hs)\n script go\n on |λ|(delta)\n ns = dropLength(delta, hs)\n end |λ|\n end script\n bindMay(dropLengthMaybe(ns, hs), go)\nend isSuffixOf",
"isUpper": "-- isUpper :: Char -> Bool\non isUpper(c)\n set d to (id of c) - 65 -- id of \"A\"\n d ≥ 0 and d < 26\nend isUpper",
"iso8601Local": "-- iso8601Local :: Date -> String\non iso8601Local(dte)\n (dte as «class isot» as string)\nend iso8601Local",
"iterate": "-- iterate :: (a -> a) -> a -> Gen [a]\non iterate(f, x)\n script\n property v : missing value\n property g : mReturn(f)\n on |λ|()\n if missing value is v then\n set v to x\n else\n set v to g's |λ|(v)\n end if\n return v\n end |λ|\n end script\nend iterate",
"iterateUntil": "-- iterateUntil :: (a -> Bool) -> (a -> a) -> a -> [a]\non iterateUntil(p, f, x)\n script\n property mp : mReturn(p)'s |λ|\n property mf : mReturn(f)'s |λ|\n property lst : {x}\n on |λ|(v)\n repeat until mp(v)\n set v to mf(v)\n set end of lst to v\n end repeat\n return lst\n end |λ|\n end script\n |λ|(x) of result\nend iterateUntil",
"join": "-- join :: Monad m => m (m a) -> m a\non join(x)\n bind(x, my identity)\nend join",
"jsonFromTree": "-- jsonFromTree :: Tree a -> String\non jsonFromTree(tree)\n script go\n on |λ|(x)\n {root of x, map(go, nest of x)}\n end |λ|\n end script\n set ca to current application\n ca's (NSString's alloc()'s ¬\n initWithData:((ca's (NSJSONSerialization's ¬\n dataWithJSONObject:(|λ|(tree) of go) ¬\n options:0 |error|:(missing value)))) ¬\n encoding:(ca's NSUTF8StringEncoding)) as string\nend jsonFromTree",
"jsonLog": "-- jsonLog :: a -> IO ()\non jsonLog(e)\n log showJSON(e)\nend jsonLog",
"jsonParseLR": "-- jsonParseLR :: String -> Either String a\non jsonParseLR(s)\n set ca to current application\n set {x, e} to ca's NSJSONSerialization's ¬\n JSONObjectWithData:((ca's NSString's stringWithString:s)'s ¬\n dataUsingEncoding:(ca's NSUTF8StringEncoding)) ¬\n options:0 |error|:(reference)\n if x is missing value then\n |Left|(e's localizedDescription() as string)\n else\n if 1 = (x's isKindOfClass:(ca's NSArray)) as integer then\n |Right|(x as list)\n else\n |Right|(item 1 of (x as list))\n end if\n end if\nend jsonParseLR",
"justifyLeft": "-- justifyLeft :: Int -> Char -> String -> String\non justifyLeft(n, cFiller, strText)\n if n > length of strText then\n text 1 thru n of (strText & replicate(n, cFiller))\n else\n strText\n end if\nend justifyLeft",
"justifyRight": "-- justifyRight :: Int -> Char -> String -> String\non justifyRight(n, cFiller)\n script\n on |λ|(txt)\n if n > length of txt then\n text -n thru -1 of ((replicate(n, cFiller) as text) & txt)\n else\n txt\n end if\n end |λ|\n end script\nend justifyRight",
"keys": "-- keys :: Dict -> [String]\non keys(rec)\n (current application's NSDictionary's dictionaryWithDictionary:rec)'s allKeys() as list\nend keys",
"kleisliCompose (>=>)": "-- kleisliCompose (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)\non kleisliCompose(f, g)\n script\n on |λ|(x)\n bind(mReturn(f)'s |λ|(x), g)\n end |λ|\n end script\nend kleisliCompose",
"last": "-- last :: [a] -> a\non |last|(xs)\n item -1 of xs\nend |last|",
"lastMay": "-- lastMay :: [a] -> Maybe a\non lastMay(xs)\n if length of xs > 0 then\n Just(item -1 of xs)\n else\n Nothing()\n end if\nend lastMay",
"lcm": "-- lcm :: Int -> Int -> Int\non lcm(x, y)\n if (x = 0 or y = 0) then\n 0\n else\n abs(floor(x / (gcd(x, y))) * y)\n end if\nend lcm",
"lefts": "-- lefts :: [Either a b] -> [a]\non lefts(xs)\n script go\n on |λ|(x)\n if class of x is record then\n set ks to keys(x)\n if ks contains \"type\" and ks contains \"Left\" then\n {x}\n else\n {}\n end if\n else\n {}\n end if\n end |λ|\n end script\n concatMap(go, xs)\nend lefts",
"length": "-- length :: [a] -> Int\non |length|(xs)\n set c to class of xs\n if list is c or string is c then\n length of xs\n else\n (2 ^ 29 - 1) -- (maxInt - simple proxy for non-finite)\n end if\nend |length|",
"levelNodes": "-- levelNodes :: Tree a -> [[Tree a]]\non levelNodes(tree)\n script p\n on |λ|(xs)\n length of xs < 1\n end |λ|\n end script\n \n script f\n on |λ|(xs)\n script nest\n on |λ|(Node)\n nest of Node\n end |λ|\n end script\n concatMap(nest, xs)\n end |λ|\n end script\n \n iterateUntil(p, f, {tree})\nend levelNodes",
"levels": "-- levels :: Tree a -> [[a]]\ron levels(tree)\r -- A list of lists, grouping the root\r -- values of each level of the tree.\r script go\r on |λ|(node, a)\r if {} ≠ a then\r tell a to set {h, t} to {item 1, rest}\r else\r set {h, t} to {{}, {}}\r end if\r \r {{root of node} & h} & foldr(go, t, nest of node)\r end |λ|\r end script\r \r |λ|(tree, {}) of go\rend levels",
"liftA2": "-- liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c\non liftA2(f, a, b)\n -- Lift a binary function to actions.\n -- e.g.\n -- liftA2(mult, {1, 2, 3}, {4, 5, 6}) \n --> {4, 5, 6, 8, 10, 12, 12, 15, 18}\n set c to class of a\n if c is list or c is text then\n liftA2List(f, a, b)\n else\n set t to typeName(a)\n if \"(a -> b)\" = t then\n liftA2Fn(f, a, b)\n else if \"Either\" = t then\n liftA2LR(f, a, b)\n else if \"Maybe\" = t then\n liftA2May(f, a, b)\n else if \"Tuple\" = t then\n liftA2Tuple(f, a, b)\n else if \"Node\" = t then\n liftA2Tree(f, a, b)\n else\n missing value\n end if\n end if\nend liftA2",
"liftA2Fn": "-- liftA2Fn :: (a0 -> b -> c) -> (a -> a0) -> (a -> b) -> a -> c\non liftA2Fn(op, f, g)\n -- Lift a binary function to a composition\n -- over two other functions.\n -- liftA2 (*) (+ 2) (+ 3) 7 == 90\n script go\n property mop : mReturn(op)\n property mf : mReturn(f)\n property mg : mReturn(g)\n on |λ|(x)\n |λ|(|λ|(x) of mf, |λ|(x) of mg) of mop\n end |λ|\n end script\nend liftA2Fn",
"liftA2LR": "-- liftA2LR :: (a -> b -> c) -> Either d a -> Either d b -> Either d c\non liftA2LR(f, a, b)\n set x to |Right| of a\n if class of b is list then\n set y to {}\n else\n set y to |Right| of b\n end if\n \n if x is missing value then\n a\n else if y is missing value then\n b\n else\n |Right|(|λ|(x, y) of mReturn(f))\n end if\nend liftA2LR",
"liftA2List": "-- liftA2List :: (a -> b -> c) -> [a] -> [b] -> [c]\non liftA2List(f, xs, ys)\n script\n property g : mReturn(f)'s |λ|\n on |λ|(x)\n script\n on |λ|(y)\n {g(x, y)}\n end |λ|\n end script\n concatMap(result, ys)\n end |λ|\n end script\n concatMap(result, xs)\nend liftA2List",
"liftA2May": "-- liftA2May :: (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c\non liftA2May(f, a, b)\n if Nothing of a then\n a\n else if Nothing of b then\n b\n else\n Just(|λ|(Just of a, Just of b) of mReturn(f))\n end if\nend liftA2May",
"liftA2Tree": "-- liftA2Tree :: (a -> b -> c) -> Tree a -> Tree b -> Tree c\non liftA2Tree(f, tx, ty)\n \n script fx\n on |λ|(y)\n mReturn(f)'s |λ|(root of tx, y)\n end |λ|\n end script\n \n script fmapT\n on |λ|(t)\n fmapTree(fx, t)\n end |λ|\n end script\n \n script liftA2T\n on |λ|(t)\n liftA2Tree(f, t, ty)\n end |λ|\n end script\n \n if class of ty is list then\n set rootLabel to {}\n set forest to {}\n else\n set rootLabel to root of ty\n set forest to map(fmapT, nest of ty) & map(liftA2T, nest of tx)\n end if\n \n Node(mReturn(f)'s |λ|(root of tx, rootLabel), forest)\nend liftA2Tree",
"liftA2Tuple": "-- liftA2Tuple :: Monoid m => (a -> b -> c) -> (m, a) -> (m, b) -> (m, c)\non liftA2Tuple(f, a, b)\n if class of b is list then\n set b1 to {}\n set b2 to {}\n else\n set b1 to |1| of b\n set b2 to |2| of b\n end if\n Tuple(mappend(|1| of a, b1), mReturn(f)'s |λ|(|2| of a, b2))\nend liftA2Tuple",
"lines": "-- lines :: String -> [String]\non |lines|(xs)\n paragraphs of xs\nend |lines|",
"list": "-- list :: Gen [a] -> [a]\non |list|(gen)\n -- A strict list derived from a lazy generator. \n set xs to {}\n set x to |λ|() of gen\n repeat while missing value ≠ x\n set end of xs to x\n set x to |λ|() of gen\n end repeat\n return xs\nend |list|",
"listDirectory": "-- listDirectory :: FilePath -> [FilePath]\non listDirectory(strPath)\n set ca to current application\n unwrap(ca's NSFileManager's defaultManager()'s ¬\n contentsOfDirectoryAtPath:(unwrap(stringByStandardizingPath of ¬\n wrap(strPath))) |error|:(missing value))\nend listDirectory",
"listFromMaybe": "-- listFromMaybe :: Maybe a -> [a]\non listFromMaybe(mb)\n -- A singleton list derived from a Just value, \n -- or an empty list derived from Nothing.\n if Nothing of mb then\n {}\n else\n {Just of mb}\n end if\nend maybeToList",
"listFromTree": "-- listFromTree :: Tree a -> [a]\non listFromTree(tree)\n script go\n on |λ|(x)\n {root of x} & concatMap(go, nest of x)\n end |λ|\n end script\n |λ|(tree) of go\nend listFromTree",
"listFromTuple": "-- listFromTuple :: (a, a ...) -> [a]\non listFromTuple(tpl)\n items 2 thru -2 of (tpl as list)\nend listFromTuple",
"listToMaybe": "-- listToMaybe :: [a] -> Maybe a\non listToMaybe(xs)\n -- The listToMaybe function returns Nothing on \n -- an empty list or Just the head of the list.\n if xs ≠ {} then\n Just(item 1 of xs)\n else\n Nothing()\n end if\nend listToMaybe",
"log": "-- log :: Float -> Float\non |log|(n)\n Just of evalJSMay((\"Math.log(\" & n as string) & \")\")\nend |log|",
"lookup": "-- lookup :: Eq a => a -> Container -> Maybe b\non lookup(k, m)\n set c to class of m\n if c is list then\n lookupTuples(k, m)\n else if c = record then\n lookupDict(k, m)\n else\n Nothing()\n end if\nend lookup",
"lookupDict": "-- lookupDict :: a -> Dict -> Maybe b\non lookupDict(k, dct)\n -- Just the value of k in the dictionary,\n -- or Nothing if k is not found.\n set ca to current application\n set v to (ca's NSDictionary's dictionaryWithDictionary:dct)'s objectForKey:k\n if missing value ≠ v then\n Just(item 1 of ((ca's NSArray's arrayWithObject:v) as list))\n else\n Nothing()\n end if\nend lookupDict",
"lookupTuples": "-- lookupTuples :: Eq a => a -> [(a, b)] -> Maybe b\non lookupTuples(k, xs)\n script keyMatch\n on |λ|(x)\n k = fst(x)\n end |λ|\n end script\n \n script harvestMay\n on |λ|(kv)\n Just(snd(kv))\n end |λ|\n end script\n \n bindMay(find(keyMatch, xs), harvestMay)\nend lookupTuples",
"lt": "-- lt (<) :: Ord a => a -> a -> Bool\ron lt(x)\r\tscript\r\t\ton |λ|(y)\r\t\t\tx < y\r\t\tend |λ|\r\tend script\rend lt",
"mReturn": "-- mReturn :: First-class m => (a -> b) -> m (a -> b)\non mReturn(f)\n -- 2nd class handler function lifted into 1st class script wrapper. \n if script is class of f then\n f\n else\n script\n property |λ| : f\n end script\n end if\nend mReturn",
"map": "-- map :: (a -> b) -> [a] -> [b]\non map(f, xs)\n -- The list obtained by applying f\n -- to each element of xs.\n tell mReturn(f)\n set lng to length of xs\n set lst to {}\n repeat with i from 1 to lng\n set end of lst to |λ|(item i of xs, i, xs)\n end repeat\n return lst\n end tell\nend map",
"mapAccumL": "-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])\non mapAccumL(f, acc, xs)\n -- 'The mapAccumL function behaves like a combination of map and foldl; \n -- it applies a function to each element of a list, passing an \n -- accumulating parameter from |Left| to |Right|, and returning a final \n -- value of this accumulator together with the new list.' (see Hoogle)\n script\n on |λ|(a, x, i)\n tell mReturn(f) to set pair to |λ|(|1| of a, x, i)\n Tuple(|1| of pair, (|2| of a) & {|2| of pair})\n end |λ|\n end script\n \n foldl(result, Tuple(acc, []), xs)\nend mapAccumL",
"mapAccumL_Tree": "-- mapAccumL_Tree :: (acc -> x -> (acc, y)) -> acc -> Tree -> (acc, Tree)\non mapAccumL_Tree(f, acc, tree)\n script go\n property mf : mReturn(f)'s |λ|\n on |λ|(a, x)\n set pair to f(a, root of x)\n set tpl to mapAccumL(go, item 1 of pair, nest of x)\n Tuple(item 1 of tpl, Node(item 2 of pair, item 2 of tpl))\n end |λ|\n end script\n |λ|(acc, tree) of go\nend mapAccumL_Tree",
"mapAccumR": "-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])\non mapAccumR(f, acc, xs)\n -- 'The mapAccumR function behaves like a combination of map and foldr; \n -- it applies a function to each element of a list, passing an accumulating \n -- parameter from |Right| to |Left|, and returning a final value of this \n -- accumulator together with the new list.' (see Hoogle)\n script\n on |λ|(x, a, i)\n tell mReturn(f) to set pair to |λ|(|1| of a, x, i)\n Tuple(|1| of pair, (|2| of pair) & |2| of a)\n end |λ|\n end script\n foldr(result, Tuple(acc, []), xs)\nend mapAccumR",
"mapKeys": "-- mapKeys :: (Key -> Key) -> IntMap a -> IntMap a\non mapKeys(f, dct)\n script\n property g : mReturn(f)\n on |λ|(kv)\n set {k, v} to kv\n {g's |λ|(k), v}\n end |λ|\n end script\n map(result, zip(keys(dct), elems(dct)))\nend mapKeys",
"mapMaybe": "-- mapMaybe :: (a -> Maybe b) -> [a] -> [b]\non mapMaybe(mf, xs)\n -- The mapMaybe function is a version of map which can throw out\n -- elements. In particular, the functional argument returns\n -- something of type Maybe b. If this is Nothing, no element is\n -- added on to the result list. If it just Just b, then b is\n -- included in the result list.\n script\n property g : mReturn(mf)\n on |λ|(a, x)\n set mb to g's |λ|(x)\n if Nothing of mb then\n a\n else\n a & (Just of mb)\n end if\n end |λ|\n end script\n foldl(result, {}, xs)\nend mapMaybe",
"mapMaybeGen": "-- mapMaybeGen :: (a -> Maybe b) -> Gen [a] -> Gen [b]\non mapMaybeGen(mf, gen)\n script\n property mg : mReturn(mf)\n on |λ|()\n set v to gen's |λ|()\n if v is not missing value then\n set mb to mg's |λ|(v)\n repeat while (Nothing of mb) and not (missing value is v)\n set v to gen's |λ|()\n if missing value is not v then set mb to mg's |λ|(v)\n end repeat\n if not |Nothing| of mb then\n |Just| of mb\n else\n missing value\n end if\n else\n v\n end if\n end |λ|\n end script\nend mapMaybeGen",
"mappend (<>)": "-- mappend (<>) :: Monoid a => a -> a -> a\non mappend(a, b)\n set ca to class of a\n if record is ca then\n script instanceMay\n on |λ|(strType)\n set mb to lookup(strType, ¬\n {Maybe:mappendMaybe, Ordering:mappendOrdering, Tuple:mappendTuple})\n end |λ|\n end script\n set mbi to bindMay(lookup(\"type\", a), instanceMay)\n if Nothing of mbi then\n a & b\n else\n mReturn(Just of mbi)'s |λ|(a, b)\n end if\n else if handler is ca then\n mappendFn(a, b)\n else\n a & b\n end if\nend mappend",
"mappendFn": "-- mappendFn :: Monoid b => (a -> b) -> (a -> b) -> (a -> b)\non mappendFn(f, g)\n script\n property mf : mReturn(f)\n property mg : mReturn(g)\n on |λ|(x)\n mappend(mf's |λ|(x), mg's |λ|(x))\n end |λ|\n end script\nend mappendFn",
"mappendMaybe (<>)": "-- mappendMaybe (<>) :: Maybe a -> Maybe a -> Maybe a\non mappendMaybe(a, b)\n if Nothing of a then\n b\n else if Nothing of b then\n a\n else\n Just(mappend(Just of a, Just of b))\n end if\nend mappendMaybe",
"mappendOrd (<>)": "-- mappendOrd (<>) :: Ordering -> Ordering -> Ordering\non mappendOrd(a, b)\n if 0 ≠ a then\n a\n else\n b\n end if\nend mappendOrd",
"mappendTuple (<>)": "-- mappendTuple (<>) :: (a, b) -> (a, b) -> (a, b)\non mappendTuple(a, b)\n Tuple(mappend(|1| of a, |1| of b), mappend(|2| of a, |2| of b))\nend mappendTuple",
"matching": "-- matching :: [a] -> (a -> Int -> [a] -> Bool)\n-- matching :: String -> (Char -> Int -> String -> Bool)\non matching(pat)\n -- Returns a sequence-matching function for findIndices etc\n if class of pat is text then\n set xs to characters of pat\n else\n set xs to pat\n end if\n set lng to length of xs\n set bln to 0 < lng\n if bln then\n set h to item 1 of xs\n else\n set h to missing value\n end if\n script\n on |λ|(x, i, src)\n (h = x) and xs = ¬\n (items i thru min(length of src, -1 + lng + i) of src)\n end |λ|\n end script\nend matching",
"matrix": "-- matrix :: Int -> Int -> ((Int, Int) -> a) -> [[a]]\ron matrix(nRows, nCols, f)\r -- A matrix of a given number of columns and rows,\r -- in which each value is a given function of its\r -- (zero-based) column and row indices.\r script go\r property g : mReturn(f)'s |λ|\r on |λ|(iRow)\r set xs to {}\r repeat with iCol from 1 to nCols\r set end of xs to g(iRow, iCol)\r end repeat\r xs\r end |λ|\r end script\r \r map(go, enumFromTo(1, nRows))\rend matrix",
"max": "-- max :: Ord a => a -> a -> a\non max(x, y)\n if gt(x, y) then\n x\n else\n y\n end if\nend max",
"maxBound": "-- maxBound :: a -> a\non maxBound(x)\n set c to class of x\n if text is c then\n character id 65535\n else if integer is c then\n (2 ^ 29 - 1)\n else if real is c then\n 1.797693E+308\n else if boolean is c then\n true\n end if\nend maxBound",
"maximum": "-- maximum :: Ord a => [a] -> a\non maximum(xs)\n set ca to current application\n unwrap((ca's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@max.self\")\nend maximum",
"maximumBy": "-- maximumBy :: (a -> a -> Ordering) -> [a] -> a\non maximumBy(f, xs)\n set cmp to mReturn(f)\n script max\n on |λ|(a, b)\n if a is missing value or cmp's |λ|(a, b) < 0 then\n b\n else\n a\n end if\n end |λ|\n end script\n \n foldl(max, missing value, xs)\nend maximumBy",
"maximumByMay": "-- maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a\non maximumByMay(f, xs)\n set cmp to mReturn(f)\n script max\n on |λ|(a, b)\n if a is missing value or cmp's |λ|(a, b) < 0 then\n b\n else\n a\n end if\n end |λ|\n end script\n \n foldl1May(max, xs)\nend maximumByMay",
"maximumMay": "-- maximumMay :: Ord a => [a] -> Maybe a\non maximumMay(xs)\n foldl1May(max, xs)\nend maximumMay",
"maybe": "-- maybe :: b -> (a -> b) -> Maybe a -> b\non maybe(v, f, mb)\n -- Either the default value v (if mb is Nothing),\n -- or the application of the function f to the \n -- contents of the Just value in mb.\n if Nothing of mb then\n v\n else\n tell mReturn(f) to |λ|(Just of mb)\n end if\nend maybe",
"mean": "-- mean :: [Num] -> Num\non mean(xs)\n set ca to current application\n ((ca's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@avg.self\") as real\nend mean",
"memberDict": "-- memberDict :: Key -> Dict -> Bool\non memberDict(k, dct)\n ((current application's ¬\n NSDictionary's dictionaryWithDictionary:dct)'s ¬\n objectForKey:k) is not missing value\nend member",
"memberSet": "-- memberSet :: a -> Set a -> Bool\non memberSet(x, oSet)\n oSet's containsObject:(x)\nend memberSet",
"min": "-- min :: Ord a => a -> a -> a\non min(x, y)\n if y < x then\n y\n else\n x\n end if\nend min",
"minBound": "-- minBound :: a -> a\non minBound(x)\n set c to class of x\n if text is c then\n character id 1\n else if integer is c then\n -(2 ^ 29 - 1)\n else if real is c then\n -1.797693E+308\n else if boolean is c then\n false\n end if\nend minBound",
"minimum": "-- minimum :: Ord a => [a] -> a\non minimum(xs)\n set ca to current application\n unwrap((ca's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@min.self\")\nend minimum",
"minimumBy": "-- minimumBy :: (a -> a -> Ordering) -> [a] -> a\non minimumBy(f, xs)\n set lng to length of xs\n if lng < 1 then\n missing value\n else if lng > 1 then\n tell mReturn(f)\n set v to item 1 of xs\n repeat with x in xs\n if |λ|(x, v) < 0 then set v to contents of x\n end repeat\n return v\n end tell\n else\n item 1 of xs\n end if\nend minimumBy",
"minimumByMay": "-- minimumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a\non minimumByMay(f, xs)\n set lng to length of xs\n if lng < 1 then\n Nothing()\n else if lng > 1 then\n tell mReturn(f)\n set v to item 1 of xs\n repeat with x in xs\n if |λ|(x, v) < 0 then set v to contents of x\n end repeat\n return Just(v)\n end tell\n else\n Just(item 1 of xs)\n end if\nend minimumByMay",
"minimumMay": "-- minimumMay :: [a] -> Maybe a\non minimumMay(xs)\n set lng to length of xs\n if lng < 1 then\n Nothing()\n else if lng > 1 then\n set m to item 1 of xs\n repeat with x in xs\n set v to contents of x\n if v < m then set m to v\n end repeat\n Just(m)\n else\n Just(item 1 of xs)\n end if\nend minimumMay",
"mod": "-- mod :: Int -> Int -> Int\non |mod|(n, d)\n -- The built-in infix `mod` inherits the sign of the \n -- *dividend* for non zero results. \n -- (i.e. the 'rem' pattern in some languages).\n --\n -- This version inherits the sign of the *divisor*.\n -- (A more typical 'mod' pattern, and useful,\n -- for example with biredirectional list rotations).\n if signum(n) = signum(-d) then\n (n mod d) + d\n else\n (n mod d)\n end if\nend |mod|",
"modificationTime": "-- modificationTime :: FilePath -> Either String Date\non modificationTime(fp)\n script fs\n on |λ|(rec)\n |Right|(NSFileModificationDate of rec)\n end |λ|\n end script\n bindLR(my fileStatus(fp), fs)\nend modificationTime",
"mul": "-- mul (*) :: Num a => a -> a -> a\non mul(a)\n -- Curried multiplication.\n script\n on |λ|(b)\n a * b\n end |λ|\n end script\nend mul",
"ne": "-- ne :: a -> a -> Bool\non ne(a)\n script\n on |λ|(b)\n a ≠ b\n end |λ|\n end script\nend ne",
"negate": "-- negate :: Num -> Num\non |negate|(n)\n -n\nend |negate|",
"nest": "-- nest :: Tree a -> [a]\non nest(oTree)\n nest of oTree\nend nest",
"newUUID": "-- newUUID :: () -> IO UUID String\non newUUID()\n current application's NSUUID's UUID's UUIDString as string\nend newUUID",
"not": "-- not :: Bool -> Bool\non |not|(p)\n -- `not` as a composable and mappable function.\n not p\nend |not|",
"notElem": "-- notElem :: Eq a => a -> [a] -> Bool\non notElem(x, xs)\n xs does not contain x\nend notElem",
"nub": "-- nub :: [a] -> [a]\non nub(xs)\n ((current application's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@distinctUnionOfObjects.self\") as list\nend nub",
"nubBy": "-- nubBy :: (a -> a -> Bool) -> [a] -> [a]\non nubBy(f, xs)\n set g to mReturn(f)'s |λ|\n \n script notEq\n property fEq : g\n on |λ|(a)\n script\n on |λ|(b)\n not fEq(a, b)\n end |λ|\n end script\n end |λ|\n end script\n \n script go\n on |λ|(xs)\n if (length of xs) > 1 then\n set x to item 1 of xs\n {x} & go's |λ|(filter(notEq's |λ|(x), items 2 thru -1 of xs))\n else\n xs\n end if\n end |λ|\n end script\n \n go's |λ|(xs)\nend nubBy",
"odd": "-- odd :: Int -> Bool\non odd(x)\n not even(x)\nend odd",
"on": "-- on :: (b -> b -> c) -> (a -> b) -> a -> a -> c\non |on|(f, g)\n -- e.g. sortBy(|on|(compare, |length|), [\"epsilon\", \"mu\", \"gamma\", \"beta\"])\n script\n on |λ|(a, b)\n tell mReturn(g) to set {va, vb} to {|λ|(a), |λ|(b)}\n tell mReturn(f) to |λ|(va, vb)\n end |λ|\n end script\nend |on|",
"or": "-- or :: [Bool] -> Bool\non |or|(ps)\n repeat with p in ps\n if p then return true\n end repeat\n return false\nend |or|",
"ord": "-- ord :: Char -> Int\non ord(c)\n id of c\nend ord",
"orderedUnion": "-- orderedUnion :: [a] -> [a] -> [a]\ron orderedUnion(xs, ys)\r (union(setFromList(xs), setFromList(ys))'s ¬\r allObjects()'s sortedArrayUsingSelector:\"compare:\") as list\rend orderedUnion",
"ordering": "-- ordering :: () -> Ordering\non ordering()\n enumFromPairs(\"Ordering\", {{\"LT\", -1}, {\"EQ\", 0}, {\"GT\", 1}})\nend ordering",
"outdented": "-- All lines in the string outdented by the same amount\n-- (just enough to ensure that the least indented lines \n-- have no remaining indent)\n-- All relative indents are left unchanged\n-- outdented :: String -> String\non outdented(s)\n set xs to |lines|(s)\n script dent\n on |λ|(x)\n script isSpace\n on |λ|(c)\n id of c = 32\n end |λ|\n end script\n length of takeWhile(isSpace, x)\n end |λ|\n end script\n set n to |λ|(minimumBy(comparing(dent), xs)) of dent\n if n < 1 then\n s\n else\n unlines(map(|λ|(n) of curry(drop), xs))\n end if\nend outdented",
"partition": "-- partition :: (a -> Bool) -> [a] -> ([a], [a])\non partition(f, xs)\n tell mReturn(f)\n set ys to {}\n set zs to {}\n repeat with x in xs\n set v to contents of x\n if |λ|(v) then\n set end of ys to v\n else\n set end of zs to v\n end if\n end repeat\n end tell\n Tuple(ys, zs)\nend partition",
"partitionEithers": "-- partitionEithers :: [Either a b] -> ([a],[b])\non partitionEithers(xs)\n set ys to {}\n set zs to {}\n repeat with x in xs\n if isRight(x) then\n set end of zs to x\n else\n set end of ys to x\n end if\n end repeat\n Tuple(ys, zs)\nend partitionEithers",
"permutations": "-- permutations :: [a] -> [[a]]\non permutations(xs)\n script go\n on |λ|(x, a)\n script\n on |λ|(ys)\n script infix\n on |λ|(n)\n if ys ≠ {} then\n take(n, ys) & x & drop(n, ys)\n else\n {x}\n end if\n end |λ|\n end script\n map(infix, enumFromTo(0, (length of ys)))\n end |λ|\n end script\n concatMap(result, a)\n end |λ|\n end script\n foldr(go, {{}}, xs)\nend permutations",
"permutationsWithRepetition": "-- permutationsWithRepetition :: Int -> [a] -> [[a]]\non permutationsWithRepetition(n, xs)\n if 0 < length of xs then\n foldl1(curry(my cartesianProduct)'s |λ|(xs), replicate(n, xs))\n else\n {}\n end if\nend permutationsWithRepetition",
"pi": "-- pi :: Float\non |pi|()\n pi\nend |pi|",
"plus": "-- plus :: Num -> Num -> Num\non plus(a, b)\n a + b\nend plus",
"postorder": "-- Root elements of tree flattened bottom-up\n-- into a postorder list.\n-- postorder :: Tree a -> [a]\non postorder(node)\n script go\n on |λ|(xs, x)\n foldl(go, xs, nest of x) & {root of x}\n end |λ|\n end script\n go's |λ|({}, node)\nend postorder",
"pred": "-- pred :: Enum a => a -> a\non pred(x)\n if isChar(x) then\n chr(ord(x) - 1)\n else\n (-1) + x\n end if\nend pred",
"predMay": "-- predMay :: Enum a => a -> Maybe a\non predMay(x)\n if x is minBound(x) then\n Nothing()\n else\n Just(toEnum(x)'s |λ|(fromEnum(x) - 1))\n end if\nend predMay",
"print": "-- print :: a -> IO ()\non print (x)\n log x\n return x\nend print",
"product": "-- product :: [Num] -> Num\non product(xs)\n script multiply\n on |λ|(a, b)\n a * b\n end |λ|\n end script\n \n foldl(multiply, 1, xs)\nend product",
"properFracRatio": "-- properFracRatio :: Ratio -> (Int, Ratio)\non properFracRatio(r)\n set n to n of r\n set d to d of r\n Tuple(n div d, ratio(n mod d, d))\nend properFracRatio",
"properFraction": "-- properFraction :: Real -> (Int, Real)\non properFraction(n)\n set i to (n div 1)\n Tuple(i, n - i)\nend properFraction",
"pureLR": "-- pureLR :: a -> Either e a\non pureLR(x)\n |Right|(x)\nend pureLR",
"pureList": "-- pureList :: a -> [a]\non pureList(x)\n {x}\nend pure",
"pureMay": "-- pureMay :: a -> Maybe a\non pureMay(x)\n Just(x)\nend pureMay",
"pureT": "-- Given a type name string, returns a \n-- specialised 'pure', where\n-- 'pure' lifts a value into a particular functor.\n-- pureT :: String -> f a -> (a -> f a)\non pureT(t, x)\n if \"List\" = t then\n pureList(x)\n else if \"Either\" = t then\n pureLR(x)\n else if \"Maybe\" = t then\n pureMay(x)\n else if \"Node\" = t then\n pureTree(x)\n else if \"Tuple\" = t then\n pureTuple(x)\n else\n pureList(x)\n end if\nend pureT",
"pureTree": "-- pureTree :: a -> Tree a\non pureTree(x)\n Node(x, {})\nend pureTree",
"pureTuple": "-- pureTuple :: a -> (a, a)\non pureTuple(x)\n Tuple(\"\", x)\nend pureTuple",
"quickSort": "-- quickSort :: (Ord a) => [a] -> [a]\non quickSort(xs)\n -- Adequate for small sorts, but sort (Ord a => [a] -> [a]), (which uses the ObjC\n -- sortedArrayUsingSelector) is the one to use\n if length of xs > 1 then\n set h to item 1 of xs\n script\n on |λ|(x)\n x ≤ h\n end |λ|\n end script\n set {less, more} to partition(result, rest of xs)\n quickSort(less) & h & quickSort(more)\n else\n xs\n end if\nend quickSort",
"quickSortBy": "-- quickSortBy :: (a -> a -> Ordering) -> [a] -> [a]\non quickSortBy(cmp, xs)\n -- quickSortBy(comparing(my |length|), \n -- {\"alpha\", \"beta\", \"gamma\", \"delta\", \"epsilon\", \"zeta\", \n -- \"eta\", \"theta\", \"iota\", \"kappa\", \"lambda\", \"mu\"})\n if length of xs > 1 then\n set h to item 1 of xs\n script\n on |λ|(x)\n cmp's |λ|(x, h) ≠ 1\n end |λ|\n end script\n set {less, more} to partition(result, rest of xs)\n quickSortBy(cmp, less) & h & quickSortBy(cmp, more)\n else\n xs\n end if\nend quickSortBy",
"quot": "-- quot :: Int -> Int -> Int\non quot(m, n)\n m div n\nend quot",
"quotRem": "-- quotRem :: Int -> Int -> (Int, Int)\non quotRem(m, n)\n {m div n, m mod n}\nend quotRem",
"quoted": "-- quoted :: Char -> String -> String\non quoted(c)\n -- A string flanked on both sides\n -- by a specified quote character.\n script\n on |λ|(s)\n c & s & c\n end |λ|\n end script\nend quoted",
"radians": "-- radians :: Float x => Degrees x -> Radians x\non radians(x)\n (pi / 180) * x\nend radians",
"raise": "-- raise :: Num -> Int -> Num\non raise(m, n)\n m ^ n\nend raise",
"randomRInt": "-- e.g. map(randomRInt(1, 10), ft(1, 20))\n-- randomRInt :: Int -> Int -> IO () -> Int\non randomRInt(low, high)\n script\n on |λ|(_)\n (low + ((random number) * (1 + (high - low)))) div 1\n end |λ|\n end script\nend randomRInt",
"range": "-- range :: Ix a => (a, a) -> [a]\non range(ab)\n set {a, b} to {|1| of ab, |2| of ab}\n if class of a is list then\n set {xs, ys} to {a, b}\n else\n set {xs, ys} to {{a}, {b}}\n end if\n set lng to length of xs\n \n if lng = length of ys then\n if lng > 1 then\n script\n on |λ|(_, i)\n enumFromTo(item i of xs, item i of ys)\n end |λ|\n end script\n sequence(map(result, xs))\n else\n enumFromTo(a, b)\n end if\n else\n {}\n end if\nend range",
"ratio": "-- ratio :: Int -> Int -> Ratio Int\non ratio(x, y)\n script go\n on |λ|(x, y)\n if 0 ≠ y then\n if 0 ≠ x then\n set d to gcd(x, y)\n {type:\"Ratio\", n:(x div d), d:(y div d)}\n else\n {type:\"Ratio\", n:0, d:0}\n end if\n else\n missing value\n end if\n end |λ|\n end script\n go's |λ|(x * (signum(y)), abs(y))\nend ratio",
"ratioDiv": "-- ratioDiv :: Rational -> Rational -> Rational\non ratioDiv(n1, n2)\n set r1 to rational(n1)\n set r2 to rational(n2)\n ratio((n of r1) * (d of r2), (d of r1) * (n of r2))\nend ratioDiv",
"ratioMinus": "-- ratioMinus :: Rational -> Rational -> Rational\non ratioMinus(n1, n2)\n set r1 to rational(n1)\n set r2 to rational(n2)\n set d to lcm(d of r1, d of r2)\n ratio((n of r1) * (d / (d of r1) - ¬\n ((n of r2) * (d / (d of r2)))), d)\nend ratioMinus",
"ratioMult": "-- ratioMult :: Rational -> Rational -> Rational\non ratioMult(n1, n2)\n set r1 to rational(n1)\n set r2 to rational(n2)\n ratio((n of r1) * (n of r2), (d of r1) * (d of r2))\nend ratioMult",
"ratioPlus": "-- ratioPlus :: Rational -> Rational -> Rational\non ratioPlus(n1, n2)\n set r1 to rational(n1)\n set r2 to rational(n2)\n set d to lcm(d of r1, d of r2)\n ratio((n of r1) * (d / (d of r1) + ¬\n ((n of r2) * (d / (d of r2)))), d)\nend ratioPlus",
"rational": "-- rational :: Num a => a -> Rational\non rational(x)\n set c to class of x\n if integer is c then\n ratio(x, 1)\n else if real is c then\n approxRatio(missing value, x)\n else\n x\n end if\nend rational",
"read": "-- read :: Read a => String -> a\non read (s)\n run script s\nend read",
"readBinary": "-- readBinary :: String -> Int\non readBinary(s)\n -- The integer value of the binary string s\n script go\n on |λ|(c, en)\n set {e, n} to en\n set v to ((id of c) - 48)\n \n {2 * e, v * e + n}\n end |λ|\n end script\n \n item 2 of foldr(go, {1, 0}, s)\nend readBinary",
"readFile": "-- readFile :: FilePath -> IO String\non readFile(strPath)\n set ca to current application\n set e to reference\n set {s, e} to (ca's NSString's ¬\n stringWithContentsOfFile:((ca's NSString's ¬\n stringWithString:strPath)'s ¬\n stringByStandardizingPath) ¬\n encoding:(ca's NSUTF8StringEncoding) |error|:(e))\n if missing value is e then\n s as string\n else\n (localizedDescription of e) as string\n end if\nend readFile",
"readFileLR": "-- readFileLR :: FilePath -> Either String IO String\non readFileLR(strPath)\n set ca to current application\n set e to reference\n set {s, e} to (ca's NSString's ¬\n stringWithContentsOfFile:((ca's NSString's ¬\n stringWithString:strPath)'s ¬\n stringByStandardizingPath) ¬\n encoding:(ca's NSUTF8StringEncoding) |error|:(e))\n if s is missing value then\n |Left|((localizedDescription of e) as string)\n else\n |Right|(s as string)\n end if\nend readFileLR",
"readHex": "-- readHex :: String -> Int\non readHex(s)\n -- The integer value of the given hexadecimal string.\n set ds to \"0123456789ABCDEF\"\n script go\n on |λ|(c, a)\n set {v, e} to a\n set i to maybe(0, my identity, elemIndex(c, ds))\n {v + (i * e), 16 * e}\n end |λ|\n end script\n item 1 of foldr(go, {0, 1}, characters of s)\nend readHex",
"readLR": "-- readLR :: Read a => String -> Either String a\non readLR(s)\n try\n |Right|(run script s)\n on error e\n |Left|(e)\n end try\nend readLR",
"recip": "-- recip :: Num -> Num\non recip(n)\n if n ≠ 0 then\n 1 / n\n else\n missing value\n end if\nend recip",
"recipMay": "-- recipMay :: Num -> Maybe Num\non recipMay(n)\n if n ≠ 0 then\n Just(1 / n)\n else\n Nothing()\n end if\nend recipMay",
"regexMatches": "-- regexMatches :: Regex String -> String -> [[String]]\ron regexMatches(strRegex, strHay)\r\tset ca to current application\r\t-- NSNotFound handling and and High Sierra workaround due to @sl1974\r\tset NSNotFound to a reference to 9.22337203685477E+18 + 5807\r\tset oRgx to ca's NSRegularExpression's regularExpressionWithPattern:strRegex ¬\r\t\toptions:((ca's NSRegularExpressionAnchorsMatchLines as integer)) ¬\r\t\t|error|:(missing value)\r\tset oString to ca's NSString's stringWithString:strHay\r\t\r\tscript matchString\r\t\ton |λ|(m)\r\t\t\tscript rangeMatched\r\t\t\t\ton |λ|(i)\r\t\t\t\t\ttell (m's rangeAtIndex:i)\r\t\t\t\t\t\tset intFrom to its location\r\t\t\t\t\t\tif NSNotFound ≠ intFrom then\r\t\t\t\t\t\t\ttext (intFrom + 1) thru (intFrom + (its |length|)) of strHay\r\t\t\t\t\t\telse\r\t\t\t\t\t\t\tmissing value\r\t\t\t\t\t\tend if\r\t\t\t\t\tend tell\r\t\t\t\tend |λ|\r\t\t\tend script\r\t\tend |λ|\r\tend script\r\t\r\tscript asRange\r\t\ton |λ|(x)\r\t\t\trange() of x\r\t\tend |λ|\r\tend script\r\tmap(asRange, (oRgx's matchesInString:oString ¬\r\t\toptions:0 range:{location:0, |length|:oString's |length|()}) as list)\rend regexMatches",
"rem": "-- rem :: Int -> Int -> Int\non rem(m, n)\n m mod n\nend rem",
"removeFile": "-- removeFile :: FilePath -> Either String String\non removeFile(fp)\n set e to reference\n set {bln, obj} to current application's NSFileManager's ¬\n defaultManager's removeItemAtPath:(fp) |error|:(e)\n if bln then\n |Right|(\"Removed: \" & fp)\n else\n |Left|(obj's localizedDescription as string)\n end if\nend removeFile",
"renamedFile": "-- renamedFile :: FilePath -> FilePath ->\n-- Either IO String IO String\non renamedFile(fp, fp2)\n set e to reference\n set {bln, obj} to current application's NSFileManager's ¬\n defaultManager's moveItemAtPath:(fp) toPath:(fp2) |error|:(e)\n if bln then\n |Right|(fp2)\n else\n |Left|(obj's localizedDescription as string)\n end if\nend renameFile",
"repeat": "-- repeat :: a -> Generator [a]\non |repeat|(x)\n script\n on |λ|()\n return x\n end |λ|\n end script\nend |repeat|",
"replace": "-- replace :: String -> String -> String -> String\non replace(strNeedle, strNew, strHayStack)\n set {dlm, my text item delimiters} to {my text item delimiters, strNeedle}\n set xs to text items of strHayStack\n set my text item delimiters to strNew\n set strReplaced to xs as text\n set my text item delimiters to dlm\n return strReplaced\nend replace",
"replicate": "-- Egyptian multiplication - progressively doubling a list, appending\n-- stages of doubling to an accumulator where needed for binary \n-- assembly of a target length\n-- replicate :: Int -> String -> String\non replicate(n, s)\n -- Egyptian multiplication - progressively doubling a list, \n -- appending stages of doubling to an accumulator where needed \n -- for binary assembly of a target length\n script p\n on |λ|({n})\n n ≤ 1\n end |λ|\n end script\n \n script f\n on |λ|({n, dbl, out})\n if (n mod 2) > 0 then\n set d to out & dbl\n else\n set d to out\n end if\n {n div 2, dbl & dbl, d}\n end |λ|\n end script\n \n set xs to |until|(p, f, {n, s, \"\"})\n item 2 of xs & item 3 of xs\nend replicate",
"replicateM": "-- Instance for lists only here\n\n-- e.g. replicateM(3, {1, 2})) -> \n-- {{1, 1, 1}, {1, 1, 2}, {1, 2, 1}, {1, 2, 2}, {2, 1, 1}, \n-- {2, 1, 2}, {2, 2, 1}, {2, 2, 2}}\n-- replicateM :: Int -> [a] -> [[a]]\non replicateM(n, xs)\n script go\n script cons\n on |λ|(a, bs)\n {a} & bs\n end |λ|\n end script\n on |λ|(x)\n if x ≤ 0 then\n {{}}\n else\n liftA2List(cons, xs, |λ|(x - 1))\n end if\n end |λ|\n end script\n \n go's |λ|(n)\nend replicateM",
"replicateString": "-- replicateString :: Int -> String -> String\non replicateString(n, s)\n set out to \"\"\n if n < 1 then return out\n set dbl to s\n \n repeat while (n > 1)\n if (n mod 2) > 0 then set out to out & dbl\n set n to (n div 2)\n set dbl to (dbl & dbl)\n end repeat\n return out & dbl\nend replicateS",
"reverse": "-- reverse :: [a] -> [a]\non |reverse|(xs)\n if class of xs is text then\n (reverse of characters of xs) as text\n else\n reverse of xs\n end if\nend |reverse|",
"rights": "-- rights :: [Either a b] -> [b]\non rights(xs)\n script\n on |λ|(x)\n if class of x is record then\n set ks to keys(x)\n if ks contains \"type\" and ks contains \"Right\" then\n {|Right| of x}\n else\n {}\n end if\n else\n {}\n end if\n end |λ|\n end script\n concatMap(result, xs)\nend rights",
"root": "-- root :: Tree a -> a\non root(oTree)\n root of oTree\nend root",
"rotate": "-- rotate :: Int -> [a] -> [a]\non rotate(n, xs)\n set lng to |length|(xs)\n if missing value is not lng then\n take(lng, drop(lng - n, cycle(xs)))\n else\n lng\n end if\nend rotate",
"rotated": "-- rotated :: Int -> [a] -> [a]\non rotated(n, xs)\n set lng to length of xs\n set m to |mod|(n, lng)\n \n if 0 ≠ n then\n (items (1 + m) thru -1 of xs) & ¬\n (items 1 thru m of xs)\n else\n xs\n end if\nend rotated",
"round": "-- round :: a -> Int\non |round|(n)\n round n\nend |round|",
"roundTo": "-- Float x rounded to n decimals\n-- roundTo :: Int -> Float -> Float\ron roundTo(n, x)\r\tset d to 10 ^ n\r\t(round (x * d)) / d\rend roundTo",
"runAction": "-- runAction :: Action a -> a\non runAction(act)\n -- Evaluation of an action.\n tell act to |λ|(its arg) of my mReturn(its act)\nend runAction",
"safeMay": "-- safeMay :: (a -> Bool) -> (a -> b) -> Maybe b\non safeMay(p, f, x)\n if p(x) then\n Just(f(x))\n else\n Nothing()\n end if\nend safeMay",
"scanl": "-- scanl :: (b -> a -> b) -> b -> [a] -> [b]\non scanl(f, startValue, xs)\n tell mReturn(f)\n set v to startValue\n set lng to length of xs\n set lst to {startValue}\n repeat with i from 1 to lng\n set v to |λ|(v, item i of xs, i, xs)\n set end of lst to v\n end repeat\n return lst\n end tell\nend scanl",
"scanl1": "-- scanl1 :: (a -> a -> a) -> [a] -> [a]\non scanl1(f, xs)\n if 0 < length of xs then\n scanl(f, item 1 of xs, rest of xs)\n else\n {}\n end if\nend scanl",
"scanr": "-- scanr :: (b -> a -> b) -> b -> [a] -> [b]\non scanr(f, startValue, xs)\n tell mReturn(f)\n set v to startValue\n set lng to length of xs\n set lst to {startValue}\n repeat with i from lng to 1 by -1\n set v to |λ|(v, item i of xs, i, xs)\n set end of lst to v\n end repeat\n return reverse of lst\n end tell\nend scanr",
"scanr1": "-- scanr1 :: (a -> a -> a) -> [a] -> [a]\non scanr1(f, xs)\n if length of xs > 0 then\n scanr(f, item -1 of xs, init(xs))\n else\n {}\n end if\nend scanr1",
"second": "-- second :: (a -> b) -> ((c, a) -> (c, b))\non |second|(f)\n-- Lift a simple function to one which applies to a tuple, \n-- transforming only the second item of that tuple\n script\n on |λ|(xy)\n Tuple(|1| of xy, mReturn(f)'s |λ|(|2| of xy))\n end |λ|\n end script\nend |second|",
"sequenceA": "-- sequenceA :: (Applicative f, Traversable t) => t (f a) -> f (t a)\non sequenceA(tfa)\n script identity\n on |λ|(x)\n x\n end |λ|\n end script\n traverse(identity, tfa)\nend sequenceA",
"setCurrentDirectory": "-- setCurrentDirectory :: String -> IO ()\non setCurrentDirectory(strPath)\n if doesDirectoryExist(strPath) then\n set ca to current application\n set oPath to (ca's NSString's stringWithString:strPath)'s ¬\n stringByStandardizingPath\n ca's NSFileManager's defaultManager()'s ¬\n changeCurrentDirectoryPath:oPath\n end if\nend setCurrentDirectory",
"setFromList": "-- setFromList :: Ord a => [a] -> Set a\non setFromList(xs)\n -- NB All names of NSMutableSets should be set to *missing value*\n -- before the script exits.\n -- ( scpt files can not be saved if they contain ObjC pointer values)\n set ca to current application\n ca's NSMutableSet's ¬\n setWithArray:(ca's NSArray's arrayWithArray:(xs))\nend setFromList",
"setInsert": "-- setInsert :: Ord a => a -> Set a -> Set a\non setInsert(x, objcSet)\n objcSet's addObject:(x)\n objcSet\nend setInsert",
"setMember": "-- setMember :: Ord a => a -> Set a -> Bool\non setMember(x, objcSet)\n missing value is not (objcSet's member:(x))\nend setMember",
"setSize": "-- setSize :: Set a -> Int\non setSize(objcSet)\n objcSet's |count|() as integer\nend setSize",
"shift": "-- shift :: Int -> [a] -> [a]\non shift(n, xs)\n set lng to |length|(xs)\n if missing value is not lng then\n take(lng, drop(n, cycle(xs)))\n else\n drop(n, xs)\n end if\nend shift",
"show": "-- show :: a -> String\non show(e)\n set c to class of e\n if c = list then\n showList(e)\n else if c = record then\n set mb to lookupDict(\"type\", e)\n if Nothing of mb then\n showDict(e)\n else\n script\n on |λ|(t)\n if \"Either\" = t then\n set f to my showLR\n else if \"Maybe\" = t then\n set f to my showMaybe\n else if \"Ordering\" = t then\n set f to my showOrdering\n else if \"Ratio\" = t then\n set f to my showRatio\n else if class of t is text and t begins with \"Tuple\" then\n set f to my showTuple\n else\n set f to my showDict\n end if\n tell mReturn(f) to |λ|(e)\n end |λ|\n end script\n tell result to |λ|(Just of mb)\n end if\n else if c = date then\n \"\\\"\" & showDate(e) & \"\\\"\"\n else if c = text then\n \"'\" & e & \"'\"\n else if (c = integer or c = real) then\n e as text\n else if c = class then\n \"null\"\n else\n try\n e as text\n on error\n (\"«\" & c as text) & \"»\"\n end try\n end if\nend show",
"showBinary": "-- showBinary :: Int -> String\non showBinary(n)\n script binaryChar\n on |λ|(n)\n character id (48 + n)\n end |λ|\n end script\n \n showIntAtBase(2, binaryChar, n, \"\")\nend showBinary",
"showDate": "-- ISO 8601 UTC \n-- showDate :: Date -> String\non showDate(dte)\n ((dte - (time to GMT)) as «class isot» as string) & \".000Z\"\nend showDate",
"showDict": "-- showDict :: Dict -> String\non showDict(dct)\n showJSON(dct)\nend showDict",
"showForest": "-- showForest :: [Tree a] -> String\non showForest(xs)\n unlines(map(my showTree, xs))\nend showForest",
"showHex": "-- showHex :: Int -> String\non showHex(n)\n showIntAtBase(16, mReturn(intToDigit), n, \"\")\nend showHex",
"showIntAtBase": "-- showIntAtBase :: Int -> (Int -> Char) -> Int -> String -> String\non showIntAtBase(base, toDigit, n, rs)\n script go\n property f : mReturn(toDigit)\n on |λ|(nd_, r)\n set {n, d} to nd_\n set r_ to f's |λ|(d) & r\n if n > 0 then\n |λ|(quotRem(n, base), r_)\n else\n r_\n end if\n end |λ|\n end script\n |λ|(quotRem(n, base), rs) of go\nend showIntAtBase",
"showJSON": "-- showJSON :: a -> String\ron showJSON(x)\r set c to class of x\r if (c is list) or (c is record) then\r set ca to current application\r set json to ca's NSJSONSerialization's dataWithJSONObject:x options:1 |error|:(missing value)\r if json is missing value then\r \"Could not serialize as JSON\"\r else\r (ca's NSString's alloc()'s initWithData:json encoding:(ca's NSUTF8StringEncoding)) as text\r end if\r else if c is date then\r \"\\\"\" & ((x - (time to GMT)) as «class isot» as string) & \".000Z\" & \"\\\"\"\r else if c is text then\r \"\\\"\" & x & \"\\\"\"\r else if (c is integer or c is real) then\r x as text\r else if c is class then\r \"null\"\r else\r try\r x as text\r on error\r (\"«\" & c as text) & \"»\"\r end try\r end if\rend showJSON",
"showLR": "-- showLR :: Either a b -> String\non showLR(lr)\n if isRight(lr) then\n \"Right(\" & unQuoted(show(|Right| of lr)) & \")\"\n else\n \"Left(\" & unQuoted(show(|Left| of lr)) & \")\"\n end if\nend showLR",
"showList": "-- showList :: [a] -> String\non showList(xs)\n \"[\" & intercalateS(\", \", map(my show, xs)) & \"]\"\nend showList",
"showLog": "-- showLog :: a -> IO ()\non showLog(e)\n log show(e)\nend showLog",
"showMatrix": "-- showMatrix :: [[Maybe a]] -> String\ron showMatrix(rows)\r -- String representation of rows\r -- as a matrix.\r \r script showRow\r on |λ|(a, row)\r set {maxWidth, prevRows} to a\r script showCell\r on |λ|(acc, cell)\r set {w, xs} to acc\r if missing value is cell then\r {w, xs & \"\"}\r else\r set s to cell as string\r {max(w, length of s), xs & s}\r end if\r end |λ|\r end script\r \r set {rowMax, cells} to foldl(showCell, {0, {}}, row)\r {max(maxWidth, rowMax), prevRows & {cells}}\r end |λ|\r end script\r \r set {w, stringRows} to foldl(showRow, {0, {}}, rows)\r script go\r on |λ|(row)\r unwords(map(justifyRight(w, space), row))\r end |λ|\r end script\r \r unlines(map(go, stringRows))\rend showMatrix",
"showMaybe": "-- showMaybe :: Maybe a -> String\non showMaybe(mb)\n if Nothing of mb then\n \"Nothing\"\n else\n \"Just \" & unQuoted(show(Just of mb))\n end if\nend showMaybe",
"showOrdering": "-- showOrdering :: Ordering -> String\non showOrdering(e)\n set v to value of e\n if v > 0 then\n \"GT\"\n else if v < 0 then\n \"LT\"\n else\n \"EQ\"\n end if\nend showOrdering",
"showOutline": "-- showOutline :: Tree String -> String\non showOutline(x)\n script go\n on |λ|(indent)\n script\n on |λ|(tree)\n {indent & (root of tree)} & ¬\n concatMap(go's |λ|(tab & indent), ¬\n nest of tree)\n end |λ|\n end script\n end |λ|\n end script\n unlines((go's |λ|(\"\"))'s |λ|(x))\nend showOutline",
"showPrecision": "-- showPrecision :: Int -> Float -> String\non showPrecision(n, x)\n set d to 10 ^ n\n ((round (x * d)) / d) as string\nend showPrecision",
"showRatio": "-- showRatio :: Ratio -> String\non showRatio(r)\n set s to (n of r as string)\n set d to d of r\n if 1 ≠ d then\n s & \"/\" & (d as string)\n else\n s\n end if\nend showRatio",
"showSet": "-- showSet :: Set a -> String\non showSet(s)\n script str\n on |λ|(x)\n x as string\n end |λ|\n end script\n \"{\" & intercalate(\", \", map(str, sort(elems(s)))) & \"}\"\nend showSet",
"showTree": "-- showTree :: Tree a -> String\non showTree(tree)\n script str\n on |λ|(x)\n x as string\n end |λ|\n end script\n drawTree2(false, true, fmapTree(str, tree))\nend showTree",
"showTuple": "-- showTuple :: Tuple -> String\non showTuple(tpl)\n set ca to current application\n script\n on |λ|(n)\n set v to (ca's NSDictionary's dictionaryWithDictionary:tpl)'s objectForKey:(n as string)\n if v ≠ missing value then\n unQuoted(show(item 1 of ((ca's NSArray's arrayWithObject:v) as list)))\n else\n missing value\n end if\n end |λ|\n end script\n \"(\" & intercalateS(\", \", map(result, enumFromTo(1, length of tpl))) & \")\"\nend showTuple",
"showUndefined": "-- showUndefined :: () -> String\non showUndefined()\n \"⊥\"\nend showUndefined",
"signum": "-- signum :: Num -> Num\non signum(x)\n if x < 0 then\n -1\n else if x = 0 then\n 0\n else\n 1\n end if\nend signum",
"sj": "-- Abbreviation for quick testing\n-- sj :: a -> String\non sj(x)\n showJSON(x)\nend sj",
"snd": "-- snd :: (a, b) -> b\non snd(tpl)\n if class of tpl is record then\n |2| of tpl\n else\n item 2 of tpl\n end if\nend snd",
"snoc": "-- Mirror image of cons\n-- New copy of the list, with an atom added at the end\n-- snoc :: [a] -> a -> [a]\non snoc(xs, x)\n xs & {x}\nend snoc",
"sort": "-- sort :: Ord a => [a] -> [a]\non sort(xs)\n ((current application's NSArray's arrayWithArray:xs)'s ¬\n sortedArrayUsingSelector:\"compare:\") as list\nend sort",
"sortBy": "-- sortBy :: (a -> a -> Ordering) -> [a] -> [a]\non sortBy(f, xs)\n -- Enough for small scale sorts.\n -- Use instead sortOn (Ord b => (a -> b) -> [a] -> [a])\n -- which is equivalent to the more flexible sortBy(comparing(f), xs)\n -- and uses a much faster ObjC NSArray sort method\n if length of xs > 1 then\n set h to item 1 of xs\n set f to mReturn(f)\n script\n on |λ|(x)\n f's |λ|(x, h) ≤ 0\n end |λ|\n end script\n set lessMore to partition(result, rest of xs)\n sortBy(f, |1| of lessMore) & {h} & ¬\n sortBy(f, |2| of lessMore)\n else\n xs\n end if\nend sortBy",
"sortOn": "-- sortOn :: Ord b => (a -> b) -> [a] -> [a]\r-- sortOn :: Ord b => [((a -> b), Bool)] -> [a] -> [a]\ron sortOn(f, xs)\r\t-- Sort a list by comparing the results of a key function applied to each\r\t-- element. sortOn f is equivalent to sortBy(comparing(f), xs), but has the\r\t-- performance advantage of only evaluating f once for each element in\r\t-- the input list. This is called the decorate-sort-undecorate paradigm,\r\t-- or Schwartzian transform.\r\t-- Elements are arranged from from lowest to highest.\r\t\r\t-- In this Applescript implementation, f can optionally be [(a -> b)]\r\t-- or [((a -> b), Bool)]) to specify a compound sort order\r\t\r\t-- xs: List of items to be sorted. \r\t-- (The items can be records, lists, or simple values).\r\t--\r\t-- f: A single (a -> b) function (Applescript handler),\r\t-- or a list of such functions.\r\t-- if the argument is a list, any function can \r\t-- optionally be followed by a bool. \r\t-- (False -> descending sort)\r\t--\r\t-- (Subgrouping in the list is optional and ignored)\r\t-- Each function (Item -> Value) in the list should \r\t-- take an item (of the type contained by xs) \r\t-- as its input and return a simple orderable value \r\t-- (Number, String, or Date).\r\t--\r\t-- The sequence of key functions and optional \r\t-- direction bools defines primary to N-ary sort keys.\r\tscript keyBool\r\t\ton |λ|(x, a)\r\t\t\tif boolean is class of x then\r\t\t\t\t{asc:x, fbs:fbs of a}\r\t\t\telse\r\t\t\t\t{asc:true, fbs:({Tuple(x, asc of a)} & fbs of a)}\r\t\t\tend if\r\t\tend |λ|\r\tend script\r\tset {fs, bs} to {|1|, |2|} of unzip(fbs of foldr(keyBool, ¬\r\t\t{asc:true, fbs:{}}, flatten({f})))\r\t\r\tset intKeys to length of fs\r\tset ca to current application\r\tscript dec\r\t\tproperty gs : map(my mReturn, fs)\r\t\ton |λ|(x)\r\t\t\tset nsDct to (ca's NSMutableDictionary's ¬\r\t\t\t\tdictionaryWithDictionary:{val:x})\r\t\t\trepeat with i from 1 to intKeys\r\t\t\t\t(nsDct's setValue:((item i of gs)'s |λ|(x)) ¬\r\t\t\t\t\tforKey:(character id (96 + i)))\r\t\t\tend repeat\r\t\t\tnsDct as record\r\t\tend |λ|\r\tend script\r\t\r\tscript descrip\r\t\ton |λ|(bool, i)\r\t\t\tca's NSSortDescriptor's ¬\r\t\t\t\tsortDescriptorWithKey:(character id (96 + i)) ¬\r\t\t\t\t\tascending:bool\r\t\tend |λ|\r\tend script\r\t\r\tscript undec\r\t\ton |λ|(x)\r\t\t\tval of x\r\t\tend |λ|\r\tend script\r\t\r\tmap(undec, ((ca's NSArray's arrayWithArray:map(dec, xs))'s ¬\r\t\tsortedArrayUsingDescriptors:map(descrip, bs)) as list)\rend sortOn",
"span": "-- span :: (a -> Bool) -> [a] -> ([a], [a])\non span(p, xs)\n -- The longest (possibly empty) prefix of xs\n -- that contains only elements satisfying p,\n -- tupled with the remainder of xs.\n -- span(p, xs) eq (takeWhile(p, xs), dropWhile(p, xs)) \n script go\n property mp : mReturn(p)\n on |λ|(vs)\n if {} ≠ vs then\n set x to item 1 of vs\n if |λ|(x) of mp then\n set {ys, zs} to |λ|(rest of vs)\n {{x} & ys, zs}\n else\n {{}, vs}\n end if\n else\n {{}, {}}\n end if\n end |λ|\n end script\n |λ|(xs) of go\nend span",
"splitArrow (***)": "-- splitArrow (***) :: (a -> b) -> (c -> d) -> ((a, c) -> (b, d))\non splitArrow(f, g)\n -- Compose a function (from a tuple to a tuple), \n -- (with separate transformations for fst and snd)\n script\n on |λ|(xy)\n Tuple(mReturn(f)'s |λ|(|1| of xy), mReturn(g)'s |λ|(|2| of xy))\n end |λ|\n end script\nend splitArrow",
"splitAt": "-- splitAt :: Int -> [a] -> ([a], [a])\non splitAt(n, xs)\n if n > 0 and n < length of xs then\n if class of xs is text then\n {items 1 thru n of xs as text, ¬\n items (n + 1) thru -1 of xs as text}\n else\n {items 1 thru n of xs, items (n + 1) thru -1 of xs}\n end if\n else\n if n < 1 then\n {{}, xs}\n else\n {xs, {}}\n end if\n end if\nend splitAt",
"splitBy": "-- splitBy :: (a -> a -> Bool) -> [a] -> [[a]]\n-- splitBy :: (String -> String -> Bool) -> String -> [String]\non splitBy(p, xs)\n if 2 > length of xs then\n {xs}\n else\n script pairMatch\n property mp : mReturn(p)'s |λ|\n on |λ|(a, b)\n {mp(a, b), a, b}\n end |λ|\n end script\n \n script addOrSplit\n on |λ|(a, blnXY)\n set {bln, x, y} to blnXY\n if bln then\n {item 1 of a & {item 2 of a}, {y}}\n else\n {item 1 of a, (item 2 of a) & y}\n end if\n end |λ|\n end script\n set {a, r} to foldl(addOrSplit, ¬\n {{}, {item 1 of xs}}, ¬\n zipWith(pairMatch, xs, rest of xs))\n \n if list is class of xs then\n a & {r}\n else\n map(my concat, a & {r})\n end if\n end if\nend splitBy",
"splitFileName": "-- splitFileName :: FilePath -> (String, String)\non splitFileName(strPath)\n -- Split a filename into directory and file. combine is the inverse.\n if strPath ≠ \"\" then\n if last character of strPath ≠ \"/\" then\n set xs to splitOn(\"/\", strPath)\n set stem to init(xs)\n if stem ≠ {} then\n Tuple(intercalate(\"/\", stem) & \"/\", |last|(xs))\n else\n Tuple(\"./\", |last|(xs))\n end if\n else\n Tuple(strPath, \"\")\n end if\n else\n Tuple(\"./\", \"\")\n end if\nend splitFileName",
"splitOn": "-- splitOn :: [a] -> [a] -> [[a]]\n-- splitOn :: String -> String -> [String]\non splitOn(pat, src)\n -- splitOn(\"\\r\\n\", \"a\\r\\nb\\r\\nd\\r\\ne\") --> [\"a\",\"b\",\"d\",\"e\"]\n -- splitOn(\"aaa\", \"aaaXaaaXaaaXaaa\") --> {\"\", \"X\", \"X\", \"X\", \"\"}\n -- splitOn(\"x\", \"x\") --> {\"\", \"\"}\n -- splitOn([3, 1], [1, 2, 3, 1, 2, 3, 1, 2, 3])\n --> {{1, 2}, {2}, {2, 3}}\n if class of src is text then\n set {dlm, my text item delimiters} to ¬\n {my text item delimiters, pat}\n set xs to text items of src\n set my text item delimiters to dlm\n return xs\n else\n set lng to length of pat\n script residue\n on |λ|(a, i)\n Tuple(fst(a) & ¬\n {init(items snd(a) thru (i) of src)}, lng + i)\n end |λ|\n end script\n set tpl to foldl(residue, ¬\n Tuple({}, 1), findIndices(matching(pat), src))\n return fst(tpl) & {drop(snd(tpl) - 1, src)}\n end if\nend splitOn",
"splitRegex": "-- splitRegex :: Regex -> String -> [String]\non splitRegex(strRegex, str)\n set lstMatches to regexMatches(strRegex, str)\n if length of lstMatches > 0 then\n script preceding\n on |λ|(a, x)\n set iFrom to start of a\n set iLocn to (location of x)\n \n if iLocn > iFrom then\n set strPart to text (iFrom + 1) thru iLocn of str\n else\n set strPart to \"\"\n end if\n {parts:parts of a & strPart, start:iLocn + (length of x) - 1}\n end |λ|\n end script\n \n set recLast to foldl(preceding, {parts:[], start:0}, lstMatches)\n \n set iFinal to start of recLast\n if iFinal < length of str then\n parts of recLast & text (iFinal + 1) thru -1 of str\n else\n parts of recLast & \"\"\n end if\n else\n {str}\n end if\nend splitRegex",
"sqrt": "-- sqrt :: Num -> (missing value | Num)\non sqrt(n)\n if 0 <= n then\n n ^ (1 / 2)\n else\n missing value\n end if\nend sqrt",
"sqrtLR": "-- sqrtLR :: Num -> Either String Num\non sqrtLR(n)\n if 0 ≤ n then\n |Right|(n ^ (1 / 2))\n else\n |Left|(\"Square root of negative number: \" & n)\n end if\nend sqrtLR",
"sqrtMay": "-- sqrtMay :: Num -> Maybe Num\non sqrtMay(n)\n if n ≥ 0 then\n Just(n ^ (1 / 2))\n else\n Nothing()\n end if\nend sqrtMay",
"str": "-- str :: a -> String\non str(x)\n x as string\nend str",
"strip": "-- strip :: String -> String\non strip(s)\n script isSpace\n on |λ|(c)\n set i to id of c\n 32 = i or (9 ≤ i and 13 ≥ i)\n end |λ|\n end script\n dropWhile(isSpace, dropWhileEnd(isSpace, s))\nend strip",
"stripEnd": "-- stripEnd :: String -> String\non stripEnd(s)\n dropWhileEnd(my isSpace, s)\nend stripEnd",
"stripPrefix": "-- stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]\n-- stripPrefix :: String -> String -> Maybe String\non stripPrefix(pfx, s)\n set blnString to class of pfx is text\n if blnString then\n set {xs, ys} to {characters of pfx, characters of s}\n else\n set {xs, ys} to {pfx, s}\n end if\n \n script\n on |λ|(xs, ys)\n if length of xs < 1 then\n if blnString then\n set v to intercalate(\"\", ys)\n else\n set v to ys\n end if\n Just(v)\n else\n if (length of ys < 1) or (item 1 of xs ≠ item 1 of ys) then\n Nothing()\n else\n |λ|(tail(xs), tail(ys))\n end if\n end if\n end |λ|\n end script\n |λ|(xs, ys) of result\nend stripPrefix",
"stripStart": "-- stripStart :: String -> String\non stripStart(s)\n dropWhile(my isSpace, s)\nend stripStart",
"subTreeAtPath": "-- subTreeAtPath :: Tree String -> [String] -> Maybe Tree String\non subTreeAtPath(tree, pathSegments)\n script go\n on |λ|(children, xs)\n if {} ≠ children and {} ≠ xs then\n set h to item 1 of xs\n script parentMatch\n on |λ|(t)\n h = root of t\n end |λ|\n end script\n script childMatch\n on |λ|(t)\n if 1 < length of xs then\n |λ|(nest of t, rest of xs) of go\n else\n Just(t)\n end if\n end |λ|\n end script\n bindMay(find(parentMatch, children), childMatch)\n else\n Nothing()\n end if\n end |λ|\n end script\n |λ|({tree}, pathSegments) of go\nend subTreeAtPath",
"subsequences": "-- subsequences :: [a] -> [[a]]\n-- subsequences :: String -> [String]\non subsequences(xs)\n -- subsequences([1,2,3]) -> [[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]]\n -- subsequences(\"abc\") -> [\"\",\"a\",\"b\",\"ab\",\"c\",\"ac\",\"bc\",\"abc\"]\n script nonEmptySubsequences\n on |λ|(xxs)\n if length of xxs < 1 then\n {}\n else\n set {x, xs} to {item 1 of xxs, tail(xxs)}\n \n script f\n on |λ|(ys, r)\n cons(ys, cons(cons(x, ys), r))\n end |λ|\n end script\n \n cons({x}, foldr(f, {}, |λ|(xs) of nonEmptySubsequences))\n end if\n end |λ|\n end script\n if class of xs is text then\n cons(\"\", map(my concat, |λ|(characters of xs) of nonEmptySubsequences))\n else\n cons([], |λ|(xs) of nonEmptySubsequences)\n end if\nend subsequences",
"subsets": "-- subsets :: [a] -> [[a]]\non subsets(xs)\n script go\n on |λ|(ys)\n if 0 < length of ys then\n set h to item 1 of ys\n set zs to |λ|(rest of ys)\n script hcons\n on |λ|(z)\n {h} & z\n end |λ|\n end script\n zs & map(hcons, zs)\n else\n {{}}\n end if\n end |λ|\n end script\n go's |λ|(xs)\nend subsets",
"subtract": "-- subtract :: Num -> Num -> Num\non subtract(x, y)\n y - x\nend subtract",
"succ": "-- succ :: Enum a => a -> a\non succ(x)\n if isChar(x) then\n chr(1 + ord(x))\n else\n 1 + x\n end if\nend succ",
"succMay": "-- succMay :: Enum a => a -> Maybe a\non succMay(x)\n if x is maxBound(x) then\n Nothing()\n else\n Just(toEnum(x)'s |λ|(fromEnum(x) + 1))\n end if\nend succMay",
"sum": "-- sum :: [Num] -> Num\non sum(xs)\n set ca to current application\n ((ca's NSArray's arrayWithArray:xs)'s ¬\n valueForKeyPath:\"@sum.self\") as real\nend sum",
"swap": "-- swap :: (a, b) -> (b, a)\non swap(ab)\n if class of ab is record then\n Tuple(|2| of ab, |1| of ab)\n else\n {item 2 of ab, item 1 of ab}\n end if\nend swap",
"table": "-- table :: Int -> [String] -> String\ron table(n, xs)\r -- A list of strings formatted as\r -- right-justified rows of n columns.\r set w to length of last item of xs\r unlines(map(my unwords, ¬\r chunksOf(n, map(justifyRight(w, space), xs))))\rend table",
"tail": "-- tail :: [a] -> [a]\non tail(xs)\n set blnText to text is class of xs\n if blnText then\n set unit to \"\"\n else\n set unit to {}\n end if\n set lng to length of xs\n if 1 > lng then\n missing value\n else if 2 > lng then\n unit\n else\n if blnText then\n text 2 thru -1 of xs\n else\n rest of xs\n end if\n end if\nend tail",
"tailMay": "-- tailMay :: [a] -> Maybe [a]\non tailMay(xs)\n if xs = {} then\n Nothing()\n else\n Just(rest of xs)\n end if\nend tailMay",
"tails": "-- tails :: [a] -> [[a]]\non tails(xs)\n if class of xs is text then\n set es to characters of xs\n else\n set es to xs\n end if\n script residue\n on |λ|(_, i)\n items i thru -1 of es\n end |λ|\n end script\n map(residue, es) & {{}}\nend tails",
"take": "-- take :: Int -> [a] -> [a]\n-- take :: Int -> String -> String\non take(n, xs)\n set c to class of xs\n if list is c then\n set lng to length of xs\n if 0 < n and 0 < lng then\n items 1 thru min(n, lng) of xs\n else\n {}\n end if\n else if string is c then\n if 0 < n then\n text 1 thru min(n, length of xs) of xs\n else\n \"\"\n end if\n else if script is c then\n set ys to {}\n repeat with i from 1 to n\n set v to |λ|() of xs\n if missing value is v then\n return ys\n else\n set end of ys to v\n end if\n end repeat\n return ys\n else\n missing value\n end if\nend take",
"takeAround": "-- takeAround :: (a -> Bool) -> [a] -> [a]\non takeAround(p, xs)\n set ys to takeWhile(p, xs)\n if length of ys < length of xs then\n ys & takeWhileR(p, xs)\n else\n ys\n end if\nend takeAround",
"takeBaseName": "-- takeBaseName :: FilePath -> String\non takeBaseName(strPath)\n if \"\" ≠ strPath then\n if \"/\" = text -1 of strPath then\n \"\"\n else\n set fn to item -1 of splitOn(\"/\", strPath)\n if fn contains \".\" then\n intercalate(\".\", items 1 thru -2 of splitOn(\".\", fn))\n else\n fn\n end if\n end if\n else\n \"\"\n end if\nend takeBaseName",
"takeCycle": "-- takeCycle :: Int -> [a] -> [a]\non takeCycle(n, xs)\n set lng to length of xs\n if lng ≥ n then\n set cycle to xs\n else\n set cycle to concat(replicate((n div lng) + 1, xs))\n end if\n \n if class of xs is string then\n items 1 thru n of cycle as string\n else\n items 1 thru n of cycle\n end if\nend takeCycle",
"takeDirectory": "-- takeDirectory :: FilePath -> FilePath\non takeDirectory(fp)\n set strPath to filePath(fp)\n if \"\" ≠ strPath then\n if \"/\" = character -1 of strPath then\n text 1 thru -2 of strPath\n else\n set xs to init(splitOn(\"/\", strPath))\n if {} ≠ xs then\n intercalateS(\"/\", xs)\n else\n \".\"\n end if\n end if\n else\n \".\"\n end if\nend takeDirectory",
"takeDropCycle": "-- take N Members of an infinite cycle of xs, starting from index I\n-- takeDropCycle :: Int -> [a] -> [a]\non takeDropCycle(n, i, xs)\n set lng to length of xs\n set m to n + i\n \n if lng ≥ m then\n set ys to xs\n else\n set ys to concat(replicate(ceiling(m / lng), xs))\n end if\n \n drop(i, take(m, ys))\nend takeDropCycle",
"takeExtension": "-- takeExtension :: FilePath -> String\non takeExtension(fp)\n set xs to splitOn(\".\", fp)\n if 1 < length of xs then\n \".\" & item -1 of xs\n else\n \"\"\n end if\nend takeExtension",
"takeFileName": "-- takeFileName :: FilePath -> FilePath\non takeFileName(strPath)\n if \"\" ≠ strPath and \"/\" ≠ character -1 of strPath then\n item -1 of splitOn(\"/\", strPath)\n else\n \"\"\n end if\nend takeFileName",
"takeFromThenTo": "-- takeFromThenTo :: Int -> Int -> Int -> [a] -> [a]\non takeFromThenTo(a, b, z, xs)\n script go\n on |λ|(i)\n item (1 + i) of xs\n end |λ|\n end script\n map(go, enumFromThenTo(a, b, z))\nend takeFromThenTo",
"takeIterate": "-- takeIterate n f x == [x, f x, f (f x), ...]\n-- takeIterate :: Int -> (a -> a) -> a -> [a]\non takeIterate(n, f, x)\n set v to x\n set vs to {v}\n tell mReturn(f)\n repeat with i from 1 to n - 1\n set v to |λ|(v)\n set end of vs to v\n end repeat\n end tell\n return vs\nend takeIterate",
"takeWhile": "-- takeWhile :: (a -> Bool) -> [a] -> [a]\n-- takeWhile :: (Char -> Bool) -> String -> String\non takeWhile(p, xs)\n if script is class of xs then\n takeWhileGen(p, xs)\n else\n tell mReturn(p)\n repeat with i from 1 to length of xs\n if not |λ|(item i of xs) then ¬\n return take(i - 1, xs)\n end repeat\n end tell\n return xs\n end if\nend takeWhile",
"takeWhileGen": "-- takeWhileGen :: (a -> Bool) -> Gen [a] -> [a]\non takeWhileGen(p, xs)\n set ys to {}\n set v to |λ|() of xs\n tell mReturn(p)\n repeat while (|λ|(v))\n set end of ys to v\n set v to xs's |λ|()\n end repeat\n end tell\n return ys\nend takeWhileGen",
"takeWhileR": "-- takeWhileR :: (a -> Bool) -> [a] -> [a]\non takeWhileR(p, xs)\n set bln to false\n set blnText to (class of xs) is text\n tell mReturn(p)\n set lng to length of xs\n repeat with i from lng to 1 by -1\n if not |λ|(item i of xs) then\n set bln to true\n exit repeat\n end if\n end repeat\n end tell\n if bln then\n if i > 1 then\n if blnText then\n text (1 + i) thru (-1) of xs\n else\n items (1 + i) thru (-1) of xs\n end if\n else\n if blnText then\n \"\"\n else\n {}\n end if\n end if\n else\n xs\n end if\nend takeWhileR",
"taskPaperDateString": "-- taskPaperDateString :: Date -> String\non taskPaperDateString(dte)\n set {d, t} to splitOn(\"T\", dte as «class isot» as string)\n d & space & text 1 thru 5 of t\nend taskPaperDateString",
"tempFilePath": "-- tempFilePath :: String -> IO FilePath\non tempFilePath(template)\n (current application's ¬\n NSTemporaryDirectory() as string) & ¬\n takeBaseName(template) & ¬\n text 3 thru -1 of ((random number) as string) & ¬\n takeExtension(template)\nend tempFilePath",
"toEnum": "-- toEnum :: a -> Int -> a\non toEnum(e)\n script\n property c : class of e\n on |λ|(x)\n if integer is c or real is c then\n x as number\n else if text is c then\n character id x\n else if boolean is c then\n if 0 ≠ x then\n true\n else\n false\n end if\n end if\n end |λ|\n end script\nend toEnum",
"toLower": "-- toLower :: String -> String\non toLower(str)\n -- String in lower case. \n tell current application\n ((its (NSString's stringWithString:(str)))'s ¬\n lowercaseStringWithLocale:(its NSLocale's currentLocale())) as text\n end tell\nend toLower",
"toRatio": "-- toRatio :: Real -> Ratio\non toRatio(n)\n approxRatio(1.0E-12, n)\nend toRatio",
"toSentence": "-- Sentence case - initial string capitalized and rest lowercase\n-- toSentence :: String -> String\non toSentence(str)\n set ca to current application\n if length of str > 0 then\n set locale to ca's NSLocale's currentLocale()\n set ws to ca's NSString\n (((ws's stringWithString:(text 1 of str))'s ¬\n uppercaseStringWithLocale:(locale)) as text) & ¬\n ((ws's stringWithString:(text 2 thru -1 of str))'s ¬\n lowercaseStringWithLocale:(locale)) as text\n else\n str\n end if\nend toSentence",
"toTitle": "-- NB this does not model any regional or cultural conventions.\n-- It simply simply capitalizes the first character of each word.\n-- toTitle :: String -> String\non toTitle(str)\n set ca to current application\n ((ca's NSString's stringWithString:(str))'s ¬\n capitalizedStringWithLocale:(ca's NSLocale's currentLocale())) as text\nend toTitle",
"toUpper": "-- toUpper :: String -> String\non toUpper(str)\n tell current application\n ((its (NSString's stringWithString:(str)))'s ¬\n uppercaseStringWithLocale:(its NSLocale's currentLocale())) as text\n end tell\nend toUpper",
"transpose": "-- transpose :: [[a]] -> [[a]]\non transpose(xxs)\n -- If some of the rows are shorter than the following rows, \n -- their elements are skipped:\n -- transpose({{10,11},{20},{},{30,31,32}}) -> {{10, 20, 30}, {11, 31}, {32}}\n set intMax to |length|(maximumBy(comparing(my |length|), xxs))\n set gaps to replicate(intMax, {})\n script padded\n on |λ|(xs)\n set lng to |length|(xs)\n if lng < intMax then\n xs & items (lng + 1) thru -1 of gaps\n else\n xs\n end if\n end |λ|\n end script\n set rows to map(padded, xxs)\n \n script cols\n on |λ|(_, iCol)\n script cell\n on |λ|(row)\n item iCol of row\n end |λ|\n end script\n concatMap(cell, rows)\n end |λ|\n end script\n map(cols, item 1 of rows)\nend transpose",
"transpose_": "-- Simplified version - assuming rows of unvarying length.\n-- transpose_ :: [[a]] -> [[a]]\ron transpose_(rows)\r\tscript cols\r\t\ton |λ|(_, iCol)\r\t\t\tscript cell\r\t\t\t\ton |λ|(row)\r\t\t\t\t\titem iCol of row\r\t\t\t\tend |λ|\r\t\t\tend script\r\t\t\tconcatMap(cell, rows)\r\t\tend |λ|\r\tend script\r\tmap(cols, item 1 of rows)\rend transpose_",
"traverse": "-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)\non traverse(f, tx)\n if class of tx is list then\n traverseList(f, tx)\n else if class of tx is record and keys(tx) contains \"type\" then\n set t to type of tx\n if \"Either\" = t then\n traverseLR(f, tx)\n else if \"Maybe\" = t then\n traverseMay(f, tx)\n else if \"Node\" = t then\n traverseTree(f, tx)\n else if \"Tuple\" = t then\n traverseTuple(f, tx)\n else\n missing value\n end if\n else\n missing value\n end if\nend traverse",
"traverseLR": "-- traverseLR :: Applicative f => (t -> f b) -> Either a t -> f (Either a b)\non traverseLR(f, lr)\n if |Left| of lr is not missing value then\n {lr}\n else\n fmap(my |Right|, mReturn(f)'s |λ|(|Right| of lr))\n end if\nend traverseLR",
"traverseList": "-- 1. Map each element of a structure to an action,\n-- 2. evaluate these actions from left to right, and\n-- 3. collect the results.\n-- \n-- traverse f = List.foldr cons_f (pure [])\n-- where cons_f x ys = liftA2 (:) (f x) ys\n-- traverseList :: (Applicative f) => (a -> f b) -> [a] -> f [b]\non traverseList(f, xs)\n set lng to length of xs\n if 0 < lng then\n set mf to mReturn(f)\n \n set vLast to mf's |λ|(item -1 of xs)\n if class of vLast is record and ¬\n keys(vLast) contains \"type\" then\n set t to type of vLast\n else\n set t to \"List\"\n end if\n \n script cons_f\n on |λ|(x, ys)\n liftA2(my cons, mf's |λ|(x), ys)\n end |λ|\n end script\n \n foldr(cons_f, ¬\n liftA2(my cons, vLast, pureT(t, [])), ¬\n init(xs))\n else\n {{}}\n end if\nend traverseList",
"traverseMay": "-- traverseMay :: Applicative f => (t -> f a) -> Maybe t -> f (Maybe a)\non traverseMay(f, mb)\n if Nothing of mb then\n {mb}\n else\n fmap(my Just, mReturn(f)'s |λ|(Just of mb))\n end if\nend traverseMay",
"traverseTree": "-- traverseTree :: Applicative f => (a -> f b) -> Tree a -> f (Tree b)\non traverseTree(f, tree)\n -- traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts)\n script go\n on |λ|(x)\n liftA2(my Node, ¬\n mReturn(f)'s |λ|(root of x), ¬\n traverseList(go, nest of x))\n end |λ|\n end script\n go's |λ|(tree)\nend traverseTree",
"traverseTuple": "-- traverseTuple :: Functor f => (t -> f b) -> (a, t) -> f (a, b)\non traverseTuple(f, tpl)\n fmap(curry(my Tuple)'s |λ|(|1| of tpl), ¬\n mReturn(f)'s |λ|(|2| of tpl))\nend traverseTuple",
"treeFromDict": "-- treeFromDict :: String -> Dict -> Tree String\non treeFromDict(treeTitle, recDict)\n script go\n on |λ|(x)\n set c to class of x\n if list is c then\n script\n on |λ|(v)\n Node(v, {})\n end |λ|\n end script\n map(result, x)\n else if record is c then\n script\n on |λ|(k)\n Node(k, go's |λ|(|Just| of lookupDict(k, x)))\n end |λ|\n end script\n map(result, keys(x))\n else\n {}\n end if\n end |λ|\n end script\n Node(treeTitle, go's |λ|(recDict))\nend treeFromDict",
"treeFromNestedList": "-- treeFromNestedList :: NestedList a -> Tree a\non treeFromNestedList(vxs)\n script go\n on |λ|(pair)\n Node(item 1 of pair, map(go, item 2 of pair))\n end |λ|\n end script\n |λ|(vxs) of go\nend treeFromPairNest",
"treeLeaves": "-- treeLeaves :: Tree -> [Tree]\non treeLeaves(oNode)\n script go\n on |λ|(x)\n set lst to nest of x\n if 0 < length of lst then\n concatMap(my treeLeaves, lst)\n else\n {x}\n end if\n end |λ|\n end script\n |λ|(oNode) of go\nend treeLeaves",
"treeMatches": "-- A list of all nodes in the tree which match \n-- a predicate p.\n-- For the first match only, see findTree.\n-- treeMatches :: (a -> Bool) -> Tree a -> [Tree a]\non treeMatches(p, tree)\n script go\n property pf : mReturn(p)'s |λ|\n on |λ|(x)\n if pf(root of x) then\n {x}\n else\n concatMap(go, nest of x)\n end if\n end |λ|\n end script\n go's |λ|(tree)\nend treeMatches",
"treeMenu": "-- treeMenu :: Tree String -> IO [String]\non treeMenu(tree)\n script go\n on |λ|(tree)\n set menuTitle to root of tree\n set subTrees to nest of tree\n set menuItems to map(my root, subTrees)\n set blnNoSubMenus to {} = concatMap(my nest, subTrees)\n \n script menuCancelledOrChoiceMade\n on |λ|(statusAndChoices)\n (not my fst(statusAndChoices)) or ({} ≠ my snd(statusAndChoices))\n end |λ|\n end script\n \n script choicesOrSubMenu\n on |λ|(choices)\n set k to item 1 of choices\n script match\n on |λ|(x)\n k = root of x\n end |λ|\n end script\n set chosenSubTree to (Just of find(match, subTrees))\n if {} ≠ (nest of chosenSubTree) then\n |Right|(|λ|(chosenSubTree) of go)\n else\n |Right|(choices)\n end if\n end |λ|\n end script\n \n script nothingFromThisMenu\n on |λ|(_)\n Tuple(false, {})\n end |λ|\n end script\n \n script selectionsFromThisMenu\n on |λ|(xs)\n Tuple(true, xs)\n end |λ|\n end script\n \n script nextStepInNestedMenu\n on |λ|(statusAndChoice)\n either(nothingFromThisMenu, selectionsFromThisMenu, ¬\n bindLR(showMenuLR(blnNoSubMenus, menuTitle, menuItems), ¬\n choicesOrSubMenu))\n end |λ|\n end script\n \n snd(|until|(menuCancelledOrChoiceMade, ¬\n nextStepInNestedMenu, ¬\n Tuple(true, {}))) -- (Status, Choices) pair\n end |λ|\n end script\n |λ|(tree) of go\nend treeMenu",
"truncate": "-- truncate :: Num -> Int\non truncate(x)\n item 1 of properFraction(x)\nend truncate",
"tupleFromList": "-- tupleFromList :: [a] -> (a, a ...)\non tupleFromList(xs)\n set lng to length of xs\n if 1 < lng then\n if 2 < lng then\n set strSuffix to lng as string\n else\n set strSuffix to \"\"\n end if\n script kv\n on |λ|(a, x, i)\n insertDict((i as string), x, a)\n end |λ|\n end script\n foldl(kv, {type:\"Tuple\" & strSuffix}, xs) & {length:lng}\n else\n missing value\n end if\nend tupleFromList",
"typeName": "-- typeName :: a -> String\non typeName(x)\n set mb to lookupDict((class of x) as string, ¬\n {|list|:\"List\", |integer|:\"Int\", |real|:\"Float\", |text|:¬\n \"String\", |string|:\"String\", |record|:¬\n \"Record\", |boolean|:\"Bool\", |handler|:\"(a -> b)\", |script|:\"(a -> b\"})\n if Nothing of mb then\n \"Bottom\"\n else\n set k to Just of mb\n if k = \"Record\" then\n if keys(x) contains \"type\" then\n type of x\n else\n \"Dict\"\n end if\n else\n k\n end if\n end if\nend typeName",
"unDigits": "-- unDigits :: [Int] -> Int\non unDigits(ds)\n -- The integer with the given digits.\n script go\n on |λ|(a, x)\n 10 * a + x\n end |λ|\n end script\n foldl(go, 0, ds)\nend unDigits",
"unQuoted": "-- unQuoted :: String -> String\non unQuoted(s)\n script p\n on |λ|(x)\n --{34, 39} contains id of x\n 34 = id of x\n end |λ|\n end script\n dropAround(p, s)\nend unQuoted",
"uncons": "-- uncons :: [a] -> Maybe (a, [a])\non uncons(xs)\n set lng to |length|(xs)\n if 0 = lng then\n Nothing()\n else\n if (2 ^ 29 - 1) as integer > lng then\n if class of xs is string then\n set cs to text items of xs\n Just(Tuple(item 1 of cs, rest of cs))\n else\n Just(Tuple(item 1 of xs, rest of xs))\n end if\n else\n set nxt to take(1, xs)\n if {} is nxt then\n Nothing()\n else\n Just(Tuple(item 1 of nxt, xs))\n end if\n end if\n end if\nend uncons",
"uncurry": "-- Given a curried/default function, returns an\n-- equivalent function on a tuple or list pair.\n-- A function over a pair, derived from\n-- a function over two arguments.\n-- uncurry :: (a -> b -> c) -> ((a, b) -> c)\non uncurry(f)\n if 1 < argvLength(f) then\n script\n on |λ|(ab)\n if class of ab is list then\n mReturn(f)'s |λ|(item 1 of ab, item 2 of ab)\n else\n mReturn(f)'s |λ|(|1| of ab, |2| of ab)\n end if\n end |λ|\n end script\n else\n script\n on |λ|(ab)\n if class of ab is list then\n f's |λ|(item 1 of ab)'s |λ|(item 2 of ab)\n else\n f's |λ|(|1| of ab)'s |λ|(|2| of ab)\n end if\n end |λ|\n end script\n end if\nend uncurry\n",
"unfoldForest": "-- unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree]\non unfoldForest(f, xs)\n -- | Build a forest from a list of seed values\n set g to mReturn(f)\n script\n on |λ|(x)\n unfoldTree(g, x)\n end |λ|\n end script\n map(result, xs)\nend unfoldForest",
"unfoldTree": "-- | Build a tree from a seed value\n-- unfoldTree :: (b -> (a, [b])) -> b -> Tree a\non unfoldTree(f, b)\n set g to mReturn(f)\n set tpl to g's |λ|(b)\n Node(|1| of tpl, unfoldForest(g, |2| of tpl))\nend unfoldTree",
"unfoldl": "-- unfoldl :: (b -> Maybe (b, a)) -> b -> [a]\non unfoldl(f, v)\n -- > unfoldl (\\b -> if b == 0 then Nothing else Just (b, b-1)) 10\n -- > [1,2,3,4,5,6,7,8,9,10]\n set xr to Tuple(v, v) -- (value, remainder)\n set xs to {}\n tell mReturn(f)\n repeat -- Function applied to remainder.\n set mb to |λ|(|2| of xr)\n if Nothing of mb then\n exit repeat\n else -- New (value, remainder) tuple,\n set xr to Just of mb\n -- and value appended to output list.\n set xs to ({|1| of xr} & xs)\n end if\n end repeat\n end tell\n return xs\nend unfoldl",
"unfoldr": "-- unfoldr :: (b -> Maybe (a, b)) -> b -> [a]\non unfoldr(f, v)\n -- A lazy (generator) list unfolded from a seed value\n -- by repeated application of f to a value until no\n -- residue remains. Dual to fold/reduce.\n -- f returns either nothing (missing value) \n -- or just (value, residue).\n script\n property valueResidue : {v, v}\n property g : mReturn(f)\n on |λ|()\n set valueResidue to g's |λ|(item 2 of (valueResidue))\n if missing value ≠ valueResidue then\n item 1 of (valueResidue)\n else\n missing value\n end if\n end |λ|\n end script\nend unfoldr",
"union": "-- union :: [a] -> [a] -> [a]\non union(xs, ys)\n script flipDelete\n on |λ|(xs, x)\n my |delete|(x, xs)\n end |λ|\n end script\n \n set sx to nub(xs)\n sx & foldl(flipDelete, nub(ys), sx)\nend union",
"unionBy": "-- unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]\non unionBy(fnEq, xs, ys)\n script flipDeleteByEq\n on |λ|(xs, x)\n deleteBy(fnEq, x, xs)\n end |λ|\n end script\n xs & foldl(flipDeleteByEq, nubBy(fnEq, ys), xs)\nend unionBy",
"unionSet": "-- unionSet :: Ord a => Set a -> Set a -> Set a\non unionSet(s, s1)\n set sUnion to current application's NSMutableSet's alloc's init()\n sUnion's setSet:(s)\n sUnion's unionSet:(s1)\n return sUnion\nend unionSet",
"unlines": "-- unlines :: [String] -> String\non unlines(xs)\n -- A single string formed by the intercalation\n -- of a list of strings with the newline character.\n set {dlm, my text item delimiters} to ¬\n {my text item delimiters, linefeed}\n set s to xs as text\n set my text item delimiters to dlm\n s\nend unlines",
"unsnoc": "-- If the list is empty returns Nothing, otherwise returns \n-- Just the init and the last.\n-- unsnoc :: [a] -> Maybe ([a], a)\non unsnoc(xs)\n set blnString to class of xs is string\n set lng to length of xs\n if lng = 0 then\n Nothing()\n else\n set h to item -1 of xs\n if lng > 1 then\n if blnString then\n Just(Tuple(text 1 thru -2 of xs, h))\n else\n Just(Tuple(items 1 thru -2 of xs, h))\n end if\n else\n if blnString then\n Just(Tuple(\"\", h))\n else\n Just(Tuple({}, h))\n end if\n end if\n end if\nend unsnoc",
"until": "-- until :: (a -> Bool) -> (a -> a) -> a -> a\ron |until|(p, f, x)\r\tset v to x\r\tset mp to mReturn(p)\r\tset mf to mReturn(f)\r\trepeat until mp's |λ|(v)\r\t\tset v to mf's |λ|(v)\r\tend repeat\r\tv\rend |until|",
"unwords": "-- unwords :: [String] -> String\non unwords(xs)\n set {dlm, my text item delimiters} to ¬\n {my text item delimiters, space}\n set s to xs as text\n set my text item delimiters to dlm\n return s\nend unwords",
"unwrap": "-- unwrap :: NSValue -> a\non unwrap(nsValue)\n if nsValue is missing value then\n missing value\n else\n set ca to current application\n item 1 of ((ca's NSArray's arrayWithObject:nsValue) as list)\n end if\nend unwrap",
"unzip": "-- unzip :: [(a,b)] -> ([a],[b])\non unzip(xys)\n set xs to {}\n set ys to {}\n repeat with xy in xys\n set end of xs to |1| of xy\n set end of ys to |2| of xy\n end repeat\n return Tuple(xs, ys)\nend unzip",
"unzip3": "-- unzip3 :: [(a,b,c)] -> ([a],[b],[c])\non unzip3(xyzs)\n set xs to {}\n set ys to {}\n set zs to {}\n repeat with xyz in xyzs\n set end of xs to |1| of xyz\n set end of ys to |2| of xyz\n set end of zs to |3| of xyz\n end repeat\n return TupleN({xs, ys, zs})\nend unzip3",
"unzip4": "-- unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])\non unzip4(wxyzs)\n set ws to {}\n set xs to {}\n set ys to {}\n set zs to {}\n repeat with wxyz in wxyzs\n set end of ws to |1| of wxyz\n set end of xs to |2| of wxyz\n set end of ys to |3| of wxyz\n set end of zs to |4| of wxyz\n end repeat\n return TupleN({ws, xs, ys, zs})\nend unzip4",
"unzipN": "-- unzipN :: [(a,b,...)] -> ([a],[b],...)\non unzipN(tpls)\n if 0 < length of tpls then\n set xs to replicate(length of item 1 of tpls, {})\n script go\n on |λ|(a, tpl)\n script inner\n on |λ|(x, i)\n x & Just of lookupDict(i as string, tpl)\n end |λ|\n end script\n map(inner, a)\n end |λ|\n end script\n foldl(go, xs, tpls)\n else\n missing value\n end if\nend unzipN",
"variance": "-- variance :: [Num] -> Num\non variance(xs)\n set m to mean(xs)\n script\n on |λ|(a, x)\n a + (x - m) ^ 2\n end |λ|\n end script\n foldl(result, 0, xs) / ((length of xs) - 1)\nend variance",
"words": "-- words :: String -> [String]\non |words|(s)\n set ca to current application\n (((ca's NSString's stringWithString:(s))'s ¬\n componentsSeparatedByCharactersInSet:(ca's ¬\n NSCharacterSet's whitespaceAndNewlineCharacterSet()))'s ¬\n filteredArrayUsingPredicate:(ca's ¬\n NSPredicate's predicateWithFormat:\"0 < length\")) as list\nend |words|",
"wrap": "-- wrap :: a -> NSObject\non wrap(v)\n set ca to current application\n ca's (NSArray's arrayWithObject:v)'s objectAtIndex:0\nend wrap",
"writeFile": "-- use framework \"Foundation\"\n-- writeFile :: FilePath -> String -> IO ()\non writeFile(strPath, strText)\n set ca to current application\n (ca's NSString's stringWithString:strText)'s ¬\n writeToFile:(stringByStandardizingPath of ¬\n (ca's NSString's stringWithString:strPath)) atomically:true ¬\n encoding:(ca's NSUTF8StringEncoding) |error|:(missing value)\nend writeFile",
"writeFileLR": "-- writeFileLR :: FilePath -> Either String IO FilePath\non writeFileLR(strPath, strText)\n set ca to current application\n set fp to stringByStandardizingPath of ¬\n (ca's NSString's stringWithString:strPath)\n set {bln, e} to (ca's NSString's stringWithString:strText)'s ¬\n writeToFile:(fp) atomically:true ¬\n encoding:(ca's NSUTF8StringEncoding) |error|:(reference)\n if bln and (missing value is e) then\n |Right|(fp as string)\n else\n |Left|(e's localizedDescription() as string)\n end if\nend writeFileLR",
"writeTempFile": "use framework \"Foundation\"\n-- File name template -> string data -> temporary path\n-- (Random digit sequence inserted between template base and extension)\n-- writeTempFile :: String -> String -> IO FilePath\non writeTempFile(template, txt)\n set strPath to (current application's ¬\n NSTemporaryDirectory() as string) & ¬\n takeBaseName(template) & ¬\n text 3 thru -1 of ((random number) as string) & ¬\n takeExtension(template)\n -- Effect\n writeFile(strPath, txt)\n -- Value\n strPath\nend writeTempFile",
"zip": "-- zip :: [a] -> [b] -> [(a, b)]\ron zip(xs, ys)\r set n to min(length of xs, length of ys)\r \r set lst to {}\r repeat with i from 1 to n\r set end of lst to {item i of xs, item i of ys}\r end repeat\r return lst\rend zip",
"zip3": "-- zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]\non zip3(xs, ys, zs)\n script\n on |λ|(x, i)\n TupleN({x, item i of ys, item i of zs})\n end |λ|\n end script\n map(result, items 1 thru ¬\n minimum({length of xs, length of ys, length of zs}) of xs)\nend zip3",
"zip4": "-- zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]\non zip4(ws, xs, ys, zs)\n script\n on |λ|(w, i)\n TupleN({w, item i of xs, item i of ys, item i of zs})\n end |λ|\n end script\n map(result, items 1 thru ¬\n minimum({length of xs, length of ys, length of zs}) of xs)\nend zip4",
"zipGen": "-- zipGen :: Gen [a] -> Gen [b] -> Gen [(a, b)]\non zipGen(ga, gb)\n script\n property ma : missing value\n property mb : missing value\n on |λ|()\n if missing value is ma then\n set ma to uncons(ga)\n set mb to uncons(gb)\n end if\n if Nothing of ma or Nothing of mb then\n missing value\n else\n set ta to Just of ma\n set tb to Just of mb\n set x to Tuple(|1| of ta, |1| of tb)\n set ma to uncons(|2| of ta)\n set mb to uncons(|2| of tb)\n return x\n end if\n end |λ|\n end script\nend zipGen",
"zipList": "-- zipList :: [a] -> [b] -> [(a, b)]\non zipList(xs, ys)\n set lng to min(length of xs, length of ys)\n script go\n on |λ|(x, i)\n {x, item i of ys}\n end |λ|\n end script\n map(go, items 1 thru lng of xs)\nend zipList",
"zipN": "-- Arbitrary number of lists to zip\n-- all enclosed in an argument vector list\n-- zipN :: [a] -> [b] -> ... -> [(a, b ...)]\non zipN(argv)\n if 1 < length of argv then\n script go\n on |λ|(x, i)\n script peers\n on |λ|(y)\n item i of y\n end |λ|\n end script\n tupleFromList(map(peers, argv))\n end |λ|\n end script\n map(go, take(minimum(map(my |length|, argv)), ¬\n item 1 of argv))\n else\n argv\n end if\nend zipN",
"zipWith": "-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]\non zipWith(f, xs, ys)\n set lng to min(|length|(xs), |length|(ys))\n if 1 > lng then return {}\n set xs_ to take(lng, xs) -- Allow for non-finite\n set ys_ to take(lng, ys) -- generators like cycle etc\n set lst to {}\n tell mReturn(f)\n repeat with i from 1 to lng\n set end of lst to |λ|(item i of xs_, item i of ys_)\n end repeat\n return lst\n end tell\nend zipWith",
"zipWith3": "-- zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]\non zipWith3(f, xs, ys, zs)\n set lng to minimum({length of xs, length of ys, length of zs})\n if 1 > lng then return {}\n set lst to {}\n tell mReturn(f)\n repeat with i from 1 to lng\n set end of lst to |λ|(item i of xs, item i of ys, item i of zs)\n end repeat\n return lst\n end tell\nend zipWith3",
"zipWith4": "-- zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]\non zipWith4(f, ws, xs, ys, zs)\n set lng to minimum({length of ws, length of xs, length of ys, length of zs})\n if 1 > lng then return {}\n set lst to {}\n tell mReturn(f)\n repeat with i from 1 to lng\n set end of lst to |λ|(item i of ws, item i of xs, item i of ys, item i of zs)\n end repeat\n return lst\n end tell\nend zipWith4",
"zipWithGen": "-- zipWithGen :: (a -> b -> c) -> Gen [a] -> Gen [b] -> Gen [c]\non zipWithGen(f, ga, gb)\n script\n property ma : missing value\n property mb : missing value\n property mf : mReturn(f)\n on |λ|()\n if missing value is ma then\n set ma to uncons(ga)\n set mb to uncons(gb)\n end if\n if Nothing of ma or Nothing of mb then\n missing value\n else\n set ta to Just of ma\n set tb to Just of mb\n set ma to uncons(|2| of ta)\n set mb to uncons(|2| of tb)\n |λ|(|1| of ta, |1| of tb) of mf\n end if\n end |λ|\n end script\nend zipWithGen",
"zipWithList": "-- zipWithList :: (a -> b -> c) -> [a] -> [b] -> [c]\non zipWithList(f, xs, ys)\n set lng to min(length of xs, length of ys)\n set lst to {}\n if 1 > lng then\n return {}\n else\n tell mReturn(f)\n repeat with i from 1 to lng\n set end of lst to |λ|(item i of xs, item i of ys)\n end repeat\n return lst\n end tell\n end if\nend zipWithList",
"zipWithM": "-- zipWithM :: Applicative m => (a -> b -> m c) -> [a] -> [b] -> m [c]\non zipWithM(fm, xs, ys)\n -- A functor of the type to which fm lifts its result.\n -- For example, Nothing/Left if any of the zip applications failed,\n -- or Just/Right a list of the results, when all succeeded.\n traverseList(my identity, zipWith(fm, xs, ys))\nend zipWithM",
"zipWithN": "-- zipWithN :: (a -> b -> ... -> c) -> ([a], [b] ...) -> [c]\non zipWithN(f, rows)\n -- f applied to each tuple formed by the\n -- zipping together of each list in rows\n script go\n property mf : mReturn(f)\n on |λ|(i)\n script nth\n on |λ|(row)\n item i of row\n end |λ|\n end script\n mf's |λ|(map(nth, rows))\n end |λ|\n end script\n map(go, enumFromTo(1, minimum(map(my |length|, rows))))\nend zipWithN"
}