Rebol [
Title: "Curry"
Date: 10/12/1999
Version: 2.0.1
File: %curry.r
Author: "Ladislav Mecir"
Email: [EMAIL PROTECTED]
Comment: {
The former version had the following limitations:
1. incompatibility with CATCH and THROW attributes in the argument
function
2. incompatibility with refinements in the argument function
3. incompatibility with literal or fetched arguments in the argument
function
4. incompatibility with argument functions with one of the following
arguments:
SET, DO, APPEND, COPY, F, FORMARGS, ARGS, REDARGS, RESTARGS
5. didn't handle correctly natives and actions
6. didn't handle correctly functions with local variables
7. The argument function's code has been unnecessarily copied
The limitations 4 to 7 are gone now, limitations 1 to 3 are still
valid.
The meaning of the ARGS argument has changed.
ARGS is now an INTEGER! - see below
The error checking is gone for now, but I will add it next time...
}
]
; some helper functions
map: func ["Maps a function to all elements of a block"
f [any-function!] blk [block!] /local result
][
result: make block! length? blk
foreach elem blk [
append/only result f :elem
]
result
]
enum: func ["Creates a block of integers"
from [integer!]
to [integer!]
/local result
] [
result: make block! 1 + to - from
for i from to 1 [
append result i
]
result
]
ao: func [block [block!] value] [
head insert/only tail copy block value
]
ac: func [block1 [series!] block2 [series!]] [
append copy block1 block2
]
toarg: func [i [integer!]] [to-word ac "a" form i]
tga: func [i [integer!]] [to-get-word to-word ac "a" form i]
nargs: func ["The number of the function arguments"
f [any-function!]
] [
result: 0
ptr: first :f
while [not tail? ptr] [
either refinement? first :ptr [ptr: tail ptr] [
result: result + 1
ptr: next ptr
]
]
result
]
; Although strange, it is much needed
apply: func ["Apply a function to it's arguments"
f [any-function!]
blkargs [block!] "Argument values"
/local args
] [
args: map :toarg enum 1 length? blkargs
use args [
args: bind args 'a1
set args blkargs
args: map :to-get-word args
args: bind args 'a1
do ac [f] args
]
]
curry: func ["Create curried functions"
f [any-function!] "Function to be curried"
args [integer!] "Number of the arguments of the result"
] [
func map :toarg enum 1 args ao [
apply func [f args] [
function map :toarg enum args + 1 nargs :f [y] ao [
apply function [f args redargs] [redrest] [
redrest: reduce bind map :tga enum args + 1 nargs :f 'y
apply :f ac redargs redrest
]
] reduce [:f :args reduce bind map :tga enum 1 args 'a1]
]
] reduce [:f :args]
]
curryfirst: func [f [any-function!]] [curry :f 1]
;**********end of %curry.r
f: func [x y] [reduce [x y]]
cfx: curryfirst :f
Examples:
>> f: func [x y] [reduce [x y]]
>> cfx: curryfirst :f
>> cf777: cfx 777
>> cf777 4
== [777 4]
>> cf5: cfx 5
>> cf777 8
== [777 8]
>> cf5 6
== [5 6]
>> curryadd: curryfirst :add
>> ca1: curryadd 1
>> ca2: curryadd 2
>> ca1 1
== 2
>> ca2 1
== 3
>> ca2 3
== 5
>> ca1 4
== 5
>> capp: curryfirst :apply
>> cappt: capp :type?
>> cappt reduce [:odd?]
== action!
>> composition: curry func [f [any-function!] g [any-function!] x] [f g :x]
2
>> cf: composition func [x] [x + 1] func [x] [10 * x]
>> cf 1
== 11
>> mapper: curry :map 1
>> oddm: mapper :odd?
>> oddm [1 2 3 4 5 6]
== [true false true false true false]
