Community portal

As you know one of the main problem of rebol is documentation, searching on internet people feel like a man in the middle of the desert:

Every site on Rebol is closed and seem totally separated form the others.
Now there is http://rebol.informe.com, it's a site based on http://www.phpbb3portal.net/ software; it's free and it has:

• a forum
• a wiki
• an image gallery
• a blog

I just imported all most important wiki about Rebol (2 and 3) in it, forum is already divided in sub-forum, support links, images, attachments and flash videos. Image gallery already contains Rebol 2 examples, Rebol 3 examples and the original Rebol 3 GUI images form Carl S. The blog at the moment is just a copy of this one, but you can register and send articles.

I ask to all rebol users in the world to start use it, because at the present every developer is inside his little cave, without any communication with the external world. Rebol 3 is open source now, but it's missing all most important features of Rebol 2 (VID, sound, ...). We must organize and decide what to do, all other communication channels are too closed, slow or disorganized.
Come on join the portal, you'll find only friends abroad.

Rebol on Android

Here is a screenshot of Rebol on Android:

It works...
http://development.saphirion.com/experimental/r3-droid.apk

NEW-LINE function

Ok, I always forget of this essential function, so I write this post hoping to remember it next time I work with blocks.
Did you aver noticed that block can be saved with invisible break lines? Look this example:

>> a: [1 2 3]
== [1 2 3]
>> b: [
1
2
3
]
== [1
2
3
]
>> a = b
== true


Did you notice it? a and b are the same block, but b is saved with "invisible" new lines char.
Computer ignore the "invisible" newline char, but human like you and me need them to understood data in blocks, look another example:

>> address-book: [
Michelle
["+3906500000" "S. Mary St." "Rome" "Italy"]
Carl
["+155500000" "Sassenrath Ranch" "San Francisco" "USA"]
]
>> ? address-book
ADDRESS-BOOK is a block of value: [
Michelle
["+3906500000" "S. Mary St." "Rome" "Italy"]
Carl
["+155500000" "Sassenrath Ranch" "San Francisco" "USA"]
]

It's easy to understand how is made, now try the same blocks without new-lines:

>> new-line/all address-book false
>> ? address-book
ADDRESS-BOOK is a block of value: [Michelle ["+3906500000" "S. Mary St." "Rome" "Italy"] Carl ["+15550000
0" "Sassenrath Ranch" "San Francisco" "USA"]
]


Now, do you understand the importance of "invisible" new-lines in block? They make files human readable!
Rebol has the new-line function to switch or insert new lines in blocks, let's see how it works.
First of all new-line has a refinement called /all that add or remove all newlines from block, setting the newline value true or false, example:

new-line/all address-book false
? address-book
new-line/all address-book true
? address-book


Moreover you can set the new-line on o off also only in a specific point (use at:

new-line at address-book 2 off
>> ? address-book
ADDRESS-BOOK is a block of value: [
Michelle ["+3906500000" "S. Mary St." "Rome" "Italy"]
Carl
["+155500000" "Sassenrath Ranch" "San Francisco" "USA"]
]


I remember you also that ON, TRUE and YES are the same thing on rebol, and OFF, FALSE, NO are the same thing on rebol.

Seeing parse in action

Mr. Brett Handley has a great site about Rebol: http://www.codeconscious.com
and he made a lot of useful scripts. Today we will discover three of them about PARSE. I contacted him and he was so kind to answer to my email and writing the following examples and concepts.
If this post seems too complicated, jump to the examples and all will become clear (otherwise post your questions on the comments :-) )
First of all let's see the scripts:

• PARSE-ANALYSIS.R , (Examples)
• PARSE-ANALYSIS-VIEW.R, (Examples)
• LOAD-PARSE-TREE.R, (Examples)

PARSE-ANALYSIS.R

Brett says about this script: "My first insight was to realize a script I could track parse rules by modifying them to call tracking code. In this way I could have some functions help me debug complex parse rules.
I used the concept of hooking into existing parse rules. This allows tracing of parse rules that you may have downloaded or even the parse rules used by REBOL's mezzanine functions (e.g REBOL's parse-xml function)."

