The very useful example of
https://forum.latenightsw.com/t/create-folder-structure-based-on-excel-data/1706/7
reminded me that I do sometimes need to capture ‘indented’ Excel sheets as outline data, which might then become anything from an OPML (or tab-indented text file) to an OmniGraffle diagram or OO Outline.
Here is a rough draft of something fairly general (code below)
- Reading Excel rows to an generic outline structure (a list of nested ‘tree’ records), and
- rewriting this data to some other format (two examples, an OO outline and a plain text visualisation)
The intention is that testing with an active Excel sheet like:
we should obtain something like:
and:
Sheet1
│
├─ alpha
│ │
│ ├─ delta
│ │ │
│ │ └─ kappa
│ │
│ ├─ epsilon
│ │
│ └─ zeta
│ │
│ ├─ mu
│ │
│ ├─ nu
│ │
│ └─ xi
│
├─ beta
│ │
│ ├─ eta
│ │
│ ├─ theta
│ │ │
│ │ ├─ omicron
│ │ │
│ │ ├─ pi
│ │ │
│ │ ├─ rho
│ │ │
│ │ └─ sigma
│ │
│ └─ iota
│ │
│ ├─ kai
│ │
│ ├─ psi
│ │
│ └─ omega
│
└─ gamma
│
├─ tau
│
├─ upsilon
│
└─ phi
use AppleScript version "2.4" -- Yosemite (10.10) or later
use scripting additions
on run
-- READING INDENTED EXCEL ROWS AS AN OUTLINE FOREST
-- (LIST OF NESTED 'TREE' NODES (AS RECORDS))
tell application "Microsoft Excel"
if 0 < (count of sheets) then
tell active sheet
tell used range to set rowList to formula
if list is class of rowList then
set strSheet to name
set lrTrees to my |Right|(my forestFromCols(my transpose(rowList)))
else
set lrTrees to my |Left|("Empty Excel sheet")
end if
end tell
else
set lrTrees to my |Left|("No Excel sheet found")
end if
end tell
-- OMNIOUTLINER OUTLINE REPRESENTATION OF A FOREST
bindLR(lrTrees, ooOutlineFromForest)
-- PLAIN TEXT VISUALISATION OF THE SAME FOREST
script showTree
on |λ|(xs)
set strForest to drawForest({Node(strSheet, xs)})
set the clipboard to strForest
strForest
end |λ|
end script
bindLR(lrTrees, showTree)
end run
-- AN OO OUTLINE FROM A GENERIC FOREST
on ooOutlineFromForest(trees)
tell application "OmniOutliner"
set oDoc to make new document
script go
on |λ|(oParent, x)
tell oParent
tell (make new row with properties {topic:root of x})
my map(my curry(|λ|)'s |λ|(it), nest of x)
set expanded to true
end tell
end tell
end |λ|
end script
activate
end tell
my map(curry(go's |λ|)'s |λ|(oDoc), trees)
end ooOutlineFromForest
-- FOREST OF TREES FROM ROWS OF STRINGS
-- (Sample strings of strings: Excel 'used range' formulae lists)
-- forestFromCols :: [[String]] -> [Tree]
on forestFromCols(cols)
script rowGroups
on |λ|(rows, xs)
if 0 < length of rows then
set lng to length of item 1 of rows
set cols to map(curry(my take)'s |λ|(lng), xs)
script hasText
on |λ|(x)
missing value is not (root of x)
end |λ|
end script
if 1 < length of cols then
set nest to filter(hasText, forestFromCols(rest of cols))
else
set nest to {}
end if
{Node(head(dropWhile(my isNull, item 1 of cols)), nest)} & ¬
|λ|(rest of rows, map(curry(my drop)'s |λ|(lng), xs))
else
{}
end if
end |λ|
end script
script heading
on |λ|(_, b)
"" ≠ b
end |λ|
end script
rowGroups's |λ|(splitBy(heading, item 1 of cols), cols)
end forestFromCols
-- GENERIC FUNCTIONS ----------------------------------------
-- https://github.com/RobTrew/prelude-applescript
-- Node :: a -> [Tree a] -> Tree a
on Node(v, xs)
{type:"Node", root:v, nest:xs}
end Node
-- Left :: a -> Either a b
on |Left|(x)
{type:"Either", |Left|:x, |Right|:missing value}
end |Left|
-- Right :: b -> Either a b
on |Right|(x)
{type:"Either", |Left|:missing value, |Right|:x}
end |Right|
-- Append two lists.
-- append (++) :: [a] -> [a] -> [a]
-- append (++) :: String -> String -> String
on append(xs, ys)
xs & ys
end append
-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
on bindLR(m, mf)
if missing value is not |Right| of m then
mReturn(mf)'s |λ|(|Right| of m)
else
m
end if
end bindLR
-- 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
-- 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
-- cons :: a -> [a] -> [a]
on cons(x, xs)
if list is class of xs then
{x} & xs
else
x & xs
end if
end cons
-- curry :: ((a, b) -> c) -> a -> b -> c
on curry(f)
script
on |λ|(a)
script
on |λ|(b)
|λ|(a, b) of mReturn(f)
end |λ|
end script
end |λ|
end script
end curry
-- draw :: Tree String -> [String]
on draw(tree)
-- shift :: String -> String -> [String] -> [String]
script shift
on |λ|(strFirst, strOther, xs)
zipWith(my append, ¬
cons(strFirst, replicate((length of xs) - 1, strOther)), xs)
end |λ|
end script
-- drawSubTrees :: [Tree String] -> [String]
script drawSubTrees
on |λ|(xs)
set lng to length of xs
if 0 < lng then
if 1 < lng then
cons("│", append(shift's |λ|("├─ ", "│ ", draw(item 1 of xs)), ¬
|λ|(items 2 thru -1 of xs)))
else
cons("│", shift's |λ|("└─ ", " ", draw(item 1 of xs)))
end if
else
{}
end if
end |λ|
end script
paragraphs of (root of tree) & |λ|(nest of tree) of drawSubTrees
end draw
-- drawForest :: [Tree String] -> String
on drawForest(trees)
intercalate("
", map(my drawTree, trees))
end drawForest
-- drawTree :: Tree String -> String
on drawTree(tree)
unlines(draw(tree))
end drawTree
-- 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
-- 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
-- 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 |λ|(v, item i of xs, i, xs)
end repeat
return v
end tell
end foldl
-- head :: [a] -> a
on head(xs)
if xs = {} then
missing value
else
item 1 of xs
end if
end head
-- intercalate :: [a] -> [[a]] -> [a]
-- intercalate :: String -> [String] -> String
on intercalate(sep, xs)
concat(intersperse(sep, xs))
end intercalate
-- intersperse(0, [1,2,3]) -> [1, 0, 2, 0, 3]
-- intersperse :: a -> [a] -> [a]
-- intersperse :: Char -> String -> String
on intersperse(sep, xs)
set lng to length of xs
if lng > 1 then
set acc to {item 1 of xs}
repeat with i from 2 to lng
set acc to acc & {sep, item i of xs}
end repeat
if class of xs is string then
concat(acc)
else
acc
end if
else
xs
end if
end intersperse
-- isNull :: [a] -> Bool
-- isNull :: String -> Bool
on isNull(xs)
if class of xs is string then
"" = xs
else
{} = xs
end if
end isNull
-- 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
-- maximumBy :: (a -> a -> Ordering) -> [a] -> a
on maximumBy(f, xs)
set cmp to mReturn(f)
script max
on |λ|(a, b)
if a is missing value or cmp's |λ|(a, b) < 0 then
b
else
a
end if
end |λ|
end script
foldl(max, missing value, xs)
end maximumBy
-- 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
-- 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
-- shift :: Int -> [a] -> [a]
on shift(n, xs)
set lng to |length|(xs)
if missing value is not lng then
take(lng, drop(n, cycle(xs)))
else
drop(n, xs)
end if
end shift
-- splitBy :: (a -> a -> Bool) -> [a] -> [[a]]
-- splitBy :: (String -> String -> Bool) -> String -> [String]
on splitBy(p, xs)
if 2 > length of xs then
{xs}
else
script pairMatch
property mp : mReturn(p)'s |λ|
on |λ|(a, b)
{mp(a, b), a, b}
end |λ|
end script
script addOrSplit
on |λ|(a, blnXY)
set {bln, x, y} to blnXY
if bln then
{item 1 of a & {item 2 of a}, {y}}
else
{item 1 of a, (item 2 of a) & y}
end if
end |λ|
end script
set {a, r} to foldl(addOrSplit, ¬
{{}, {item 1 of xs}}, ¬
zipWith(pairMatch, xs, rest of xs))
if list is class of xs then
a & {r}
else
map(my concat, a & {r})
end if
end if
end splitBy
-- 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
-- If some of the rows are shorter than the following rows,
-- their elements are skipped:
-- transpose({{10,11},{20},{},{30,31,32}}) -> {{10, 20, 30}, {11, 31}, {32}}
-- transpose :: [[a]] -> [[a]]
on transpose(xxs)
set intMax to |length|(maximumBy(comparing(my |length|), xxs))
set gaps to replicate(intMax, {})
script padded
on |λ|(xs)
set lng to |length|(xs)
if lng < intMax then
xs & items (lng + 1) thru -1 of gaps
else
xs
end if
end |λ|
end script
set rows to map(padded, xxs)
script cols
on |λ|(_, iCol)
script cell
on |λ|(row)
item iCol of row
end |λ|
end script
concatMap(cell, rows)
end |λ|
end script
map(cols, item 1 of rows)
end transpose
-- 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
-- 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