REBOL [
    Title:    "Scroll Example"
    Date:     4-Aug-2004
    Name:     'Scrolling
    Version:  0.0.5
    File:     %scrolling.r
    Author:   "Carl Read"
    Email:    carl@cybercraft.co.nz
    Home:     http://homepages.paradise.net.nz/left/rebol/scripts/scrolling.r
    Rights:   "Public domain.  Use as you wish."
    Purpose: {
        An example of using insert-event-func to allow scrolling of text areas,
        text-lists and the like using a wheel-mouse.  Also shows how to capture
        a window's close gadget being hit.  Could be extended to control
        window-resizing and other stuff needed to be done at the window-level.
    }
    Note: {
        1) Has been tested on Windows View 1.2.1, 1.2.5 and 1.2.46 and on Linux
        View 1.2.1 and 1.2.15.  (Hopefully it'll become redundant with View 1.3.)
        2) This could be included in your user.r script to add scroll-wheel
        support to any script you run, but it may not always work properly and
        may break some scripts, SO DO THIS AT YOUR OWN RISK.  Also, remove the
        script-specific window-close support if you do include it.  (See below.)
    }
    History: [
        0.0.0 [29-Jul-2004 {First version.}]
        0.0.1 [30-Jul-2004 {
            Bug fixed.  Was scrolling lists that were short enough to show
            all in the list.
        }]
        0.0.2 [31-Jul-2004 {Added support for panels.}]
        0.0.3 [1-Aug-2004 {
            1) Bug fixed.  Mouse-offset was being set wrong by time events.
            (Thanks to Phil Bevan for help in finding this.)
            2) Touched up recurse-panels.  It should now always return the event
            unless a scroll is responded to, in which case it returns a none.
            It should also exit quicker after responding to an event.
            3) Added support for text areas and the like.  They scroll now, but
            there's a very obvious bug in that the text can scroll off the top
            of the box it's in.  This is because I could find no way to detect
            how many lines of text there are and how many lines can be
            shown...
        }]
        0.0.4 [3-Aug-2004 {
            1) Moved mouse-offset into the function so it's not a global word.
            Now referenced with mouse-offset/1 since it's in a block so its
            value's retained between function calls.
            2) Major touch up of the comments.
        }]
        0.0.5 [4-Aug-2004 {
            Scrolling in area bug fixed.  (Thanks to Gregg Irwin for pointing
            me in the right direction.  size-text returns the size taken by
            all the text in a face, not just the displayed text, so it can
            give me the info I need.
        }]
    ]
]

;-- Remove our scrolling function from event-funcs if it's found to already
;-- be there.  A previous version may be there if you've run your program
;-- from the REBOL Console already or have included the function in your
;-- user.r script.  Having more than one instance of the function in event-
;-- funcs will a single scroll to be duplicated, so this should be included
;-- in your scripts.
event-funcs: system/view/screen-face/feel/event-funcs
forall event-funcs [
    if 'global-events = first second first event-funcs [remove event-funcs]
]

;-- Insert the scrolling function.
insert-event-func func [face event /local recurse-panels mouse-offset][
    'global-events  ;-- A word to identify the function if it needs to be removed.
    mouse-offset: [0x0]
    recurse-panels: func [
        {A recursive look through panels to see what should be scrolled.}
        panel event offset /local lines
    ][
        foreach pane panel [
            either pane/style = 'panel [
                if not recurse-panels pane/pane event offset + pane/offset [return none]
            ][
                if all [
                    ;-- Any words in the find block below refer to the text-list styles to
                    ;-- be scrolled with a scroll-wheel.  If you create new text-list styles
                    ;-- and you wish to scroll them, add their names to this block.
                    find [text-list] pane/style
                    within? mouse-offset/1 offset + pane/offset pane/size
                    pane/lc < length? head pane/lines
                ][
                    ;-- scroll text-list.
                    lines: 1 - pane/lc + length? head pane/lines
                    pane/sn: min lines max 0 to-integer event/offset/y / 3 + pane/sn
                    pane/sld/data: pane/sn / lines
                    pane/sld/redrag pane/lc / max 1 length? head pane/lines
                    show pane
                    return none
                ]
                if all [
                    ;-- Any words in the find block below refer to the text styles to
                    ;-- be scrolled with a scroll-wheel.  If you create new text styles
                    ;-- and you wish to scroll them, add their names to this block.
                    find [area info] pane/style
                    within? mouse-offset/1 offset + pane/offset pane/size
                ][
                    ;-- Scroll area or info style.
                    lines: min 0 pane/size/y - pane/font/size - second size-text pane
                    pane/para/scroll/y: max lines min 0 pane/para/scroll/y - to-integer
                         pane/font/size + pane/font/offset/y + pane/font/space/y * event/offset/y / 3
                    show pane
                    return none
                ]
            ]
        ]
        event
    ]
    either event/type = 'scroll-line [
        ;-- Respond to mouse scroll-wheel event.
        if not recurse-panels event/face/pane event face/offset [return none]
    ][
        if event/type = 'move [mouse-offset/1: event/offset]
    ]

    ;-- Example of intercepting the window close gadget.  This opens the quit
    ;-- layout if the close gadget is clicked on in the main layout.  The
    ;-- other windows can still be closed normally.
    ;-- THIS IS SPECIFIC TO THE EXAMPLE SCRIPT. REMOVE OR MODIFY FOR YOUR OWN
    ;-- SCRIPTS OR IF PLACING IT IN YOUR USER.R SCRIPT.
    if all [event/type = 'close same? event/face :main-lo][
        view/new/title quit-lo "Quit?"
        return none
    ]
    ;-- End of close example.

    event ;-- Always return the event.
]


;-- Test layouts.

quit-lo: layout [
    across
    button "Quit!" [unview/all]
    button "Cancel" [unview/only :quit-lo]
]

text-data: {a^/b^/c^/d^/e^/f^/g^/h^/i^/j^/k^/l^/m
    n^/o^/p^/q^/r^/s^/t^/u^/v^/w^/x^/y^/z}

win2-data: [a b c d e f g h i j k l m n o p q r s t]
win2-lo: layout [
    across
    text-list data win2-data
    area copy text-data
    info 100x100 copy text-data
]

main-styles: stylize [
    text-list: text-list 200x100
    area: area 200x100
    info: info 100x100
]
main-data1: [1 2 3 4 5 6 7 8 10 11 12 13 14 15]
main-data2: [aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz]
main-lo: layout [
    styles main-styles
    across
    text-list data main-data1
    text-list data main-data2
    text-list data ["small" "list" "test"]
    return
    area copy text-data
    info copy text-data
    area copy "Small^/file^/test."
    return
    panel [
        backdrop blue
        label "Two text-lists, an area and an info in a panel..."
        across
        text-list data main-data1
        text-list data main-data2
        return
        area copy text-data font [size: 17 offset: 0x3]
        info copy text-data font [size: 14 offset: 0x4]
    ] 450x280
    return
    button "Window 2" [view/new/title win2-lo "Window 2"]
    button "Quit" [view/new/title quit-lo "Quit?"]
]

view/title main-lo "Main"