cco/decons
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

minor fixes; add rreduce: recursive reduce

Browse source
This commit is contained in:
Helmut Merz 2025-05-24 09:43:47 +02:00
parent fa683982b7
commit b4a337ee37
2 changed files with 22 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
decons.lisp
View file

@ -3,19 +3,19 @@
(defpackage :decons (defpackage :decons
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:util :scopes/util)) (:local-nicknames (:util :scopes/util))
(:export #:*pi* #:area #:circle (:export #:+pi+ #:area #:circle
#:absv #:double #:remainder #:absv #:double #:remainder
#:scalar-p #:tensor #:at #:scalar-p #:tensor #:at
#:rapply #:rapply #:rreduce
#:line #:line
#:lg- #:lgx
)) ))
(in-package :decons) (in-package :decons)
;;;; basic explorations ;;;; basic explorations
(defconstant *pi* 3.14159) (defconstant +pi+ 3.14159)
(defclass circle () (defclass circle ()
;;; ! implement as closure ;;; ! implement as closure
@ -23,7 +23,7 @@
(defgeneric area (c) (defgeneric area (c)
(:method ((c circle)) (:method ((c circle))
(* *pi* (radius c) (radius c)))) (* +pi+ (radius c) (radius c))))
(defun double (f) (defun double (f)
#'(lambda (v) (* 2 (funcall f v)))) #'(lambda (v) (* 2 (funcall f v))))
@ -61,7 +61,7 @@
(:method (op (a number) (b number)) (:method (op (a number) (b number))
(funcall op a b))) (funcall op a b)))
;;;; rapply - recursive application of an operation ;;;; rapply, rreduce - recursive application of operations
(defun rapply (op arg1 &optional arg2) (defun rapply (op arg1 &optional arg2)
(if arg2 (if arg2
@ -78,12 +78,23 @@
(:method (op (arg list)) (:method (op (arg list))
(lambda (j) (mapcar (lambda (i) (rapply op i j)) arg)))) (lambda (j) (mapcar (lambda (i) (rapply op i j)) arg))))
(defun rreduce (op arg &key (initial-value 0))
(reduce op arg :initial-value initial-value
:key (lambda (v) (relement op v :initial-value initial-value))))
(defgeneric relement (op v &key initial-value)
(:method (op v &key (initial-value 0)) v)
(:method (op (v list) &key (initial-value 0))
(rreduce op v :initial-value initial-value)))
;;;; logging (printing) functions for debugging purposes ;;;; logging (printing) functions for debugging purposes
(defun lg- (&rest args) (defun lgx (op)
(let ((r (apply #'- args))) (lambda (&rest args)
(format t "~&(- ~a) = ~a~%" args r) (let ((r (apply op args)))
r)) (format t "~&(~a ~a) = ~a~%" op args r)
r)))
;;;; parameterized functions ;;;; parameterized functions

2
test-decons.lisp
View file

@ -17,7 +17,7 @@
(t:show-result))) (t:show-result)))
(deftest test-basic () (deftest test-basic ()
(== decons:*pi* 3.14159) (== decons:+pi+ 3.14159)
(let ((c (make-instance 'decons:circle :radius 2.0))) (let ((c (make-instance 'decons:circle :radius 2.0)))
(== (decons:area c) 12.56636)) (== (decons:area c) 12.56636))
(== (funcall (decons:double #'1+) 7) 16) (== (funcall (decons:double #'1+) 7) 16)