(gethash key gnugo-state))
(defsubst gnugo--tree-mnum (tree)
- (aref tree 0))
+ (aref tree 1))
(defsubst gnugo--tree-ends (tree)
- (aref tree 2))
+ (aref tree 0))
(defsubst gnugo--set-tree-ends (tree ls)
- (aset tree 2 (apply 'vector ls))
- ;; hmm, probably unnecessary
- tree)
+ (aset tree 0 (apply 'vector ls))
+ (gnugo--tree-ends tree))
(defun gnugo-describe-internal-properties ()
"Pretty-print `gnugo-state' properties in another buffer.
(:sgf-gametree
(list (hash-table-count
(gnugo--tree-mnum val))
- (hash-table-count
- (aref val 1))
(gnugo--tree-ends val)))
(:monkey
(let ((mem (aref val 0)))
(when (gnugo-get :waitingp)
(user-error "Not your turn yet -- please wait for \"\(%s to play\)\""
(gnugo-get :user-color)))
- (when (and (gnugo-get :game-over) in-progress-p)
+ (when (and in-progress-p (gnugo-get :game-over))
(user-error "Sorry, game over")))
(defun gnugo-sentinel (proc string)
(defun gnugo--root-node (&optional tree)
(aref (or tree (gnugo-get :sgf-gametree))
- 3))
+ 2))
(defsubst gnugo--root-prop (prop &optional tree)
(cdr (assq prop (gnugo--root-node tree))))
(or (assq :B node)
(assq :W node)))
-(defun gnugo--as-pos-func (size)
- (lexical-let ((size size))
+(defun gnugo--as-pos-func ()
+ (lexical-let ((size (gnugo-get :SZ)))
;; rv
(lambda (cc)
(if (string= "" cc)
(interactive "P")
(let* ((monkey (gnugo-get :monkey))
(mem (aref monkey 0))
- (as-pos (gnugo--as-pos-func (gnugo-get :SZ)))
- col
+ (as-pos (gnugo--as-pos-func))
acc node mprop move)
(cl-flet*
((as-pos-maybe (x) (if (string= "resign" x)
(width (length ends))
(lanes (number-sequence 0 (1- width)))
(monkey (gnugo-get :monkey))
- (as-pos (gnugo--as-pos-func (gnugo-get :SZ)))
+ (as-pos (gnugo--as-pos-func))
(at (car (aref monkey 0)))
(bidx (aref monkey 1))
(valid (map 'vector (lambda (end)
(gethash node seen))
(emph (s face)
(propertize s 'face face))
- (fsi (fmt &rest args)
- (insert (apply 'format fmt args))))
+ (fsi (properties fmt &rest args)
+ (insert (apply 'propertize
+ (apply 'format fmt args)
+ properties))))
;; breathe in
(loop
for bx below width
do (loop
- with (node fork)
+ with fork
for node in (aref ends bx)
do (if (setq fork (on node))
(cl-flet
(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 "%3d %s -- "
+ (fsi props
+ "%3d %s -- "
n (aref ["W" "B"] (logand 1 n))))
for bx below width
do (let* ((node (unless (< (aref valid bx) n)
(when (and ok (setq br (gethash node soil)))
(push (cons bx (sort br '<))
forks))
- (fsi " %-5s"
+ (fsi (list* 'bx bx props)
+ " %-5s"
(cond ((and (eq at node)
(or ok (= bx bidx)))
(when (= bx bidx)
(emph s dimmed-node-face))
(t s))))
finally do
- (when (progn (newline)
+ (when (progn (fsi props "\n")
(setq forks (nreverse forks)))
(let* ((margin (make-string 11 ?\s))
- (count (length forks))
(heads (mapcar #'car forks))
(tails (mapcar #'cdr forks)))
(cl-flet*
(let ((try (/ (- col 10)
6)))
(unless (<= width try)
- try)))))
+ try))))
+ (rv (list a)))
(when (memq 'require-valid-branch how)
(unless a
(user-error "No branch here")))
- (values tree ends width
- monkey (aref monkey 1)
- line a)))
+ (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))
- `(multiple-value-bind (tree ends width
- monkey bidx
- line
- a)
+ `(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))
(defun gnugo--swiz (direction &optional blunt)
(gnugo--awakened (require-valid-branch
+ (omit tree)
(line . numeric))
(let* ((b (cond ((numberp blunt)
(unless (and (< -1 blunt)
(user-error "Cannot prune with monkey on branch"))
(when (= 1 width)
(user-error "Cannot prune last remaining branch"))
- (let* ((new (append ends nil))
- ;; Gratuitous ‘pop’ rv assignment avoids byte-compiler warning.
- (bye (pop (nthcdr a new))))
+ (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)))
(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--awakened nil
- (gnugo--move-to-bcol (mod (- (or a width) n) width))))
+ (gnugo--sideways t n))
(defun gnugo-frolic-forward-branch (&optional n)
"Move forward N (default 1) branches."
(interactive "p")
- (gnugo--awakened nil
- (gnugo--move-to-bcol (mod (+ (or a -1) n) width))))
+ (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."
(eq (aref ends (aref monkey 1))
(aref monkey 0)))
+(defun gnugo--as-cc-func ()
+ (lexical-let ((size (gnugo-get :SZ)))
+ (lambda (pos)
+ (let* ((col (aref pos 0))
+ (one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
+ (two (+ ?a (- size (string-to-number
+ (substring pos 1))))))
+ (format "%c%c" one two)))))
+
(defun gnugo-note (property value &optional mogrifyp)
(when mogrifyp
- (let ((sz (gnugo-get :SZ)))
+ (let ((as-cc (gnugo--as-cc-func)))
(cl-flet
((mog (pos) (if (gnugo--passp pos)
""
- (let* ((col (aref pos 0))
- (one (+ ?a (- col (if (< ?H col) 1 0) ?A)))
- (two (+ ?a (- sz (string-to-number
- (substring pos 1))))))
- (format "%c%c" one two)))))
+ (funcall as-cc pos))))
(setq value (if (consp value)
(mapcar #'mog value)
(mog value))))))
finally do
(progn
(unless (gnugo--no-regrets monkey ends)
- (gnugo--set-tree-ends
- tree (let ((ls (append ends nil)))
- ;; copy old to the right of new
- (push mem (nthcdr bidx ls))
- ls)))
+ (setq ends (gnugo--set-tree-ends
+ tree (let ((ls (append ends nil)))
+ ;; copy old to the right of new
+ (push mem (nthcdr bidx ls))
+ ls))))
(puthash fruit (1+ (gethash tip mnum)) mnum)
(push fruit mem)
(aset ends bidx mem)))
0)
nil t))
+(defun gnugo-okay (&optional full)
+ "Redo a pair of undone moves.
+Prefix arg means to redo all the undone moves."
+ (interactive "P")
+ (gnugo-gate)
+ (let* ((tree (gnugo-get :sgf-gametree))
+ (ends (gnugo--tree-ends tree))
+ (monkey (gnugo-get :monkey)))
+ (if (gnugo--no-regrets monkey ends)
+ (message "Oop ack!")
+ (let* ((as-pos (gnugo--as-pos-func))
+ (mnum (gnugo--tree-mnum tree))
+ (mem (aref monkey 0))
+ (bidx (aref monkey 1))
+ (end (aref ends bidx))
+ (ucolor (gnugo-get :user-color))
+ (gcolor (gnugo-other ucolor))
+ (uprop (if (gnugo--blackp ucolor)
+ :B :W)))
+ (cl-flet ((mvno (node) (gethash node mnum)))
+ (loop
+ with ok = (if full
+ (mvno (car end))
+ (+ 2 (mvno (car mem))))
+ with (node move todo)
+ for ls on end
+ do (progn
+ (setq node (car ls)
+ move (gnugo--move-prop node))
+ (when (and move (>= ok (mvno node)))
+ (let ((userp (eq uprop (car move))))
+ (push (list (if userp ucolor gcolor)
+ userp
+ (funcall as-pos (cdr move)))
+ todo))))
+ until (eq mem (cdr ls))
+ finally do
+ (loop
+ for (color userp pos) in todo
+ do (let* ((move (format "play %s %s" color pos))
+ (accept (gnugo--q move)))
+ (unless (= ?= (aref accept 0))
+ (user-error "%s" accept))
+ (gnugo-push-move userp pos)
+ (gnugo-refresh)
+ (redisplay)))))))))
+
(defun gnugo-display-final-score ()
"Display final score and other info in another buffer (when game over).
If the game is still ongoing, Emacs asks if you wish to stop play (by
(save-excursion (gnugo-refresh)))
(defun gnugo-describe-position ()
- "Display the board position under cursor in the echo area."
+ "Display the board position under cursor in the echo area.
+If there a stone at that position, also display its move number."
(interactive)
- (message "%s" (gnugo-position)))
+ (let ((pos (gnugo-position)) ; do first (can throw)
+ (color (case (following-char)
+ (?X :B)
+ (?O :W))))
+ (message
+ "%s%s" pos
+ (or (when color
+ (loop
+ with monkey = (gnugo-get :monkey)
+ with tree = (gnugo-get :sgf-gametree)
+ with mnum = (gnugo--tree-mnum tree)
+ with as-cc = (gnugo--as-cc-func)
+ with fruit = (cons color (funcall as-cc pos))
+ for node in (aref monkey 0)
+ if (member fruit node)
+ return
+ (format " (move %d)"
+ (gethash node mnum))
+ finally return
+ nil))
+ ""))))
(defun gnugo-switch-to-another ()
"Switch to another GNU Go game buffer (if any)."
'gnugo-option-history))
proc
board-size user-color handicap komi minus-l infile)
- (loop for (var default opt &optional rx)
+ (loop for (var default opt rx)
in '((board-size 19 "--boardsize")
(user-color "black" "--color" "\\(black\\|white\\)")
(handicap 0 "--handicap")
(gnugo-put :monkey (vector (aref (gnugo--tree-ends tree) 0) 0)))
(gnugo--SZ! board-size)
(loop with gb = (gnugo--blackp (gnugo-other user-color))
- for (property value &optional mogrifyp) in
+ for (property value mogrifyp) in
`((:SZ ,board-size)
(:DT ,(format-time-string "%Y-%m-%d"))
(:RU ,(if (string-match "--chinese-rules" args)
("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)
("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)
(t (message "(no such command: %s)" sel)))))
(deffull final_score
+ ;; Explicit ignorance avoids byte-compiler warning.
+ (ignore sel)
(gnugo-display-final-score))
(defgtp '(boardsize
a string containing SGF[4] data.
A collection is a list of gametrees, each a vector of four elements:
- MNUM -- `eq' hash: node to move numbers; non-\"move\" nodes
- have a move number of the previous \"move\" node (or zero)
-
- KIDS -- `eq' hash: node to node list (branch points only)
-
ENDS -- a vector of node lists, with shared tails
(last element of all the lists is the root node)
+ MNUM -- `eq' hash: node to move numbers; non-\"move\" nodes
+ have a move number of the previous \"move\" node (or zero)
+
ROOT -- the root node"
;; Arg names inspired by `create-image', despite -P being frowned upon.
(let ((keywords (or (get 'gnugo/sgf-*r4-properties* :keywords)
SZ)
(cl-labels
((sw () (skip-chars-forward " \t\n"))
- (x (end) (let ((beg (point))
- (endp (case end
- (:end (lambda (char) (= ?\] char)))
- (:mid (lambda (char) (= ?\: char)))
- (t (lambda (char) (or (= ?\: char)
- (= ?\] char))))))
- c)
- (while (not (funcall endp (setq c (following-char))))
- (cond ((= ?\\ c)
- (delete-char 1)
- (if (eolp)
- (kill-line 1)
- (forward-char 1)))
- ((looking-at "\\s-+")
- (delete-region (point) (match-end 0))
- (insert " "))
- (t (forward-char 1))))
- (buffer-substring-no-properties beg (point))))
+ (x (end preserve-whitespace)
+ (let ((beg (point))
+ (endp (case end
+ (:end (lambda (char) (= ?\] char)))
+ (:mid (lambda (char) (= ?\: char)))
+ (t (lambda (char) (or (= ?\: char)
+ (= ?\] char))))))
+ c)
+ (while (not (funcall endp (setq c (following-char))))
+ (cond ((= ?\\ c)
+ (delete-char 1)
+ (if (eolp)
+ (kill-line 1)
+ (forward-char 1)))
+ ((unless preserve-whitespace
+ (looking-at "\\s-+"))
+ (delete-region (point) (match-end 0))
+ (insert " "))
+ (t (forward-char 1))))
+ (buffer-substring-no-properties beg (point))))
(one (type end) (let ((s (progn
(forward-char 1)
- (x end))))
+ (x end (eq 'text type)))))
(case type
((stone point move)
;; blech, begone bu"tt"-ugly blatherings
(when (eq :SZ (car prop))
(setq SZ (cdr prop)))
prop))))
- (TREE (parent mnum kids)
+ (TREE (parent mnum)
(let ((ls parent)
prev node)
(seek-into ?\()
0)
(gethash prev mnum 0))
mnum)
- ;; phase 2
- (when (listp (gethash prev kids t))
- (push node (gethash prev kids)))
(push node
ls))
(prog1
;; singular
(list ls)
;; multiple
- ;; phase 1
- (puthash node (list) kids)
(loop while (seek ?\()
- append (TREE ls mnum kids)))
+ append (TREE ls mnum)))
(seek-into ?\))))))
(with-temp-buffer
(if (not data-p)
(goto-char (point-min)))
(loop while (morep)
collect (let* ((mnum (gnugo--mkht :weakness 'key))
- (kids (gnugo--mkht))
- (ends (TREE nil mnum kids))
+ (ends (TREE nil mnum))
(root (car (last (car ends)))))
- (vector mnum
- kids
- (apply 'vector ends)
+ (vector (apply 'vector ends)
+ mnum
root)))))))
-(defun gnugo/sgf-hang-from-root (tree)
- (let ((ht (gnugo--mkht))
- (leaves (append (gnugo--tree-ends tree) nil)))
- (cl-flet
- ((hang (stack)
- (loop
- with rh ; rectified history
- with bp ; branch point
- for node in stack
- until (setq bp (gethash node ht))
- do (puthash node
- (push node rh) ; good for now: ½τ
- ht)
- finally return
- (if (not bp)
- ;; first run: main line
- rh
- ;; subsequent runs: grafts (value discarded)
- (setcdr bp (nconc
- ;; Maintain order of ‘leaves’.
- (let ((was (cdr bp)))
- (if (gnugo--nodep (car was))
- (list was)
- was))
- (list rh)))))))
- (setq tree (hang (pop leaves)))
- (mapc #'hang leaves)
- tree)))
-
(defun gnugo/sgf-write-file (collection filename)
- ;; take responsibility for our actions
- (let ((me (cons "gnugo.el" gnugo-version)))
- (dolist (tree collection)
- (gnugo--set-root-prop :AP me tree)))
- ;; write it out
(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)))
gnugo/sgf-*r4-properties*))
p name v spec)
- ;; todo: escape special chars for `text' and `simpletext'.
(cl-labels
- ((>>one (v) (insert (format "[%s]" v)))
- (>>two (v) (insert (format "[%s:%s]" (car v) (cdr v))))
+ ((esc (composed fmt arg)
+ (mapconcat (lambda (c)
+ (case c
+ ;; ‘?\[’ is not strictly required
+ ;; but neither is it forbidden.
+ ((?\[ ?\] ?\\) (format "\\%c" c))
+ (?: (concat (if composed "\\" "") ":"))
+ (t (string c))))
+ (string-to-list (format fmt arg))
+ ""))
+ (>>one (v) (insert "[" (esc nil "%s" v) "]"))
+ (>>two (v) (insert "["
+ (esc t "%s" (car v))
+ ":"
+ (esc t "%s" (cdr v))
+ "]"))
(>>nl () (cond ((memq name aft-newline-appreciated)
(insert "\n"))
((< 60 (current-column))
(insert ")")))
(with-temp-buffer
(dolist (tree collection)
- (>>tree (gnugo/sgf-hang-from-root tree)))
+ ;; 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
+ with rh ; rectified history
+ with bp ; branch point
+ for node in stack
+ until (setq bp (gethash node ht))
+ do (puthash node
+ (push node rh) ; good for now: ½τ
+ ht)
+ finally return
+ (if (not bp)
+ ;; first run: main line
+ rh
+ ;; subsequent runs: grafts (value discarded)
+ (setcdr bp (nconc
+ ;; Maintain order of ‘leaves’.
+ (let ((was (cdr bp)))
+ (if (gnugo--nodep (car was))
+ (list was)
+ was))
+ (list rh)))))))
+ (setq tree (hang (pop leaves)))
+ (mapc #'hang leaves)
+ (>>tree tree))))
(newline)
(write-file filename)))))