(defvar gnugo-board-mode-map nil
"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.")
(eval-when-compile
(defvar gnugo-xpms nil))
+(defvar gnugo-frolic-parent-buffer nil)
+(defvar gnugo-frolic-origin nil)
+
;;;---------------------------------------------------------------------------
;;; Support functions
(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 ends)
- (aset tree 2 ends)
- ;; hmm, probably unnecessary
- tree)
+(defsubst gnugo--set-tree-ends (tree ls)
+ (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)))
(defun gnugo-board-buffer-p (&optional buffer)
"Return non-nil if BUFFER is a GNUGO Board buffer."
- (with-current-buffer (or buffer (current-buffer)) gnugo-state))
+ (eq 'gnugo-board-mode
+ (buffer-local-value
+ 'major-mode
+ (or buffer (current-buffer)))))
(defun gnugo-board-user-play-ok-p (&optional buffer)
"Return non-nil if BUFFER is a GNUGO Board buffer ready for a user move."
(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)
(`two (nn) (nn) acc)
(_ 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:
to indicate the branches. Branch 0 is the \"main line\".
Point (* in this example) indicates the current position,
and moves not actually on the game tree (e.g., E7, branch 3)
-are dimmed. The buffer is in View minor mode."
+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 (gnugo--tree-ends tree))
+ (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 (gnugo-get :SZ)))
+ (as-pos (gnugo--as-pos-func))
(at (car (aref monkey 0)))
(bidx (aref monkey 1))
- (max-move-num (loop for bx in lanes
- maximize (gethash (car (aref ends bx))
- mnum)))
- (eert (make-vector width nil))
+ (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 (fmt &rest args)
- (insert (apply 'format fmt args))))
+ (fsi (properties fmt &rest args)
+ (insert (apply 'propertize
+ (apply 'format fmt args)
+ properties))))
;; breathe in
- (let ((monkey-on-main-line (zerop bidx))
- fixup)
- ;; monkey knows a lot
- (loop with acc
- for node in (aref monkey 0)
- do (puthash node bidx seen)
- if (gnugo--move-prop node)
- do (push node acc)
- finally do (progn
- (unless monkey-on-main-line
- (setq fixup (apply 'vector acc)))
- (aset eert bidx acc)))
- ;; but monkey does not know everything
- (loop
- for bx below width
- do (loop
- with (bef acc node fork cur)
- for ls on (aref ends bx)
- do (if (setq node (car ls)
- fork (on node))
- (cl-flet
- ((link (other)
- (push other (gethash node soil))))
- (let ((move-num (gethash node mnum)))
- (when (< bx fork)
- (assert (and (not monkey-on-main-line)
- (= fork bidx)))
- (loop for old in ls
- while (< bx (on old))
- do (puthash old bx seen))
- (when (< move-num (length fixup))
- (link (aref fixup move-num))))
- ;; ugh, wasteful
- (when (setq bef (copy-sequence (aref eert fork)))
- (setcdr (nthcdr (1- move-num) bef)
- acc))
- (aset eert bx (or bef acc))
- (when acc
- (link (car acc)))))
- (puthash node bx seen)
- (when (gnugo--move-prop node)
- (push node acc)))
- until fork)))
+ (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)
- (when view-mode
- (view-mode -1))
- (buffer-disable-undo)
+ (gnugo-frolic-mode)
(erase-buffer)
(setq header-line-format
- (concat (make-string 11 ?\s)
- (mapconcat (lambda (n)
- (format "%-5s" n))
- lanes
- " ")))
+ (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 1 upto max-move-num
+ from max-move-num downto 1
+ do (setq props (list 'n n))
do
(loop
with (move forks br)
- initially (fsi "%3d %s -- "
- n (aref ["W" "B"] (logand 1 n)))
+ initially (progn
+ (goto-char (point-min))
+ (fsi props
+ "%3d %s -- "
+ n (aref ["W" "B"] (logand 1 n))))
for bx below width
- do (let* ((node (pop (aref eert bx)))
+ do (let* ((node (unless (< (aref valid bx) n)
+ ;; todo: ignore non-"move" nodes
+ (pop (aref ends bx))))
(ok (when node
(= bx (on node))))
(s (cond ((not node) "")
((not (setq move (gnugo--move-prop node))) "-")
(t (funcall as-pos (cdr move))))))
- ;; todo: move this into "breathe in"
(when (and ok (setq br (gethash node soil)))
- (setq br (delq bx (mapcar #'on br)))
- (when (and br (car (aref eert bx)))
- (push bx br))
- ;; do not point w/ a fist
- (when br
- (push (cons bx (sort br '<))
- forks)))
- (fsi " %-5s"
+ (push (cons bx (sort br '<))
+ forks))
+ (fsi (list* 'bx bx props)
+ " %-5s"
(cond ((and (eq at node)
(or ok (= bx bidx)))
(when (= bx bidx)
- (setq finish (point)))
+ (setq finish (point-marker)))
(emph s (list :inherit 'default
:foreground (frame-parameter
nil 'cursor-color))))
(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*
(- (1+ (length forks))))
(point))))))))
(when finish
- (goto-char finish)
- (recenter (- (count-lines (line-beginning-position) (point-max)))))
- (view-mode 1)))
+ (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)
+ ;; 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."
(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))
- (apply 'vector 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)
;;;---------------------------------------------------------------------------
;;; 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)
+ ("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)
("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 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)))))