(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.")
(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)))
(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)
(_ nil)))))
(define-derived-mode gnugo-frolic-mode special-mode "GNUGO Frolic"
- "A special mode for viewing a GNUGO gametree.
-Initially View minor mode is active.
+ "A special mode for manipulating a GNUGO gametree.
\\{gnugo-frolic-mode-map}"
+ (setq truncate-lines t)
(buffer-disable-undo))
(defun gnugo-frolic-quit ()
(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
(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 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*
(set (make-local-variable 'gnugo-frolic-origin) finish)
(gnugo-frolic-return-to-origin))))
-(defun gnugo--awake ()
+(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 (count-lines (point-min) (line-beginning-position)))
- (col (current-column)))
- (values tree ends width
- monkey (aref monkey 1)
- line col (unless (> 10 col)
- (let ((try (/ (- col 10)
- 6)))
- (unless (<= width try)
- try))))))
-
-(defmacro gnugo--awakened (&rest body)
- `(multiple-value-bind (tree ends width
- monkey bidx
- line col
- a)
- (gnugo--awake)
+ (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
- (unless a
- (user-error "No branch here"))
- (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))))
+ (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."
This fails if the monkey is on the current branch
\(a restriction that will probably be lifted Real Soon Now\)."
(interactive)
- (gnugo--awakened
- (unless a
- (user-error "No branch here"))
- ;; 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"))
- ;; A numeric line number is unreliable; branch points might vanish.
- ;; Hang on to something more useful, instead.
- (setq line (save-excursion
- (when (re-search-backward "^ *[0-9]+ [BW]" nil t)
- (match-string 0))))
- (let* ((new (append ends nil))
- ;; Gratuitous ‘pop’ rv assignment avoids byte-compiler warning.
- (bye (pop (nthcdr a new))))
- (gnugo--set-tree-ends tree (apply 'vector 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))))))
+ (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--awakened
- (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
- (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))
- (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
-(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)
- ("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-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))
("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)))))