Experiments with Rebol/View 2.7.8

events.r

#!/usr/local/bin/rebview -iqvs

Rebol [
    Title: "Events Test"
    Date: 12-Dec-2018
    Author: "Christopher Ross-Gill"
    File: %events.r
    Version: 0.1.0
    Comments: {
        - Linkify Face (http://www.ross-gill.com/page/Beyond_Regular_Expressions)
        - Eat Event and CTX-TEXT by Romano and Gabriele
        - Event to Object (for reflection)
        - Customised Button Feel
        - Resize Text function (force reflows text, measures size and adjusts height)
        - Resize View function (recursively resizes every face based on its parent face)
        - Event func that enforces RESIZE event, close window event.
        - Move function that moves a face a given distance.
        - Shadows function that adds shadows to a panel based on its content
        - Window feel for resizing, closing, quitting
    }
]

linkify-face: use [links hypertext make-link][
    hypertext: use [uri letter digit word space punct chars paren mark extent][
        letter: charset [#"a" - #"z"]
        digit: charset [#"0" - #"9"]
        word: charset [#"_" #"0" - #"9" #"A" - #"Z" #"a" - #"z"] ; per regex
        space: charset "^/^- ()<>^"'" ; for curly quotes, need unicode (R3)
        punct: charset "!'#$%&`*+,-./:;=?@[/]^^{|}~" ; regex 'punct without ()<>
        chars: complement union space punct
        paren: ["(" some [chars | punct | "(" some [chars | punct] ")"]")"]
        
        uri: [
            [
                  letter some [word | "-"] ":" [1 3 "/" | letter | digit | "%"]
                | "www" 0 3 digit "."
                | some [letter | digit] "." 2 4 letter
            ]
            some [opt [some punct] some [chars | paren] opt "/"]
        ]

        [
            any [
                mark: uri extent: (keep reduce [mark extent])
                | some [chars | punct] some space ; non-uri words, line not required
                | skip
            ]
        ]
    ]

    make-link: use [style link][
        style: stylize [
            link: txt 0.0.204 400x20 as-is para [origin: margin: 0x0] [
                attempt [browse to-url value]
            ][
                write clipboard:// to-url value
            ]
        ]

        func [
            parent [object!]
            start [string!]
            end [string!]
            link-colors [block!]
        ][
            link: make-face style/link
            link/text: link/data: copy/part start end
            link/color: none
            link/offset: caret-to-offset parent start
            link/size: size-text link
            link/font: make parent/font [
                offset: 0x0
                color: first colors: link-colors
            ]
            link/saved-area: yes
            link
        ]
    ]

    func [
        "Adds links to a face"
        face [object!] "Face to add links to"
        /colors "Optional link colors" normal [tuple!] hover [tuple!]
    ][
        if string? face/text [
            colors: reduce [
                any [normal normal: 0.0.204]
                any [hover normal]
            ]

            links: collect [
                parse/all face/text bind/copy hypertext 'keep
            ]

            face/pane: collect [
                foreach [start end] links [
                    keep make-link face start end colors
                ]
            ]
        ]
    ]
]

context [
    ; http://scripts.rebol.info/scripts/eat

    no-queue: context [move: offset: none]

    wake-event: func [event /local no-btn] bind [
        either not pop-face [
            do event
            empty? screen-face/pane
        ] [
            either any [
                pop-face = event/face
                within? event/offset win-offset? pop-face pop-face/size
            ][ 
                no-btn: false
                if block? get in pop-face 'pane [
                    no-btn: foreach item pop-face/pane [
                        if get in item 'action [
                            break/return false
                        ]
                        true
                    ]
                ]
                if any [
                    all [event/type = 'up no-btn]
                    event/type = 'close
                ][
                    hide-popup
                ]
                do event
            ][
                if pop-face/action [
                    if not find [move time] event/type [
                        hide-popup
                    ]
                    do event
                ]
            ]
            none? find pop-list pop-face
        ]
    ] system/view

    wake-event: func [event /local no-btn] bind [
        do event
        return empty? screen-face/pane
    ] system/view

    system/ports/wait-list/1/awake: func [port /local event events lasttype][
        events: copy []
        while [event: pick port 1] [
            either all [
                in no-queue event/type
                lasttype = event/type
            ][
                change back tail events event
            ][
                lasttype: event/type
                insert tail events event
            ]
        ]
        foreach event events [
            if wake-event event [return true]
        ]
        false
    ]
]

context bind bind [
    ;-- Patch For Text Handling -- Gabriele and Romano
    hilight-all: func [face /only][
        either empty? face/text [unlight-text][
            highlight-start: head face/text
            highlight-end: tail face/text
        ]
        if all [not only in face 'esc][face/esc: copy face/text]
    ]

    move: func [event ctrl plain][
        either event/shift [any [highlight-start highlight-start: caret]][unlight-text]
        caret: either event/control ctrl plain
        if event/shift [either caret = highlight-start [unlight-text][highlight-end: caret]]
    ]

    move-y: func [face delta /local pos tmp tmp2][
        tmp: offset-to-caret face delta + pos: caret-to-offset face caret
        tmp2: caret-to-offset face tmp
        either tmp2/y <> pos/y [tmp][caret]
    ]

    edit-text: func [
        face event action
        /local key liney swap-text tmp tmp2 page-up page-down face-size
    ][
        face-size: face/size - either face/edge [2 * face/edge/size][0]
        key: event/key
        if flag-face? face hide swap-text: [
            tmp: face/text face/text: face/data face/data: tmp
            caret: either error? try [index? caret][tail face/text][at face/text index? caret]
        ]
        textinfo face line-info 0
        liney: line-info/size/y
        if char? key [
            either find keys-to-insert key [insert-char face key][key: select keymap key]
        ]
        if word? key [
            page-up: [move-y face face-size - liney - liney * 0x-1]
            page-down: [move-y face face-size - liney * 0x1]
            do select [
                left [move event [back-word caret][back caret]]
                right [move event [next-word caret][next caret]]
                up [move event page-up [move-y face liney * 0x-1]]
                down [move event page-down [move-y face liney * 0x1]]
                page-up [move event [head caret] page-up]
                page-down [move event [tail caret] page-down]
                home [move event [head caret][beg-of-line caret]]
                end [move event [tail caret][end-of-line caret]]
                back-char [
                    any [
                        delete-selected-text
                        head? caret
                        either event/control [
                            tmp: caret
                            remove/part caret: back-word tmp tmp
                        ][remove caret: back caret]
                    ]
                    face/dirty?: true
                ]
                del-char [
                    any [
                        delete-selected-text
                        tail? caret
                        either event/control [remove/part caret next-word caret][remove caret]
                    ]
                    face/dirty?: true
                ]
                enter [
                    if flag-face? face return [
                        if flag-face? face hide swap-text
                        action face face/data
                        if flag-face? face tabbed [focus next-field face]
                        exit
                    ]
                    insert-char face newline
                ]
                all-text [hilight-all/only face]
                copy-text [copy-text face unlight-text]
                cut-text [
                    copy-selected-text face
                    delete-selected-text
                    face/dirty?: true
                ]
                paste-text [
                    delete-selected-text
                    face/line-list: none
                    face/dirty?: true
                    caret: insert caret read clipboard://
                ]
                clear-tail [
                    remove/part caret end-of-line caret
                    face/dirty?: true
                ]
                tab-char [
                    if flag-face? face tabbed [
                        either in face 'refocus [
                            face/refocus event/shift
                        ][
                            tmp2: either event/shift [back-field face][next-field face]
                            if flag-face? face hide swap-text
                            action face face/data
                            focus tmp2
                        ]
                        exit
                    ]
                    insert-char face tab
                ]
                ;new
            ] key
        ]
        if face: focal-face [
            if flag-face? face hide [
                view*/highlight-start: view*/highlight-end: none
                insert/dup clear face/data "*" length? face/text
                do swap-text
            ]
            tmp: caret-to-offset face caret
            tmp2: face/para/scroll
            if all [tmp/x < 0 tmp2/x < 0] [face/para/scroll/x: tmp2/x - tmp/x]
            if all [tmp/y < 0 tmp2/y < 0] [face/para/scroll/y: tmp2/y - tmp/y]
            action: face-size - tmp
            if action/x < 5 [face/para/scroll/x: tmp2/x + action/x - 5]
            if action/y < liney [face/para/scroll/y: tmp2/y + action/y - liney]
            face/para/scroll/y: min 0 face/para/scroll/y
            show face
        ]
    ]

    ; export [hilight-all edit-text]
] system/view ctx-text

event-to-object: func [event [event!]][
    ; ? event/face
    make object! [
       face: event/face/type
       type: event/type
       offset: event/offset
       key: event/key
       time: event/time
       control: event/control
       shift: event/shift
       double-click: event/double-click
   ]
]

button-feel: make face/feel [
    redraw: func [face action position][
        switch/default face/state [
            pressed pressed/away [
                if face/images [
                    face/image: face/images/2
                    face/effect: [extend]
                ]
                if face/colors [
                    face/color: face/colors/1
                ]
            ]
            hover [
                 if face/images [
                    face/image: face/images/1
                    face/effect: compose [mix (face/images/3) extend]
                ]
                if face/colors [
                    face/color: face/colors/1 + 20.20.20
                ]
            ]
        ][
            if face/images [
                face/image: face/images/1
                face/effect: [extend]
            ]
            if face/colors [
                face/color: face/colors/1
            ]
        ]
        face/size: face/para/origin + face/para/margin + size-text face
    ]
    over: func [face into position][
        switch/default face/state [
            default [if into [face/state: 'hover]]
            hover [if not into [face/state: 'default]]
        ][
            probe face/state
        ]
        show face
    ]
    engage: func [face action event][
        ; probe reduce [face/state action event/type event/offset]
        switch face/state switch/default event/type [
            ; down
            ; alt-down
            ; up
            ; alt-up
            ; over
            ; away
            ; move

            down alt-down [
                [
                    hover [
                        face/state: 'pressed
                        mark: event/offset
                    ]
                ]
            ]

            up [
                [
                    pressed [
                        face/state: 'hover
                        do-face face face/text
                    ]
                    pressed-away [face/state: 'default]
                ]
            ]

            alt-up [
                [
                    pressed [
                        face/state: 'hover
                        do-face-alt face face/text
                    ]
                    pressed-away [face/state: 'default]
                ]
            ]

            move [
                [
                    pressed [
                        if action = 'away [face/state: 'pressed-away]
                    ]
                    pressed-away [
                        if action = 'over [face/state: 'pressed]
                    ]
                ]
            ]
        ][
            probe event/type
            []
        ]
        show face
    ]
]

draggable-box-feel: make face/feel [
    redraw: func [face action position][
        face/text: reform [face/state position]
        face/color: switch/default face/state [
            hover [gray]
            pressed [red]
            dragged [forest]
        ][
            coal
        ]
    ]
    over: func [face into position][
        switch/default face/state [
            default [if into [face/state: 'hover]]
            hover [if not into [face/state: 'default]]
        ][
            probe face/state
        ]
        show face
    ]
    mark: none
    engage: func [face action event][
        ; probe reduce [face/state action event/type event/offset]
        switch face/state switch/default event/type [
            ; down
            ; alt-down
            ; up
            ; alt-up
            ; over
            ; away
            ; move

            down alt-down [
                [
                    hover [
                        face/state: 'pressed
                        mark: event/offset
                    ]
                ]
            ]

            up [
                [
                    pressed [
                        face/state: 'hover
                        do-face face face/text
                    ]
                    pressed-away [face/state: 'default]
                    dragged [
                        face/state: 'hover
                    ]
                ]
            ]

            alt-up [
                [
                    pressed [
                        face/state: 'hover
                        do-face-alt face face/text
                    ]
                    pressed-away [face/state: 'default]
                    dragged [
                        face/state: 'hover
                    ]
                ]
            ]

            move [
                [
                    pressed [
                        face/state: 'dragged
                    ]
                    dragged [
                        face/offset: face/offset + event/offset - mark
                    ]
                    pressed [
                        if action = 'away [face/state: 'pressed-away]
                    ]
                    pressed-away [
                        if action = 'over [face/state: 'pressed]
                    ]
                ]
            ]
        ][
            probe event/type
            []
        ]
        show face
    ]
]

demo-text: trim/head/tail trim/auto {
    Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea http://rebol.info consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.
}

resize-text: func [face [object!] /local old-height][
    old-height: face/size/y
    ; Line-List: http://www.rebol.com/docs/view-face-content.html#section-1
    face/line-list: none
    face/size/y: face/para/origin/y + face/para/margin/y + second size-text face
    foreach subface find/tail face/parent-face/pane face [
        subface/offset/y: subface/offset/y - old-height + face/size/y
    ]
    face/size
]

resize-image: func [face [object!] /local face-aspect image-aspect adjusted-size][
    ; cover
    face-aspect: face/size/x / face/size/y
    image-aspect: face/image/size/x / face/image/size/y
    adjusted-size: either face-aspect > image-aspect [
        ; image is narrower, crop top/bottom
        as-pair face/image/size/x face/image/size/x / face-aspect
    ][
        ; image is wider, crop sides
        as-pair face/image/size/y * face-aspect face/image/size/y
    ]
    face/effect: compose [crop (face/image/size - adjusted-size / 2) (adjusted-size) fit]
    face/size

    ; contain
]

win: layout [
    ; feel [redraw: func [f a p][]]
    style btn btn para [origin: margin: 30x10]
    backcolor 237.186.101
    origin 8 space 8
    ; my-area: FIELD wrap 200x150 demo-text with [
    ;     sld: none sz: fsz: tsz: 0x0
    ;     no-edit: false
    ;     edge: none
    ;
    ;     ; make-area-scroller: func [face][
    ;     ;     ; Creates the scroll bar within a text area.
    ;     ;     sld: [sld: scroller as-pair 18 size/y - (edge/size/y * 2)]
    ;     ;     layout/origin sld 0x0
    ;     ;     sld/action: func [face value][scroll-para face/user-data face]
    ;     ;     sld/user-data: face return sld
    ;     ; ]
    ;
    ;     ; resize: does [pane/offset/x: size/x - (edge/size/x * 2) - pane/size/x]
    ;     flags: [tabbed on-unfocus]
    ;     ; words: [no-edit [new/no-edit: true args]]
    ;     feel: ctx-text/edit
    ;
    ;     init: [
    ;         para: make para [origin: 2x2 margin: 22x2]
    ;         ; all [no-edit remove next flags]
    ;         ; feel: make get in svvf either no-edit ['area-noedit]['area-edit][]
    ;         ; effects: colors: images: [] effect: image: none
    ;         ; size: any [size 240x240]
    ;         any [size/x > -1 size/x: 240]
    ;         ; pane: make-area-scroller self
    ;         ; resize
    ;     ]
    ; ]

    my-image: image http://ross-gill.com/files/goatfell-holyisle.jpg 304 effect []

    my-box: box coal 304x200 center middle "Coal" feel draggable-box-feel [
        set-face redraw-text face/state
    ]
    with [state: 'default]

    redraw-text: text 304 para [origin: margin: 0x0] font [offset: 0x0]

    my-text: text 304 demo-text para [origin: margin: 0x0] font [offset: 0x0]

    btn 304 "Move Box Right" [
        move my-box as-pair 8 + my-box/size/x 0
        foreach kid find/tail my-box/parent-face/pane my-box [
            if kid = face [kid/state: 'default]
            move kid as-pair 0 -8 - my-box/size/y
        ]
    ]
    with [state: 'default]
    feel button-feel

    button coal white edge [size: 0] 304 "Move Box Left" [
        move my-box as-pair -8 - my-box/size/x 0
        foreach kid find/tail my-box/parent-face/pane my-box [
            if kid = face [kid/state: 'default]
            move kid as-pair 0 8 + my-box/size/y
        ]
    ]
    with [state: 'default]
    feel button-feel

    btn 304 "I do nothing" #"X" [
        print value
    ]
    with [state: 'default]
    feel button-feel
]

resize-view: func [face [object!]][
    switch type?/word face/pane [
        object! [
            face/pane/size/x: face/size/x - 16
            resize-view face/pane
        ]
        block! [
            foreach subface face/pane [
                if object? subface [
                    subface/size/x: face/size/x - 16
                    switch/default subface/style [
                        text [
                            resize-text subface
                            linkify-face subface
                        ]
                        image [resize-image subface]
                    ][
                        resize-view subface
                    ]
                ]
            ]
        ]
    ]
]

; view win
insert-event-func func [face event][
    switch/default event/type [
        resize maximize [
            event/face/feel/engage event/face event/type event
        ]
        move up down time key []
        close [probe "Closing (global)"]
    ][
        probe reduce ['screen event/type]
    ]
    event
]

view/new/options win reduce [
    'resize 'min-size win/size
]

move: func [target [object!] distance [pair!]][
    target/feel: make face/feel [
        old-state: target/state
        old-feel: target/feel
        old-rate: target/rate
        steps: collect [
            repeat step 5 [
                keep distance * step / 5 + target/offset
            ]
        ]
        engage: func [face action event][
            if action = 'time [
                face/offset: take steps
                if empty? steps [
                    face/rate: old-rate
                    face/feel: old-feel
                    face/state: old-state
                ]
                show face
            ]
        ]
    ]
    target/state: 'moving
    target/rate: 30
    show target
]

shadows-for: func [target [object!] /local effect][
    collect [
        effect: collect [
            foreach kid compose [(target/pane)][
                if all [
                    any [kid/color kid/style = 'image]
                    not kid/state = 'moving
                ][
                    keep reduce [
                        'box kid/offset kid/offset + kid/size + 1x2 1
                    ]
                ]
            ]
        ]
        if not empty? effect [
            keep compose/deep [
                draw [
                    fill-pen 0.0.0.221 pen none
                    (effect)
                ] blur
            ]
        ]
    ]
]

win/feel: make win/feel [
    redraw: func [face action position][
        ; if all [
        ;     find
        ; ]
        face/effect: shadows-for face
    ]

    detect: func [face event][
        switch/default event/type [
            key [
                case [
                    (probe event/key) = #"^w" [
                        unview/only face
                        none
                    ]

                    face: find-key-face face event/key [
                        probe face/style
                        if get in face 'action [do-face face event/key]
                        none
                    ]

                    /else [
                        event
                    ]
                ]
            ]
            move up down time [event]
            resize [
                if event/offset = face/size [
                    probe reduce [win = face 'offset event/offset 'face-offset face/offset 'size face/size 'old-size face/old-size]
                ]
                ; probe event-to-object event
                event
            ]
            close [
                probe "Closing (window detect)"
                event
            ]
        ][
            probe reduce ['window 'detect event/type]
            event
        ]
    ]

    engage: func [face [object!] action [word!] event [event!]][
        switch/all/default event/type [
            resize maximize [
                face/size: max face/size face/options/min-size
                resize-view face
                ; face/effect: shadows-for face
                show face
            ]
            maximize [
                probe 'maximize
                probe event-to-object event
            ]
        ][
            probe reduce ['window 'engage event/type]
        ]
        event
    ]
]

; source find-key-face q

do-events