Tetrlang Interpreter for xyzzy

gistfile1.cl

;;; Tetrlang Interpreter for xyzzy

;;; 元ネタ
;;; わーい、テトリス言語 Tetrlang 完成したよー＼（＾o＾）／
;;; http://d.hatena.ne.jp/athos/20100707/tetrlang

(defpackage :tetrlang
  (:use :lisp :editor))

(in-package :tetrlang)
(export '(run))

(defparameter *tetramino*
  '((:ms (0 0 0 1 1 1 1 2) (0 0 0 1 -1 1 1 0))
    (:mz (0 0 0 1 -1 1 -1 2) (0 0 1 0 1 1 2 1))
    (:ml (0 0 0 1 -1 1 -2 1) (0 0 1 0 1 1 1 2) (0 0 0 1 1 0 2 0) (0 0 0 1 0 2 1 2))
    (:mj (0 0 0 1 1 1 2 1) (0 0 0 1 0 2 1 0) (0 0 0 1 0 2 -1 2) (0 0 1 0 2 0 2 1))
    (:mt (0 0 0 1 -1 1 1 1) (0 0 0 1 0 2 1 1) (0 0 0 1 -1 1 0 2) (0 0 1 0 1 1 2 0))
    (:mo (0 0 0 1 1 1 1 0))
    (:mi (0 0 0 1 0 2 0 3))
    (:m- (0 0 1 0 2 0 3 0))))

(defun whitec (c)
  (not (char/= c #\SPC #\x8140)))

(defun guess-type (mino)
  (let* ((ox (caar mino))
	 (oy (cdar mino))
	 (m (mapcan (lambda (c) (list (- (car c) ox) (- (cdr c) oy))) mino)))
    (car (find-if (lambda (mt) (find m mt :test 'equal)) *tetramino*))))

(defun parse (src)
  (let* ((lines (split-string src #\LFD))
	 (w (apply #'max (mapcar #'length lines)))
	 (h (length lines))
	 (pad (make-sequence 'string w :initial-element #\SPC))
	 (field (make-array (list h w) :initial-contents
			    (mapcar #'(lambda (l) (subseq (concat l pad) 0 w)) lines)))
	 (marks (make-array (list h w)))
	 minos
	 insts)
    (labels
	((rec (x y)
	   (let ((chr (aref field y x))
		 (cells (list (cons x y))))
	     (dotimes (i 3)
	       (let ((_x (+ x i -1))
		     (_y (+ y (mod i 2))))
		 (when (and (< -1 _x w) (< -1 _y h)
			    (not #1=(aref marks _y _x))
			    (char= chr (aref field _y _x)))
		   (setf #1# t)
		   (mapc (lambda (c) (push c cells)) (rec _x _y)))))
	     (nreverse cells))))
      (#2=dotimes (y h)
       (#2# (x w)
	(unless (or (whitec #3=(aref field y x))
		    #4=(aref marks y x))
	  (setf #4# t)
	  (let ((mino (rec x y)))
	    (when (/= (length mino) 4)
	      (error (format nil "malformed mino: ~S" mino) 'simple-error))
	    (push (guess-type mino) insts))))))
    (nreverse insts)))

(defun run (src &optional (is *standard-input*) (os *standard-output*))
  (let* ((tape-length 1000)
	 (code (coerce (parse src) 'vector))
	 (len (length code))
	 (jump (make-hash-table)))
    (do* ((i 0 (1+ i)) (stack))
	((= i len) (when stack (error "syntax error, unexpected EOF, expecting J Block" 'simple-error)))
      (case (aref code i)
	(:ml (push i stack))
	(:mj (unless stack (error "Unexpected J Block" 'simple-error))
	 (let ((j (pop stack)))
	   (setf (gethash j jump) i (gethash i jump) j)))))
    (do* ((tape (make-array tape-length :initial-element 0))
	  (pos 0)
	  (cur 0 (1+ cur)))
	((= cur len) (values tape pos))
      (case (aref code cur)
	(:mt (incf #1=(aref tape pos)))
	(:mo (decf #1#))
	(:ms (incf pos))
	(:mz (decf pos))
	(:m- (setf #1# (char-code (read-char is))))
	(:mi (princ (code-char #1#) os))
	(:ml (when (= 0 #1#) (setq cur #2=(gethash cur jump))))
	(:mj (when (> #1# 0) (setq cur #2#)))))))


(in-package "user")

(defun eval-tetrlang-region-with-input (from to stdin-str)
  (interactive "r\nstetrlang> ")
  (let ((src (buffer-substring from to))
	(outbuf (create-new-buffer "*tetrlang console*")))
    (with-input-from-string (is stdin-str)
      (with-output-to-buffer (outbuf)
	(handler-case
	    (tetrlang::run src is)
	  (end-of-file (c) t))))
    (pop-to-buffer outbuf t)))

(defun eval-tetrlang-region (from to)
  (interactive "r")
  (eval-tetrlang-region-with-input from to ""))

(defun eval-tetrlang-buffer ()
  (interactive)
  (eval-tetrlang-region (point-min) (point-max)))

(defun eval-tetrlang-buffer-with-input (stdin-str)
  (interactive "stetrlang> ")
  (eval-tetrlang-region-with-input (point-min) (point-max) stdin-str))
  
(provide "tetrlang")