REBOL [
    Title: "HOF"
    Date: 16-Nov-2002
    Name: "HOF"
    Version: 1.0.1
    File: %hof.r
    Author: "Jan Skibinski"
    Needs: []
    Purpose: "Higher Order Functions and series manipulators"
    Email: jan.skibinski@sympatico.ca
    Acknowledgments: {
        Version 1.0.0 - The basic set of HOF functions
    }
    library: [
        level: 'advanced 
        platform: none 
        type: 'tool 
        domain: none 
        tested-under: none 
        support: none 
        license: none 
        see-also: none
    ]
]

comment {
    This collection of Higher Order Functions and
    series manipulators mirrors a small subset
    of functions found in the Haskell modules Prelude
    and List.

    I did not however strive to provide the same
    implementation; in contrary, I tried to take
    advantage of Rebol facilities for efficiency reasons.
    While most of the Haskell functions are recursive
    in nature, their Rebol counterparts use imperative
    looping instead.

    However, the spirit of the original design is
    preserved stressing the importance of reusable
    patterns.
    While some of the functions provided here can be
    easily implemented in some alternate ways, other
    functions do not have obvious counterparts in the
    Rebol Core. I hope you will find them useful.

    In addition, I provide alternative implementations
    of several basic Rebol functions, such as OR', AND',
    ANY' and ALL'. The first two are lazy block replacements
    for OR and AND - quite useful in WHILE clauses.
    The other two, based on predicates (a -+ logic)
    are very convenient for scanning the series.

    The following is a list of all the functions provided
    here, with their corresponding patterns. The list
    has been created by a 'summary function from unpublished
    yet version of script %signature.r - a prototype
    type checker for Rebol. Among other things, I use this
    module to test the type checker itself.


------------------------------------------------------------
SUMMARY of script HOF.R
------------------------------------------------------------
.                    ([number] -+ [number] -+ number)
..                   ([ord] -+ [ord])
all'                 ((a -+ logic) -+ [a] -+ logic)
and'                 ([logic] -+ logic)
any'                 ((a -+ logic) -+ [a] -+ logic)
cat                  ([[a]] -+ [a])
cycle                (integer -+ [a] -+ [a])
drop                 (integer -+ [a] -+ [a])
drop-while           ((a -+ logic) -+ [a] -+ [a])
elem                 (series -+ any-type -+ logic)
ensure               ([[logic]] -+ logic)
filter               ((a -+ logic) -+ [a] -+ [a])
foldl                ((a -+ b -+ a) -+ a -+ [b] -+ a)
foldl-2              ((a -+ b -+ c -+ a) -+ a -+ [b] -+ [c] -+ a)
foldl1               ((a -+ a -+ a) -+ [a] -+ a)
foldr                ((a -+ b -+ b) -+ b -+ [a] -+ b)
implies              (logic -+ logic -+ logic)
inner-2              (([a] -+ [b] -+ c) -+ [[a]] -+ [[b]] -+ [[c]])
insert-by            ((a -+ a -+ logic) -+ a -+ [a] -+ [a])
iterate              (integer -+ (a -+ a) -+ a -+ [a])
map                  ((a -+ b) -+ [a] -+ [b])
map-2                ((a -+ b -+ c) -+ [a] -+ [b] -+ [c])
max-block            ([ord] -+ ord)
min-block            ([ord] -+ ord)
or'                  ([logic] -+ logic)
partition            ((a -+ logic) -+ [a] -+ [[a] [a]])
poly                 ([number] -+ number -+ number)
product              ([ring] -+ ring]
remove-by            ((a -+ a -+ logic) -+ a -+ [a] -+ [a])
replicate            (integer -+ a -+ [a])
require              ([[logic]] -+ logic)
scanl                ((a -+ b -+ a) -+ a -+ [b] -+ [a])
span                 ((a -+ logic) -+ [a] -+ [[a] [a]])
sum                  ([ring] -+ ring)
take                 (integer -+ [a] -+ [a])
take-while           ((a -+ logic) -+ [a] -+ [a])
unzip                ([[c]] -+ [[a] [b]])
zip                  ([a] -+ [b] -+ [[a b]])
|      ((number -+ number -+ number) -+ n-ring -+ n-ring -+ n-ring)
}


    map: function [
        {Maps a function (a -+ b) to all elements
        of a series [a] producing series of type [b]
            ((a -+ b) -+ [a] -+ [b])
        }
        [throw]
        f [any-function!]
        blk [series!]
    ][
        result [series!]
    ][
        result: make blk length? blk
        foreach elem blk [
            insert/only tail result f :elem
        ]
        result
    ]


    filter: func [
        {Filter a 'series using a 'selector function.
            ((a -+ logic) -+ [a] -+ [a])
        }
        [throw]
        selector [any-function!] {(a -> logic)}
        series [series!] {[a]}
        /local result [series!]
        pattern ((a -+ logic) -+ [a] -+ [a])
    ][
        result: make :series length? :series
        foreach element :series [
            if selector :element [
                insert/only tail result :element
            ]
        ]
        result
    ]


    foldl: func [
        {Fold left operation:
            ((a -+ b -+ a) -+ a -+ [b] -+ a)
        }
        f [any-function!]
        x [any-type!]
        ys [series!]
        /local result [any-type!]
    ][
        result: x
        while [not tail? ys][
            result: f result first ys
            ys: next ys
        ]
        result
    ]


    sum: func [
        {Sum of all ring components of the block 'xs
            ([ring] -+ ring)
        }
        xs [block!]
    ][
        foldl :+ 0 xs
    ]


    product: func [
        {Product of all ring components of the block 'xs
            ([ring] -+ ring)
        }
        xs [block!]
    ][
        foldl :* 1 xs
    ]


    foldl-2: func [
        {Fold left operation on two series:
            ((a -+ b -+ c -+ a) -+ a -+ [b] -+ [c] -+ a)
        }
        f [any-function!]
        x [any-type!]
        ys [series!]
        zs [series!]
        /local result [any-type!]
    ][
        result: x
        for k 1 min (length? ys) (length? zs) 1 [
            result: f result ys/:k zs/:k
        ]
        result
    ]

    .: func [
        {Scalar product, or dot product of two real 
        vectors 'xs and 'ys
            ([number] -+ [number] -+ number)
        }
        xs [block!]
        ys [block!]
        /local f result [number!]
    ][
        f: func[u x y][u + (x * y)]
        result: foldl-2 :f 0 xs ys
        result
    ]


    map-2: func [
        {Mapping two series via binary function:
            ((a -+ b -+ c) -+ [a] -+ [b] -+ [c])
        }
        f [any-function!]
        xs [series!]
        ys [series!]
        /local size result [block!]
    ][
        size: min (length? xs) (length? ys)
        result: make xs size
        for k 1 size 1 [
            insert/only tail result f xs/:k ys/:k
        ]
        result
    ]


    inner-2: func [
        {Inner generic operation 'f on two matrices:
            (([a] -+ [b] -+ c) -+ [[a]] -+ [[b]] -+ [[c]])
        }
        f [any-function!]
        xs [block!]
        ys [block!]
        /local col result [block!]
    ][
        result: copy []
        for i 1 (length? ys)1 [
            col: copy []
            for k 1 (length? xs) 1 [
                insert/only tail col f xs/:k ys/:i
            ]
            insert/only tail result col
        ]
        result
    ]


    |: func [
        {
        Overloaded binary operation 'f for numbers,
        vectors and matrices, such as addition, subtraction,
        multiplication, linear combination, such as
        (3 * x) + (4 * y); i.e., for those operations 'f
        which have this signature:
            (number -+ number -+ number)
        The signature of the functional '| itself is:
        ((number -+ number -+ number) -+ n-ring -+ n-ring -+ n-ring)
        where
            nring: (number [number] [[number]])
        }
        f [any-function!]
        x
        y
        /local v m
    ][
        v: func [x y][map-2 :f x y]
        m: func [x y][map-2 :v x y]

        either number? x [
            f x y
        ][
            either number? x/1 [
                v x y
            ][
                m x y
            ]
        ]
    ]


    foldr: func [
        {Fold right operation
            ((a -+ b -+ b) -+ b -+ [a] -+ b)
        }
        f [any-function!]
        z [any-type!]
        xs [series!]
        /local result [any-type!]
    ][
        either empty? xs [
            result: z
        ][
            result: f xs/1 (foldr :f z next xs)
        ]
    ]


    foldl1: func [
        {As foldl but with the first alement of the series 'ys
        serving as the starting point. The series ys should
        not be empty.
            (a -+ a -+ a) -+ [a] -+ a)
        }
        f [any-function!]  {a -> a -> a}
        ys [series!]  {[a]}
        /local result [any-type!]
    ][
        require [[not empty? ys]]
        result: foldl :f (first ys) (next ys)
        result
    ]


    cat: func [
        {Concatenates block of blocks
            ([[a]] -+ [a])
        }
        xs [block!] {Block of blocks [[a]]}
        /local result [block!]
    ][
        result: copy []
        foreach k xs [
            insert tail result :k
        ]
        result
    ]

    scanl: func [
        {Scan left operation.
        This is a foldl operation aplied to all prefixes
        of the series ys: [], [y1], [y1 y2], [y1 y2 y3].
        Returns a block of length + 1 with partial results.
            ((a -> b -> a) -> a -> [b] -> [a])
        }
        f [any-function!]  {a -> b -> a}
        x [any-type!] {a}
        ys [series!]  {[b]}
        /local n result [block!] {:: a}
    ][
        n: length? ys
        result: make block! (n + 1)
        for k 0 n 1 [
            result: append result (foldl :f x (copy/part ys :k))
        ]
        result
    ]


    max-block: func [
        {Returns maximum value from a block
            ([a] -> a}
        xs [block!] {[a]}
        /local result [any-type!]
    ][
        result: foldl1 :max xs
        result
    ]

    min-block: func [
        {Returns maximum value from a block
        min-block :: [a] -> a
        }
        xs [block!] {[a]}
        /local result [any-type!]
    ][
        result: foldl1 :min xs
        result
    ]


    poly: func [
        {Evaluates a polynomial represented as block
        of its coefficients 'as, as in:
        as = [a(n-1) a(n-2) ... a0],
        where 'x is a power base.
        result: [a(n-1)*x**(n-1) + ... a1*x**1 + a0*x**0]
            ([number] -+ number -+ number)
        }
        as [block!] {[..a3 a2 a1 a0]}
        x  [number!]
        /local pack result [number!]
    ][
        require [[all' :number? as]]

        pack: func[u v][u * x + v]
        result: foldl :pack 0 as
        result
    ]

    ..: func [
        {Makes a block containing a range of ord! values.
        Format: .. [1 5]   == [1 2 3 4 5]
                .. [1 3 6] == [1 2 5]
                .. [2 2 6] == [2 2 2 2 2 2]
            ([ord] -> [ord])
        }
        [catch throw]
        xs [block!] {either [start end] or [start next end]}
        /local range x1 x2 delta result [block!]
    ][

        range: reduce xs
        throw-on-error [
            x1: range/1
            either range/3 [
                x2: range/3
                delta: (range/2 - x1)
            ][
                x2: range/2
                delta: 1
            ]

            ;result: make block! (x2 - x1) / delta
            result: copy []
            either delta <> 0 [
                for k x1 x2 delta [
                    insert tail result k
                ]
            ][
                loop abs x2 [
                    insert tail result x1
                ]
            ]
            result
        ]
    ]


    take: func [
        {Take first 'n elements from the series 'xs
            (integer -+ [a] -+ [a])
        }
        n [integer!]
        xs [series!]
        /local result [series!]
    ][
        result: copy/part xs n
        result
    ]


    drop: func [
        {Drop first 'n elements from the series 'xs
            (integer -+ [a] -+ [a])
        }
        n [integer!]
        xs [series!]
        /local result [series!]
    ][
        result: copy skip xs n
    ]


    take-while: func [
        {Take successive elements from the series 'xs
        while the predicate 'p is true
            ((a -+ logic) -+ [a] -+ [a])
        }
        p [any-function!]
        xs [series!]
        /local n result [series!]
    ][
        n: 0
        while [and' [(not tail? xs) (p xs/1)]][
            n: n + 1
            xs: next xs
        ]
        xs: head xs
        result: copy/part xs n
        result
    ]


    and': func [
        {True if all block predicates 'ps are true.
        False otherwise. This is lazy 'and, since
        no predicate is evaluated unless needed.
            ([logic] -+ logic)
        }
        ps [block!]
        /local result [logic!]
    ][
        result: not none? all ps
        result
    ]


    or': func [
        {True if any predicate from block 'ps is true.
        False otherwise. This is lazy 'or, since
        no predicate is evaluated unless needed.
            ([logic] -+ logic)
        }
        ps [block!]
        /local result [logic!]
    ][
        result: not none? any ps
        result
    ]


    drop-while: func [
        {Drop successive elements from the series 'xs
        while the predicate 'p is true
            ((a -+ logic) -+ [a] -+ [a])
        }
        p [any-function!]
        xs [series!]
        /local n result [series!]
    ][
        n: 0
        while [and' [(not tail? xs) (p xs/1)]][
            n: n + 1
            xs: next xs
        ]
        xs: head xs
        result: copy skip xs n
        result
    ]


    span: func [
        {Split the series 'xs in two parts,
        'success and 'failure, delineated
        by a first element of 'xs which
        failed to satisfy the predicate 'p.
            ((a -+ logic) -+ [a] -+ ([a],[a]))
        }
        p [any-function!]
        xs [series!]
        /local n result [block!]
    ][
        n: 0
        while [and' [(not tail? xs) (p xs/1)]][
            n: n + 1
            xs: next xs
        ]
        xs: head xs
        result: copy []
        append/only result copy/part xs n
        append/only result copy skip xs n
        result
    ]


    partition: func [
        {Partition the series 'xs in two parts,
        'success and 'failure - according to the
        outcome of application of the predicate 'p
        to all elements of 'xs.
            ((a -+ logic) -+ [a] -> [[a] [a]])
        }
        p [any-function!]
        xs [series!]
        /local us vs result [block!]
    ][
        us: copy []
        vs: copy []
        foreach k xs [
            either p :k [
                insert/only tail us :k
            ][
                insert/only tail vs :k
            ]
        ]
        result: copy []
        append/only result us
        append/only result vs
        result
    ]


    replicate: func [
        {A block with item 'x replicated n times
            (integer -+ a -+ [a])
        }
        n [integer!]
        x [any-type!]
        /local result [block!]
    ][
        result: copy []
        loop n [
            insert/only tail result x
        ]
        result
    ]


    iterate: func [
        {A block with results of 'n iterations
        of application of 'f  to 'x.
            (integer -+ (a -+ a) -+ a -+ [a])
        }
        n [integer!]
        f [any-function!]
        x [any-type!]
        /local u result [block!]
    ][
        u: x
        result: copy []
        if n >= 1 [
            insert tail result u
            loop (n - 1) [
                u: f u
                insert/only tail result u
            ]
        ]
        result
    ]


    cycle: func [
        {A series made of 'n cycles of series 'xs.
            (integer -+ [a] -+ [a])
        }
        n [integer!]
        xs [series!]
        /local result [block!]
    ][
        result: make xs (n * length? xs)
        loop n [
            insert tail result xs
        ]
        result
    ]


    any': func [
        {True if any element of the series 'xs
        satisfies the predicate 'p
            ((a -+ logic) -+ [a] -+ logic)
        }
        p [any-function!]
        xs [series!]
        /local result [logic!]
    ][
        result: or' map :p xs
        result
    ]


    all': func [
        {True if all elements of the series 'xs
        satisfy the predicate 'p
            ((a -+ logic) -+ [a] -+ logic)
        }
        p [any-function!]
        xs [series!]
        /local result [logic!]
    ][
        result: and' map :p xs
        result
    ]


    elem: func [
        {True if a set 'xs includes elem 'x

        }
        xs [series!]
        x [any-type!]
        /local result [logic!]
    ][
        result: not none? find xs x
        result
    ]


    insert-by: func [
        {Insert elem 'z into series xs' according
        to a 'compare rule.
            ((a -+ a -+ logic) -+ a -+ [a] -+ [a])
        }
        compare [any-function!]
        z [any-type!]
        xs [series!]
        /local done?
    ][
        done?: false
        while [not tail? xs][
            if compare z xs/1 [
                insert/only xs z
                done?: true
                break
            ]
            xs: next xs
        ]
        if not done? [
            insert/only xs z
        ]
        xs: head xs
        xs
    ]


    remove-by: func [
        {Remove first element of a series 'xs which
        satisfies the 'compare rule
            ((a -+ a -+ logic) -+ a -+ [a] -+ [a])
        }
        compare [any-function!]
        z [any-type!]
        xs [series!]
    ][
        while [not tail? xs][
            if compare z xs/1 [
                insert/only xs z
                break
            ]
            xs: next xs
        ]
        xs: head xs
        xs
    ]


    zip: func [
        {Zip two series producing a block of pair-blocks
            ([a] -+ [b] -+ [[a b]])
        }
        xs [series!]
        ys [series!]
        /local result [block!]
    ][
        size: min (length? xs) (length? ys)
        result: make block! size
        for i 1 size 1 [
            insert/only tail result reduce [xs/:i ys/:i]
        ]
        result
    ]


    unzip: func [
        {Unzip a block of pair-blocks producing a block of two blocks
            ([[a b]] -+ [[a] [b]])
        }
        zs [block!]
        /local result [block!]
    ][
        size: length? zs
        result: make block! 2
        xs: make block! size
        ys: make block! size
        for i 1 size 1 [
            insert/only tail xs zs/:i/1
            insert/only tail ys zs/:i/2
        ]
        insert/only tail result xs
        insert/only tail result ys
        result
    ]


    intersperse: func [
        {A copy of a series 'xs with a separator 'sep
        inserted between elements of 'xs
            (a -+ [a] -+ [a])
        }
        sep [any-type!]
        xs [series!]
        /local result [series!]
    ][
        result: copy/deep xs
        if (length? result) >= 2 [
            result: next result
            while [not tail? result][
                insert/only result sep
                result: next next result
            ]
            result: head result
        ]
        result
    ]

    require: func [
        {Throws an error if any 'precondition' is violated,
        otherwise returns 'true'. Used for preconditions validation.
            ([[logic]] -+ logic)
        }
        [throw]
        preconditions [block!]
        /local result [logic!]
    ][
        foreach p preconditions [
            if not (do p) [
                throw make error! (join "Violated precondition " (mold p))
            ]
        ]
        result: true
        result
    ]


    ensure: func [
        {Throws an error if any 'postcondition' is violated,
        otherwise returns 'true'. Used for postconditions validation.
            ([[logic]] -+ logic)
        }
        [throw]
        postconditions [block!]
        /local result [logic!]
    ][
        foreach p postconditions [
            if not (do p) [
                throw make error! (join "Violated postcondition " (mold p))
            ]
        ]
        result: true
        result
    ]


    implies: func [
        {True if condition c1 is false, or if c1 and c2 are both true.
        Used to encode this logic:
        if c1 is true then c2 must also be true
            (logic -+ logic -+ logic)
        }
        c1 [logic!]
        c2 [logic!]
        /local result [logic!]
    ][
        result: (c1 and c2) or not c1
        result
    ]


