Script Library: 1221 scripts
 

hof.r

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 }
halt ;; to terminate script if DO'ne from webpage
Notes
  • email address(es) have been munged to protect them from spam harvesters. If you are a Library member, you can log on and view this script without the munging.
  • (jan:skibinski:sympatico:ca)