[Common Lisp] LET OVER LAMBDA でステートマシン

LISPUSER さんとこの Common Lisp で簡単ステートマシンマクロ で題材になっているステートマシンを LET OVER LAMBDA でやってみようかと思ったら、ちょっと違った方向にいってしまった。

plambda は自身の手続を this に持っていて、それを外部から書きかえて状態が遷移できる、という予定だったけど、何故か case* マクロを書いておわってしまった。

this の書きかえはまたそのうちに。

(defpan print-status (tray player)
  (format t "~&tray => ~a~%player => ~a" tray player))

(let* ((tray :close)
       (player :stop)
       (cd-player (plambda (action) (tray player)
            (format t "~&Action: ~a" action)
            (case* (action tray player)
              ((:open :close :play)
               (print ">>> STOP")
               (setf player :stop)
               (print ">>> OPEN")
               (setf tray :open))
              ((:open :close :stop)
               (print ">>> OPEN")
               (setf tray :open))
              ((:close :open _)
               (print ">>> CLOSE")
               (setf tray :close))
              ((:play :close :stop)
               (print ">>> PLAY")
               (setf player :play))
              ((:play :open _)
               (print ">>> CLOSE")
               (setf tray :close)
               (print ">>> PLAY")
               (setf player :play))
              ((:stop _ _)
               (print ">>> STOP")
               (setf player :stop))
              (t
               (warn "Ignore action: ~a for tray: ~a, player: ~a."
                     action tray player)
               :ignore)))))
  (funcall cd-player :play)
  (funcall cd-player :open)
  (funcall cd-player :open)
  (funcall cd-player :play)
  (funcall cd-player :stop)
  (funcall cd-player :open)
  (funcall cd-player :close)
  (print-status cd-player))

(defmacro case* (keyform &body cases)
  `(cond ,@(mapcar #`(,(if (consp (car a1))
                         `(and
                           ,@(loop for k in keyform
                                   for v in (car a1)
                                   unless (eq v '_)
                                   append `((eq ,k ,v))))
                         t)
                       ,@(cdr a1))
            cases)))