rebol [
  title: "VID inspect"
  author: "vpavlu"
  date: 19-dec-2002/12:14
  home: http://plain.at/vpavlu
]

vid-inspect: make object! [
  
  styles: func [ "displays a list of all styles" /local list s base son dad act len max-len print-line ][
    max-len: 0
    list: copy []
    s: system/view/vid/vid-styles
    forskip s 2 [
      if max-len < len: length? form s/1 [ max-len: len ]
      repend list [s/1 to-block s/2/style]
    ]

    print-line: func [ base /local s][
      s: form base/1 remove base
      s: tail s
      insert/dup s " " 2 + max-len - length? head s
      s: head s
      forall base [ repend s [" < " base/1] ]
      ;append s " < object!"
      print s
    ]
  
    print "VID-STYLES:"  
    base: copy []
    foreach [son dad] list [
      clear base
      act: find list son
      while [ not none? act ][
        append base act/1
        act: find list act/2/1
      ]
      print-line base
    ]
  ]


  style-tree: func [ "prints a hierarchical view of VID-styles" /local recurs-print-node list s pos ][
    ;build block with "style [child1 ... childn]" elements of all styles
    list: copy []
    s: system/view/vid/vid-styles
    forskip s 2 [
      either none? pos: find list s/2/style [
        repend list [ s/2/style reduce [s/1] ]
      ][
        append first next pos s/1
      ]
    ]
    ;function to recursively print a style and its children
    recurs-print-node: func [ prefix this follower /local desc i child ][
      print rejoin [ prefix " +-" this ]
      if not none? desc: select list this [
        append prefix pick ["   " " | "] zero? follower
        i: length? desc
        foreach child desc [ recurs-print-node copy prefix child i: i - 1]
        remove/part skip tail prefix -3 3
      ]
    ]
    ;go printing!
    print "VID-STYLES:"
    recurs-print-node "" 'face 0
    unset 's ;so that nothing is returned
  ]
]

style-tab: get in vid-inspect 'styles
style-tree: get in vid-inspect 'style-tree

style-tree
halt