Here is the script:

REBOL [
    Title: "Parse Analysis Toolset"
    Date: 17-Dec-2004
    File: %parse-analysis.r
    Purpose: "Some tools to help learn/analyze parse rules."
    Version: 1.1.0
    Author: "Brett Handley"
    Web: http://www.codeconscious.com
    license:   {
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:
May not be executed within web CGI or other server processes.
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.  
}
]
hook-parse: func [
    "Hook parse rules for events: test a rule (Test), rule succeeds (Pass), rule fails (Fail). Returns hook context."
    rules [block!] "Block of words. Each word must identify a Parse rule to be hooked."
    /local hook-context spec
] [
    ; Check the input

    if not parse rules [some any-word!] [make error! "Expecting a block of words."]
    ; Create the hook context.

    hook-context: context [
        step: level: status: current: ; State tracking variables.
        rule-words: ; The original rules (maintaining their bindings).
        rule-def: ; The original rule values.
        last-begin: ; A variable to track the input position when the rule starts.
        last-end: ; A variable to track the input position when the rule ends.
        pass: fail: test: ; Functions called when the corresponding parse event occurs.
        none
        reset: does [step: level: 0 last-begin: last-end: current: none]
    ]
    hook-context/rule-words: rules
    ; Create a context to store the original rule definitions.

    spec: make block! multiply 2 length? rules
    repeat rule rules [insert tail spec to set-word! rule]
    hook-context/rule-def: context append spec [none]
    ; Modify the given rules to point to the
    ; hook-context's tracking rules and save
    ; the original rules.

    repeat rule rules [
        set in hook-context/rule-def rule reduce [get rule]
        set rule bind reduce [
            ; Rule invocation

            to set-word! 'last-begin
            to paren! compose [
                step: step + 1 level: level + 1
                current: (to lit-word! rule) status: 'test
                test
            ]
            ; Call the original rule.

            in hook-context/rule-def rule
            ; Rule Success

            to set-word! 'last-end
            to paren! compose [
                step: step + 1 level: level - 1
                current: (to lit-word! rule) status: 'pass
                pass
            ]
            '|
            ; Rule failure

            to set-word! 'last-end
            to paren! compose [
                step: step + 1 level: level - 1
                current: (to lit-word! rule) status: 'fail
                fail
            ]
            'end 'skip ; Ensure the failure result is maintained.

        ] in hook-context 'self
    ]
    ; Return the hook-context.
    hook-context
]
unhook-parse: func [
    "Unhooks parse rules hooked by the Hook-Parse function."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
] [
    repeat rule hook-context/rule-words [set rule first get in hook-context/rule-def rule]
    hook-context/rule-def: none ; Clear references to original rules.
    hook-context/reset
    return ; return unset
]
count-parse: func [
    "Returns counts of calls, successes, fails of Parse rules."
    body [block!] "Expression to invoke Parse on your input."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
    /local ctr-t ctr-p ctr-f increment
] [
    ; Initialise counters
    foreach w [ctr-t ctr-p ctr-f] [set w array/initial length? hook-context/rule-words 0]
    ; Helper function
    increment: func [ctr /local idx] [
        idx: index? find hook-context/rule-words hook-context/current
        poke ctr idx add 1 pick ctr idx
    ]
    ; Bind to the hook-context. Note that the event functions *must* be bound to the same context.
    do bind [
        test: does [increment ctr-t]
        pass: does [increment ctr-p]
        fail: does [increment ctr-f]
    ] in hook-context 'self
    ; Invoke the parse as specified by user.
    hook-context/reset
    do body
    ; Return result
    reduce [copy hook-context/rule-words ctr-t ctr-p ctr-f]
]
explain-parse: func [
    "Emits numbered parse steps."
    body [block!] "Invoke Parse on your input."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
    /begin begin-fn [any-function!] "Function called when rule begins. Spec: [context-stack [block!] begin-context-clone [object!]]"
    /end end-fn [any-function!] "Function called when rule ends.   Spec: [context-stack [block!] begin-context-clone [object!] end-context-clone [object!]]."
] [
    ; Initialise

    if not begin [
        begin-fn: func [context-stack begin-context] [
            print rejoin bind/copy [
                head insert/dup copy "" "   " subtract level 1
                step " begin '" current " at " index? last-begin
            ] in begin-context 'self
        ]
    ]
    if not end [
        end-fn: func [context-stack begin-context end-context] [
            print rejoin bind/copy [
                head insert/dup copy "" "   " (subtract begin-context/level 1)
                step " end '" current " at " index? last-end
                " started-on " begin-context/step " " end-context/status "ed"
            ] in end-context 'self
        ]
    ]
    use [stack] [
        stack: make block! 20
        ; Make the hook-context. Note that the event functions *must* be
        ; bound to the same context.
        do bind [
            test: has [] [
                begin-fn stack hook-context
                insert tail stack make hook-context []
            ]
            pass: has [ctx] [
                ctx: last stack
                remove back tail stack
                end-fn stack ctx hook-context
            ]
            fail: has [ctx] compose [
                ctx: last stack
                remove back tail stack
                end-fn stack ctx hook-context
            ]
        ] in hook-context 'self
        ; Invoke the hook-context
        hook-context/reset
        do body
    ]
    ; Return unset
    return
]
tokenise-parse: func [
    "Tokenises the input using the rule names."
    body [block!] "Invoke Parse on your input. The block must return True in order to return the result."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
] [
    use [stack result fn-b fn-e] [
        stack: make block! 20
        result: make block! 10000
        fn-b: does [insert/only tail stack tail result]
        fn-e: func [context-stack begin-context end-context /local bookmark] [
            bookmark: last stack
            remove back tail stack
            either 'pass = end-context/status [
                insert tail result reduce [
                    end-context/current
                    subtract index? end-context/last-end index? begin-context/last-begin ; Length
                    index? begin-context/last-begin ; Input position
                ]
            ] [clear bookmark]
        ]
        explain-parse/begin/end body hook-context :fn-b :fn-e
        result
    ]
]


