Visualize a tree: Difference between revisions
Content added Content deleted
m (→JS Vertically centered tree: Added a comment) |
(→{{header|AppleScript}}: Added an AppleScript version, (Trans PY and JS)) |
||
Line 269: | Line 269: | ||
</table> |
</table> |
||
=={{header| |
=={{header|AppleScript}}== |
||
Prints a tree of the current directory. |
|||
Using UTF8 box-drawing characters in a monospaced font, with options for (1.) compacted vs vertically centered display, and (2.) retaining or pruning out nodeless lines of text. |
|||
<lang dos>@tree %cd%</lang> |
|||
{{Trans|Python}} |
|||
{{Trans|JavaScript}} |
|||
<lang AppleScript>-- Vertically centered textual tree using UTF8 monospaced |
|||
-- box-drawing characters, with options for compacting |
|||
-- and pruning. |
|||
-- ┌── Gamma |
|||
-- ┌─ Beta ┼── Delta |
|||
-- │ └ Epsilon |
|||
-- Alpha ┼─ Zeta ───── Eta |
|||
-- │ ┌─── Iota |
|||
-- └ Theta ┼── Kappa |
|||
-- └─ Lambda |
|||
on run |
|||
set tree to Node(1, ¬ |
|||
{Node(2, ¬ |
|||
{Node(4, {Node(7, {})}), ¬ |
|||
Node(5, {})}), ¬ |
|||
Node(3, ¬ |
|||
{Node(6, ¬ |
|||
{Node(8, {}), Node(9, {})})})}) |
|||
set tree2 to Node("Alpha", ¬ |
|||
{Node("Beta", ¬ |
|||
{Node("Gamma", {}), ¬ |
|||
Node("Delta", {}), ¬ |
|||
Node("Epsilon", {})}), ¬ |
|||
Node("Zeta", {Node("Eta", {})}), ¬ |
|||
Node("Theta", ¬ |
|||
{Node("Iota", {}), Node("Kappa", {}), Node("Lambda", {})})}) |
|||
set strTrees to unlines({"(NB – view in mono-spaced font)\n\n", ¬ |
|||
"Compacted (not all parents vertically centered):\n", ¬ |
|||
drawTree2(true, false, tree), ¬ |
|||
"\nFully expanded and vertically centered:\n", ¬ |
|||
drawTree2(false, false, tree2), ¬ |
|||
"\nVertically centered, with nodeless lines pruned out:\n", ¬ |
|||
drawTree2(false, true, tree2)}) |
|||
set the clipboard to strTrees |
|||
log strTrees |
|||
end run |
|||
-- drawTree2 :: Bool -> Bool -> Tree String -> String |
|||
on drawTree2(blnCompressed, blnPruned, tree) |
|||
-- Tree design and algorithm inspired by the Haskell snippet at: |
|||
-- https://doisinkidney.com/snippets/drawing-trees.html |
|||
script measured |
|||
on |λ|(t) |
|||
script go |
|||
on |λ|(x) |
|||
set s to " " & x & " " |
|||
Tuple(length of s, s) |
|||
end |λ| |
|||
end script |
|||
fmapTree(go, t) |
|||
end |λ| |
|||
end script |
|||
set measuredTree to |λ|(tree) of measured |
|||
script levelMax |
|||
on |λ|(a, level) |
|||
a & maximum(map(my fst, level)) |
|||
end |λ| |
|||
end script |
|||
set levelWidths to foldl(levelMax, {}, init(levels(measuredTree))) |
|||
-- Lefts, Mid, Rights |
|||
script lmrFromStrings |
|||
on |λ|(xs) |
|||
set {ls, rs} to items 2 thru -2 of (splitAt((length of xs) div 2, xs) as list) |
|||
Tuple3(ls, item 1 of rs, rest of rs) |
|||
end |λ| |
|||
end script |
|||
script stringsFromLMR |
|||
on |λ|(lmr) |
|||
script add |
|||
on |λ|(a, x) |
|||
a & x |
|||
end |λ| |
|||
end script |
|||
foldl(add, {}, items 2 thru -2 of (lmr as list)) |
|||
end |λ| |
|||
end script |
|||
script fghOverLMR |
|||
on |λ|(f, g, h) |
|||
script |
|||
property mg : mReturn(g) |
|||
on |λ|(lmr) |
|||
set {ls, m, rs} to items 2 thru -2 of (lmr as list) |
|||
Tuple3(map(f, ls), |λ|(m) of mg, map(h, rs)) |
|||
end |λ| |
|||
end script |
|||
end |λ| |
|||
end script |
|||
script lmrBuild |
|||
on leftPad(n) |
|||
script |
|||
on |λ|(s) |
|||
replicateString(n, space) & s |
|||
end |λ| |
|||
end script |
|||
end leftPad |
|||
on conS(x) |
|||
script |
|||
on |λ|(xs) |
|||
x & xs |
|||
end |λ| |
|||
end script |
|||
end conS |
|||
-- lmrBuild main |
|||
on |λ|(w, f) |
|||
script |
|||
property mf : mReturn(f) |
|||
on |λ|(wsTree) |
|||
set xs to nest of wsTree |
|||
set lng to length of xs |
|||
set {nChars, x} to items 2 thru -2 of ((root of wsTree) as list) |
|||
set _x to replicateString(w - nChars, "─") & x |
|||
if 0 = lng then |
|||
Tuple3({}, _x, {}) |
|||
else if 1 = lng then |
|||
set indented to leftPad(1 + w) |
|||
script lineLinked |
|||
on |λ|(z) |
|||
_x & "─" & z |
|||
end |λ| |
|||
end script |
|||
|λ|(|λ|(item 1 of xs) of mf) of ¬ |
|||
(|λ|(indented, lineLinked, indented) of fghOverLMR) |
|||
else |
|||
script treeFix |
|||
on |λ|(l, m, r) |
|||
compose(stringsFromLMR, ¬ |
|||
|λ|(conS(l), conS(m), conS(r)) of fghOverLMR) |
|||
end |λ| |
|||
end script |
|||
script linked |
|||
on |λ|(s) |
|||
set c to text 1 of s |
|||
set t to tail(s) |
|||
if "┌" = c then |
|||
_x & "┬" & t |
|||
else if "│" = c then |
|||
_x & "┤" & t |
|||
else if "├" = c then |
|||
_x & "┼" & t |
|||
else |
|||
_x & "┴" & t |
|||
end if |
|||
end |λ| |
|||
end script |
|||
set indented to leftPad(w) |
|||
set lmrs to map(f, xs) |
|||
if blnCompressed then |
|||
set sep to {} |
|||
else |
|||
set sep to {"│"} |
|||
end if |
|||
tell lmrFromStrings |
|||
set tupleLMR to |λ|(intercalate(sep, ¬ |
|||
{|λ|(item 1 of lmrs) of (|λ|(" ", "┌", "│") of treeFix)} & ¬ |
|||
map(|λ|("│", "├", "│") of treeFix, init(tail(lmrs))) & ¬ |
|||
{|λ|(item -1 of lmrs) of (|λ|("│", "└", " ") of treeFix)})) |
|||
end tell |
|||
|λ|(tupleLMR) of (|λ|(indented, linked, indented) of fghOverLMR) |
|||
end if |
|||
end |λ| |
|||
end script |
|||
end |λ| |
|||
end script |
|||
set treeLines to |λ|(|λ|(measuredTree) of foldr(lmrBuild, 0, levelWidths)) of stringsFromLMR |
|||
if blnPruned then |
|||
script notEmpty |
|||
on |λ|(s) |
|||
script isData |
|||
on |λ|(c) |
|||
"│ " does not contain c |
|||
end |λ| |
|||
end script |
|||
any(isData, characters of s) |
|||
end |λ| |
|||
end script |
|||
set xs to filter(notEmpty, treeLines) |
|||
else |
|||
set xs to treeLines |
|||
end if |
|||
unlines(xs) |
|||
end drawTree2 |
|||
-- GENERIC ----------------------------------------------------------- |
|||
-- Node :: a -> [Tree a] -> Tree a |
|||
on Node(v, xs) |
|||
{type:"Node", root:v, nest:xs} |
|||
end Node |
|||
-- Tuple (,) :: a -> b -> (a, b) |
|||
on Tuple(a, b) |
|||
-- Constructor for a pair of values, possibly of two different types. |
|||
{type:"Tuple", |1|:a, |2|:b, length:2} |
|||
end Tuple |
|||
-- Tuple3 (,,) :: a -> b -> c -> (a, b, c) |
|||
on Tuple3(x, y, z) |
|||
{type:"Tuple3", |1|:x, |2|:y, |3|:z, length:3} |
|||
end Tuple3 |
|||
-- Applied to a predicate and a list, |
|||
-- |any| returns true if at least one element of the |
|||
-- list satisfies the predicate. |
|||
-- any :: (a -> Bool) -> [a] -> Bool |
|||
on any(f, xs) |
|||
tell mReturn(f) |
|||
set lng to length of xs |
|||
repeat with i from 1 to lng |
|||
if |λ|(item i of xs) then return true |
|||
end repeat |
|||
false |
|||
end tell |
|||
end any |
|||
-- compose (<<<) :: (b -> c) -> (a -> b) -> a -> c |
|||
on compose(f, g) |
|||
script |
|||
property mf : mReturn(f) |
|||
property mg : mReturn(g) |
|||
on |λ|(x) |
|||
|λ|(|λ|(x) of mg) of mf |
|||
end |λ| |
|||
end script |
|||
end compose |
|||
-- 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 |
|||
-- 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 |
|||
-- fmapTree :: (a -> b) -> Tree a -> Tree b |
|||
on fmapTree(f, tree) |
|||
script go |
|||
property g : |λ| of mReturn(f) |
|||
on |λ|(x) |
|||
set xs to nest of x |
|||
if xs ≠ {} then |
|||
set ys to map(go, xs) |
|||
else |
|||
set ys to xs |
|||
end if |
|||
Node(g(root of x), ys) |
|||
end |λ| |
|||
end script |
|||
|λ|(tree) of go |
|||
end fmapTree |
|||
-- 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 |
|||
-- foldr :: (a -> b -> b) -> b -> [a] -> b |
|||
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 |λ|(item i of xs, v, i, xs) |
|||
end repeat |
|||
return v |
|||
end tell |
|||
end foldr |
|||
-- fst :: (a, b) -> a |
|||
on fst(tpl) |
|||
if class of tpl is record then |
|||
|1| of tpl |
|||
else |
|||
item 1 of tpl |
|||
end if |
|||
end fst |
|||
-- identity :: a -> a |
|||
on identity(x) |
|||
-- The argument unchanged. |
|||
x |
|||
end identity |
|||
-- init :: [a] -> [a] |
|||
-- init :: [String] -> [String] |
|||
on init(xs) |
|||
set blnString to class of xs = string |
|||
set lng to length of xs |
|||
if lng > 1 then |
|||
if blnString then |
|||
text 1 thru -2 of xs |
|||
else |
|||
items 1 thru -2 of xs |
|||
end if |
|||
else if lng > 0 then |
|||
if blnString then |
|||
"" |
|||
else |
|||
{} |
|||
end if |
|||
else |
|||
missing value |
|||
end if |
|||
end init |
|||
-- 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 |
|||
-- iterateUntil :: (a -> Bool) -> (a -> a) -> a -> [a] |
|||
on iterateUntil(p, f, x) |
|||
script |
|||
property mp : mReturn(p)'s |λ| |
|||
property mf : mReturn(f)'s |λ| |
|||
property lst : {x} |
|||
on |λ|(v) |
|||
repeat until mp(v) |
|||
set v to mf(v) |
|||
set end of lst to v |
|||
end repeat |
|||
return lst |
|||
end |λ| |
|||
end script |
|||
|λ|(x) of result |
|||
end iterateUntil |
|||
-- levels :: Tree a -> [[a]] |
|||
on levels(tree) |
|||
script nextLayer |
|||
on |λ|(xs) |
|||
script |
|||
on |λ|(x) |
|||
nest of x |
|||
end |λ| |
|||
end script |
|||
concatMap(result, xs) |
|||
end |λ| |
|||
end script |
|||
script roots |
|||
on |λ|(xs) |
|||
script |
|||
on |λ|(x) |
|||
root of x |
|||
end |λ| |
|||
end script |
|||
map(result, xs) |
|||
end |λ| |
|||
end script |
|||
map(roots, iterateUntil(my isNull, nextLayer, {tree})) |
|||
end levels |
|||
-- map :: (a -> b) -> [a] -> [b] |
|||
on map(f, xs) |
|||
-- The list obtained by applying f |
|||
-- to each element of 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 |
|||
-- 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 |
|||
-- mReturn :: First-class m => (a -> b) -> m (a -> b) |
|||
on mReturn(f) |
|||
-- 2nd class handler function lifted into 1st class script wrapper. |
|||
if script is class of f then |
|||
f |
|||
else |
|||
script |
|||
property |λ| : f |
|||
end script |
|||
end if |
|||
end mReturn |
|||
-- replicateString :: Int -> String -> String |
|||
on replicateString(n, s) |
|||
set out to "" |
|||
if n < 1 then return out |
|||
set dbl to s |
|||
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 replicateString |
|||
-- snd :: (a, b) -> b |
|||
on snd(tpl) |
|||
if class of tpl is record then |
|||
|2| of tpl |
|||
else |
|||
item 2 of tpl |
|||
end if |
|||
end snd |
|||
-- splitAt :: Int -> [a] -> ([a], [a]) |
|||
on splitAt(n, xs) |
|||
if n > 0 and n < length of xs then |
|||
if class of xs is text then |
|||
Tuple(items 1 thru n of xs as text, items (n + 1) thru -1 of xs as text) |
|||
else |
|||
Tuple(items 1 thru n of xs, items (n + 1) thru -1 of xs) |
|||
end if |
|||
else |
|||
if n < 1 then |
|||
Tuple({}, xs) |
|||
else |
|||
Tuple(xs, {}) |
|||
end if |
|||
end if |
|||
end splitAt |
|||
-- tail :: [a] -> [a] |
|||
on tail(xs) |
|||
set blnText to text is class of xs |
|||
if blnText then |
|||
set unit to "" |
|||
else |
|||
set unit to {} |
|||
end if |
|||
set lng to length of xs |
|||
if 1 > lng then |
|||
missing value |
|||
else if 2 > lng then |
|||
unit |
|||
else |
|||
if blnText then |
|||
text 2 thru -1 of xs |
|||
else |
|||
rest of xs |
|||
end if |
|||
end if |
|||
end tail |
|||
-- unlines :: [String] -> String |
|||
on unlines(xs) |
|||
-- A single string formed by the intercalation |
|||
-- of a list of strings with the newline character. |
|||
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</lang> |
|||
{{Out}} |
|||
<pre>(NB – view in mono-spaced font) |
|||
Compacted (not all parents vertically centered): |
|||
┌ 4 ─ 7 |
|||
┌ 2 ┴ 5 |
|||
1 ┤ ┌ 8 |
|||
└ 3 ─ 6 ┴ 9 |
|||
Fully expanded and vertically centered: |
|||
┌── Gamma |
|||
│ |
|||
┌─ Beta ┼── Delta |
|||
│ │ |
|||
│ └ Epsilon |
|||
│ |
|||
Alpha ┼─ Zeta ───── Eta |
|||
│ |
|||
│ ┌─── Iota |
|||
│ │ |
|||
└ Theta ┼── Kappa |
|||
│ |
|||
└─ Lambda |
|||
Vertically centered, with nodeless lines pruned out: |
|||
┌── Gamma |
|||
┌─ Beta ┼── Delta |
|||
│ └ Epsilon |
|||
Alpha ┼─ Zeta ───── Eta |
|||
│ ┌─── Iota |
|||
└ Theta ┼── Kappa |
|||
└─ Lambda <pre> |
|||
=={{header|BBC BASIC}}== |
=={{header|BBC BASIC}}== |