Download
(provide 'chinese-chess)
(eval-when-compile
(require 'cl))
(require 'cus-edit)
(defvar chinese-chess-red-face '(:foreground "red"))
(defvar chinese-chess-black-face 'default)
(defvar chinese-chess-selected-face '(:background "cyan"))
(defvar chinese-chess-last-move-face '(:background "pink1"))
(defconst chinese-chess-width 9)
(defconst chinese-chess-height 10)
(defconst chinese-chess-col-offset 8)
(defconst chinese-chess-row-offset 5
"First line lists buttons, Second line display state, the third
display chessmen")
(defvar chinese-chess-display-coords t)
(defvar chinese-chess-board nil)
(defvar chinese-chess-display
`((r . ,(propertize "车" 'face chinese-chess-black-face))
(n . ,(propertize "马" 'face chinese-chess-black-face))
(b . ,(propertize "象" 'face chinese-chess-black-face))
(a . ,(propertize "士" 'face chinese-chess-black-face))
(k . ,(propertize "将" 'face chinese-chess-black-face))
(p . ,(propertize "兵" 'face chinese-chess-black-face))
(c . ,(propertize "炮" 'face chinese-chess-black-face))
(R . ,(propertize "車" 'face chinese-chess-red-face))
(N . ,(propertize "馬" 'face chinese-chess-red-face))
(B . ,(propertize "相" 'face chinese-chess-red-face))
(A . ,(propertize "仕" 'face chinese-chess-red-face))
(K . ,(propertize "帅" 'face chinese-chess-red-face))
(P . ,(propertize "卒" 'face chinese-chess-red-face))
(C . ,(propertize "炮" 'face chinese-chess-red-face))))
(defvar chinese-chess-type-name
'((red . "红方")
(black . "黑方")))
(defvar chinese-chess-next-type 'red)
(defvar chinese-chess-selected-man nil)
(defvar chinese-chess-history nil)
(defvar chinese-chess-init-round nil)
(defvar chinese-chess-message-updated nil)
(defvar chinese-chess-message-interval 3)
(defvar chinese-chess-change-turn-hook nil)
(defvar chinese-chess-begin-hook nil)
(defvar chinese-chess-mode-map nil)
(defvar chinese-chess-mode-menu nil)
(unless chinese-chess-mode-map
(setq chinese-chess-mode-map (make-sparse-keymap))
(let ((map chinese-chess-mode-map))
(define-key map "R" 'chinese-chess-begin)
(define-key map "B" 'chinese-chess-backward)
(define-key map "S" 'chinese-chess-save)
(define-key map "T" 'chinese-chess-change-turn)
(define-key map "L" 'chinese-chess-load)
(define-key map "D" 'chinese-chess-puts-mode)
(define-key map "F" 'chinese-chess-board-fen)
(define-key map "m" 'chinese-chess-move)
(define-key map "C" 'chinese-chess-toggle-coords)
(define-key map (kbd "<down-mouse-1>") 'chinese-chess-select)
(define-key map (kbd "<down-mouse-3>") 'chinese-chess-mouse-move)
(define-key map (kbd "<mouse-1>") 'undefined)
(define-key map (kbd "<mouse-2>") 'undefined)
(define-key map (kbd "<mouse-3>") 'undefined)
(define-key map (kbd "<mouse-4>") 'undefined)
(define-key map (kbd "<mouse-5>") 'undefined)
(define-key map (kbd "<drag-mouse-1>") 'undefined)
(define-key map (kbd "<M-drag-mouse-1>") 'undefined)
(define-key map (kbd "<M-down-mouse-1>") 'undefined)
(define-key map (kbd "<M-mouse-1>") 'undefined)
(define-key map (kbd "<M-mouse-2>") 'undefined)
(define-key map (kbd "<M-mouse-3>") 'undefined)
(define-key map (kbd "<double-mouse-1>") 'undefined))
(easy-menu-define chinese-chess-mode-menu
chinese-chess-mode-map
"Menu for chinese chess"
(cons "Chess"
'(["Reset" chinese-chess-begin "R"]
["Back" chinese-chess-backward "B"]
["Save" chinese-chess-save "S"]
["Load" chinese-chess-load "L"]
["Turn" chinese-chess-type-turn "T"]
["Put" chinese-chess-puts-mode "D"]
["Coords" chinese-chess-toggle-coords "C"]))))
(defvar chinese-chess-button-map
(let ((map (make-sparse-keymap)))
(define-key map "\r" 'push-button)
(define-key map [mouse-1] 'push-button)
(define-key map [?\t] 'forward-button)
(define-key map "\e\t" 'backward-button)
(define-key map [backtab] 'backward-button)
map))
(defvar chinese-chess-buffer "*chess*" "buffer name of game")
(defsubst chinese-chess-other-type (type)
(if (eq type 'black)
'red 'black))
(defun chinese-chess-add-history (hist-var elem)
(set hist-var (cons elem (symbol-value hist-var))))
(defun chinese-chess-round ()
(+ chinese-chess-init-round
(/ (length chinese-chess-history) 2)))
(defun chinese-chess-buffer ()
(let ((buf (get-buffer chinese-chess-buffer)))
(and (buffer-live-p buf)
buf)))
(defsubst chinese-chess-row (row type)
"For convention of row"
(if (eq type 'red)
(1+ (- chinese-chess-height row))
row))
(defsubst chinese-chess-line2row (line)
(+ (/ (- line chinese-chess-row-offset) 2) 1))
(defsubst chinese-chess-column2col (columnn)
(+ (/ (- columnn chinese-chess-col-offset) 4) 1))
(defun chinese-chess-goto (row col)
(goto-char (point-min))
(forward-line (+ chinese-chess-row-offset (* 2 (1- row))))
(move-to-column (+ chinese-chess-col-offset (* 4 (1- col)))))
(defun chinese-chess-draw-board ()
(let ((inhibit-read-only t))
(erase-buffer)
(dotimes (i chinese-chess-row-offset)
(insert "\n"))
(mapc (lambda (line)
(insert-char ? chinese-chess-col-offset)
(insert " " line "\n"))
(split-string
"+---+---+---+---+---+---+---+---+
| | | | \\ | / | | | |
+---+---+---+---+---+---+---+---+
| | | | / | \\ | | | |
+---+---+---+---+---+---+---+---+
| | | | | | | | |
+---+---+---+---+---+---+---+---+
| | | | | | | | |
+---+---+---+---+---+---+---+---+
| |
+---+---+---+---+---+---+---+---+
| | | | | | | | |
+---+---+---+---+---+---+---+---+
| | | | | | | | |
+---+---+---+---+---+---+---+---+
| | | | \\ | / | | | |
+---+---+---+---+---+---+---+---+
| | | | / | \\ | | | |
+---+---+---+---+---+---+---+---+" "\n"))
(add-text-properties (point-min) (point)
'(read-only t rear-sticky t front-sticky t))
(insert (propertize "\n" 'rear-nonsticky t))
(chinese-chess-put-buttons
(cons "重新开始" 'chinese-chess-begin)
(cons "悔棋" 'chinese-chess-backward))
(if chinese-chess-display-coords
(chinese-chess-toggle-coords 1))))
(defun chinese-chess-toggle-coords (arg)
(interactive "P")
(let ((inhibit-read-only t))
(setq chinese-chess-display-coords
(if (null arg)
(not chinese-chess-display-coords)
(> (prefix-numeric-value arg) 0)))
(save-excursion
(goto-char (point-min))
(forward-line (1- chinese-chess-row-offset))
(if chinese-chess-display-coords
(progn
(delete-region (point) (progn (forward-line 1) (point)))
(insert-char ? chinese-chess-col-offset)
(insert " a b c d e f g h i\n")
(dotimes (i chinese-chess-height)
(move-to-column (- chinese-chess-col-offset 2))
(delete-char 1)
(insert (number-to-string (- 9 i)))
(forward-line 2)))
(delete-region (point) (progn (forward-line 1) (1- (point))))
(dotimes (i chinese-chess-height)
(move-to-column (- chinese-chess-col-offset 2))
(delete-char 1)
(insert " ")
(forward-line 2))))))
(defun chinese-chess-remove-man-at (row col)
(chinese-chess-board-set row col nil)
(let ((inhibit-read-only t))
(save-excursion
(chinese-chess-goto row col)
(delete-char 1)
(insert (if (= col 1) " +" "-+")))))
(defun chinese-chess-put-man (man &optional row col)
(let ((inhibit-read-only t))
(if row
(chinese-chess-man-set man 'row row)
(setq row (chinese-chess-man-get man 'row)))
(if col
(chinese-chess-man-set man 'col col)
(setq col (chinese-chess-man-get man 'col)))
(chinese-chess-goto row col)
(if (chinese-chess-board-get row col)
(chinese-chess-remove-man-at row col))
(delete-char 2)
(chinese-chess-board-set row col man)
(insert (propertize (chinese-chess-man-get man 'display)
'chessman man))))
(defsubst chinese-chess-valid-row (row)
(and (> row 0) (<= row chinese-chess-height)))
(defsubst chinese-chess-valid-col (col)
(and (> col 0) (<= col chinese-chess-width)))
(defsubst chinese-chess-board-get (row col)
(aref (aref chinese-chess-board (1- row)) (1- col)))
(defsubst chinese-chess-board-set (row col man)
(aset (aref chinese-chess-board (1- row)) (1- col) man))
(defun chinese-chess-coords-at (pos)
(save-excursion
(goto-char pos)
(setq row (chinese-chess-line2row (line-number-at-pos))
col (chinese-chess-column2col (current-column)))
(when (and (chinese-chess-valid-row row)
(chinese-chess-valid-col col))
(list row col))))
(defsubst chinese-chess-man-at (&optional pos)
(get-text-property (or pos (point)) 'chessman))
(defsubst chinese-chess-remove-man (man)
(chinese-chess-remove-man-at (chinese-chess-man-get man 'row)
(chinese-chess-man-get man 'col)))
(defun chinese-chess-reset-board ()
(chinese-chess-draw-board)
(setq chinese-chess-next-type
(if (eq (default-value 'chinese-chess-next-type) 'black)
'black 'red)
chinese-chess-selected-man nil
chinese-chess-history nil
chinese-chess-init-round 1
chinese-chess-board
(apply 'vector
(mapcar (lambda (i) (make-vector chinese-chess-width nil))
(number-sequence 1 chinese-chess-height)))))
(defun chinese-chess-read-fen (fen)
(let ((data (split-string fen))
(all (append "RNBAKPCrnbakpc" nil))
(i 1)
j men)
(dolist (row (split-string (car data) "/"))
(setq j 1)
(dolist (c (append row nil))
(if (and (>= c ?1) (<= c ?9))
(setq j (+ j (- c ?0)))
(if (member c all)
(progn
(push (list (intern (char-to-string c)) i j) men)
(setq j (1+ j)))
(error "Unknown chessman %c" c))))
(setq i (1+ i)))
(list men
(if (string= (cadr data) "w") 'red 'black)
(string-to-number (nth 5 data)))))
(defun chinese-chess-set-board (fen)
(interactive "sFen: ")
(chinese-chess-reset-board)
(let ((board (chinese-chess-read-fen fen)))
(mapc (lambda (args)
(chinese-chess-put-man (apply 'chinese-chess-make-man args)))
(car board))
(setq chinese-chess-next-type (cadr board)
chinese-chess-init-round (nth 2 board))
(chinese-chess-message (chinese-chess-type-message))))
(defun chinese-chess-make-man (name &optional row col)
(if row
(unless (chinese-chess-valid-row row)
(error "Row(%d) out of board, should between 1-%d" row chinese-chess-height)))
(if col
(unless (chinese-chess-valid-col col)
(error "Column(%d) out of board, should between 1-%d" col chinese-chess-width)))
(list (cons 'type (if (member name '(r n b a k c p)) 'black 'red))
(cons 'name name)
(cons 'row row)
(cons 'col col)
(cons 'rule (intern-soft (concat "chinese-chess-rule-"
(downcase (symbol-name name)))))
(cons 'display (assoc-default name chinese-chess-display))))
(defalias 'chinese-chess-copy-man 'copy-alist)
(defsubst chinese-chess-man-get (man attr)
(cdr (assoc attr man)))
(defsubst chinese-chess-man-set (man attr val)
(setcdr (assoc attr man) val))
(defun chinese-chess-pos-type (row)
(if (< row 6)
'black 'red))
(defun chinese-chess-row-men (row from to)
(if (< from to)
(delq nil
(mapcar
(lambda (i)
(chinese-chess-board-get row i))
(number-sequence (1+ from) (- to 1))))
(chinese-chess-row-men row to from)))
(defun chinese-chess-col-men (col from to)
(if (< from to)
(delq nil
(mapcar (lambda (i)
(chinese-chess-board-get i col))
(number-sequence (1+ from) (- to 1))))
(chinese-chess-col-men col to from)))
(defun chinese-chess-rule-check (man row col)
(let ((nman (chinese-chess-board-get row col)))
(when nman
(if (eq (chinese-chess-man-get nman 'type)
(chinese-chess-man-get man 'type))
(throw 'cannot-move 'same-type))))
(let* ((king (car(chinese-chess-lookup-board 'k)))
(men (chinese-chess-col-men (chinese-chess-man-get king 'col)
(chinese-chess-man-get king 'row)
(1+ chinese-chess-height))))
(if (and (> (length men) 1)
(eq (car men) man)
(eq (chinese-chess-man-get (cadr men) 'name) 'K))
(throw 'cannot-move 'king-meet))))
(defun chinese-chess-rule-r (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(or (and (= row nrow)
(= (length (chinese-chess-row-men row col ncol)) 0))
(and (= col ncol)
(= (length (chinese-chess-col-men col row nrow)) 0)))))
(defun chinese-chess-rule-a (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(and (if (< (chinese-chess-man-get man 'row) 4)
(< nrow 4)
(> nrow (chinese-chess-row 4 'red)))
(< ncol 7) (> ncol 3)
(= (abs (- nrow row)) 1)
(= (abs (- ncol col)) 1))))
(defun chinese-chess-rule-k (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(and (if (< (chinese-chess-man-get man 'row) 4)
(< nrow 4)
(> nrow (chinese-chess-row 4 'red)))
(let (men)
(if (eq (chinese-chess-pos-type nrow) 'black)
(setq men (chinese-chess-col-men
ncol (max nrow row) (1+ chinese-chess-height)))
(setq men (nreverse
(chinese-chess-col-men
ncol 0 (min nrow row)))))
(if (not (member
(chinese-chess-man-get (car men) 'name)
'(k K)))
t
(throw 'cannot-move 'king-meet)))
(< ncol 7) (> ncol 3)
(or (and (= row nrow)
(= (abs (- ncol col)) 1))
(and (= col ncol)
(= (abs (- nrow row)) 1))))))
(defun chinese-chess-rule-p (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(if (eq (chinese-chess-pos-type
(chinese-chess-man-get man 'row))
(chinese-chess-man-get man 'type))
(and (= col ncol)
(= (if (eq (chinese-chess-man-get man 'type) 'black)
(- nrow (chinese-chess-man-get man 'row))
(- (chinese-chess-man-get man 'row) nrow)) 1))
(let ((crow (if (eq (chinese-chess-man-get man 'type) 'black)
(- nrow (chinese-chess-man-get man 'row))
(- (chinese-chess-man-get man 'row) nrow))))
(or (and (= crow 1) (= col ncol))
(and (= crow 0) (= (abs (- col ncol)) 1)))))))
(defun chinese-chess-rule-b (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(and (eq (chinese-chess-pos-type
(chinese-chess-man-get man 'row))
(chinese-chess-man-get man 'type))
(= (abs (- row nrow)) 2)
(= (abs (- col ncol)) 2)
(null (chinese-chess-board-get (/ (+ row nrow) 2)
(/ (+ col ncol) 2))))))
(defun chinese-chess-rule-n (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col)))
(chinese-chess-rule-check man nrow ncol)
(if (= (abs (- row nrow)) 2)
(and (= (abs (- col ncol)) 1)
(null (chinese-chess-board-get (/ (+ row nrow) 2) col)))
(and (= (abs (- col ncol)) 2)
(= (abs (- row nrow)) 1)
(null (chinese-chess-board-get row (/ (+ col ncol) 2)))))))
(defun chinese-chess-rule-c (man nrow ncol)
(let ((row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col))
step)
(chinese-chess-rule-check man nrow ncol)
(and (if (= row nrow)
(setq step (length (chinese-chess-row-men row col ncol)))
(if (= col ncol)
(setq step (length (chinese-chess-col-men col row nrow)))))
(or (and (= step 1)
(chinese-chess-board-get nrow ncol))
(and (= step 0)
(null (chinese-chess-board-get nrow ncol)))))))
(defun chinese-chess-king-dangerous (type)
(let ((other (chinese-chess-other-type type))
(king (car (chinese-chess-lookup-board (if (eq type 'black) 'k 'K))))
row col
man)
(setq row (chinese-chess-man-get king 'row)
col (chinese-chess-man-get king 'col))
(catch 'danger
(dolist (r (number-sequence 1 chinese-chess-height))
(dolist (c (number-sequence 1 chinese-chess-width))
(setq man (chinese-chess-board-get r c))
(catch 'cannot-move
(if (and (eq (chinese-chess-man-get man 'type) other)
(member (chinese-chess-man-get man 'name)
'(r n c p R N C P))
(funcall (chinese-chess-man-get man 'rule)
man row col))
(throw 'danger t))))))))
(defun chinese-chess-lookup-board (name &optional all rows cols)
(let ((num (if all 2 1))
(have 0)
found man)
(or rows (setq rows (number-sequence 1 chinese-chess-height)))
(or cols (setq cols (number-sequence 1 chinese-chess-width)))
(catch 'found
(dolist (r rows)
(dolist (c cols)
(setq man (chinese-chess-board-get r c))
(when (eq (chinese-chess-man-get man 'name) name)
(setq have (1+ have))
(push man found)
(if (= have num)
(throw 'found man))))))
found))
(defun chinese-chess-put-buttons (&rest buttons)
"BUTTON is a cons cell like (LABEL . ACTION)"
(let ((inhibit-read-only t)
action)
(save-excursion
(goto-char (point-min))
(delete-region (point) (line-end-position))
(dolist (but buttons)
(insert-button (car but)
'keymap chinese-chess-button-map
'face 'custom-button
'action `(lambda (&rest ignore)
(funcall ',(cdr but)))
'mouse-action
`(lambda (&rest ignore)
(with-current-buffer (get-buffer chinese-chess-buffer)
(funcall ',(cdr but)))))
(insert " "))
(delete-char -3))))
(defun chinese-chess-message (msg)
(let ((inhibit-read-only t))
(save-excursion
(goto-char (point-min))
(forward-line 1)
(delete-region (point) (line-end-position))
(insert msg)
(setq chinese-chess-message-updated t))))
(defun chinese-chess-message-tempo (msg later-msg)
(chinese-chess-message (propertize msg 'face 'font-lock-warning-face))
(run-at-time chinese-chess-message-interval nil
`(lambda ()
(let ((buf (get-buffer chinese-chess-buffer)))
(when (and buf (buffer-live-p buf))
(with-current-buffer buf
(unless chinese-chess-message-updated
(chinese-chess-message ,later-msg)))))))
(setq chinese-chess-message-updated nil))
(defun chinese-chess-current-message ()
(save-excursion
(goto-char (point-min))
(forward-line 1)
(buffer-substring (point) (line-end-position))))
(defun chinese-chess-type-message ()
(concat
(assoc-default chinese-chess-next-type chinese-chess-type-name)
"执棋"))
(defun chinese-chess-state-message ()
(concat
(format "回合 %d: " (chinese-chess-round))
(chinese-chess-type-message)
(propertize
(cond ((chinese-chess-king-dangerous 'black)
(format " %s将军" (assoc-default 'red chinese-chess-type-name)))
((chinese-chess-king-dangerous 'red)
(format " %s将军" (assoc-default 'black chinese-chess-type-name)))
(t ""))
'face 'font-lock-warning-face)))
(defun chinese-chess-unselect-man ()
(when chinese-chess-selected-man
(goto-char (car chinese-chess-selected-man))
(mapc 'delete-overlay (overlays-at (point)))
(setq chinese-chess-selected-man nil)))
(defun chinese-chess-select-man (row col)
(when (chinese-chess-board-get row col)
(chinese-chess-goto row col)
(let ((man (chinese-chess-board-get row col))
(inhibit-read-only t))
(if (eq (chinese-chess-man-get man 'type)
chinese-chess-next-type)
(progn
(setq chinese-chess-selected-man
(cons (point-marker) man))
(overlay-put (make-overlay (point) (1+ (point)))
'face chinese-chess-selected-face))
(chinese-chess-message-tempo
(format "%s走棋" (assoc-default chinese-chess-next-type
chinese-chess-type-name))
(chinese-chess-current-message))))))
(defun chinese-chess-show-last-movement ()
(save-excursion
(mapc 'delete-overlay
(overlays-in (progn (goto-char (point-min))
(forward-line chinese-chess-row-offset)
(point))
(point-max)))
(let ((step (car chinese-chess-history)))
(chinese-chess-goto (car step) (cadr step))
(overlay-put (make-overlay (point) (+ (point) 1))
'face chinese-chess-last-move-face)
(chinese-chess-goto (nth 3 step) (nth 4 step))
(overlay-put (make-overlay (point) (min (+ (point) 3)
(line-end-position)))
'face chinese-chess-last-move-face))))
(defun chinese-chess-change-turn ()
(interactive)
(setq chinese-chess-next-type
(if (eq chinese-chess-next-type 'black)
'red 'black))
(chinese-chess-message (chinese-chess-state-message))
(run-hooks 'chinese-chess-change-turn-hook))
(defun chinese-chess-move-man (man nrow ncol)
(let ((rule (chinese-chess-man-get man 'rule))
(row (chinese-chess-man-get man 'row))
(col (chinese-chess-man-get man 'col))
reason)
(setq reason
(catch 'cannot-move
(when (funcall rule man nrow ncol)
(chinese-chess-add-history
'chinese-chess-history
(append (list nrow ncol
(chinese-chess-man-get man 'name)
row col)
(let ((removed (chinese-chess-board-get nrow ncol)))
(if removed
(list (chinese-chess-man-get removed 'name))))))
(chinese-chess-remove-man man)
(chinese-chess-put-man man nrow ncol)
(chinese-chess-show-last-movement)
(setq chinese-chess-selected-man nil)
(chinese-chess-change-turn))))
(cond ((eq reason 'same-type)
(chinese-chess-message-tempo
"不能吃自己的棋子"
(chinese-chess-current-message)))
((eq reason 'king-meet)
(chinese-chess-message-tempo
"将军相会"
(chinese-chess-current-message)))
(t (message nil)))))
(defun chinese-chess-select (event)
(interactive "e")
(let ((pos (event-end event))
coords)
(with-selected-window (posn-window pos)
(setq coords (chinese-chess-coords-at (posn-point pos)))
(if chinese-chess-selected-man
(chinese-chess-unselect-man))
(when coords
(apply 'chinese-chess-select-man coords)))))
(defun chinese-chess-mouse-move (event)
(interactive "e")
(let ((pos (event-end event))
coords)
(with-selected-window (posn-window pos)
(if (null chinese-chess-selected-man)
(chinese-chess-message-tempo
"先选择棋子"
(chinese-chess-current-message))
(setq coords (chinese-chess-coords-at (posn-point pos)))
(when coords
(chinese-chess-move-man (cdr chinese-chess-selected-man)
(car coords) (cadr coords)))))))
(defun chinese-chess-str-to-coords (str)
(let ((row (- 10 (- (aref str 1) ?0)))
(col (+ (- (aref str 0) ?a) 1)))
(if (and (chinese-chess-valid-row row)
(chinese-chess-valid-col col))
(list row col))))
(defun chinese-chess-move (str)
(interactive "sMove: ")
(setq str (downcase str))
(let ((select (chinese-chess-str-to-coords (substring str 0 2)))
(move (chinese-chess-str-to-coords
(substring str (if (= (aref str 3) ?-) 3 2))))
man)
(if (and select (setq man (apply 'chinese-chess-board-get select)))
(if (eq (chinese-chess-man-get man 'type)
chinese-chess-next-type)
(chinese-chess-move-man man (car move) (cadr move))
(chinese-chess-message-tempo
(format "%s走棋" (assoc-default chinese-chess-next-type chinese-chess-type-name))
(chinese-chess-current-message)))
(chinese-chess-message-tempo "输入错误" (chinese-chess-current-message)))))
(defun chinese-chess-backward ()
(interactive)
(if chinese-chess-history
(progn
(chinese-chess-unselect-man)
(let ((step (car chinese-chess-history))
removed)
(chinese-chess-remove-man-at (car step) (cadr step))
(chinese-chess-put-man
(chinese-chess-make-man (nth 2 step) (nth 3 step) (nth 4 step)))
(if (setq removed (nth 5 step))
(chinese-chess-put-man
(chinese-chess-make-man removed (car step) (cadr step)))))
(setq chinese-chess-history (cdr chinese-chess-history))
(chinese-chess-change-turn))
(chinese-chess-message-tempo "不能再悔棋了" (chinese-chess-current-message))))
(defun chinese-chess-save ()
(interactive)
(with-temp-buffer
(let ((file (read-file-name "Save to file: "))
(buf (get-buffer chinese-chess-buffer))
(standard-output (current-buffer)))
(when (and buf (buffer-live-p buf))
(insert "(\n;; chinese-chess-board-fen\n")
(insert (format "%S\n" (with-current-buffer buf
(chinese-chess-board-fen))))
(insert ";; chinese-chess-next-type\n")
(pp (buffer-local-value 'chinese-chess-next-type buf))
(insert "\n;; chinese-chess-history\n")
(pp (buffer-local-value 'chinese-chess-history buf))
(insert ")")
(write-file file)))))
(defun chinese-chess-load ()
(interactive)
(let ((file (read-file-name "Load file: "))
chessmen vars)
(setq vars
(with-temp-buffer
(insert-file-contents file)
(read (current-buffer))))
(when vars
(chinese-chess-set-board (car vars))
(setq chinese-chess-next-type (cadr vars)
chinese-chess-history (nth 2 vars)))))
(define-derived-mode chinese-chess-mode nil "Chinese-Chess"
"Play chinese chess game. Left mouse key to choose a chessman, right
mouse key to move the selected chessman. That is it. Enjoy yourself!"
(make-local-variable 'chinese-chess-next-type)
(make-local-variable 'chinese-chess-selected-man)
(make-local-variable 'chinese-chess-board)
(make-local-variable 'chinese-chess-message-updated)
(make-local-variable 'chinese-chess-history)
(chinese-chess-set-board
"rnbakabnr/9/1c5c1/p1p1p1p1p/9/9/P1P1P1P1P/1C5C1/9/RNBAKABNR w - - 0 1"))
(defun chinese-chess-begin ()
(interactive)
(with-current-buffer (get-buffer-create chinese-chess-buffer)
(chinese-chess-mode)
(run-hooks 'chinese-chess-begin-hook)
(select-window (display-buffer (current-buffer)))))
(defalias 'chinese-chess 'chinese-chess-begin)
(defun chinese-chess-puts-mode ()
(interactive)
(let ((inhibit-read-only t)
man)
(chinese-chess-reset-board)
(chinese-chess-put-buttons
(cons "结束" 'chinese-chess-puts-begin))
(chinese-chess-message "")
(save-excursion
(goto-char (point-min))
(forward-line 2)
(dolist (type '(black red))
(dolist (name '("r" "n" "b" "a" "k" "p" "c"))
(setq man (chinese-chess-make-man (intern
(if (eq type 'black)
name
(upcase name)))))
(insert (propertize (chinese-chess-man-get man 'display)
'chessman man)
" "))
(delete-char -2)
(forward-line 1)))
(define-key chinese-chess-mode-map [down-mouse-1] 'chinese-chess-puts-select)
(define-key chinese-chess-mode-map [down-mouse-3] 'chinese-chess-puts-put)))
(defun chinese-chess-puts-begin ()
(interactive)
(let ((type (intern (completing-read "哪方先走: "
(list "black" "red")
nil t)))
(inhibit-read-only t))
(if chinese-chess-selected-man
(chinese-chess-unselect-man))
(setq chinese-chess-next-type type
chinese-chess-selected-man nil
chinese-chess-history nil)
(chinese-chess-put-buttons
(cons "重新开始" 'chinese-chess-begin)
(cons "悔棋" 'chinese-chess-backward))
(goto-char (point-min))
(forward-line 2)
(delete-region (point) (progn (forward-line 1)
(line-end-position)))
(insert "\n")
(chinese-chess-message (chinese-chess-state-message))
(define-key chinese-chess-mode-map [down-mouse-1] 'chinese-chess-select)
(define-key chinese-chess-mode-map [down-mouse-3] 'chinese-chess-mouse-move)
(run-hooks 'chinese-chess-begin-hook)))
(defun chinese-chess-puts-select (event)
(interactive "e")
(let ((pos (event-end event))
(inhibit-read-only t))
(with-selected-window (posn-window pos)
(if chinese-chess-selected-man
(chinese-chess-unselect-man))
(goto-char (posn-point pos))
(when (chinese-chess-man-at (point))
(overlay-put (make-overlay (point) (1+ (point)))
'face chinese-chess-selected-face)
(setq chinese-chess-selected-man
(cons (point-marker) (chinese-chess-man-at (point))))))))
(defun chinese-chess-puts-put (event)
(interactive "e")
(let ((pos (event-end event))
coords)
(with-selected-window (posn-window pos)
(if (null chinese-chess-selected-man)
(chinese-chess-message-tempo
"先选择棋子"
(chinese-chess-current-message))
(let ((man (cdr chinese-chess-selected-man)))
(setq coords (chinese-chess-coords-at (posn-point pos)))
(when (chinese-chess-man-get man 'row)
(chinese-chess-remove-man man)
(chinese-chess-man-set man 'row nil))
(when coords
(chinese-chess-put-man (chinese-chess-copy-man man)
(car coords) (cadr coords))))))))
(defun chinese-chess-board-fen ()
(let ((fen "") j)
(dolist (i (number-sequence 1 chinese-chess-height))
(setq j 0)
(dolist (m (append (aref chinese-chess-board (1- i)) nil))
(if (null m)
(incf j)
(setq fen (concat fen
(if (> j 0) (number-to-string j) "")
(symbol-name (chinese-chess-man-get m 'name))))
(setq j 0)))
(setq fen (concat fen (if (> j 0) (number-to-string j) "") "/")))
(mapconcat 'identity
(list (substring fen 0 -1)
(if (eq chinese-chess-next-type 'black) "b" "w")
"-" "-" "0"
(number-to-string (chinese-chess-round)))
" ")))
(defun chinese-chess-copy-fen ()
(interactive)
(kill-new (chinese-chess-board-fen)))