Archive version of: parse-analysis-view.r ... version: 2 ... brett 19-Dec-2004

Amendment note: Highight positioning bugfix, ensure btns are highlighted in lasted View versions. || Publicly available? Yes

REBOL [
    Title: "Parse Analysis Toolset /View"
    Date: 19-Dec-2004
    File: %parse-analysis-view.r
    Purpose: "Some REBOL/View tools to help learn/analyse parse rules."
    Version: 1.1.0
    Author: "Brett Handley"
    Web: http://www.codeconscious.com
    Comment: "Companion script to parse-analysis.r"
    Library: [
        level: 'intermediate
        platform: 'all
        type: 'tool
        domain: [parse text-processing]
        tested-under: [
            view 1.2.8.3.1 on [WinNT4] {Basic tests.} "Brett"
        ]
        support: none
        license: none
        comment: {
Copyright (C) 2004 Brett Handley All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.  Redistributions
in binary form must reproduce the above copyright notice, this list of
conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.  Neither the name of
the author nor the names of its contributors may be used to
endorse or promote products derived from this software without specific
prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.  
}
        see-also: "parse-analsyis.r"
    ]
]

stylize/master [

    HIGHLIGHTED-TEXT: text with [
        highlights: sizing-face: none
        highlight: has [
            offset highlight-tail part-tail line-tail
            drw-blk highlight-size tmp
        ] [
            append clear drw-blk: effect/draw [pen yellow]
            if any [not highlights empty? highlights] [return]
            foreach [caret length colour] head reverse copy highlights [
                caret: at text caret
                highlight-tail: skip caret length
                copy/part caret highlight-tail
                while [lesser? index? caret index? highlight-tail] [
                    offset: caret-to-offset self caret
                    line-tail: next offset-to-caret self to pair! reduce [first size second offset]
                    part-tail: either lesser? index? line-tail index? highlight-tail [line-tail] [highlight-tail]
                    if lesser-or-equal? index? part-tail index? caret [break]
                    if newline = last tmp: copy/part caret part-tail [remove back tail tmp]
                    if not empty? tmp [
                        if edge [offset: offset - edge/size]
                        sizing-face/text: tmp
                        highlight-size: size-text sizing-face
                        insert tail drw-blk reduce ['fill-pen colour 'box offset offset + highlight-size]
                    ]
                    caret: part-tail
                ]
            ]
        ]
        words: [highlights [new/highlights: second args next args]]
        append init [
            effect: append/only copy [draw] make block! multiply 5 divide length? any [highlights []] 3
            sizing-face: make-face/styles/spec 'text copy self/styles compose [size: (size)]
            highlight
        ]
    ]

    SCROLL-PANEL: FACE edge [size: 2x2 effect: 'ibevel] with [
        data: cropbox: sliders: none

        ; returns unit-vector for an axis
        uv?: func [w] [either w = 'x [1x0] [0x1]]

        ; calculates canvas size
        sz?: func [f] [either f/edge [f/size - (2 * f/edge/size)] [f/size]]

        ; slider widths for both directions as a pair
        sldw: 15x15

        ; Manages the pane.
        layout-pane: function [/resize child-face] [sz dsz v v1 v2 lyo] [
            if none? data [data: copy []]

            ; Convert VID to a face.
            if block? data [data: layout/offset/styles data 0x0 copy self/styles]

            ; On initial layout create the crop-box and sliders.
            if not resize [
                if not size [size: data/size if edge [size: 2 * edge/size + size]]
                lyo: layout compose/deep [origin 0x0 cropbox: box
                    slider 5x1 * sldw [face/parent-face/scroll uv? face/axis value]
                    slider 1x5 * sldw [face/parent-face/scroll uv? face/axis value]]
                sliders: copy/part next lyo/pane 2
                pane: lyo/pane
            ]

            cropbox/pane: data
            sz: sz? self
            cropbox/size: sz dsz: data/size

            ; Determine the size of the content plus any required sliders.
            repeat i 2 [
                repeat v [x y] [
                    if dsz/:v > sz/:v [dsz: sldw * (reverse uv? v) + dsz]
                ]
            ]
            dsz: min dsz sldw + data/size

            ; Size the cropbox to accomodate sliders.
            repeat v [x y] [
                if (dsz/:v > sz/:v) [
                    cropbox/size: cropbox/size - (sldw * (reverse uv? v))
                ]
            ]

            ; Size and position the sliders - non-required slider(s) is/are off stage.
            repeat sl sliders [
                v2: reverse v1: uv? v: sl/axis
                sl/offset: cropbox/size * v2
                sl/size: add 2 * sl/edge/size + cropbox/size * v1 sldw * v2
                sl/redrag min 1.0 divide cropbox/size/:v data/size/:v
                if resize [svvf/drag-off sl sl/pane/1 0x0]
            ]
            if resize [do-face self data/offset]
            self
        ]

        ; Method to scroll the content with performance hinting.
        scroll: function [v value] [extra] [
            extra: min 0x0 (sz? cropbox) - data/size
            data/offset: add extra * v * value data/offset * reverse v
            cropbox/changes: 'offset
            show cropbox
            do-face self data/offset
            self
        ]

        ; Method to change the content
        modify: func [spec] [data: spec layout-pane/resize self]
        resize: func [new /x /y] [
            either any [x y] [
                if x [size/x: new]
                if y [size/y: new]
            ] [size: any [new size]]
            layout-pane/resize self
        ]
        init: [feel: none layout-pane]
        words: [data [new/data: second args next args]
            action [new/action: func [face value] second args next args]]
        multi: make multi [
            image: file: text: none
            block: func [face blk] [if blk/1 [face/data: blk/1]]
        ]
    ]
]

make-token-highlighter: func [
    {Returns a face which highlights tokens.}
    input "The input the tokens are based on."
    tokens [block!] "Block of tokens as returned from the tokenise-parse function."
    /local highlighter-face sz-main sz-input names name-area
] [

    sz-main: system/view/screen-face/size - 150x150
    sz-input: sz-main
    ctx-text/unlight-text

    use [token-lyo colours set-highlight rule? trace-term btns] [

        ; Build colours and bind token words to them.
        use [name-count set-highlight] [
            name-count: length? names: unique extract tokens 3
            colours: make block! 1 + name-count
            foreach name names [insert tail colours reduce [to set-word! name silver]]
            colours: context colours
            tokens: bind/copy tokens in colours 'self
        ]

        ; Helper functions
        rule?: func [
            "Returns the rules that are satisfied at the given input position."
            tokens "As returned from tokenise-parse."
            position [integer!] "The index position to check."
            /local result
        ] [
            if empty? tokens [return copy []]
            result: make block! 100
            forskip tokens 3 [
                if all [
                    get in colours tokens/1 ; Make sure only highlighted terms are selected
                    position >= tokens/3 tokens/3 + tokens/2 > position] [
                    insert tail result copy/part tokens 3
                ]
            ]
            result
        ]
        all-highlights: has [btn] [
            repeat word next first colours [
                set in colours word sky
                btn: get in btns word
                btn/edge/color: sky
            ]
        ]
        clear-highlights: has [btn] [
            repeat word next first colours [
                set in colours word none
                btn: get in btns word
                btn/edge/color: silver
            ]
        ]
        set-highlight: func [name /local clr btn] [
            clr: 110.110.110 + random 120.120.120
            set in colours name clr ; Set the highlighted token.
            btn: get in btns name
            btn/edge/color: clr
        ]

        ; Build name area
        btns: make colours []
        name-area: append make block! 2 * length? names [
            origin 0x0 space 0x0 across
            btn "[Clear]" [
                ctx-text/unlight-text clear trace-term/text
                clear-highlights show token-lyo
            ]
            btn "[All]" [
                ctx-text/unlight-text clear trace-term/text
                all-highlights show token-lyo
            ]
        ]
        foreach name names [
            insert tail name-area append reduce [
                (first bind reduce [to set-word! name] in btns 'self) 'btn
                form name get in colours name
                compose [set-highlight (to lit-word! name) show token-lyo]
            ] [edge [size: 3x3]]
        ]

        ; Build main layout
        token-lyo: layout [

            origin 0x0 space 0x0

            scroll-panel to pair! reduce [sz-input/1 45] name-area
            scroll-panel sz-input [
                origin 0x0 space 0x0
                highlighter-face: highlighted-text black input as-is highlights tokens feel [
                    engage: func [face act event /local rules pos] [
                        switch act [
                            down [
                                either not-equal? face system/view/focal-face [
                                    focus face
                                    system/view/caret: offset-to-caret face event/offset
                                ] [
                                    system/view/highlight-start:
                                    system/view/highlight-end: none
                                    system/view/caret: offset-to-caret face event/offset
                                ]
                                pos: index? system/view/caret
                                rules: rule? tokens pos
                                if not empty? rules [
                                    system/view/highlight-start: at face/text rules/3
                                    system/view/highlight-end: skip system/view/highlight-start rules/2
                                ]
                                insert clear trace-term/text form head reverse extract rules 3
                                show face show trace-term
                            ]
                        ]
                    ]
                ]

            ]
            trace-term: area wrap to pair! reduce [sz-main/1 40]

        ]
        token-lyo/text: "Token Highlighter"
        all-highlights
        token-lyo
    ]
]