ラムダ式からの変換

Schemeのラムダ式に対応するコンビネータ表記を求めるプログラムを作った。

使い方

lambdaをlambdaccにして、通常のlambdaと同じように引数と本体を与える。

gosh> (lambdacc (x y z) (x (y z)))
B
gosh> (lambdacc (x y) (x (y y)))
(C B M)

ソースコード

(use util.match)

(define-syntax lambdacc (syntax-rules ()
  ((_ var body ...) (uncurry (lcc 'var (curry '(body ...)))))))

(define lcc (match-lambda*
  ((() x) x)
  (((v . vs) x) (lcc v (lcc vs x)))
  ((v (x y)) (match `(,(in? v x) ,(in? v y))
    ((#f   #f)       `( K (,x ,y)))
    ((#f  'eq)          x)
    (('eq  #f)       `( T ,y))
    (('eq 'eq)         'M)
    (('eq (not #f))  `( O ,(lcc v y)))
    (((not #f) 'eq)  `( W ,(lcc v x)))
    ((#f    _)       `((B ,x)         ,(lcc v y)))
    ((_    #f)       `((C ,(lcc v x)) ,y))
    ( _              `((S ,(lcc v x)) ,(lcc v y)))))
  ((v x) (if (eq? v x) 'I `(K ,x)))))

(define in? (match-lambda*
  ((v (x y)) (if (or (in? v x) (in? v y)) 'in #f))
  ((v  x)    (if     (eq? v x)            'eq #f))))

(define (curry l)
  (if (pair? l) (currys (reverse l)) l))
(define currys (match-lambda
  ((x)                      (curry x))
  ((x . xs) `(,(currys xs) ,(curry x)))))

(define (uncurry l)
  (if (pair? l) (uncurrys l) l))
(define uncurrys (match-lambda
  ((xs x) `(,@(uncurrys xs) ,(uncurry x)))
  (    x  `(                ,(uncurry x)))))

バリエーション

なるべく後のパターンほど広くマッチするようにしたので、不要なパターンを削ればそれなりの動作をする。
例えば以下はSKIコンビネータのみの表記を求めるバージョン。

(define lcc (match-lambda*
  ((() x) x)
  (((v . vs) x) (lcc v (lcc vs x)))
  ((v (x y)) (match `(,(in? v x) ,(in? v y))
    ((#f   #f)       `( K (,x ,y)))
    ((#f  'eq)          x)
   ;(('eq  #f)       `( T ,y))
   ;(('eq 'eq)         'M)
   ;(('eq (not #f))  `( O ,(lcc v y)))
   ;(((not #f) 'eq)  `( W ,(lcc v x)))
   ;((#f    _)       `((B ,x)         ,(lcc v y)))
   ;((_    #f)       `((C ,(lcc v x)) ,y))
    ( _              `((S ,(lcc v x)) ,(lcc v y)))))
  ((v x) (if (eq? v x) 'I `(K ,x)))))

実行結果

gosh> (lambdacc (x y z) (x (y z)))
(S (K S) K)
gosh> (lambdacc (x y) (x (y y)))
(S (S (K S) K) (K (S I I)))

対応表

	v	y	yv
v	Mv	Tyv	Oyv
x	xv	K(xy)v	Bxyv
xv	Wxv	Cxyv	Sxyv