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)
  58 (require 'chess-algebraic)
  59 (require 'chess-display)
  60 (require 'chess-fen)
  61 (require 'chess-game)
  62 (require 'chess-ply)
  63 (require 'chess-message)
  64 (require 'mm-decode)
  65 (require 'mm-view)
  66 (require 'pcomplete)
  67
  68 (defvar chess-pgn-fill-column 60)
  69
  70 (chess-message-catalog 'english
  71   '((pgn-read-error  . "Error reading move: %s")
  72     (pgn-parse-error . "Error parsing PGN syntax")))
  73
  74 (defun chess-pgn-read-plies (game position &optional top-level)
  75   (let ((plies (list t)) (begin (point)) move-beg prevpos)
  76     (catch 'done
  77       (while (not (eobp))
  78         (cond
  79          ((looking-at "[1-9][0-9]*\\.[. ]*")
  80           (goto-char (match-end 0)))
  81
  82          ((looking-at chess-algebraic-regexp-ws)
  83           (setq move-beg (point))
  84           (goto-char (match-end 0))
  85           (skip-syntax-backward " ")
  86           (setq prevpos position)
  87           (let* ((move (buffer-substring-no-properties move-beg (point)))
  88                  (ply (condition-case err
  89                           (chess-algebraic-to-ply position move)
  90                         (error
  91                          (message "PGN: %s" (buffer-substring begin (point-max)))
  92                          (error (error-message-string err))))))
  93             (unless ply
  94               (chess-error 'pgn-read-error move))
  95             (setq position (chess-ply-next-pos ply))
  96             (nconc plies (list ply))))
  97
  98          ((and top-level
  99                (looking-at "\\(\\*\\|1-0\\|0-1\\|1/2-1/2\\)"))
 100           (goto-char (match-end 0))
 101           (chess-game-set-tag game "Result" (match-string-no-properties 0))
 102           (unless (eq t (car (last plies)))
 103             (cond
 104              ((string= "1/2-1/2" (match-string 1))
 105               (nconc plies (list (chess-ply-create
 106                                   (chess-ply-next-pos (car (last plies)))
 107                                   t :drawn))))
 108              (t
 109               (nconc plies (list (chess-ply-create*
 110                                   (chess-ply-next-pos (car (last plies)))))))))
 111           (throw 'done t))
 112
 113          ((looking-at "{")
 114           (forward-char)
 115           (let ((begin (point)))
 116             (search-forward "}")
 117             (forward-char)
 118             (chess-pos-add-annotation position (buffer-substring-no-properties
 119                                                 begin (- (point) 2)))))
 120          ((looking-at "(")
 121           (forward-char)
 122           (skip-chars-forward " \t\n")
 123           (chess-pos-add-annotation prevpos
 124                                     (chess-pgn-read-plies game prevpos)))
 125
 126          ((and (not top-level)
 127                (looking-at ")"))
 128           (forward-char)
 129           (throw 'done t))
 130
 131          (t
 132           (if (eq t (car (last plies)))
 133               (error "PGN parser: Expected a ply here: '%s'"
 134                      (buffer-substring (point) (point-max))))
 135           (nconc plies (list (chess-ply-create*
 136                               (chess-ply-next-pos (car (last plies))))))
 137           (throw 'done t)))
 138         (skip-chars-forward " \t\n\r")))
 139     (cdr plies)))
 140
 141 (defun chess-pgn-to-game (&optional string)
 142   "Convert PGN notation at point into a chess game.
 143 Optionally use the supplied STRING instead of the current buffer."
 144   (if string
 145       (with-temp-buffer
 146         (insert string)
 147         (goto-char (point-min))
 148         (chess-pgn-parse))
 149     (chess-pgn-parse)))
 150
 151 (defun chess-pgn-parse ()
 152   (if (or (looking-at "\\[")
 153           (and (search-forward "[" nil t)
 154                (goto-char (match-beginning 0))))
 155       (let ((game (chess-game-create)))
 156         (chess-game-set-tags game nil)
 157         (while (looking-at (rx
 158                             ?[ (group (one-or-more (not (syntax whitespace))))
 159                                (one-or-more (syntax whitespace))
 160                                (syntax string-quote)
 161                                (group (*? not-newline))
 162                                (syntax string-quote)
 163                                ?]
 164                             (one-or-more (char ?  ?\n ?\r ?\t))))
 165           (chess-game-set-tag game (match-string-no-properties 1)
 166                               (match-string-no-properties 2))
 167           (goto-char (match-end 0)))
 168         (let ((fen (chess-game-tag game "FEN")))
 169           (when fen
 170             (chess-game-set-start-position game (chess-fen-to-pos fen))))
 171         (chess-game-set-plies game (chess-pgn-read-plies game (chess-game-pos game) t))
 172         game)
 173     (error "Data not in legal PGN format: '%s'"
 174            (buffer-substring (point) (point-max)))))
 175
 176 (defun chess-pgn-insert-annotations (game index ply)
 177   (dolist (ann (chess-pos-annotations (chess-ply-pos ply)))
 178     (if (stringp ann)
 179         (insert "\n{" ann "}")
 180       (cl-assert (listp ann))
 181       (chess-pgn-insert-plies game index ann))))
 182
 183 (defun chess-pgn-insert-plies (game index plies &optional
 184                                      for-black indented no-annotations)
 185   "NYI: Still have to implement INDENTED argument."
 186   (while plies
 187     (unless for-black
 188       (when (chess-ply-changes (car plies))
 189         (if (> (current-column) chess-pgn-fill-column)
 190             (insert ?\n))
 191         (insert (format "%d. %s" index (chess-ply-to-algebraic (car plies))))
 192         (unless no-annotations
 193           (chess-pgn-insert-annotations game index (car plies))))
 194       (setq plies (cdr plies) index (1+ index)))
 195     (when plies
 196       (when (chess-ply-changes (car plies))
 197         (when for-black
 198           (if (> (current-column) chess-pgn-fill-column)
 199               (insert ?\n))
 200           (insert (format "%d. ..." index))
 201           (setq for-black nil))
 202         (insert (format " %s" (chess-ply-to-algebraic (car plies))))
 203         (unless no-annotations
 204           (chess-pgn-insert-annotations game index (car plies))))
 205       (setq plies (cdr plies)))
 206     (if plies
 207         (insert ? ))))
 208
 209 (defvar chess-pgn-tag-order
 210   '("Event" "Site" "Date" "Round"
 211     "White" "WhiteElo" "Black" "BlackElo"
 212     "Result" "TimeControl"))
 213
 214 (defun chess-game-to-pgn (game &optional indented to-string)
 215   "Convert a chess GAME to PGN notation.
 216 If INDENTED is non-nil, indent the move texts.
 217 If TO-STRING is non-nil, return a string instead of inserting the resulting
 218 PGN text."
 219   (if to-string
 220       (with-temp-buffer
 221         (chess-insert-pgn game indented)
 222         (buffer-string))
 223     (chess-insert-pgn game indented)))
 224
 225 (defun chess-member-index (tag)
 226   (let ((index 0)
 227         (tags chess-pgn-tag-order))
 228     (while tags
 229       (if (equal tag (car tags))
 230           (setq tags nil)
 231         (setq index (1+ index)
 232               tags (cdr tags))))
 233     index))
 234
 235 (defun chess-insert-pgn (game &optional indented)
 236   (let ((fen (chess-game-tag game "FEN"))
 237         (first-pos (chess-game-pos game 0)))
 238     (when (and fen (not (string= fen (chess-pos-to-fen first-pos))))
 239       (chess-game-del-tag game "FEN")
 240       (setq fen nil))
 241     (if (and (not fen)
 242              (not (eq chess-starting-position first-pos)))
 243         (chess-game-set-tag game "FEN" (chess-pos-to-fen first-pos))))
 244   (dolist (tag (sort (copy-alist (chess-game-tags game))
 245                      (function
 246                       (lambda (left right)
 247                         (setq left (car left) right (car right))
 248                         (let ((l-idx (chess-member-index left))
 249                               (r-idx (chess-member-index right)))
 250                           (cond
 251                            ((and l-idx (not r-idx)) t)
 252                            ((and (not l-idx) r-idx) nil)
 253                            ((and l-idx r-idx) (< l-idx r-idx))
 254                            (t (string-lessp left right))))))))
 255     (insert (format "[%s \"%s\"]\n" (car tag) (cdr tag))))
 256   (insert ?\n)
 257   (chess-pgn-insert-plies game 1 (chess-game-plies game))
 258   (insert (or (chess-game-tag game "Result") "*") ?\n))
 259
 260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 261 ;;
 262 ;; chess-pgn-mode for editing and browsing PGN files.
 263 ;;
 264
 265 (require 'chess-database)
 266
 267 (defvar chess-pgn-database nil
 268   "Chess database object.")
 269 (make-variable-buffer-local 'chess-pgn-database)
 270
 271 (defvar chess-pgn-display nil
 272   "If non-nil, the chess display object used for this buffer.")
 273 (make-variable-buffer-local 'chess-pgn-display)
 274
 275 (defvar chess-pgn-current-game)
 276 (defvar chess-pgn-current-index)
 277
 278 (make-variable-buffer-local 'chess-pgn-current-game)
 279 (make-variable-buffer-local 'chess-pgn-current-index)
 280
 281 (chess-message-catalog 'english
 282   '((could-not-read-pgn . "Could not read or find a PGN game")))
 283
 284 ;;;###autoload
 285 (defun chess-pgn-read (&optional file)
 286   "Read and display a PGN game after point."
 287   (interactive "P")
 288   (if (or file (not (search-forward "[Event " nil t)))
 289       (setq file (read-file-name "Read a PGN game from file: ")))
 290   (if file
 291       (find-file file))
 292   (let ((game (chess-pgn-to-game)))
 293     (if game
 294         (chess-display-set-game
 295          (setq chess-pgn-display (chess-create-display t))
 296          game)
 297       (chess-error 'could-not-read-pgn))))
 298
 299 (defvar chess-pgn-mode-map
 300   (let ((map (make-sparse-keymap)))
 301     (set-keymap-parent map text-mode-map)
 302     (define-key map [(control ?c) (control ?c)] 'chess-pgn-show-position)
 303     (define-key map [mouse-2] 'chess-pgn-mouse-show-position)
 304
 305     ;;(define-key map [(control ?m)] 'chess-pgn-move)
 306     ;;(define-key map [space] 'chess-pgn-move)
 307     (define-key map [? ] 'chess-pgn-insert-and-show-position)
 308     (define-key map [tab] 'chess-pgn-complete-move)
 309     map))
 310
 311 ;;;###autoload
 312 (define-derived-mode chess-pgn-mode text-mode "PGN"
 313   "A mode for editing chess PGN files."
 314   (setq comment-start "{"
 315         comment-end "}")
 316
 317   (modify-syntax-entry ?\{ "<")
 318   (modify-syntax-entry ?\} ">")
 319   (modify-syntax-entry ?\" "\"")
 320
 321   (if (fboundp 'font-lock-mode)
 322       (font-lock-mode 1))
 323   (set (make-local-variable 'pcomplete-default-completion-function)
 324        'chess-pgn-completions)
 325   (set (make-local-variable 'pcomplete-command-completion-function)
 326        'chess-pgn-completions)
 327   (set (make-local-variable 'pcomplete-parse-arguments-function)
 328        'chess-pgn-current-word))
 329
 330 ;;;###autoload
 331 (defalias 'pgn-mode 'chess-pgn-mode)
 332
 333 (defvar chess-pgn-bold-face 'bold)
 334
 335 (defconst chess-pgn-move-regexp
 336   (concat "[^0-9]\\(\\([1-9][0-9]*\\)\\.\\s-+"
 337           "\\(\\.\\.\\.\\|" chess-algebraic-regexp "\\)"
 338           "\\(\\s-+\\(" chess-algebraic-regexp "\\)\\)?\\)"))
 339
 340 (if (fboundp 'font-lock-add-keywords)
 341     (font-lock-add-keywords
 342      'chess-pgn-mode
 343      (list (list "\\[\\(\\S-+\\)\\s-+\".*\"\\]" 1 'font-lock-keyword-face)
 344            (cons "\\(1-0\\|0-1\\|1/2-1/2\\|\\*\\)$" 'chess-pgn-bold-face))))
 345
 346 ;;;###autoload
 347 (add-to-list 'auto-mode-alist '("\\.pgn\\'" . chess-pgn-mode))
 348
 349 (eval-after-load "mm-decode"
 350   '(unless (fboundp 'mm-display-pgn-inline)
 351      (defun mm-display-pgn-inline (handle)
 352        (mm-display-inline-fontify handle 'chess-pgn-mode))
 353      (push '("application/x-chess-pgn" mm-display-pgn-inline identity)
 354            mm-inline-media-tests)
 355      (push "application/x-chess-pgn" mm-inlined-types)
 356      (push "application/x-chess-pgn" mm-automatic-display)))
 357
 358 (defun chess-pgn-completions ()
 359   "Return a list of possible completions for the current move."
 360   (let ((position (chess-game-pos chess-pgn-current-game
 361                                   chess-pgn-current-index)))
 362     (while (pcomplete-here
 363             (mapcar 'chess-ply-to-algebraic
 364                     (chess-legal-plies position :color
 365                                        (chess-pos-side-to-move position)))))))
 366
 367 (defun chess-pgn-current-word ()
 368   (let ((here (point)))
 369     (if (setq chess-pgn-current-index (chess-pgn-index))
 370         (save-restriction
 371           (narrow-to-region (match-beginning 3) here)
 372           (pcomplete-parse-buffer-arguments)))))
 373
 374 (defun chess-pgn-complete-move ()
 375   (interactive)
 376   (save-restriction
 377     (narrow-to-region (point-min) (point))
 378     (chess-pgn-read-game))
 379   (if (eq last-command 'chess-pgn-complete-move)
 380       (setq last-command 'pcomplete))
 381   (call-interactively 'pcomplete))
 382
 383 (defun chess-pgn-index (&optional location)
 384   "Return the move index associated with point."
 385   (save-excursion
 386     (when location (goto-char location))
 387     (if (re-search-backward chess-pgn-move-regexp nil t)
 388         (let* ((index (string-to-number (match-string 2)))
 389                ;; (first-move (match-string 3))
 390                (second-move (match-string 14))
 391                (ply (1+ (* 2 (1- index)))))
 392           (if second-move
 393               (setq ply (1+ ply)))
 394           ply))))
 395
 396 (defvar chess-file-locations nil)
 397
 398 (defun chess-pgn-read-game ()
 399   "Load a database to represent this file if not already up."
 400   (unless chess-pgn-database
 401     (setq chess-pgn-database
 402           (chess-database-open buffer-file-name 'chess-file)))
 403
 404   ;; a hack for speed's sake to read the current game text
 405   (save-excursion
 406     (let ((locations chess-file-locations)
 407           (here (point))
 408           last-location index)
 409       (while locations
 410         (if (> (car locations) here)
 411             (setq locations nil)
 412           (setq last-location locations
 413                 locations (cdr locations))))
 414       (setq index (if last-location
 415                       (- (length chess-file-locations) (length last-location))
 416                     0))
 417       (when (or (null chess-pgn-current-game)
 418                 (/= index (chess-game-data chess-pgn-current-game
 419                                            'database-index)))
 420         (setq chess-pgn-current-game
 421               (chess-database-read chess-pgn-database index))))))
 422
 423 (defvar chess-game-inhibit-events)
 424
 425 (defun chess-pgn-create-display ()
 426   "Return the move index associated with point."
 427   ;; now find what position we're at in the game
 428   (save-excursion
 429     (when chess-pgn-current-game
 430       (let ((index (chess-pgn-index)))
 431         (if (or (and (or (null chess-pgn-display)
 432                          (not (buffer-live-p chess-pgn-display)))
 433                      (let ((chess-game-inhibit-events t))
 434                        (setq chess-pgn-display (chess-create-display t))))
 435                 (/= (chess-game-data chess-pgn-current-game 'database-index)
 436                     (or (chess-game-data (chess-display-game chess-pgn-display)
 437                                          'database-index) -1)))
 438             (progn
 439               (chess-display-disable-popup chess-pgn-display)
 440               (chess-display-set-game chess-pgn-display
 441                                       chess-pgn-current-game index)
 442               (chess-game-set-tag (chess-display-game chess-pgn-display)
 443                                   'database-index
 444                                   (chess-game-data chess-pgn-current-game
 445                                                    'database-index)))
 446           (chess-display-set-index chess-pgn-display index))
 447         (chess-display-popup chess-pgn-display)))))
 448
 449 (defun chess-pgn-visualize ()
 450   "Visualize the move for the PGN game under point.
 451 This does not require that the buffer be in PGN mode."
 452   (let (game)
 453     (save-excursion
 454       (if (search-backward "[Event " nil t)
 455           (setq game (chess-pgn-to-game))))
 456     (if game
 457         (let ((chess-pgn-current-game game))
 458           (chess-pgn-show-position))
 459       (chess-error 'could-not-read-pgn))))
 460
 461 (defun chess-pgn-show-position ()
 462   (interactive)
 463   (if (not (eq major-mode 'chess-pgn-mode))
 464       (chess-pgn-visualize)
 465     (chess-pgn-read-game)
 466     (chess-pgn-create-display)))
 467
 468 (defun chess-pgn-mouse-show-position (event)
 469   (interactive "e")
 470   (if (fboundp 'event-window)           ; XEmacs
 471       (progn
 472         (set-buffer (window-buffer (event-window event)))
 473         (and (event-point event) (goto-char (event-point event))))
 474     (set-buffer (window-buffer (posn-window (event-start event))))
 475     (goto-char (posn-point (event-start event))))
 476   (chess-pgn-show-position))
 477
 478 (defun chess-pgn-insert-and-show-position ()
 479   (interactive)
 480   (self-insert-command 1)
 481   (chess-pgn-show-position))
 482
 483 (provide 'chess-pgn)
 484
 485 ;;; chess-pgn.el ends here