September Morn Update

Task/Sort-disjoint-sublist/AppleScript/sort-disjoint-sublist-1.applescript

@@ -1,58 +1,70 @@
-use framework "Foundation" -- for basic NSArray sort
+use AppleScript version "2.4"
+use framework "Foundation"
+use scripting additions
 
--- DISJOINT SORT -------------------------------------------------------------
 
---  disjointSort :: [a] -> [Int] -> [a]
-on disjointSort(xs, indices)
-
-    -- Sequence of indices discarded
-    set indicesSorted to my sort(indices)
-
-    -- valueByIndex :: Int -> a
-    script valueByIndex
-        on |λ|(i)
-            item i of xs
+-- disjointSort :: [Int] -> [Int] -> [Int]
+on disjointSort(ixs, xs)
+    set ks to sort(ixs)
+    script nth -- 1-based index
+        on |λ|(k)
+            item (succ(k)) of xs
         end |λ|
     end script
+    set dct to mapFromList(zip(ks, sort(map(nth, ks))))
 
-    set subsetSorted to ¬
-        sort(map(valueByIndex, indicesSorted))
-
-    -- staticOrSorted :: a -> Int -> a
-    script staticOrSorted
+    script build
         on |λ|(x, i)
-            set iIndex to elemIndex(i, indicesSorted)
-            if iIndex is missing value then
+            set mb to lookupDict(pred(i) as string, dct)
+            if Nothing of mb then
                 x
             else
-                item iIndex of subsetSorted
+                |Just| of mb
             end if
         end |λ|
     end script
-
-    -- Sorted subset re-stitched into unsorted remainder of list
-    map(staticOrSorted, xs)
-
+    map(build, xs)
 end disjointSort
 
--- TEST ----------------------------------------------------------------------
-on run
-    -- The indexing of AppleScript lists is 1-based
-    -- so we use {7,2,8} in place of {6,1,7}
 
-    disjointSort({7, 6, 5, 4, 3, 2, 1, 0}, {7, 2, 8})
+on run
+    disjointSort({6, 1, 7}, {7, 6, 5, 4, 3, 2, 1, 0})
 end run
 
--- GENERIC FUNCTIONS ---------------------------------------------------------
 
--- elemIndex :: a -> [a] -> Maybe Int
-on elemIndex(x, xs)
-    set lng to length of xs
-    repeat with i from 1 to lng
-        if x = (item i of xs) then return i
-    end repeat
-    return missing value
-end elemIndex
+
+-- GENERIC FUNCTIONS ----------------------------------------------------
+
+-- Just :: a -> Maybe a
+on Just(x)
+    {type:"Maybe", Nothing:false, Just:x}
+end Just
+
+-- Nothing :: Maybe a
+on Nothing()
+    {type:"Maybe", Nothing:true}
+end Nothing
+
+-- 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|
+
+-- lookupDict :: a -> Dict -> Maybe b
+on lookupDict(k, dct)
+    set ca to current application
+    set v to (ca's NSDictionary's dictionaryWithDictionary:dct)'s objectForKey:k
+    if v ≠ missing value then
+        Just(item 1 of ((ca's NSArray's arrayWithObject:v) as list))
+    else
+        Nothing()
+    end if
+end lookupDict
 
 -- map :: (a -> b) -> [a] -> [b]
 on map(f, xs)
@@ -66,8 +78,30 @@ on map(f, xs)
     end tell
 end map
 
+-- mapFromList :: [(k, v)] -> Dict
+on mapFromList(kvs)
+    set tpl to unzip(kvs)
+    script
+        on |λ|(x)
+            x as string
+        end |λ|
+    end script
+    (current application's NSDictionary's ¬
+        dictionaryWithObjects:(|2| of tpl) ¬
+            forKeys:map(result, |1| of tpl)) as record
+end mapFromList
+
+-- 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 :: Handler -> Script
+-- mReturn :: First-class m => (a -> b) -> m (a -> b)
 on mReturn(f)
     if class of f is script then
         f
@@ -78,8 +112,86 @@ on mReturn(f)
     end if
 end mReturn
 
--- sort :: [a] -> [a]
-on sort(lst)
-    ((current application's NSArray's arrayWithArray:lst)'s ¬
+-- pred :: Enum a => a -> a
+on pred(x)
+    x - 1
+end pred
+
+-- sort :: Ord a => [a] -> [a]
+on sort(xs)
+    ((current application's NSArray's arrayWithArray:xs)'s ¬
         sortedArrayUsingSelector:"compare:") as list
 end sort
+
+-- succ :: Enum a => a -> a
+on succ(x)
+    1 + x
+end succ
+
+-- 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
+
+-- Tuple (,) :: a -> b -> (a, b)
+on Tuple(a, b)
+    {type:"Tuple", |1|:a, |2|:b, length:2}
+end Tuple
+
+-- unzip :: [(a,b)] -> ([a],[b])
+on unzip(xys)
+    set xs to {}
+    set ys to {}
+    repeat with xy in xys
+        set end of xs to |1| of xy
+        set end of ys to |2| of xy
+    end repeat
+    return Tuple(xs, ys)
+end unzip
+
+-- 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