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

   1 ;;; chess-scid.el --- A game database that uses SCID for storage/retrieval
   2
   3 ;; Copyright (C) 2002, 2004, 2008  Free Software Foundation, Inc.
   4
   5 ;; Author: John Wiegley <johnw@gnu.org>
   6 ;; Maintainer: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: games, processes
   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 ;; The advantage of SCID is that it's much faster than PGN, and far, far more
  25 ;; compact.
  26 ;;
  27 ;; SCID offers a Tcl-based command-line interface, tcscid, which is what
  28 ;; this module uses to query SCID databases.
  29
  30 ;;; Code:
  31
  32 (require 'chess-game)
  33 (require 'chess-message)
  34 (require 'chess-pgn)
  35
  36 (chess-message-catalog 'english
  37   '((failed-load     . "Failed to load game %d from ChessDB")
  38     (failed-find-end . "Failed to locate end of game %d in ChessDB")))
  39
  40 (defvar chess-scid-process)
  41
  42 (make-variable-buffer-local 'chess-scid-process)
  43
  44 (defsubst chess-scid-send (string)
  45   (process-send-string chess-scid-process (concat string "\n")))
  46
  47 (defun chess-scid-get-result (command)
  48   (let ((here (point-max)) (iterations 10))
  49     (chess-scid-send command)
  50     (accept-process-output chess-scid-process)
  51     (while (and (> (setq iterations (1- iterations)) 0)
  52                 (eobp))
  53       (accept-process-output chess-scid-process 1 0 t))
  54     (if (= here (point-max))
  55         (error "chess-scid: '%s' failed to produce any output" command))
  56     (goto-char (point-max))
  57     (skip-chars-backward " \t\n\r%")
  58     (prog1
  59         (buffer-substring here (point))
  60       (erase-buffer))))
  61
  62 (defun chess-scid-handler (event &rest args)
  63   (cond
  64    ((eq event 'open)
  65     (let* ((db-file (if (string-match "\\.sg3\\'" (car args))
  66                         (car args)
  67                       (concat (car args) ".sg3")))
  68            (db-base (and (string-match "\\`\\(.+\\)\\.sg3\\'" db-file)
  69                          (match-string 1 db-file))))
  70       (if (and db-base (file-readable-p db-file))
  71           (let* ((buffer (generate-new-buffer " *chess-scid*"))
  72                  (proc (start-process "*chess-scid*" buffer
  73                                       (or (executable-find "tcscid")
  74                                           (executable-find "tcchessdb")))))
  75             (if (and proc (eq (process-status proc) 'run))
  76                 (with-current-buffer buffer
  77                   (accept-process-output proc)
  78                   (setq chess-scid-process proc)
  79                   (if (= 1 (string-to-number
  80                             (chess-scid-get-result
  81                              (format "sc_base open %s"
  82                                      (expand-file-name db-base)))))
  83                       buffer
  84                     (kill-process proc)
  85                     (kill-buffer buffer)
  86                     nil))
  87               (kill-buffer buffer)
  88               nil)))))
  89
  90    ((eq event 'close)
  91     (chess-scid-send "sc_base close\nexit")
  92     (while (eq (process-status chess-scid-process) 'run)
  93       (sit-for 0 250)))
  94
  95    ((eq event 'read-only-p)
  96     (if (zerop (string-to-number (chess-scid-get-result "sc_base isReadOnly")))
  97         nil
  98       t))
  99
 100    ((eq event 'filename)
 101     (chess-scid-get-result "sc_base filename"))
 102
 103    ((eq event 'count)
 104     (string-to-number (chess-scid-get-result "sc_base numGames")))
 105
 106    ((eq event 'read)
 107     ;; clear the buffer, since we don't need old data here any more, and it
 108     ;; can accumulate without bound during running of the validation tests
 109     (erase-buffer)
 110     (process-send-string chess-scid-process
 111                          (format "sc_game load %d\n" (1+ (car args))))
 112     (accept-process-output chess-scid-process)
 113     (let ((here (point-max))
 114           (iterations 10)
 115           found)
 116       (process-send-string chess-scid-process "sc_game pgn\n")
 117       (accept-process-output chess-scid-process)
 118       (goto-char here)
 119       (while (and (> (setq iterations (1- iterations)) 0)
 120                   (not (and (or (looking-at "\\[")
 121                                 (and (search-forward "[" nil t)
 122                                      (goto-char (match-beginning 0))))
 123                             (setq found t))))
 124         (accept-process-output chess-scid-process 1 0 t))
 125       (if (not found)
 126           (chess-error 'failed-load (1+ (car args)))
 127         (setq iterations 10 found nil here (point))
 128         (while (and (> (setq iterations (1- iterations)) 0)
 129                     (not (and (re-search-forward "\\(\\*\\|1-0\\|0-1\\|1/2-1/2\\)" nil t)
 130                               (goto-char (match-beginning 0))
 131                               (setq found t))))
 132           (accept-process-output chess-scid-process 1 0 t))
 133         (if (not found)
 134             (chess-error 'failed-find-end (1+ (car args)))
 135           (goto-char here)
 136           (let ((game (chess-pgn-to-game)))
 137             (when game
 138               (chess-game-set-data game 'database (current-buffer))
 139               (chess-game-set-data game 'database-index (car args))
 140               (chess-game-set-data game 'database-count (chess-scid-handler 'count))
 141               game))))))
 142
 143    ((and (eq event 'query)
 144          (eq (car args) 'tree-search))
 145     (if (string=
 146          (chess-scid-get-result
 147           (format "sc_game import \"%s\""
 148                   (with-temp-buffer
 149                     (chess-pgn-insert-plies
 150                      (cadr args) 1 (chess-game-plies (cadr args)))
 151                     (insert " " (or (chess-game-tag (cadr args) "Result") "*"))
 152                     (buffer-string))))
 153          "PGN text imported with no errors or warnings.")
 154         (let ((here (point-max)))
 155           (chess-scid-send "sc_tree search")
 156           (accept-process-output chess-scid-process)
 157           (goto-char here)
 158           (let ((lines (list t)))
 159             (while
 160                 (re-search-forward
 161                  (concat "\\s-*\\([1-9][0-9]*\\):\\s-+\\([^ ]+\\)\\s-+"
 162                          "\\([0-9]+\\):\\s-*\\([0-9.]+\\)%\\s-+"
 163                          "\\([0-9.]+\\)%\\s-+\\([0-9]+\\|    \\)\\s-+"
 164                          "\\([0-9]+\\|    \\)\\s-+\\([0-9]+\\|    \\)\\s-+"
 165                          "\\([0-9.]+\\)%")
 166                  nil t)
 167               (let ((move (match-string 2))
 168                     (freq (string-to-number (match-string 3)))
 169                     (score (string-to-number (match-string 5)))
 170                     (avgelo (string-to-number (match-string 6)))
 171                     (perf (string-to-number (match-string 7)))
 172                     (avgyear (string-to-number (match-string 8)))
 173                     (draws (string-to-number (match-string 9))))
 174                 (nconc lines
 175                        (list
 176                         (append
 177                          (list move freq score draws)
 178                          (cond
 179                           ((and (zerop avgyear) (zerop avgelo) (zerop perf))
 180                            nil)
 181                           ((and (zerop avgelo) (zerop perf))
 182                            (list avgyear))
 183                           (t
 184                            (list
 185                             (unless (zerop avgyear) avgyear)
 186                             (unless (zerop avgelo) avgelo)
 187                             (unless (zerop perf) perf)))))))))
 188             (when (re-search-forward
 189                    (concat "TOTAL:\\s-+\\([0-9]+\\):100.0%\\s-+"
 190                            "\\([0-9.]+\\)%\\s-+\\([0-9]+\\|    \\)\\s-+"
 191                            "\\([0-9]+\\|    \\)\\s-+\\([0-9]+\\|    \\)\\s-+"
 192                            "\\([0-9.]+\\)%") nil t)
 193               (goto-char (point-max))
 194               (append
 195                (list (string-to-number (match-string 1))
 196                      (string-to-number (match-string 2))
 197                      (string-to-number (match-string 6)))
 198                (cdr lines)))))
 199       (error "Unable to import game")))
 200
 201    ((eq event 'write)
 202     (chess-scid-handler 'replace (car args) 0))
 203
 204    ((eq event 'replace)
 205     (unless (chess-scid-handler 'read-only-p)
 206       (let ((index (or (1+ (cadr args))
 207                        (chess-game-data (car args) 'database-index))))
 208         (chess-scid-send
 209          (format "sc_game import \"%s\""
 210                  (with-temp-buffer
 211                    (chess-pgn-insert-plies
 212                     (car args) 1 (chess-game-plies (car args)))
 213                    (insert (or (chess-game-tag (car args) "Result") "*"))
 214                    (buffer-string))))
 215         (dolist (tag (chess-game-tags (car args)))
 216           ;; jww (2002-05-01): how do I set extra tags?
 217           (unless (string= (car tag) "TimeControl")
 218             (chess-scid-send
 219              (concat "sc_game tags set "
 220                      (cond
 221                       ((string= (car tag) "Event")     "-event")
 222                       ((string= (car tag) "Site")      "-site")
 223                       ((string= (car tag) "Date")      "-date")
 224                       ((string= (car tag) "Round")     "-round")
 225                       ((string= (car tag) "White")     "-white")
 226                       ((string= (car tag) "WhiteElo")  "-whiteElo")
 227                       ((string= (car tag) "Black")     "-black")
 228                       ((string= (car tag) "BlackElo")  "-blackElo")
 229                       ((string= (car tag) "Result")    "-result")
 230                       ((string= (car tag) "ECO")       "-eco")
 231                       ((string= (car tag) "EventDate") "-eventdate")
 232                       ((string= (car tag) "Extra")     "-extra"))
 233                      " \"" (cdr tag) "\""))))
 234         (chess-scid-send (format "sc_game save %d" index)))))))
 235
 236 (provide 'chess-scid)
 237
 238 ;;; chess-scid.el ends here