542 lines
12 KiB
AppleScript
542 lines
12 KiB
AppleScript
use AppleScript version "2.4"
|
|
use framework "Foundation"
|
|
use scripting additions
|
|
|
|
|
|
------------------ STERN-BROCOT SEQUENCE -----------------
|
|
|
|
-- sternBrocot :: Generator [Int]
|
|
on sternBrocot()
|
|
script go
|
|
on |λ|(xs)
|
|
set x to snd(xs)
|
|
tail(xs) & {fst(xs) + x, x}
|
|
end |λ|
|
|
end script
|
|
fmapGen(my head, iterate(go, {1, 1}))
|
|
end sternBrocot
|
|
|
|
|
|
--------------------------- TEST -------------------------
|
|
on run
|
|
set sbs to take(1200, sternBrocot())
|
|
set ixSB to zip(sbs, enumFrom(1))
|
|
|
|
script low
|
|
on |λ|(x)
|
|
12 ≠ fst(x)
|
|
end |λ|
|
|
end script
|
|
|
|
script sameFst
|
|
on |λ|(a, b)
|
|
fst(a) = fst(b)
|
|
end |λ|
|
|
end script
|
|
|
|
script asList
|
|
on |λ|(x)
|
|
{fst(x), snd(x)}
|
|
end |λ|
|
|
end script
|
|
|
|
script below100
|
|
on |λ|(x)
|
|
100 ≠ fst(x)
|
|
end |λ|
|
|
end script
|
|
|
|
script fullyReduced
|
|
on |λ|(ab)
|
|
1 = gcd(|1| of ab, |2| of ab)
|
|
end |λ|
|
|
end script
|
|
|
|
unlines(map(showJSON, ¬
|
|
{take(15, sbs), ¬
|
|
take(10, map(asList, ¬
|
|
nubBy(sameFst, ¬
|
|
sortBy(comparing(fst), ¬
|
|
takeWhile(low, ixSB))))), ¬
|
|
asList's |λ|(fst(take(1, dropWhile(below100, ixSB)))), ¬
|
|
all(fullyReduced, take(1000, zip(sbs, tail(sbs))))}))
|
|
end run
|
|
|
|
--> [1,1,2,1,3,2,3,1,4,3,5,2,5,3,4]
|
|
--> [[1,32],[2,24],[3,40],[4,36],[5,44],[6,33],[7,38],[8,42],[9,35],[10,39]]
|
|
--> [100,1179]
|
|
--> true
|
|
|
|
|
|
------------------------- GENERIC ------------------------
|
|
|
|
-- Absolute value.
|
|
-- abs :: Num -> Num
|
|
on abs(x)
|
|
if 0 > x then
|
|
-x
|
|
else
|
|
x
|
|
end if
|
|
end abs
|
|
|
|
|
|
-- Applied to a predicate and a list, `all` determines if all elements
|
|
-- of the list satisfy the predicate.
|
|
-- all :: (a -> Bool) -> [a] -> Bool
|
|
on all(p, xs)
|
|
tell mReturn(p)
|
|
set lng to length of xs
|
|
repeat with i from 1 to lng
|
|
if not |λ|(item i of xs, i, xs) then return false
|
|
end repeat
|
|
true
|
|
end tell
|
|
end all
|
|
|
|
|
|
-- comparing :: (a -> b) -> (a -> a -> Ordering)
|
|
on comparing(f)
|
|
script
|
|
on |λ|(a, b)
|
|
tell mReturn(f)
|
|
set fa to |λ|(a)
|
|
set fb to |λ|(b)
|
|
if fa < fb then
|
|
-1
|
|
else if fa > fb then
|
|
1
|
|
else
|
|
0
|
|
end if
|
|
end tell
|
|
end |λ|
|
|
end script
|
|
end comparing
|
|
|
|
|
|
-- drop :: Int -> [a] -> [a]
|
|
-- drop :: Int -> String -> String
|
|
on drop(n, xs)
|
|
set c to class of xs
|
|
if c is not script then
|
|
if c is not string then
|
|
if n < length of xs then
|
|
items (1 + n) thru -1 of xs
|
|
else
|
|
{}
|
|
end if
|
|
else
|
|
if n < length of xs then
|
|
text (1 + n) thru -1 of xs
|
|
else
|
|
""
|
|
end if
|
|
end if
|
|
else
|
|
take(n, xs) -- consumed
|
|
return xs
|
|
end if
|
|
end drop
|
|
|
|
|
|
-- dropWhile :: (a -> Bool) -> [a] -> [a]
|
|
-- dropWhile :: (Char -> Bool) -> String -> String
|
|
on dropWhile(p, xs)
|
|
set lng to length of xs
|
|
set i to 1
|
|
tell mReturn(p)
|
|
repeat while i ≤ lng and |λ|(item i of xs)
|
|
set i to i + 1
|
|
end repeat
|
|
end tell
|
|
drop(i - 1, xs)
|
|
end dropWhile
|
|
|
|
|
|
-- enumFrom :: a -> [a]
|
|
on enumFrom(x)
|
|
script
|
|
property v : missing value
|
|
property blnNum : class of x is not text
|
|
on |λ|()
|
|
if missing value is not v then
|
|
if blnNum then
|
|
set v to 1 + v
|
|
else
|
|
set v to succ(v)
|
|
end if
|
|
else
|
|
set v to x
|
|
end if
|
|
return v
|
|
end |λ|
|
|
end script
|
|
end enumFrom
|
|
|
|
|
|
-- filter :: (a -> Bool) -> [a] -> [a]
|
|
on filter(f, xs)
|
|
tell mReturn(f)
|
|
set lst to {}
|
|
set lng to length of xs
|
|
repeat with i from 1 to lng
|
|
set v to item i of xs
|
|
if |λ|(v, i, xs) then set end of lst to v
|
|
end repeat
|
|
return lst
|
|
end tell
|
|
end filter
|
|
|
|
|
|
-- fmapGen <$> :: (a -> b) -> Gen [a] -> Gen [b]
|
|
on fmapGen(f, gen)
|
|
script
|
|
property g : gen
|
|
property mf : mReturn(f)'s |λ|
|
|
on |λ|()
|
|
set v to g's |λ|()
|
|
if v is missing value then
|
|
v
|
|
else
|
|
mf(v)
|
|
end if
|
|
end |λ|
|
|
end script
|
|
end fmapGen
|
|
|
|
|
|
-- fst :: (a, b) -> a
|
|
on fst(tpl)
|
|
if class of tpl is record then
|
|
|1| of tpl
|
|
else
|
|
item 1 of tpl
|
|
end if
|
|
end fst
|
|
|
|
|
|
-- gcd :: Int -> Int -> Int
|
|
on gcd(a, b)
|
|
set x to abs(a)
|
|
set y to abs(b)
|
|
repeat until y = 0
|
|
if x > y then
|
|
set x to x - y
|
|
else
|
|
set y to y - x
|
|
end if
|
|
end repeat
|
|
return x
|
|
end gcd
|
|
|
|
|
|
-- head :: [a] -> a
|
|
on head(xs)
|
|
if xs = {} then
|
|
missing value
|
|
else
|
|
item 1 of xs
|
|
end if
|
|
end head
|
|
|
|
|
|
-- iterate :: (a -> a) -> a -> Gen [a]
|
|
on iterate(f, x)
|
|
script
|
|
property v : missing value
|
|
property g : mReturn(f)'s |λ|
|
|
on |λ|()
|
|
if missing value is v then
|
|
set v to x
|
|
else
|
|
set v to g(v)
|
|
end if
|
|
return v
|
|
end |λ|
|
|
end script
|
|
end iterate
|
|
|
|
|
|
-- length :: [a] -> Int
|
|
on |length|(xs)
|
|
set c to class of xs
|
|
if list is c or string is c then
|
|
length of xs
|
|
else
|
|
(2 ^ 29 - 1) -- (maxInt - simple proxy for non-finite)
|
|
end if
|
|
end |length|
|
|
|
|
|
|
-- map :: (a -> b) -> [a] -> [b]
|
|
on map(f, xs)
|
|
tell mReturn(f)
|
|
set lng to length of xs
|
|
set lst to {}
|
|
repeat with i from 1 to lng
|
|
set end of lst to |λ|(item i of xs, i, xs)
|
|
end repeat
|
|
return lst
|
|
end tell
|
|
end map
|
|
|
|
|
|
-- min :: Ord a => a -> a -> a
|
|
on min(x, y)
|
|
if y < x then
|
|
y
|
|
else
|
|
x
|
|
end if
|
|
end min
|
|
|
|
|
|
-- Lift 2nd class handler function into 1st class script wrapper
|
|
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
|
|
on mReturn(f)
|
|
if class of f is script then
|
|
f
|
|
else
|
|
script
|
|
property |λ| : f
|
|
end script
|
|
end if
|
|
end mReturn
|
|
|
|
|
|
-- nubBy :: (a -> a -> Bool) -> [a] -> [a]
|
|
on nubBy(f, xs)
|
|
set g to mReturn(f)'s |λ|
|
|
|
|
script notEq
|
|
property fEq : g
|
|
on |λ|(a)
|
|
script
|
|
on |λ|(b)
|
|
not fEq(a, b)
|
|
end |λ|
|
|
end script
|
|
end |λ|
|
|
end script
|
|
|
|
script go
|
|
on |λ|(xs)
|
|
if (length of xs) > 1 then
|
|
set x to item 1 of xs
|
|
{x} & go's |λ|(filter(notEq's |λ|(x), items 2 thru -1 of xs))
|
|
else
|
|
xs
|
|
end if
|
|
end |λ|
|
|
end script
|
|
|
|
go's |λ|(xs)
|
|
end nubBy
|
|
|
|
|
|
-- partition :: predicate -> List -> (Matches, nonMatches)
|
|
-- partition :: (a -> Bool) -> [a] -> ([a], [a])
|
|
on partition(f, xs)
|
|
tell mReturn(f)
|
|
set ys to {}
|
|
set zs to {}
|
|
repeat with x in xs
|
|
set v to contents of x
|
|
if |λ|(v) then
|
|
set end of ys to v
|
|
else
|
|
set end of zs to v
|
|
end if
|
|
end repeat
|
|
end tell
|
|
Tuple(ys, zs)
|
|
end partition
|
|
|
|
|
|
-- showJSON :: a -> String
|
|
on showJSON(x)
|
|
set c to class of x
|
|
if (c is list) or (c is record) then
|
|
set ca to current application
|
|
set {json, e} to ca's NSJSONSerialization's dataWithJSONObject:x options:0 |error|:(reference)
|
|
if json is missing value then
|
|
e's localizedDescription() as text
|
|
else
|
|
(ca's NSString's alloc()'s initWithData:json encoding:(ca's NSUTF8StringEncoding)) as text
|
|
end if
|
|
else if c is date then
|
|
"\"" & ((x - (time to GMT)) as «class isot» as string) & ".000Z" & "\""
|
|
else if c is text then
|
|
"\"" & x & "\""
|
|
else if (c is integer or c is real) then
|
|
x as text
|
|
else if c is class then
|
|
"null"
|
|
else
|
|
try
|
|
x as text
|
|
on error
|
|
("«" & c as text) & "»"
|
|
end try
|
|
end if
|
|
end showJSON
|
|
|
|
|
|
-- snd :: (a, b) -> b
|
|
on snd(tpl)
|
|
if class of tpl is record then
|
|
|2| of tpl
|
|
else
|
|
item 2 of tpl
|
|
end if
|
|
end snd
|
|
|
|
|
|
-- Enough for small scale sorts.
|
|
-- Use instead sortOn :: Ord b => (a -> b) -> [a] -> [a]
|
|
-- which is equivalent to the more flexible sortBy(comparing(f), xs)
|
|
-- and uses a much faster ObjC NSArray sort method
|
|
-- sortBy :: (a -> a -> Ordering) -> [a] -> [a]
|
|
on sortBy(f, xs)
|
|
if length of xs > 1 then
|
|
set h to item 1 of xs
|
|
set f to mReturn(f)
|
|
script
|
|
on |λ|(x)
|
|
f's |λ|(x, h) ≤ 0
|
|
end |λ|
|
|
end script
|
|
set lessMore to partition(result, rest of xs)
|
|
sortBy(f, |1| of lessMore) & {h} & ¬
|
|
sortBy(f, |2| of lessMore)
|
|
else
|
|
xs
|
|
end if
|
|
end sortBy
|
|
|
|
|
|
-- tail :: [a] -> [a]
|
|
on tail(xs)
|
|
set blnText to text is class of xs
|
|
if blnText then
|
|
set unit to ""
|
|
else
|
|
set unit to {}
|
|
end if
|
|
set lng to length of xs
|
|
if 1 > lng then
|
|
missing value
|
|
else if 2 > lng then
|
|
unit
|
|
else
|
|
if blnText then
|
|
text 2 thru -1 of xs
|
|
else
|
|
rest of xs
|
|
end if
|
|
end if
|
|
end tail
|
|
|
|
|
|
-- take :: Int -> [a] -> [a]
|
|
-- take :: Int -> String -> String
|
|
on take(n, xs)
|
|
set c to class of xs
|
|
if list is c then
|
|
if 0 < n then
|
|
items 1 thru min(n, length of xs) of xs
|
|
else
|
|
{}
|
|
end if
|
|
else if string is c then
|
|
if 0 < n then
|
|
text 1 thru min(n, length of xs) of xs
|
|
else
|
|
""
|
|
end if
|
|
else if script is c then
|
|
set ys to {}
|
|
repeat with i from 1 to n
|
|
set v to xs's |λ|()
|
|
if missing value is v then
|
|
return ys
|
|
else
|
|
set end of ys to v
|
|
end if
|
|
end repeat
|
|
return ys
|
|
else
|
|
missing value
|
|
end if
|
|
end take
|
|
|
|
|
|
-- takeWhile :: (a -> Bool) -> [a] -> [a]
|
|
-- takeWhile :: (Char -> Bool) -> String -> String
|
|
on takeWhile(p, xs)
|
|
if script is class of xs then
|
|
takeWhileGen(p, xs)
|
|
else
|
|
tell mReturn(p)
|
|
repeat with i from 1 to length of xs
|
|
if not |λ|(item i of xs) then ¬
|
|
return take(i - 1, xs)
|
|
end repeat
|
|
end tell
|
|
return xs
|
|
end if
|
|
end takeWhile
|
|
|
|
|
|
-- takeWhileGen :: (a -> Bool) -> Gen [a] -> [a]
|
|
on takeWhileGen(p, xs)
|
|
set ys to {}
|
|
set v to |λ|() of xs
|
|
tell mReturn(p)
|
|
repeat while (|λ|(v))
|
|
set end of ys to v
|
|
set v to xs's |λ|()
|
|
end repeat
|
|
end tell
|
|
return ys
|
|
end takeWhileGen
|
|
|
|
|
|
-- Tuple (,) :: a -> b -> (a, b)
|
|
on Tuple(a, b)
|
|
{type:"Tuple", |1|:a, |2|:b, length:2}
|
|
end Tuple
|
|
|
|
|
|
-- unlines :: [String] -> String
|
|
on unlines(xs)
|
|
set {dlm, my text item delimiters} to ¬
|
|
{my text item delimiters, linefeed}
|
|
set str to xs as text
|
|
set my text item delimiters to dlm
|
|
str
|
|
end unlines
|
|
|
|
|
|
-- zip :: [a] -> [b] -> [(a, b)]
|
|
on zip(xs, ys)
|
|
zipWith(Tuple, xs, ys)
|
|
end zip
|
|
|
|
|
|
-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
|
|
on zipWith(f, xs, ys)
|
|
set lng to min(|length|(xs), |length|(ys))
|
|
if 1 > lng then return {}
|
|
set xs_ to take(lng, xs) -- Allow for non-finite
|
|
set ys_ to take(lng, ys) -- generators like cycle etc
|
|
set lst to {}
|
|
tell mReturn(f)
|
|
repeat with i from 1 to lng
|
|
set end of lst to |λ|(item i of xs_, item i of ys_)
|
|
end repeat
|
|
return lst
|
|
end tell
|
|
end zipWith
|