diff options
| -rw-r--r-- | lisplib.c | 20 | ||||
| -rw-r--r-- | stdlib/arith-each.tl | 54 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 8 | ||||
| -rw-r--r-- | stdlib/each-prod.tl | 31 | ||||
| -rw-r--r-- | tests/016/arith.tl | 58 | ||||
| -rw-r--r-- | txr.1 | 120 |
6 files changed, 290 insertions, 1 deletions
@@ -835,6 +835,23 @@ static val copy_file_set_entries(val dlt, val fun) return nil; } +static val arith_each_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(scat2(stdlib_path, lit("arith-each"))); + return nil; +} + +static val arith_each_set_entries(val dlt, val fun) +{ + val name[] = { + lit("sum-each"), lit("mul-each"), lit("sum-each*"), lit("mul-each*"), + nil + }; + set_dlt_entries(dlt, name, fun); + return nil; +} + static val each_prod_instantiate(val set_fun) { funcall1(set_fun, nil); @@ -846,7 +863,9 @@ static val each_prod_set_entries(val dlt, val fun) { val name[] = { lit("each-prod"), lit("collect-each-prod"), lit("append-each-prod"), + lit("sum-each-prod"), lit("mul-each-prod"), lit("each-prod*"), lit("collect-each-prod*"), lit("append-each-prod*"), + lit("sum-each-prod*"), lit("mul-each-prod*"), nil }; set_dlt_entries(dlt, name, fun); @@ -1009,6 +1028,7 @@ void lisplib_init(void) dlt_register(dl_table, save_exe_instantiate, save_exe_set_entries); dlt_register(dl_table, defset_instantiate, defset_set_entries); dlt_register(dl_table, copy_file_instantiate, copy_file_set_entries); + dlt_register(dl_table, arith_each_instantiate, arith_each_set_entries); dlt_register(dl_table, each_prod_instantiate, each_prod_set_entries); dlt_register(dl_table, quips_instantiate, quips_set_entries); dlt_register(dl_table, match_instantiate, match_set_entries); diff --git a/stdlib/arith-each.tl b/stdlib/arith-each.tl new file mode 100644 index 00000000..b0be94ab --- /dev/null +++ b/stdlib/arith-each.tl @@ -0,0 +1,54 @@ +;; Copyright 2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, +;; this list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +;; POSSIBILITY OF SUCH DAMAGE. + +(defmacro sum-each (vars . body) + (with-gensyms (accum) + ^(let ((,accum 0)) + (each ,vars + (inc ,accum (progn ,*body))) + ,accum))) + +(defmacro sum-each* (vars . body) + (with-gensyms (accum) + ^(let ((,accum 0)) + (each* ,vars + (inc ,accum (progn ,*body))) + ,accum))) + +(defmacro mul-each (vars . body) + (with-gensyms (accum) + ^(let ((,accum 1)) + (each ,vars + (set ,accum (* ,accum (progn ,*body)))) + ,accum))) + +(defmacro mul-each* (vars . body) + (with-gensyms (accum) + ^(let ((,accum 1)) + (each* ,vars + (set ,accum (* ,accum (progn ,*body)))) + ,accum))) diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl index 60a81501..c9fcf582 100644 --- a/stdlib/doc-syms.tl +++ b/stdlib/doc-syms.tl @@ -1283,6 +1283,10 @@ ("ms-invalidate" "N-01F782B2") ("ms-sync" "N-01F782B2") ("msync" "N-02805A83") + ("mul-each" "N-01C5F219") + ("mul-each*" "N-01C5F219") + ("mul-each-prod" "N-003CC14A") + ("mul-each-prod*" "N-003CC14A") ("multi" "N-034946BA") ("multi-sort" "N-0132852F") ("munmap" "N-00E1BF52") @@ -1878,6 +1882,10 @@ ("subtypep" "N-00699D3B") ("succ" "N-038E636C") ("sum" "N-0163FFE2") + ("sum-each" "N-01C5F219") + ("sum-each*" "N-01C5F219") + ("sum-each-prod" "N-003CC14A") + ("sum-each-prod*" "N-003CC14A") ("super" "N-03D8EEEE") ("super-method" "N-02AC8367") ("suspend" "N-02E7852D") diff --git a/stdlib/each-prod.tl b/stdlib/each-prod.tl index d1a9c15a..1393b80a 100644 --- a/stdlib/each-prod.tl +++ b/stdlib/each-prod.tl @@ -50,12 +50,29 @@ (let* ((each-prod-op (caseq (car form) (each-prod* 'each-prod) (collect-each-prod* 'collect-each-prod) - (append-each-prod* 'append-each-prod))) + (append-each-prod* 'append-each-prod) + (sum-each-prod* 'sum-each-prod) + (mul-each-prod* 'mul-each-prod))) (syms [mapcar car vars]) (inits [mapcar cadr vars])) ^(let* ,vars (,each-prod-op ,(zip syms syms) ,*body)))) +(defun sys:expand-arith-each-prod (form vars body) + (sys:vars-check form vars) + (let ((syms [mapcar car vars]) + (inits [mapcar cadr vars])) + (sys:bindable-check form syms) + (let ((op-iv (caseq (car form) + (sum-each-prod '(+ . 0)) + (mul-each-prod '(* . 1))))) + (with-gensyms (acc) + ^(let ((,acc ,(cdr op-iv))) + (maprodo (lambda (,*syms) + (set ,acc (,(car op-iv) ,acc (progn ,*body)))) + ,*inits) + ,acc))))) + (defmacro each-prod (:form f vars . body) (sys:expand-each-prod f vars body)) @@ -65,6 +82,12 @@ (defmacro append-each-prod (:form f vars . body) (sys:expand-each-prod f vars body)) +(defmacro sum-each-prod (:form f vars . body) + (sys:expand-arith-each-prod f vars body)) + +(defmacro mul-each-prod (:form f vars . body) + (sys:expand-arith-each-prod f vars body)) + (defmacro each-prod* (:form f vars . body) (sys:expand-each-prod* f vars body)) @@ -73,3 +96,9 @@ (defmacro append-each-prod* (:form f vars . body) (sys:expand-each-prod* f vars body)) + +(defmacro sum-each-prod* (:form f vars . body) + (sys:expand-each-prod* f vars body)) + +(defmacro mul-each-prod* (:form f vars . body) + (sys:expand-each-prod* f vars body)) diff --git a/tests/016/arith.tl b/tests/016/arith.tl index 34a82c7f..367b0c32 100644 --- a/tests/016/arith.tl +++ b/tests/016/arith.tl @@ -253,3 +253,61 @@ 3.0 3.0 3.0 3.0 3.0)]) (0.0 0.0 0.0 0.0 0.0 1.5 2.25 2.625 2.8125 2.90625)) + +(mtest + (sum-each ((x '(1 2 3)) + (y '(4 5 6))) + (* x y)) + 32 + (mul-each ((x '(1 2 3)) + (y '(4 5 6))) + (+ x y)) + 315 + (sum-each* ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + 8 + (mul-each* ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + 15 + (sum-each ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + :error + (mul-each ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + :error) + +(mtest + (sum-each-prod ((x '(1 2 3)) + (y '(4 3 2))) + (* x y)) + 54 + (sum-each-prod* ((x '(1 2 3 4)) + (y (cdr x))) + (* x y)) + 90 + (sum-each-prod ((x '(1 2 3 4)) + (y (cdr x))) + (* x y)) + :error) + +(mvtest + (mul-each-prod ((x '(1 2 3)) + (y '(4 3 2))) + (+ x y)) + (* (+ 1 4) (+ 1 3) (+ 1 2) + (+ 2 4) (+ 2 3) (+ 2 2) + (+ 3 4) (+ 3 3) (+ 3 2)) + (mul-each-prod* ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + (* (+ 1 2) (+ 1 3) + (+ 2 2) (+ 2 3) + (+ 3 2) (+ 3 3)) + (sum-each-prod ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + :error) @@ -17639,6 +17639,84 @@ into the .meta step-form position. +.coNP Macros @, sum-each @, sum-each* @ mul-each and @ mul-each* +.synb +.mets (sum-each >> ({( sym << init-form )}*) << body-form *) +.mets (sum-each* >> ({( sym << init-form )}*) << body-form *) +.mets (mul-each >> ({( sym << init-form )}*) << body-form *) +.mets (mul-each* >> ({( sym << init-form )}*) << body-form *) +.syne +.desc +The macros +.codn sum-each , +and +.code mul-each +behave very similarly to the +.code each +operator. Whereas the +.code each +operator form returns +.code nil +as its result, the +.code sum-each +and +.code mul-each +forms, if they execute to completion and return normally, return +an accumulated value. + +The +.code sum-each +macro initializes newly instantiated, hidden accumulator variable +to the value +.codn 0 . +For each iteration of the loop, the +.metn body-form s +are evaluated, and are expected to produce a value. This value +is added to the current value of the hidden accumulator using the +.code + +function, and the result is stored into the accumulator. If +.code sum-each +returns normally, then the value of this accumulator becomes its +resulting value. + +The +.code mul-each +macro similarly initializes a hidden accumulator to the value +.codn 1 . +The value from each iteration of the body is multiplied with +the accumulator using the +.code * +function, and the result is stored into the accumulator. If +.code mul-each +returns normally, then the value of this accumulator becomes +its resulting value. + +The +.code sum-each* +and +.code mul-each* +variants of the macros implement the sequential scoping rule for +the variable bindings, exactly the way +.code each* +alters the semantics of +.codn each . + +Note: the following equivalences apply, except that the accumulator +variable is a named by a unique, generated symbol. + +.verb + (sum-each (vars ...) <--> (let ((acc 0)) + body ...) (each vars + (inc acc (progn body))) + acc) + + (mul-each (vars ...) <--> (let ((acc 1)) + body) (each vars + (set acc (* acc + (progn body)))) + acc) +.brev + .coNP Macros @, each-prod @ collect-each-prod and @ append-each-prod .synb .mets (each-prod >> ({( sym << init-form )}*) << body-form *) @@ -17761,6 +17839,48 @@ stepped by assignment. --> ("aA" "aB" "aC" "bA" "bB" "bC" "cA" "cB" "cC") .onom +.coNP Macros @, sum-each-prod @, sum-each-prod* @ mul-each-prod and @ mul-each-prod* +.synb +.mets (sum-each-prod >> ({( sym << init-form )}*) << body-form *) +.mets (sum-each-prod* >> ({( sym << init-form )}*) << body-form *) +.mets (mul-each-prod >> ({( sym << init-form )}*) << body-form *) +.mets (mul-each-prod* >> ({( sym << init-form )}*) << body-form *) +.syne +.desc +The macros +.code sum-each-prod +and +.code mul-each-prod +have a similar syntax to +.code sum-each +and +.codn mul-each . +However, instead of iterating over sequences in parallel, they iterate over +the Cartesian product of the elements from the sequences. + +The macros +.code sum-each-prod* +and +.code mul-each-prod* +variants perform sequential variable binding when establishing the initial +values of the variables, similarly to the +.code each* +operator. + +.TP* Examples: + +.verb + ;; Inefficiently calculate (+ (* 1 2 3) (* 4 3 2)). + ;; Every value from (1 2 3) is paired with every value + ;; from (4 3 2) to form a partial products, and + ;; sum-each-prod adds these together implicitly: + + (sum-each-prod ((x '(1 2 3)) + (y '(4 3 2))) + (* x y)) + -> 54 +.brev + .coNP Operators @ block and @ block* .synb .mets (block < name << body-form *) |