func-tools.red

Red[
    Title: "Various function! related tools"
    Author: "Boleslav Březovský"
    Note: {
For details about these functions, see my articles:

`apply`, `ufc` - http://red.qyz.cz/apply-and-ufcs.html
`dispatcher`   - http://red.qyz.cz/pattern-matching.html
}
]

actions: has [
    "Return block of all actions"
    result
][
    result: []
    if empty? result [
        result: collect [
            foreach word words-of system/words [
                if action? get/any word [keep word]
            ]
        ]
    ]
    result
]

op: func [
    "Defines op! with given spec and body"
    spec [block!]
    body [block!]
][
    make op! func spec body
]

; --- get arity and refinements ------------------------------------------------

arity?: func [
    "Return function's arity" ; TODO: support for lit-word! and get-word! ?
    fn [any-function!]  "Function to examine"
    /local result count name count-rule refinement-rule append-name
][
    result: copy []
    count: 0
    name: none
    append-name: quote (repend result either name [[name count]][[count]]) 
    count-rule: [
        some [
            word! (count: count + 1)
        |   ahead refinement! refinement-rule
        |   skip
        ]
    ] 
    refinement-rule: [
        append-name
        set name refinement!
        (count: 0)
        count-rule
    ]
    parse spec-of :fn count-rule
    do append-name
    either find result /local [
        head remove/part find result /local 2
    ][result]
]

refinements?: func [
    "Return block of refinements for given function"
    fn      [any-function!] "Function to examine"
    /local value
][
    parse spec-of :fn [
        collect [some [set value refinement! keep (to word! value) | skip]]
    ]
]

; --- unified function call syntax ---------------------------------------------

ufcs: func [
    "Apply functions to given series"
    series  [series!]       "Series to manipulate"
    dialect [block!]        "Block of actions and arguments, without first argument (series defined above)"
    /local result action args code arity refs ref-stack refs?
][
    result: none
    code: []
    until [
        ; do some preparation
        clear code
        action: take dialect
        arity: arity? get action
        args: arity/1 - 1
        refs: refinements? get action
        ref-stack: clear []
        refs?: false
        unless zero? args [append ref-stack take dialect]
        ; check for refinements
        while [find refs first dialect][
            refs?: true
            ref: take dialect
            either path? action [
                append action ref 
            ][
                action: make path! reduce [action ref]
            ] 
            unless zero? select arity ref [
                append ref-stack take dialect 
            ]
        ]
        ; put all code together
        append/only code action 
        append/only code series
        unless empty? ref-stack [append code ref-stack]
        series: do code
        empty? dialect
    ]
    series
]

ufc: function [
    "Apply functions to given series"
    data    [series!] "Series to manipulate"
    dialect [block!]  "Block of actions and arguments, without first argument (series defined above)"
][
    foreach [cmd args] dialect [
        data: apply get cmd head insert/only args data
    ]
    data
]

; --- apply function -----------------------------------------------------------

apply: func [
    "Apply a function to a block of arguments"
    fn      [any-function!] "Function value to apply"
    args    [block!]        "Block of arguments (to quote refinement use QUOTE keyword)"
    /local refs vals val
][
    refs: copy []
    vals: copy []
    set-val: [set val skip (append/only vals val)]
    parse args [
        some [
            'quote set-val
        |   set val refinement! (append refs to word! val)
        |   set-val
        ]
    ]
    do compose [(make path! head insert refs 'fn) (vals)]
]

map: func [
	"Apply code over block of values"
	data
	code
	/local f
][
	data: copy data
	f: get take code
	forall data [
		data/1: apply :f compose [(first data) (code)]
	]
	data
]

map-each: func [
    'word
    series
    code
][
    collect [
        until [
            set :word first series
            keep do code
            series: next series
            tail? series
        ]
    ]
]

; --- dispatch function --------------------------------------------------------

dispatcher: func [
	"Return dispatcher function that can be extended with DISPATCH"
	spec [block!] "Function specification"
][
	func spec [
		case []
	]
]

dispatch: func [
	"Add new condition and action to DISPATCHER function"
	dispatcher  [any-function!] "Dispatcher function to use"
	cond		[block! none!]	"Block of conditions to pass or NONE for catch-all condition (forces /RELAX)" 
	body		[block! none!]  "Action to do when condition is fulfilled or NONE for removing rule"
	/relax						"Add condition to end of rules instead of beginning"
	/local this cases mark penultimo
][
	cases: second body-of :dispatcher
    penultimo: back back tail cases
    unless equal? true first penultimo [penultimo: tail cases]
    if cond [bind cond :dispatcher]
    if body [bind body :dispatcher]
	this: compose/deep [all [(cond)] [(body)]]
	case [
        all [not cond not body not empty? penultimo][remove/part penultimo 2]   ; remove catch-all rule (if exists)
        all [not body mark: find/only cases cond][remove/part back mark 3]      ; remove rule (if exists)
        all [not cond true = first penultimo][change/only next penultimo body]  ; change catch-all rule (if exists)
        not cond                            [repend cases [true body]]          ; add catch-all rule
		mark: find/only cases cond 	        [change/part back mark this 3]      ; change existing rule (if exists)
		relax 				    	        [insert penultimo this]             ; add new rule to end
		'default 				            [insert cases this]                 ; add new rule to beginning
	]
	:dispatcher
]

; --- function constructors --------------------------------------------

dfunc: func [
    "Define function with default values for local words"
    spec
    body
][
    ; format for default values is [set-word: value] after /local refinement
    ; it's possible to mix normal words (without default value) and set-words
    local: copy []
    locals: copy #()
    if mark: find spec /local [
        parse next mark [
            some [
                set word set-word!
                set value skip (
                    append local to word! word
                    locals/:word: value
                )
            |   set word word! (append local word)
            ]
        ]
        remove/part mark length? mark
        append spec compose [/local (local)]
        foreach word words-of locals [
            insert body reduce [to set-word! word locals/:word]
        ]
    ]
    func spec body
]

fce: func [
	"The ultimate function constructor" ; right now supports /local only
	spec [block!]
	body [block!]
	/local local-mark locals locs expose? body-rule word length
][
	; get local words defined in function specs
	parse spec [
		any [
			ahead /local local-mark: skip
			copy locals to [refinement! | issue! | end]
		|	remove #expose (expose?: true)
		|	skip
		]
	]
	unless locals [locals: copy []]
	locs: clear []
	; get local words defined in function body using local
	parse body body-rule: [
		some [
			ahead [/local [set-word! | word!]]
			remove skip set word skip (append locs to word! word)
		|	['foreach | 'remove-each] set word [word! | block!] (append locs word)
		|	'repeat set word word! (append locs word)
		|	ahead [block! | paren!] into body-rule
		|	skip
		]
	]
	length: length? locals
	either expose? [
		remove/part local-mark 1 + length
	][
		append locals locs
		locals: unique locals
		either local-mark [
			change/part next local-mark locals length
		][
			append spec head insert locals /local
		]
	]
	func spec body
]