自家製match-lambda

Gauche

util.matchでは以下のようなパターンを使った関数が定義できないのがちょっと残念。

(use util.match)
(define rm (match-lambda*
  ((_ ())       ())
  ((x (x . ys)) (rm x ys))
  ((x (y . ys)) (cons y (rm x ys)))))

エラーメッセージ

gosh: "error": Compile Error: duplicate variable in pattern (x (x . ys))

というわけで、以下のようなモジュールを書いてみた。

(define-module mymatch (export match match-lambda match-lambda*))
(select-module mymatch)

(define (match? x y m) (cond
  ((eq? m #f) #f)
  ((eq? x '_) m)
  ((symbol? x) (let ((v (assoc x m))) (if v (and (equal? (cdr v) y) m) (acons x y m))))
  ((or (eq? x y) (equal? x (list 'quote y))) m)
  ((and (pair? x) (pair? y)) (match? (cdr x) (cdr y) (match? (car x) (car y) m)))
  (else #f)))

(define (matchf expr clause)
  (if (null? clause) (error "not match")
    (let ((m (match? (caar clause) expr ())))
      (if m (apply (eval `(lambda ,(map car m) ,@(cdar clause)) (interaction-environment)) (map cdr m))
            (matchf expr (cdr clause))))))

(define-syntax match         (syntax-rules () ((_ expr . clause) (matchf expr 'clause))))
(define-syntax match-lambda  (syntax-rules () ((_ . clause) (lambda (expr) (matchf expr 'clause)))))
(define-syntax match-lambda* (syntax-rules () ((_ . clause) (lambda expr (matchf expr 'clause)))))

(provide "mymatch")

これをmymatch.scmとして*load-path*に保存して、同じ関数を定義してみる。

(use mymatch)
(define rm (match-lambda*
  ((_ ())       ())
  ((x (x . ys)) (rm x ys))
  ((x (y . ys)) (cons y (rm x ys)))))

実行結果

gosh> (rm 'た '(い た ち の た ぬ き))
(い ち の ぬ き)

追記
すでにこんなものがあった

;(smatch '(a (a b)) ;長さが２で、第二要素が 長さが2でcar部が第一要素に等しいリスト、であるリストにマッチ
; '(1 (1 2))) => *1

http://lists.sourceforge.jp/mailman/archives/gauche-devel-jp/2004-April/000705.html

しかもこれがutil.matchのバンドルのきっかけだったとは。

パターンマッチングについてはたびたび話題になりますね。
Andrew Wrightのmatchあたりを標準でバンドルしておくと 使いでがあるでしょうか。

http://lists.sourceforge.jp/mailman/archives/gauche-devel-jp/2004-April/000708.html

追記2
少し機能追加したバージョン

(define (match? x y m) (cond
  ((eq? m #f) #f)
  ((eq? x '_) m)
  ((symbol? x) (let ((v (assoc x m))) (if v (and (equal? (cdr v) y) m) (acons x y m))))
  ((or (eq? x y) (equal? x (list 'quote y))) m)
  ((pair? x) (let ((z (car x)) (n? (null? (cdr x)))) (cond
    ((eq? z 'and) (if n? m (match? (cons 'and (cddr x)) y (match? (cadr x) y m))))
    ((eq? z 'or) (if n? #f (or (match? (cadr x) y m) (match? (cons 'or (cddr x)) y m))))
    ((pair? y) (match? (cdr x) (cdr y) (match? (car x) (car y) m)))
    (else #f))))
  (else #f)))

*1:a 1) (b 2