LISPUSER

http://cadr.g.hatena.ne.jp/g000001/20081015/1224059357 からのネタ

関数 MAPF を定義してみた。

こんな感じ？

(defpackage :caddr.mdl (:use :cl))
(in-package :caddr.mdl)

(defvar *mapf-mapret* nil)
(defvar *mapf-mapstop* nil)
(defvar *mapf-mapleave* nil)

(defun mapret (&rest rest)
  (apply *mapf-mapret* rest))
(defun mapstop (&rest rest)
  (apply *mapf-mapstop* rest))
(defun mapleave (&rest rest)
  (apply *mapf-mapleave* rest))

(defun mapf (final-function loop-function &rest lists &aux tail result)
  (labels ((cons-forward (value)
             (if result
                 (setf (cdr tail) (cons value nil)
                       tail       (cdr tail))
                 (setf result (cons value nil)
                       tail   result)))
           (list-forward (values)
             (when values
               (if result
                   (setf (cdr tail) values
                         tail (last values))
                   (setf result values
                         tail   (last result))))))
    (let ((*mapf-mapret* #'(lambda (&rest rest)
                             (list-forward rest)
                             (throw 'mapf-ret nil)))
          (*mapf-mapstop* #'(lambda (&rest rest)
                              (list-forward rest)
                              (throw 'mapf-stop (apply final-function result))))
          (*mapf-mapleave* #'(lambda (result)
                               (throw 'mapf-stop result))))
      (catch 'mapf-stop
        (loop for args in (if lists (apply #'mapcar (cons #'list lists)) '#1=(NIL . #1#))
              do (catch 'mapf-ret
                   (cons-forward (apply loop-function args)))
              finally (return (apply final-function result)))))))

どんなもんでしょ。

Scheme で書いたら？という話がありましたのでこっちも。 大域脱出を継続で、ダイナミックスコープを fluid-let に翻訳しました。

(define mapleave #f)
(define mapstop #f)
(define mapret #f)

(define (mapf final-function loop-function . lists)
  (let ((result ()))
    (let/cc stop
       (fluid-let ((mapleave (lambda (result) (stop result)))
                   (mapstop (lambda rest
                              (set! result (append result rest))
                              (stop (apply final-function result)))))
         (let loop ((lists (if (pair? lists) (apply map (cons list lists)) '#1=(() . #1#))))
           (if (null? lists)
               (apply final-function result)
               (begin
                 (let/cc ret
                   (fluid-let ((mapret (lambda rest
                                         (set! result (append result rest))
                                         (ret))))
                     (set! result (append result (list (apply loop-function (car lists)))))))
                 (loop (cdr lists)))))))))

なんか Scheme 版は効率がさがっているが気にしない。 CL 版の破壊的 cons-forward, list-forward をコピればきっと長さも効率ほぼ等価でしょう。