X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/2ba7e772cc6ed17a7bf1d2b96aea18b528f922e4..8c98f12ec75b2a9b6083542979e11c80429249d9:/packages/gnugo/gnugo.el?ds=sidebyside diff --git a/packages/gnugo/gnugo.el b/packages/gnugo/gnugo.el index 0f24a2459..c25cee3eb 100644 --- a/packages/gnugo/gnugo.el +++ b/packages/gnugo/gnugo.el @@ -4,9 +4,10 @@ ;; Author: Thien-Thi Nguyen ;; Maintainer: Thien-Thi Nguyen -;; Version: 2.3.1 -;; Package-Requires: ((ascii-art-to-unicode "1.5") (xpm "1.0.0") (cl-lib "0.5")) +;; Version: 3.0.0 +;; Package-Requires: ((ascii-art-to-unicode "1.5") (xpm "1.0.1") (cl-lib "0.5")) ;; Keywords: games, processes +;; URL: http://www.gnuvola.org/software/gnugo/ ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -81,13 +82,7 @@ ;; Meta-Meta-Playing (aka Hacking) ;; ------------------------------- ;; -;; -;; -;; -;; Tip Jar -;; ------- -;; -;; +;; ;;; Code: @@ -97,7 +92,7 @@ ;;;--------------------------------------------------------------------------- ;;; Political arts -(defconst gnugo-version "2.3.1" +(defconst gnugo-version "3.0.0" "Version of gnugo.el currently loaded. This follows a MAJOR.MINOR.PATCH scheme.") @@ -113,6 +108,15 @@ For more information on GTP and GNU Go, please visit: ") (defvar gnugo-board-mode-map + ;; Re , + ;; ideally we could ‘defvar’ here w/o value and also ‘defvar’ below + ;; in "load-time actions" w/ value and docstring, to avoid this ugly + ;; (from the forward references) block early in the file. Unfortunately, + ;; byte-compiling such a split formulation results in the initial ‘defvar’ + ;; being replaced by: + ;; (defvar VAR (make-sparse-keymap)) + ;; and the second ‘defvar’ is ignored on load. At least, this is the case + ;; for Emacs built from repo (trunk) 2014-05-27. --ttn (let ((map (make-sparse-keymap))) (suppress-keymap map) (mapc (lambda (pair) @@ -370,26 +374,27 @@ Handle the big, slow-to-render, and/or uninteresting ones specially." (interactive) (let ((buf (current-buffer)) (d (gnugo-get :diamond)) - (acc (cl-loop for key being the hash-keys of gnugo-state - using (hash-values val) - collect (cons key - (cl-case key - ((:xpms) - (format "hash: %X (%d images)" - (sxhash val) - (length val))) - (:sgf-collection - (length val)) - (:sgf-gametree - (list (hash-table-count - (gnugo--tree-mnum val)) - (gnugo--root-node val) - (gnugo--tree-ends val))) - (:monkey - (let ((mem (aref val 0))) - (list (aref val 1) - (car mem)))) - (t val)))))) + (acc (cl-loop + for key being the hash-keys of gnugo-state + using (hash-values val) + collect (cons key + (cl-case key + ((:xpms) + (format "hash: %X (%d images)" + (sxhash val) + (length val))) + (:sgf-collection + (length val)) + (:sgf-gametree + (list (hash-table-count + (gnugo--tree-mnum val)) + (gnugo--root-node val) + (gnugo--tree-ends val))) + (:monkey + (let ((mem (aref val 0))) + (list (aref val 1) + (car mem)))) + (t val)))))) (switch-to-buffer (get-buffer-create (format "%s*GNUGO Board Properties*" d))) @@ -404,7 +409,7 @@ Handle the big, slow-to-render, and/or uninteresting ones specially." (if (string= "" d) ".+\n" "")))) - (while (re-search-forward rx (point-max) t) + (while (re-search-forward rx nil t) (let ((pos (get-text-property (string-to-number (match-string 1)) 'gnugo-position buf))) (delete-region (+ 2 (match-beginning 0)) (point)) @@ -603,11 +608,11 @@ when you are sure the command cannot fail." (setplist (gnugo-f 'ispc) (and new '(display (space :width 0)))) (gnugo-put :highlight-last-move-spec (if new - '((lambda (p) - (get (gnugo-yy (get-text-property p 'gnugo-yin) - (get-text-property p 'gnugo-yang) - t) - 'display)) + `(,(lambda (p) + (get (gnugo-yy (get-text-property p 'gnugo-yin) + (get-text-property p 'gnugo-yang) + t) + 'display)) 0 delete-overlay) (gnugo-get :default-highlight-last-move-spec))) ;; a kludge to be reworked another time perhaps by another gnugo.el lover @@ -628,7 +633,7 @@ when you are sure the command cannot fail." (funcall (if bool 'remove-from-invisibility-spec 'add-to-invisibility-spec) - :nogrid) + :nogrid) (save-excursion (gnugo-refresh))))) (defun gnugo-propertize-board-buffer () @@ -857,14 +862,15 @@ For all other values of RSEL, do nothing and return nil." (`car (car (nn))) (`cadr (nn) (car (nn))) (`two (nn) (nn) acc) - (`bpos (cl-loop with prop = (gnugo--prop<-color color) - while mem - when (and (remem) - (eq prop (car mprop)) - (setq move (cdr mprop)) - ;; i.e., "normal CC" position - (= 2 (length move))) - return (funcall as-pos move))) + (`bpos (cl-loop + with prop = (gnugo--prop<-color color) + while mem + when (and (remem) + (eq prop (car mprop)) + (setq move (cdr mprop)) + ;; i.e., "normal CC" position + (= 2 (length move))) + return (funcall as-pos move))) (_ nil))))) (defun gnugo-boss-is-near () @@ -887,15 +893,16 @@ For all other values of RSEL, do nothing and return nil." (format "%c%c" one two))))) (defun gnugo--decorate (node &rest plist) - (cl-loop with tp = (last node) - with fruit - while plist - do (setf - fruit (list (cons ; DWR: LtR OoE assumed. - (pop plist) - (pop plist))) - (cdr tp) fruit - tp fruit))) + (cl-loop + with tp = (last node) + with fruit + while plist + do (setf + fruit (list (cons ; DWR: LtR OoE assumed. + (pop plist) + (pop plist))) + (cdr tp) fruit + tp fruit))) (defun gnugo-close-game (end-time resign) (gnugo-put :game-end-time end-time) @@ -944,8 +951,8 @@ For all other values of RSEL, do nothing and return nil." (cur (assq :RE root))) (when cur (cl-assert (not (eq cur (car root))) nil - ":RE at head of root node: %S" - root) + ":RE at head of root node: %S" + root) (delq cur root)))) (defun gnugo-push-move (who move) @@ -1013,23 +1020,22 @@ For all other values of RSEL, do nothing and return nil." below count if (setq bx (mod (+ bidx i) count) previous - (cl-loop with node - for m on (aref ends bx) - while (< tip-move-num - (gethash (setq node (car m)) - mnum)) - if (eq mem (cdr m)) - return - (when (equal pair (assq property node)) - m) - finally return - nil)) + (cl-loop + with node + for m on (aref ends bx) + while (< tip-move-num + (gethash (setq node (car m)) + mnum)) + if (eq mem (cdr m)) + return (when (equal pair (assq property node)) + m) + finally return nil)) ;; yes => follow return (progn (unless (= bidx bx) (cl-rotatef (aref ends bidx) - (aref ends bx))) + (aref ends bx))) (setq mem previous)) ;; no => construct finally do @@ -1455,13 +1461,14 @@ To start a game try M-x gnugo." (message "%s %s in group." blurb (length stones)) (setplist (gnugo-f 'anim) nil) (let* ((spec (if (gnugo-get :display-using-images) - (cl-loop with yin = (get-text-property (point) 'gnugo-yin) - with yang = (gnugo-yang (following-char)) - with up = (get (gnugo-yy yin yang t) 'display) - with dn = (get (gnugo-yy yin yang) 'display) - for n below (length gnugo-animation-string) - collect (if (zerop (logand 1 n)) - dn up)) + (cl-loop + with yin = (get-text-property (point) 'gnugo-yin) + with yang = (gnugo-yang (following-char)) + with up = (get (gnugo-yy yin yang t) 'display) + with dn = (get (gnugo-yy yin yang) 'display) + for n below (length gnugo-animation-string) + collect (if (zerop (logand 1 n)) + dn up)) (split-string gnugo-animation-string "" t))) (cell (list spec)) (ovs (save-excursion @@ -1549,6 +1556,9 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (when (and (file-exists-p filename) (not (y-or-n-p "File exists. Continue? "))) (user-error "Not writing %s" filename)) + (when (buffer-modified-p) + ;; take responsibility for our actions + (gnugo--set-root-prop :AP (cons "gnugo.el" gnugo-version))) (gnugo/sgf-write-file (gnugo-get :sgf-collection) filename) (gnugo--ok-file filename)) @@ -1655,11 +1665,12 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (if (not color) (unless noerror (user-error "No stone at %s" pos)) - (cl-loop with fruit = (cons color (funcall (gnugo--as-cc-func) pos)) - for mem on (aref (gnugo-get :monkey) 0) - when (equal fruit (caar mem)) - return mem - finally return nil)))) + (cl-loop + with fruit = (cons color (funcall (gnugo--as-cc-func) pos)) + for mem on (aref (gnugo-get :monkey) 0) + when (equal fruit (caar mem)) + return mem + finally return nil)))) (defun gnugo--climb-towards-root (spec &optional reaction keep) (gnugo-gate) @@ -1847,14 +1858,14 @@ to the last move, as a comment." (cond ((string= "Chinese" (gnugo--root-prop :RU)) (dolist (group live) (cl-incf (if (gnugo--blackp (caar group)) - b-terr - w-terr) - (length (cdr group)))) + b-terr + w-terr) + (length (cdr group)))) (dolist (group dead) (cl-incf (if (gnugo--blackp (caar group)) - w-terr - b-terr) - (length (cdr group)))) + w-terr + b-terr) + (length (cdr group)))) (push (format "%s%d %s = %3.1f\n" b= b-terr terr b-terr) blurb) (push (format "%s%d %s + %3.1f %s = %3.1f\n" w= w-terr terr komi 'komi (+ w-terr komi)) @@ -1862,9 +1873,9 @@ to the last move, as a comment." (t (dolist (group dead) (cl-incf (if (gnugo--blackp (caar group)) - w-terr - b-terr) - (* 2 (length (cdr group))))) + w-terr + b-terr) + (* 2 (length (cdr group))))) (push (format "%s%d %s + %s %s = %3.1f\n" b= b-terr terr b-capt capt @@ -1891,7 +1902,7 @@ to the last move, as a comment." (cl-flet ((yep (pretty moment) (push (format-time-string - (concat pretty ": %Y-%m-%d %H:%M:%S %z\n") + (concat pretty ": %F %T %z\n") moment) blurb))) (yep "Game start" beg) @@ -1977,12 +1988,13 @@ If there a stone at that position, also display its move number." (defun gnugo-switch-to-another () "Switch to another GNU Go game buffer (if any)." (interactive) - (cl-loop for buf in (cdr (buffer-list)) - if (gnugo-board-buffer-p buf) - return (progn - (bury-buffer) - (switch-to-buffer buf)) - finally do (message "(only one)"))) + (cl-loop + for buf in (cdr (buffer-list)) + if (gnugo-board-buffer-p buf) + return (progn + (bury-buffer) + (switch-to-buffer buf)) + finally do (message "(only one)"))) (defun gnugo-comment (node comment) "Add to NODE a COMMENT (string) property. @@ -2262,11 +2274,10 @@ See `gnugo-board-mode' for a full list of commands." (when (and (zerop handicap) actually) (setq handicap (string-to-number (cadr actually))))) (r! :SZ board-size - :DT (format-time-string "%Y-%m-%d") + :DT (format-time-string "%F") :RU (if (member "--chinese-rules" args) "Chinese" "Japanese") - :AP (cons "gnugo.el" gnugo-version) :KM komi) (let ((ub (gnugo--blackp user-color))) (r! (if ub :PW :PB) (concat "GNU Go " (gnugo-query "version")) @@ -2307,14 +2318,15 @@ See `gnugo-board-mode' for a full list of commands." (plist-put (sget cmd) prop val))) (validpos (s &optional go) (let ((pos (upcase s))) - (cl-loop with size = (gnugo-get :SZ) - for c across (funcall (gnugo--as-cc-func) - pos) - do (let ((norm (- c ?a))) - (unless (and (< -1 norm) - (> size norm)) - (user-error "Invalid position: %s" - pos)))) + (cl-loop + with size = (gnugo-get :SZ) + for c across (funcall (gnugo--as-cc-func) + pos) + do (let ((norm (- c ?a))) + (unless (and (< -1 norm) + (> size norm)) + (user-error "Invalid position: %s" + pos)))) (when go (gnugo-goto-pos pos)) pos)) @@ -2337,7 +2349,7 @@ See `gnugo-board-mode' for a full list of commands." (goto-char (point-min)) (save-excursion (while (re-search-forward "^ *[*] \\([a-zA-Z_]+\\)\\(:.*\\)*\n" - (point-max) t) + nil t) (unless pad (setq pad (make-string (- (match-beginning 1) (match-beginning 0)) @@ -2391,10 +2403,10 @@ See `gnugo-board-mode' for a full list of commands." ;;;--------------------------------------------------------------------------- -;; The remainder of this file defines a simplified SGF-handling library. -;; When/if it should start to attain generality, it should be split off into -;; a separate file (probably named sgf.el) w/ funcs and vars renamed sans the -;; "gnugo/" prefix. +;;; The remainder of this file defines a simplified SGF-handling library. +;;; When/if it should start to attain generality, it should be split off into +;;; a separate file (probably named sgf.el) w/ funcs and vars renamed sans the +;;; "gnugo/" prefix. (defconst gnugo/sgf-*r4-properties* '((AB "Add Black" setup list stone) @@ -2594,12 +2606,13 @@ A collection is a list of gametrees, each a vector of four elements: (forward-char 1) t)) (NODE () (when (seek-into ?\;) - (cl-loop with prop - while (setq prop (PROP)) - collect (progn - (when (eq :SZ (car prop)) - (setq SZ (cdr prop))) - prop)))) + (cl-loop + with prop + while (setq prop (PROP)) + collect (progn + (when (eq :SZ (car prop)) + (setq SZ (cdr prop))) + prop)))) (TREE (parent mnum) (let ((ls parent) prev node) @@ -2619,25 +2632,26 @@ A collection is a list of gametrees, each a vector of four elements: ;; singular (list ls) ;; multiple - (cl-loop while (seek ?\() - append (TREE ls mnum))) + (cl-loop + while (seek ?\() + append (TREE ls mnum))) (seek-into ?\)))))) (with-temp-buffer (if (not data-p) (insert-file-contents file-or-data) (insert file-or-data) (goto-char (point-min))) - (cl-loop while (morep) - collect (let* ((mnum (gnugo--mkht :weakness 'key)) - (ends (TREE nil mnum)) - (root (car (last (car ends))))) - (vector (apply 'vector ends) - mnum - root))))))) + (cl-loop + while (morep) + collect (let* ((mnum (gnugo--mkht :weakness 'key)) + (ends (TREE nil mnum)) + (root (car (last (car ends))))) + (vector (apply 'vector ends) + mnum + root))))))) (defun gnugo/sgf-write-file (collection filename) (let ((aft-newline-appreciated '(:AP :GN :PB :PW :HA :KM :RU :RE)) - (me (cons "gnugo.el" gnugo-version)) (specs (mapcar (lambda (full) (cons (intern (format ":%s" (car full))) (cl-cdddr full))) @@ -2689,9 +2703,10 @@ A collection is a list of gametrees, each a vector of four elements: (t (>>one v) (>>nl)))) (>>node (node) - (cl-loop initially (insert ";") - for prop in node - do (>>prop prop))) + (cl-loop + initially (insert ";") + for prop in node + do (>>prop prop))) (>>tree (tree) (unless (zerop (current-column)) (newline)) @@ -2704,8 +2719,6 @@ A collection is a list of gametrees, each a vector of four elements: (insert ")"))) (with-temp-buffer (dolist (tree collection) - ;; take responsibility for our actions - (gnugo--set-root-prop :AP me tree) ;; write it out (let ((ht (gnugo--mkht)) (leaves (append (gnugo--tree-ends tree) nil)))