Skip to content

Instantly share code, notes, and snippets.

@greggirwin

greggirwin/inject.red

Last active May 14, 2020 10:59
Show Gist options
  • Save greggirwin/29836d25de0c68eaba0e6dbd268a20f5 to your computer and use it in GitHub Desktop.
Save greggirwin/29836d25de0c68eaba0e6dbd268a20f5 to your computer and use it in GitHub Desktop.
Download ZIP
INJECT func experiment. Alternative to REDUCE or COMPOSE.
Raw
inject.red
Red [
name: 'inject
file: %inject.red
author: "Gregg Irwin"
notes: {
Red version of Ladislav Mecir's R2 `build` func. I can't find his on
the net, to link to, but can post his original if desired. His point
was that `compose` isn't always easy to use, when parens are part of
block you're composing, or how your blocks are structured, whether you
can use `/only` with `compose`. e.g.
Given:
a: [block a]
Wanting:
[[[block a] (f: fail) | (f: none)] f]
Compose:
compose/deep [[(reduce [a]) ([(f: fail) | (f: none)])] f]
Build:
build [[only a (f: fail) | (f: none)] f]
The idea is great, but too often I forget about it. Part of the reason
was that I had my own `build` func, which did something very different.
So I'm reviving it for Red, and thinking about names. It may not be as
important in Red, as we have the `quote` function, which let's you not
compose a given paren. For example:
>> compose/deep [[(reduce [a]) (quote (f: fail)) | (quote (f: none))] f]
== [[[block a] (f: fail) | (f: none)] f]
Still not great.
Possible names, in order of my personal preference:
inject place inset embed inlay sub-in fabricate implant prefab
cut-in introduce incorporate combine blend meld alloy
compound admix fuse intermix integrate synthesize amalgamate
I like `inject` with the caveat that it may appear to deal with
Dependency Injection, or a Smalltalk-like fold func to the uninitiated.
`Inset` is a good word, but very close to `insert`, which is a concern.
Both allow blocks as their first argument, which may make mistakes less
obvious. The other problem with `inject` as a name is that it implies
more that it's changing the series in place, not producing a new one.
Once we have the function name, we also need the keywords. `Build` used
`insert` and `only` which were very clear choices for their behavior.
The escape mechanism was to use `only`.
build [only 'only only 'insert] ; == [only insert]
Those keywords may be common, which is what makes them clear. But it may
also make them hide in plain sight. Also, the expressions are evaluated.
Should we use words that have a clue about that? What about a base
keyword with an `/only` "refinement". Longer though. That rules out using
issue! values...or does it?
>> parse [#insert/only] [#insert /only]
== true
Currently, email! will keep the path part, but a new ref! type may change
things.
>> parse [@/only] [@/only]
== true
Should we have a default, but let them pass in a keyword of their own?
No. At least not in v1.
[@ @/only #-- do get /only do_ get_ /do /get __ __/only]
}
]
admix: function [
"Builds a block, like COMPOSE, but using 'only and 'insert rather than parens."
input [block! paren!]
/local value
][
; TBD: consider copying/deep the input and using parse `change`.
collect/into [
parse :input [ ; use get-word! as input may be a paren!
any [
set op ['insert | 'only] position: (
set/any 'value do/next :position 'position
if value? 'value [
either op = 'only [keep/only :value][keep :value]
]
) :position
| set value [block! | paren!] (keep/only admix :value)
| set value skip (if value? 'value [keep/only :value])
]
]
] make :input length? :input ; so we return a paren if given one
]
inject: function [
"Modifies a block, using 'only and 'insert keywords"
input [block! paren!] "(modified)"
;/local value
][
parse :input rule: [ ; use get-word! as input may be a paren!
any [
;!! Unset results appear in the output using this approach
change ['insert pos: any-type!] (do/next :pos 'pos) :pos
| change only ['only pos: any-type!] (do/next :pos 'pos) :pos
| ahead [block! | paren!] into rule
| skip
]
]
:input
]
inject-x: function [
"Modifies a block, using 'only and 'insert keywords"
input [block! paren!] "(modified)"
/local value
][
parse :input rule: [ ; use get-word! as input may be a paren!
any [
;!! Unset results DO NOT appear in the output using this approach
set op s: ['insert | 'only] pos: (
set/any 'value do/next :pos 'pos
pos: either value? 'value [
either op = 'only [change/only/part s :value 2][change/part s :value 2]
][remove/part s 2]
) :pos
| ahead [block! | paren!] into rule
| skip
]
]
:input
]
e.g.: :comment
e.g. [
a: [block a]
inject [[only a (f: fail) | (f: none)] f] ;== [[[block a] (f: fail) | (f: none)] f]
inject [[insert a (f: fail) | (f: none)] f] ;== [[block a (f: fail) | (f: none)] f]
inject first [([insert a (f: fail) | (f: none)] f)]
inject [only 'only only 'insert]
; paths needn't be escaped
inject [insert/only] ; == [insert/only]
; to escape a whole subblock, i.e. to prevent BUILD to modify it do
inject [only [insert only]] ; == [[insert only]]
; to escape a whole paren! i.e. to forbid BUILD to modify it do
inject [insert [(insert only)]] ; == [(insert only)]
;inject [[#only a (f: fail) | (f: none)] f]
;inject [[#insert a (f: fail) | (f: none)] f]
;
;inject [[#set a (f: fail) | (f: none)] f]
;inject [[#set-only a (f: fail) | (f: none)] f]
;
;inject [[ONLY a (f: fail) | (f: none)] f]
;inject [[/only a (f: fail) | (f: none)] f]
;inject [[INSERT a (f: fail) | (f: none)] f]
;inject [[/insert a (f: fail) | (f: none)] f]
; only> only-> only_>
;inject [[only> a (f: fail) | (f: none)] f]
;inject [[insert> a (f: fail) | (f: none)] f]
]
; Can we make sensical short keywords/markers? The thought here is that we
; already have `inject` as the func name, then we use `insert`, which is
; kind of redundant.
; (insert) #_ #___ #here
; (only) #__ #|_| #._. #only
; Not a real macro approach of course, just uses #keywords to look like one.
inject-mac: function [
"Modifies a block, using #only and #insert keywords"
input [block! paren!] "(modified)"
/any "Insert unset values, rather than omitting them"
/local value
][
;!! Watch all the `any` uses here. There's parse usage and also a refinement
;!! that means we have to use `system/words/any` in action logic.
parse :input rule: [ ; use get-word! as input may be a paren!
any [
;!! Unset results DO NOT appear in the output by default.
;!! You have to use /any to force them in.
set op s: [#insert | #only] pos: (
set/any 'value do/next :pos 'pos
; Check for `/any` refinement here, which forces an `change`.
; If that's not used, unset values cause a `remove`.
pos: either system/words/any [any value? 'value] [
either op = #only [change/only/part s :value 2][change/part s :value 2]
][remove/part s 2]
) :pos
| ahead [block! | paren!] into rule
| skip
]
]
:input
]
e.g.: :comment
e.g. [
a: [block a]
inject-mac [[#only a (f: fail) | (f: none)] f] ;== [[[block a] (f: fail) | (f: none)] f]
inject-mac [[#insert a (f: fail) | (f: none)] f] ;== [[block a (f: fail) | (f: none)] f]
inject-mac [[#insert () (f: fail) | (f: none)] f] ;== [[(f: fail) | (f: none)] f]
inject-mac [[#only () (f: fail) | (f: none)] f] ;== [[(f: fail) | (f: none)] f]
inject-mac/any [[#insert () (f: fail) | (f: none)] f] ;== [[unset block a (f: fail) | (f: none)] f]
inject-mac/any [[#only () (f: fail) | (f: none)] f] ;== [[unset block a (f: fail) | (f: none)] f]
inject-mac first [([#insert a (f: fail) | (f: none)] f)]
inject-mac [#only 'only #only 'insert]
; paths needn't be escaped
inject-mac [insert/only] ; == [insert/only]
; to escape a whole subblock, i.e. to prevent BUILD to modify it do
inject-mac [#only [insert only]] ; == [[insert only]]
; to escape a whole paren! i.e. to forbid BUILD to modify it do
inject-mac [#insert [(insert only)]] ; == [(insert only)]
;inject [[#only a (f: fail) | (f: none)] f]
;inject [[#insert a (f: fail) | (f: none)] f]
;
;inject [[#set a (f: fail) | (f: none)] f]
;inject [[#set-only a (f: fail) | (f: none)] f]
;
;inject [[ONLY a (f: fail) | (f: none)] f]
;inject [[/only a (f: fail) | (f: none)] f]
;inject [[INSERT a (f: fail) | (f: none)] f]
;inject [[/insert a (f: fail) | (f: none)] f]
; only> only-> only_>
;inject [[only> a (f: fail) | (f: none)] f]
;inject [[insert> a (f: fail) | (f: none)] f]
]
@hiiamboris
Copy link

Thanks! build/with is very interesting

@hiiamboris
Copy link

hiiamboris commented May 11, 2020 •
edited
Loading

Here's some deep code construction cases from for-each and map-each. All four variants do the same things. Compose variant is working, everything else is just how I see it - not tested. Tell me what variant is less atrocious ☻

Tip: variant 4 is supposed to be line-oriented (delimited with newline markers)

Compose Ladislav Boris 1 Boris 2 
end-cond: compose either range? [
    length: either integer? series [s][s/x * s/y]
    [index + (ahead - 1) > (length)]
][
    [index + (ahead - 1) > length? s]
]






upd-idx: []
if index-word [
    upd-idx: case [
        set-word? index-word ['where]
        not image? series    ['index]
        'image [ compose [int2pair index (series/size/x)] ]
    ]
    upd-idx: reduce [to set-word! index-word  upd-idx]
]




refill: compose pick [
    [fill-int-range  where index (length)]
    [fill-pair-range where index (series)]
] integer? series



prefix: pick [ old: [] ] filtered?
spec-fill: compose/deep pick [
    [set [(spec)] (prefix) where]
    [   (refill when range?)
        foreach [(spec)] (prefix) where [break]
    ]
] yes = find set-able! type? series








test: []
if filtered? [
    type-check:   [types-match?  old types]
    values-check: [values-match? old values values-mask :val-cmp-op]
    test: compose [
        (type-check   when use-types?)
        (values-check when use-values?)
    ]
    if all [use-types? use-values?] [
        test: compose/deep [all [(test)]]
    ]
    test: compose [unless (test) [continue]]
]









move-idxs: compose [
    ([where: at series] when not range?)
    index: (step) + index
]



advance: does compose/deep [
    while [not (end-cond)] [
        old: where
        (move-idxs)
        (test when filtered?)
        return old
    ]
    none
]



do compose/deep [
    set/any 'r forever [
        if (end-cond) [break/return :r]
        (upd-idx) (spec-fill)
        (move-idxs)
        (test)
        set/any 'r do code
    ]
]

get-pos: compose pick [
    [(index-word)]
    [at series (index-word)]
] set-word? spec/1


call: as path! compose [for-each ('case when case) ('same when same)]






do-code: compose pick [ 
    [ either block? set/any 'r (as paren! code) [r: reduce r][:r] ]
    [ (as paren! code) ]
] eval


do compose/deep pick [
    [
        old-advance: none
        new-advance: does [new: any [r: old-advance  tail series]]
        do-once: func [b [block!]] [do b clear b]
        (call) [(spec)] old: series [
            do-once [old-advance: :advance  advance: :new-advance]
            new: (get-pos)
            unless old =? new [append tgt copy/part old new]
            old: new
            (keep) (do-code)
            old: skip new (size)
        ]
        unless empty? old [append tgt copy old] 
    ]
    [
        (call) [(spec)] old: series [(keep) (do-code)]
    ]
] not drop






end-cond: build/with [
    index + !ahead-1 > !length     ;-- can't use `ins` here!
][
    !ahead-1: ahead - 1
    !length: either range? [
        either integer? s [s][s/x * s/y]
    ][
        [length? s]
    ]
]


upd-idx: build/with [
    :!set-index :!index
][
    !set-index: !index: []
    if index-word [
        !set-index: to set-word! index-word
        !index: case [
            set-word? index-word ['where]
            not image? series ['index]
            'image [build [int2pair index ins series/size/x]]
    ]
]

refill: build/with [
    !fill-range where index !limit
][
    !fill-range: pick [fill-int-range fill-pair-range] integer? series
    !limit: either integer? series [length][series]
]

spec-fill: build/with [
    :?refill
    !set !spec :?prefix where :!break
][
    !spec: spec
    ?refill: either range? [refill][[]]
    ?prefix: pick [old: []] filtered?
    !set: 'set
    !break: []
    if find set-able! type? series [
        !set: 'foreach
        !break: [[break]]
    ]
]

test: either filtered? [
    build/with [
        unless :!test [continue]
    ][
        !test: build/with [
            :!type-check :!values-check
        ][
            !type-check:   pick [
                [types-match?  old types]
                []
            ] use-types?
            !values-check: pick [
                [values-match? old values values-mask :val-cmp-op]
                []
            ] use-values?
        ]
        if all [use-types? use-values?] [
            !test: build [all only !test]
        ]
    ]
][ [] ]

move-idxs: build/with [
    :?where index: !step + index
][
    ?where: pick [[where: at series] []] not range?
    !step: step
]

advance: does build/with [
    while [not ins end-cond] [
        old: where
        ins move-idxs
        ?test
        return old
    ]
    none
][
    ?test: either filtered? [test][[]]
]

do build [
    set/any 'r forever [
        if ins end-cond [break/return :r]
        ins upd-idx ins spec-fill
        ins move-idxs
        ins test
        set/any 'r do code
    ]
]

get-pos: build/with [
    :?at-series ins index-word
][
    ?at-series: pick [[] [at series]] set-word? spec/1
]

call: as path! build/with [
    for-each :?case :?same
][
    ?case: pick [case []] case
    ?same: pick [same []] same
]

do-code: build [
    ins  [either block? set/any 'r] when eval
    only as paren! code
    ins  [[r: reduce r][:r]] when eval
]

do build/with pick [
    [
        old-advance: none
        new-advance: does [new: any [r: old-advance  tail series]]
        do-once: func [b [block!]] [do b clear b]
        !call !spec old: series [
            do-once [old-advance: :advance  advance: :new-advance]
            new: ins get-pos
            unless old =? new [append tgt copy/part old new]
            old: new
            :!keep :!do-code
            old: skip new ins size
        ]
        unless empty? old [append tgt copy old] 
    ]
    [
        !call !spec old: series [:!keep :!do-code]
    ]
] not drop [
    !call: call
    !spec: spec
    !keep: keep
    !do-code: do-code
]

end-cond: build [
    index + !(ahead - 1) >
        range? => !(length: either integer? s [s][s/x * s/y])
               || length? s
]







upd-idx: build [
    index-word =>
        !(to set-word! index-word)
        (set-word? index-word) => where
        || (not image? series) => index
        || int2pair index !(series/size/x)
]






refill: build [     
    (int?: integer? series)
        => fill-int-range  where index !(length)
        => fill-pair-range where index !(series)
]


prefix: [ filtered? => old: ]
spec-fill: [
    range? => @(refill) .
    (find set-able! type? series)
        => set     !(spec) @(prefix) where
        || foreach !(spec) @(prefix) where [break]
]








test: build [
    filtered? =>
        /do (test: [
            use-values? => types-match?  old types .
            use-types?  => values-match? old values values-mask :val-cmp-op
        ])
        unless
        (all [use-types? use-values?])
            => all !(test)
            || @(test) .
        [continue]
]










move-idxs: build [
    (not range?) => where: at series .
    index: !(step) + index
]



advance: does build [
    while [not @(end-cond)] [
        old: where
        @(move-idxs)
        filtered? => @(test) .
        return old
    ]
    none
]



do build [
    set/any 'r forever [
        if @(end-cond) [break/return :r]
        @(upd-idx) @(spec-fill)
        @(move-idxs)
        @(test)
        set/any 'r do code
    ]
]

get-pos: build [
    (not set-word? spec/1) => at series .
    !(index-word)
]


call: as path! build [for-each case => case . same => same]






do-code: build [
    eval => either block? set/any 'r .
            !(as paren! code)
    eval => [r: reduce r][:r] .
]

do build pick [
    [
        old-advance: none
        new-advance: does [new: any [r: old-advance  tail series]]
        do-once: func [b [block!]] [do b clear b]
        !(call) !(spec) old: series [
            do-once [old-advance: :advance  advance: :new-advance]
            new: @(get-pos)
            unless old =? new [append tgt copy/part old new]
            old: new
            @(keep) @(do-code)
            old: skip new !(size)
        ]
        unless empty? old [append tgt copy old] 
    ]
    [
        !(call) !(spec) old: series [@(keep) @(do-code)]
    ]
] not drop






end-cond: build [
    index + !(ahead - 1) >
        !(length)           /if range? /do length: either integer? s [s][s/x * s/y]
        length? s           /if not range?
]







upd-idx: build [                        /if index-word
    !(set-index)                            /do set-index: to set-word! index-word
        where                               /if sw?: set-word? index-word
        index                               /else /if not img?: image? series
        int2pair index !(series/size/x)           /else
]







refill: build [     
    fill-int-range  where index !(length)   /if int?: integer? series
    fill-pair-range where index !(series)   /else
]



prefix: [
    old:                                        /if filtered?
]
spec-fill: [
    @(refill)                                   /if range?
    set     !(spec) @(prefix) where             /if setable?: find set-able! type? series
    foreach !(spec) @(prefix) where [break]     /else
]







test: build [                                           /if filtered?
    /do test: [
        types-match?  old types                             /if use-values?
        values-match? old values values-mask :val-cmp-op    /if use-types?
    ]
    unless
        all !(test)                                         /if all [use-types? use-values?]
        @(test)                                             /else
    [continue]
]












move-idxs: build [
    where: at series            /if not range?
    index: !(step) + index
]



advance: does build [
    while [not @(end-cond)] [
        old: where
        @(move-idxs)
        @(test)             /if filtered?
        return old
    ]
    none
]



do build [
    set/any 'r forever [
        if @(end-cond) [break/return :r]
        @(upd-idx) @(spec-fill)
        @(move-idxs)
        @(test)
        set/any 'r do code
    ]
]

get-pos: build [
    at series           /if not set-word? spec/1
    !(index-word)
]


call: as path! build [
    for-each
        case    /if case
        same    /if same
]


do-code: build [
    either block? set/any 'r        /if eval
    !(as paren! code)
    [r: reduce r][:r]               /if eval
]

do build pick [
    [
        old-advance: none
        new-advance: does [new: any [r: old-advance  tail series]]
        do-once: func [b [block!]] [do b clear b]
        !(call) !(spec) old: series [
            do-once [old-advance: :advance  advance: :new-advance]
            new: @(get-pos)
            unless old =? new [append tgt copy/part old new]
            old: new
            @(keep) @(do-code)
            old: skip new !(size)
        ]
        unless empty? old [append tgt copy old] 
    ]
    [
        !(call) !(spec) old: series [@(keep) @(do-code)]
    ]
] not drop

@greggirwin
Copy link
Author

Have to figure out how to view all of them at once. Horz scrolling in the browser makes comparison painful.

@greggirwin
Copy link
Author

I deeply appreciate the time put into it. 👍

@greggirwin
Copy link
Author

Reading through, without context, the various indirections, and the original use case for the function itself, make it hard to visualize. That is, where are parens being passed through to the result? Having not looked at build/with beyond a glance when Bolek posted, I have to get my head in that space as well. Also have to look up your when func it seems.

@hiiamboris
Copy link

hiiamboris commented May 14, 2020 •
edited
Loading

when: make op! func [value test] [either :test [:value][[]]]
A common thing when including code conditionally. Ideally it shouldn't be used in comparison as makes compose look better than it usually is ;) But I just copy/pasted it from real code.

That is, where are parens being passed through to the result?

This case study is mostly about deeply built code, not a show of how ugly parens become within compose. I'll write a wiki soon, to go with the implementation (I chose 4th).

Horz scrolling in the browser makes comparison painful.

Tip: click on the wheel ;)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment