2016 Update

Task/Box-the-compass/AppleScript/box-the-compass.applescript

@@ -0,0 +1,375 @@
+use framework "Foundation"
+use scripting additions
+
+property plstLangs : [{|name|:"English"} & ¬
+    {expansions:{N:"north", S:"south", E:"east", W:"west", b:" by "}} & ¬
+    {|N|:"N", |NNNE|:"NbE", |NNE|:"N-NE", |NNENE|:"NEbN", |NE|:"NE", |NENEE|:"NEbE"} & ¬
+    {|NEE|:"E-NE", |NEEE|:"EbN", |E|:"E", |EEES|:"EbS", |EES|:"E-SE", |EESES|:"SEbE"} & ¬
+    {|ES|:"SE", |ESESS|:"SEbS", |ESS|:"S-SE", |ESSS|:"SbE", |S|:"S", |SSSW|:"SbW"} & ¬
+    {|SSW|:"S-SW", |SSWSW|:"SWbS", |SW|:"SW", |SWSWW|:"SWbW", |SWW|:"W-SW"} & ¬
+    {|SWWW|:"WbS", |W|:"W", |WWWN|:"WbN", |WWN|:"W-NW", |WWNWN|:"NWbW"} & ¬
+    {|WN|:"NW", |WNWNN|:"NWbN", |WNN|:"N-NW", |WNNN|:"NbW"}, ¬
+    ¬
+        {|name|:"Chinese", |N|:"北", |NNNE|:"北微东", |NNE|:"东北偏北"} & ¬
+    {|NNENE|:"东北微北", |NE|:"东北", |NENEE|:"东北微东", |NEE|:"东北偏东"} & ¬
+    {|NEEE|:"东微北", |E|:"东", |EEES|:"东微南", |EES|:"东南偏东", |EESES|:"东南微东"} & ¬
+    {|ES|:"东南", |ESESS|:"东南微南", |ESS|:"东南偏南", |ESSS|:"南微东", |S|:"南"} & ¬
+    {|SSSW|:"南微西", |SSW|:"西南偏南", |SSWSW|:"西南微南", |SW|:"西南"} & ¬
+    {|SWSWW|:"西南微西", |SWW|:"西南偏西", |SWWW|:"西微南", |W|:"西"} & ¬
+    {|WWWN|:"西微北", |WWN|:"西北偏西", |WWNWN|:"西北微西", |WN|:"西北"} & ¬
+    {|WNWNN|:"西北微北", |WNN|:"西北偏北", |WNNN|:"北微西"}]
+
+--  Scale invariant keys for points of the compass
+-- (allows us to look up a translation for one scale of compass (32 here)
+-- for use in another size of compass (8 or 16 points)
+-- (Also semi-serviceable as more or less legible keys without translation)
+
+-- compassKeys :: Int -> [String]
+on compassKeys(intDepth)
+    -- Simplest compass divides into two hemispheres
+    -- with one peak of ambiguity to the left,
+    -- and one to the right  (encoded by the commas in this list):
+    set urCompass to ["N", "S", "N"]
+
+    -- Necessity drives recursive subdivision of broader directions, shrinking
+    -- boxes down to a workable level of precision:
+    script subdivision
+        on lambda(lstCompass, N)
+            if N ≤ 1 then
+                lstCompass
+            else
+                script subKeys
+                    on lambda(a, x, i, xs)
+                        -- Borders between N and S engender E and W.
+                        -- further subdivisions (boxes) concatenate their two parent keys.
+                        if i > 1 then
+                            cond(N = intDepth, ¬
+                                a & {cond(x = "N", "W", "E")} & x, ¬
+                                a & {item (i - 1) of xs & x} & x)
+                        else
+                            a & x
+                        end if
+                    end lambda
+                end script
+
+                lambda(foldl(subKeys, {}, lstCompass), N - 1)
+            end if
+        end lambda
+    end script
+
+    tell subdivision to items 1 thru -2 of lambda(urCompass, intDepth)
+end compassKeys
+
+-- pointIndex :: Int -> Num -> String
+on pointIndex(power, degrees)
+    set nBoxes to 2 ^ power
+    set i to round (degrees + (360 / (nBoxes * 2))) mod 360 * nBoxes / 360 rounding up
+    cond(i > 0, i, 1)
+end pointIndex
+
+-- pointNames :: Int -> Int -> [String]
+on pointNames(precision, iBox)
+    set k to item iBox of compassKeys(precision)
+
+    script translation
+        on lambda(recLang)
+            set maybeTrans to keyValue(recLang, k)
+            set strBrief to cond(maybeTrans is missing value, k, maybeTrans)
+
+            set recExpand to keyValue(recLang, "expansions")
+
+            if recExpand is not missing value then
+                script expand
+                    on lambda(c)
+                        set t to keyValue(recExpand, c)
+                        cond(t is not missing value, t, c)
+                    end lambda
+                end script
+                set strName to (intercalate(cond(precision > 5, " ", ""), ¬
+                    map(expand, characters of strBrief)))
+                toUpper(text item 1 of strName) & text items 2 thru -1 of strName
+            else
+                strBrief
+            end if
+        end lambda
+    end script
+
+    map(translation, plstLangs)
+end pointNames
+
+-- maxLen :: [String] -> Int
+on maxLen(xs)
+    -- compareByLength = (String, String) -> (-1 | 0 | 1)
+    script compareByLength
+        on lambda(a, b)
+            set {intA, intB} to {length of a, length of b}
+            cond(intA < intB, -1, cond(intA > intB, 1, 0))
+        end lambda
+    end script
+
+    length of maximumBy(compareByLength, xs)
+end maxLen
+
+-- alignRight :: Int -> String -> String
+on alignRight(nWidth, x)
+    justifyRight(nWidth, space, x)
+end alignRight
+
+-- alignLeft :: Int -> String -> String
+on alignLeft(nWidth, x)
+    justifyLeft(nWidth, space, x)
+end alignLeft
+
+-- show :: asString => a -> Text
+on show(x)
+    x as string
+end show
+
+-- compassTable :: Int -> [Num] -> Maybe String
+on compassTable(precision, xs)
+    if precision < 1 then
+        missing value
+    else
+        set intPad to 2
+        set rightAligned to curry(alignRight)
+        set leftAligned to curry(alignLeft)
+        set join to curry(my intercalate)
+
+        -- INDEX COLUMN
+        set lstIndex to map(lambda(precision) of curry(pointIndex), xs)
+        set lstStrIndex to map(show, lstIndex)
+        set nIndexWidth to maxLen(lstStrIndex)
+        set colIndex to map(lambda(nIndexWidth + intPad) of rightAligned, lstStrIndex)
+
+        -- ANGLES COLUMN
+        script degreeFormat
+            on lambda(x)
+                set {c, m} to splitOn(".", x as string)
+                c & "." & (text 1 thru 2 of (m & "0")) & "°"
+            end lambda
+        end script
+        set lstAngles to map(degreeFormat, xs)
+        set nAngleWidth to maxLen(lstAngles) + intPad
+        set colAngles to map(lambda(nAngleWidth) of rightAligned, lstAngles)
+
+        -- NAMES COLUMNS
+        script precisionNames
+            on lambda(iBox)
+                pointNames(precision, iBox)
+            end lambda
+        end script
+
+        set lstTrans to transpose(map(precisionNames, lstIndex))
+        set lstTransWidths to map(maxLen, lstTrans)
+
+        script spacedNames
+            on lambda(lstLang, i)
+                map(lambda((item i of lstTransWidths) + 2) of leftAligned, lstLang)
+            end lambda
+        end script
+
+        set colsTrans to map(spacedNames, lstTrans)
+
+        -- TABLE
+        intercalate(linefeed, ¬
+            map(lambda("") of join, ¬
+                transpose({colIndex} & {colAngles} & ¬
+                    {replicate(length of lstIndex, "  ")} & colsTrans)))
+    end if
+end compassTable
+
+
+
+-- TEST
+on run
+
+    set xs to [0.0, 16.87, 16.88, 33.75, 50.62, 50.63, 67.5, 84.37, ¬
+        84.38, 101.25, 118.12, 118.13, 135.0, 151.87, 151.88, 168.75, ¬
+        185.62, 185.63, 202.5, 219.37, 219.38, 236.25, 253.12, 253.13, ¬
+        270.0, 286.87, 286.88, 303.75, 320.62, 320.63, 337.5, 354.37, ¬
+        354.38]
+
+    --   If we supply other precisions, like 4 or 6, (2^n -> 16 or 64 boxes)
+    --    the bearings will be divided amongst smaller or larger numbers of boxes,
+    --    either using name translations retrieved by the generic hash
+    --    or using the keys of the hash itself (combined with any expansions)
+    --    to substitute for missing names for very finely divided boxes.
+
+    compassTable(5, xs) -- // 2^5  -> 32 boxes
+
+end run
+
+
+-- GENERIC FUNCTIONS
+
+-- 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 lambda(item i of xs, i, xs)
+        end repeat
+        return lst
+    end tell
+end map
+
+-- foldl :: (a -> b -> a) -> a -> [b] -> a
+on foldl(f, startValue, xs)
+    tell mReturn(f)
+        set v to startValue
+        set lng to length of xs
+        repeat with i from 1 to lng
+            set v to lambda(v, item i of xs, i, xs)
+        end repeat
+        return v
+    end tell
+end foldl
+
+-- curry :: (Script|Handler) -> Script
+on curry(f)
+    script
+        on lambda(a)
+            script
+                on lambda(b)
+                    lambda(a, b) of mReturn(f)
+                end lambda
+            end script
+        end lambda
+    end script
+end curry
+
+-- transpose :: [[a]] -> [[a]]
+on transpose(xss)
+    script column
+        on lambda(_, iCol)
+            script row
+                on lambda(xs)
+                    item iCol of xs
+                end lambda
+            end script
+
+            map(row, xss)
+        end lambda
+    end script
+
+    map(column, item 1 of xss)
+end transpose
+
+-- maximumBy :: (a -> a -> Ordering) -> [a] -> a
+on maximumBy(f, xs)
+    set cmp to mReturn(f)
+    script max
+        on lambda(a, b)
+            if a is missing value or cmp's lambda(a, b) < 0 then
+                b
+            else
+                a
+            end if
+        end lambda
+    end script
+
+    foldl(max, missing value, xs)
+end maximumBy
+
+-- splitOn :: Text -> Text -> [Text]
+on splitOn(strDelim, strMain)
+    set {dlm, my text item delimiters} to {my text item delimiters, strDelim}
+    set xs to text items of strMain
+    set my text item delimiters to dlm
+    return xs
+end splitOn
+
+-- 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
+    set my text item delimiters to dlm
+    return strJoined
+end intercalate
+
+-- keyValue :: Record -> String -> Maybe String
+on keyValue(rec, strKey)
+    set ca to current application
+    set v to (ca's NSDictionary's dictionaryWithDictionary:rec)'s objectForKey:strKey
+    if v is not missing value then
+        item 1 of ((ca's NSArray's arrayWithObject:v) as list)
+    else
+        missing value
+    end if
+end keyValue
+
+-- toLower :: String -> String
+on toLower(str)
+    set ca to current application
+    ((ca's NSString's stringWithString:(str))'s ¬
+        lowercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
+end toLower
+
+-- toUpper :: String -> String
+on toUpper(str)
+    set ca to current application
+    ((ca's NSString's stringWithString:(str))'s ¬
+        uppercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
+end toUpper
+
+-- toTitle :: String -> String
+on toTitle(str)
+    set ca to current application
+    ((ca's NSString's stringWithString:(str))'s ¬
+        capitalizedStringWithLocale:(ca's NSLocale's currentLocale())) as text
+end toTitle
+
+
+-- justifyLeft :: Int -> Char -> Text -> Text
+on justifyLeft(N, cFiller, strText)
+    if N > length of strText then
+        text 1 thru N of (strText & replicate(N, cFiller))
+    else
+        strText
+    end if
+end justifyLeft
+
+-- justifyRight :: Int -> Char -> Text -> Text
+on justifyRight(N, cFiller, strText)
+    if N > length of strText then
+        text -N thru -1 of ((replicate(N, cFiller) as text) & strText)
+    else
+        strText
+    end if
+end justifyRight
+
+-- 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
+
+-- Lift 2nd class handler function into 1st class script wrapper
+-- mReturn :: Handler -> Script
+on mReturn(f)
+    if class of f is script then
+        f
+    else
+        script
+            property lambda : f
+        end script
+    end if
+end mReturn
+
+-- cond :: Bool -> a -> a -> a
+on cond(bool, f, g)
+    if bool then
+        f
+    else
+        g
+    end if
+end cond