September Morn Update

Task/Pascals-triangle/AppleScript/pascals-triangle.applescript

@@ -1,94 +1,83 @@
--- PASCAL ---------------------------------------------------------------------
-
--- pascal :: Int -> [[Int]]
-on pascal(intRows)
-
-    script addRow
-        on nextRow(row)
-            script add
-                on |λ|(a, b)
-                    a + b
-                end |λ|
-            end script
-
-            zipWith(add, [0] & row, row & [0])
-        end nextRow
-
-        on |λ|(xs)
-            xs & {nextRow(item -1 of xs)}
+-- pascal :: Generator [[Int]]
+on pascal()
+    script nextRow
+        on |λ|(row)
+            zipWith(my plus, {0} & row, row & {0})
         end |λ|
     end script
-
-    foldr(addRow, {{1}}, enumFromTo(1, intRows - 1))
+    iterate(nextRow, {1})
 end pascal
 
--- TEST -----------------------------------------------------------------------
+
 on run
-    set lstTriangle to pascal(7)
-
-    script spaced
-        on |λ|(xs)
-            script rightAlign
-                on |λ|(x)
-                    text -4 thru -1 of ("    " & x)
-                end |λ|
-            end script
-
-            intercalate("", map(rightAlign, xs))
-        end |λ|
-    end script
-
-    script indented
-        on |λ|(a, x)
-            set strIndent to leftSpace of a
-
-            {rows:¬
-                strIndent & x & linefeed & rows of a, leftSpace:¬
-                leftSpace of a & "  "} ¬
-
-        end |λ|
-    end script
-
-    rows of foldr(indented, ¬
-        {rows:"", leftSpace:""}, map(spaced, lstTriangle))
+    showPascal(take(7, pascal()))
 end run
 
--- GENERIC FUNCTIONS ----------------------------------------------------------
 
--- enumFromTo :: Int -> Int -> [Int]
-on enumFromTo(m, n)
-    if n < m then
-        set d to -1
+-- showPascal :: [[Int]] -> String
+on showPascal(xs)
+    set w to length of intercalate("   ", item -1 of xs)
+    script align
+        on |λ|(x)
+            |center|(w, space, intercalate("   ", x))
+        end |λ|
+    end script
+    unlines(map(align, xs))
+end showPascal
+
+
+-- GENERIC ABSTRACTIONS -------------------------------------------------------
+
+-- center :: Int -> Char -> String -> String
+on |center|(n, cFiller, strText)
+    set lngFill to n - (length of strText)
+    if lngFill > 0 then
+        set strPad to replicate(lngFill div 2, cFiller) as text
+        set strCenter to strPad & strText & strPad
+        if lngFill mod 2 > 0 then
+            cFiller & strCenter
+        else
+            strCenter
+        end if
     else
-        set d to 1
+        strText
     end if
-    set lst to {}
-    repeat with i from m to n by d
-        set end of lst to i
-    end repeat
-    return lst
-end enumFromTo
+end |center|
 
--- foldr :: (a -> b -> a) -> a -> [b] -> a
-on foldr(f, startValue, xs)
-    tell mReturn(f)
-        set v to startValue
-        set lng to length of xs
-        repeat with i from lng to 1 by -1
-            set v to |λ|(v, item i of xs, i, xs)
-        end repeat
-        return v
-    end tell
-end foldr
-
--- intercalate :: Text -> [Text] -> Text
-on intercalate(strText, lstText)
-    set {dlm, my text item delimiters} to {my text item delimiters, strText}
-    set strJoined to lstText as text
+-- intercalate :: String -> [String] -> String
+on intercalate(sep, xs)
+    set {dlm, my text item delimiters} to {my text item delimiters, sep}
+    set s to xs as text
     set my text item delimiters to dlm
-    return strJoined
+    return s
 end intercalate
 
+-- iterate :: (a -> a) -> a -> Generator [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 ^ 30 -- (simple proxy for non-finite)
+    end if
+end |length|
+
 -- map :: (a -> b) -> [a] -> [b]
 on map(f, xs)
     tell mReturn(f)
@@ -111,7 +100,7 @@ on min(x, y)
 end min
 
 -- Lift 2nd class handler function into 1st class script wrapper
--- mReturn :: Handler -> Script
+-- mReturn :: First-class m => (a -> b) -> m (a -> b)
 on mReturn(f)
     if class of f is script then
         f
@@ -122,13 +111,82 @@ on mReturn(f)
     end if
 end mReturn
 
+-- plus :: Num -> Num -> Num
+on plus(a, b)
+    a + b
+end plus
+
+-- Egyptian multiplication - progressively doubling a list, appending
+-- stages of doubling to an accumulator where needed for binary
+-- assembly of a target length
+-- replicate :: Int -> a -> [a]
+on replicate(n, a)
+    set out to {}
+    if n < 1 then return out
+    set dbl to {a}
+
+    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 end of ys to xs's |λ|()
+        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
+
+-- unwords :: [String] -> String
+on unwords(xs)
+    set {dlm, my text item delimiters} to {my text item delimiters, space}
+    set s to xs as text
+    set my text item delimiters to dlm
+    return s
+end unwords
+
 -- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
 on zipWith(f, xs, ys)
-    set lng to min(length of xs, length of 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)
+            set end of lst to |λ|(item i of xs_, item i of ys_)
         end repeat
         return lst
     end tell