AltME groups: search

rewrite: func [block rules /local rules* rule flag mk1 mk2 prod] 
[
    if empty? rules [return block]
    rules*: make block! 16
    foreach [pattern production] rules [

        insert insert/only insert/only tail rules* pattern make paren! compose/only 
        [
            prod: compose/deep (production)
        ] '|
    ]
    remove back tail rules*
    until [
        ;probe block ask ""

        not match block [mk1: rules* mk2: (mk2: change/part mk1 prod mk2) 
        :mk2]
    ]
    block
]

Here are some minimum additonal parse operations, and some workarounds 
that could be used to replace them until they are implemented.

fail ==> [end skip]
check (code) ==> (tmp1: unless (code) [fail]) tmp1
remove rule ==> tmp1: rule tmp2: :tmp1 (remove/part :tmp1 :tmp2)

replace rule (code) ==> tmp1: rule tmp2: :tmp1 (tmp1: change/part 
:tmp1 (code) :tmp2) :tmp1

replace-only rule (code) ==> tmp1: rule tmp2: :tmp1 (tmp1: change/part/only 
:tmp1 (code) :tmp2) :tmp1

into-string rule ==> set tmp1 string! (tmp1: unless parse tmp1 rule 
[fail]) tmp1


Note that if parse operations are changed to take refinements or 
if these are being done as rewrite rules, replace-only and into-string 
could be expressed as remove/only and into/string. This would be 
slower in a native implementation, but about the same in rewrite 
rules. It would look more REBOL-like if that matters to you.


A rewrite engine for these workarounds will need temporaries for 
their implementation. The caller would need to provide a block of 
their own temporaries, and would not be able to reuse them in their 
code. The rewriter will need to count temporaries and complain if 
the caller doesn't provide enough. As with all parse rules, these 
temporaries will not be recursion-safe. Directly nested rules should 
be fine as long as there are enough temporaries provided.

Looks good to me. BTW, the mk2: in

    not match data [mk1: rules* mk2: (mk2: change/part mk1 prod mk2) 
    :mk1]
isn't used by your code. Did you mean mk1: instead?

Didec, i should do: parse b [any [h: set x skip (h: change/part h 
x 1) :h]]

I was thinking (name pending) --

one-word: func [blk][head while [not tail? blk][blk: change/part 
blk get blk/1 1]]

>> a: copy b
== [[1 2] [3 4]]
>> while [not tail? a][a: change/part a a/1 1] a: head a
== [1 2 3 4]

tm: func [p act [block!] /local t][t: now/time/precise loop p :act 
print now/time/precise - t]

flat-while: func[b][a: copy b while [not tail? a][a: change/part 
a a/1 1] a: head a]

flat-repeat: func[b][a: copy [] repeat i length? b [insert tail a 
pick b i] a]

flat-parse: func [b][a: copy [] parse b r: [any [ p: block! :p into 
r | skip (insert/only tail a first p)]]a]
flat-load: func[b][load form b]
b1: [[1 2 3 4 5][6 7 8 9 0]]
tm 10000 [flat-while b1]  ;== 0:00:00.062
tm 10000 [flat-repeat b1] ;== 0:00:00.063
tm 10000 [flat-parse b1]  ;== 0:00:00.172
tm 10000 [flat-load b1]   ;== 0:00:00.046

b2: head insert/dup copy [] [a b c d] 300
b3: head insert/dup copy [] b2 100

tm 1000 [flat-while b3]  ;== 0:03:03.985
tm 1000 [flat-repeat b3] ;== 0:02:11.125
tm 1000 [flat-parse b3]  ;== 0:02:43.704
tm 1000 [flat-load b3]   ;== 0:00:52.344

flatten: func [block [any-block!]][

    parse block [

         any [block: any-block! (change/part block first block 1) :block | 
         skip]

    ]
 
   head block
]

hm.. parse t: "a//bb/c" [any [to "/" p1: some "/" p2: (p1: change/part 
p1 "/" p2) :p1] to end] t

REBOL []

