X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/ef7dc9ad6b5fb5d7940d7b49febf52bb3f0319c0..90473ac8cf0c833bfec413fc18d5866208d2e3e9:/packages/gnugo/gnugo.el diff --git a/packages/gnugo/gnugo.el b/packages/gnugo/gnugo.el index 6098f6e68..c25cee3eb 100644 --- a/packages/gnugo/gnugo.el +++ b/packages/gnugo/gnugo.el @@ -3,8 +3,11 @@ ;; Copyright (C) 2014 Free Software Foundation, Inc. ;; Author: Thien-Thi Nguyen -;; Version: 2.3.1 -;; Package-Requires: ((ascii-art-to-unicode "1.5")) +;; Maintainer: Thien-Thi Nguyen +;; 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 @@ -66,27 +69,30 @@ ;; `gnugo-animation-string' ;; `gnugo-mode-line' ;; `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face' -;; `gnugo-xpms' +;; `gnugo-undo-reaction' +;; `gnugo-xpms' (see also gnugo-imgen.el) ;; normal hooks: `gnugo-board-mode-hook' ;; `gnugo-frolic-mode-hook' ;; `gnugo-start-game-hook' ;; `gnugo-post-move-hook' -;; and the keymap: `gnugo-board-mode-map' +;; and the keymaps: `gnugo-board-mode-map' +;; `gnugo-frolic-mode-map' ;; -;; The variable `gnugo-xpms' is a special case. To set it you need to load -;; gnugo-xpms.el (http://www.emacswiki.org) or some other library w/ congruent -;; interface. +;; +;; Meta-Meta-Playing (aka Hacking) +;; ------------------------------- +;; +;; ;;; Code: -(eval-when-compile (require 'cl)) ; use the source luke! -(require 'ascii-art-to-unicode) ; for `aa2u' +(require 'cl-lib) ; use the source luke! (require 'time-date) ; for `time-subtract' ;;;--------------------------------------------------------------------------- ;;; 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.") @@ -101,12 +107,68 @@ This program must accept command line args: For more information on GTP and GNU Go, please visit: ") -(defvar gnugo-board-mode-map nil +(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) + (define-key map (car pair) (cdr pair))) + '(("?" . describe-mode) + ("S" . gnugo-request-suggestion) + ("\C-m" . gnugo-move) + (" " . gnugo-move) + ("P" . gnugo-pass) + ("R" . gnugo-resign) + ("q" . gnugo-quit) + ("Q" . gnugo-leave-me-alone) + ("U" . gnugo-fancy-undo) + ("\M-u" . gnugo-undo-one-move) + ("u" . gnugo-undo-two-moves) + ("\C-?" . gnugo-undo-two-moves) + ("o" . gnugo-oops) + ("O" . gnugo-okay) + ("\C-l" . gnugo-refresh) + ("\M-_" . gnugo-boss-is-near) + ("_" . gnugo-boss-is-near) + ("h" . gnugo-move-history) + ("L" . gnugo-frolic-in-the-leaves) + ("\C-c\C-l" . gnugo-frolic-in-the-leaves) + ("i" . gnugo-image-display-mode) + ("w" . gnugo-worm-stones) + ("W" . gnugo-worm-data) + ("d" . gnugo-dragon-stones) + ("D" . gnugo-dragon-data) + ("g" . gnugo-grid-mode) + ("!" . gnugo-estimate-score) + (":" . gnugo-command) + (";" . gnugo-command) + ("=" . gnugo-describe-position) + ("s" . gnugo-write-sgf-file) + ("\C-x\C-s" . gnugo-write-sgf-file) + ("\C-x\C-w" . gnugo-write-sgf-file) + ("l" . gnugo-read-sgf-file) + ("F" . gnugo-display-final-score) + ("A" . gnugo-switch-to-another) + ("C" . gnugo-comment) + ("\C-c\C-a" . gnugo-assist-mode) + ("\C-c\C-z" . gnugo-zombie-mode) + ;; mouse + ([(down-mouse-1)] . gnugo-mouse-move) + ([(down-mouse-2)] . gnugo-mouse-move) ; mitigate accidents + ([(down-mouse-3)] . gnugo-mouse-pass) + ;; delving into the curiosities + ("\C-c\C-p" . gnugo-describe-internal-properties))) + map) "Keymap for GNUGO Board mode.") -(defvar gnugo-frolic-mode-map nil - "Keymap for GNUGO Frolic mode.") - (defvar gnugo-board-mode-hook nil "Hook run when entering GNUGO Board mode.") @@ -162,6 +224,43 @@ For ~t, the value is a snapshot, use `gnugo-refresh' to update it.") (defvar gnugo-grid-face 'default "Name of face to use for the grid (A B C ... 1 2 3 ...).") +(defvar gnugo-undo-reaction 'play! + "What to do if undo (or oops) leaves GNU Go to play. +After `gnugo-undo-one-move', `gnugo-undo-two-moves' or `gnugo-oops', +when GNU Go is to play, this can be a symbol: + play -- make GNU Go play (unless in Zombie mode) + play! -- make GNU Go play unconditionally (traditional behavior) + zombie -- enable Zombie mode (`gnugo-zombie-mode') + one-shot -- like `zombie' but valid only for the next move +Any other value, or (as a special case) for `gnugo-undo-one-move', +any value other than `zombie', is taken as `one-shot'. Note that +making GNU Go play will probably result in the recently-liberated +board position becoming re-occupied.") + +(defvar gnugo-xpms nil + "List of 46 ((TYPE . LOCATION) . XPM-IMAGE) forms. +XPM-IMAGE is an image as returned by `create-image' with +inline data (i.e., property :data with string value). + +TYPE is a symbol, one of: + hoshi -- unoccupied position with dot + empty -- unoccupied position sans dot + bpmoku, bmoku -- black stone with and sans highlight point + wpmoku, wmoku -- white stone with and sans highlight point + +LOCATION is an integer encoding edge, corner, or center: + 1 2 3 + 4 5 6 + 7 8 9 +For instance, 4 means \"left edge\", 9 means \"bottom right\". + +There is only one location for hoshi: center. The other five +types each have all possible locations. So (+ 1 (* 9 5)) => 46. + +The value can also be a function (satisfying `functionp') that +takes one arg, the size of the board, and returns the appropriate +list of forms.") + ;;;--------------------------------------------------------------------------- ;;; Variables for the inquisitive programmer @@ -174,12 +273,6 @@ For ~t, the value is a snapshot, use `gnugo-refresh' to update it.") (defvar gnugo-state nil) ; hint: C-c C-p -(eval-when-compile - (defvar gnugo-xpms nil)) - -(defvar gnugo-frolic-parent-buffer nil) -(defvar gnugo-frolic-origin nil) - (defvar gnugo-btw nil) ;;;--------------------------------------------------------------------------- @@ -237,7 +330,7 @@ you may never really understand to any degree of personal satisfaction\". `gnugo-toggle-image-display' and `gnugo-refresh', as well as gnugo-xpms.el (available elsewhere) - :all-yy -- list of 46 keywords used as the `category' text property + :all-yy -- list of 46 symbols used as the `category' text property (so that their plists, typically w/ property `display' or `do-not-display') are consulted by the Emacs display engine; 46 = 9 places * (4 moku + 1 empty) + 1 hoshi; see functions @@ -281,31 +374,30 @@ Handle the big, slow-to-render, and/or uninteresting ones specially." (interactive) (let ((buf (current-buffer)) (d (gnugo-get :diamond)) - acc) - (loop for key being the hash-keys of gnugo-state - using (hash-values val) - do (push (cons key - (case key - ((:xpms :local-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)) + (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*" - (gnugo-get :diamond)))) + d))) (erase-buffer) (emacs-lisp-mode) (setq truncate-lines t) @@ -317,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)) @@ -354,7 +446,7 @@ Handle the big, slow-to-render, and/or uninteresting ones specially." (user-error "Wrong buffer -- try M-x gnugo")) (unless (gnugo-get :proc) (user-error "No \"gnugo\" process!")) - (destructuring-bind (&optional color . suggestion) + (cl-destructuring-bind (&optional color . suggestion) (gnugo-get :waiting) (when color (apply 'user-error @@ -469,8 +561,11 @@ when you are sure the command cannot fail." (1- letter))) ?A))))) -(defun gnugo-f (frag) - (intern (format ":gnugo-%s%s-props" (gnugo-get :diamond) frag))) +(defun gnugo-f (id) + (intern (if (symbolp id) + (symbol-name id) + id) + (gnugo-get :obarray))) (defun gnugo-yang (c) (cdr (assq c '((?+ . hoshi) @@ -480,17 +575,18 @@ when you are sure the command cannot fail." (defun gnugo-yy (yin yang &optional momentaryp) (gnugo-f (format "%d-%s" - yin (cond ((and (consp yang) momentaryp) (cdr yang)) - ((consp yang) (car yang)) - (t yang))))) + yin (cond ((symbolp yang) yang) + (momentaryp (cdr yang)) + (t (car yang)))))) (defun gnugo-toggle-image-display () - (unless (and (fboundp 'display-images-p) (display-images-p)) + (unless (display-images-p) (user-error "Display does not support images, sorry")) - (require 'gnugo-xpms) - (unless (and (boundp 'gnugo-xpms) gnugo-xpms) - (user-error "Could not load `gnugo-xpms', sorry")) - (let ((fresh (or (gnugo-get :local-xpms) gnugo-xpms))) + (let ((fresh (if (functionp gnugo-xpms) + (funcall gnugo-xpms (gnugo-get :SZ)) + gnugo-xpms))) + (unless fresh + (user-error "Sorry, `gnugo-xpms' unset")) (unless (eq fresh (gnugo-get :xpms)) (gnugo-put :xpms fresh) (gnugo--forget :all-yy))) @@ -512,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 @@ -528,14 +624,17 @@ when you are sure the command cannot fail." '(1 . 1))) (gnugo-put :display-using-images new))) -(defun gnugo-toggle-grid () - "Turn the grid around the board on or off." - (interactive) - (funcall (if (memq :nogrid buffer-invisibility-spec) - 'remove-from-invisibility-spec - 'add-to-invisibility-spec) - :nogrid) - (save-excursion (gnugo-refresh))) +(define-minor-mode gnugo-grid-mode + "If enabled, display grid around the board." + :variable + ((not (memq :nogrid buffer-invisibility-spec)) + . + (lambda (bool) + (funcall (if bool + 'remove-from-invisibility-spec + 'add-to-invisibility-spec) + :nogrid) + (save-excursion (gnugo-refresh))))) (defun gnugo-propertize-board-buffer () (erase-buffer) @@ -574,7 +673,7 @@ when you are sure the command cannot fail." ;; This has something to do w/ the bletcherous `before-string'. (overlay-put ov 'invisible :nogrid) (overlay-put ov 'category %lpad)) - (do ((p edge (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even))) + (cl-do ((p edge (+ 2 p)) (ival 'even (if (eq 'even ival) 'odd 'even))) ((< other-edge p)) (let* ((position (format "%c%s" (aref "ABCDEFGHJKLMNOPQRST" (truncate (- p edge) 2)) @@ -685,7 +784,7 @@ when you are sure the command cannot fail." (gnugo-put capprop new) (delete-char old-len) (insert (apply 'propertize new keep)) - (incf adj (- (length new) old-len))) + (cl-incf adj (- (length new) old-len))) (setq new (aref aft aft-idx)) (insert-and-inherit (char-to-string new)) (let ((yin (get-text-property cut 'gnugo-yin)) @@ -706,7 +805,7 @@ when you are sure the command cannot fail." (assq :W node))) (defun gnugo--as-pos-func () - (lexical-let ((size (gnugo-get :SZ))) + (let ((size (gnugo-get :SZ))) ;; rv (lambda (cc) (if (string= "" cc) @@ -763,449 +862,17 @@ For all other values of RSEL, do nothing and return nil." (`car (car (nn))) (`cadr (nn) (car (nn))) (`two (nn) (nn) acc) - (`bpos (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))))) -(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic" - "A special mode for manipulating a GNUGO gametree. - -\\{gnugo-frolic-mode-map}" - (setq truncate-lines t) - (buffer-disable-undo)) - -(defun gnugo-frolic-quit () - "Kill GNUGO Frolic buffer and switch to its parent buffer." - (interactive) - (let ((bye (current-buffer))) - (switch-to-buffer (when (buffer-live-p gnugo-frolic-parent-buffer) - gnugo-frolic-parent-buffer)) - (kill-buffer bye))) - -(defun gnugo-frolic-return-to-origin () - "Move point to the board's current position." - (interactive) - (if (not gnugo-frolic-origin) - (message "No origin") - (goto-char gnugo-frolic-origin) - (recenter (- (count-lines (line-beginning-position) - (point-max)))))) - -(defun gnugo-frolic-in-the-leaves () - "Display the game tree in a *GNUGO Frolic* buffer. -This looks something like: - - 1 B -- E7 E7 E7 E7 - 2 W -- K10 K10 K10 K10 - 3 B -- E2 E2 E2 E2 - 4 W -- J3 J3 J3 J3 - 5 B -- A6 A6 A6 A6 - 6 W -- C9 C9 C9 C9 - │ - ├─────┬─────┐ - │ │ │ - 7 B -- H7 !B8 C8 C8 - │ - ├─────┐ - │ │ - 8 W -- D9 D9 D9 E9 - 9 B -- H8 H8 - 10 W -- PASS PASS - 11 B -- H5 PASS - 12 W -- PASS - 13 B -- *PASS - -with 0, 1, ... N (in this case N is 3) in the header line -to indicate the branches. Branch 0 is the \"main line\". -Point (* in this example) indicates the current position, -\"!\" indicates comment properties (e.g., B8, branch 1), -and moves not actually on the game tree (e.g., E7, branch 3) -are dimmed. Type \\[describe-mode] in that buffer for details." - (interactive) - (let* ((buf (get-buffer-create (concat (gnugo-get :diamond) - "*GNUGO Frolic*"))) - (from (or gnugo-frolic-parent-buffer - (current-buffer))) - ;; todo: use defface once we finally succumb to ‘customize’ - (dimmed-node-face (list :inherit 'default - :foreground "gray50")) - (tree (gnugo-get :sgf-gametree)) - (ends (copy-sequence (gnugo--tree-ends tree))) - (mnum (gnugo--tree-mnum tree)) - (seen (gnugo--mkht)) - (soil (gnugo--mkht)) - (width (length ends)) - (lanes (number-sequence 0 (1- width))) - (monkey (gnugo-get :monkey)) - (as-pos (gnugo--as-pos-func)) - (at (car (aref monkey 0))) - (bidx (aref monkey 1)) - (valid (map 'vector (lambda (end) - (gethash (car end) mnum)) - ends)) - (max-move-num (apply 'max (append valid nil))) - (inhibit-read-only t) - finish) - (cl-flet - ((on (node) - (gethash node seen)) - (emph (s face) - (propertize s 'face face)) - (fsi (properties fmt &rest args) - (insert (apply 'propertize - (apply 'format fmt args) - properties)))) - ;; breathe in - (loop - for bx below width - do (loop - with fork - for node in (aref ends bx) - do (if (setq fork (on node)) - (cl-flet - ((tip-p (bix) - ;; todo: ignore non-"move" nodes - (eq node (car (aref ends bix)))) - (link (other) - (pushnew other (gethash node soil)))) - (unless (tip-p bx) - (unless (tip-p fork) - (link fork)) - (link bx))) - (puthash node bx seen)) - until fork)) - ;; breathe out - (switch-to-buffer buf) - (gnugo-frolic-mode) - (erase-buffer) - (setq header-line-format - (lexical-let ((full (concat - (make-string 11 ?\s) - (mapconcat (lambda (n) - (format "%-5s" n)) - lanes - " ")))) - `((:eval - (funcall - ,(lambda () - (cl-flet - ((sp (w) (propertize - " " 'display - `(space :width ,w)))) - (concat - (when (eq 'left scroll-bar-mode) - (let ((w (or scroll-bar-width - (frame-parameter - nil 'scroll-bar-width))) - (cw (frame-char-width))) - (sp (if w - (/ w cw) - 2)))) - (let ((fc (fringe-columns 'left t))) - (unless (zerop fc) - (sp fc))) - (condition-case nil - (substring full (window-hscroll)) - (error "")))))))))) - (set (make-local-variable 'gnugo-frolic-parent-buffer) from) - (set (make-local-variable 'gnugo-state) - (buffer-local-value 'gnugo-state from)) - (loop - with props - for n ; move number - from max-move-num downto 1 - do (setq props (list 'n n)) - do - (loop - with (move forks br) - initially (progn - (goto-char (point-min)) - (fsi props - "%3d %s -- " - n (aref ["W" "B"] (logand 1 n)))) - for bx below width - do (let* ((node (unless (< (aref valid bx) n) - ;; todo: ignore non-"move" nodes - (pop (aref ends bx)))) - (zow (list* 'bx bx props)) - (ok (when node - (= bx (on node)))) - (comment (when ok - (cdr (assq :C node)))) - (s (cond ((not node) "") - ((not (setq move (gnugo--move-prop node))) "-") - (t (funcall as-pos (cdr move)))))) - (when comment - (push comment zow) - (push 'help-echo zow)) - (when (and ok (setq br (gethash node soil))) - (push (cons bx (sort br '<)) - forks)) - (fsi zow - "%c%-5s" - (if comment ?! ?\s) - (cond ((and (eq at node) - (or ok (= bx bidx))) - (when (= bx bidx) - (setq finish (point-marker))) - (emph s (list :inherit 'default - :foreground (frame-parameter - nil 'cursor-color)))) - ((not ok) - (emph s dimmed-node-face)) - (t s)))) - finally do - (when (progn (fsi props "\n") - (setq forks (nreverse forks))) - (let* ((margin (make-string 11 ?\s)) - (heads (mapcar #'car forks)) - (tails (mapcar #'cdr forks))) - (cl-flet* - ((spaced (lanes func) - (mapconcat func lanes " ")) - ;; live to play ~ ~ () - ;; play to learn (+) (-) . o O - ;; learn to live --ttn .M. _____U - (dashed (lanes func) ;;; _____ ^^^^ - (mapconcat func lanes "-----")) - (cnxn (lanes set) - (spaced lanes (lambda (bx) - (if (memq bx set) - "|" - " ")))) - (pad-unless (condition) - (if condition - "" - " ")) - (edge (set) - (insert margin - (cnxn lanes set) - "\n"))) - (edge heads) - (loop with bef - for ls on forks - do (let* ((one (car ls)) - (yes (append - ;; "aft" heads - (mapcar 'car (cdr ls)) - ;; ‘bef’ tails - (apply 'append (mapcar 'cdr bef)))) - (ord (sort one '<)) - (beg (car ord)) - (end (car (last ord)))) - (cl-flet - ((also (b e) (cnxn (number-sequence b e) - yes))) - (insert - margin - (also 0 (1- beg)) - (pad-unless (zerop beg)) - (dashed (number-sequence beg end) - (lambda (bx) - (cond ((memq bx ord) "+") - ((memq bx yes) "|") - (t "-")))) - (pad-unless (>= end width)) - (also (1+ end) (1- width)) - "\n")) - (push one bef))) - (edge (apply 'append tails)) - (aa2u (line-beginning-position - (- (1+ (length forks)))) - (point)))))))) - (when finish - (set (make-local-variable 'gnugo-frolic-origin) finish) - (gnugo-frolic-return-to-origin)))) - -(defun gnugo--awake (how) - ;; Valid HOW elements: - ;; require-valid-branch - ;; (line . numeric) - ;; (line . move-string) - ;; (omit . [VAR...]) - ;; Invalid elements blissfully ignored. :-D - (let* ((tree (gnugo-get :sgf-gametree)) - (ends (gnugo--tree-ends tree)) - (width (length ends)) - (monkey (gnugo-get :monkey)) - (line (case (cdr (assq 'line how)) - (numeric - (count-lines (point-min) (line-beginning-position))) - (move-string - (save-excursion - (when (re-search-backward "^ *[0-9]+ [BW]" nil t) - (match-string 0)))) - (t nil))) - (col (current-column)) - (a (unless (> 10 col) - (let ((try (/ (- col 10) - 6))) - (unless (<= width try) - try)))) - (rv (list a))) - (when (memq 'require-valid-branch how) - (unless a - (user-error "No branch here"))) - (loop with omit = (cdr (assq 'omit how)) - for (name . value) in `((line . ,line) - (bidx . ,(aref monkey 1)) - (monkey . ,monkey) - (width . ,width) - (ends . ,ends) - (tree . ,tree)) - do (unless (memq name omit) - (push value rv))) - rv)) - -(defmacro gnugo--awakened (how &rest body) - (declare (indent 1)) - `(destructuring-bind ,(loop with omit = (cdr (assq 'omit how)) - with ls = (list 'a) - for name in '(line bidx monkey - width ends - tree) - do (unless (memq name omit) - (push name ls)) - finally return ls) - (gnugo--awake ',how) - ,@body)) - -(defsubst gnugo--move-to-bcol (bidx) - (move-to-column (+ 10 (* 6 bidx)))) - -(defun gnugo--swiz (direction &optional blunt) - (gnugo--awakened (require-valid-branch - (omit tree) - (line . numeric)) - (let* ((b (cond ((numberp blunt) - (unless (and (< -1 blunt) - (< blunt width)) - (user-error "No such branch: %s" blunt)) - blunt) - (t (mod (+ direction a) width)))) - (flit (if blunt (lambda (n) - (cond ((= n a) b) - ((= n b) a) - (t n))) - (lambda (n) - (mod (+ direction n) width)))) - (was (copy-sequence ends)) - (new-bidx (funcall flit bidx))) - (loop for bx below width - do (aset ends (funcall flit bx) - (aref was bx))) - (unless (= new-bidx bidx) - (aset monkey 1 new-bidx)) - (gnugo-frolic-in-the-leaves) - (goto-char (point-min)) - (forward-line line) - (gnugo--move-to-bcol b)))) - -(defun gnugo-frolic-exchange-left () - "Exchange the current branch with the one to its left." - (interactive) - (gnugo--swiz -1 t)) - -(defun gnugo-frolic-rotate-left () - "Rotate all branches left." - (interactive) - (gnugo--swiz -1)) - -(defun gnugo-frolic-exchange-right () - "Exchange the current branch with the one to its right." - (interactive) - (gnugo--swiz 1 t)) - -(defun gnugo-frolic-rotate-right () - "Rotate all branches right." - (interactive) - (gnugo--swiz 1)) - -(defun gnugo-frolic-set-as-main-line () - "Make the current branch the main line." - (interactive) - (gnugo--swiz nil 0)) - -(defun gnugo-frolic-prune-branch () - "Remove the current branch from the gametree. -This fails if there is only one branch in the tree. -This fails if the monkey is on the current branch -\(a restriction that will probably be lifted Real Soon Now\)." - (interactive) - (gnugo--awakened (require-valid-branch - (line . move-string)) - ;; todo: define meaningful eviction semantics; remove restriction - (when (= a bidx) - (user-error "Cannot prune with monkey on branch")) - (when (= 1 width) - (user-error "Cannot prune last remaining branch")) - (let ((new (append ends nil))) - ;; Explicit ignorance avoids byte-compiler warning. - (ignore (pop (nthcdr a new))) - (gnugo--set-tree-ends tree new)) - (when (< a bidx) - (aset monkey 1 (decf bidx))) - (gnugo-frolic-in-the-leaves) - (when line - (goto-char (point-min)) - (search-forward line) - (gnugo--move-to-bcol (min a (- width 2)))))) - -(defun gnugo--sideways (backwards n) - (gnugo--awakened ((omit tree ends monkey bidx line)) - (gnugo--move-to-bcol (mod (if backwards - (- (or a width) n) - (+ (or a -1) n)) - width)))) - -(defun gnugo-frolic-backward-branch (&optional n) - "Move backward N (default 1) branches." - (interactive "p") - (gnugo--sideways t n)) - -(defun gnugo-frolic-forward-branch (&optional n) - "Move forward N (default 1) branches." - (interactive "p") - (gnugo--sideways nil n)) - -(defun gnugo--vertical (n direction) - (when (> 0 n) - (setq n (- n) - direction (- direction))) - (gnugo--awakened ((line . numeric) - (omit tree ends width monkey bidx)) - (let ((stop (if (> 0 direction) - 0 - (max 0 (1- (count-lines (point-min) - (point-max)))))) - (col (unless a - (current-column)))) - (loop while (not (= line stop)) - do (loop do (progn - (forward-line direction) - (incf line direction)) - until (get-text-property (point) 'n)) - until (zerop (decf n))) - (if a - (gnugo--move-to-bcol a) - (move-to-column col))))) - -(defun gnugo-frolic-previous-move (&optional n) - "Move to the Nth (default 1) previous move." - (interactive "p") - (gnugo--vertical n -1)) - -(defun gnugo-frolic-next-move (&optional n) - "Move to the Nth (default 1) next move." - (interactive "p") - (gnugo--vertical n 1)) - (defun gnugo-boss-is-near () "Do `bury-buffer' until the current one is not a GNU Board." (interactive) @@ -1217,7 +884,7 @@ This fails if the monkey is on the current branch (aref monkey 0))) (defun gnugo--as-cc-func () - (lexical-let ((size (gnugo-get :SZ))) + (let ((size (gnugo-get :SZ))) (lambda (pos) (let* ((col (aref pos 0)) (one (+ ?a (- col (if (< ?H col) 1 0) ?A))) @@ -1226,15 +893,16 @@ This fails if the monkey is on the current branch (format "%c%c" one two))))) (defun gnugo--decorate (node &rest plist) - (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) @@ -1282,9 +950,9 @@ This fails if the monkey is on the current branch (let* ((root (gnugo--root-node)) (cur (assq :RE root))) (when cur - (assert (not (eq cur (car root))) nil - ":RE at head of root node: %S" - root) + (cl-assert (not (eq cur (car root))) nil + ":RE at head of root node: %S" + root) (delq cur root)))) (defun gnugo-push-move (who move) @@ -1341,7 +1009,7 @@ This fails if the monkey is on the current branch ;; ;; This linear search loses for multiple ‘old’ w/ "A", ;; a very unusual (but not invalid, sigh) situation. - (loop + (cl-loop with (bx previous) for i ;; Start with latest / highest likelihood for hit. @@ -1352,23 +1020,22 @@ This fails if the monkey is on the current branch below count if (setq bx (mod (+ bidx i) count) previous - (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) - (rotatef (aref ends bidx) - (aref ends bx))) + (cl-rotatef (aref ends bidx) + (aref ends bx))) (setq mem previous)) ;; no => construct finally do @@ -1394,7 +1061,9 @@ This fails if the monkey is on the current branch (let* ((fg-yy (gnugo-yy yin yang)) (fg-disp (or (get fg-yy 'display) (get fg-yy 'do-not-display))) - (fg-data (plist-get (cdr fg-disp) :data)) + (fg-props (cdr fg-disp)) + (fg-data (plist-get fg-props :data)) + (c-symbs (plist-get fg-props :color-symbols)) (bg-yy (gnugo-yy yin (gnugo-yang ?.))) (bg-disp (or (get bg-yy 'display) (get bg-yy 'do-not-display))) @@ -1420,9 +1089,12 @@ This fails if the monkey is on the current branch (when (and (not (= color-key (aref new sx))) (cl-plusp (random 4))) (aset new sx (aref bg-data sb))) - (incf sx) - (incf sb)) - (create-image new 'xpm t :ascent 'center))) + (cl-incf sx) + (cl-incf sb)) + (apply 'create-image new 'xpm t + :ascent 'center (when c-symbs + (list :color-symbols + c-symbs))))) (defun gnugo-refresh (&optional nocache) "Update GNUGO Board buffer display. @@ -1445,7 +1117,7 @@ its move." (gnugo-propertize-board-buffer)) ;; last move (when move - (destructuring-bind (l-ov . r-ov) (gnugo-get :paren-ov) + (cl-destructuring-bind (l-ov . r-ov) (gnugo-get :paren-ov) (if (member move '("PASS" "resign")) (mapc 'delete-overlay (list l-ov r-ov)) (gnugo-goto-pos move) @@ -1582,11 +1254,11 @@ its move." (let (acc cut c) (while (setq cut (string-match "~[bwpmtu]" cur)) (aset cur cut ?%) - (setq c (aref cur (incf cut))) + (setq c (aref cur (cl-incf cut))) (aset cur cut ?s) (push `(,(intern (format "squig-%c" c)) - ,(case c + ,(cl-case c (?b '(or (gnugo-get :black-captures) 0)) (?w '(or (gnugo-get :white-captures) 0)) (?p '(gnugo-current-player)) @@ -1650,7 +1322,7 @@ its move." (let ((old "to play") (new "waiting for suggestion")) (when back - (rotatef old new)) + (cl-rotatef old new)) (let ((name (buffer-name))) (when (string-match old name) (rename-buffer (replace-match new t t name)))))) @@ -1666,7 +1338,7 @@ its move." (full (gnugo-put :get-move-string (concat so-far string)))) (when (string-match "^= \\(.+\\)\n\n" full) (setq full (match-string 1 full)) ; POS or "PASS" - (destructuring-bind (color . suggestion) + (cl-destructuring-bind (color . suggestion) (gnugo-get :waiting) (gnugo--forget :get-move-string :waiting) @@ -1693,20 +1365,6 @@ its move." (when (gnugo-board-buffer-p) (unless (zerop (buffer-size)) (message "Thank you for playing GNU Go.")) - (mapc (lambda (sym) - (setplist sym nil) ; "...is next to fordliness." --Huxley - ;; Sigh, "2nd arg optional" obsolete as of Emacs 23.3. - ;; No worries, things will be Much Better w/ structs, RSN... - (unintern sym nil)) - (append (gnugo-get :all-yy) - (mapcar 'gnugo-f - '(anim - tpad - gpad - gspc - lpad - rpad - ispc)))) (setq gnugo-state nil))) (defun gnugo-position () @@ -1726,12 +1384,19 @@ cursor to the suggested position. Prefix arg inhibits warp." 'nowarp t))) -(defun gnugo--karma (color) - (member color (cdr (gnugo-get :wheel)))) +(defun gnugo--karma (color) ; => BOOL + (when (member color (cdr (gnugo-get :wheel))) + t)) (defsubst gnugo--:karma (role) (gnugo--karma (gnugo-get role))) +(defun gnugo--assist-state (&optional gate) + (let ((bool (gnugo--:karma :user-color))) + (if (and bool gate) + (user-error "Sorry, Assist mode enabled") + bool))) + (defun gnugo--user-play (pos-or-pass) (gnugo-gate t) ;; The "user" in this func's name used to signify both @@ -1740,8 +1405,10 @@ cursor to the suggested position. Prefix arg inhibits warp." (let ((color (gnugo-current-player))) ;; Don't get confused by mixed signals. (when (gnugo--karma color) - (user-error "Sorry, you cannot play for %s at this time" - color)) + (if (equal color (gnugo-get :one-shot)) + (gnugo--forget :one-shot) + (user-error "Sorry, you cannot play for %s at this time" + color))) (gnugo-push-move color pos-or-pass)) (gnugo--finish-move t)) @@ -1783,6 +1450,7 @@ To start a game try M-x gnugo." (defun gnugo-animate-group (w/d) ;; W/D is a symbol, either ‘worm’ or ‘dragon’. + (gnugo-gate) (let* ((pos (gnugo-position)) (orig-b-m-p (buffer-modified-p)) blurb stones) @@ -1793,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) - (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 @@ -1822,6 +1491,7 @@ To start a game try M-x gnugo." t))) (defun gnugo-display-group-data (command buffer-name) + (gnugo-gate) (message "Computing %s ..." command) (let ((data (gnugo--q "%s %s" command (gnugo-position)))) (switch-to-buffer buffer-name) @@ -1834,14 +1504,12 @@ To start a game try M-x gnugo." Signal error if done out-of-turn or if game-over. See variable `gnugo-animation-string' for customization." (interactive) - (gnugo-gate) (gnugo-animate-group 'worm)) (defun gnugo-worm-data () "Display in another buffer data from \"worm\" at current position. Signal error if done out-of-turn or if game-over." (interactive) - (gnugo-gate) (gnugo-display-group-data "worm_data" "*gnugo worm data*")) (defun gnugo-dragon-stones () @@ -1849,14 +1517,12 @@ Signal error if done out-of-turn or if game-over." Signal error if done out-of-turn or if game-over. See variable `gnugo-animation-string' for customization." (interactive) - (gnugo-gate) (gnugo-animate-group 'dragon)) (defun gnugo-dragon-data () "Display in another buffer data from \"dragon\" at current position. Signal error if done out-of-turn or if game-over." (interactive) - (gnugo-gate) (gnugo-display-group-data "dragon_data" "*gnugo dragon data*")) (defun gnugo-estimate-score () @@ -1877,6 +1543,12 @@ by how many stones)." (message "Est.score ... B %s %s | W %s %s | %s" black black-captures white white-captures est))) +(defun gnugo--ok-file (filename) + (setq default-directory + (file-name-directory + (expand-file-name filename))) + (set-buffer-modified-p nil)) + (defun gnugo-write-sgf-file (filename) "Save the game history to FILENAME (even if unfinished). If FILENAME already exists, Emacs confirms that you wish to overwrite it." @@ -1884,11 +1556,14 @@ 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) - (set-buffer-modified-p nil)) + (gnugo--ok-file filename)) (defun gnugo--dance-dance (karma) - (destructuring-bind (dance btw) + (cl-destructuring-bind (dance btw) (aref [(moshpit " Zombie") (classic nil) (reverse " Zombie Assist") ; "Assist Zombie"? no thanks! :-D @@ -1980,24 +1655,26 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (gnugo-put :last-user-bpos (gnugo-move-history 'bpos (gnugo-get :user-color))) (gnugo-refresh t) - (set-buffer-modified-p nil) + (gnugo--ok-file filename) (gnugo--who-is-who wait play samep))) (defun gnugo--mem-with-played-stone (pos &optional noerror) - (let ((color (case (following-char) + (let ((color (cl-case (following-char) (?X :B) (?O :W)))) (if (not color) (unless noerror (user-error "No stone at %s" pos)) - (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 noalt keep) + (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) + (gnugo--assist-state t) (let* ((user-color (gnugo-get :user-color)) (monkey (gnugo-get :monkey)) (tree (gnugo-get :sgf-gametree)) @@ -2011,16 +1688,10 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." 2) spec) (aref monkey 0)) - (let* ((pos (if (stringp spec) - spec - (gnugo-position))) - (hmm (gnugo--mem-with-played-stone pos))) - ;; todo: relax ‘gnugo--user-play’ then lift restriction - (unless (eq (gnugo--prop<-color user-color) - (car (gnugo--move-prop (car hmm)))) - (user-error "%s not occupied by %s" - pos user-color)) - (cdr hmm))))) + (cdr (gnugo--mem-with-played-stone + (if (stringp spec) + spec + (gnugo-position))))))) (when (gnugo-get :game-over) (gnugo--unclose-game)) (while (and (not (eq stop (aref monkey 0))) @@ -2031,7 +1702,6 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (gnugo-refresh) ; this (redisplay)) ; eye candy (let* ((ulastp (string= (gnugo-get :last-mover) user-color)) - (ubpos (gnugo-move-history (if ulastp 'car 'cadr)))) (gnugo-put :last-user-bpos (if (and ubpos (not (gnugo--passp ubpos))) ubpos @@ -2039,13 +1709,16 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (gnugo-refresh t) (unless (or keep remorseful) (aset ends (aref monkey 1) (aref monkey 0))) - (when (and ulastp (not noalt)) - (let ((wheel (gnugo-get :wheel))) - ;; ugh, backward compat - ;; todo: add auto-Zombie (see also "relax" above) - (letf (((cdr wheel) (remove (gnugo-get :gnugo-color) - (cdr wheel)))) - (gnugo--turn-the-wheel t))))))) + (when ulastp + (let ((g (gnugo-get :gnugo-color))) + (cl-flet ((turn () (gnugo--turn-the-wheel t))) + (cl-case (or reaction gnugo-undo-reaction) + (play (turn)) + (play! (let ((wheel (gnugo-get :wheel))) + (cl-letf (((cdr wheel) (cons g (cdr wheel)))) + (turn)))) + (zombie (gnugo-zombie-mode 1)) + (t (gnugo-put :one-shot g))))))))) (defun gnugo-undo-one-move (&optional me-next) "Undo exactly one move (perhaps GNU Go's, perhaps yours). @@ -2062,18 +1735,20 @@ See also `gnugo-undo-two-moves'." (gnugo-gate) (when me-next (let* ((play (gnugo-get :last-mover)) - (wait (gnugo-other play))) - (gnugo--who-is-who wait play (string= play (gnugo-get :user-color))) + (wait (gnugo-other play)) + (samep (string= play (gnugo-get :user-color)))) (gnugo-put :user-color play) - (gnugo-put :gnugo-color wait))) - (gnugo--climb-towards-root 1 t)) + (gnugo-put :gnugo-color wait) + (gnugo--who-is-who wait play samep))) + (gnugo--climb-towards-root 1 (cl-case gnugo-undo-reaction + (zombie gnugo-undo-reaction) + (t 'one-shot)))) (defun gnugo-undo-two-moves () "Undo a pair of moves (GNU Go's and yours). However, if you are the last mover, undo only one move. Regardless, after undoing, it is your turn to play again." (interactive) - (gnugo-gate) (gnugo--climb-towards-root 0)) (defun gnugo-oops (&optional position) @@ -2082,7 +1757,6 @@ The kept moves become a sub-gametree (variation) when play resumes. Prefix arg means, instead, undo repeatedly up to and including the move which placed the stone at point, like `\\[gnugo-fancy-undo]'." (interactive "P") - (gnugo-gate) (gnugo--climb-towards-root (unless position 0) nil t)) @@ -2105,7 +1779,7 @@ Prefix arg means to redo all the undone moves." (ucolor (gnugo-get :user-color)) (uprop (gnugo--prop<-color ucolor))) (cl-flet ((mvno (node) (gethash node mnum))) - (loop + (cl-loop with ok = (if full (mvno (car end)) (+ 2 (mvno (car mem)))) @@ -2121,7 +1795,7 @@ Prefix arg means to redo all the undone moves." todo)))) until (eq mem (cdr ls)) finally do - (loop + (cl-loop for (userp pos) in todo do (progn (gnugo-push-move userp pos) @@ -2183,25 +1857,25 @@ to the last move, as a comment." result (gnugo-query "final_score %d" seed)) (cond ((string= "Chinese" (gnugo--root-prop :RU)) (dolist (group live) - (incf (if (gnugo--blackp (caar group)) - b-terr - w-terr) - (length (cdr group)))) + (cl-incf (if (gnugo--blackp (caar group)) + b-terr + w-terr) + (length (cdr group)))) (dolist (group dead) - (incf (if (gnugo--blackp (caar group)) - w-terr - b-terr) - (length (cdr group)))) + (cl-incf (if (gnugo--blackp (caar 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)) blurb)) (t (dolist (group dead) - (incf (if (gnugo--blackp (caar group)) - w-terr - b-terr) - (* 2 (length (cdr group))))) + (cl-incf (if (gnugo--blackp (caar 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 @@ -2228,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) @@ -2278,14 +1952,20 @@ Otherwise, undo repeatedly up to and including the move which placed the stone at point." (interactive "P") (gnugo--climb-towards-root - (cond ((numberp count) count) - ((consp count) (car count))))) + (if (numberp count) + count + (car-safe count)))) -(defun gnugo-toggle-image-display-command () ; ugh - "Toggle use of images to display the board, then refresh." - (interactive) - (gnugo-toggle-image-display) - (save-excursion (gnugo-refresh))) +(define-minor-mode gnugo-image-display-mode + "If enabled, display the board using images. +See function `display-images-p' and variable `gnugo-xpms'." + :variable + ((gnugo-get :display-using-images) + . + (lambda (bool) + (unless (eq bool (gnugo-get :display-using-images)) + (gnugo-toggle-image-display) + (save-excursion (gnugo-refresh)))))) (defsubst gnugo--node-with-played-stone (pos &optional noerror) (car (gnugo--mem-with-played-stone pos noerror))) @@ -2308,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) - (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. @@ -2334,10 +2015,7 @@ If COMMENT is nil or the empty string, remove the property entirely." (gnugo--decorate node :C comment))) (defun gnugo--struggle (prop updn) - (unless (eq ; drudgery avoidance - (when (gnugo--:karma prop) ; normalize - t) - updn) + (unless (eq updn (gnugo--:karma prop)) ; drudgery avoidance (let ((color (gnugo-get prop))) (if updn ;; enable @@ -2379,7 +2057,7 @@ When disabling, if GNU Go has already started thinking of a move to play for you, the thinking is not cancelled but instead transformed into a move suggestion (see `gnugo-request-suggestion')." :variable - ((gnugo--:karma :user-color) + ((gnugo--assist-state) . (lambda (bool) (gnugo--struggle :user-color bool)))) @@ -2462,9 +2140,7 @@ NOTE: At this time, GTP command handling specification is still (define-derived-mode gnugo-board-mode special-mode "GNUGO Board" "Major mode for playing GNU Go. Entering this mode runs the normal hook `gnugo-board-mode-hook'. -In this mode, keys do not self insert. - -\\{gnugo-board-mode-map}" +In this mode, keys do not self insert." (buffer-disable-undo) ; todo: undo undo undoing (setq font-lock-defaults '(gnugo-font-lock-keywords t) truncate-lines t) @@ -2480,6 +2156,7 @@ In this mode, keys do not self insert. (overlay-put ov 'display ")") ov))) (gnugo-put :mul '(1 . 1)) + (gnugo-put :obarray (make-vector 31 nil)) (add-to-invisibility-spec :nogrid)) ;;;--------------------------------------------------------------------------- @@ -2529,7 +2206,7 @@ See `gnugo-board-mode' for a full list of commands." (gnugo-board-mode) (let* ((filename nil) (user-color "black") - (args (loop + (args (cl-loop with ls = (split-string ;; todo: grok ‘gnugo --help’; completion (read-string @@ -2597,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")) @@ -2635,78 +2311,6 @@ See `gnugo-board-mode' for a full list of commands." ;;;--------------------------------------------------------------------------- ;;; Load-time actions -(unless gnugo-frolic-mode-map - (setq gnugo-frolic-mode-map (make-sparse-keymap)) - (suppress-keymap gnugo-frolic-mode-map) - (mapc (lambda (pair) - (define-key gnugo-frolic-mode-map (car pair) (cdr pair))) - '(("q" . gnugo-frolic-quit) - ("Q" . gnugo-frolic-quit) - ("\C-q" . gnugo-frolic-quit) - ("C" . gnugo-frolic-quit) ; like ‘View-kill-and-leave’ - ("\C-b" . gnugo-frolic-backward-branch) - ("\C-f" . gnugo-frolic-forward-branch) - ("\C-p" . gnugo-frolic-previous-move) - ("\C-n" . gnugo-frolic-next-move) - ("j" . gnugo-frolic-exchange-left) - ("J" . gnugo-frolic-rotate-left) - ("k" . gnugo-frolic-exchange-right) - ("K" . gnugo-frolic-rotate-right) - ("\C-m" . gnugo-frolic-set-as-main-line) - ("\C-\M-p" . gnugo-frolic-prune-branch) - ("o" . gnugo-frolic-return-to-origin)))) - -(unless gnugo-board-mode-map - (setq gnugo-board-mode-map (make-sparse-keymap)) - (suppress-keymap gnugo-board-mode-map) - (mapc (lambda (pair) - (define-key gnugo-board-mode-map (car pair) (cdr pair))) - '(("?" . describe-mode) - ("S" . gnugo-request-suggestion) - ("\C-m" . gnugo-move) - (" " . gnugo-move) - ("P" . gnugo-pass) - ("R" . gnugo-resign) - ("q" . gnugo-quit) - ("Q" . gnugo-leave-me-alone) - ("U" . gnugo-fancy-undo) - ("\M-u" . gnugo-undo-one-move) - ("u" . gnugo-undo-two-moves) - ("\C-?" . gnugo-undo-two-moves) - ("o" . gnugo-oops) - ("O" . gnugo-okay) - ("\C-l" . gnugo-refresh) - ("\M-_" . gnugo-boss-is-near) - ("_" . gnugo-boss-is-near) - ("h" . gnugo-move-history) - ("L" . gnugo-frolic-in-the-leaves) - ("\C-c\C-l" . gnugo-frolic-in-the-leaves) - ("i" . gnugo-toggle-image-display-command) - ("w" . gnugo-worm-stones) - ("W" . gnugo-worm-data) - ("d" . gnugo-dragon-stones) - ("D" . gnugo-dragon-data) - ("g" . gnugo-toggle-grid) - ("!" . gnugo-estimate-score) - (":" . gnugo-command) - (";" . gnugo-command) - ("=" . gnugo-describe-position) - ("s" . gnugo-write-sgf-file) - ("\C-x\C-s" . gnugo-write-sgf-file) - ("\C-x\C-w" . gnugo-write-sgf-file) - ("l" . gnugo-read-sgf-file) - ("F" . gnugo-display-final-score) - ("A" . gnugo-switch-to-another) - ("C" . gnugo-comment) - ("\C-c\C-a" . gnugo-assist-mode) - ("\C-c\C-z" . gnugo-zombie-mode) - ;; mouse - ([(down-mouse-1)] . gnugo-mouse-move) - ([(down-mouse-2)] . gnugo-mouse-move) ; mitigate accidents - ([(down-mouse-3)] . gnugo-mouse-pass) - ;; delving into the curiosities - ("\C-c\C-p" . gnugo-describe-internal-properties)))) - (unless (get 'help :gnugo-gtp-command-spec) (cl-flet* ((sget (x) (get x :gnugo-gtp-command-spec)) @@ -2714,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))) - (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)) @@ -2744,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)) @@ -2758,12 +2363,13 @@ See `gnugo-board-mode' for a full list of commands." (when (setq output (plist-get spec :output)) (if (functionp output) (note "handles the output specially") - (case output + (cl-case output (:discard (note "discards the output")) (:message (note "displays the output in the echo area"))))) (when (eq sel cur) - (setq found (match-beginning 0)))))) - (cond (found (goto-char found)) + (setq found (make-marker)) + (set-marker found (match-beginning 0)))))) + (cond (found (goto-char found) (set-marker found nil)) ((not sel)) (t (message "(no such command: %s)" sel))))) @@ -2905,14 +2511,14 @@ A collection is a list of gametrees, each a vector of four elements: (specs (or (get 'gnugo/sgf-*r4-properties* :specs) (put 'gnugo/sgf-*r4-properties* :specs (mapcar (lambda (full) - (cons (car full) (cdddr full))) + (cons (car full) (cl-cdddr full))) gnugo/sgf-*r4-properties*)))) SZ) (cl-labels ((sw () (skip-chars-forward " \t\n")) (x (end preserve-whitespace) (let ((beg (point)) - (endp (case end + (endp (cl-case end (:end (lambda (char) (= ?\] char))) (:mid (lambda (char) (= ?\: char))) (t (lambda (char) (or (= ?\: char) @@ -2933,7 +2539,7 @@ A collection is a list of gametrees, each a vector of four elements: (one (type end) (let ((s (progn (forward-char 1) (x end (eq 'text type))))) - (case type + (cl-case type ((stone point move) ;; blech, begone bu"tt"-ugly blatherings ;; (but bide brobdingnagian boards)... @@ -2963,7 +2569,7 @@ A collection is a list of gametrees, each a vector of four elements: ;; probably this assumption is consistent ;; w/ the SGF authors' desire to make the ;; parsing easy, but you never know... - (cons v (one (cdaddr spec) :end))))) + (cons v (one (cl-cdaddr spec) :end))))) (t (cons (one (car spec) :mid) (one (cdr spec) :end))))) (short (who) (when (eobp) @@ -3000,12 +2606,13 @@ A collection is a list of gametrees, each a vector of four elements: (forward-char 1) t)) (NODE () (when (seek-into ?\;) - (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) @@ -3025,34 +2632,35 @@ A collection is a list of gametrees, each a vector of four elements: ;; singular (list ls) ;; multiple - (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))) - (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))) - (cdddr full))) + (cl-cdddr full))) gnugo/sgf-*r4-properties*)) p name v spec) (cl-labels ((esc (composed fmt arg) (mapconcat (lambda (c) - (case c + (cl-case c ;; ‘?\[’ is not strictly required ;; but neither is it forbidden. ((?\[ ?\] ?\\) (format "\\%c" c)) @@ -3095,9 +2703,10 @@ A collection is a list of gametrees, each a vector of four elements: (t (>>one v) (>>nl)))) (>>node (node) - (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)) @@ -3110,14 +2719,12 @@ 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))) (cl-flet ((hang (stack) - (loop + (cl-loop with rh ; rectified history with bp ; branch point for node in stack