The functions contained in the script are:

Hook-Parse

Enables you to trace the execution of parse rules. It replaces rules with modified rules that track the parse state. Returns an object that represents the parse state and stores the original parse definitions. It is important to note that any rules you do not hook are not tracked and do not appear in the outputs. This is useful when you want to filter out terms that are not important to your application. On the other hand you do not want to filter out terms that are necessary to get a complete picture of the parsing. For example: If your data is described by [a b c] and you filter out b - you will miss important information. But if your data is descibed by [a b] where b: [x y z] and you filter out b OR you filter out x, y and z then there is no problem because your input is completely specified by the rules.

Unhook-Parse

Removes the calls to tracing code, to return the parse rules back to their original definitions.

Count-Parse

Counts each time rule is tested, passed or failed. The result is in the form: [rules test-counts pass-counts fail-counts] Two benefits of this function:

1. the results may give some insight into which rules are doing all the work.
2. the code shows how you can set the event functions in the hook context.

Explain-Parse

Interprets events as the parse rules are executing - useful for debugging rules. By default displays the events as they occur which can help with debugging complex parse rules. There are begin events and end events and each is numbered sequentially as they occur. Each shows the input index position after the word AT. The end event shows the number of the begin event it is paired with after the word STARTED-ON. explain-parse is used by tokenise-parse and load-parse-tree.

Tokenise-Parse

Returns a sequence of tokens where each token is a triple of the form: rule-name length-of-input-matched input-index-position This output form allows the result to be reversed and sorted by index positions if desired. The output from Tokenise-parse is used by make-token-highlighter of parse-analysis-view.r script.

Examples

Let's do the script and start a rule example:

