Tinderbox Forum

A first experiment with AppleScript in Tinderbox 8


(RobTrew) #1

FWIW a first experiment in traversing the tree of Tinderbox 8 notes with Applescript.

(Counting all notes, childless leaf notes, and nesting layers, as well as listing all note titles)

Runs in macOS Script Editor, etc:

use AppleScript version "2.4" -- Yosemite (10.10) or later
use scripting additions

-- nodeCount :: Tree a -> Int
on nodeCount(_, xs)
    -- One more than the total number of descendants.
    -- (With foldTree, returns the total number of nodes in the note tree,
    --  including the document/root node)
    1 + sum(xs)
end nodeCount

-- treeWidth :: Tree a -> Int
on treeWidth(_, xs)
    -- Sum of widths of any children, or a minimum of 1.
    -- (With foldTree, returns the total count of
    --  childless leaf notes in the tree)
    if xs ≠ {} then
        sum(xs)
    else
        1
    end if
end treeWidth

-- treeDepth :: Tree a -> Int
on treeDepth(_, xs)
    -- One more than that of the deepest child.
    -- (With foldTree, returns the total number of levels in the tree)
    if xs ≠ {} then
        1 + maximum(xs)
    else
        0
    end if
end treeDepth

-- preorder :: a -> [[a]] -> [a]
on preorder(x, xs)
    -- Name of this node followed by the rest.
    -- (With foldTree, returns an ordered list of note names)
    {name of x} & concat(xs)
end preorder

on run
    tell application "Tinderbox 8"
        set ds to documents
        if 0 < (count of ds) then
            set lrDoc to my |Right|(item 1 of ds)
        else
            set lrDoc to my |Left|("No documents open in " & name)
        end if
        
        script asTree
            on |λ|(x)
                my pureTreeTBX(x)
            end |λ|
        end script
        set oTree to my bindLR(lrDoc, asTree)
    end tell
    
    -- TESTING TRAVERSAL OF THE TINDERBOX NOTE TREE
    
    -- Total number of notes traversed, total number of childless leaf notes,
    -- depth of tree (number of nesting levels)
    
    {notesTotal:foldTree(nodeCount, oTree) - 1 ¬
        , leavesTotal:foldTree(treeWidth, oTree) ¬
        , levelsTotal:foldTree(treeDepth, oTree) ¬
        , noteTitles:unlines(foldTree(preorder, oTree))}
    
    
end run

-- TINDERBOX ----------------------------------------------

-- pureTreeTBX :: Note -> Tree Note
on pureTreeTBX(oNote)
    using terms from application "Tinderbox 8"
        script go
            on |λ|(x)
                Node(x, my map(go, notes of x))
            end |λ|
        end script
        |λ|(oNote) of go
    end using terms from
end pureTreeTBX


-- GENERIC ------------------------------------------------
-- https://github.com/RobTrew/prelude-applescript

-- 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|

-- 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

-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
    {type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple

-- Node :: a -> [Tree a] -> Tree a
on Node(v, xs)
    {type:"Node", root:v, nest:xs}
end Node

-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
on bindLR(m, mf)
    if missing value is not |Right| of m then
        |λ|(|Right| of m) of mReturn(mf)
    else
        m
    end if
end bindLR

-- 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

-- 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

-- foldl1 :: (a -> a -> a) -> [a] -> a
on foldl1(f, xs)
    if length of xs > 1 then
        tell mReturn(f)
            set v to {item 1 of xs}
            set lng to length of xs
            repeat with i from 2 to lng
                set v to |λ|(v, item i of xs, i, xs)
            end repeat
            return v
        end tell
    else
        item 1 of xs
    end if
end foldl1

-- foldMapTree :: Monoid m => (a -> m) -> Tree a -> m
on foldMapTree(f, tree)
    script go
        property g : |λ| of mReturn(f)
        on |λ|(x)
            if length of (nest of x) > 0 then
                mappend(g(root of x), ¬
                    foldl1(my mappend, (map(go, nest of x))))
            else
                g(root of x)
            end if
        end |λ|
    end script
    
    |λ|(tree) of go
end foldMapTree


-- foldTree :: (a -> [b] -> b) -> Tree a -> b
on foldTree(f, tree)
    script go
        property g : |λ| of mReturn(f)
        on |λ|(oNode)
            g(root of oNode, map(go, nest of oNode))
        end |λ|
    end script
    |λ|(tree) of go
end foldTree

-- 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


-- mappend (<>) :: Monoid a => a -> a -> a
on mappend(a, b)
    set ca to class of a
    if record is ca then
        script instanceMay
            on |λ|(strType)
                set mb to lookup(strType, ¬
                    {Maybe:mappendMaybe, Ordering:mappendOrdering, Tuple:mappendTuple})
            end |λ|
        end script
        set mbi to bindMay(lookup("type", a), instanceMay)
        if Nothing of mbi then
            a & b
        else
            |λ|(a, b) of mReturn(Just of mbi)
        end if
    else if handler is ca then
        mappendFn(a, b)
    else
        a & b
    end if
end mappend

-- maximum :: Ord a => [a] -> a
on maximum(xs)
    script
        on |λ|(a, b)
            if a is missing value or b > a then
                b
            else
                a
            end if
        end |λ|
    end script
    
    foldl(result, missing value, xs)
end maximum

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- str :: a -> String
on str(x)
    x as string
end str

-- sum :: [Num] -> Num
on sum(xs)
    script add
        on |λ|(a, b)
            a + b
        end |λ|
    end script
    
    foldl(add, 0, xs)
end sum


-- > unfoldl (\b -> if b == 0 then Nothing else Just (b, b-1)) 10
-- > [1,2,3,4,5,6,7,8,9,10]
-- unfoldl :: (b -> Maybe (b, a)) -> b -> [a]
on unfoldl(f, v)
    set xr to Tuple(v, v) -- (value, remainder)
    set xs to {}
    tell mReturn(f)
        repeat -- Function applied to remainder.
            set mb to |λ|(|2| of xr)
            if Nothing of mb then
                exit repeat
            else -- New (value, remainder) tuple,
                set xr to Just of mb
                -- and value appended to output list.
                set xs to (xs & {|1| of xr})
            end if
        end repeat
    end tell
    return xs
end unfoldl

-- 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

(RobTrew) #2

Re performance, note that the time taken above is in building a tree structure of more rapidly accessible nodes - once that is constructed, other traversals and translations of the tree (exporting in other nested formats, obtaining stats etc) are then fast.

The main bottleneck, for the moment, is in obtaining a list of the children of a given note, which is done in the snippet above via a slowish chain of nextSibling references.

It may be that a faster children method has already been written, but for one reason or another has not yet been exposed in the osascript (AppleScript / JavaScript for Automation) API.


(RobTrew) #3

And in fact it has, in the form of a notes method.

I’ve updated the code above, and it’s now much faster.

We can simply refer to the notes of a note, for a single Apple-Event retrieval of its children.

Forgive my slowness in interpreting the dictionary, and many thanks to the API writers !