REBOL [
    Title: "ARROW Style"
    Author: ["Gregg Irwin" "Christopher Ross-Gill"]
    File: %arrow-style.r
    Version: 0.0.5
    Date: 5-Apr-2005
    History: {
        Comments omitted for brevity.  4-point version only.
        See http://shadwolf.free.fr/arrow-RebGUI-port.r for
        more options...
    }
]

do %gui.r

widgets: make widgets [
    flip-pair: func [pr [pair!] os][
        pr: pr - os
        os + as-pair pr/y pr/x
    ]

    compose-arrow: func [
        "Returns a block of DRAW commands for an arrow glyph"
        size  "Parent Style Size"
        glyph "Glyph Data Block: [shape word! color tuple! direction word!]"
        /local rel-coord gsize gcenter os goffset weight out
    ][
        rel-coord: func ["Returns glyph-offset-relative coordinate" x y][
            goffset + as-pair x y
        ]
        gsize: min size/x size/y
        gsize: gsize - either gsize > 17 [7][5]
        gcenter: reduce [to-integer gsize / 2  none]
        gcenter/2: gsize - gcenter/1
        weight: max 2 to-integer gsize / 6
        os: goffset: size - gsize / 2

        goffset/y: either find [chevron penta pointer] glyph/shape [
            size/y - gcenter/1 - weight - 1 / 2
        ][
            size/y - gcenter/1 - 1 / 2
        ]

        out: reduce [
            rel-coord gcenter/1       0
            rel-coord 0               gcenter/1
            rel-coord weight          gcenter/1 + weight
            rel-coord gcenter/1       2 * weight
            rel-coord gcenter/2       2 * weight
            rel-coord gsize - weight  gcenter/1 + weight
            rel-coord gsize           gcenter/1
            rel-coord gcenter/2       0
        ]

        switch glyph/shape [
            triangle [remove/part at out 3 4]
            compass  [remove at out 6 remove at out 3]
            penta    [remove/part at out 4 2]
            pointer  [
                change/part at out 4 reduce [
                    rel-coord gcenter/1 - weight  gcenter/1
                    rel-coord gcenter/1 - weight  2 * weight + gcenter/1
                    rel-coord gcenter/2 + weight  2 * weight + gcenter/1
                    rel-coord gcenter/2 + weight  gcenter/1
                ] 2
                out: head forall out [change out subtract first out 0x1]
            ]
        ]

        forall out [
            switch glyph/direction [
                down  [out/1/y: size/y - 1 - out/1/y]
                left  [change out flip-pair out/1 os]
                right [change out flip-pair out/1 os  out/1/x: size/x - 1 - out/1/x]
            ]
        ]
        compose [pen none fill-pen (glyph/color) polygon (head out)]
    ]

    arrow-feel: context [
        arrow: make svvf/hot [
            redraw: func [face action position][
                all [action = 'show face/edge face/edge/effect: pick [ibevel bevel] face/state]
            ]
            over: func [f a p][]
            engage: func [face action event][
                switch action [
                    time     [if face/state [do-face face face/text]]
                    down     [face/state: on  do-face face face/text]
                    alt-down [face/state: on  do-face-alt face face/text]
                    up       [face/state: off]
                    alt-up   [face/state: off]
                    over     [face/state: on ]
                    away     [face/state: off]
                ]
                show face
            ]
        ]
    ]

    ARROW: make face [
        color: water
        size: 20x20
        glyph: context [shape: 'chevron color: 255.255.255 direction: 'up]
        data: none
        state: off
        feel: arrow-feel/arrow
        font: none
        edge: make face/edge [size: 1x1]
        init: does [
            if find [up down left right] data [glyph/direction: data]
            effect: compose [(any [effect []])]
            insert effect reduce ['draw compose-arrow size - edge/size - edge/size glyph]
        ]
    ]
]

display "RebGUI Arrow Example" [
    aw1: arrow []
    aw2: arrow [data down]
]

wait []