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