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

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