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

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