Rebol [
    Title: "ROAM - REBOL Object Browser"
    Author: ["Carl Sassenrath" "Gregg Irwin"]
    Version: 0.1.2 ; Alpha
    Copyright: "2005 REBOL Technologies"
    Needs: [1.2.122]
    History: [
        0.1.2 {Resizing added} Gregg
    ]
]

help-text: {
Roam is a very simple object browser for REBOL. It has none of the
features of other object browsers, but it is very easy to use. Click on
the displayed fields to explore. Click the back arrow to return to the
prior object.
}

values: []
cnt: 0
max-str: 72
std-effect: reduce ['gradient 1x1 ivory mint + 50]
path-val: to-path [system]
bar-color: 240.240.180
over-count: none
over-color: 200.200.255

clip-str: func [str] [
    ; Keep string to one line.
    trim/lines str 
    if (length? str) > max-str [str: append copy/part str max-str "..."]
    str
]

form-val: func [val] [
    ; Form a limited string from the value provided.
    if any-block? :val [return reform ["length:" length? val]]
    if image? :val [return reform ["size:" val/size]]
    if any-function? :val [
        val: third :val
        if block? val/1 [val: next val]
        return clip-str either string? val/1 [copy val/1][mold val]
    ]
    if object? :val [val: next first val]
    clip-str either port? :val [form val][mold :val]
]

disect-object: func [obj /local words vals out type n] [
    words: first obj
    vals: next second obj
    out: copy []
    n: 0
    foreach word next words [
        type: type?/word pick vals 1
        n: n + 1
        append/only out reduce [
            word
            n
            form word
            form type
            either type <> 'unset! [form-val pick vals 1]['unset]
            color-type type
        ]
        vals: next vals
    ]
    out
]

disect-block: func [blk /local out type n] [
    out: copy []
    n: 0
    foreach item blk [
        type: type?/word :item
        append/only out reduce [
            n: n + 1
            n
            reform ["index:" n]
            form type
            either type <> 'unset! [form-val item]['unset]
            color-type type
        ]
    ]
    out
]

disect-func: func [funct /local out type n] [
    out: copy []
    n: 0
    foreach item first :funct [
        type: type?/word :item
        append/only out reduce [
            n: n + 1
            n
            reform ["index:" n]
            form type
            either type <> 'unset! [form-val item]['unset]
            color-type type
        ]
    ]
    type: type?/word second :funct
    append/only out reduce [
        'body
        n
        "body"
        form type
        form-val second :funct
        color-type type
    ]
    out
]

disect: func [val /local ret] [
    ret: switch type?/word :val [
        block!  [disect-block val]
        object! [disect-object val]
        function! [disect-func :val]
        native! [disect-func :val]
        action! [disect-func :val]
        op! [disect-func :val]
    ]
    either ret [
        values: ret true
    ][
        if series? val [show-info/val path-val val none]
    ]
]

color-type: func [type] [
    type: find [
        none!
            120.120.120
        logic! integer! decimal! money! char! tuple! date! time! pair!
            60.60.60
        string! file! url! issue! image! bitset! email! tag!
            0.160.0
        block! list! hash! paren! struct!
            0.160.0
        object! port!
            0.0.160
        native! action! function! op! routine!
            200.0.0
        datatype!
            80.150.200
        word! set-word! lit-word! get-word! path! set-path! get-path! lit-path!
            200.150.80
    ] type
    either type [first find type tuple!] [160.160.160]
]

next-value: func [word][
    if either integer? word [
        attempt [disect do join path-val word]
    ][
        attempt [disect get in do path-val word]
    ][
        append path-val word
        update-lst
    ]
]

back-value: does [
    if not tail? next path-val [remove back tail path-val]
    disect do path-val
    update-lst
]

update-lst: does [
    tpa/text: form path-val
    cnt: 0
    scr/data: 0
    scr/redrag lst-cnt / max 1 length? values
    show [tpa lst scr]
]

sort-values: func[field] [
    sort/compare values func [a b] [b/:field > a/:field]
    show lst
]

show-help: does [
    inform layout [
        backdrop effect std-effect
        h2 "ROAM Help:"
        txt 300 help-text
        txt blue underline bold "Send Feedback" [browse http://www.rebol.com/feedback.html]
        indent 200 btn-cancel 80 [hide-popup]
    ]
]

show-info: func [path /val data] [
    if not val [data: mold do path]
    view/new layout [
        origin 0x0 space 0
        txt bold form path
        area 640x500 data
        btn-cancel 75 "Close" [unview/only face/parent-face]
    ]
]

out: layout [
    origin 0 space 0 across
    style hdr txt bold white black 20x20
    f-top-pnl: panel 640x26 [
        across
        pad 5x2
        h2 80 as-is "ROAM 0.1"
        pad 0x2
        txt 502 bottom bold gray "[A very simple REBOL object browser]"
        f-help: txt "Help" underline blue [show-help]
    ] effect std-effect
    return
    box 40x20 bar-color effect [draw [fill-pen red triangle 25x10 34x4 34x16]] [back-value]
    tpa: text 560x20 0.0.200 bar-color bold [back-value]
    f-show: btn 40 "Show" [
        either tail? next path-val [alert "Output is too large."][
            show-info path-val
        ]
    ]
    return
    hdr 40  "#" right [sort-values 2]
    hdr 120 "Name" [sort-values 3]
    hdr 60  "Type" [sort-values 4]
    f-val-hdr: hdr 420 "Value or attributes" [sort-values 5]
    return
    lst: list 640x400 - 16x0 [
        across space 0
        style txt base-text
            font [colors: [0.0.0 0.0.0]]
            feel [
                over: func [face ovr] [
                    if all [ovr over-count <> face/data][over-count: face/data show lst]
                ]
                engage: func [face act evt] [
                    if all [act = 'down face/user-data][next-value face/user-data/1]
                ]
            ]
        txt 40 right gray
        txt 120 bold
        txt 60  bold
        txt 1024 font []  
    ] supply [
        count: count + cnt
        face/color: pick [240.240.240 220.230.220] odd? count
        face/text: ""
        if not face/user-data: pick values count [exit]
        if over-count = count [face/color: over-color]
        face/data: count
        face/font/color: either index >= 3 [face/user-data/6][0.0.0]
        face/text: pick face/user-data index + 1
    ]
    do [lst-cnt: to-integer lst/size/y / lst/subface/size/y - 1]
    scr: scroller 16x400 [
        value: to-integer value * max 0 (length? values) - lst-cnt
        if cnt <> value [cnt: value show lst]
    ]
]

on-resize: does [
    f-top-pnl/size/x: out/size/x
    f-help/offset/x: out/size/x - f-help/size/x - 5
    tpa/size/x: out/size/x
    f-show/offset/x: out/size/x - f-show/size/x
    f-val-hdr/size/x: out/size/x - f-val-hdr/offset/x
    lst/size/x: out/size/x - 16
    lst/size/y: out/size/y - lst/offset/y
    scr/offset/x: out/size/x - scr/size/x
    scr/resize/y out/size/y - scr/offset/y
    lst-cnt: to-integer lst/size/y / lst/subface/size/y - 1
    scr/redrag lst-cnt / max 1 length? values   
    show out
]


back-value
insert-event-func [
    if event/type = 'scroll-line [
        n: max 0 (length? values) - lst-cnt
        cnt: max 0 min n cnt + event/offset/y
        scr/data: cnt / max 1 n
        show [scr lst]
    ]
    if event/type = 'resize [on-resize]
    event
]
view/options center-face out 'resize

;   system object
;   native functions
;   mezzanine functions
;   protocols
;   components
;   VID styles