164 lines
3.5 KiB
AppleScript
164 lines
3.5 KiB
AppleScript
------------------------- CANTOR SET -----------------------
|
|
|
|
-- cantor :: [String] -> [String]
|
|
on cantor(xs)
|
|
script go
|
|
on |λ|(s)
|
|
set m to (length of s) div 3
|
|
set blocks to text 1 thru m of s
|
|
|
|
if "█" = text 1 of s then
|
|
{blocks, replicate(m, space), blocks}
|
|
else
|
|
{s}
|
|
end if
|
|
end |λ|
|
|
end script
|
|
concatMap(go, xs)
|
|
end cantor
|
|
|
|
|
|
---------------------------- TEST --------------------------
|
|
on run
|
|
showCantor(5)
|
|
end run
|
|
|
|
-- showCantor :: Int -> String
|
|
on showCantor(n)
|
|
unlines(map(my concat, ¬
|
|
take(n, iterate(cantor, ¬
|
|
{replicate(3 ^ (n - 1), "█")}))))
|
|
end showCantor
|
|
|
|
|
|
--------------------- GENERIC FUNCTIONS --------------------
|
|
|
|
-- concat :: [[a]] -> [a]
|
|
-- concat :: [String] -> String
|
|
on concat(xs)
|
|
set lng to length of xs
|
|
if 0 < lng and string is class of (item 1 of xs) then
|
|
set acc to ""
|
|
else
|
|
set acc to {}
|
|
end if
|
|
repeat with i from 1 to lng
|
|
set acc to acc & item i of xs
|
|
end repeat
|
|
acc
|
|
end concat
|
|
|
|
|
|
-- concatMap :: (a -> [b]) -> [a] -> [b]
|
|
on concatMap(f, xs)
|
|
set lng to length of xs
|
|
set acc to {}
|
|
tell mReturn(f)
|
|
repeat with i from 1 to lng
|
|
set acc to acc & |λ|(item i of xs, i, xs)
|
|
end repeat
|
|
end tell
|
|
return acc
|
|
end concatMap
|
|
|
|
|
|
-- map :: (a -> b) -> [a] -> [b]
|
|
on map(f, xs)
|
|
tell mReturn(f)
|
|
set lng to length of xs
|
|
set lst to {}
|
|
repeat with i from 1 to lng
|
|
set end of lst to |λ|(item i of xs, i, xs)
|
|
end repeat
|
|
return lst
|
|
end tell
|
|
end map
|
|
|
|
|
|
-- Lift 2nd class handler function into 1st class script wrapper
|
|
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
|
|
on mReturn(f)
|
|
if class of f is script then
|
|
f
|
|
else
|
|
script
|
|
property |λ| : f
|
|
end script
|
|
end if
|
|
end mReturn
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
-- replicate :: Int -> String -> String
|
|
on replicate(n, s)
|
|
set out to ""
|
|
if n < 1 then return out
|
|
set dbl to s
|
|
|
|
repeat while (n > 1)
|
|
if (n mod 2) > 0 then set out to out & dbl
|
|
set n to (n div 2)
|
|
set dbl to (dbl & dbl)
|
|
end repeat
|
|
return out & dbl
|
|
end replicate
|
|
|
|
|
|
-- 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
|
|
|
|
|
|
-- 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
|