diff --git a/mapfold/README b/mapfold/README new file mode 100644 index 0000000..28d522f --- /dev/null +++ b/mapfold/README @@ -0,0 +1 @@ +these should be compiled as `red -c -d ...` \ No newline at end of file diff --git a/mapfold/mapfold-mark.red b/mapfold/mapfold-mark.red new file mode 100644 index 0000000..a6a057a --- /dev/null +++ b/mapfold/mapfold-mark.red @@ -0,0 +1,49 @@ +Red [title: "ACCUMULATE simple benchmark"] + +#include %mapfold.red + +rou-add: routine [a [float!] b [float!] return: [float!]] [a + b] +do [ + fun-add: func [a [float!] b [float!]] [a + b] ;-- make it fully interpreted + + any [ + attempt [do %/d/devel/red/common/clock.red] + do https://gitlab.com/hiiamboris/red-mezz-warehouse/-/raw/master/clock.red + ] + + b: append/dup [] 1e-16 n: 1'000'000 + v: make vector! b + + print ["^/Summing" n "floats using internal addition"] + rv: clock/times [accumulate 0.0 v :add] 1000 + print ["result is" rv "(pairwise/vector)"] + + print ["^/Summing" n "floats using native 'add'"] + rb: clock/times [accumulate 0.0 b :add] 100 + print ["result is" rb "(block)"] + + print ["^/Summing" n "floats using routine 'add'"] + rb: clock/times [accumulate 0.0 b :rou-add] 100 + print ["result is" rb "(block)"] + + print ["^/Summing" n "floats using function 'add'"] + rb: clock/times [accumulate 0.0 b :fun-add] 10 + print ["result is" rb "(block)"] + + ; print ["Subtracting" n "floats (no special case)"] + ; rv: clock/times [accumulate 0.0 v :subtract] 100 + ; print ["result is" rv "(normal/vector)"] + + clear b clear v + append/dup b 12345 n ;-- big enough to overflow integer range + v: make vector! b + + print ["^/Summing" n "integers using native add"] + rb: clock/times [accumulate 0.0 b :add] 100 + rv: clock/times [accumulate 0.0 v :add] 100 + print ["result is" rb "(block) =" rv "(pairwise/vector)"] + print ["^/Subtracting" n "ints (no special case)"] + rv: clock/times [accumulate 0.0 v :subtract] 100 + print ["result is" rv "(normal/vector)"] +] + diff --git a/mapfold/mapfold-test.red b/mapfold/mapfold-test.red new file mode 100644 index 0000000..4772f27 --- /dev/null +++ b/mapfold/mapfold-test.red @@ -0,0 +1,276 @@ +Red [title: "MAP/ACCUMULATE manual tests"] + +#include %mapfold.red + +{ +==== BINARY builtin functions that's possible to use with ACCUMULATE: ==== + +to while insert if set AT FIND PICK SKIP SELECT change append MOVE SWAP +checksum ADD SUBTRACT divide MULTIPLY rename write MAKE reflect POWER +REMAINDER AND~ OR~ XOR~ as unless loop forall func function has +switch equal? not-equal? strict-equal? lesser? greater? +lesser-or-equal? greater-or-equal? same? BIND in parse union +INTERSECT DIFFERENCE exclude MAX MIN shift arctangent2 as-pair as-money +extend new-line set-env + < <> % << or = also ** * / // - > MOD <= save +set-quiet set-slot-quiet =? >> offset? >= repend routine find-flag? draw +foreach-face pad alter extract ellipsize-at get-scroller caret-to-offset +offset-to-caret shift-right shift-left shift-logical count-chars +parse-trace MODULO split atan2 == >>> AND XOR is react? overlap? distance? +offset-to-char metrics? red-complete-input + +==== those also defined in mezz-warehouse: ==== + +count with default once maybe anonymize trace pcatch fcatch apply keep-type +composite bind-only upscale by parent-of? face-to-window window-to-face +face-to-screen screen-to-face trace-deep + +==== UNARY builtin functions, that can be used with MAP: ==== + +not remove collect ANY copy quote case back head head? index? LENGTH? next +tail tail? clear random reverse sort TAKE trim uppercase lowercase try catch +browse open create close delete query read update scan load comment throw math +return form mold ALL absolute negate round even? odd? complement last open? +source until forever does DO expand reduce compose GET print prin type? show +context object unique complement? dehex enhex negative? positive? to-hex SINE +COSINE TANGENT ARCSINE ARCCOSINE ARCTANGENT NaN? zero? LOG-2 LOG-10 LOG-e EXP +SQUARE-ROOT construct value? debase enbase to-local-file wait unset new-line? +context? get-env sign? CALL size? compress decompress transcode dir +set-current-dir make-dir view error? quit-return series? map? none? any-block? +any-list? binary? any-string? block? bitset? tag? trap word? url? string? +suffix? SECOND file? object? body-of FIRST third clean-path dir? exists? +normalize-dir empty? dirize CREATE-DIR attempt charset expand-directives +split-path change-dir path-thru load-thru SUM any-word? words-of TO-JSON +LOAD-JSON to-csv load-csv keys-of rejoin ASSERT reactor set-word? +STOP-REACTOR REACT function? spec-of unset? get-word? paren? integer? +any-function? path? op? to-paren TO-RED-FILE class-of SIZE-TEXT hex-to-rgb +tuple? make-face debug-info? handle? link-tabs-to-parent update-font-faces +do-safe event? pair? issue? typeset? datatype? layout image? rtd-layout +TO-LOGIC TO-SET-WORD TO-BLOCK center-face dump-face char? any-object? a-an +help-string routine? to-UTC-date write-clipboard TO-WORD float? ask list-dir +TO-INTEGER probe action? native? refinement? logic? TO-STRING write-stdout +alert ?? fourth fifth values-of email? get-path? hash? lit-path? lit-word? +percent? set-path? time? date? money? ref? vector? any-path? number? immediate? +scalar? all-word? to-bitset to-binary to-char to-email to-file TO-FLOAT +to-get-path to-get-word to-hash to-issue to-lit-path to-lit-word to-map to-none +TO-PAIR to-path to-percent to-refinement to-set-path to-tag to-time to-typeset +to-tuple to-unset to-url TO-IMAGE to-date to-money to-ref eval-set-path +flip-exe-flag do-file exists-thru? read-thru do-thru COS SIN TAN ACOS ASIN ATAN +SQRT to-local-date transcode-trace AVERAGE last? DT single? deep-reactor +register-scheme decode-url encode-url face? insert-event-func remove-event-func +set-focus help ? fetch-help ls ll cd + +==== also those defined in mezz-warehouse: ==== + +import export minmax-of minimum-of maximum-of prettify reshape +collect-set-words catch-a-break catch-continue catch-return pixels-to-units +contrast-with explore units-to-pixels window-of CLOCK clock-each +format-readable exponent-of show-trace stepwise EXPECT show-deep-trace DETAB +ENTAB do-atomic is-face? +} + + +last-result: none +test: func [expr] [ + prin pad mold/only expr 70 + set/any 'last-result do expr + print [" =>" mold/part :last-result 100] + :last-result +] +===: func [expected] [ + unless :last-result == :expected [ + print ["TEST FAILED! Expected:" :expected] + ] +] + + +;-- +;-- ACCUMULATE +;-- + + +test [type? try [accumulate "abc" [#[none] #[none]] 'to]] +=== error! + +test [accumulate 1 make vector! [2% 3% 4%] :add] +=== 1.09 + +test [accumulate 100% make vector! [2% 3% 4% 5%] :add] +=== 114% + +test [accumulate 100% make vector! [2% 3% 4%] :add] +=== 109% + +test [accumulate 100% make vector! [2% 3%] :add] +=== 105% + +test [accumulate 100% make vector! [2%] :add] +=== 102% + + +;-- suppose we have an array of word lengths; we can skip some of them without summing +test [accumulate "one two three four" [4 4 6] :skip] +=== "four" +;-- or we can do similar thing using find/tail +test [accumulate "one two three four" " " func [s x] [find/tail s :x]] +=== "four" + +;-- we can deep-pick/deep-select fast +test [accumulate [one [two [three [four] x] y] z] [2 2 2] :pick] +=== [four] +test [accumulate [one [two [three [four] x] y] z] [one two three] :select] +=== [four] + +;-- we could swap multiple items at once ("xyz" will contain "abc").. if only swap advanced it's input :) +; probe accumulate "abcdef" ["x" "y" "z"] :swap +test [head accumulate "abcdef" ["x" "y" "z"] func [s1 s2] [swap s1 s2 next s1]] +=== "xyzdef" + +;-- we can deeply translate coordinates in a face tree, like what face-to-screen and screen-to-face do +;-- problem is getting those coordinates from faces ;) +test [accumulate 101x201 [20x20 0x150 80x30] :subtract] +=== 1x1 + +;-- factorial can be accumulate over a range (when we'll have ranges) +test [accumulate 1 [1 2 3 4 5] :multiply] +=== 120 + +;-- extend object with multiple extensions; though more GC load +test [accumulate object! [[a: 1] [b: 1] [b: 2 c: 3]] :make] +=== object [a: 1 b: 2 c: 3] + +;-- incremental xoring, or incremental hash computation +test [accumulate 0 [1 10h 100h 1000h] :xor] +=== 1111h + +;-- 'with' can be rewritten faster: +; accumulate 'target [ctx-word1 ctx-word2 ...] :bind + + + + +;-- +;-- MAP & co +;-- + + +test [map :length? ["abc" "de" "f"]] +=== [3 2 1] + +fsine: func [x /radians] [either radians [sine/radians x][sine x]] +test [map :sine [90 180 -90]] +=== [1.0 0.0 -1.0] + +test [map :fsine [90 180 -90]] +=== [1.0 0.0 -1.0] + +test [map :cosine [90 180 -90]] +=== [0.0 -1.0 0.0] + + +;-- any [all [expr..] all [expr..] ...] pattern can be simplified: +;-- failed all failed all succeeded all +test [any map :all [ [yes yes no] [no yes] [yes] ]] +=== true + +;-- check if all list items are any-words: +test [all map :any-word? [x 'y :z w:]] +=== true +;-- but then it's faster to fold the results without 'all': +test [accumulate true (map :any-word? [x 'y :z w:]) :and] +=== true +;-- `accumulate` then can be used as non-evaluating `all` or `any`... +test [accumulate true [#[true] #[true] #[true]] :and] +=== true +test [accumulate false [#[false] #[true] #[false]] :or] +=== true + + +;-- and we can also make a non-evaluating `reduce`: +test [x: 1 y: 2 z: 3 map :get [x y z]] +=== [1 2 3] + +;-- we can take first data column: +test [rejoin map :take ["123" "456" "789"]] +=== "147" +;-- or any other: +test [rejoin map :take map :next ["123" "456" "789"]] +=== "258" + +;-- having a set of lines of text, we can calc the whole text size (including newlines), fast: +test [lines: ["line1" "line2" "line3"] (length? lines) + sum map :length? lines] +=== 3 + 15 + + + +;-- map can be used as faster `foreach x xs [f x]`, where it matters +test [map :dt [[1 + 2] [2 + 3 * 4]]] + +;-- multi-line unit tests done with just assert+map: +; test [all map :assert [ +; [1 = 1] +; [2 + 3 = 5] +; ]] +; === yes + + + + +;-- +;-- SUM +;-- + + +test [sum reduce [make vector! [1 1 1] make vector! [2 2 2] make vector! [3 3 3] make vector! [4 4 4]]] +=== make vector! [10 10 10] + +test [sum reduce [make vector! [1 1 1] 2 3 4]] +=== make vector! [10 10 10] + +test [sum [1x1 2x2 3 4.0]] +=== 10x10 + +test [sum [1/1/1970 1:0 2:0 3:0]] +=== 1-Jan-1970/6:00:00 + +test [sum [1.2.3 4.5.6]] +=== 5.7.9 + + + + +;-- +;-- SCAN +;-- + + +test [scan :add 0 [1 2 3 4 5 6]] +=== [0 1 3 6 10 15 21] + +test [scan :+ 0 [1 2 3 4 5 6]] +=== [0 1 3 6 10 15 21] + +test [scan :add 1 next [1 2 3 4 5 6]] +=== [ 1 3 6 10 15 21] + +; test [scan :+ now/time next [0 1:0]] + +; test [accumulate "abc" [#[none] #[none]] :pick] + +; probe fold ["abc"] :+ #"b" + + +; probe accumulate 1 make vector! [2] :add +; probe accumulate 1 make vector! [2 3] :add +; probe accumulate 1 make vector! [2 3 4] :add +; probe accumulate 1 make vector! [2 3 4 5] :add +; probe accumulate 1 make vector! [2 3 4 5 6] :add +; probe accumulate 1 make vector! [2 3 4 5 6 7] :add +; probe accumulate 1 make vector! [2 3 4 5 6 7 8] :add +; probe fold :+ 1 make vector! [2 3 4] +; probe fold :r 1 make vector! [2 3 4] +; probe fold func [a b] [probe reduce [a b]] 1 make vector! [2 3 4] + +; probe fold "^A^B^C" :+ #"^@" +; probe r "abc" #"b" +; probe r "abc" #"b" +; probe r "abc" #"b" diff --git a/mapfold/mapfold.red b/mapfold/mapfold.red new file mode 100644 index 0000000..b250123 --- /dev/null +++ b/mapfold/mapfold.red @@ -0,0 +1,523 @@ +Red [ + title: "MAP & ACCUMULATE routines" + purpose: "Fast implementation of the most common higher order functions" + author: @hiiamboris + license: 'BSD-3 + notes: { + + } +] + +; system/state/trace: 2 + +#system [ + count-refines: func [ + spec [node!] + return: [integer!] + /local + value [red-value!] + s [series!] + n [integer!] + ][ + assert spec <> null + s: as series! spec/value + value: s/offset + n: 0 + while [value < s/tail] [ + if TYPE_OF(value) = TYPE_REFINEMENT [n: n + 1] + value: value + 1 + ] + n + ] + + ;-- recursive implementation of https://en.wikipedia.org/wiki/Pairwise_summation + sum-pairwise*: func [ + data [byte-ptr!] ;-- ptr to vector values + unit [integer!] + int? [logic!] + len [integer!] + return: [float!] + /local r [float!] i half p + ][ + either all [len <= 16 len > 0] [ ;-- 16 is found empirically (8 is ~20% slower, 32 is on par) + r: 0.0 + p: data + (len * unit) + either int? [ + while [p: p - unit p >= data] [ + r: r + as-float vector/get-value-int as int-ptr! p unit + ] + ][ + while [p: p - unit p >= data] [ + r: r + vector/get-value-float p unit + ] + ] + if r <> r [throw 1] ;-- early exit for NaN case + ][ + half: len >>> 1 + r: sum-pairwise* data unit int? half + r: r + sum-pairwise* data + (half * unit) unit int? len - half ;-- watch out for bug #4937 + ] + r + ] + + sum-pairwise: func [ + vec [red-vector!] + return: [float!] + /local buf unit phead len r + ][ + assert any [vec/type = TYPE_FLOAT vec/type = TYPE_PERCENT vec/type = TYPE_INTEGER] + buf: GET_BUFFER(vec) + unit: GET_UNIT(buf) + phead: (as byte-ptr! buf/offset) + (vec/head << (log-b unit)) + len: (as-integer buf/tail - phead) >>> (log-b unit) + if len = 0 [return 0.0] + catch 1 [ ;-- catch for NaN case + r: sum-pairwise* phead unit (vec/type = TYPE_INTEGER) len + return r + ] + system/thrown: 0 + 0.0 / 0.0 + ] +] + +{ + Red-like argument order is: Accumulator Series Operator + however when chained this becomes not so good: + accumulate (accumulate 0 series1 :fun1) series2 :fun2 + and when we produce the series in-line, it's also not very readable: + accumulate 0 produce the series :fun + Haskell-like argument order is: Operator Accumulator Series + which isn't very great when function is defined in-line: + accumulate func [a x] [a + x] 0 series + func can be longer.. but that can be fixed by giving it a name (a good practice anyway) + it also chains badly: + accumulate :fun2 (accumulate :fun1 0 series1) series2 + it though works for in-line series generation (common case): + accumulate :fun 0 produce the series + so for now I don't see a clear winner, and am choosing the Red-like order +} +accumulate: routine [ + "Evaluate the operator over each item in the series" + accumulator [any-type!] "Used as first argument to the operator, updated with it's result" + series [series!] "Each item is used as second argument to the operator" ;-- requires #4927 fixed + operator [any-type!] "Operator or any binary function (or a word referring to it)" + return: [any-type!] "Last value of the accumulator (unchanged if series is empty)" + /local check-arity [subroutine!] p [int-ptr!] ref-array [int-ptr!] + fun [red-function!] empty-path [red-path!] arity [integer!] code [integer!] name [red-word!] + oper srs type stype atype call rout nat act vec result i f item op? native? spec nrefs args +][ + stype: TYPE_OF(series) + unless ANY_SERIES?(stype) [ ;@@ typechecks are not working - #4928, have to do manually + fire [TO_ERROR(script wrong-type) series] ;@@ not the best error message but there's no better one, with arg name + ] + srs: as red-series! series + atype: TYPE_OF(accumulator) + + type: TYPE_OF(operator) + name: words/_anon + if type = TYPE_WORD [ + name: as red-word! operator + operator: word/get name + type: TYPE_OF(operator) + ] + + fun: as red-function! operator + check-arity: [ + empty-path: path/make-at as red-path! stack/push* 1 + arity: FFFFh and _function/calc-arity empty-path fun 0 + unless arity = 2 [ + fire [TO_ERROR(script invalid-arg) operator] ;@@ need a better error message, stating arity and arg name + ] + ] + + switch type [ + TYPE_ACTION TYPE_NATIVE TYPE_OP [ + op?: type = TYPE_OP + native?: type = TYPE_NATIVE + unless op? [check-arity] ;@@ this relies on op having only 2 args (will change some day?) + + code: case [ + op? [ + oper: as red-op! operator + oper/code + ] + native? [ + nat: as red-native! operator + nat/code + ] + true [ + act: as red-action! operator + act/code + ] + ] + + ;-- if action is a sum, attempt to perform fast pairwise summation on numeric vectors + assert code <> 0 + i: ACT_ADD + vec: as red-vector! srs + if all [ ;-- sum of vector: special case + actions/table/i = code + stype = TYPE_VECTOR + any [atype = TYPE_INTEGER atype = TYPE_FLOAT atype = TYPE_PERCENT] + any [vec/type = TYPE_INTEGER vec/type = TYPE_FLOAT atype = TYPE_PERCENT] ;-- delegate other vector types to 'add' action + ][ + switch atype [ ;-- fetch initial accumulator value + TYPE_INTEGER [f: as-float integer/get accumulator] + TYPE_FLOAT [f: float/get accumulator] + TYPE_PERCENT [f: percent/get accumulator] + ] + + if f = f [ ;-- don't sum if accumulator is NaN + f: f + sum-pairwise as red-vector! srs ;-- perform summation + ] + i: as-integer f + either all [ ;-- try to coerce to integer if sources are all integer + atype = TYPE_INTEGER + vec/type = TYPE_INTEGER + ][ + unless f = as-float i [ ;-- error, only for consistency with 'add' as an action! + fire [TO_ERROR(math overflow)] + ] + result: as red-value! integer/push i + ][ + either atype = TYPE_PERCENT [ + result: as red-value! percent/push f + ][ result: as red-value! float/push f + ] + ] + return stack/set-last result + ] + + ;-- natives/actions require an array of +1/-1 for each refinement, so we prepare it + nrefs: 0 + unless op? [ + spec: either native? [nat/spec][act/spec] + nrefs: count-refines spec + ] + ref-array: null + if nrefs <> 0 [ + ref-array: system/stack/allocate nrefs + p: ref-array loop nrefs [p/1: -1 p: p + 1] ;-- -1 sets refinement to false + ] + + stack/mark-native name + stack/push accumulator + stack/push* + + call: as function! [] code + args: stack/arguments + i: 0 + catch RED_THROWN_ERROR [ + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + copy-cell item stack/arguments + 1 + stack/top: args + 2 ;-- clean up after _series/pick, or we get stack overflow + if nrefs <> 0 [ ;-- push prepared '-1's on the native stack + p: system/stack/top - nrefs + system/stack/top: p + copy-memory + as byte-ptr! p + as byte-ptr! ref-array + nrefs * size? integer! + ] + if native? [push yes] ;-- yes to perform typecheck + call + ; if nrefs <> 0 [system/stack/top: p + nrefs] + ; copy-cell stack/arguments accumulator + ] + ] + if nrefs <> 0 [system/stack/free nrefs] + if system/thrown <> 0 [re-throw] + ] + + TYPE_ROUTINE [ + rout: as red-routine! operator + unless 2 = routine/get-arity rout [ + fire [TO_ERROR(script invalid-arg) operator] + ] + + stack/mark-native name + stack/push accumulator + stack/push* + + i: 0 + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + stack/top: stack/arguments + 2 ;-- clean up after _series/pick, or we get stack overflow + copy-cell item stack/arguments + 1 + interpreter/exec-routine rout + ] + ] + + TYPE_FUNCTION [ + check-arity + + stack/mark-func name fun/ctx + stack/push accumulator + stack/push* + + i: 0 + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + stack/top: stack/arguments + 2 ;-- clean up after _series/pick, or we get stack overflow + copy-cell item stack/arguments + 1 + interpreter/set-locals fun ;-- have to also set refinements and their arguments + _function/call fun global-ctx ;@@ should it be called with global-ctx? + ] + ] + + ;@@ again, not the best error (should tell the expected type as 'any-function' and arg name) + default [fire [TO_ERROR(script invalid-op) oper]] + ] + + stack/unwind-last ;-- copies 'accumulator' (old stack/args+0) into new stack/args+0 +] + +;-- another name option: `apply-to-each` (quite verbose, nonstandard) +map: routine [ + "Evaluate the function over each item in the series" + ;-- Haskell-like argument order + mapfunc [any-type!] "Any unary function (or a word referring to one)" + ; series [series!] ;@@ CRASHES - see #4927 + series [series!] "Each item is used a an argument to the function" + return: [block!] + /local check-arity [subroutine!] empty-path [red-path!] arity [integer!] p [int-ptr!] + fun [red-function!] name [red-word!] code [integer!] + nat act rout spec call srs type result i item len native? nrefs ref-array +][ + type: TYPE_OF(series) + unless ANY_SERIES?(type) [ ;@@ typechecks are not working - #4928, have to do manually + fire [TO_ERROR(script wrong-type) series] ;@@ not the best error message but there's no better one, with arg name + ] + + type: TYPE_OF(mapfunc) + name: words/_anon + if type = TYPE_WORD [ + name: as red-word! mapfunc + mapfunc: word/get name + type: TYPE_OF(mapfunc) + ] + + fun: as red-function! mapfunc + rout: as red-routine! mapfunc + check-arity: [ + empty-path: path/make-at as red-path! stack/push* 1 + arity: FFFFh and _function/calc-arity empty-path fun 0 + unless arity = 1 [ + fire [TO_ERROR(script invalid-arg) mapfunc] ;@@ need a better error message, stating arity and arg name + ] + ] + + srs: as red-series! series + len: _series/length? srs + result: block/push-only* len + + switch type [ + TYPE_ACTION TYPE_NATIVE [ + check-arity + + native?: type = TYPE_NATIVE + either native? [ + nat: as red-native! mapfunc + spec: nat/spec + code: nat/code + ][ + act: as red-action! mapfunc + spec: act/spec + code: act/code + ] + nrefs: count-refines spec + ref-array: system/stack/allocate nrefs ;-- natives/actions require an array of +1/-1 for each refinement + p: ref-array loop nrefs [p/1: -1 p: p + 1] ;-- -1 sets refinement to false + + stack/mark-native name + stack/push* + + assert code <> 0 + call: as function! [] code + i: 0 + catch RED_THROWN_ERROR [ + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + stack/reset ;-- clean up after _series/pick, or we get stack overflow + stack/push item + + if nrefs <> 0 [ ;-- push prepared '-1's on the native stack + p: system/stack/top - nrefs + copy-memory + as byte-ptr! p + as byte-ptr! ref-array + nrefs * size? integer! + system/stack/top: p ;-- stack offset is fragile and should be set right before the call + ] + if native? [push yes] ;-- yes to perform typecheck + call + + block/rs-append result stack/arguments + ] + ] + system/stack/free nrefs + if system/thrown <> 0 [re-throw] + ] + + TYPE_ROUTINE [ + unless 1 = routine/get-arity rout [ + fire [TO_ERROR(script invalid-arg) mapfunc] + ] + + stack/mark-native name + stack/push* + + i: 0 + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + stack/reset ;-- clean up after _series/pick, or we get stack overflow + stack/push item + interpreter/exec-routine rout + block/rs-append result stack/arguments + ] + ] + + TYPE_FUNCTION [ + check-arity + + stack/mark-func name fun/ctx + stack/push* + + i: 0 + while [i < _series/length? srs] [ ;-- length is not cached, in case it changes + i: i + 1 + item: _series/pick srs i null + stack/reset ;-- clean up after _series/pick, or we get stack overflow + stack/push item + interpreter/set-locals fun ;-- have to also set refinements and their arguments + _function/call fun global-ctx ;@@ should it be called with global-ctx? + block/rs-append result stack/arguments + ] + ] + + ;@@ again, not the best error (should tell the expected type as 'any-function except op' and arg name) + default [fire [TO_ERROR(script invalid-arg) mapfunc]] + ] + + stack/unwind + as red-block! stack/set-last as cell! result +] + + + + +;-- this is how FP junkies expect the interface to be (uses Haskell-like name & argument order) +;-- but do we want it beside `accumulate`? I think it only brings confusion +fold: func [ + "Evaluate the operator over each item in the series" + operator [word! any-function!] "Operator or any binary function (or a word referring to one)" + accumulator [any-type!] "Used as first argument to the operator, updated with it's result" + series [series!] "Each item is used as second argument to the operator" + return: [any-type!] "Last value of the accumulator (unchanged if series is empty)" +][ + accumulate :accumulator series :operator +] + +;-- http://www.multiwingspan.co.uk/haskell.php?page=scanning +;-- this a is very important function in pure functional langs, but.. +;-- * do WE need it? +;-- * how do we name it? +;-- * in any case, it does not deserve to be a native IMO +scan: func [ + "Evaluate the operator over each item in the series" + ;-- Haskell-like argument order + operator [any-function!] "Operator or any binary function" + accumulator [any-type!] "Used as first argument to the operator, updated with it's result" + series [series!] "Each item is used as second argument to the operator" + return: [any-type!] "All values accumulator has had" +][ + collect [ + keep/only :accumulator + fun: func [a [any-type!] b [any-type!]] + either op? :operator [ + [keep/only :a operator :b] + ][ [keep/only operator :a :b] + ] + accumulate :accumulator :series :fun + ] +] + +;-- by far the most common use case of fold/accumulate +;-- see https://github.com/red/red/issues/4372 for some SUM design notes +;-- this version returns none on empty series +;@@ TODO: for vectors, sum could return zero of their element type if we had a reflector for it +sum: func [ + "Returns the sum of all values in the list" + list [any-list! vector!] + return: [any-type!] "none if list is empty" +][ + accumulate :list/1 next list :+ +] + + +mean: average: function [ + "Returns the average of all values in the list" + list [any-list! vector!] + return: [any-type!] "none if list is empty" +][ + if total: sum list [total / length? list] +] + +;@@ TODO: how to define average on tuples so it'll work for all the edge cases? +;@@ e.g. average [1.2.3 100 1000 1.#nan] ? average [1.2.3 100.200.300.400 99.99.99.99.99] ? + +minimum-of: func [ + "Returns smallest value in the list" + list [any-list! vector!] + return: [any-type!] "none if list is empty" +][ + accumulate :list/1 next list :min +] + +minimum-of: func [ + "Returns biggest value in the list" + list [any-list! vector!] + return: [any-type!] "none if list is empty" +][ + accumulate :list/1 next list :max +] + + +{ + Alternate implementations - no `none`, enforces integer type for empty list + although I think it makes no sense for minimum-of/maximum-of + + sum: func [ + "Returns the sum of all values in the list" + list [any-list! vector!] + return: [any-type!] "integer 0 if list is empty" + ][ + if tail? list [return 0] + accumulate :list/1 next list :+ + ] + + average: func [ + "Returns the average of all values in the list" + list [any-list! vector!] + return: [any-type!] "integer 0 if list is empty" + ][ + (sum list) / max 1 length? list + ] + + ;-- this is more correct: 0/0 = NaN + average: func [ + "Returns the average of all values in the list" + list [any-list! vector!] + return: [any-type!] "NaN if list is empty" + ][ + (sum list) * 1.0 / length? list + ] +} + +