A CommonLisp Implementation of the programming language "ModanShogi".

modanshogi.lisp

;;; ref. http://github.com/yhara/ShogiModan

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package :modanshogi)
    (defpackage :modanshogi
      (:use #+:xyzzy :lisp
            #-:xyzzy :common-lisp))))

(provide 'modanshogi)

(in-package :modanshogi)
(export '(parse-kifu run compile-and-run))

(defvar *delimiter-chars* "*△▲")
(defvar *operator-chars*  "と歩金銀桂香龍馬玉王飛角")
(defvar *operators*
  #(:mov :add :sub :mul :div :mod :push :pop :putc :putn :jumpif :jumpifp))
(defvar *column-chars*    "同１２３４５６７８９")
(defvar *row-chars*       "　一二三四五六七八九")


;;; conditions
(define-condition kifu-error (error)
  (kifu)
  (:report
   (lambda (c s)
     (format s "kifu-error at :~{~A~}" (kifu-error-kifu c)))))

(define-condition runtime-error (error)
  (op col row stack cond)
  (:report
   (lambda (c s)
     (format s "runtime-error~%~A~% on ~S(X: ~A Y: ~A)~% stack:[~{~A~^,~}]"
	     (runtime-error-cond c)
	     (runtime-error-op c)
	     (runtime-error-col c)
	     (runtime-error-row c)
	     (runtime-error-stack c)))))


;;; parser
(defun readinst (is c)
  (let* ((chars (list #1=(read-char is nil nil) #1# #1#))
	 (inst (mapcar #'position chars
		       (list *column-chars* *row-chars* *operator-chars*))))
    (when (some #'null inst)
      (error 'kifu-error :kifu (cons c chars)))
    (list (svref *operators* (caddr inst)) (car inst) (cadr inst))))

(defun parse-kifu (source)
  (let ((table (make-hash-table :test 'eql))
	(i 0) insts last)
    (with-input-from-string (is source)
      (do ((c #1=(read-char is nil nil) #1#))
	  ((null c))
	(when (find c *delimiter-chars*)
	  (case c
	    (#\* (let ((label (read is)))
		   (setf (gethash label table) i)
		   (push (list :label label 0) insts)))
	    (t (let ((inst (readinst is c)))
		 (when (= (cadr inst) 0)
		   (setf (cdr inst) (cdr last)))
		 (push (setq last inst) insts))))
	  (incf i)))
      (values (nreverse insts) table))))


;;; evaluator
(defun evaluate (insts jumptbl)
  (do ((insts (apply #'vector insts))
       (reg (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9)))
       (stack (list))
       (end (length insts))
       (cur 0 (1+ cur)))
      ((= cur end))
    (let* ((inst (aref insts cur))
	   (op (car inst))
	   (c (cadr inst))
	   (r (caddr inst)))
      (handler-case
	  (case op
	    (:mov (setf #1=(aref reg c) #2=(aref reg r)))
	    (:add (incf #1# #2#))
	    (:sub (decf #1# #2#))
	    (:mul (setf #1# (* #1# #2#)))
	    (:div (setf #1# (/ #1# #2#)))
	    (:mod (setf #1# (mod #1# #2#)))
	    (:push (push #1# stack))
	    (:pop (setf #1# (pop stack)))
	    (:putc (princ (code-char (round #1#))))
	    (:putn (princ #1#))
	    (:jumpif (when (/= #1# 0)
		       (setq cur (gethash #2# jumptbl))))
	    (:jumpifp (when (>= #1# 0)
			(setq cur (gethash #2# jumptbl))))
	    (:label t))
	(error (c)
	  #3=(error 'runtime-error
		    :cond c
		    :op op :col c :row r :stack stack)))
      (unless cur #3#))))

(defun run (src)
  (multiple-value-call #'evaluate (parse-kifu src)))


;;; compiler
(defmacro w/uniq (names &body body)
  `(let ,(mapcar #'(lambda (s)
		     `(,s (make-symbol ,(symbol-name s))))
		 (if (consp names) names (list names)))
     ,@body))

(defun compile% (src)
  (w/uniq (greg gstack glabel gstart)
    (let ((clauses (list))
	  (exprs (list gstart)))
      (dolist (insts (parse-kifu src))
	(let ((op (car insts))
	      (c (cadr insts))
	      (r (caddr insts)))
	  (if (eq op :label)
	      (progn
		(push c exprs)
		(push (nreverse exprs) clauses)
		(setq exprs (list c)))
	    (let ((x `(aref ,greg ,c))
		  (y `(aref ,greg ,r)))
	      (push
	       (case op
		 (:mov `(setf ,x ,y))
		 (:add `(incf ,x ,y))
		 (:sub `(decf ,x ,y))
		 (:mul `(setf ,x (* ,x ,y)))
		 (:div `(setf ,x (/ ,x ,y)))
		 (:mod `(setf ,x (mod ,x ,y)))
		 (:push `(push ,x ,gstack))
		 (:pop `(setf ,x (pop ,gstack)))
		 (:putc `(princ (code-char (round ,x))))
		 (:putn `(princ ,x))
		 (:jumpif `(when (/= ,x 0) (return ,y)))
		 (:jumpifp `(when (>= ,x 0) (return ,y))))
	       exprs)))))
      (push nil exprs)
      (push (reverse exprs) clauses)
      `(let ((,greg (make-array 10 :initial-contents '(0 1 2 3 4 5 6 7 8 9)))
	     (,gstack (list)))
	 (do ((,glabel ',gstart
	       (block ()
		 (case ,glabel
		   ,@(reverse clauses)))))
	     ((null ,glabel)))))))


(defun compile-and-run (src)
  (w/uniq (gfn)
    (eval
     `(progn
	(compile (defun ,gfn () ,(compile% src)))
	(,gfn)))))


(defvar *kifu-fib-1to1k*
  "▲９九金 △８七金 ▲６四歩 △５五歩 ▲６六銀 △６五銀 ▲７七金 △７六金 *1 ▲７二角 △７一歩 ▲８四王 △５八玉 ▲８八龍 △８九歩 ▲９二馬 △１一飛 *2"
  "fork of http://github.com/yhara/ShogiModan/blob/master/examples/fib1000.modan")

(defvar *kifu-fib-10k*
  "▲９九金 △８七金 ▲６四歩 △５五歩 ▲６六銀 △同　銀 ▲７七金 △７六金 *1 ▲７二角 △７一歩 ▲８八龍 △８九歩 ▲９二馬 △１一飛 *2 ▲８四王 △５八玉 "
  "print fib(10000)")

(defvar *kifu-hw-strict*
  "▲２六歩    △６二銀    ▲６六歩    △７一銀    ▲５六歩    △６二金
▲６八金    △６四歩    ▲６九金    △６三金    ▲６八玉    △５二玉
▲５九金右  △６二金    ▲５八金直  △６三金    ▲５七金    △６二金
▲５九金    △６五歩    ▲６七金    △６三金    ▲５八金    △５一金
▲５九金    △５四歩    ▲５五歩    △５三玉    ▲５七玉    △４二銀
▲６八玉    △５二金    ▲５八金    △５一金    ▲５七金上  △５二金
▲５八金    △５一金    ▲５七金上  △５二金    ▲５八金    △３一銀
▲５七玉    △４二玉    ▲５四歩    △同　金    ▲５五歩    △５一金
▲５四歩    △４一金    ▲５六玉    △５一金    ▲６五玉    △５七歩
▲３六歩    △３二玉    ▲５九金    △６一金    ▲６九金    △５一金
▲５七金    △６二金    ▲５六玉    △６三金    ▲５八金上  △７四金
▲５五玉    △４四歩    ▲３四金    △同　歩    ▲５九金    △３五金
▲４八金    △３六金    ▲６七金    △２六金    ▲３八金    △３六金
▲４八金    △３三玉    ▲５七金上  △２六金    ▲４六金    △２五金
▲４五金    △同　歩    ▲３五歩    △同　金    ▲５七金    △４三金
▲５六金    △４二玉"
  "from http://yowaken.dip.jp/tdiary/20100402.html#p01")