DO %parse-analysis.r
digit: charset {0123456789}
hex-digit: charset {0123456789ABCDEF}
letter: charset [#"a" - #"z" #"A" - #"Z"]
word: [some letter]
phrase: [some [word | { } ]]
number: [some digit]
hex-literal: [#"$" some hex-digit]
item: [phrase | hex-literal | number | { } ]
data: {There were 374 brown foxes and $0001 mottley one.}


then we create a function that launch our parse command:
parse-the-example: does [ parse/all data [any item]]

then we must create the hook object:
example-hook-context: hook-parse [phrase word hex-literal number]

a hook object is made this way:

>> ? example-hook-context
EXAMPLE-HOOK-CONTEXT is an object of value:
  step             none!     none
  level           none!     none
  status           none!     none
  current         none!     none
  rule-words       block!     length: 4
  rule-def         object!   [phrase word hex-literal number]
  last-begin       none!     none
  last-end         none!     none
  pass             none!     none
  fail             none!     none
  test             none!     none
  reset           function! []


now we are read to launch script functions like explain-parse:


>> explain-parse [parse-the-example] example-hook-context
1 begin 'phrase at 1
2 begin 'word at 1
3 end 'word at 6 started-on 2 passed
4 begin 'word at 6
5 end 'word at 6 started-on 4 failed
6 begin 'word at 7
7 end 'word at 11 started-on 6 passed
8 begin 'word at 11
9 end 'word at 11 started-on 8 failed
10 begin 'word at 12
11 end 'word at 12 started-on 10 failed
12 end 'phrase at 12 started-on 1 passed
13 begin 'phrase at 12
14 begin 'word at 12
15 end 'word at 12 started-on 14 failed
16 end 'phrase at 12 started-on 13 failed
17 begin 'hex-literal at 12
18 end 'hex-literal at 12 started-on 17 failed
19 begin 'number at 12
20 end 'number at 15 started-on 19 passed
21 begin 'phrase at 15
22 begin 'word at 15
23 end 'word at 15 started-on 22 failed
24 begin 'word at 16
25 end 'word at 21 started-on 24 passed
26 begin 'word at 21
27 end 'word at 21 started-on 26 failed
28 begin 'word at 22
29 end 'word at 27 started-on 28 passed
30 begin 'word at 27
31 end 'word at 27 started-on 30 failed
32 begin 'word at 28
33 end 'word at 31 started-on 32 passed
34 begin 'word at 31
35 end 'word at 31 started-on 34 failed
36 begin 'word at 32
37 end 'word at 32 started-on 36 failed
38 end 'phrase at 32 started-on 21 passed
39 begin 'phrase at 32
40 begin 'word at 32
41 end 'word at 32 started-on 40 failed
42 end 'phrase at 32 started-on 39 failed
43 begin 'hex-literal at 32
44 end 'hex-literal at 37 started-on 43 passed
45 begin 'phrase at 37
46 begin 'word at 37
47 end 'word at 37 started-on 46 failed
48 begin 'word at 38
49 end 'word at 45 started-on 48 passed
50 begin 'word at 45
51 end 'word at 45 started-on 50 failed
52 begin 'word at 46
53 end 'word at 49 started-on 52 passed
54 begin 'word at 49
55 end 'word at 49 started-on 54 failed
56 end 'phrase at 49 started-on 45 passed
57 begin 'phrase at 49
58 begin 'word at 49
59 end 'word at 49 started-on 58 failed
60 end 'phrase at 49 started-on 57 failed
61 begin 'hex-literal at 49
62 end 'hex-literal at 49 started-on 61 failed
63 begin 'number at 49
64 end 'number at 49 started-on 63 failed


Did you notice it? Parse is explained line by line: what it found and if test is passed or not.
Now let's see count-parse:

>> print mold new-line/all (count-parse [parse-the-example] example-hook-context) true
== [
[phrase word hex-literal number]
[6 21 3 2]
[3 7 1 1]
[3 14 2 1]
]
Remember that output is put this way: [rules test-counts pass-counts fail-counts].
So you can read it:

rules	test-counts	pass-counts	fail-counts
phrase	6	3	3
word	21	7	14
hex-literal	3	1	2
number	2	1	1

Now let's see tokenise-parse:

>> print mold tokens: new-line/all/skip (tokenise-parse [parse-the-example] example-hook-con
text) true 3
== [
word 5 1
word 4 7
phrase 11 1
number 3 12
word 5 16
word 5 22
word 3 28
phrase 17 15
hex-literal 5 32
word 7 38
word 3 46
phrase 12 37
]

Even in this case you must remember that output is in the form:
rule-name length-of-input-matched input-index-position
so a word i length 5 chars and start at position 1; a number start at position 12 and it's 3 chars length.

PARSE-ANALYSIS-VIEW.R

Brett says about this script: "My second insight was to realize I could visualize how the rules break up text by displaying the textual input in a window and overlaying it with boxes and colors that represent the rules."

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"
    license: {
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.  
}
]
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
    ]
]