parse-async: func [
        file rules
        /local port buffer offset getf seek meta & && result
][
        port: open/seek/binary  file
        buffer: clear #{}
        offset: 1
        getf: func [len][
                offset: offset - length? buffer
                clear buffer 
                append buffer copy/part at port offset len 
                offset: offset + len 
        ]
        seek: [(offset: offset + 1)]
        ..: func [blk] [change/part & compose/deep blk && ]
        parse rules meta: [
                some [

                        &: binary! &&: (.. [buffer: (to-paren reduce ['getf length? &/1]) 
                        (&/1)]) :& 3 skip 
                        | &: 'skip &&: (.. [seek]) :& skip
                        | &: 'get word! integer! &&:

                                (.. [buffer: (to-paren compose/deep [getf (&/3) set [(&/2)] to integer! 
                                as-binary cp buffer]) to end]) :& 4 skip

                        | &: string! &&: (.. [(as-binary &/1)]) :& 
                        | 'end 'skip 
                        | into meta
                        | skip
                ]
        ]
        result: parse/all buffer rules
        close port
        result
 ]
 
if parse-async %15.jpg [
        #{FFD8}   ; jpeg Header
        [
                 #{FFE0}                        ;JFIF header

                        get len 2               ;get data length  for the current header 
                        (2 bytes)

                         "JFIF"                 ;yeah it's a JFIF (confirmation)

                        (len: len - 6) len skip ;skip data (len) times
                        some [

                                 #{FFC0}        ;good ! i found the length properties

                                        2 skip  ; skip length of this header

                                        skip    ; filler ??? always = #{08}
                                        get height 2
                                        get width 2
                                        break   ; finished

                                | #{FF} skip    ;skip this header
                                        get len 2 
                                        (len: len - 2) len skip
                                | 

                                        [end skip]     ;error format
                        ]

                | #{FFE1}                       ;EXIF header

                        get len 2               ;get length of a header
                                                ;... to do
                        [end skip]
        ]
        to end
][
   ?? height
   ?? width
]        
halt

Paul, you can avoid copy blk/1 by using change/part.

And perhaps better to continue processing the data when blk/1 is 
not a block.

semi-flat: func [blk][
    while [not tail? blk][
        blk: either block? blk/1 [
            change/part blk blk/1 1
        ][
	    next blk
	]
    ]
    head blk
]

semi-flat [[1 ["one"]] [2 ["two"]] "other data"]

You can also use until instead of while:
semi-flat: func [blk][
    until [
	tail? blk: either block? blk/1 [
            change/part blk blk/1 1
        ][
	    next blk
	]
    ]
    head blk
]

Here's a version which modifies in place:

flatten: func [blk [block!] /local rule a b] [
	parse blk [some [a: set b block! (change/part a b 1) :a | skip]]
	blk
]

s2: copy s parse/all s2 [some [p: "^/" (change/part p "^^/" 1) skip 
| "^-" (change/part p "^^-" 1) skip | skip]]

s2: copy a parse/all s2 [some [p: "^/" (change/part p "^^/" 1) skip 
| "^-" (chang
e/part p "^^-" 1) skip | skip]]
== true
>> s2
== {a^^/^^-b^^/^^-c}
>> print s2
a^/^-b^/^-c


Anton, It looks like what I want but if aI print it the newlines 
are not reconized???

>> s: "a^/^-b^/^-^-c"
== {a
^-b
^-^-c}


>> s2: copy s parse/all s2 [some [p: "^/" (change/part p "^^/" 1) 
skip | "^-" (change/part p "^^-" 1) skip | skip]]
== true

>> s3: load rejoin ["{" s "}"]
== {a
^-b
^-^-c}

>> s = s3
== true

while [not empty? blk] [
	blk: change/part blk copy/part blk span
]

Sorry, change/part -> change/part/only

unless [empty? blk: change/part blk copy/part blk span span]
(unless is a litlle faster than while)

Yeah, you need to be escaping a lot more than just those characters 
to really do it right.  I can't help you with building the table 
of escapes, but this version should be a lot faster if you're escaping 
large quantities of text...

encode-html: func [

    "Make HTML tags into HTML viewable escapes (for posting code)"
    text
][
	parse/all text [
		any [
			h: #"&" (h: change/part h "&" 1) :h |
			h: #"<" (h: change/part h "&lt;" 1) :h |
			h: #">" (h: change/part h "&gt;" 1) :h |
			h: #""" (h: change/part h "&quot;" 1) :h |
			h: #"'" (h: change/part h "&apos;" 1) :h |
			h: #"€" (h: change/part h "&#8364;" 1) :h |
			skip
		]
    ]
	text
]

Maybe better:
forall blk [change/part blk blk/1 1]

Slight differences - no internal blocks are preserved in Geomol's:
>> blk: [1 [2] [3 [4]] [5 6]]    
== [1 [2] [3 [4]] [5 6]]
>> forall blk [change/part blk blk/1 1]                     
== []
>> blk
== [1 2 3 4 5 6]


My version (gives the same result as kcollins, but is in-place like 
Geomol's) only flattens one level:
>> blk: [1 [2] [3 [4]] [5 6]]          
== [1 [2] [3 [4]] [5 6]]
>> forall blk [blk: back insert blk also blk/1 remove blk]
== [6]
>> blk
== [1 2 3 [4] 5 6]

I use a variant of this:

sanitize: use [chars encode][
	chars: complement charset {&<>"}
	encode: func [txt chr][change/part txt chr 1]
	
	func [text [any-string!]][
		parse/all copy text [
			copy text any [
				text: some chars
				| #"&" (text: encode text "&amp;") :text
				| #"<" (text: encode text "&lt;") :text
				| #">" (text: encode text "&gt;") :text
				| #"^"" (text: encode text "&quot;") :text
			]
		]
		any [text ""]
	]
]

Provides a bit of scope for expansion...

A non-parse solution (for the replace problem) based on the existing 
replace mezz:

replace-each: make function! [
	target [series!] "Series that is being modified"
	values [block!] "Block of search/replace strings"
	/local len pos
][
	foreach [search replace] values [
		len: length? search
		while [pos: find target search] [
			target: change/part pos replace len 
		]
	]
]

Sounds interesting. I know that CHANGE/part is the real fundamental 
operation, but that needs an additional parameter and would require 
renaming the option - /into isn't an appropriate name for that operation. 
But I don't think it would have been implemented in that case, and 
having it be a direct CHANGE would definitely not have been accepted 
because /into is mostly used to replace chained INSERT and APPEND 
operations.

Is there a way to copy a part of an image from a certain position 
to another image at a certain position? Something like:

change/part at image1 5x5 at image2 10x10 20x20


That should take 20x20 pixels from image2 at position 10x10 and put 
them in image1 at position 5x5, but it takes from the start of image2, 
so it doesn't work as intended.

For a binary float value in the variable binfloat, try this:

a: make struct! [x [float]] none
change/part third a binfloat
a/x


The third a accessor returns a reference to the binary data of the 
struct. Modifications to the value returned affect the struct. Be 
sure to keep the length of the returned binary the same.

Whoops, the change line is: change/part third a binfloat 4

dt: now/precise   t: dt/time   t: find form t/second "." 

rejoin [form-date dt "%C%y-%m-%d-%H:%M:%S" head change/part ".000000" 
t length? t]

I think I'll bug Chris to add %P for precise padded seconds.  :)

and of course   head change/part COPY ".000000" ... if you reuse 
the sequence...It'd be nice to be able to just use form-date now/precise 
"%C%y-%m-%d-%H:%M:%P"

REBOL []

do %include.r
include %file-list.r


flash-wnd: flash "Finding test files..."

if file: request-file/only [
    files: read first split-path file
]
if none? file [halt]

items: collect/only item [
    foreach file files [item: reduce [file none]]
]

unview/only flash-wnd



;-------------------------------------------------------------------------------
;-- Generic functions

call*: func [cmd] [
    either find first :call /show [call/show cmd] [call cmd]
]

change-each: func [
    [throw]

    "Change each value in the series by applying a function to it"

    'word   [word!] "Word or block of words to set each time (will be 
    local)"
    series  [series!] "The series to traverse"

    body    [block!] "Block to evaluate. Return value to change current 
    item to."
    /local do-body
][
    do-body: func reduce [[throw] word] body
    forall series [change/only series do-body series/1]

    ; The newer FORALL doesn't return the series at the tail like the 
    old one

    ; did, but it will return the result of the block, which is CHANGE's 
    result,
    ; so we need to explicitly return the series here.
    series
]

collect: func [
    "Collects block evaluations." [throw]
    'word
    block [block!] "Block to evaluate."
    /into dest [block!] "Where to append results"
    /only "Insert series results as series"

    /local fn code marker at-marker? marker* mark replace-marker rules
][
    block: copy/deep block
    dest: any [dest make block! []]

    fn: func [val] compose [(pick [insert insert/only] not only) tail 
    dest get/any 'val

        get/any 'val
    ]
    code: 'fn
    marker: to set-word! word
    at-marker?: does [mark/1 = marker]
    replace-marker: does [change/part mark code 1]
    marker*: [mark: set-word! (if at-marker? [replace-marker])]
    parse block rules: [any [marker* | into rules | skip]]
    do block
    head :dest
]

edit-file: func [file] [
    ;print mold file

    call* join "notepad.exe " to-local-file file ;join test-file-dir 
    file
]

flatten: func [block [any-block!]][
    parse block [

        any [block: any-block! (change/part block first block 1) :block | 
        skip]
    ]
    head block
]

logic-to-words: func [block] [

    change-each val block [either logic? val [to word! form val] [:val]]
]

standardize: func [

    "Make sure a block contains standard key-value pairs, using a template 
    block"
    block    [block!] "Block to standardize"
    template [block!] "Key value template pairs"
][
    foreach [key val] template [
        if not found? find/skip block key 2 [
            repend block [key val]
        ]
    ]
]

tally: func [

    "Counts values in the series; returns a block of [value count] sub-blocks."
    series [series!]
    /local result blk
][
    result: make block! length? unique series

    foreach value unique series [repend result [value reduce [value 0]]]
    foreach value series [
        blk: first next find/skip result value 2
        blk/2: blk/2 + 1
    ]
    extract next result 2
]


;-------------------------------------------------------------------------------

counts: none

refresh: has [i] [
    reset-counts
    i: 0
    foreach item items [
        i: i + 1
        set-status reform ["Testing" mold item/1]
        item/2: random/only reduce [true false]
        show main-lst
        set-face f-prog i / length? items
        wait .25
    ]
    update-counts
    set-status mold counts
]

reset-counts: does [counts: copy [total 0 passed 0 failed 0]]

set-status: func [value] [set-face status form value]

update-counts: has [pass-fail] [
    counts/total: length? items

    pass-fail: logic-to-words flatten tally collect res [foreach item 
    items [res: item/2]]
    ;result (e.g.): [true 2012 false 232]
    standardize pass-fail [true 0 false 0]
    counts/passed: pass-fail/true
    counts/failed: pass-fail/false
]

;---------------------------------------------------------------


main-lst: sld: ; The list and slider faces
c-1:           ; A face we use for some sizing calculations
    none
ml-cnt:        ; Used to track the result list slider value.
visible-rows:  ; How many result items are visible at one time.
    0

lay: layout [
    origin 5x5
    space 1x0
    across

    style col-hdr text 100 center black mint - 20

    text 600 navy bold {

        This is a sample using file-list and updating progress as files are
        processed. 
    }
    return
    pad 0x10

    col-hdr "Result"  col-hdr 400 "File" col-hdr 100
    return
    pad -2x0

    ; The first block for a LIST specifies the sub-layout of a "row",

    ; which can be any valid layout, not just a simple "line" of data.

    ; The SUPPLY block for a list is the code that gets called to display

    ; data, in this case as the list is scrolled. Here COUNT tells us

    ; which ~visible~ row data is being requested for. We add that to 
    the

    ; offset (ML-CNT) set as the slider is moved. INDEX tells us which
    ; ~face~ in the sub-layout the data is going to.

    ; COUNT is defined in the list style itself, as a local variable 
    in
    ; the 'pane function.
    main-lst: list 607x300 [
        across space 1x0 origin 0x0
        style cell text 100x20 black mint + 25 center middle
        c-1: cell  cell 400 left   cell [edit-file item/1]
    ] supply [
        count: count + ml-cnt
        item: pick items count
        face/text: either item [
            switch index [
                1 [

                    face/color: switch item/2 reduce [none [gray] false [red] true [green]]
                    item/2
                ]
                2 [mold item/1]
                3 ["Edit"]
            ]
        ] [none]
    ]

    sld: scroller 16x298 [ ; use SLIDER for older versions of View

        if ml-cnt <> (val: to-integer value * subtract length? items visible-rows) 
        [
            ml-cnt: val
            show main-lst
        ]
    ]
    return
    pad 0x20
    f-prog: progress 600x16
    return
    status: text 500 return
    button 200 "Run" [refresh  show lay]
    pad 200
    button "Quit" #"^q" [quit]
]

visible-rows: to integer! (main-lst/size/y / c-1/size/y)

either visible-rows >= length? items [
    sld/step: 0
    sld/redrag 1
][
    sld/step: 1 / ((length? items) - visible-rows)
    sld/redrag (max 1 visible-rows) / length? items
]

view lay

Something like this? (it's not parse based though)

    flatten: func [block] [
        head forall block [
            if block? block/1 [change/part block block/1 1]
        ]
    ]

s: "Hello cè World" 
es: charset[#"e" #"è"#"è"#"ê"#"i"#"î" #"y"]

parse/all s [ to "c" p: skip es p2: ( p: change/part p "s" p2 ) :p 
]
? s

questions: 
-long string? then better copy instead of change/part
-more patterns in same path, then not 'to.

parse/all data [any [to "*" a: skip b: to "*" c: skip d: :a (change/part 
a rejoin ["<strong>" copy/part b c "</strong>"] d)] to end]

markup-chars: charset "*~"
non-markup: complement markup-chars
tag1: ["*" "<strong>" "~" "<i>"]
tag2: ["*" "</strong>" "~" "</i>"]
parse/all data [
    any non-markup
    any [

        ["*" a: skip b: to "*" c: skip d: | "~" a: skip b: to "~" c: skip 
        d: ] :a (
            change/part a rejoin [
                select tag1 copy/part a b
                copy/part b c
                select tag2 copy/part c d
            ] d
        ) any non-markup
    ]
    to end
]

w: complement charset "*"
rule: [	
	to "*" here: "*"
	opt[ 
		copy item some w "*" there:
		(change/part :here join "" [<strong> item </strong>] :there)
	]
]
parse/all str [some rule]

OK, I tried this: parse "abc" [to "bc" a: "bc" (change/part a "b" 
2)]

It returns true on View 1.3 and Core 2.6, but false on View 1.2 and 
Core 2.5.0.

Here's a simplified version of my example that can handle multiple 
instances of multiple markup types and be adapted to different end 
tags (thanks Tomc for the idea!):

markup-chars: charset "*~"
non-markup: complement markup-chars
tag1: ["*" "<strong>" "~" "<i>"]
tag2: ["*" "</strong>" "~" "</i>"]
parse/all data [
    any non-markup
    any [

        ; This next block can be generated if you have many markup types...

        [a: copy b "*" copy c to "*" copy d "*" e: | a: copy b "~" copy c 
        to "~" copy d "~" e: ]
        :a (change/part a rejoin [tag1/:b c tag2/:d] e)
        any non-markup
    ]
    to end
]

Here's what I have right now:

		markup-chars: charset "*_@"
		non-markup: complement markup-chars
		inline-tags: [
			"*" "strong"
			"_" "em"
			"@" "code"
		]

		markup-rule: [
			any non-markup
			any [
				[ a: "*" b: to "*" c: skip d: |
				  a: "_" b: to "_" c: skip d: | 
				  a: "@" b: to "@" c: skip d: ] :a (
					change/part a rejoin [ 
						"<" select inline-tags copy/part a b ">"
						copy/part b c 
						"</" select inline-tags copy/part a b ">"
					] d
				) any non-markup
			]
			to end
		]
		parse text markup-rule

okay, here's a slightly tweaked version that uses a multichar markup 
tag:

        markup-chars: charset "[*_-:---]"
        non-markup: complement markup-chars
        inline-tags: [
            "*" "strong"
            "_" "em"
            "@" "code"
            "--" "small"
        ]

        markup-rule: [
            any non-markup
            any [
                [ a: "*" b: to "*" c: skip d: |
                  a: "_" b: to "_" c: skip d: | 
                  a: "@" b: to "@" c: skip d: |
                  a: "--" b: to "--" c: skip skip d: ] :a (
                    change/part a rejoin [ 
                        "<" select inline-tags copy/part a b ">"
                        copy/part b c 
                        "</" select inline-tags copy/part a b ">"
                    ] d
                ) any non-markup | skip
            ]
            to end
        ]
        parse/all text markup-rule

capitals: charset ["#"A" - #"Z"]
alpha: charset ["#"A" - #"Z" #"a" - #"z"]
non-alpha: complement alpha
parse/all/case [any non-alpha any [
    a: 5 capitals any capitals b: non-alpha (

        b: change/part a rejoin ["<strong>" copy/part a b "</strong>"] b
    ) :b |
    some alpha any non-alpha
] to end]

; A few fixes
capitals: charset ["#"A" - #"Z"]
alpha: charset ["#"A" - #"Z" #"a" - #"z"]
non-alpha: complement alpha
parse/all/case [any non-alpha any [
    a: 5 capitals any capitals b: [non-alpha | end] (

        b: change/part a rejoin ["<strong>" copy/part a b "</strong>"] b
    ) :b |
    some alpha any non-alpha
] to end]

; Sorry, more fixes
capitals: charset ["#"A" - #"Z"]
alpha: charset ["#"A" - #"Z" #"a" - #"z"]
non-alpha: complement alpha
parse/all/case [any [

    any non-alpha a: 5 capitals any capitals b: [non-alpha | end] (

        b: change/part a rejoin ["<strong>" copy/part a b "</strong>"] b
    ) :b |
    some alpha
] to end]

; Sorry, more fixes
capitals: charset [#"A" - #"Z"]
alpha: charset [#"A" - #"Z" #"a" - #"z"]
non-alpha: complement alpha
parse/all/case [any [to alpha [
    a: 5 capitals any capitals b: [non-alpha | end] (

        b: change/part a rejoin ["<strong>" copy/part a b "</strong>"] b
    ) :b |
    some alpha
]] to end]

Trying to do some macro expansion in text ...

This is not working :(

expand-macros: func [tmp [string!] macros [block!]
	/local white-rule rule len lexp
] [
	white-rule: charset [#" " #"^/"]
	foreach [macro expansion] macros [
        len: length? macro
		lexp: length? expansion
		rule:  compose/deep copy [

            [ to here: white-rule (macro) white-rule ( change/part here expansion 
            len  ?? macro) lexp skip ]
            to end
        ]
		parse/all tmp [some [rule]]
	]
	tmp
]

expand-macros: func [data [string!] macros [block!]
	/local whitespace macro-rule macro here there
] compose [
	whitespace: (charset " ^/")
    macro-rule: make block! length? macros
	foreach [macro expansion] macros [
        macro-rule: insert insert macro-rule macro '|
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [
        here: copy macro macro-rule there: [whitespace | end] (

            there: change/part here select/skip macros macro 2 there
        ) :there |
        skip
    ]]
    macro-rule: none
    data
]

expand-macros: func [data [string!] macros [block!]
    /local whitespace macro-rule macro here there
] compose [
    whitespace: (charset " ^/")
    macro-rule: make block! length? macros
    foreach [macro expansion] macros [
        macro-rule: insert insert macro-rule macro '|
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [
        here: copy macro macro-rule there: [whitespace | end] (

            there: change/part here select/skip macros macro 2 there
        ) :there |
        skip
    ]]
    macro-rule: none
    data
]

expand-macros: func [data [string!] macros [block!]
    /local whitespace macro-rule macro expansion here there
] compose [
    whitespace: (charset " ^/")
    macro-rule: make block! 2.5 * length? macros
    foreach [macro expansion] macros [
        macro-rule: insert macro-rule
            compose [here: (macro) there: [whitespace | end] '|]
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [
        macro-rule (
            macro: copy/part here there

            there: change/part here select/skip macros macro 2 there
        ) :there |
        skip
    ]]
    macro-rule: none
    data
]

expand-macros: func [data [string!] macros [block!]
    /local whitespace macro-rule macro expansion here there
] compose [
    whitespace: (charset " ^/")
    macro-rule: make block! 2.5 * length? macros
    foreach [macro expansion] macros [
        macro-rule: insert macro-rule
            compose [here: (macro) there: [whitespace | end] |]
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [
        macro-rule (
            macro: copy/part here there

            there: change/part here select/skip macros macro 2 there
        ) :there |
        skip
    ]]
    macro-rule: none
    data
]

expand-macros: func [data [string!] macros [block!]
    /local whitespace macro-rule macro expansion here there
] compose [
    whitespace: (charset " ^/")
    macro-rule: make block! 2.5 * length? macros
    foreach [macro expansion] macros [
        macro-rule: insert macro-rule
            compose [here: (macro) there: [whitespace | end] |]
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [
        macro-rule (
            macro: copy/part here there

            there: change/part here select/skip macros macro 2 there
        ) :there |
        thru whitespace
    ] to end]
    macro-rule: none
    data
]

; Now whitespace is dealt with
expand-macros: func [data [string!] macros [block!]
    /local whitespace macro-rule macro expansion here there
] compose [
    whitespace: (charset " ^/")
    macro-rule: make block! 2.5 * length? macros
    foreach [macro expansion] macros [
        macro-rule: insert macro-rule
            compose [here: (macro) there: [whitespace | end] |]
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [any whitespace [
        macro-rule (
            macro: copy/part here there

            there: change/part here select/skip macros macro 2 there
        ) :there |
        to whitespace
    ]] to end]
    macro-rule: none
    data
]

expand-macros: func [data [string!] macros [block!]
    /local ws non-ws macro-rule macro expansion here there
] compose [
    ws: (charset " ^/") non-ws: (complement charset " ^/")
    macro-rule: make block! 2.5 * length? macros
    foreach [macro expansion] macros [
        macro-rule: insert macro-rule
            compose [here: (macro) there: [ws | end] |]
    ]
    macro-rule: head remove back macro-rule
    parse/all data [some [any ws [
        macro-rule (
            macro: copy/part here there

            there: change/part here select/skip macros macro 2 there
        ) :there |
        some non-ws
    ]] to end]
    macro-rule: none
    data
]

string: "<good tag><bad tag><other tag><good tag>"
entity: "<ENTITY>"
parse/all string [
	any [
		to "<" start: skip
		to ">" end: skip 
		(if not find copy/part start end "good tag" [
			change/part start entity 1

   ; fix up END (for when your entity is other than a 1-character long 
   string)
			end: skip end (length? entity) - 1
			change/part end entity 1
			; fix up END again
			end: skip end (length? entity) - 1
		])
		:end skip
	]
	to end
]
string

;== {<good tag><ENTITY>bad tag<ENTITY><ENTITY>other tag<ENTITY><good 
tag>}

string: "<good tag><bad tag> 3 > 5 <other tag><good tag with something 
inside>"

string: " > >> < <<good tag><bad tag> 3 > 5 <other tag><good tag 
etc> >> > "

; (1) search for end tags >, they are erroneous so replace them

; (2) search for start tags <, if there is more than one, replace 
all except the last one

; (3) search for end tag >, check tag body and replace if necessary

entity: "&entity;"
ntag: complement charset "<>" ; non tag
parse/all result: copy string [
	any [
		; (1)
		any [
			any ntag start: ">" end: (

    change/part start entity 1 end: skip start length? entity  ;print 
    [1 index? start]
			) 
			:end
		]
	
		; (2)
		(start: none stop?: none)
		any [
			any ntag start: "<" end:   ;(print [2 mold start])
			any ntag "<" (  ;print "found a second start tag"

    change/part start entity 1 end: skip start length? entity  ;(print 
    [2.1 mold copy/part start end]) 
				start: none
			) :end
		]
		(if none? start [stop?: 'break]) stop?
		
		; ok, we found at least one start tag
		;(print ["OK we found at least one start tag" mold start])
		:start skip
		
		; (3)
		any ntag end: ">"   ;(print [3 mold copy/part start end])
		(if not find copy/part start end "good tag" [
			;print ["found a bad tag" mold copy/part start end]
			change/part start entity 1

   ; fix up END (for when your entity is other than a 1-character long 
   string)
			end: skip end (length? entity) - 1
			change/part end entity 1
			; fix up END again
			end: skip end (length? entity) - 1
		])
		:end skip
	]
	to end
]
result

but, in R2,  I'm not using it for some reason I don't remember... 
I actually use the change/part within a paren and manually set the 
series using the :here trick.

convert-input: func[input [string!] /local stops rest opened-tags 
b e][
	probe input
	
	space: charset " ^-"
	stops: charset "-+^/"
	rest:  complement stops
	opened-li?: false

	parse/all input [
		some [

   () ;<-- to be able escape from the parse loop if there is any infinite 
   loop
			b: #"^/" e: (
				if opened-li? [
					e: change/part b "</li>^/" 1
					opened-li?: false
				]
			) 
			:e
			b: [
				#"-" any space e: (
					e: change/part b {<li class="minus">} e
					opened-li?: true
				)
				|
				#"+" any space e: (
					e: change/part b {<li class="plus">} e
					opened-li?: true
				)
			] :e
			| to #"^/"
			| end
		]
	]
	if opened-li? [
		append input "</li>"
	]
	input
]

probe convert-input {
- line 1
+ line 2
+ line 3
- line 4
+ line 5}

Assuming SRC: contains the source text, it seems to work too:

header-char: complement charset "^/:"
EOL2: rejoin [newline newline]
parse/all src [
	some [
		some [pos: #" " (change pos #"-") | header-char]
		#":" pos: newline (change/part pos " {" 1)
		[to EOL2 | to end] pos: (change pos "} ") skip skip
	]
]
probe construct to block! src

Right, i added skiping of useless newline.

parse/all src [
	some [
		any newline
		some [pos: #" " (change pos #"-") | header-char]
		#":" pos: newline (change/part pos " {" 1)
		[to EOL2 | to end] pos: (change pos "} ") skip skip
	]
]

Could you figure it ?

it's a change/part which is performed

But change/part just tells you, how many chars you replace, no? mmnt

>> change/part s: "(1)" "(2222222)"  4 s
== "(2222222)"

it's not behaving the same way, if it was the same, we would not 
have this difference:

>> parse s: "(1)." [change "(1)" "(11)"] ?? s
s: "(11)."

>> head change "(1)." "(11)"
== "(11)"

In parse it's a change/part that is performed

>> head change/part "(1)." "(11)" 3
== "(11)."

yep a change/part not a simple change

You are right, it is most probably a bug:

>> head change/part "(1)" "()" 3
== "()"

>> parse s: "(1)" [change "(1)" "()"] s
== "())"

Actually, Steeve, the behavior of parse's change does have to do 
with the behavior of change in normal code. That would be an error 
if the CHANGE/part function had that same behavior. It's a bug.

Another:

>> out: parse "this-is-a-string" "-"
>> forall out [change/part out rejoin [out/1 "-" out/2] 2]
>> out
== ["this-is" "a-string"]

Classical...
ending: (ending: change/part start "mystring" ending) :ending

Now, I can make a bold statement: for any method distinct from the 
one using PARSE and CHANGE/PART combo holds, that it is faster than 
the above method, until it's not :-p

its not a single change/part which is the issue, its managing the 
stack, allocating all those blocks over and over... the sheer speed 
of the parse loop, blows away all the other looped/recursive algorythms 
in my usage so far.

And here I thought yesterday, wow I finally understood Parse and 
gosh it's awesome. And now I read change/part, which I used, is not 
the way to do things unless it is. I am confused! Generally, but 
also now specifically.

I think change/part is as fast as Rebol's change/part native, and 
hence usable, unless Ladislav proves such pov being somehow fundamentally 
wrong :-)

Of course that has other semantics than

>> head change/part "abc" take/part "123" 2 1
== "12bc"

and may lead to new confusion.

it's true, 'change/part does not behave correctly by default.

insert/part et append/part do the right thing we want now for change

That's said too much; I think it's more that CHANGE/PART behaves 
as advertised and the /PART refinement just happens to have a different 
meaning for INSERT or APPEND. 

Neither one of /WITH, /TO, /SPAN and /RANGE communicate very well 
that they refer to the second argument though, and /TAKE has the 
drawback of suggesting that it's taking away from the second argument 
like TAKE instead of leaving the second argument untouched. 

CHANGE/FROM, however, seems to work:

>> head change/from #abcdef #123456 3
== #123def
>> head change/part/from #abcdef #12345 1 3
== #123bcdef 


All that under the assumption that for compatibility, /PART in it's 
current meaning will stay as it is.

It's funny, I always thought INSERT/part was the weird one, and CHANGE/part 
the normal one. Didn't stop me from adding /part to APPEND though, 
in the INSERT style.

Gregg, I used to use append/part to avoid the memory overhead of 
copy/part in many case.
Instead of doing like in the Ladislav's example. 
>> change/part something copy/part something-else range part.
I used  to do.

>> change/part something append/part clear #{} something-else range 
part.
It's not faster, but saves memory.


So, I don't know if it's a good idea to discard this use case from 
append and insert.

prebol: func [code "changes code" /local p f] [
	parse code rule: [
		any [
			p: #include set f file! (
				p: change/part p load f 2
			) :p
			| into rule
			| skip
		]
	]
	code
]
; changes code, use copy/deep if needed

t1: now/precise
save %test.r [The embedded stuff]
p: prebol [Hello [World #include %test.r here] we are ]
print[difference now/precise t1]

prebol: func [code /local p f rule] [
	if file? code [code: load code]
	parse code rule: [
		any [
			p: #include set f file! (
				p: change/part p prebol load f 2
			) :p
			| into rule
			| skip
		]
	]
	code
]
; changes code, use copy/deep if needed

t1: now/precise
save %test.r [The embedded and #include %test2.r stuff]
save %test2.r [Subembedded]
p: prebol probe [Hello [World #include %test.r here] we are]
print [difference now/precise t1 newline mold p]

make the string without numbers, put the numbers in. with 'at, 'change/part 
ruler num length? num.

this prevents the copy... 

change/part s at s 5 2

Change/part for the n-th time. Did anybody expect this?

>> tgt: "123456789"
== "123456789"

>> src: at tgt 5
== "56789"

>> change/part tgt src 1
== "23456789"

>> tgt
== "5678923456789"

Change/part can be fast, especially if you what you are changing 
to is the same length.

First impression:
- Yay! setw/getw, rotl/rotr, bswap, change = change/part, brab 

- I hadn't thought of those, but cool: ext8/ext16, break now breakt/breakf, 
making rebcode* now a field in system/internal

- Questions: Haven't done the grand renaming yet? Rewrite getting 
rewritten? Does brab work yet (it crashed for me)?

Replace the column-text block in the SQL function with:

	[(
		either direct [
			[*column-text (sid) idx]
		][
			[
				s: v: *column-text (sid) idx
				while [s: find s {""}] [change/part s "" 2]
				load v
			]
		]
	)]

I've added this to the next build.

A little update from Alpha testing. Since last time, this happened:

- POWER can now handle negative number and exponent

- Some bugs fixed regarding: money!, path, VID crash, change/part, 
read, function and closure recursion crash, compose/deep
- New dictionary! datatype (replacing hash!)
- A lot is going on in the graphics, VID and DRAW groups
- Ongoing work to get the test methods to perfection

We're now on Alpha 49.

i make a proposal:

Most of the times, we use the same rules several times on different 
data.
reword should be able to not reconstruct the rules if so.

I used the similiar tricks in some scripts, for example:

map-chars: func [
	{replace/all pair chars in a string}
	data [string!] values [block!]
	/local chars pos
][

 ;** if the first value in values is a bitset, do not reconstruct 
 the bitset
	unless bitset? chars: first values [
		chars: make bitset! 256
		forskip array 2 [append chars array/1]
		insert values chars
	]
	pos: data
	values: next values

 while [pos: find pos chars][pos: change/part pos select/skip values 
 first pos 2 1]
	data
]

data: "Hello You"
map-chars copy data values: [#"s" "SS" #"t" #"T"] 
;** the second call is faster
map-chars copy data values

load: func [
	{Loads a file, URL, or string.}

 source [file! url! string! binary! block!] {Source or block of sources}

 /header  {Includes REBOL header object if present. Preempts /all.}

 /next    {Load the next value only. Return block with value and new 
 position.}

;	/library {Force file to be a dynamic library. (Command version)}
;	/markup  {Convert HTML and XML to a block of tags and strings.}
	/all     {Load all values. Does not evaluate REBOL header.}
	/unbound {Do not bind the block.}
	/local data content val rst tmp

][  ; Note: Avoid use of ALL and NEXT funcs, because of /all and 
/next options
	content: val: rst: tmp: none ; In case people call LOAD/local
	
	; Retrieve the script data
	data: case [
		block? source [ ; Load all in block
			return map x source [apply :load [:x header next all unbound]]
		]
		string? source [source] ; Will convert to binary! later
		binary? source [source]
		; Otherwise source is file or url
		'else [
			; See if a codec exists for this file type
			tmp: find find system/catalog/file-types suffix? source word!
			; Get the data, script required if /header
			content: read source  ; Must be a value, not unset
			case [
				binary? :content [content] ; Assumed script or decodable
				string? :content [content] ; Assumed script or decodable
				header [cause-error 'syntax 'no-header source]
				block? :content [content]
				'else [content: reduce [:content]]
			] ; Don't LOAD/header non-script data from urls and files.

  ] ; content is data if content doesn't need copying, or none if it 
  does
	]
	;print [1 "data type?" type? :data 'content true? :content]
	if string? :data [data: to-binary data] ; REBOL script is UTF-8

 assert/type [data [binary! block!] content [binary! string! block! 
 none!]]
	assert [any [binary? :data not header]]
	if tmp [ ; Use a codec if found earlier
		set/any 'data decode first tmp :data

  ; See if we can shortcut return the value, or fake a script if we 
  can't
		case [

   block? :data [if header [insert data val: make system/standard/script 
   []]]

   header [data: reduce [val: make system/standard/script [] :data]]

   (to logic! unbound) and not next [return :data] ; Shortcut return

   any [next any-block? :data any-word? :data] [data: reduce [:data]]
			'else [return :data] ; No binding needed, shortcut return
		]
		assert/type [data block!] ; If we get this far
	]
	;print [2 'data mold to-string :data]
	
	if binary? :data [ ; It's a script
		unless find [0 8] tmp: utf? data [ ; Not UTF-8
			cause-error 'script 'no-decode ajoin ["UTF-" abs tmp]
		]
		; Process the header if necessary
		either any [header not all] [
			if tmp: script? data [data: tmp] ; Load script data
			; Check for a REBOL header
			set/any [val rst] transcode/only data
			unless case [
				:val = [rebol] [ ; Possible script-in-a-block
					set/any [val rst] transcode/next/error rst
					if block? :val [ ; Is script-in-a-block
						data: first transcode/next data
						rst: skip data 2
					] ; If true, val is header spec
				]
				:val = 'rebol [ ; Possible REBOL header
					set/any [val rst] transcode/next/error rst
					block? :val ; If true, val is header spec
				]
			] [ ; No REBOL header, use default
				val: [] rst: data
			]
			; val is the header spec block, rst the position afterwards

   assert/type [val block! rst [binary! block!] data [binary! block!]]
			assert [same? head data head rst]
			; Make the header object

   either val: attempt [construct/with :val system/standard/script] 
   [
				if (select val 'content) = true [
					val/content: any [:content copy source]
				]
			] [cause-error 'syntax 'no-header data]
			; val is correct header object! here, or you don't get here
			; Convert the rest of the data if necessary and not /next
			unless any [next block? data] [data: rst: to block! rst]
			if block? data [ ; Script-in-a-block or not /next
				case [

     header [change/part data val rst] ; Replace the header with the object

     not all [remove/part data rst]	; Remove the header from the data
				]
				rst: none ; Determined later
			]
		] [rst: data] ; /all and not /header
	]

 ; val is the header object or none, rst is the binary position after 
 or none

 assert/type [val [object! none!] rst [binary! none!] data [binary! 
 block!]]

 assert [any [none? rst same? head data head rst] any [val not header]]

 ;print [3 'val mold/all :val 'data mold/all :data "type?" type? :data]
	
	; LOAD/next or convert data to block - block either way
	assert [block? data: case [
		not next [ ; Not /next
			unless any [block? data not binary? rst] [data: to block! rst]
			data
		]
		; Otherwise /next

  block? data [reduce pick [[data] [first+ data data]] empty? data]
		header [reduce [val rst]] ; Already transcoded above
		binary? rst [transcode/next rst]
	]]
	
	; Bind to current global context if not a module
	unless any [ ; Note: NOT ANY instead of ALL because of /all
		unbound
		(select val 'type) = 'module
	][
		bind/new data system/contexts/current
	]
	;print [6 'data mold/all :data 'tmp mold/all :tmp]
	
	; If appropriate and possible, return singular data value
	unless any [
		all header next  ; /all /header /next
		empty? data
		1 < length? data
	][set/any 'data first data]
	;print [7 'data mold/all :data]
	
	:data
]

While I have your attention and I'm thinking about sorting I just 
thought I'd mention that I'm using the following work-around for 
the lack of /compare in sort:

; R3 /compare bug work around
sort-compare: func [
	blk
][
	; disorder the rows
	forskip blk 2 [change/part blk reduce [blk/2 blk/1] 2]
	; sort em
	sort/skip/reverse blk 2
	; reorder the rows
	forskip blk 2 [change/part blk reduce [blk/2 blk/1] 2]
	blk
]

I came with something existing, and said: Now, how can i do this 
more rebolish...

parse/case opcode [
	any [
		start: 
		| "nn" end: (change/part start get-byte end)
		| "+d" end: (change/part start get-d end)
		| "e" end: (change/part start get-e end)
		| skip
	]
]

Yet another version, that works with nested blocks:

flatten: func [block] [
	forall block [
		if block! = type? block/1 [
			change/part block block/1 1
		]
	]
	block
]

>> flatten [1 [2 [hmm] 42 3] 4]
== [1 2 hmm 42 3 4]

flatten: func [block [any-block!]] [
        parse block [

            any [block: any-block! (change/part block first block 1) :block | 
            skip]
        ]
        head block
    ]

As parse rules go, it wouldn't be difficult. Try this:
>> hex: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"]
== make bitset! #{000000000000FFC07E0000007E}

>> parse a: "paul%40tretbase.com" [any [to "%" [b: skip copy x 2 
hex (b: change/part b to-char first debase/base x 16 3) :b | skip]]] 
a
== "[paul-:-tretbase-:-com]"

Now that is a modifying method, but it should be easy to adapt that 
to a copying method.

It's a little better if you do this, but still not quite right:

>> a: [[1] 2 [[3] [4]] [[5]]] forall a [change/part a first a 1] 
a
== [1 2 [3] 4 [5]]  ; should be [1 2 [3] [4] [5]]

The WHILE trick above needs the same CHANGE/part (whoops):

>> b: [[1] 2 [[3] [4]] [[5]]] while [not tail? b] [either block? 
first b [b: change/part b first b 1] [++ b]] b: head b
== [1 2 [3] [4] [5]]

>> b: [[1] 2 [[3] [4]] [[5]]] while [not tail? b] [either block? 
first b [change/part b first b 1] [++ b]] b: head b
== [1 2 3 4 5]