Scheme でスタック操作

Scheme でスタック構造を実装する記事を読みました。

How To Become A Hacker: Schemeでスタックマシンの基礎

Scheme でスタックを「関数的に」実装するというのはむしろ筋が悪いかもしれません。 プログラミング言語 SchemeLisp 族のひとつであり、歴史的経緯から関数型言語に分類されることもありますが、必ずしもプログラムを関数的に設計することを推奨しているわけではないのです。 ユーザが望むパラダイムで記述できることが本来の理念です。

Scheme の仕様の最初のほうにこうあります。

A wide variety of programming paradigms, including imperative, functional, and object-oriented styles, and convenient expression in Scheme.

しかし、もちろん、関数的なパラダイムを望んだときにもそれが出来るはずです。 そこで、関数的にスタックを実装している事例を参考にしてみようと探したところ「すごい Haskell たのしく学ぼう!」にありました。 第十四章に State モナドの使用例として挙がっています。

import Control.Monad.State

type Stack = [Int]
    
pop :: State Stack Int
pop = state $ \(x:xs) -> (x, xs)

push :: Int -> State Stack ()
push a = state $ \xs -> ((), a:xs)

stackStuff :: State Stack ()
stackStuff = do
  a <- pop
  if a == 5
     then push 5
          else do
            push 3
            push 8

main = print $ snd $ runState stackStuff [9, 0, 2, 1, 0]
http://learnyouahaskell.com/for-a-few-monads-more#state

これを Scheme (R7RS) にそのまま翻訳してみるとこうなります。

(define-library (tuple)
  (export tuple fst snd)
  (import (scheme base))
  (begin
    (define-record-type <tuple>
      (tuple x y) tuple? (x fst) (y snd))
    ))
(define-library (state)
  (export state run-state >>= $do)
  (import (scheme base)
          (scheme write)
          (tuple))

  (begin
    (define-record-type <state>
      (state proc) state? (proc run-state))

    (define (>>= h f)
      (state (lambda(s)(let* ((t ((run-state h) s))
                              (a (fst t))
                              (newState (snd t)))
                         ((run-state (f a)) newState)))))

    (define-syntax $do
      (syntax-rules ()
        ((_ ((var expr) rest ...) body)
         (>>= expr (lambda(var) ($do (rest ...) body))))
        ((_ ((expr) rest ...) body)
         (>>= expr (lambda(_) ($do (rest ...) body))))
        ((_ () body) body)))
    ))
