X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/3f0e9993715c93d847861b39f2d81d434bc65f9c..f5185fad93cc5ea244172baceb2272a604331ea4:/packages/gnugo/gnugo.el diff --git a/packages/gnugo/gnugo.el b/packages/gnugo/gnugo.el index 73e0dfe7c..ffa2ebbe4 100644 --- a/packages/gnugo/gnugo.el +++ b/packages/gnugo/gnugo.el @@ -66,16 +66,20 @@ ;; `gnugo-animation-string' ;; `gnugo-mode-line' ;; `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face' +;; `gnugo-undo-reaction' ;; `gnugo-xpms' ;; 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: @@ -162,6 +166,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,9 +215,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) @@ -286,7 +324,7 @@ Handle the big, slow-to-render, and/or uninteresting ones specially." using (hash-values val) do (push (cons key (case key - ((:xpms :local-xpms) + ((:xpms) (format "hash: %X (%d images)" (sxhash val) (length val))) @@ -485,12 +523,13 @@ when you are sure the command cannot fail." (t 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))) @@ -1726,12 +1765,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 +1786,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 +1831,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) @@ -1822,6 +1871,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 +1884,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 +1897,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 +1923,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." @@ -1885,7 +1937,7 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." (not (y-or-n-p "File exists. Continue? "))) (user-error "Not writing %s" filename)) (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) @@ -1980,7 +2032,7 @@ 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) @@ -1996,8 +2048,9 @@ If FILENAME already exists, Emacs confirms that you wish to overwrite it." return mem finally return nil)))) -(defun gnugo--climb-towards-root (spec &optional noalt keep) +(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 +2064,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 +2078,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 +2085,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))) + (case (or reaction gnugo-undo-reaction) + (play (turn)) + (play! (let ((wheel (gnugo-get :wheel))) + (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,11 +2111,14 @@ 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 (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). @@ -2332,10 +2384,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 @@ -2377,7 +2426,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))))