code.delx.au - gnu-emacs-elpa/blob - chess-pgn.el

   1 ;;; chess-pgn.el --- Convert a chess game to/from Portable Game Notation (PGN)
   2
   3 ;; Copyright (C) 2002, 2004, 2008, 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Maintainer: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: files, games
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; Portable Game Notation (PGN) is a plain text computer-processible format for
  25 ;; recording chess games (both the moves and related data).
  26 ;;
  27 ;; Here is a sample game in PGN format:
  28 ;;
  29 ;; [Event "F/S Return Match"]
  30 ;; [Site "Belgrade, Serbia Yugoslavia|JUG"]
  31 ;; [Date "1992.11.04"]
  32 ;; [Round "29"]
  33 ;; [White "Fischer, Robert J."]
  34 ;; [Black "Spassky, Boris V."]
  35 ;; [Result "1/2-1/2"]
  36 ;;
  37 ;; 1. e4 e5 2. Nf3 Nc6 3. Bb5 a6 {This opening is called the Ruy Lopez.}
  38 ;; 4. Ba4 Nf6 5. O-O Be7 6. Re1 b5 7. Bb3 d6 8. c3 O-O 9. h3 Nb8  10. d4 Nbd7
  39 ;; 11. c4 c6 12. cxb5 axb5 13. Nc3 Bb7 14. Bg5 b4 15. Nb1 h6 16. Bh4 c5 17. dxe5
  40 ;; Nxe4 18. Bxe7 Qxe7 19. exd6 Qf6 20. Nbd2 Nxd6 21. Nc4 Nxc4 22. Bxc4 Nb6
  41 ;; 23. Ne5 Rae8 24. Bxf7+ Rxf7 25. Nxf7 Rxe1+ 26. Qxe1 Kxf7 27. Qe3 Qg5 28. Qxg5
  42 ;; hxg5 29. b3 Ke6 30. a3 Kd6 31. axb4 cxb4 32. Ra5 Nd5 33. f3 Bc8 34. Kf2 Bf5
  43 ;; 35. Ra7 g6 36. Ra6+ Kc5 37. Ke1 Nf4 38. g3 Nxh3 39. Kd2 Kb5 40. Rd6 Kc5 41. Ra6
  44 ;; Nf2 42. g4 Bd3 43. Re6 1/2-1/2
  45 ;;
  46 ;; This module provides functions for converting to/from PGN format:
  47 ;;
  48 ;;    chess-game-to-pgn
  49 ;;    chess-pgn-to-game
  50 ;;
  51 ;; and a mode for viewing/editing PGN files:
  52 ;;
  53 ;;    chess-pgn-mode
  54
  55 ;;; Code:
  56
  57 (require 'chess-algebraic)
  58 (require 'chess-fen)
  59 (require 'chess-ply)
  60 (require 'chess-message)
  61
  62 (eval-when-compile
  63   (require 'pcomplete nil t))
  64
  65 (defvar chess-pgn-fill-column 60)
  66
  67 (chess-message-catalog 'english
  68   '((pgn-read-error  . "Error reading move: %s")
  69     (pgn-parse-error . "Error parsing PGN syntax")))
  70
  71 (defun chess-pgn-read-plies (game position &optional top-level)
  72   (let ((plies (list t)) (begin (point)) move-beg prevpos)
  73     (catch 'done
  74       (while (not (eobp))
  75         (cond
  76          ((looking-at "[1-9][0-9]*\\.[. ]*")
  77           (goto-char (match-end 0)))
  78
  79          ((looking-at chess-algebraic-regexp-ws)
  80           (setq move-beg (point))
  81           (goto-char (match-end 0))
  82           (skip-syntax-backward " ")
  83           (setq prevpos position)
  84           (let* ((move (buffer-substring-no-properties move-beg (point)))
  85                  (ply (condition-case err
  86                           (chess-algebraic-to-ply position move)
  87                         (error
  88                          (message "PGN: %s" (buffer-substring begin (point-max)))
  89                          (error (error-message-string err))))))
  90             (unless ply
  91               (chess-error 'pgn-read-error move))
  92             (setq position (chess-ply-next-pos ply))
  93             (nconc plies (list ply))))
  94
  95          ((and top-level
  96                (looking-at "\\(\\*\\|1-0\\|0-1\\|1/2-1/2\\)"))
  97           (goto-char (match-end 0))
  98           (chess-game-set-tag game "Result" (match-string-no-properties 0))
  99           (unless (eq t (car (last plies)))
 100             (cond
 101              ((string= "1/2-1/2" (match-string 1))
 102               (nconc plies (list (chess-ply-create
 103                                   (chess-ply-next-pos (car (last plies)))
 104                                   t :drawn))))
 105              (t
 106               (nconc plies (list (chess-ply-create*
 107                                   (chess-ply-next-pos (car (last plies)))))))))
 108           (throw 'done t))
 109
 110          ((looking-at "{")
 111           (forward-char)
 112           (let ((begin (point)))
 113             (search-forward "}")
 114             (forward-char)
 115             (chess-pos-add-annotation position (buffer-substring-no-properties
 116                                                 begin (- (point) 2)))))
 117          ((looking-at "(")
 118           (forward-char)
 119           (skip-chars-forward " \t\n")
 120           (chess-pos-add-annotation prevpos
 121                                     (chess-pgn-read-plies game prevpos)))
 122
 123          ((and (not top-level)
 124                (looking-at ")"))
 125           (forward-char)
 126           (throw 'done t))
 127
 128          (t
 129           (if (eq t (car (last plies)))
 130               (error "PGN parser: Expected a ply here: '%s'"
 131                      (buffer-substring (point) (point-max))))
 132           (nconc plies (list (chess-ply-create*
 133                               (chess-ply-next-pos (car (last plies))))))
 134           (throw 'done t)))
 135         (skip-chars-forward " \t\n\r")))
 136     (cdr plies)))
 137
 138 (defun chess-pgn-to-game (&optional string)
 139   "Convert PGN notation at point into a chess game.
 140 Optionally use the supplied STRING instead of the current buffer."
 141   (if string
 142       (with-temp-buffer
 143         (insert string)
 144         (goto-char (point-min))
 145         (chess-pgn-parse))
 146     (chess-pgn-parse)))
 147
 148 (defun chess-pgn-parse ()
 149   (if (or (looking-at "\\[")
 150           (and (search-forward "[" nil t)
 151                (goto-char (match-beginning 0))))
 152       (let ((game (chess-game-create))
 153             (begin (point)))
 154         (chess-game-set-tags game nil)
 155         (while (looking-at "\\[\\(\\S-+\\)\\s-+\\(\".*?\"\\)\\][ \t\n\r]+")
 156           (chess-game-set-tag game (match-string-no-properties 1)
 157                               (let ((str (match-string-no-properties 2)))
 158                                 (substring str 1 (1- (length str)))))
 159           (goto-char (match-end 0)))
 160         (let ((fen (chess-game-tag game "FEN")))
 161           (if fen
 162               (chess-game-set-start-position game (chess-fen-to-pos fen)))
 163           (chess-game-set-plies game (chess-pgn-read-plies game (chess-game-pos game) t)))
 164         game)
 165     (error "Data not in legal PGN format: '%s'"
 166            (buffer-substring (point) (point-max)))))
 167
 168 (defun chess-pgn-insert-annotations (game index ply)
 169   (dolist (ann (chess-pos-annotations (chess-ply-pos ply)))
 170     (if (stringp ann)
 171         (insert "\n{" ann "}")
 172       (assert (listp ann))
 173       (chess-pgn-insert-plies game index ann))))
 174
 175 (defun chess-pgn-insert-plies (game index plies &optional
 176                                      for-black indented no-annotations)
 177   "NYI: Still have to implement INDENTED argument."
 178   (while plies
 179     (unless for-black
 180       (when (chess-ply-changes (car plies))
 181         (if (> (current-column) chess-pgn-fill-column)
 182             (insert ?\n))
 183         (insert (format "%d. %s" index (chess-ply-to-algebraic (car plies))))
 184         (unless no-annotations
 185           (chess-pgn-insert-annotations game index (car plies))))
 186       (setq plies (cdr plies) index (1+ index)))
 187     (when plies
 188       (when (chess-ply-changes (car plies))
 189         (when for-black
 190           (if (> (current-column) chess-pgn-fill-column)
 191               (insert ?\n))
 192           (insert (format "%d. ..." index))
 193           (setq for-black nil))
 194         (insert (format " %s" (chess-ply-to-algebraic (car plies))))
 195         (unless no-annotations
 196           (chess-pgn-insert-annotations game index (car plies))))
 197       (setq plies (cdr plies)))
 198     (if plies
 199         (insert ? ))))
 200
 201 (defvar chess-pgn-tag-order
 202   '("Event" "Site" "Date" "Round"
 203     "White" "WhiteElo" "Black" "BlackElo"
 204     "Result" "TimeControl"))
 205
 206 (defun chess-game-to-pgn (game &optional indented to-string)
 207   "Convert a chess GAME to PGN notation.
 208 If INDENTED is non-nil, indent the move texts.
 209 If TO-STRING is non-nil, return a string instead of inserting the resulting
 210 PGN text."
 211   (if to-string
 212       (with-temp-buffer
 213         (chess-insert-pgn game indented)
 214         (buffer-string))
 215     (chess-insert-pgn game indented)))
 216
 217 (defun chess-member-index (tag)
 218   (let ((index 0)
 219         (tags chess-pgn-tag-order))
 220     (while tags
 221       (if (equal tag (car tags))
 222           (setq tags nil)
 223         (setq index (1+ index)
 224               tags (cdr tags))))
 225     index))
 226
 227 (defun chess-insert-pgn (game &optional indented)
 228   (let ((fen (chess-game-tag game "FEN"))
 229         (first-pos (chess-game-pos game 0)))
 230     (when (and fen (not (string= fen (chess-pos-to-fen first-pos))))
 231       (chess-game-del-tag game "FEN")
 232       (setq fen nil))
 233     (if (and (not fen)
 234              (not (eq chess-starting-position first-pos)))
 235         (chess-game-set-tag game "FEN" (chess-pos-to-fen first-pos))))
 236   (dolist (tag (sort (copy-alist (chess-game-tags game))
 237                      (function
 238                       (lambda (left right)
 239                         (setq left (car left) right (car right))
 240                         (let ((l-idx (chess-member-index left))
 241                               (r-idx (chess-member-index right)))
 242                           (cond
 243                            ((and l-idx (not r-idx)) t)
 244                            ((and (not l-idx) r-idx) nil)
 245                            ((and l-idx r-idx) (< l-idx r-idx))
 246                            (t (string-lessp left right))))))))
 247     (insert (format "[%s \"%s\"]\n" (car tag) (cdr tag))))
 248   (insert ?\n)
 249   (let ((begin (point)))
 250     (chess-pgn-insert-plies game 1 (chess-game-plies game))
 251     (insert (or (chess-game-tag game "Result") "*") ?\n)))
 252
 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 254 ;;
 255 ;; chess-pgn-mode for editing and browsing PGN files.
 256 ;;
 257
 258 (require 'chess-database)
 259 (require 'chess-file)
 260
 261 (defvar chess-pgn-database nil
 262   "Chess database object.")
 263 (make-variable-buffer-local 'chess-pgn-database)
 264
 265 (defvar chess-pgn-display nil
 266   "If non-nil, the chess display object used for this buffer.")
 267 (make-variable-buffer-local 'chess-pgn-display)
 268
 269 (defvar chess-pgn-current-game)
 270 (defvar chess-pgn-current-index)
 271
 272 (make-variable-buffer-local 'chess-pgn-current-game)
 273 (make-variable-buffer-local 'chess-pgn-current-index)
 274
 275 (chess-message-catalog 'english
 276   '((could-not-read-pgn . "Could not read or find a PGN game")))
 277
 278 ;;;###autoload
 279 (defun chess-pgn-read (&optional file)
 280   "Read and display a PGN game after point."
 281   (interactive "P")
 282   (if (or file (not (search-forward "[Event " nil t)))
 283       (setq file (read-file-name "Read a PGN game from file: ")))
 284   (if file
 285       (find-file file))
 286   (let ((game (chess-pgn-to-game)))
 287     (if game
 288         (chess-display-set-game
 289          (setq chess-pgn-display (chess-create-display t))
 290          game)
 291       (chess-error 'could-not-read-pgn))))
 292
 293 (eval-after-load "pcomplete"
 294   '(progn
 295      (make-variable-buffer-local 'pcomplete-default-completion-function)
 296      (make-variable-buffer-local 'pcomplete-command-completion-function)
 297      (make-variable-buffer-local 'pcomplete-parse-arguments-function)))
 298
 299 ;;;###autoload
 300 (define-derived-mode chess-pgn-mode text-mode "PGN"
 301   "A mode for editing chess PGN files."
 302   (setq comment-start "{"
 303         comment-end "}")
 304
 305   (modify-syntax-entry ?\{ "<")
 306   (modify-syntax-entry ?\} ">")
 307   (modify-syntax-entry ?\" "\"")
 308
 309   (if (fboundp 'font-lock-mode)
 310       (font-lock-mode 1))
 311
 312   (let ((map (current-local-map)))
 313     (define-key map [(control ?c) (control ?c)] 'chess-pgn-show-position)
 314     (define-key map [mouse-2] 'chess-pgn-mouse-show-position)
 315
 316     ;;(define-key map [(control ?m)] 'chess-pgn-move)
 317     ;;(define-key map [space] 'chess-pgn-move)
 318     (define-key map [? ] 'chess-pgn-insert-and-show-position)
 319
 320     (when (require 'pcomplete nil t)
 321       (setq pcomplete-default-completion-function 'chess-pgn-completions)
 322       (setq pcomplete-command-completion-function 'chess-pgn-completions)
 323       (setq pcomplete-parse-arguments-function 'chess-pgn-current-word)
 324       (define-key map [tab] 'chess-pgn-complete-move))))
 325
 326 ;;;###autoload
 327 (defalias 'pgn-mode 'chess-pgn-mode)
 328
 329 (defvar chess-pgn-bold-face 'bold)
 330
 331 (defconst chess-pgn-move-regexp
 332   (concat "[^0-9]\\(\\([1-9][0-9]*\\)\\.\\s-+"
 333           "\\(\\.\\.\\.\\|" chess-algebraic-regexp "\\)"
 334           "\\(\\s-+\\(" chess-algebraic-regexp "\\)\\)?\\)"))
 335
 336 (if (fboundp 'font-lock-add-keywords)
 337     (font-lock-add-keywords
 338      'chess-pgn-mode
 339      (list (list "\\[\\(\\S-+\\)\\s-+\".*\"\\]" 1 'font-lock-keyword-face)
 340            (cons "\\(1-0\\|0-1\\|1/2-1/2\\|\\*\\)$" 'chess-pgn-bold-face))))
 341
 342 ;;;###autoload
 343 (add-to-list 'auto-mode-alist '("\\.pgn\\'" . chess-pgn-mode))
 344
 345 (eval-after-load "mm-decode"
 346   '(unless (fboundp 'mm-display-pgn-inline)
 347      (defun mm-display-pgn-inline (handle)
 348        (mm-display-inline-fontify handle 'chess-pgn-mode))
 349      (push '("application/x-chess-pgn" mm-display-pgn-inline identity)
 350            mm-inline-media-tests)
 351      (push "application/x-chess-pgn" mm-inlined-types)
 352      (push "application/x-chess-pgn" mm-automatic-display)))
 353
 354 (defun chess-pgn-completions ()
 355   "Return a list of possible completions for the current move."
 356   (let ((position (chess-game-pos chess-pgn-current-game
 357                                   chess-pgn-current-index)))
 358     (while (pcomplete-here
 359             (mapcar 'chess-ply-to-algebraic
 360                     (chess-legal-plies position :color
 361                                        (chess-pos-side-to-move position)))))))
 362
 363 (defun chess-pgn-current-word ()
 364   (let ((here (point)))
 365     (if (setq chess-pgn-current-index (chess-pgn-index))
 366         (save-restriction
 367           (narrow-to-region (match-beginning 3) here)
 368           (pcomplete-parse-buffer-arguments)))))
 369
 370 (defun chess-pgn-complete-move ()
 371   (interactive)
 372   (save-restriction
 373     (narrow-to-region (point-min) (point))
 374     (chess-pgn-read-game))
 375   (if (eq last-command 'chess-pgn-complete-move)
 376       (setq last-command 'pcomplete))
 377   (call-interactively 'pcomplete))
 378
 379 (defun chess-pgn-index (&optional location)
 380   "Return the move index associated with point."
 381   (save-excursion
 382     (when location (goto-char location))
 383     (if (re-search-backward chess-pgn-move-regexp nil t)
 384         (let* ((index (string-to-number (match-string 2)))
 385                (first-move (match-string 3))
 386                (second-move (match-string 14))
 387                (ply (1+ (* 2 (1- index)))))
 388           (if second-move
 389               (setq ply (1+ ply)))
 390           ply))))
 391
 392 (defun chess-pgn-read-game ()
 393   "Load a database to represent this file if not already up."
 394   (unless chess-pgn-database
 395     (setq chess-pgn-database
 396           (chess-database-open buffer-file-name 'chess-file)))
 397
 398   ;; a hack for speed's sake to read the current game text
 399   (save-excursion
 400     (let ((locations chess-file-locations)
 401           (here (point))
 402           last-location index)
 403       (while locations
 404         (if (> (car locations) here)
 405             (setq locations nil)
 406           (setq last-location locations
 407                 locations (cdr locations))))
 408       (setq index (if last-location
 409                       (- (length chess-file-locations) (length last-location))
 410                     0))
 411       (when (or (null chess-pgn-current-game)
 412                 (/= index (chess-game-data chess-pgn-current-game
 413                                            'database-index)))
 414         (setq chess-pgn-current-game
 415               (chess-database-read chess-pgn-database index))))))
 416
 417 (defun chess-pgn-create-display ()
 418   "Return the move index associated with point."
 419   ;; now find what position we're at in the game
 420   (save-excursion
 421     (when chess-pgn-current-game
 422       (let ((index (chess-pgn-index)))
 423         (if (or (and (or (null chess-pgn-display)
 424                          (not (buffer-live-p chess-pgn-display)))
 425                      (let ((chess-game-inhibit-events t))
 426                        (setq chess-pgn-display (chess-create-display t))))
 427                 (/= (chess-game-data chess-pgn-current-game 'database-index)
 428                     (or (chess-game-data (chess-display-game chess-pgn-display)
 429                                          'database-index) -1)))
 430             (progn
 431               (chess-display-disable-popup chess-pgn-display)
 432               (chess-display-set-game chess-pgn-display
 433                                       chess-pgn-current-game index)
 434               (chess-game-set-tag (chess-display-game chess-pgn-display)
 435                                   'database-index
 436                                   (chess-game-data chess-pgn-current-game
 437                                                    'database-index)))
 438           (chess-display-set-index chess-pgn-display index))
 439         (chess-display-popup chess-pgn-display)))))
 440
 441 (defun chess-pgn-visualize ()
 442   "Visualize the move for the PGN game under point.
 443 This does not require that the buffer be in PGN mode."
 444   (let (game)
 445     (save-excursion
 446       (if (search-backward "[Event " nil t)
 447           (setq game (chess-pgn-to-game))))
 448     (if game
 449         (let ((chess-pgn-current-game game))
 450           (chess-pgn-show-position))
 451       (chess-error 'could-not-read-pgn))))
 452
 453 (defun chess-pgn-show-position ()
 454   (interactive)
 455   (if (not (eq major-mode 'chess-pgn-mode))
 456       (chess-pgn-visualize)
 457     (chess-pgn-read-game)
 458     (chess-pgn-create-display)))
 459
 460 (defun chess-pgn-mouse-show-position (event)
 461   (interactive "e")
 462   (if (fboundp 'event-window)           ; XEmacs
 463       (progn
 464         (set-buffer (window-buffer (event-window event)))
 465         (and (event-point event) (goto-char (event-point event))))
 466     (set-buffer (window-buffer (posn-window (event-start event))))
 467     (goto-char (posn-point (event-start event))))
 468   (chess-pgn-show-position))
 469
 470 (defun chess-pgn-insert-and-show-position ()
 471   (interactive)
 472   (self-insert-command 1)
 473   (chess-pgn-show-position))
 474
 475 (provide 'chess-pgn)
 476
 477 ;;; chess-pgn.el ends here