(define-library (stack)
  (export pop push)
  (import (scheme base)
          (state)
          (only (tuple) tuple))
  (begin
    (define (pop)
      (state (lambda(s)(tuple (car s) (cdr s)))))

    (define (push x)
      (state (lambda(s)(tuple '() (cons x s)))))
    ))
;;; test case
(import (scheme base)
        (scheme write)
        (only (tuple) snd)
        (only (state) $do run-state)
        (stack))

(define stack-stuff
  ($do ((a (pop)))
       (if (= a 5) (push 5)
           ($do (((push 3)))
                (push 8)))))

(write (snd ((run-state stack-stuff) '(9 0 2 1 0))))
(newline)

Scheme にはタプルやモナドはないためにその部分から記述しているので長くなっていますが、まるっきり直訳したつもりです。

まわりくどい印象をうけますね。 Haskell の純粋関数型としての側面よりは強力な型システムをあてにしているように見えます。 Haskell 的な規律で統制された中では有用なのかもしれませんが、 Scheme 的には過度の抽象化でしょう。

次に Lisp 系に目を向けてみると Common Lisp にはリストの先頭に値を入れたり取出したりする push と pop というマクロが定義されています。

push item place => new-place-value

http://www.lispworks.com/documentation/HyperSpec/Body/m_push.htm

pop place => element

http://www.lispworks.com/documentation/HyperSpec/Body/m_pop.htm

これは Scheme (R7RS) 風に定義すると以下のようになります。 引数の順序が Common Lisp とは変えてあるので気を付けてください。

(define-library (experimental-stack 1)
  (export pop! push!)
  (import (scheme base)
          (scheme case-lambda))

  (begin
    (define-syntax pop!
      (syntax-rules ()
        ((_ place)
         (let ((temp (car place)))
           (set! place (cdr place))
           temp))))
    
    (define-syntax push!
      (syntax-rules ()
        ((_ stack item)
         (set! stack (cons item stack)))))
    ))
(import (scheme base)
        (scheme write)
        (experimental-stack 1))

(define (stack-stuff! stack)
  (let ((a (pop! stack)))
    (if (= a 5)
        (push! stack 5)
        (begin (push! stack 3)
               (push! stack 8)))
    stack))

(write (stack-stuff! '(9 0 2 1 0)))

リストに対してスタック的なインターフェイスを定義するものですね。 つまり、これはあくまでも「スタック的なインターフェイスを持ったリスト」です。 次は中身がリストであることを隠蔽することを考えましょう。

(define-library (experimental-stack 2)
  (export make-stack push! pop! ->list)
  (import (scheme base)
          (scheme case-lambda))

  (begin
    (define make-stack
      (case-lambda
       ((x)
        (let ((s (cons x #f)))
          (lambda(proc . arg)
            (apply proc s arg))))
       (() (make-stack '()))))

    (define (push! s i)
      (set-car! s (cons i (car s))))

    (define (pop! s)
      (let ((temp (caar s)))
        (set-car! s (cdar s))
        temp))

    (define (->list s)
      (car s))
    ))
(import (scheme base)
        (scheme write)
        (experimental-stack 2))

(define (stack-stuff! stack)
  (let ((a (stack pop!)))
    (if (= a 5)
        (stack push! 5)
        (begin (stack push! 3)
               (stack push! 8)))
    stack))

(let ((stack (make-stack '(9 0 2 1 0))))
  (stack-stuff! stack)
  (write (stack ->list)))

スタックの実態としてはリストですが、クロージャの中に隠してしまいました。 ちょとしたお遊びとしてスタックオブジェクトを先頭に置く語順になるようにしています。 なんちゃってオブジェクト指向です。

今の Scheme にはレコード型があるので、専用の型を定義した方がクロージャの中に隠すよりわかりやすいかもしれません。 また、仮想マシンの一部として利用するスタックであれば小さなオブジェクト (ペア) を頻繁に作ったり破棄したりすることになるので GC の負担が無視できないかもしれないということに配慮してベクタとインデックスを使った構造もよいと思います。

(define-library (experimental-stack 3)
  (export make-stack pop! push! stack->list)
  (import (scheme base)
          (scheme case-lambda)
          (scheme write))

  (begin
    (define-record-type <stack>
      (stack vec ptr)
      stack?
      (vec stack-vector)
      (ptr stack-pointer set-stack-pointer!))

    (define *default-stack-limit* 1024)

    (define make-stack
      (case-lambda
       (() (make-stack '() *default-stack-limit*))
       ((initializer-list) (make-stack initializer-list *default-stack-limit*))
       ((initializer-list limit)
        (let ((vec (make-vector limit)))
          (stack vec 
                 (let loop ((lst initializer-list))
                   (if (null? lst)
                       (- limit 1)
                       (let ((i (loop (cdr lst))))
                         (vector-set! vec i (car lst))
                         (- i 1)))))))))

    (define (pop! stack)
      (let* ((ptr (+ (stack-pointer stack) 1)))
        (set-stack-pointer! stack ptr)
        (vector-ref (stack-vector stack) ptr)))

    (define (push! stack item)
      (let ((ptr (stack-pointer stack)))
        (vector-set! (stack-vector stack) ptr item)
        (set-stack-pointer! stack (- ptr 1))))

    (define (stack->list stack)
      (let ((vec (stack-vector stack))
            (ptr (stack-pointer stack)))
        (let loop ((result '())
                   (i (- (vector-length vec) 1)))
          (if (= ptr i)
              result
              (loop (cons (vector-ref vec i) result) (- i 1))))))
    ))
(import (scheme base)
        (scheme write)
        (experimental-stack 3))

(define (stack-stuff! stack)
  (let ((a (pop! stack)))
    (if (= a 5)
        (push! stack 5)
        (begin (push! stack 3)
               (push! stack 8)))
    stack))

(let ((stack (make-stack '(9 0 2 1 0) 10)))
  (stack-stuff! stack)
  (write (stack->list stack)))

この定義では最初に確保したベクタのサイズを越えたときにはエラーになってしまいますが、必要であれば確保しなおすなり、チャンクを繋げていくなりしてスタックを伸ばすということも可能です。

さて、こうやってあらためて様々なやり方を考えましたが、今回は「やってみた」系の題材なので結論はありません。 強いて言えば色々な考え方があるという感想です。

Document ID: 61fa98c4a67dbde7395fb1b22fd2e296