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

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; A game database that uses SCID for storage/retrieval
   4 ;;
   5 ;; The advantage is that it's much faster than PGN, and far, far more
   6 ;; compact.
   7 ;;
   8
   9 (defvar chess-scid-process)
  10
  11 (make-variable-buffer-local 'chess-scid-process)
  12
  13 (defun chess-scid-get-result (command)
  14   (let ((here (point-max)))
  15     (process-send-string chess-scid-process command)
  16     (accept-process-output chess-scid-process)
  17     (goto-char (point-max))
  18     (while (memq (char-before) '(?  ?\t ?\n ?\r ?\%))
  19       (backward-char 1))
  20     (buffer-substring here (point))))
  21
  22 (defun chess-scid-handler (event &rest args)
  23   (cond
  24    ((eq event 'open)
  25     (if (file-readable-p (concat (car args) ".sg3"))
  26         (let* ((buffer (generate-new-buffer " *chess-scid*"))
  27                (proc (start-process "*chess-scid*" buffer
  28                                     (executable-find "tcscid"))))
  29           (if (and proc (eq (process-status proc) 'run))
  30               (with-current-buffer buffer
  31                 (accept-process-output proc)
  32                 (setq chess-scid-process proc)
  33                 (if (= 1 (string-to-int
  34                           (chess-scid-get-result
  35                            (format "sc_base open %s\n"
  36                                    (expand-file-name (car args))))))
  37                     buffer
  38                   (kill-process proc)
  39                   (kill-buffer buffer)
  40                   nil))
  41             (kill-buffer buffer)
  42             nil))))
  43
  44    ((eq event 'close)
  45     (process-send-string chess-scid-process "sc_base close\nexit\n")
  46     (while (eq (process-status chess-scid-process) 'run)
  47       (sit-for 0 250)))
  48
  49    ((eq event 'count)
  50     (string-to-int (chess-scid-get-result "sc_base numGames\n")))
  51
  52    ((eq event 'read)
  53     (let ((here (point-max)) game)
  54       (process-send-string chess-scid-process
  55                            (format "sc_game load %d\nsc_game pgn\n"
  56                                    (car args)))
  57       (accept-process-output chess-scid-process)
  58       (goto-char here)
  59       (when (setq game (chess-pgn-to-game))
  60         (chess-game-set-data game 'database (current-buffer))
  61         (chess-game-set-data game 'database-index (car args))
  62         (chess-game-set-data game 'database-count
  63                              (chess-scid-handler 'count))
  64         game)))
  65
  66    ((eq event 'write)
  67     (chess-scid-handler 'replace (car args) 0))
  68
  69    ((eq event 'replace)
  70     (let ((index (or (cadr args)
  71                      (chess-game-data (car args) 'database-index))))
  72       (process-send-string
  73        chess-scid-process
  74        (format "sc_game import \"%s\"\n"
  75                (with-temp-buffer
  76                  (chess-pgn-insert-plies (car args) 1
  77                                          (chess-game-plies (car args)))
  78                  (insert (or (chess-game-tag (car args) "Result") "*"))
  79                  (buffer-string))))
  80       (dolist (tag (chess-game-tags (car args)))
  81         ;; jww (2002-05-01): how do I set extra tags?
  82         (unless (string= (car tag) "TimeControl")
  83           (process-send-string
  84            chess-scid-process
  85            (concat "sc_game tags set "
  86                    (cond
  87                     ((string= (car tag) "Event")     "-event")
  88                     ((string= (car tag) "Site")      "-site")
  89                     ((string= (car tag) "Date")      "-date")
  90                     ((string= (car tag) "Round")     "-round")
  91                     ((string= (car tag) "White")     "-white")
  92                     ((string= (car tag) "WhiteElo")  "-whiteElo")
  93                     ((string= (car tag) "Black")     "-black")
  94                     ((string= (car tag) "BlackElo")  "-blackElo")
  95                     ((string= (car tag) "Result")    "-result")
  96                     ((string= (car tag) "ECO")       "-eco")
  97                     ((string= (car tag) "EventDate") "-eventdate")
  98                     ((string= (car tag) "Extra")     "-extra"))
  99                    " \"" (cdr tag) "\"\n"))))
 100       (process-send-string chess-scid-process
 101                            (format "sc_game save %d\n" index))))))
 102
 103 (provide 'chess-scid)
 104
 105 ;;; chess-scid.el ends here