comment {
    Some examples:

        Ranges:
        ..[1 4]
            ; == [1 2 3 4]

        ..[1 3 8]
            ; == [1 3 5 7]  Arithmetical progresion

        ..[1 1 6]
            ; [1 1 1 1 1 1] or constant block if step=0

        cat [..[1 5] ..[100 110 200]]
            ; Combining many ranges

        map :..[[1 5] [10 110 200]]
            ; Mapping range operator to produce block of blocks

        cat map :..[[1 5] [10 110 200]]
            ; then concatenating them (rejoin does not do it well)

        map :to-money ..[1 10]
            ; Converting to money at your leisure

        map :to-string .. [1 10]
            ; or to other objects

        map :log-10 ..[1 10]
            ; or producing logarithmic scales

        foldl :+ 0 [1 2 3 4 5]
            ; Sum of all numbers on the list

        foldl :+ 0 ..[1 5]
            ; Same using range function to define a block

        foldl :* 1 ..[1 10]
            ; Factorial 10

        foldl :subtract 0 [1 2 3 4]
            ; Does not work with, confusion with unary :-

        max-block [1 6 3 7 3]
            ; Picking max numerical values

        min-block [1 6 3 7 3]
            ; or minimum numerical values

        poly ..[1 8] 10
            ; computing polynomials (12345678)

        poly ..[1 9] 0.1
            ; using different bases 9.87654321

        poly [1 4 5 6 8 1] 16
            ; such as hex base (1332865)

        scanl :* 1 [1 2 3 4 5]
            ; list of partial products

        scanl :+ 0 .. [1 20]
            ; list of partial sums

        filter :prime? ..[1 20]
            ; Computing list of prime numbers
            ; == [3 5 7 11 13 17 19]

        filter :prime? (filter :odd? ..[1 20])
            ; A shorter way

        ..[1 1 6]
            ; Constant of six ones [1 1 1 1 1 1]

        scanl :* 1 ..[3 3 6]
            ; Geometrical progression
            ; [1 3 9 27 81 243 729]

        scanl :* 1 ..[2 2 10]
            ; And another one
            ;[1 2 4 8 16 32 64 128 256 512 1024]

        foldl :+ 0 (scanl :* 1 ..[2 2 10])
            ; Sum of geom progression == 2047
    }