hof

[basp]

в одном блоге прочитал про:
(mapcar #M(abs /) '(1 -2 3 -4) '(2 -9 -8 2)) ;; ==> (1/2 2/9 3/8 2)
чуть дописал - теперь работает и такое:
;; типа hook из J
(#1J(- truncate) 2.79) ;; ==> 0.78999996
;; 0.7 (+ - *) 0.3
(#2J(+ - *) 0.3 0.7) ;; вероятностная сумма ==> 0.78999996
;; (+/ % #) 1 2 3 4 5
(#1J( #/(+) / length) #(1 2 3 4 5)) ;; среднее ==> 3


(set-dispatch-macro-character
#\# #\/ #'(lambda (stream sub-character infix-parameter)
(when infix-parameter
(error "#~a does not take an integer infix parameter."
sub-character))
(let ((expr (read stream t nil t)))
(if (> (length expr) 1)
(error "#~a does not take more than 1 function" sub-character)
`(lambda (x) (reduce #',(car expr) x))))))

(set-dispatch-macro-character
#\# #\J #'(lambda (stream sub-character infix-parameter)
(when (or (null infix-parameter) (> infix-parameter 2))
(error "#~a does not take an `#~a` infix parameter."
sub-character infix-parameter))
(let ((expr (read stream t nil t)))
(typecase (car expr)
(function (car expr))
(t (cond ((= (length expr) 3)
;; fork
(if (= infix-parameter 2)
`(lambda (x y)
(funcall #',(cadr expr)
(funcall #',(car expr) x y)
(funcall #',(caddr expr) x y)))
`(lambda (x)
(funcall #',(cadr expr)
(funcall #',(car expr) x)
(funcall #',(caddr expr) x)))))
((= (length expr) 2)
;; hook
(if (= infix-parameter 2)
`(lambda (x y)
(funcall #',(car expr)
x
(funcall #',(cadr expr) y)))
`(lambda (x)
(funcall #',(car expr)
x
(funcall #',(cadr expr) x)))))
(t (error "#~a does not take such functions" sub-character))))))))