Example

DO %parse-analysis.r
DO %parse-analysis-view.r
digit: charset {0123456789}
hex-digit: charset {0123456789ABCDEF}
letter: charset [#"a" - #"z" #"A" - #"Z"]
word: [some letter]
phrase: [some [word | { }   ]]
number: [some digit]
hex-literal: [#"$" some hex-digit]
item: [phrase | hex-literal | number | { } ]
data: {There were 374 brown foxes and $0001 mottley one.}
parse-the-example: does [parse/all data [any item] ]
example-hook-context: hook-parse [phrase word hex-literal number]
tokens: new-line/all/skip (tokenise-parse [parse-the-example] example-hook-context) true 3

and the new function make-token-highlighter
view make-token-highlighter data tokens
and this will be the result:

You can play with buttons to see the different matches.

LOAD-PARSE-TREE.R

Brett says about this script: "My third insight was to realise that parse rules describe the structure of a format implicitly and that each parse rule name (a word) represents a term in the structure.
The normal way to build output with parse rules is to add actions (parens) to the rules that build up the output structure. In my mind this is a duplication, because the parse rules describe the structure, and now we build it again with output actions.
So instead of those actions and their redundancy I decided to write a function that automatically creates an output structure just by tracking which parse rules were successful as they are executed. This allows an abstract syntax tree of the input to be built automatically."

Here is the script:

REBOL [
    Title: "Load-Parse-Tree (Parse-Analysis)"
    Date: 17-June-2006
    File: %load-parse-tree.r
    Purpose: "Load a block structure representing your input as matched by Parse."
    Version: 1.0.0
    Author: "Brett Handley"
    Web: http://www.codeconscious.com
    Comment: "Requires parse-analysis.r (see rebol.org)"
    license: {
Copyright (c) 2006, 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:
* This program must not be used to run websever CGI or other server processes.
* 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.
* The name of Brett Handley may not 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.
}
]
load-parse-tree: func [
    "Tokenises the input using the rule names."
    body [block!] "Invoke Parse on your input. The block must return True in order to return the result."
    hook-context [object!] "Hook context returned by the Hook-Parse function."
    /block input [any-block!] "For block input, supply the input block here so it can be indexed."
] [
    use [stack result fn-b fn-e block-list index-fn] [
    index-fn: :index?
        stack: make block! 20
        result: copy []
        fn-b: does [
        insert/only tail stack result
        result: copy []
    ]
        fn-e: func [context-stack begin-context end-context /local content tk-len tk-ref] [
        ; Restore state to parent of just completed term.
        content: result
            result: last stack
            remove back tail stack
        ; Term has just completed - insert it into the result or discard it.
            if 'pass = end-context/status [
                either 1 + begin-context/step = end-context/step [
            tk-len: subtract index? end-context/last-end index? begin-context/last-begin ; Length
            tk-ref: begin-context/last-begin ; Input position
            content: copy/part tk-ref tk-len
        ][new-line/all/skip content 1 2]
                insert tail result reduce [end-context/current content]
            ]
        ]
        explain-parse/begin/end body hook-context :fn-b :fn-e
        new-line/all/skip result true 2
    ]
]


Example

As usual let's to all from the beginning:


DO %parse-analysis.r
DO %parse-analysis-view.r
digit: charset {0123456789}
hex-digit: charset {0123456789ABCDEF}
letter: charset [#"a" - #"z" #"A" - #"Z"]
word: [some letter]
phrase: [some [word | { }   ]]
number: [some digit]
hex-literal: [#"$" some hex-digit]
item: [phrase | hex-literal | number | { } ]
data: {There were 374 brown foxes and $0001 mottley one.}
parse-the-example: does [parse/all data [any item] ]
example-hook-context: hook-parse [phrase word hex-literal number]

Then we launch load-parse-tree
temp: load-parse-tree [ parse data [any item] ] example-hook-context
and temp will contain:

[
phrase [
word "There were "
]
number "374 "
phrase [
word "brown foxes and "
]
hex-literal "$0001 "
phrase [
word "mottley one"
]
]


Locking and unlocking resources

The script presented today is very interesting, it permits to lock a variable (so any resource), to prevent access to other users.
The script is composed of a server (lock-server)and the client functions (try-obtain-lock and free-lock). Let's see how it works:
open a rebol console do the following script:

REBOL [
    Title: "REBOL Locking System"
    Date: 23-Jun-1999
    Version: 1
    File: %lock-file.r
    Author: "Cal Dixon"
    Rights: {
        Copyright (c) 1999 Caleb Dixon.   This version is free for ANY
        use.   Do whatever you want with it as long as you don't claim
        to have created this.
    }
    Usage: {
        Be sure to run the 'lock-server function in a separate rebol
        process before calling the other functions, they will fail if
        the server is not available.   Once the server is running, you
        can just "do %locker.r" then use 'get-lock and 'free-lock in
        any script that needs resource locking.
    }
    Purpose: {To provide functions for voluntary resource locking in rebol}
    Comment: {
      This version does not do enough error checking.   This will be
      fixed later.
    }
    Email: deadzaphod@hotmail.com
]
; change this line if you want to use a port other than 7007 for this service.
if not value? 'rebol-lock-port   [rebol-lock-port: 7007]
lock-server: func [{Handles requests to lock and unlock named resources.}][
    locks: make block! []
    listener: open/lines join tcp://: rebol-lock-port
    while [true] [
        conn: first listener
        wait conn
        req: load first conn
        if (= to-lit-word (pick req 1) 'lock) [
            if none? find locks (pick req 2) [ append locks reduce [ (pick req 2) true ] ]
        if (available: do rejoin ["locks/" (pick req 2) ]) [
            do rejoin [ "locks/" (pick req 2) ": false" ]
        ]
        insert conn rejoin ["[" available "]" ]
        ]
        if (= to-lit-word (pick req 1) 'free) [
            do rejoin [ "locks/" (pick req 2) ": true" ]
            insert conn "[true ]"
        ]
        close conn
    ]
]
try-obtain-lock: function ["Attempt to lock a named resource"
    whichword [word!] ] [] [
    conn: open/lines join tcp://localhost: rebol-lock-port
    insert conn rejoin [ "[lock " whichword "]" ]
    return do load first conn
]
get-lock: function [
    {Attempt to lock a named resource, and retry if it is not available}
    whichword [word!] retries [integer!] ] [gotit ] [
    while [ not (gotit: try-obtain-lock whichword) ] [
        if (retries < 1) [ return gotit ]
        retries: retries - 1
        wait 1
    ]
    gotit
]
free-lock: function ["Free a named resource" whichword [word!] ] [] [
  conn: open/lines join tcp://localhost: rebol-lock-port
  insert conn rejoin [ "[free " whichword "]" ]
  return do load first conn
]


then launch:

lock-server


Now open another rebol console, do the same script and try this:

>> a: "hello word"
== "hello word"
>> try-obtain-lock 'a
== true
>> try-obtain-lock 'a
== false
>> free-lock 'a
== true


As you noted, the first console check if some variable is locked and advice you. You can't obtain TRUE from try-to-obtain if the variable isn't freed.
Well, why is so interesting? The answer is that in a multiuser environment or working with databases, you must know if someone is working on a resource, and avoid job collisions.  Just image a webshop that it has just one item to sell and two users simultaneously order the item, only with locking you avoid mistakes.
Another great feature of this script is the client server configuration, this way you can work with multiple users, across internet, and create multithreads programs!!!