REBOL [
    Title:  "Add Sliders when necessary"
    Author: "Jeff Kreis"
    Email:  jeff@rebol.com
    Version: 0.0.1
    Purpose: {
        Adds Horizontal and Vertical scroll bars when necessary
        to a face, depending on the amount that is visible. 
        Constrains face to a specific size.
    }
    Comments: "Meta-programming VID. Styles. Layout called only once."
]
slar: stylize [
    sl: slider [face/user-data/1/offset: fract-pair face show face/user-data/1]
    arr: arrow [push-scroll face] it: box with [set [font para edge] none]
]
scroll-face: func [
    {Returns version of input face with vert or horiz scroll if needed.}
    at      [object!]  {Face to attach scroll bars to}
    viz     [pair!]    {Visible size of final face}
    /arrows            {Include arrows}
    /size              {Size of scroll bar/arrows}
    siz     [integer!] {New width for scroll bar/arrows}
    /local l slr slu ra la ua da as sx sy vx vy x
    xper yper xoff yoff hsiz vsiz sz2 b1 aru arl
][
    fract-pair: func [face /local o f2 f3 fd c][
        set [o f2 f3] face/user-data o: o/offset fd: to-integer f2 * face/data
        pick reduce [c: repair [pick reduce [o/x o/y] f3 fd] reverse c] f3
    ]
    push-scroll: func [face /local s1 s2 f][
        set [s1 s2] face/user-data f: s1/user-data/1                
        s1/data: min 1.0 max 0.0 s1/data + switch face/data [
            up [- s2] down [s2] right [s2] left [- s2]
        ] f/offset: fract-pair s1 show [s1 f]
    ]
    repair: func [x][to-pair reduce x]

    sz2: any [all [arrows any [siz 16]] 0] siz: any [siz 16] 
    set [vx vy sx sy] reduce [viz/x viz/y at/size/x at/size/y] 
    set [xper yper xoff yoff] reduce [vx / sx vy / sy vx - sx vy - sy]
    if (not sx: xoff < 0) and (not sy: yoff < 0) [return at]
    ua: any [all [sy vsiz: repair [siz (-2 * sz2)+ vy: either sx [vy - siz][vy]]
            vx: vx - siz copy [return slu: sl vsiz]][]] 
    ra: any [all [sx hsiz: repair [vx - (2 * sz2) siz]
            vy: either sy [vy][vy - siz] copy [across slr: sl hsiz]][]]
    viz: repair [vx vy]
    if arrows [ 
        x: reduce ['arr 1x1 * siz]
        foreach [s d] reduce [
            ua [ua: (x) up da: (x) down] ra [ra: (x) left la: (x) right] 
        ][if not empty? s [insert tail s compose d]]
    ]
    l: layout/origin compose [styles slar space 0 b1: it (viz)(ua)(ra)] 0x0
    b1/pane: at l/offset: at/offset: 0x0 aru: [slu yper] arl: [slr xper] 
    foreach [item go] reduce [
        slu [at yoff 1] slr [at xoff 2] ua aru da aru la arl ra arl
    ][if object? item [set in item 'user-data reduce go]] 
    all [slr slr/redrag xper] all [slu slu/redrag yper] 
    return l
]

{

;-- Some silly examples:
f: layout [ origin 0x0 space 0 size 200x200 box 
    red box blue return box yellow box green]
foreach s [100x200 200x100 100x100][
    view/offset scroll-face f s 140x130 
]

;-- A growing face: 
g: next first system/words
f: layout [
    backdrop 240.210.140
    h1 "Growing text:"
    t: box 200x200
    button "Add 20 words" [
        loop 20 [
            append tt/text reform [g/1 " "]
            if tail? g: next g [g: next head g]
        ] tt/size: 184x0 + (0x1 * size-text tt)
        t/pane: scroll-face/arrows tt 200x200
        show [t tt]
    ]
]
t/pane: tt: make face [
    edge: none size: 200x200 text: "System/words: ^/" 
    font: make font [align: [justify]]
    color: 240.210.140
]
view f

}