Domain-Specific Languages - Combinators - Function combinators - Arity repair

Software Design for Flexibility: How to Avoid Programming Yourself into a Corner (English Edition)
楽天ブックス

開発環境

Software Design for Flexibility: How to Avoid Programming Yourself into a Corner (English Edition)(Chris Hanson(著)、Gerald Jay Sussman(著)、The MIT Press)のChapter 2(Domain-Specific Languages)、2.1(Combinators)、2.1.1(Function combinators)、Arity、Exercise 2.1: Arity repairの解答を求めてみる。

コード

(define (restrict-arity proc nargs)
  (hash-table-set! arity-table proc nargs)
  proc)

(define (get-arity proc)
  (or (hash-table-ref/default arity-table proc #f)
      (let ((a (procedure-arity proc)))
        (assert (eqv? (procedure-arity-min a)
                      (procedure-arity-max a)))
        (procedure-arity-min a))))

(define arity-table (make-key-weak-eqv-hash-table))

(define (compose f g)
  (assert (= (get-arity f) 1))
  (define (the-composition . args)
    (f (apply g args)))
  (restrict-arity the-composition (get-arity g)))

(define (parallel-combine h f g)
  (assert (= (get-arity f) (get-arity g)))
  (define (the-combination . args)
    (h (apply f args)
       (apply g args)))
  (restrict-arity the-combination (get-arity f)))

((compose (lambda (x) (list 'foo x))
            (lambda (x) (list 'bar x)))
   'z)

((parallel-combine list
                     (lambda (x y z) (list 'foo x y z))
                     (lambda (u v w) (list 'bar u v w)))
   'a 'b 'c)

(exit)

入出力結果(Terminal, Zsh)

% scheme < answer2.1.scm
MIT/GNU Scheme running under OS X
Type `^C' (control-C) followed by `H' to obtain information about interrupts.

Copyright (C) 2022 Massachusetts Institute of Technology
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

Image saved on Friday January 6, 2023 at 10:11:41 PM
  Release 12.1 || SF || LIAR/x86-64

…

1 ]=> ((compose (lambda (x) (list 'foo x))
            (lambda (x) (list 'bar x)))
   'z)
;Value: (foo (bar z))

1 ]=> ((parallel-combine list
                     (lambda (x y z) (list 'foo x y z))
                     (lambda (u v w) (list 'bar u v w)))
   'a 'b 'c)
;Value: ((foo a b c) (bar a b c))

1 ]=> (exit)
Ceterum censeo Carthaginem esse delendam.
%