├── .gitignore
├── .gitattributes
├── screenshot
    ├── igo-org-20201205.gif
    └── igo-org-20201227.gif
├── igo-sgf-mode.el
├── igo-org.el
├── README.org
├── igo-sgf-parser.el
├── igo-org-export-html.el
├── igo-view.el
└── igo-model.el


/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.elc
3 | README.html
4 | 


--------------------------------------------------------------------------------
/.gitattributes:
--------------------------------------------------------------------------------
1 | *.el encoding=utf-8
2 | *.org encoding=utf-8
3 | 


--------------------------------------------------------------------------------
/screenshot/igo-org-20201205.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/misohena/el-igo/master/screenshot/igo-org-20201205.gif


--------------------------------------------------------------------------------
/screenshot/igo-org-20201227.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/misohena/el-igo/master/screenshot/igo-org-20201227.gif


--------------------------------------------------------------------------------
/igo-sgf-mode.el:
--------------------------------------------------------------------------------
  1 | ;;; igo-sgf-mode.el --- SGF Editing Mode  -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2020  AKIYAMA Kouhei
  4 | 
  5 | ;; Author: AKIYAMA Kouhei
  6 | ;; Keywords: games
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; (add-to-list 'auto-mode-alist '("\\.sgf$" . igo-sgf-mode))
 24 | 
 25 | ;;; Code:
 26 | 
 27 | (require 'igo-editor)
 28 | 
 29 | (defvar-local igo-sgf-mode-editor nil)
 30 | 
 31 | (defun igo-sgf-mode ()
 32 |   "Major mode for editing SGF files.
 33 | 
 34 | The following commands are available:
 35 | 
 36 | \\{igo-sgf-mode-map}"
 37 |   (interactive)
 38 | 
 39 |   ;; Create new igo-editor
 40 |   (setq igo-sgf-mode-editor (igo-editor (point-min) (point-max) nil nil t))
 41 |   (igo-sgf-mode-transfer-overlay-keymap-to-local-map igo-sgf-mode-editor)
 42 |   (igo-sgf-mode-track-buffer-read-only igo-sgf-mode-editor)
 43 | 
 44 |   ;; Set major mode
 45 |   (setq mode-name "SGF(Go Game)")
 46 |   (setq major-mode 'igo-sgf-mode)
 47 |   (setq font-lock-defaults '(igo-sgf-mode-font-lock-keywords t))
 48 | 
 49 | 
 50 |   (run-mode-hooks 'igo-sgf-mode-hook))
 51 | 
 52 | ;; Font Lock
 53 | 
 54 | (defvar igo-sgf-mode-font-lock-keywords
 55 |   '((igo-sgf-mode-fontify)))
 56 | 
 57 | (defun igo-sgf-mode-fontify (_limit)
 58 |   (let ((editor igo-sgf-mode-editor))
 59 |     ;; Cover whole buffer
 60 |     (igo-editor-set-region editor (point-min) (point-max))
 61 |     ;; Update editor state from buffer text.
 62 |     (igo-editor-update editor)
 63 |     ;; Set font-lock properties
 64 |     (add-text-properties (point-min) (point-max)
 65 |                          '(font-lock-fontified t font-lock-multiline t))
 66 |     ;; Highlight error place
 67 |     (if (igo-editor-last-error editor)
 68 |         (put-text-property (igo-editor-last-error-begin editor)
 69 |                            (igo-editor-last-error-end editor)
 70 |                            'face 'igo-org-error-face))))
 71 | 
 72 | (defun igo-sgf-mode-fontify-buffer ()
 73 |   (save-excursion
 74 |     (goto-char (point-min))
 75 |     (igo-sgf-mode-fontify (point-max))))
 76 | 
 77 | 
 78 | ;; Keymap
 79 | 
 80 | (defvar-local igo-sgf-mode-map nil)
 81 | 
 82 | (defun igo-sgf-mode-transfer-overlay-keymap-to-local-map (editor)
 83 |   (let* ((ov (igo-editor-overlay editor))
 84 |          (keymap (overlay-get ov 'keymap)))
 85 |     ;; Transfer overlay's keymap property to local-map.
 86 |     (setq-local igo-sgf-mode-map keymap)
 87 |     (use-local-map keymap)
 88 |     (overlay-put ov 'keymap nil) ;; remove keymap property
 89 |     ;; Track keymap changes.
 90 |     (igo-editor-add-hook editor 'keymap-change #'igo-sgf-mode-on-keymap-change)
 91 | 
 92 |     editor))
 93 | 
 94 | (defun igo-sgf-mode-on-keymap-change (_editor keymap)
 95 |   (setq-local igo-sgf-mode-map keymap)
 96 |   (use-local-map keymap)
 97 |   ;; Return t. EDITOR does not change the overlay's keymap.
 98 |   t)
 99 | 
100 | ;; Read Only
101 | 
102 | (defun igo-sgf-mode-track-buffer-read-only (editor)
103 |   (igo-sgf-mode-update-buffer-read-only editor)
104 |   (igo-editor-add-hook editor 'text-mode
105 |                        #'igo-sgf-mode-update-buffer-read-only)
106 |   (igo-editor-add-hook editor 'graphical-mode
107 |                        #'igo-sgf-mode-update-buffer-read-only))
108 | 
109 | (defun igo-sgf-mode-update-buffer-read-only (editor)
110 |   (setq buffer-read-only (not (igo-editor-text-mode-p editor))))
111 | 
112 | 
113 | 
114 | (provide 'igo-sgf-mode)
115 | ;;; igo-sgf-mode.el ends here
116 | 


--------------------------------------------------------------------------------
/igo-org.el:
--------------------------------------------------------------------------------
  1 | ;;; igo-org.el --- SGF Editor for org-mode           -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2020  AKIYAMA Kouhei
  4 | 
  5 | ;; Author: AKIYAMA Kouhei
  6 | ;; Keywords: games
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; 
 24 | 
 25 | ;;; Code:
 26 | 
 27 | (require 'org)
 28 | 
 29 | ;;(require 'igo-editor)
 30 | (autoload 'igo-editor "igo-editor")
 31 | (declare-function igo-editor-set-region "igo-editor")
 32 | (declare-function igo-editor-update "igo-editor")
 33 | (declare-function igo-editor-last-error "igo-editor")
 34 | (declare-function igo-editor-last-error-begin "igo-editor")
 35 | (declare-function igo-editor-last-error-end "igo-editor")
 36 | (declare-function igo-editor-set-status-bar-visible "igo-editor")
 37 | (declare-function igo-editor-set-move-number-visible "igo-editor")
 38 | (declare-function igo-editor-set-branch-text-visible "igo-editor")
 39 | (declare-function igo-editor-set-editable "igo-editor")
 40 | (declare-function igo-editor-find-by-queries "igo-editor")
 41 | (declare-function igo-editor-set-grid-interval "igo-editor")
 42 | 
 43 | (defface igo-org-error-face
 44 |   '((((supports :underline (:style wave)))
 45 |      :underline (:style wave :color "Red1"))
 46 |     (t
 47 |      :underline t :inherit error))
 48 |   "SGF face for errors."
 49 |   :group 'igo-org-faces)
 50 | 
 51 | 
 52 | (defun igo-org-setup ()
 53 |   (interactive)
 54 |   (with-eval-after-load "org"
 55 |     (add-hook 'org-mode-hook #'igo-org-startup)
 56 |     (igo-org-hook-fontify-block)))
 57 | 
 58 | 
 59 | ;;
 60 | ;; Variables
 61 | ;;
 62 | 
 63 | (defvar-local igo-org-block-defaults nil)
 64 | 
 65 | 
 66 | ;;
 67 | ;; Hook Fontify
 68 | ;;
 69 | 
 70 | (defun igo-org-hook-fontify-block ()
 71 |   ;;(advice-add #'org-src-font-lock-fontify-block :around #'igo-org--fontify-src-block-advice)
 72 |   (advice-add #'org-fontify-meta-lines-and-blocks-1 :around #'igo-org--fontify-igo-block-advice)
 73 |   (advice-add #'org-unfontify-region :around #'igo-org--unfontify-region-advice))
 74 | 
 75 | (defun igo-org-unhook-fontify-block ()
 76 |   (advice-remove #'org-src-font-lock-fontify-block #'igo-org--fontify-src-block-advice)
 77 |   (advice-remove #'org-fontify-meta-lines-and-blocks-1 #'igo-org--fontify-igo-block-advice)
 78 |   (advice-remove #'org-unfontify-region #'igo-org--unfontify-region-advice))
 79 | 
 80 | 
 81 | ;; Fontify
 82 | 
 83 | (defun igo-org-fontify-block (start end &optional options)
 84 |   ;; Skip leading&trailing line break
 85 |   ;; (#+begin_src sgf[start]\n ... \n[end]#+end_src)
 86 |   (if (and (< start end) (= (char-after start) ?\n))
 87 |       (setq start (1+ start)))
 88 |   (if (and (< start end) (= (char-before end) ?\n))
 89 |       (setq end (1- end)))
 90 | 
 91 |   (let ((editor (seq-some
 92 |                  (lambda (o) (overlay-get o 'igo-editor))
 93 |                  (overlays-in start end))))
 94 | 
 95 |     (if (null editor)
 96 |         ;; Create a new editor
 97 |         (setq editor (igo-org-create-editor start end options))
 98 |       ;; Cover region.
 99 |       (igo-editor-set-region editor start end)
100 |       ;; Update editor state from region text.
101 |       (igo-editor-update editor))
102 | 
103 |     ;; Highlight error place
104 |     (if (igo-editor-last-error editor)
105 |         (put-text-property (igo-editor-last-error-begin editor)
106 |                            (igo-editor-last-error-end editor)
107 |                            'face 'igo-org-error-face))))
108 | 
109 | ;; Fontify src block (#+begin_src sgf ~ #+end_src)
110 | 
111 | (defun igo-org--fontify-src-block-advice (old-func lang start end)
112 |   (if (string= lang "sgf")
113 |       (igo-org-fontify-block start end)
114 |     (funcall old-func lang start end)))
115 | 
116 | ;; Fontify igo block (#+begin_igo ~ #+end_igo)
117 | 
118 | (defun igo-org--fontify-igo-block-advice (old-func limit)
119 |   (let* ((p (point))
120 |          (org-protecting-blocks (cons "igo" org-protecting-blocks))
121 |          ;; Fontify meta and blocks
122 |          (ret-val (funcall old-func limit)))
123 |     (if ret-val
124 |         ;; Overwrite between #+begin_igo and #+end_igo if exists
125 |         (save-match-data
126 |           (save-excursion
127 |             (goto-char p)
128 |             (igo-org-fontify-igo-block limit))))
129 |     ret-val))
130 | 
131 | (defun igo-org-fontify-igo-block (limit)
132 |   "Fontify #+begin_igo block. Call after
133 | org-fontify-meta-lines-and-blocks-1. Overwrite text property
134 | between #+begin_igo and #+end_igo."
135 | 
136 |   ;; The following code is derived from org-fontify-meta-lines-and-blocks-1
137 |   (let ((case-fold-search t))
138 |     (when (re-search-forward
139 | 	   (rx bol (group (zero-or-more (any " \t")) "#"
140 | 			  (group (group (or (seq "+" (one-or-more (any "a-zA-Z")) (optional ":"))
141 | 					    (any " \t")
142 | 					    eol))
143 | 				 (optional (group "_" (group (one-or-more (any "a-zA-Z"))))))
144 | 			  (zero-or-more (any " \t"))
145 |                           ;; options
146 | 			  (group (zero-or-more any))))
147 | 	   limit t)
148 |       (let ((block-start (match-end 0))  ; includes the \n at end of #+begin line
149 | 	    (block-end nil)              ; will include \n after end of block content
150 | 	    (dc3 (downcase (match-string 3)))
151 |             (options (match-string 6))
152 | 	     block-type)
153 | 	(cond
154 | 	 ((and (match-end 4) (equal dc3 "+begin"))
155 | 	  ;; Truly a block
156 | 	  (setq block-type (downcase (match-string 5)))
157 | 	  (when (re-search-forward
158 | 		 (rx-to-string `(group bol (or (seq (one-or-more "*") space)
159 | 					       (seq (zero-or-more blank)
160 | 						    "#+end"
161 | 						    ,(match-string 4)
162 | 						    word-end
163 | 						    (zero-or-more any)))))
164 | 		 nil t)  ;; on purpose, we look further than LIMIT
165 | 	    ;; We do have a matching #+end line
166 | 	    (setq block-end (match-beginning 0)) ; includes the final newline.
167 | 
168 |             ;;
169 |             ;; Fontify begin_igo block
170 |             ;;
171 |             (when (string= block-type "igo")
172 |               (igo-org-fontify-block block-start block-end options)
173 |               t))))))))
174 | 
175 | ;; Unfontify
176 | 
177 | (defun igo-org--unfontify-region-advice (old-func beg end &optional maybe_loudly)
178 |   (funcall old-func beg end maybe_loudly)
179 |   (igo-org-unfontify-region beg end))
180 | 
181 | (defun igo-org-unfontify-region (beg end)
182 |   (dolist (ov (overlays-in beg end))
183 |     (when (overlay-get ov 'igo-editor)
184 |       ;; keep overlay if src block still exists
185 |       ;; (surrounded by begin_src and end_src)
186 |       (when (not
187 |              (and
188 |               (save-excursion
189 |                 (goto-char (overlay-start ov))
190 |                 (forward-line -1)
191 |                 (looking-at "[ \t]*#\\+begin_\\(src +sgf\\|igo\\)"))
192 |               (save-excursion
193 |                 (goto-char (overlay-end ov))
194 |                 (forward-line 1)
195 |                 (looking-at "[ \t]*#\\+end_\\(src\\|igo\\)"))))
196 |         ;;(message "delete overlay %s" ov)
197 |         (delete-overlay ov)))))
198 | 
199 | ;;
200 | ;; Create Editor
201 | ;;
202 | 
203 | (defun igo-org-create-editor (start end options-str)
204 |   (let ((editor (igo-editor start end nil nil t))
205 |         (options (org-babel-parse-header-arguments options-str t)))
206 |     ;; Merge in-buffer settings to options
207 |     (dolist (default-opt igo-org-block-defaults) ;;@todo Is (org-babel-parse-header-arguments (igo-org-get-buffer-option "igo_block_defaults")) better? But slow for big files
208 |       (if (not (seq-some (lambda (o) (eq (car o) (car default-opt))) options))
209 |           (push default-opt options)))
210 |     ;; Apply options to editor
211 |     (dolist (opt options)
212 |       (let ((key (car opt))
213 |             (value (cdr opt)))
214 |         (cond
215 |          ((eq key :status-bar)
216 |           (igo-editor-set-status-bar-visible editor (igo-org-opt-bool value)))
217 |          ((eq key :move-number)
218 |           (igo-editor-set-move-number-visible editor (igo-org-opt-bool value)))
219 |          ((eq key :branch-text)
220 |           (igo-editor-set-branch-text-visible editor (igo-org-opt-bool value)))
221 |          ((eq key :editable)
222 |           (igo-editor-set-editable editor (igo-org-opt-bool value)))
223 |          ((eq key :read-only)
224 |           (igo-editor-set-editable editor (not (igo-org-opt-bool value))))
225 |          ((eq key :path)
226 |           (igo-editor-find-by-queries editor (igo-org-opt-split-path value)))
227 |          ((eq key :grid-interval)
228 |           (igo-editor-set-grid-interval editor (igo-org-opt-int value)))
229 |          )))
230 |     editor))
231 | 
232 | (defun igo-org-opt-split-path (value)
233 |   (cond
234 |    ((null value) nil)
235 |    ((numberp value) (list value))
236 |    ((stringp value) (split-string value "[/ \f\t\n\r\v]+" t "[ \f\t\n\r\v]+"))))
237 | 
238 | (defun igo-org-opt-bool (value)
239 |   (null (member value '("no" "nil" nil))))
240 | 
241 | (defun igo-org-opt-int (value)
242 |   (cond
243 |    ((integerp value) value)
244 |    ((numberp value) (round value))
245 |    ((stringp value) (string-to-number value))
246 |    (t nil)))
247 | 
248 | (defun igo-org-opt-value (key options &optional default-value)
249 |   (cdr (or (assq key options) (cons key default-value))))
250 | 
251 | (defun igo-org-opt-bool-value (key options &optional default-value)
252 |   (igo-org-opt-bool
253 |    (igo-org-opt-value key options default-value)))
254 | 
255 | ;; #+IGO_BLOCK_DEFAULTS: <properties>
256 | 
257 | (defun igo-org-startup ()
258 |   (if-let ((block-defaults-str (igo-org-get-buffer-option "igo_block_defaults")))
259 |       (setq igo-org-block-defaults
260 |             (org-babel-parse-header-arguments block-defaults-str t))))
261 | 
262 | (defun igo-org-get-buffer-option (keyword)
263 |   (save-excursion
264 |     (goto-char (point-min))
265 |     (let ((re-keyword (org-make-options-regexp (list keyword))))
266 |       (when (re-search-forward re-keyword nil t 1)
267 |         (match-string-no-properties 2)))))
268 | 
269 | 
270 | (provide 'igo-org)
271 | ;;; igo-org.el ends here
272 | 


--------------------------------------------------------------------------------
/README.org:
--------------------------------------------------------------------------------
  1 | #+TITLE: el-igo - Emacs Go Game(SGF) Editor
  2 | #+OPTIONS: toc:nil num:nil ^:nil
  3 | 
  4 | Emacs内で囲碁の盤面を表示し、棋譜(SGF形式)を編集します。
  5 | 
  6 | [[file:./screenshot/igo-org-20201227.gif]]
  7 | 
  8 | * 動作環境
  9 | Emacs 27.1
 10 | 
 11 | * org-mode文書内に棋譜を埋め込む(igo-org.el)
 12 | ** 設定
 13 | init.elに次のコードを追加してください。
 14 | 
 15 | #+begin_src emacs-lisp
 16 | (with-eval-after-load "org"
 17 |   (require 'igo-org)
 18 |   (igo-org-setup))
 19 | #+end_src
 20 | 
 21 | また、HTMLとしてエクスポートしたときに盤面を表示したい場合は[[#org-export][後述]]の設定も追加してください。
 22 | 
 23 | ** 使い方
 24 | org文書内にigo特殊ブロックを挿入します。(操作例: C-c C-, SPC i g o RET)
 25 | 
 26 | #+begin_src org
 27 | ,#+begin_igo
 28 | ,#+end_igo
 29 | #+end_src
 30 | 
 31 | ブロックの中に (;SZ[9]) と入力すると9路盤が表示されます。またはブロック内で C-c i を押すと盤面サイズを指定して初期化できるようになっています。
 32 | 
 33 | 後は適当に石を置いたり、フリー編集モードで初期盤面を設定したり、コメントを設定したりすると、その操作毎にバッファのテキストが書き換わります。
 34 | 
 35 | ** ブロック毎のオプション
 36 | 
 37 | =#+begin_igo= の後にブロック毎のオプションを指定できます。
 38 | 
 39 | 例えば次のようにするとブロックが盤面化されたとき(orgファイルを開いたとき等)に最初から手順番号が表示されます。
 40 | 
 41 | #+begin_src org
 42 | ,#+begin_igo :move-number t
 43 | (;FF[4]GM[1]SZ[9];B[fd];W[df];B[ff];W[dd])
 44 | ,#+end_igo
 45 | #+end_src
 46 | 
 47 | 有効なオプションには次のものがあります。
 48 | 
 49 | | オプション名   | 意味                        | 値                                                            |
 50 | |----------------+-----------------------------+---------------------------------------------------------------|
 51 | | :status-bar    | ステータスバーの表示状態    | nil, noのとき非表示                                           |
 52 | | :move-number   | 手順番号の表示状態          | nil, noのとき非表示                                           |
 53 | | :branch-text   | 分岐文字(A,B,...)の表示状態 | nil, noのとき非表示                                           |
 54 | | :editable      | 編集可能                    | nil, noのとき編集不可能                                       |
 55 | | :read-only     | 編集禁止(:editableの逆)     | nil, noのとき編集可能                                         |
 56 | | :path          | 最初に表示する盤面(ノード)  | 盤面へたどり着く経路(後述)                                    |
 57 | | :display       | エクスポート時の表示方法    | 表示方法を示す値([[#org-export-options][後述]])                                        |
 58 | | :grid-interval | 格子線の間隔                | ピクセル数(デフォルトは igo-board-view-grid-interval-default) |
 59 | 
 60 | orgファイル内に ~#+IGO_BLOCK_DEFAULTS:~ を記述することで、ファイル内でのオプションのデフォルト値を設定できます。(注意:現在の所、変更時はファイルを開き直す必要があります)
 61 | 
 62 | 例:
 63 | #+begin_src org
 64 | ,#+IGO_BLOCK_DEFAULTS: :grid-interval 24 :move-number t
 65 | #+end_src
 66 | 
 67 | *** :pathの指定方法
 68 | 
 69 | :path オプションは最初に表示する盤面(ゲーム木のノード)を指定します。
 70 | 
 71 | パス(盤面へたどり着く経路)は次の要素を並べたもので、最初の盤面(ルート)から各要素が指定する盤面を順番にたどり最終的に到達した盤面が選択されます。
 72 | 
 73 | | 数字                       | 現在の盤面から数字で指定しただけ後の盤面(途中分岐がある場合は最初の分岐(A)を選択)(無い場合は最後の盤面) |
 74 | | -数字                      | 現在の盤面から数字で指定しただけ前の盤面(無い場合は最初の盤面)                                          |
 75 | | アルファベット二文字       | SGF座標とみなし、その場所に打つ現在の盤面から最も近い盤面(幅優先探索)                                   |
 76 | | 大文字アルファベット一文字 | 現在の盤面以降の最初の分岐での分岐先(A:0, B:1, ...)を指定したものと見なし、その分岐直後の盤面           |
 77 | | \under{} (アンダーバー)    | 現在の盤面以降の最初の分岐がある盤面(分岐が無ければ最後の盤面)                                          |
 78 | 
 79 | 例:
 80 | - 0 : 最初の盤面
 81 | - 12 : 最初から12手目の盤面
 82 | - cd : 最初に3の4に着手する盤面
 83 | - cc/fc : 最初に左上三々(cc)に着手した後、次に最初に二間開き(fc)した盤面
 84 | - cc/2 : 最初に着手した後の2手目
 85 | - A/B/A : 分岐をA、B、Aの順に選択した盤面
 86 | - _ : 最初の分岐(無ければ最後の盤面)
 87 | - _/-1 : 最初の分岐(無ければ最後の盤面)の一つ前
 88 | 
 89 | * SGFファイルの編集(igo-sgf-mode.el)
 90 | ** 設定
 91 | init.elに次のコードを追加してください。
 92 | 
 93 | #+begin_src emacs-lisp
 94 | (autoload 'igo-sgf-mode "igo-sgf-mode")
 95 | (add-to-list 'auto-mode-alist '("\\.sgf$" . igo-sgf-mode))
 96 | #+end_src
 97 | 
 98 | sgfファイルを開くと自動的に盤面が表示されます。
 99 | 
100 | 注意: sgfファイルはオセロ、チェス、バックギャモンなど囲碁以外のゲームの棋譜も表現できます。あなたがそれらを扱う場合は、GMプロパティが1以外のときにigo-sgf-modeを起動しないようにする必要があります(未実装)。
101 | 
102 | * バッファ内の任意の部分を盤面にする(igo-editor.el)
103 | 
104 | 任意のSGFテキストをリージョンで囲った上で M-x igo-edit-region を実行すると、その範囲がエディタ化されます。
105 | 
106 | igo-sgf-mode.el も igo-org.el も igo-editor.el を使って実装されています。igo-sgf-mode.elはバッファ全体を、igo-org.elはbegin_igo～end_igoの間を自動的にエディタ化します。
107 | 
108 | * エディタの使い方
109 | ** モード
110 | エディタは大きく分けて次のようなモードを持っています。
111 | 
112 | - テキストモード
113 |   - 固定モード(エラーが無くなってもテキストのまま)
114 |   - 自動回復モード(エラーが無くなったときに自動的にグラフィカルモードに移行する)
115 | ** キー操作
116 | 各モードで使えるキー操作は次の通りです。
117 | 
118 | *** テキストモード
119 | 
120 | | 操作  | 説明                     | 関数                      |
121 | |-------+--------------------------+---------------------------|
122 | | C-c q | エディタの終了           | igo-editor-quit           |
123 | | C-c g | グラフィカルモードへ移行 | igo-editor-graphical-mode |
124 | | C-c i | 盤面の初期化             | igo-editor-init-board     |
125 | 
126 | *** グラフィカルモード共通
127 | 
128 | | 操作                      | 説明                                   | 関数                          |
129 | |---------------------------+----------------------------------------+-------------------------------|
130 | | C-c g                     | テキストモードへ移行                   | igo-editor-text-mode          |
131 | | C-x c-q                   | 編集可能状態切り替え                   | igo-editor-toggle-editable    |
132 | |---------------------------+----------------------------------------+-------------------------------|
133 | | a, \vert{}<ボタンクリック | 最初へ                                 | igo-editor-first-node         |
134 | | e, >\vert{}ボタンクリック | 最後へ(デフォルト選択でたどれる所まで) | igo-editor-last-node          |
135 | | b, <ボタンクリック        | 前へ                                   | igo-editor-previous-node      |
136 | | f, >ボタンクリック        | 次へ(デフォルト選択でたどれる場合)     | igo-editor-next-node          |
137 | | M-b                       | 前の分岐地点へ                         | igo-editor-previous-fork      |
138 | | M-f                       | 次の分岐地点へ                         | igo-editor-next-fork          |
139 | | n                         | 次の盤面を分岐の中から選択して表示     | igo-editor-select-next-node   |
140 | |---------------------------+----------------------------------------+-------------------------------|
141 | | Q                         | 着手モード                             | igo-editor-move-mode          |
142 | | F                         | フリー編集モード                       | igo-editor-free-edit-mode     |
143 | | M                         | マーク編集モード                       | igo-editor-mark-edit-mode     |
144 | |---------------------------+----------------------------------------+-------------------------------|
145 | | s s                       | ステータスバー表示切り替え             | igo-editor-toggle-status-bar  |
146 | | s n                       | 手順番号表示切り替え                   | igo-editor-toggle-move-number |
147 | | s b                       | 分岐表示切り替え                       | igo-editor-toggle-branch-text |
148 | |---------------------------+----------------------------------------+-------------------------------|
149 | | c                         | コメントの編集                         | igo-editor-edit-comment       |
150 | | N                         | 手順番号の編集                         | igo-editor-edit-move-number   |
151 | | g                         | 対局情報の編集                         | igo-editor-edit-game-info     |
152 | |---------------------------+----------------------------------------+-------------------------------|
153 | | x                         | 盤面のSVG画像出力                      | igo-editor-export-image       |
154 | |---------------------------+----------------------------------------+-------------------------------|
155 | | C-c i                     | 盤面の初期化                           | igo-editor-init-board         |
156 | 
157 | *** 着手モード
158 | 
159 | | 操作                  | 説明                                 | 関数                               |
160 | |-----------------------+--------------------------------------+------------------------------------|
161 | | P, Passボタンクリック | パス                                 | igo-editor-pass                    |
162 | | p                     | 石を置く                             | igo-editor-put-stone               |
163 | | 盤面をクリック        | 石を置く                             | igo-editor-move-mode-board-click   |
164 | | Passボタン右クリック  | 着手「パス」に対するメニューを表示   | igo-editor-pass-click-r            |
165 | | 盤面を右クリック      | 交点(石や空点)に対するメニューを表示 | igo-editor-move-mode-board-click-r |
166 | | \dollar               | 現在の盤面をルートにする             | igo-editor-make-current-node-root  |
167 | 
168 | *** フリー編集モード
169 | 
170 | (現在の所、一番最初の盤面でのみ使用できます)
171 | 
172 | | 操作                   | 説明                     | 関数                             |
173 | |------------------------+--------------------------+----------------------------------|
174 | | Quitボタンクリック     | 着手モードへ切り替え     | igo-editor-move-mode             |
175 | | p                      | 交点を選択中の状態にする | igo-editor-free-edit-put         |
176 | | 盤面をクリック         | 交点を選択中の状態にする | igo-editor-free-edit-board-down |
177 | | B, Blackボタンクリック | 黒石を選択する           | igo-editor-free-edit-black       |
178 | | W, Whiteボタンクリック | 白石を選択する           | igo-editor-free-edit-white       |
179 | | E, Emptyボタンクリック | 空点を選択する           | igo-editor-free-edit-empty       |
180 | | T, Turnボタンクリック  | 次の手番を反転させる     | igo-editor-free-edit-toggle-turn |
181 | 
182 | *** マーク編集モード
183 | 
184 | | 操作                  | 説明                     | 関数                             |
185 | |-----------------------+--------------------------+----------------------------------|
186 | | Quitボタンクリック    | 着手モードへ切り替え     | igo-editor-move-mode             |
187 | | p                     | 交点を選択中の状態にする | igo-editor-mark-edit-put         |
188 | | 盤面をクリック        | 交点を選択中の状態にする | igo-editor-mark-edit-board-down |
189 | | X, Xボタンクリック    | ×マークを選択する       | igo-editor-mark-edit-cross       |
190 | | O, Oボタンクリック    | ○マークを選択する       | igo-editor-mark-edit-circle      |
191 | | S, SQボタンクリック   | □マークを選択する       | igo-editor-mark-edit-square      |
192 | | T, TRボタンクリック   | △マークを選択する       | igo-editor-mark-edit-triangle    |
193 | | E, Textボタンクリック | テキストを選択する       | igo-editor-mark-edit-text        |
194 | | D, Delボタンクリック  | 消去を選択する           | igo-editor-mark-edit-del         |
195 | 
196 | ** 分岐の編集
197 | 
198 | 前の手に戻って別の場所に打つと自動的に分岐が作られます。エディタは全ての分岐をツリー構造で記録しています。
199 | 
200 | 分岐は分岐直前の盤面でAから始まるアルファベットで表示されます。
201 | 
202 | 分岐箇所を示すアルファベットを「左クリック」すると、その分岐に進みます。
203 | 
204 | 「次へ進む」ボタンは最後に選んだ分岐へ進みますが、もしまだ選択していない場合は明示的に指定する必要があります。
205 | 
206 | 分岐を削除したい場合や分岐の(アルファベットの)順番を変更したい場合は、アルファベットを *「右クリック」* してください。分岐に対する操作がポップアップメニューで表示されます。
207 | 
208 | * org-modeでHTMLエクスポートする
209 |   :PROPERTIES:
210 |   :CUSTOM_ID: org-export
211 |   :END:
212 | 
213 | org-mode文書中に棋譜を埋め込んだのならエクスポート後の文書にも盤面が表示されて欲しいと思うことでしょう。ここではHTMLでのエクスポート時に盤面を出力する方法について説明します。
214 | 
215 | ** org-mode標準機能だけで処理する方法
216 | 標準のHTMLバックエンドは特殊ブロックをdivタグで囲んだ形で出力します。 ~#+begin_igo~ ～ ~#+end_igo~ も特殊ブロックなので、HTMLで出力すると ~<div class="igo"><p>~ /SGFテキスト/ ~</p></div>~ の形で出力されます。
217 | 
218 | 盤面の形で表示させたい場合は、ページ読み込み完了時にJavaScriptで一括変換すると良いでしょう。
219 | 
220 | 例えば拙作のJavaScript碁盤を使用するならば [[https://github.com/misohena/js_igo][misohena/js_igo: JavaScript Go Game Board]] より igo.js, igo_view.js, igo.css をダウンロードした上で、次のようにします。
221 | 
222 | #+begin_src org
223 | ,#+HTML_HEAD: <script src="igo.js"></script>
224 | ,#+HTML_HEAD: <script src="igo_view.js"></script>
225 | ,#+HTML_HEAD: <link rel="stylesheet" href="igo.css" />
226 | ,#+HTML_HEAD: <script>window.addEventListener("load", ev=>{ for(elem of document.querySelectorAll("div.igo")){ let sgf = elem.textContent; while(elem.hasChildNodes()){elem.removeChild(elem.firstChild);} new igo.GameView(elem, sgf, {"showBranchText": true, "showLastMoveMark": true, "showComment": true, "path":1000}); }});</script>
227 | 
228 | お互いに二連星したところ。
229 | 
230 | ,#+begin_igo
231 | (;FF[4]GM[1]SZ[9];B[fd];W[df];B[ff];W[dd])
232 | ,#+end_igo
233 | #+end_src
234 | 
235 | ** エクスポータをカスタマイズする
236 | 
237 | igo特殊ブロックの出力(変換結果)自体を変える方法もあります。
238 | 
239 | igo特殊ブロックの出力を変えるためにはorg-modeのエクスポータをカスタマイズしなければなりませんが、その方法として次の三つを用意しました。
240 | 
241 | - 既存のHTMLバックエンドを修正する
242 | - HTMLバックエンドから派生した新しいバックエンドを定義する
243 | - バッファローカル変数を書き替える
244 | 
245 | ** 既存のHTMLバックエンドを修正する
246 | 
247 | 最も使い勝手の良い方法は既存のHTMLバックエンドを修正することです。一度設定してしまえばファイル毎に設定する必要はありませんし、普段通りの操作でエクスポートできます。
248 | 
249 | 次のコードを init.el に追加してください。
250 | 
251 | #+begin_src emacs-lisp
252 | (with-eval-after-load "ox-html"
253 |   (require 'igo-org-export-html)
254 |   (igo-org-modify-html-backend))
255 | #+end_src
256 | 
257 | すると org-mode のHTMLバックエンドが読み込まれた直後にそれを書き替えてigo特殊ブロック( ~#+begin_igo~ ～ ~#+end_igo~ 部分)を特別に処理するようにします。
258 | 
259 | デフォルトは拙作のJavaScript碁盤を使うHTMLを出力するので、 [[https://github.com/misohena/js_igo][misohena/js_igo: JavaScript Go Game Board]] より igo.js, igo_view.js, igo.css をダウンロードしてhtmlと同じ場所に配置してください。
260 | 
261 | あとは通常通りHTMLとしてエクスポートするだけです。
262 | 
263 | ** HTMLバックエンドから派生した新しいバックエンドを定義する
264 | 
265 | 何らかの理由でHTMLバックエンドを直接修正して欲しくない場合、新しく専用のバックエンドを定義することも出来ます。
266 | 
267 | 次のコードを実行すると igo-html という名前のバックエンドが登録されます。
268 | 
269 | #+begin_src emacs-lisp
270 | (require 'igo-org-export-html)
271 | (igo-org-define-html-backend t)
272 | #+end_src
273 | 
274 | ~igo-org-define-html-backend~ の引数に ~t~ を指定するとメニューに項目を追加します。
275 | 
276 | =C-c C-e= でエクスポートのメニューを出した後、 g を押すことでこのバックエンドを指定できます。
277 | 
278 | ** 個別のファイルにフィルタを設定する
279 | 
280 | バックエンドをカスタマイズしなくても、ファイルごとにバッファローカル変数を設定することで変換処理を変更できます。
281 | 
282 | この方法を使うには、org-mode文書の中に次のコードを追加してください。
283 | 
284 | #+begin_src org
285 | ,#+begin_src emacs-lisp :exports results :results none
286 | (require 'igo-org-export-html)
287 | (igo-org-set-html-filters-local)
288 | ,#+end_src
289 | #+end_src
290 | 
291 | ~:exports results~ を指定することでエクスポートのたびにソースブロックを評価させ、 ~:results none~ を指定することで結果の出力を抑制しています。
292 | 
293 | 後は通常通りHTMLとしてエクスポートしてください。
294 | 
295 | org-modeのデフォルト設定ではエクスポートするたびにソースブロックを評価するか聞いてくるので yes を入力してください。
296 | 
297 | するとバッファローカル変数に変換フィルタが設定され、igo特殊ブロックが特別に変換されます。
298 | 
299 | ** オプション
300 |    :PROPERTIES:
301 |    :CUSTOM_ID: org-export-options
302 |    :END:
303 | 
304 | igo-org-export-html.el を使用して変換する場合、次のオプションが使用できます。
305 | 
306 | | オプション                                   | 意味                                                                | デフォルト値                 |
307 | |----------------------------------------------+---------------------------------------------------------------------+------------------------------|
308 | | ~#+IGO_JS_PATH:~ /<path-to-directory>/       | スクリプトのあるディレクトリへのパス                                | igo-org-js-pathの値 (./)     |
309 | | ~#+IGO_JS_TEMPLATE:~ /<header-template>/     | HTMLのHEADに挿入するテキストの雛形(displayがjsのとき)               | igo-org-js-templateの値      |
310 | | ~#+IGO_LAZY_JS_TEMPLATE:~ /<block-template>/ | igo特殊ブロックの中に挿入するテキストの雛形(displayがlazy-jsのとき) | igo-org-lazy-js-templateの値 |
311 | | ~#+IGO_HEADER_TEMPLATE:~ /<header-template>/ | HTMLのHEADに挿入するテキストの雛形(displayがcustomのとき)           | igo-org-header-templateの値  |
312 | | ~#+IGO_BLOCK_TEMPLATE:~ /<block-template>/   | igo特殊ブロックの中に挿入するテキストの雛形(displayがcustomのとき)  | igo-org-block-templateの値   |
313 | | ~#+IGO_ENABLE:~ /<boolean>/                  | igo特殊ブロックを変換するかどうか                                   | t                            |
314 | | ~#+IGO_DISPLAY:~ /<display-type>/            | igo特殊ブロックをどのように変換するか                               | js                           |
315 | 
316 | ~#+IGO_ENABLE: nil~ を指定するとファイル内で一切の変換を抑制できます。
317 | 
318 | ~#+IGO_DISPLAY:~ には次のいずれかを指定できます。
319 | 
320 | | /<display-type>/ | 表示方法                                                                          |
321 | |------------------+-----------------------------------------------------------------------------------|
322 | | ~none~           | 非表示                                                                            |
323 | | ~noconv~         | 変換しない(SGFテキストのまま)                                                     |
324 | | ~js~             | js_igoによるJavaScript碁盤                                                        |
325 | | ~lazy-js~        | js_igoによるJavaScript碁盤(遅延読み込み型。<head></head>にスクリプトを挿入しない) |
326 | | ~svg~            | SVG画像埋め込み                                                                   |
327 | | ~custom~         | ~#+IGO_HEADER_TEMPLATE:~ と ~#+IGO_BLOCK_TEMPLATE:~ を使用                        |
328 | 
329 | また、表示方法はブロック毎に ~#+begin_igo :display <display-type>~ の形でも指定できます。
330 | 
331 | 例:
332 | 
333 | #+begin_src org
334 | ,#+IGO_JS_PATH: ./js_igo/
335 | ,#+IGO_DISPLAY: svg
336 | 
337 | ,#+begin_igo :move-number t :path A/A/B
338 | ....省略(SVGで表示)....
339 | ,#+end_igo
340 | 
341 | ,#+begin_igo :read-only t :move-number t :path 5 :display js
342 | ....省略(js_igoで表示)....
343 | ,#+end_igo
344 | #+end_src
345 | 
346 | 表示方法によってはテンプレート文字列を指定できます。
347 | 
348 | オプションの /<header-template>/ の部分は、HTMLのHEAD要素内に挿入するテキストの雛形です。表示方法が js であるブロックが存在する場合、 ~#+IGO_JS_TEMPLATE:~ オプションで指定した雛形が使われます。また、表示方法が custom であるブロックが存在する場合、 ~#+IGO_HEADER_TEMPLATE:~ オプションで指定した雛形も使われます。
349 | 
350 | /<header-template>/ の中では次の記法が使用できます。
351 | 
352 | | % /<var-name>/ % | 置き換え先                      |
353 | |------------------+---------------------------------|
354 | | ~%PATH%~         | ~#+IGO_JS_PATH:~ オプションの値 |
355 | 
356 | オプションの /<block-template>/ の部分は、igo特殊ブロックの中に挿入するテキストの雛形です。表示方法が lazy-js のブロックには ~#+IGO_LAZY_JS_TEMPLATE:~ オプションで指定した雛形が使われます。また、表示方法が custom であるブロックには ~#+IGO_BLOCK_TEMPLATE:~ オプションで指定した雛形が使われます。
357 | 
358 | /<header-template>/ の中では次の記法が使用できます。
359 | 
360 | | % /<var-name>/ % | 置き換え先                      |
361 | |------------------+---------------------------------|
362 | | ~%PATH%~         | ~#+IGO_JS_PATH:~ オプションの値 |
363 | | ~%SGF%~          | SGFテキスト                     |
364 | | ~%OPT_JSON%~     | js_igo用のオプション            |
365 | | ~%SVG%~          | 盤面をSVG化したテキスト         |
366 | 
367 | また、%の後に次のいずれかを指定することでテキスト内の一部の文字をエスケープできます。
368 | 
369 | | 記法                   | 置き換える文字                 | 置き換え後の文字                  |
370 | |------------------------+--------------------------------+-----------------------------------|
371 | | ~%HTML_<var-name>%~    | & < >                          | &amp; &lt; &gt;                   |
372 | | ~%ATTR_<var-name>%~    | & < > "                        | &amp; &lt; &gt; &quot;            |
373 | | ~%LITERAL_<var-name>%~ | \ " 改行 <!-- <script </script | \\ \" \n <\!-- <\script <\/script |
374 | 
375 | つまり、HTMLの属性の中に記述するときは%ATTR_を、HTMLの内容部分に記述するときは%HTML_を、JavaScriptの文字列リテラル内に記述するときは%LITERAL_を使用してください。例えばSGFをJavaScriptの文字列にして解析したい場合、 ~parseSGF("%LITERAL_SGF%")~ のように記述します。
376 | 
377 | 


--------------------------------------------------------------------------------
/igo-sgf-parser.el:
--------------------------------------------------------------------------------
  1 | ;;; igo-sgf-parser.el --- SGF Parser                 -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2020 AKIYAMA Kouhei
  4 | 
  5 | ;; Author: AKIYAMA Kouhei
  6 | ;; Keywords: games
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; 
 24 | 
 25 | ;;; Code:
 26 | 
 27 | (require 'cl-lib)
 28 | (require 'subr-x)
 29 | 
 30 | ;;
 31 | ;; Input Stream Functions:
 32 | ;;
 33 | ;; - (igo-sgf-scan strm)
 34 | ;; - (igo-sgf-get strm)
 35 | ;; - (igo-sgf-discard strm)
 36 | ;; - (igo-sgf-strm-pos strm)
 37 | ;; - (igo-sgf-error strm message)
 38 | 
 39 | (defun igo-sgf-scan (_strm)
 40 |   (char-after))
 41 | 
 42 | (defun igo-sgf-get (_strm)
 43 |   (when (< (point) (point-max))
 44 |     (forward-char)
 45 |     (char-before)))
 46 | 
 47 | (defun igo-sgf-discard (_strm)
 48 |   (if (< (point) (point-max))
 49 |       (forward-char)))
 50 | 
 51 | (defun igo-sgf-strm-pos (_strm)
 52 |   (point))
 53 | 
 54 | (defun igo-sgf-error (strm message)
 55 |   (error "%s: %s" (igo-sgf-strm-pos strm) message))
 56 | 
 57 | ;;
 58 | ;; Character Classification
 59 | ;;
 60 | 
 61 | (defun igo-sgf-ws-p (c)
 62 |   (and
 63 |    (integerp c)
 64 |    (or (= c ? )
 65 |        (= c ?\t)
 66 |        (= c ?\v)
 67 |        (= c ?\n)
 68 |        (= c ?\r))))
 69 | 
 70 | (defun igo-sgf-ucletter-p (c)
 71 |   (and (integerp c) (>= c ?A) (<= c ?Z)))
 72 | 
 73 | ;;
 74 | ;; Stream Utilities
 75 | ;;
 76 | 
 77 | (defun igo-sgf-skip-ws (strm)
 78 |   (let (ch wss)
 79 |     (while (igo-sgf-ws-p (setq ch (igo-sgf-scan strm)))
 80 |       (push ch wss)
 81 |       (igo-sgf-discard strm))
 82 |     (concat (nreverse wss))))
 83 | 
 84 | (defun igo-sgf-match-char (strm ch)
 85 |   (let ((strm-ch (igo-sgf-scan strm)))
 86 |     (if (not (equal strm-ch ch))
 87 |         (igo-sgf-error strm (format "Unexpected %s (expecting '%c')" (if strm-ch (concat "'" (char-to-string strm-ch) "'") "end of SGF") ch))
 88 |       (igo-sgf-discard strm))))
 89 | 
 90 | (defun igo-sgf-scan-ucletters (strm)
 91 |   "Scan [A-Z]* from strm."
 92 |   (let (ch chars)
 93 |     (while (igo-sgf-ucletter-p (setq ch (igo-sgf-scan strm)))
 94 |       (push ch chars)
 95 |       (igo-sgf-discard strm))
 96 |     (concat (nreverse chars))))
 97 | 
 98 | ;;
 99 | ;; Parse SGF
100 | ;;
101 | ;; Syntax:
102 | ;;
103 | ;;  Collection = GameTree+
104 | ;;  GameTree   = "(" Sequence GameTree* ")"
105 | ;;  Sequence   = Node+
106 | ;;  Node       = ";" Property*
107 | ;;  Property   = PropIdent PropValue+
108 | ;;  PropIdent  = UcLetter+
109 | ;;  PropValue  = "[" CValueType "]"
110 | ;;  CValueType = (ValueType | Compose)
111 | ;;  ValueType  = (None | Number | Real | Double | Color | SimpleText |
112 | ;;                Text | Point  | Move | Stone)
113 | ;;  (see: https:www.red-bean.com/sgf/sgf4.html )
114 | ;;
115 | ;; Functions corresponding to non-terminal symbols:
116 | ;; - igo-sgf-parse-tree-list :: GameTree*
117 | ;; - igo-sgf-parse-tree :: GameTree
118 | ;; - igo-sgf-parse-node-list :: Node*
119 | ;; - igo-sgf-parse-node :: Node
120 | ;; - igo-sgf-parse-property-list :: Property*
121 | ;; - igo-sgf-parse-property :: Property
122 | ;; - igo-sgf-parse-prop-value :: PropValue
123 | 
124 | (defun igo-sgf-parse-tree-list (strm)
125 |   "Parse 0 or more GameTree and return list of tree object."
126 |   ;; Tree*
127 |   ;; (...) (...) (...)
128 |   (let (trees wss)
129 |     (while (progn (setq wss (igo-sgf-skip-ws strm)) (equal (igo-sgf-scan strm) ?\())
130 |       (push (igo-sgf-parse-tree strm wss) trees))
131 |     (nreverse trees)))
132 | 
133 | (defun igo-sgf-parse-tree (strm &optional leading-wss)
134 |   "Parse GameTree and return a tree object [leading-wss begin-pos
135 | nodes subtrees end-pos]."
136 | 
137 |   (setq leading-wss (concat leading-wss (igo-sgf-skip-ws strm)))
138 | 
139 |   ;; ( Node+ Tree* )
140 |   ;; ( ;... ;... ;... (...) (...) (...) )
141 |   (let (begin-pos nodes subtrees end-pos)
142 |     ;; (
143 |     (setq begin-pos (igo-sgf-strm-pos strm))
144 |     (igo-sgf-match-char strm ?\()
145 | 
146 |     ;; Node+
147 |     (setq nodes (igo-sgf-parse-node-list strm))
148 |     (if (null nodes)
149 |         (igo-sgf-error strm "GameTree requires one or more Nodes"))
150 | 
151 |     ;; Tree*
152 |     (setq subtrees (igo-sgf-parse-tree-list strm))
153 | 
154 |     ;; )
155 |     ;;;@todo skip white spaces?
156 |     (igo-sgf-match-char strm ?\))
157 |     (setq end-pos (igo-sgf-strm-pos strm))
158 | 
159 |     (vector leading-wss begin-pos nodes subtrees end-pos)))
160 | 
161 | (defun igo-sgf-parse-node-list (strm) ;;Sequence
162 |   "Parse 0 or more Node and return list of node object."
163 |   ;; Node*
164 |   ;; ;... ;... ;...
165 |   (let (nodes wss)
166 |     (while (progn (setq wss (igo-sgf-skip-ws strm)) (equal (igo-sgf-scan strm) ?\;))
167 |       (push (igo-sgf-parse-node strm wss) nodes))
168 |     (nreverse nodes)))
169 | 
170 | (defun igo-sgf-parse-node (strm &optional leading-wss)
171 |   "Parse Node and return a node object [leading-wss begin-pos properties end-pos]."
172 | 
173 |   (setq leading-wss (concat leading-wss (igo-sgf-skip-ws strm)))
174 | 
175 |   ;; ; Property*
176 |   ;; ; PID[PValue][PValue][PValue]PID[PValue][PValue][PValue]...
177 |   (let (begin-pos properties end-pos)
178 |     ;; ;
179 |     (setq begin-pos (igo-sgf-strm-pos strm))
180 |     (igo-sgf-match-char strm ?\;)
181 | 
182 |     ;; Property*
183 |     (setq properties (igo-sgf-parse-property-list strm))
184 | 
185 |     (setq end-pos (igo-sgf-strm-pos strm))
186 | 
187 |     (vector leading-wss begin-pos properties end-pos)))
188 | 
189 | (defun igo-sgf-parse-property-list (strm)
190 |   ;; Property*
191 |   ;; PID[PValue][PValue][PValue]PID[PValue][PValue][PValue]...
192 |   (let (properties wss)
193 |     (while (progn (setq wss (igo-sgf-skip-ws strm)) (igo-sgf-ucletter-p (igo-sgf-scan strm)))
194 |       (push (igo-sgf-parse-property strm wss) properties))
195 |     (nreverse properties)))
196 | 
197 | (defun igo-sgf-parse-property (strm &optional leading-wss)
198 |   "Return property object [leading-wss begin-pos id values end-pos]"
199 | 
200 |   (setq leading-wss (concat leading-wss (igo-sgf-skip-ws strm)))
201 | 
202 |   ;; PropIdent PropValue+
203 |   (let (begin-pos id values end-pos)
204 |     (setq begin-pos (igo-sgf-strm-pos strm))
205 | 
206 |     ;; PropIdent
207 |     (setq id (igo-sgf-scan-ucletters strm))
208 |     (if (string-empty-p id)
209 |         (igo-sgf-error strm "No property ID"))
210 | 
211 |     ;; PropValue+
212 |     (let (wss)
213 |       (while (progn (setq wss (igo-sgf-skip-ws strm)) (equal (igo-sgf-scan strm) ?\[))
214 |         (push (igo-sgf-parse-prop-value strm wss) values)))
215 |     (setq values (nreverse values))
216 |     (if (null values)
217 |         (igo-sgf-error strm "Property requires one or more PropValues"))
218 | 
219 |     (setq end-pos (igo-sgf-strm-pos strm))
220 | 
221 |     (vector leading-wss begin-pos id values end-pos)))
222 | 
223 | (defun igo-sgf-parse-prop-value (strm &optional leading-wss)
224 | 
225 |   (setq leading-wss (concat leading-wss (igo-sgf-skip-ws strm)))
226 | 
227 |   (let (begin-pos ch chars end-pos)
228 |     (setq begin-pos (igo-sgf-strm-pos strm))
229 |     (igo-sgf-match-char strm ?\[)
230 | 
231 |     (while (not (equal (setq ch (igo-sgf-get strm)) ?\]))
232 |       ;; end of strm
233 |       (if (null ch)
234 |           (igo-sgf-error strm "Unexpected end of SGF in Property Value"))
235 |       ;; push ch
236 |       (push ch chars)
237 |       ;; NOTE: Do not resolve compose value here(colon separation). Depends on property type.
238 | 
239 |       ;; skip \], convert \r \n\r \r\n to \n
240 |       (if (= ch ?\\)
241 |           (let ((escaped-ch (igo-sgf-get strm)))
242 |             (cond
243 |              ;; convert \\\n\r and \\\r\n to single \n
244 |              ((or (and (= escaped-ch ?\n) (equal (igo-sgf-scan strm) ?\r))
245 |                   (and (= escaped-ch ?\r) (equal (igo-sgf-scan strm) ?\n)))
246 |               (igo-sgf-discard strm)
247 |               (push ?\n chars))
248 |              ;; convert single \r to \n
249 |              ((or (= escaped-ch ?\r))
250 |               (push ?\n chars))
251 |              ;; ], \, :, \n, spaces, etc...
252 |              (t (push escaped-ch chars))))))
253 | 
254 |     (setq end-pos (igo-sgf-strm-pos strm))
255 | 
256 |     ;; return value
257 |     (igo-sgf-make-prop-value leading-wss begin-pos (concat (nreverse chars)) end-pos)))
258 | 
259 | 
260 | ;;
261 | ;; Syntax Tree Accessors
262 | ;;
263 | 
264 | (defun igo-sgf-format-location (begin end)
265 |   (cond
266 |    ((and begin end) (format "%s-%s: " begin end))
267 |    (begin (format "%s: " begin))
268 |    (end (format "%s: " end))
269 |    (t "")))
270 | 
271 | ;; Tree
272 | (defun igo-sgf-tree-leading-white-spaces (tree) (aref tree 0))
273 | (defun igo-sgf-tree-begin (tree) (aref tree 1))
274 | (defun igo-sgf-tree-nodes (tree) (aref tree 2))
275 | (defun igo-sgf-tree-subtrees (tree) (aref tree 3))
276 | (defun igo-sgf-tree-end (tree) (aref tree 4))
277 | (defun igo-sgf-tree-each-nodes (tree func)
278 |   (dolist (node (igo-sgf-tree-nodes tree))
279 |     (funcall func node tree))
280 |   (dolist (subtree (igo-sgf-tree-subtrees tree))
281 |     (igo-sgf-tree-each-nodes subtree func)))
282 | 
283 | (defun igo-sgf-tree-root-node (tree)
284 |   (car (igo-sgf-tree-nodes tree)))
285 | 
286 | ;; Node
287 | (defun igo-sgf-node-leading-white-spaces (node) (aref node 0))
288 | (defun igo-sgf-node-begin (node) (aref node 1))
289 | (defun igo-sgf-node-properties (node) (aref node 2))
290 | (defun igo-sgf-node-end (node) (aref node 3))
291 | (defun igo-sgf-node-get-property (node id)
292 |   (seq-find (lambda (prop) (string= (igo-sgf-property-id prop) id))
293 |             (igo-sgf-node-properties node)))
294 | (defun igo-sgf-node-get-property-value (node id &optional default)
295 |   (let* ((property (igo-sgf-node-get-property node id)))
296 |     (if (null property)
297 |         (igo-sgf-make-prop-value "" nil default nil)
298 |       (igo-sgf-property-ensure-one-value property)
299 |       (let* ((values (igo-sgf-property-values property)))
300 |         (car values)))))
301 | (defun igo-sgf-node-location-string (node)
302 |   (igo-sgf-format-location
303 |    (igo-sgf-node-begin node)
304 |    (igo-sgf-node-end node)))
305 | 
306 | ;; Root Node
307 | 
308 | (defun igo-sgf-node-get-board-size (node)
309 |   (let* ((sz-value (igo-sgf-node-get-property-value node "SZ" "19"))
310 |          (sz (igo-sgf-split-compose sz-value))
311 |          (w (string-to-number (igo-sgf-prop-value-content (if (consp sz) (car sz) sz))))
312 |          (h (string-to-number (igo-sgf-prop-value-content (if (consp sz) (cdr sz) sz)))))
313 |     (if (not (and (>= w 1) (<= w 52) (>= h 1) (<= h 52)))
314 |         (error "%sInvalid board size(w=%s h=%s)." (igo-sgf-prop-value-location-string sz-value) w h))
315 |     (cons w h)))
316 | 
317 | (defun igo-sgf-node-check-game-type (node)
318 |   (let* ((gm-value (igo-sgf-node-get-property-value node "GM" "1"))
319 |          (gm-str (igo-sgf-prop-value-content gm-value)))
320 |     (if (not (string= gm-str "1"))
321 |         (error "%sGame type is not Go(GM[1])." (igo-sgf-prop-value-location-string gm-value))
322 |       1)))
323 | 
324 | ;; Property
325 | (defun igo-sgf-property-leading-white-spaces (prop) (aref prop 0))
326 | (defun igo-sgf-property-begin (prop) (aref prop 1))
327 | (defun igo-sgf-property-id (prop) (aref prop 2))
328 | (defun igo-sgf-property-values (prop) (aref prop 3))
329 | (defun igo-sgf-property-end (prop) (aref prop 4))
330 | (defun igo-sgf-property-location-string (prop)
331 |   (igo-sgf-format-location
332 |    (igo-sgf-property-begin prop)
333 |    (igo-sgf-property-end prop)))
334 | 
335 | (defun igo-sgf-property-ensure-one-value (prop)
336 |   (if (/= (length (igo-sgf-property-values prop)) 1)
337 |       (error "%sProperty %s has only one value."
338 |              (igo-sgf-property-location-string prop)
339 |              (igo-sgf-property-id prop))))
340 | 
341 | ;; Value
342 | (defun igo-sgf-make-prop-value (leading-wss begin-pos value-str end-pos)
343 |   (vector leading-wss begin-pos value-str end-pos))
344 | (defun igo-sgf-prop-value-leading-white-spaces (prop-value) (aref prop-value 0))
345 | (defun igo-sgf-prop-value-begin (prop-value) (aref prop-value 1))
346 | (defun igo-sgf-prop-value-content (prop-value) (aref prop-value 2))
347 | (defun igo-sgf-prop-value-end (prop-value) (aref prop-value 3))
348 | (defun igo-sgf-prop-value-location-string (prop-value)
349 |   (igo-sgf-format-location
350 |    (igo-sgf-prop-value-begin prop-value)
351 |    (igo-sgf-prop-value-end prop-value)))
352 | 
353 | (defun igo-sgf-split-compose (value)
354 |   "Split string VALUE with a colon.
355 | 
356 | (pv \"ABCD\") => (pv \"ABCD\")
357 | (pv \"AB:CD\") => ((pv \"AB\") . (pv \"CD\"))
358 | (pv \"AB\\:):CD\") => ((pv \"AB:)\") . (pv \"CD\"))
359 | (pv \"AB:CD:EF\") => error
360 | 
361 | NOTE: (pv str)=(igo-sgf-make-prop-value \"\" nil str nil)
362 | "
363 |   (let* ((value-str (igo-sgf-prop-value-content value))
364 |          (value-length (length value-str))
365 |          colon-pos
366 |          (i 0))
367 |     (while (< i value-length)
368 |       (let ((ch (elt value-str i)))
369 |         (cond
370 |          ;; skip next escaped char
371 |          ((= ch ?\\)
372 |           (setq i (1+ i)))
373 |          ;; colon
374 |          ((= ch ?:)
375 |           (if colon-pos
376 |               (error "%sToo many colons in compose value : %s"
377 |                      (igo-sgf-prop-value-location-string value)
378 |                      value-str))
379 |           (setq colon-pos i)))
380 |         (setq i (1+ i))))
381 |     (if (null colon-pos)
382 |         value
383 |       (let ((value-begin (igo-sgf-prop-value-begin value)))
384 |         (cons (igo-sgf-make-prop-value
385 |                (igo-sgf-prop-value-leading-white-spaces value)
386 |                value-begin
387 |                (substring value-str 0 colon-pos)
388 |                (if (integerp value-begin) (+ value-begin colon-pos)))
389 |               (igo-sgf-make-prop-value
390 |                ""
391 |                (if (integerp value-begin) (+ value-begin colon-pos 1))
392 |                (substring value-str (1+ colon-pos))
393 |                (igo-sgf-prop-value-end value)) )))))
394 | 
395 | (defun igo-sgf-value-as-text (value)
396 |   (if (vectorp value) (setq value (igo-sgf-prop-value-content value)))
397 |   ;; Delete escaped line-break
398 |   (setq value (replace-regexp-in-string "\\\\\\(\n\r?\\|\r\n?\\)" "" value))
399 |   ;; Escape character
400 |   (setq value (replace-regexp-in-string "\\\\\\(.\\)" "\\1" value))
401 |   ;; Convert Spaces
402 |   (setq value (replace-regexp-in-string "\t\\|\v" " " value))
403 |   value)
404 | 
405 | (defun igo-sgf-value-as-simple-text (value)
406 |   (if (vectorp value) (setq value (igo-sgf-prop-value-content value)))
407 |   ;; Delete escaped line-break
408 |   (setq value (replace-regexp-in-string "\\\\\\(\n\r?\\|\r\n?\\)" "" value))
409 |   ;; Escape character
410 |   (setq value (replace-regexp-in-string "\\\\\\(.\\)" "\\1" value))
411 |   ;; Convert Spaces
412 |   (setq value (replace-regexp-in-string "\t\\|\v\\|\n\r?\\|\r\n?" " " value))
413 |   value)
414 | 
415 | (defun igo-sgf-value-as-color (value)
416 |   (let ((value-str (igo-sgf-prop-value-content value)))
417 |     (cond
418 |      ((string= value-str "B") 'black)
419 |      ((string= value-str "W") 'white)
420 |      (t (error "%sNot a color '%s'"
421 |                (igo-sgf-prop-value-location-string value)
422 |                value-str)))))
423 | 
424 | (defun igo-sgf-point-letter-to-number (ch pos)
425 |   "Convert a point type(same as move type) letter to an integer.
426 | 
427 | ?a-?z ?A-?Z to 0-25 26-51"
428 |   (cond
429 |    ((and (>= ch ?a) (<= ch ?z)) (- ch ?a))
430 |    ((and (>= ch ?A) (<= ch ?Z)) (+ (- ch ?A) 26))
431 |    (t (error "%s: Invalid point letter '%c'" pos ch))))
432 | 
433 | (defun igo-sgf-value-as-point-xy (value &optional w h)
434 |   "Convert point type(same as move type) value to (x . y).
435 | 
436 | ex: (igo-sgf-value-as-point-xy (igo-sgf-make-prop-value \"\" nil \"da\" nil))
437 |      => (3 . 0)"
438 |   (let ((value-str (igo-sgf-prop-value-content value)))
439 |     (if (/= (length value-str) 2)
440 |         (error "%sPoint value is not two letters." (igo-sgf-prop-value-location-string value)))
441 |     (let ((x (igo-sgf-point-letter-to-number (elt value-str 0) (+ (igo-sgf-prop-value-begin value) 1)))
442 |           (y (igo-sgf-point-letter-to-number (elt value-str 1) (+ (igo-sgf-prop-value-begin value) 2))))
443 |       (if (not (and (>= x 0) (>= y 0) (or (null w) (< x w)) (or (null h) (< y h))))
444 |           (error "%sPoint value %s is out of board (x=%s y=%s)" (igo-sgf-prop-value-location-string value) value-str x y))
445 |       (cons x y))))
446 | 
447 | (defun igo-sgf-expand-compressed-point (value &optional w h)
448 |   "https://www.red-bean.com/sgf/sgf4.html#3.5.1
449 | ex:
450 | (igo-sgf-expand-compressed-point (igo-sgf-make-prop-value \"\" nil \"jk\" nil)) => ((9 . 10))
451 | (igo-sgf-expand-compressed-point (igo-sgf-make-prop-value \"\" nil \"jk:lm\" nil) => ((9 . 10) (10 . 10) (11 . 10) (9 . 11) (10 . 11) (11 . 11) (9 . 12) (10 . 12) (11 . 12))
452 | "
453 |   ;;(if (vectorp value) (setq value (igo-sgf-prop-value-content value)))
454 | 
455 |   (let ((values (igo-sgf-split-compose value)))
456 |     (if (vectorp values)
457 |         ;; not composed
458 |         (list (igo-sgf-value-as-point-xy values w h))
459 |       ;; composed (rectangle)
460 |       (let ((lt (igo-sgf-value-as-point-xy (car values) w h))
461 |             (rb (igo-sgf-value-as-point-xy (cdr values) w h))
462 |             points)
463 |         (cl-loop for y from (cdr lt) to (cdr rb) do
464 |                  (cl-loop for x from (car lt) to (car rb) do
465 |                           (push (cons x y) points)))
466 |         (nreverse points)))))
467 | 
468 | 
469 | ;; Game Info Properties
470 | 
471 | (defconst igo-sgf-game-info-properties
472 |   '(
473 |     ("CP" "Copyright")
474 |     ("US" "Enterer Name")
475 |     ("AN" "Annotator Name")
476 |     ("SO" "Source")
477 |     ("EV" "Event Name")
478 |     ("GN" "Game Name")
479 |     ("RO" "Round Number")
480 |     ("DT" "Date")
481 |     ("PC" "Place")
482 |     ("BT" "Black Team" :player black)
483 |     ("PB" "Black Player" :player black)
484 |     ("BR" "Black Rank" :player black)
485 |     ("WT" "White Team" :player white)
486 |     ("PW" "White Player" :player white)
487 |     ("WR" "White Rank" :player white)
488 |     ("RU" "Rule")
489 |     ("OT" "Overtime Method")
490 |     ("TM" "Time Limit" :type real)
491 |     ("HA" "Handicap Stones" :type number)
492 |     ("KM" "Komi" :type real)
493 |     ("RE" "Result")
494 |     ("ON" "Opening Moves")
495 |     ("GC" "Comment" :type text)
496 |     ))
497 | 
498 | (defun igo-sgf-game-info-prop-id (prop)
499 |   (car prop))
500 | (defun igo-sgf-game-info-prop-title (prop)
501 |   (cadr prop))
502 | (defun igo-sgf-game-info-prop-type (prop)
503 |   (or (plist-get (cddr prop) :type) 'simpletext))
504 | 
505 | 
506 | ;; Encode Text
507 | 
508 | (defun igo-sgf-text (text &optional compose-type)
509 |   ;; see: https://www.red-bean.com/sgf/sgf4.html#text
510 |   (if compose-type
511 |       (replace-regexp-in-string "\\([]:\\\\]\\)" "\\\\\\1" text) ;;escape :
512 |     (replace-regexp-in-string "\\([]\\\\]\\)" "\\\\\\1" text)))
513 | 
514 | (defun igo-sgf-simple-text (text &optional compose-type)
515 |   ;;@todo same as igo-sgf-text?
516 |   ;; see: https://www.red-bean.com/sgf/sgf4.html#text
517 |   (if compose-type
518 |       (replace-regexp-in-string "\\([]:\\\\]\\)" "\\\\\\1" text) ;;escape :
519 |     (replace-regexp-in-string "\\([]\\\\]\\)" "\\\\\\1" text)))
520 | 
521 | 
522 | (provide 'igo-sgf-parser)
523 | ;;; igo-sgf-parser.el ends here
524 | 


--------------------------------------------------------------------------------
/igo-org-export-html.el:
--------------------------------------------------------------------------------
  1 | ;;; igo-org-export-html.el --- Org HTML Exporter for Igo Special Block  -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2020  AKIYAMA Kouhei
  4 | 
  5 | ;; Author: AKIYAMA Kouhei
  6 | ;; Keywords: games
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; There are three ways to export igo special blocks (begin_igo ~ end_igo).
 24 | ;;
 25 | ;; - igo-org-set-html-filters-local :: Individual file settings
 26 | ;; - igo-org-define-html-backend :: Define backend derived from HTML
 27 | ;; - igo-org-modify-html-backend :: Modify HTML backend direct
 28 | 
 29 | ;;; Code:
 30 | 
 31 | (require 'svg)
 32 | (require 'igo-org)
 33 | (require 'igo-view)
 34 | (require 'ox-html)
 35 | 
 36 | (defcustom igo-org-js-path
 37 |   "./"
 38 |   "The path to js_igo."
 39 |   :group 'el-igo
 40 |   :type 'string)
 41 | 
 42 | (defcustom igo-org-js-template
 43 |   "<script src=\"%PATH%igo.js\"></script>
 44 | <script src=\"%PATH%igo_view.js\"></script>
 45 | <link rel=\"stylesheet\" href=\"%PATH%igo.css\" />
 46 | <script>
 47 | window.addEventListener(\"load\", ev=>{
 48 |   for(elem of document.querySelectorAll(\"div.igo[data-igo-js]\")){
 49 |     let sgf = elem.textContent;
 50 |     while(elem.hasChildNodes()){
 51 |       elem.removeChild(elem.firstChild);
 52 |     }
 53 |     new igo.GameView(elem, sgf,
 54 |       elem.dataset.igoOpt ? JSON.parse(elem.dataset.igoOpt) :
 55 |       {\"showBranchText\": true, \"showLastMoveMark\": true, \"showComment\": true, \"path\":1000});
 56 |   }});
 57 | </script>
 58 | "
 59 |   "The js_igo template."
 60 |   :group 'el-igo
 61 |   :type 'string)
 62 | 
 63 | (defcustom igo-org-lazy-js-template
 64 |   "<script>
 65 | //<!--
 66 | !function(e,t){var n=function(e,t){for(var n=0;n<e.length;++n)t(e[n])},r=Promise;e.loadScriptOnViewport=function(i,o){return\"string\"==typeof i&&(i=t.getElementById(i)),new r(l=>{(function(n){return new r(r=>{function i(o){var l=n.getBoundingClientRect();l.bottom+50>=0&&l.top-50<=(e.innerHeight||t.documentElement.clientHeight)&&(e.removeEventListener(\"load\",i,!1),e.removeEventListener(\"scroll\",i,!1),r(n))}e.addEventListener(\"load\",i,!1),e.addEventListener(\"scroll\",i,!1)})})(i).then(e=>{(function e(i,o){return\"string\"==typeof i?new r(e=>{var r={};n(t.getElementsByTagName(\"link\"),e=>{\"stylesheet\"==e.getAttribute(\"rel\")&&(r[e.getAttribute(\"href\")]=e)}),n(t.getElementsByTagName(\"script\"),e=>{r[e.getAttribute(\"src\")]=e});var o=t.head,l=r[i];if(l)if(l.isUrlLoading){var s=l.onload;l.onload=s?()=>{s(),e()}:e}else e();else/\\.css/.test(i)?((l=t.createElement(\"link\")).isUrlLoading=!0,l.rel=\"stylesheet\",l.type=\"text/css\",l.href=i):((l=t.createElement(\"script\")).isUrlLoading=!0,l.type=\"text/javascript\",l.src=i),l.onload=function(t){l.isUrlLoading&&(console.log(\"loaded: \"+i),l.isUrlLoading=!1,e())},o.appendChild(l)}):o?new r(t=>{var n=()=>{0==i.length?t():e(i.shift(),!1).then(n)};n()}):r.all(i.map(t=>e(t,!0)))})(o).then(()=>{l(e)})})})}}(window,document);
 67 | 
 68 | var currScript = document.currentScript;
 69 | var div = document.createElement(\"div\");
 70 | currScript.parentNode.insertBefore(div, currScript);
 71 | 
 72 | loadScriptOnViewport(div, [\"%PATH%igo.css\", [\"%PATH%igo.js\", \"%PATH%igo_view.js\"]]).then(
 73 |     function(elem){
 74 |         var gameView = new igo.GameView(
 75 |             elem,
 76 |             igo.Game.fromSGF(\"%LITERAL_SGF%\"), %OPT_JSON%);
 77 | });
 78 | //--></script>"
 79 |   "The js_igo template for lazy loading."
 80 |   :group 'el-igo
 81 |   :type 'string)
 82 | 
 83 | (defcustom igo-org-header-template
 84 |   ""
 85 |   "The header template used when display option is custom."
 86 |   :group 'el-igo
 87 |   :type 'string)
 88 | 
 89 | (defcustom igo-org-block-template
 90 |   "%HTML_SGF%"
 91 |   "The block template used when display option is custom."
 92 |   :group 'el-igo
 93 |   :type 'string)
 94 | 
 95 | (defcustom igo-org-html-display
 96 |   'lazy-js
 97 |   "How to display igo special blocks."
 98 |   :group 'el-igo
 99 |   :type '(choice (const :tag "Not display" none)
100 |                  (const :tag "Not convert(SGF text)" noconv)
101 |                  (const :tag "SVG image" svg)
102 |                  (const :tag "Use js_igo" js)
103 |                  (const :tag "Use js_igo with lazy loading" lazy-js)
104 |                  (const :tag "Use custom template" custom)))
105 | 
106 | (defvar igo-org-js-options-alist
107 |   '((:igo-js-path "IGO_JS_PATH" nil igo-org-js-path)
108 |     (:igo-js-template "IGO_JS_TEMPLATE" nil igo-org-js-template)
109 |     (:igo-lazy-js-template "IGO_LAZY_JS_TEMPLATE" nil igo-org-lazy-js-template)
110 |     (:igo-header-template "IGO_HEADER_TEMPLATE" nil igo-org-header-template)
111 |     (:igo-block-template "IGO_BLOCK_TEMPLATE" nil igo-org-block-template)
112 |     (:igo-enable "IGO_ENABLE" nil "t")
113 |     (:igo-display "IGO_DISPLAY" nil igo-org-html-display)))
114 | 
115 | 
116 | ;; Modify Special Block
117 | 
118 | (defun igo-org-html-filter-parse-tree (data backend info)
119 |   "A filter function to set to org-export-filter-parse-tree-functions variable.
120 | 
121 | Modify all igo special blocks in the DATA tree."
122 |   (when (or (eq backend 'html)
123 |             (org-export-derived-backend-p
124 |              (org-export-get-backend backend) 'html))
125 |     (when (and ;;(not (memq 'body-only (plist-get info :export-options)))
126 |                (not (member (plist-get info :igo-enable) '(nil "" "nil" "no"))))
127 | 
128 |       (let ((display-types-used (igo-org-modify-all-special-blocks data info)))
129 | 
130 |         ;; Add HTML header
131 |         (if (memq 'js display-types-used)
132 |             (igo-org-add-to-html-head-extra
133 |              info
134 |              (igo-org-instantiate-header-template
135 |               (or (plist-get info :igo-js-template) "")
136 |               info)))
137 |         (if (memq 'custom display-types-used)
138 |             (igo-org-add-to-html-head-extra
139 |              info
140 |              (igo-org-instantiate-header-template
141 |               (or (plist-get info :igo-header-template) "")
142 |               info))))))
143 |   data)
144 | 
145 | (defun igo-org-add-to-html-head-extra (info header-html)
146 |   (if (and (stringp header-html) (not (string= header-html "")))
147 |       (if-let ((head-extra (plist-get info :html-head-extra)))
148 |           (plist-put info :html-head-extra
149 |                      (concat head-extra "\n" header-html))
150 |         ;; Add :html-head-extra property to last of INFO
151 |         (if info
152 |             (setcdr (last info) (list :html-head-extra header-html))
153 |           ;; @todo if info is null
154 |           (error "info is null")))))
155 | 
156 | (defun igo-org-modify-all-special-blocks (data info)
157 |   (let (display-types-used)
158 |     (org-element-map data 'special-block
159 |       (lambda (special-block)
160 |         (let ((display-type (igo-org-modify-special-block special-block info)))
161 |           (if (null (memq display-type display-types-used))
162 |               (push display-type display-types-used)))))
163 |     display-types-used))
164 | 
165 | (defun igo-org-modify-special-block (special-block info)
166 |   (when (string= "igo" (org-element-property :type special-block))
167 |     (let* ((options (igo-org-get-special-block-header-options special-block))
168 |            (display
169 |             (or
170 |              (let ((v (igo-org-opt-value :display options)))
171 |                (cond ((stringp v) (intern (downcase v)))
172 |                      ((symbolp v) v)))
173 |              (let ((v (plist-get info :igo-display)))
174 |                (cond ((stringp v) (intern (downcase v)))
175 |                      ((symbolp v) v))))))
176 |       (cond
177 |        ((eq display 'none)
178 |         (org-element-set-contents special-block nil))
179 |        ((or (eq display 'noconv)
180 |             (eq display 'sgf)))
181 |        ((eq display 'js)
182 |         (igo-org-modify-special-block-js special-block info))
183 |        ((eq display 'lazy-js)
184 |         (igo-org-modify-special-block-lazy-js special-block info))
185 |        ((eq display 'svg)
186 |         (igo-org-modify-special-block-svg special-block info))
187 |        ((eq display 'custom)
188 |         (igo-org-modify-special-block-custom special-block info)))
189 |       display)))
190 | 
191 | (defun igo-org-modify-special-block-js (special-block info)
192 |   ;; Add attr_html
193 |   (igo-org-js-add-html-attr-to-special-block special-block)
194 |   ;; Remove <p> </p>
195 |   (igo-org-replace-element-contents-to-html
196 |    special-block
197 |    (igo-org-get-special-block-text special-block info)))
198 | 
199 | (defun igo-org-js-add-html-attr-to-special-block (special-block)
200 |   (let ((opt-json (igo-org-make-options-for-js_igo
201 |                    (igo-org-get-special-block-header-options
202 |                     special-block))))
203 |     (if (not (string= opt-json ""))
204 |         (org-element-put-property
205 |          special-block :attr_html
206 |          (list (concat (car (org-element-property :attr_html special-block))
207 |                        " :data-igo-js t :data-igo-opt " opt-json))))))
208 | 
209 | (defun igo-org-modify-special-block-lazy-js (special-block info)
210 |   (igo-org-replace-element-contents-to-html
211 |    special-block
212 |    (igo-org-instantiate-block-template
213 |     (or (plist-get info :igo-lazy-js-template) "")
214 |     special-block info)))
215 | 
216 | (defun igo-org-modify-special-block-svg (special-block info)
217 |   (igo-org-replace-element-contents-to-html
218 |    special-block
219 |    (igo-org-create-svg-from-special-block special-block info)))
220 | 
221 | (defun igo-org-modify-special-block-custom (special-block info)
222 |   (igo-org-replace-element-contents-to-html
223 |    special-block
224 |    (igo-org-instantiate-block-template
225 |     (or (plist-get info :igo-block-template) "")
226 |     special-block info)))
227 | 
228 | 
229 | (defun igo-org-replace-element-contents-to-html (element html)
230 |   "Replace the contents of ELEMENT to HTML."
231 |   ;;@todo support replace option? (org-element-set-element element new-elem)
232 |   (org-element-set-contents
233 |    element
234 |    ;; Wrap export block (#+begin_export html ~ #+end_export)
235 |    (org-element-create 'export-block
236 |                        (list :type "HTML"
237 |                              :value html))))
238 | 
239 | ;;
240 | ;; Template Instantiation
241 | ;;
242 | 
243 | (defun igo-org-instantiate-template (template vars)
244 |   (replace-regexp-in-string
245 |    "%[A-Z_]+%"
246 |    (lambda (var-spec)
247 |      (save-match-data
248 |        (string-match "\\`%\\(\\(LITERAL\\|ATTR\\|HTML\\)_\\|\\)\\([A-Z_]+\\)%\\'" var-spec)
249 |        (let* ((prefix (match-string 2 var-spec))
250 |               (name (match-string 3 var-spec))
251 |               (rep (cdr (assoc name vars))))
252 |          (cond
253 |           ((functionp rep) (igo-org-instantiate-template-escape prefix (funcall rep)))
254 |           ((stringp rep) (igo-org-instantiate-template-escape prefix rep))
255 |           (t var-spec)))))
256 |    template
257 |    t t))
258 | 
259 | (defun igo-org-instantiate-template-escape (type string)
260 |   (save-match-data
261 |     (cond
262 |      ;; for HTML Attribute
263 |      ((string= type "ATTR")
264 |       (replace-regexp-in-string
265 |        "\"" "&quot;"
266 |        (org-html-encode-plain-text string)
267 |        t t))
268 |      ;; for JavaScript String Literal
269 |      ((string= type "LITERAL")
270 |       (dolist (pair '(("\\\\" . "\\\\")
271 |                       ("\n" . "\\n")
272 |                       ("\"" . "\\\"")
273 |                       ("<!--" . "<\\!--")
274 |                       ("<script" . "<\\script")
275 |                       ("</script" . "<\\/script")))
276 |         (setq string (replace-regexp-in-string (car pair) (cdr pair)
277 |                                                string t t)))
278 |       string)
279 |      ;; for HTML Text
280 |      ((string= type "HTML") (org-html-encode-plain-text string))
281 | 
282 |      ;; Raw Text
283 |      (t string))))
284 | 
285 | ;; Header Template
286 | 
287 | (defun igo-org-instantiate-header-template (template info)
288 |   (igo-org-instantiate-template
289 |    template
290 |    (list
291 |     (cons "PATH" (lambda () (or (plist-get info :igo-js-path) ""))))))
292 | 
293 | ;; Block Template
294 | 
295 | (defun igo-org-instantiate-block-template (template special-block info)
296 |   (igo-org-instantiate-template
297 |    template
298 |    (list
299 |     (cons "PATH"
300 |           (lambda ()
301 |             (or (plist-get info :igo-js-path) "")))
302 |     (cons "SGF"
303 |           (lambda ()
304 |             (or (igo-org-get-special-block-text special-block info) "")))
305 |     (cons "OPT_JSON"
306 |           (lambda ()
307 |             (igo-org-make-options-for-js_igo
308 |              (igo-org-get-special-block-header-options
309 |               special-block))))
310 |     (cons "SVG"
311 |           (lambda ()
312 |             (igo-org-create-svg-from-special-block special-block info)))
313 |     )))
314 | 
315 | 
316 | (defun igo-org-get-special-block-text (special-block info)
317 |   "Return SGF string in SPECIAL-BLOCK."
318 |   (org-export-data
319 |    ;;@todo check plain text only
320 |    (let* ((contents (org-element-contents special-block)))
321 |      (if (and (eq (org-element-type (car contents)) 'paragraph)
322 |               (null (cdr contents)))
323 |          (org-element-contents (car contents))
324 |        contents))
325 |    info))
326 | 
327 | (defun igo-org-get-special-block-header (special-block)
328 |   "Return header string in SPECIAL-BLOCK."
329 |   (let* (;; #+begin_igo line
330 |          (header-line
331 |           (buffer-substring-no-properties
332 |            (org-element-property :post-affiliated special-block)
333 |            (org-element-property :contents-begin special-block)))
334 |          ;; string after #+begin_igo
335 |          (options-str
336 |           (if (string-match
337 |                "^[[:blank:]]*#\\+[A-Za-z]+_[A-Za-z]+[[:blank:]]*\\([^\n]*\\)"
338 |                header-line)
339 |               (match-string-no-properties 1 header-line)
340 |             "")))
341 |     options-str))
342 | 
343 | (defun igo-org-get-special-block-header-options (special-block)
344 |   "Return alist specified by header line of SPECIAL-BLOCK."
345 |   (org-babel-parse-header-arguments
346 |    (igo-org-get-special-block-header special-block) t))
347 | 
348 | (defun igo-org-make-options-for-js_igo (options)
349 |   (defvar igo-editor-status-bar-visible) ;;igo-editor.el
350 |   (let ((json
351 |          (concat
352 |           "\"ui\": {\"top\":["
353 |           (if (igo-org-opt-bool-value :status-bar options
354 |                                       (and (boundp
355 |                                             'igo-editor-status-bar-visible)
356 |                                            igo-editor-status-bar-visible))
357 |               "\"GameStatus\"")
358 |           "], \"bottom\":[[\"UndoAll\",\"Undo\",\"Redo\",\"RedoAll\",\"Pass\",\"Menu\"], \"ViewControl\", \"Comment\"]},"
359 |           (if (igo-org-opt-bool-value :move-number options)
360 |               "\"showMoveNumber\": true,")
361 |           (if (igo-org-opt-bool-value :branch-text options "t")
362 |               "\"showBranchText\": true,")
363 |           (if (or (not (igo-org-opt-bool-value :editable options "t"))
364 |                   (igo-org-opt-bool-value :read-only options))
365 |               "\"editable\": false,")
366 |           (if-let ((path (igo-org-opt-value :path options)))
367 |               (concat
368 |                "\"path\": ["
369 |                (mapconcat
370 |                 (lambda (q)
371 |                   (cond
372 |                    ((numberp q) (number-to-string q))
373 |                    ((string-match "\\`-?[0-9]+\\'" q) q)
374 |                    (t (concat "\"" q "\""))))
375 |                 (igo-org-opt-split-path path)
376 |                 ",")
377 |                "],")))))
378 |     (if (string= json "") "" (concat "{" (substring json 0 -1) "}"))))
379 | 
380 | (defun igo-org-create-svg-from-special-block (special-block info)
381 |   (when-let ((sgf (igo-org-get-special-block-text special-block info)))
382 |     (let* ((sgf-tree (with-temp-buffer
383 |                        (insert sgf)
384 |                        (goto-char (point-min))
385 |                        (igo-sgf-parse-tree (current-buffer))))
386 |            (game-tree (igo-sgf-root-tree-to-game-tree sgf-tree))
387 |            (size (igo-sgf-node-get-board-size
388 |                   (igo-sgf-tree-root-node sgf-tree)))
389 |            (game (igo-game (car size) (cdr size) game-tree))
390 |            (board (igo-game-board game))
391 |            (options (igo-org-get-special-block-header-options special-block))
392 |            (board-view (igo-board-view board))
393 |            (svg (svg-create (igo-board-view-pixel-w board-view)
394 |                             (igo-board-view-pixel-h board-view))))
395 | 
396 |       ;; path
397 |       (if-let ((queries (igo-org-opt-split-path (igo-org-opt-value :path options))))
398 |           (igo-game-redo-by-queries game queries))
399 | 
400 |       ;;@todo support status bar?
401 | 
402 |       ;; board
403 |       (igo-board-view-create-board board-view svg 0 0)
404 | 
405 |       ;; stones
406 |       (igo-board-view-update-stones board-view svg board)
407 | 
408 |       ;; move numbers
409 |       (igo-board-view-update-move-numbers
410 |        board-view svg
411 |        (igo-org-opt-bool-value :move-number options nil)
412 |        game)
413 | 
414 |       ;; branch text
415 |       (igo-board-view-update-branches
416 |        board-view
417 |        svg
418 |        (igo-org-opt-bool-value :branch-text options t)
419 |        board (igo-game-current-node game)
420 |        nil nil nil)
421 | 
422 |       ;; last move
423 |       (igo-board-view-update-last-move-mark
424 |        board-view svg
425 |        (and (igo-org-opt-bool-value :last-move options t)
426 |             (not (igo-org-opt-bool-value :move-number options nil)))
427 |        game)
428 | 
429 |       ;; marks
430 |       (igo-board-view-update-marks board-view svg t game)
431 | 
432 |       ;; Create SVG text
433 |       (with-temp-buffer
434 |         (svg-print svg)
435 |         (buffer-string)))))
436 | 
437 | 
438 | 
439 | ;;
440 | ;; Apply Filters for Individual Files
441 | ;;
442 | ;; Usage:
443 | ;; 1. Add the following code to your org document.
444 | ;;    #+begin_src emacs-lisp :exports results :results none
445 | ;;    (require 'igo-org-export-html)
446 | ;;    (igo-org-set-html-filters-local)
447 | ;;    #+end_src
448 | ;; 2. Export as HTML (Eval source block)
449 | 
450 | (defun igo-org-set-html-filters-local ()
451 |   "Set exporter functions and variables as buffer local.
452 | 
453 | To use this function, add the following code to your org document.
454 | Then export as HTML.
455 | 
456 | #+begin_src emacs-lisp :exports results :results none
457 | (igo-org-set-html-filters-local)
458 | #+end_src
459 | "
460 |   (setq-local org-export-options-alist
461 |               (append igo-org-js-options-alist org-export-options-alist))
462 |   (setq-local org-export-filter-parse-tree-functions
463 |               (append (list #'igo-org-html-filter-parse-tree)
464 |                       org-export-filter-parse-tree-functions)))
465 | 
466 | ;;
467 | ;; Derived from HTML Backend
468 | ;;
469 | ;; Usage:
470 | ;; 1. (igo-org-define-html-backend t)
471 | ;; 2. Type C-c C-e g in org-mode
472 | 
473 | (defun igo-org-define-html-backend (&optional add-to-menu-p)
474 |   "Define a backend that transforms igo special blocks, derived
475 | from the HTML backend."
476 |   (apply #'org-export-define-derived-backend
477 |          'igo-html 'html
478 |          :filters-alist '((:filter-parse-tree . igo-org-html-filter-parse-tree))
479 |          :options-alist igo-org-js-options-alist
480 | 
481 |          (if add-to-menu-p
482 |              '(
483 |                :menu-entry
484 |                (?g "Export to Go Game HTML"
485 |                    ((?G "As HTML buffer" igo-org-export-as-html)
486 |                     (?g "As HTML file" igo-org-export-to-html)
487 |                     (?o "As HTML file and open"
488 |                         (lambda (a s v b)
489 |                           (if a (igo-org-export-to-html t s v b)
490 |                             (org-open-file (igo-org-export-to-html nil s v b)))))))))))
491 | 
492 | ;;;###autoload
493 | (defun igo-org-export-as-html
494 |   (&optional async subtreep visible-only body-only ext-plist)
495 |   (interactive)
496 |   (org-export-to-buffer 'igo-html "*Org Go Game HTML Export*"
497 |     async subtreep visible-only body-only ext-plist
498 |     (lambda () (set-auto-mode t))))
499 | 
500 | ;;;###autoload
501 | (defun igo-org-export-to-html
502 |   (&optional async subtreep visible-only body-only ext-plist)
503 |   (interactive)
504 |   (let* ((extension (concat "." (or (plist-get ext-plist :html-extension)
505 |                                     org-html-extension
506 |                                     "html")))
507 |          (file (org-export-output-file-name extension subtreep))
508 |          (org-export-coding-system org-html-coding-system))
509 |     (org-export-to-file 'igo-html file
510 |       async subtreep visible-only body-only ext-plist)))
511 | 
512 | ;;;###autoload
513 | (defun igo-org-publish-to-html (plist filename pub-dir)
514 |   (org-publish-org-to 'igo-html filename
515 |                       (concat "." (or (plist-get plist :html-extension)
516 |                                       org-html-extension
517 |                                       "html"))
518 |                       plist pub-dir))
519 | 
520 | 
521 | ;;
522 | ;; Modify HTML Backend Direct
523 | ;;
524 | ;; Usage:
525 | ;; 1. Add the following code to init.el:
526 | ;;    (with-eval-after-load "ox-html"
527 | ;;      (require 'igo-org-export-html)
528 | ;;      (igo-org-modify-html-backend))
529 | ;; 2. Export as HTML
530 | 
531 | (defun igo-org-modify-html-backend ()
532 |   "Modify registered HTML backend."
533 |   (require 'ox-html)
534 |   (let ((backend (org-export-get-backend 'html)))
535 |     ;; Add igo-org-js-options-alist to backend's options
536 |     (let ((backend-options (org-export-backend-options backend))
537 |           (new-option-names (mapcar #'car igo-org-js-options-alist)))
538 |       (setf (org-export-backend-options backend)
539 |             (nconc
540 |              (seq-remove (lambda (elem) (memq (car elem) new-option-names))
541 |                          backend-options)
542 |              igo-org-js-options-alist)))
543 |     ;; Add igo-org-html-filter-parse-tree to backend's filter-parse-tree
544 |     (let ((filter-parse-tree (assq :filter-parse-tree
545 |                                    (org-export-backend-filters backend))))
546 |       ;; null => (:filter-parse-tree . ())
547 |       (if (null filter-parse-tree)
548 |           (push (setq filter-parse-tree (list :filter-parse-tree))
549 |                 (org-export-backend-filters backend)))
550 |       ;; (:filter-parse-tree . function) => (:filter-parse-tree . (function))
551 |       (if (functionp (cdr filter-parse-tree))
552 |           (setcdr filter-parse-tree (list (cdr filter-parse-tree))))
553 |       ;; Add my filter function
554 |       (if (not (memq 'igo-org-html-filter-parse-tree (cdr filter-parse-tree)))
555 |           (push 'igo-org-html-filter-parse-tree (cdr filter-parse-tree))))))
556 | 
557 | 
558 | (provide 'igo-org-export-html)
559 | ;;; igo-org-export-html.el ends here
560 | 


--------------------------------------------------------------------------------
/igo-view.el:
--------------------------------------------------------------------------------
  1 | ;;; igo-view.el --- Igo Game View                   -*- lexical-binding: t; -*-
  2 | 
  3 | ;; Copyright (C) 2020 AKIYAMA Kouhei
  4 | 
  5 | ;; Author: AKIYAMA Kouhei
  6 | ;; Keywords: games
  7 | 
  8 | ;; This program is free software; you can redistribute it and/or modify
  9 | ;; it under the terms of the GNU General Public License as published by
 10 | ;; the Free Software Foundation, either version 3 of the License, or
 11 | ;; (at your option) any later version.
 12 | 
 13 | ;; This program is distributed in the hope that it will be useful,
 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 16 | ;; GNU General Public License for more details.
 17 | 
 18 | ;; You should have received a copy of the GNU General Public License
 19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 20 | 
 21 | ;;; Commentary:
 22 | 
 23 | ;; 
 24 | 
 25 | ;;; Code:
 26 | 
 27 | (require 'svg)
 28 | (require 'igo-model)
 29 | 
 30 | ;;
 31 | ;; Board View
 32 | ;;
 33 | 
 34 | ;; Board View - Sizes
 35 | 
 36 | (defcustom igo-board-view-size-max '(0.9 . 0.8)
 37 |   "Maximum pixel size of boards.
 38 | 
 39 | Specify an integer or a float or (width-int-or-float . height-int-or-float).
 40 | 
 41 | If the value is an integer, it directly specifies the maximum
 42 | board width and height.
 43 | 
 44 | If the value is an floating point number, it specifies the
 45 | maximum board width and height as a ratio to frame width and
 46 | height."
 47 |   :type '(choice integer
 48 |                  float
 49 |                  (cons (choice integer
 50 |                                float)
 51 |                        (choice integer
 52 |                                float)))
 53 |   :group 'el-igo)
 54 | 
 55 | (defcustom igo-board-view-grid-interval-default 32
 56 |   "Default interval of grid lines."
 57 |   :type '(integer)
 58 |   :group 'el-igo)
 59 | (defcustom igo-board-view-grid-interval-min 10
 60 |   "Minimum interval of grid lines."
 61 |   :type '(integer)
 62 |   :group 'el-igo)
 63 | 
 64 | (defun igo-board-view-size-max-spec (width-p)
 65 |   "Extract width or height from igo-svg-max-board-size."
 66 |   (let* ((spec igo-board-view-size-max)
 67 |          (max-size
 68 |           (cond
 69 |            ((consp spec) (if width-p (car spec) (cdr spec)))
 70 |            ((numberp spec))
 71 |            (t 0.8))))
 72 |     (if (floatp max-size)
 73 |         (ceiling (/ (* max-size (if width-p
 74 |                                     (frame-text-width)
 75 |                                   (frame-text-height)))
 76 |                     (image-compute-scaling-factor image-scaling-factor)))
 77 |       max-size)))
 78 | 
 79 | ;; Board View - Constructor
 80 | 
 81 | (defun igo-board-view (board &optional interval)
 82 |   (let* ((w (igo-board-w board))
 83 |          (h (igo-board-h board))
 84 |          (max-w (igo-board-view-size-max-spec t))
 85 |          (max-h (igo-board-view-size-max-spec nil))
 86 |          (max-interval-w (/ max-w (+ (1- w) 3))) ;; 3=margin*2
 87 |          (max-interval-h (/ max-h (+ (1- h) 3))) ;; 3=margin*2
 88 |          (max-interval (min max-interval-w max-interval-h))
 89 |          (interval (max (min (or interval
 90 |                                  igo-board-view-grid-interval-default)
 91 |                              max-interval)
 92 |                         igo-board-view-grid-interval-min))
 93 |          (margin (/ (* 3 interval) 2)) ;; 3=margin*2
 94 |          (view (vector w h margin interval)))
 95 |     view))
 96 | 
 97 | ;; Board View - Sizes
 98 | 
 99 | (defun igo-board-view-w (view) (aref view 0))
100 | (defun igo-board-view-h (view) (aref view 1))
101 | (defun igo-board-view-margin (view) (aref view 2))
102 | (defun igo-board-view-interval (view) (aref view 3))
103 | 
104 | (defun igo-board-view-pixel-w (view)
105 |   (+ (* 2 (igo-board-view-margin view))
106 |      (* (1- (igo-board-view-w view)) (igo-board-view-interval view))))
107 | (defun igo-board-view-pixel-h (view)
108 |   (+ (* 2 (igo-board-view-margin view))
109 |      (* (1- (igo-board-view-h view)) (igo-board-view-interval view))))
110 | 
111 | (defun igo-board-view-clickable-left (view &optional x)
112 |   (+
113 |    (- (igo-board-view-margin view) (/ (igo-board-view-interval view) 2))
114 |    (or x 0)))
115 | (defun igo-board-view-clickable-top (view &optional y)
116 |   (+
117 |    (- (igo-board-view-margin view) (/ (igo-board-view-interval view) 2))
118 |    (or y 0)))
119 | (defun igo-board-view-clickable-width (view)
120 |   (* (igo-board-view-interval view) (igo-board-view-w view)))
121 | (defun igo-board-view-clickable-height (view)
122 |   (* (igo-board-view-interval view) (igo-board-view-h view)))
123 | 
124 | (defun igo-board-view-to-grid-x (view x &optional board-left)
125 |   (/ (- x (igo-board-view-clickable-left view board-left))
126 |      (igo-board-view-interval view)))
127 | 
128 | (defun igo-board-view-to-grid-y (view y &optional board-top)
129 |   (/ (- y (igo-board-view-clickable-top view board-top))
130 |      (igo-board-view-interval view)))
131 | 
132 | 
133 | ;; Board View - Update
134 | 
135 | (defun igo-board-view-create-board (view svg left top)
136 |   (igo-svg-board
137 |    svg left top
138 |    (igo-board-view-w view)
139 |    (igo-board-view-h view)
140 |    (igo-board-view-interval view)
141 |    (igo-board-view-margin view)))
142 | 
143 | (defun igo-board-view-update-stones (view svg board)
144 |   (igo-svg-stones svg board (igo-board-view-interval view)))
145 | 
146 | (defun igo-board-view-update-move-numbers (view svg visible game)
147 |   (if visible
148 |       (igo-svg-move-numbers svg
149 |                             (igo-game-board game)
150 |                             (igo-board-view-interval view)
151 |                             (igo-game-current-node game))
152 |     (igo-svg-remove-move-numbers svg)))
153 | 
154 | (defun igo-board-view-update-branches (view svg visible board move-color node
155 |                                             &optional fun-pass fun-resign fun-setup)
156 |   (if visible
157 |       (igo-svg-branches
158 |        svg
159 |        board
160 |        move-color
161 |        (igo-board-view-interval view)
162 |        node
163 |        fun-pass fun-resign fun-setup)
164 |     (igo-svg-remove-branches svg)))
165 | 
166 | (defun igo-board-view-update-last-move-mark (view svg visible game)
167 |   (if visible
168 |       (igo-svg-last-move svg game (igo-board-view-interval view))
169 |     (igo-svg-remove-last-move svg)))
170 | 
171 | (defun igo-board-view-update-marks (view svg visible game)
172 |   (if visible
173 |       (igo-svg-marks
174 |        svg
175 |        (igo-game-board game)
176 |        (igo-board-view-interval view)
177 |        (igo-node-get-marks-property (igo-game-current-node game)))
178 |     (igo-svg-remove-marks svg)))
179 | 
180 | 
181 | 
182 | 
183 | ;;
184 | ;; SVG Board
185 | ;;
186 | 
187 | ;; Board
188 | 
189 | (defun igo-svg-board (svg left top w h grid-interval grid-margin)
190 |   (let* ((pixel-w (+ (* 2 grid-margin) (* grid-interval (1- w))))
191 |          (pixel-h (+ (* 2 grid-margin) (* grid-interval (1- h))))
192 |          (line-w 1)
193 |          (star-radius 2.5)
194 |          ;; Board Root
195 |          (svg-board-root (svg-node svg 'g
196 |                                    :class "board"
197 |                                    :transform (format "translate(%s %s)"
198 |                                                       left
199 |                                                       top)))
200 |          ;; Board Rect
201 |          (_svg-board-rect (svg-rectangle svg-board-root 0 0 pixel-w pixel-h :fill "#e3aa4e"))
202 |          ;; Game Area
203 |          (svg-game-area (svg-node svg-board-root 'g
204 |                                   :class "game-area"
205 |                                   :transform (format "translate(%s %s)"
206 |                                                      (- grid-margin 0.5)
207 |                                                      (- grid-margin 0.5))))
208 |          ;; Grid
209 |          (svg-grid (svg-node svg-game-area 'g :class "grid")))
210 |     ;; Lines
211 |     (cl-loop for x to (1- w) do
212 |              (svg-line svg-grid
213 |                        (* x grid-interval)
214 |                        (/ line-w -2.0)
215 |                        (* x grid-interval)
216 |                        (+ (* (1- h) grid-interval) (/ line-w 2.0))
217 |                        :stroke "black" :stroke-width line-w))
218 |     (cl-loop for y to (1- h) do
219 |              (svg-line svg-grid
220 |                        (/ line-w -2.0)
221 |                        (* y grid-interval)
222 |                        (+ (* (1- w) grid-interval) (/ line-w 2.0))
223 |                        (* y grid-interval)
224 |                        :stroke "black" :stroke-width line-w))
225 |     ;; Stars
226 |     (when (and (= (logand w 1) 1) (= (logand h 1) 1))
227 |       (svg-circle svg-grid (* grid-interval (/ (1- w) 2.0)) (* grid-interval (/ (1- h) 2.0)) star-radius :fill "black"))
228 |     (when (and (>= w 13) (>= h 13))
229 |       (svg-circle svg-grid (* grid-interval 3)       (* grid-interval 3) star-radius :fill "black")
230 |       (svg-circle svg-grid (* grid-interval (- w 4)) (* grid-interval 3) star-radius :fill "black")
231 |       (svg-circle svg-grid (* grid-interval 3)       (* grid-interval (- h 4)) star-radius :fill "black")
232 |       (svg-circle svg-grid (* grid-interval (- w 4)) (* grid-interval (- h 4)) star-radius :fill "black"))
233 |     (when (and (>= w 19) (>= h 19) (= (logand w 1) 1))
234 |       (svg-circle svg-grid (* grid-interval (/ (1- w) 2.0)) (* grid-interval 3) star-radius :fill "black")
235 |       (svg-circle svg-grid (* grid-interval (/ (1- w) 2.0)) (* grid-interval (- h 4)) star-radius :fill "black"))
236 |     (when (and (>= w 19) (>= h 19) (= (logand h 1) 1))
237 |       (svg-circle svg-grid (* grid-interval 3)       (* grid-interval (/ (1- h) 2.0)) star-radius :fill "black")
238 |       (svg-circle svg-grid (* grid-interval (- w 4)) (* grid-interval (/ (1- h) 2.0)) star-radius :fill "black"))
239 |     ;; Layers
240 |     (svg-node svg-game-area 'g :class "shadows")
241 |     (svg-node svg-game-area 'g :class "stones")
242 |     (svg-node svg-game-area 'g :class "move-numbers")
243 |     (svg-node svg-game-area 'g :class "overlays")
244 |     ;; Stone's Gradient
245 |     (igo-svg-stone-gradient svg-board-root) ;;@todo insert to svg root?
246 |     ;; Return Board Group
247 |     svg-board-root))
248 | 
249 | ;; Stone
250 | 
251 | (defun igo-svg-shadows-group (svg) (car (dom-by-class svg "shadows")))
252 | (defun igo-svg-stones-group (svg) (car (dom-by-class svg "stones")))
253 | (defun igo-svg-move-numbers-group (svg) (car (dom-by-class svg "move-numbers")))
254 | (defun igo-svg-overlays-group (svg) (car (dom-by-class svg "overlays")))
255 | 
256 | (defun igo-svg-stone-gradient (svg)
257 |   (igo--svg-gradient
258 |    svg "stone-black" 'radial '((0 . "#606060") (100 . "#000000"))
259 |    :cx 0.5 :cy 0.5 :fx 0.7 :fy 0.3 :r 0.55)
260 |   (igo--svg-gradient
261 |    svg "stone-white" 'radial '((0 . "#ffffff") (80 . "#e0e0e0") (100 . "#b0b0b0"))
262 |    :cx 0.5 :cy 0.5 :fx 0.7 :fy 0.3 :r 0.6)
263 |   svg)
264 | 
265 | (defun igo-svg-stone (svg x y color grid-interval)
266 |   (let* ((cx (* x grid-interval))
267 |          (cy (* y grid-interval))
268 |          (r (* grid-interval 0.98 0.5
269 |                (/ (if (igo-white-p color) 21.9 22.2) 22.2)))) ;; diameter of white stone is 21.9mm
270 |     ;; Shadow
271 |     (svg-circle (igo-svg-shadows-group svg) (- cx 2) (- cy 2) r
272 |                 :id (igo-svg-shadow-id x y)
273 |                 :fill "rgba(0,0,0,0.3)")
274 |     ;; Stone
275 |     (svg-circle (igo-svg-stones-group svg) cx cy r
276 |                 :id (igo-svg-stone-id x y)
277 |                 :gradient (if (igo-white-p color) "stone-white" "stone-black"))))
278 | 
279 | (defun igo-svg-stone-id (x y) (format "stone-%s-%s" x y))
280 | (defun igo-svg-shadow-id (x y) (format "shadow-%s-%s" x y))
281 | (defun igo-svg-move-number-id (x y) (format "mvnum-%s-%s" x y))
282 | 
283 | (defun igo-svg-stones (svg board grid-interval)
284 |   (cl-loop for pos to (1- (igo-board-intersection-count board)) do
285 |            (let ((x (igo-board-pos-to-x board pos))
286 |                  (y (igo-board-pos-to-y board pos)))
287 |              (if (igo-board-empty-p-at board pos)
288 |                  (progn
289 |                    (svg-remove svg (igo-svg-stone-id x y))
290 |                    (svg-remove svg (igo-svg-shadow-id x y)))
291 |                (igo-svg-stone svg x y (igo-board-get-at board pos) grid-interval)))))
292 | 
293 | ;; Text
294 | 
295 | (defvar igo-svg-font-family "Arial")
296 | (defvar igo-svg-font-weight "bold")
297 | (defvar igo-svg-font-baseline-shift "-40%")
298 | (defvar igo-svg-font-size-scale 0.52)
299 | 
300 | (defun igo-svg-font-size-on-board (grid-interval &optional scale)
301 |   "Calculate font size."
302 |   (ceiling (* grid-interval
303 |               (or scale igo-svg-font-size-scale))))
304 | 
305 | (defun igo-svg-text-on-board (svg center-x center-y grid-interval text text-color &optional attributes font-size-scale)
306 |   (let* ((font-size (igo-svg-font-size-on-board grid-interval font-size-scale))
307 |          (text-w (string-width text)))
308 |     ;; Shrink width
309 |     (if (>= text-w 3)
310 |         (setq attributes
311 |               (nconc
312 |                (list :transform
313 |                      (format "translate(%s 0) scale(%.4f 1) translate(%s 0)"
314 |                              (+ center-x)
315 |                              (/ 1 (* 0.5 text-w))
316 |                              (- center-x)))
317 |                attributes)))
318 | 
319 |     (apply #'svg-text svg text
320 |            :x center-x :y center-y :fill text-color
321 |            :font-size (number-to-string font-size)
322 |            :font-family igo-svg-font-family
323 |            :font-weight igo-svg-font-weight
324 |            :text-anchor "middle"
325 |            ;; :alignment-baseline "central" ;;librsvg issue
326 |            :baseline-shift igo-svg-font-baseline-shift
327 |            attributes)))
328 | 
329 | (defun igo-svg-text-at-intersection (svg x y grid-interval text text-color &optional attributes font-size-scale)
330 |   (igo-svg-text-on-board
331 |    svg
332 |    (* x grid-interval)
333 |    (* y grid-interval)
334 |    grid-interval
335 |    text text-color
336 |    attributes font-size-scale))
337 | 
338 | ;; Move Number
339 | 
340 | (defun igo-svg-move-number (svg x y grid-interval num text-color)
341 |   (igo-svg-text-at-intersection
342 |    (igo-svg-move-numbers-group svg)
343 |    x y grid-interval
344 |    (number-to-string num)
345 |    text-color
346 |    (list :id (igo-svg-move-number-id x y)
347 |          :class "mvnum")))
348 | 
349 | (defun igo-svg-move-numbers (svg board grid-interval current-node)
350 |   (igo-svg-remove-move-numbers svg)
351 | 
352 |   (let ((numbered (make-vector (igo-board-intersection-count board) nil))
353 |         (move-number (igo-node-move-number current-node))
354 |         (node current-node))
355 |     (while node
356 |       ;; skip pass, resign, setup
357 |       (if (igo-node-placement-p node)
358 |           (let ((pos (igo-node-move node)))
359 |             (when (not (aref numbered pos))
360 |               (aset numbered pos t)
361 |               (let* ((x (igo-board-pos-to-x board pos))
362 |                      (y (igo-board-pos-to-y board pos))
363 |                      (istate (igo-board-get-at board pos))
364 |                      (color (cond
365 |                              ;; last move
366 |                              ((eq node current-node) "#f00")
367 |                              ;; stone
368 |                              ((igo-black-p istate) "#fff")
369 |                              ((igo-white-p istate) "#000")
370 |                              ;; emtpy
371 |                              ((igo-white-p (igo-node-color node)) "#fff")
372 |                              (t "#000"))))
373 |                 (igo-svg-move-number svg x y grid-interval move-number color)))))
374 |       ;; previous node
375 |       (let ((prev (igo-node-prev node))
376 |             (mn (igo-node-get-move-number-property node)))
377 |         (setq move-number
378 |               (cond
379 |                ((and prev mn) (igo-node-move-number prev)) ;; recalculate
380 |                ((igo-node-move-p node) (1- move-number)) ;; decrement
381 |                (t move-number))) ;; keep number
382 |         (setq node prev)))))
383 | 
384 | (defun igo-svg-remove-move-numbers (svg)
385 |   ;;@todo 1.get (igo-svg-move-numbers-group svg), 2.delete children(class="mvnum")
386 |   (dolist (node (dom-by-class svg "^mvnum$"))
387 |     (dom-remove-node svg node)))
388 | 
389 | ;; Branchs(Next Nodes) Text
390 | 
391 | (defun igo-svg-branches (svg board move-color grid-interval node &optional fun-pass fun-resign fun-setup)
392 |   ;; Remove old text
393 |   (igo-svg-remove-branches svg)
394 | 
395 |   ;; Add new text
396 |   (let* ((branch-index 0)
397 |          (next-nodes (igo-node-next-nodes node))
398 |          (num-next-nodes (length next-nodes))
399 |          (text-color (if (igo-black-p move-color) "#000" "#fff"))
400 |          (class-name "branches"))
401 |     (dolist (next next-nodes)
402 |       (let ((text (if (= num-next-nodes 1) "X" (string (+ ?A branch-index))))) ;;@todo x => svg-line?
403 |         (cond
404 |          ((igo-node-placement-p next)
405 |           (if (igo-same-color-p (igo-node-color next) move-color)
406 |               (igo-svg-text-at-intersection
407 |                (igo-svg-overlays-group svg)
408 |                (igo-board-pos-to-x board (igo-node-move next))
409 |                (igo-board-pos-to-y board (igo-node-move next))
410 |                grid-interval text text-color (list :class class-name))))
411 |          ((igo-node-pass-p next)
412 |           (if (and (igo-same-color-p (igo-node-color next) move-color)
413 |                    (functionp fun-pass))
414 |               (funcall fun-pass branch-index num-next-nodes text text-color move-color class-name)))
415 |          ((igo-node-resign-p next)
416 |           (if (and (igo-same-color-p (igo-node-color next) move-color)
417 |                    (functionp fun-resign))
418 |               (funcall fun-resign branch-index num-next-nodes text text-color move-color class-name)))
419 |          ((igo-node-setup-p next)
420 |           (if (functionp fun-setup)
421 |               (funcall fun-setup branch-index num-next-nodes text text-color move-color class-name)))))
422 |       (setq branch-index (1+ branch-index)))))
423 | 
424 | (defun igo-svg-remove-branches (svg)
425 |   ;;@todo 1.get (igo-svg-overlays-group svg), 2.delete children(class="branches")
426 |   (dolist (node (dom-by-class svg "^branches$"))
427 |     (dom-remove-node svg node)))
428 | 
429 | ;; Last Move Mark
430 | 
431 | (defun igo-svg-last-move (svg game grid-interval)
432 |   (igo-svg-remove-last-move svg)
433 | 
434 |   (let* ((curr-node (igo-game-current-node game))
435 |          (move (igo-node-move curr-node)))
436 |     (if (igo-placement-p move)
437 |         (let* ((board (igo-game-board game))
438 |                (x (igo-board-pos-to-x board move))
439 |                (y (igo-board-pos-to-y board move))
440 |                (cx (* x grid-interval))
441 |                (cy (* y grid-interval))
442 |                (r (ceiling (* grid-interval 0.15)))
443 |                ;;(color (igo-opposite-color (igo-game-turn game)))
444 |                )
445 |           (svg-rectangle
446 |            ;;(igo-svg-overlays-group svg)
447 |            (igo-svg-stones-group svg)
448 |            (- cx r)
449 |            (- cy r)
450 |            (* 2 r)
451 |            (* 2 r)
452 |            :id "last-move"
453 |            :fill (cond
454 |                   ;;((igo-black-p color) "rgba(255,255,255,0.5)")
455 |                   ;;((igo-white-p color) "rgba(0,0,0,0.5)")
456 |                   (t "rgba(255,0,0,0.8)")))))))
457 | 
458 | (defun igo-svg-remove-last-move (svg)
459 |   (dom-remove-node svg (car (dom-by-id svg "^last-move$"))))
460 | 
461 | ;; Marker
462 | 
463 | (defun igo-svg-intersection-text-color (board x y)
464 |   (let* ((pos (igo-board-xy-to-pos board x y))
465 |          (istate (igo-board-get-at board pos)))
466 |     (cond
467 |      ((igo-black-p istate) "#fff")
468 |      ((igo-white-p istate) "#000")
469 |      (t "#fff"))))
470 | 
471 | (defun igo-svg-cross-mark (svg x y mark-color board grid-interval)
472 |   (let* ((cx (* x grid-interval))
473 |          (cy (* y grid-interval))
474 |          (r (* 0.25 grid-interval)))
475 |     (svg-path
476 |      svg
477 |      (list (list 'moveto (list (cons (- cx r) (- cy r))))
478 |            (list 'lineto (list (cons (+ cx r) (+ cy r))))
479 |            (list 'moveto (list (cons (+ cx r) (- cy r))))
480 |            (list 'lineto (list (cons (- cx r) (+ cy r)))))
481 |      :stroke-width 3
482 |      :stroke (or mark-color (igo-svg-intersection-text-color board x y))
483 |      :fill "none"
484 |      :class "mark")))
485 | 
486 | (defun igo-svg-circle-mark (svg x y mark-color board grid-interval)
487 |   (svg-circle
488 |    svg
489 |    (* x grid-interval)
490 |    (* y grid-interval)
491 |    (* 0.3 grid-interval)
492 |    :stroke-width 3
493 |    :stroke (or mark-color (igo-svg-intersection-text-color board x y))
494 |    :fill "none"
495 |    :class "mark"))
496 | 
497 | (defun igo-svg-square-mark (svg x y mark-color board grid-interval)
498 |   (let* ((r (* 0.25 grid-interval)))
499 |     (svg-rectangle
500 |      svg
501 |      (- (* x grid-interval) r)
502 |      (- (* y grid-interval) r)
503 |      (* 2 r)
504 |      (* 2 r)
505 |      :stroke-width 3
506 |      :stroke (or mark-color (igo-svg-intersection-text-color board x y))
507 |      :fill "none"
508 |      :class "mark")))
509 | 
510 | (defun igo-svg-triangle-mark (svg x y mark-color board grid-interval)
511 |   (let* ((cx (* x grid-interval))
512 |          (cy (* y grid-interval))
513 |          (r (* 0.3 grid-interval))
514 |          (rt3 (sqrt 3)))
515 |     (svg-polygon
516 |      svg
517 |      (list (cons cx (+ cy (* r rt3 -0.55)))
518 |            (cons (+ cx r) (+ cy (* r rt3 0.45)))
519 |            (cons (- cx r) (+ cy (* r rt3 0.45))))
520 |      :stroke-width 3
521 |      :stroke (or mark-color (igo-svg-intersection-text-color board x y))
522 |      :fill "none"
523 |      :class "mark")))
524 | 
525 | (defun igo-svg-marks (svg board grid-interval marks)
526 |   (igo-svg-remove-marks svg)
527 | 
528 |   (dolist (mark marks)
529 |     (let* ((type (igo-mark-type mark))
530 |            (pos (igo-mark-pos mark))
531 |            (x (igo-board-pos-to-x board pos))
532 |            (y (igo-board-pos-to-y board pos))
533 |            (parent (igo-svg-overlays-group svg)))
534 |       (cond
535 |        ((eq type 'cross) (igo-svg-cross-mark parent x y nil board grid-interval))
536 |        ((eq type 'circle) (igo-svg-circle-mark parent x y nil board grid-interval))
537 |        ((eq type 'square) (igo-svg-square-mark parent x y nil board grid-interval))
538 |        ((eq type 'triangle) (igo-svg-triangle-mark parent x y nil board grid-interval))
539 |        ((eq type 'text) (igo-svg-text-at-intersection
540 |                          parent x y grid-interval
541 |                          (igo-mark-text mark)
542 |                          (igo-svg-intersection-text-color board x y)
543 |                          '(:class "mark")))
544 |        ))))
545 | 
546 | (defun igo-svg-remove-marks (svg)
547 |   (let ((parent (igo-svg-overlays-group svg)))
548 |     (dolist (node (dom-by-class parent "^mark$"))
549 |       (dom-remove-node parent node))))
550 | 
551 | 
552 | ;;
553 | ;; SVG DOM Utilities
554 | ;;
555 | 
556 | (defun igo--svg-gradient (svg id type stops &rest args)
557 |   "Instead of svg-gradient. svg-gradient not support additional
558 | attributes(cx, cy, fx, fy, r, etc...)"
559 |   (svg--def
560 |    svg
561 |    (apply
562 |     'dom-node
563 |     (if (eq type 'linear)
564 | 	'linearGradient
565 |       'radialGradient)
566 |     `((id . ,id)
567 |       ,@(svg--arguments svg args))
568 |     (mapcar
569 |      (lambda (stop)
570 |        (dom-node 'stop `((offset . ,(format "%s%%" (car stop)))
571 | 			 (stop-color . ,(cdr stop)))))
572 |      stops))))
573 | 
574 | 
575 | 
576 | (provide 'igo-view)
577 | ;;; igo-view.el ends here
578 | 


--------------------------------------------------------------------------------
/igo-model.el:
--------------------------------------------------------------------------------
   1 | ;;; igo-model.el --- Igo Game Model                  -*- lexical-binding: t; -*-
   2 | 
   3 | ;; Copyright (C) 2020 AKIYAMA Kouhei
   4 | 
   5 | ;; Author: AKIYAMA Kouhei
   6 | ;; Keywords: games
   7 | 
   8 | ;; This program is free software; you can redistribute it and/or modify
   9 | ;; it under the terms of the GNU General Public License as published by
  10 | ;; the Free Software Foundation, either version 3 of the License, or
  11 | ;; (at your option) any later version.
  12 | 
  13 | ;; This program is distributed in the hope that it will be useful,
  14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 | ;; GNU General Public License for more details.
  17 | 
  18 | ;; You should have received a copy of the GNU General Public License
  19 | ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
  20 | 
  21 | ;;; Commentary:
  22 | 
  23 | ;; This file contains data structures for representing and processing Go games.
  24 | ;;
  25 | ;; - Position & Move
  26 | ;; - Color & Empty (Intersection State)
  27 | ;; - Board (W, H, Intersections, Turn, Prisoners, Ko-Position)
  28 | ;; - Board Changes (Used in undo move and setup node)
  29 | ;; - Node (Game Tree)
  30 | ;; - Game (Board, Game Tree, Undo Stack)
  31 | ;;
  32 | ;; https://en.wikipedia.org/wiki/Rules_of_Go
  33 | 
  34 | ;;; Code:
  35 | 
  36 | (require 'cl-lib)
  37 | (require 'igo-sgf-parser)
  38 | 
  39 | (defgroup el-igo nil
  40 |   "Go Game Editor"
  41 |   :prefix "igo-"
  42 |   :group 'games)
  43 | 
  44 | ;;
  45 | ;; Position & Move
  46 | ;;
  47 | 
  48 | ;; Position
  49 | (defconst igo-npos -1) ;;same as nmove
  50 | (defun igo-npos-p (pos) (= pos igo-npos))
  51 | (defun igo-pos-on-board-p (move-or-pos &optional w h)
  52 |   (and
  53 |    (>= move-or-pos 0)
  54 |    (or (null w) (null h) (< move-or-pos (* w h)))))
  55 | 
  56 | (defun igo-xy-to-pos (x y w) (+ x (* y w)))
  57 | (defun igo-pos-to-x (pos w) (% pos w))
  58 | (defun igo-pos-to-y (pos w) (/ pos w))
  59 | 
  60 | ;; Move (Placement(Position), Pass, Resign)
  61 | (defconst igo-nmove -1) ;;same as npos
  62 | (defconst igo-pass -2)
  63 | (defconst igo-resign -3)
  64 | (defun igo-nmove-p (move) (= move igo-nmove))
  65 | (defun igo-pass-p (move) (= move igo-pass))
  66 | (defun igo-resign-p (move) (= move igo-resign))
  67 | (defun igo-placement-p (move) (igo-pos-on-board-p move))
  68 | (defun igo-move-string (move &optional board)
  69 |   (cond
  70 |    ((igo-pass-p move) "Pass")
  71 |    ((igo-resign-p move) "Resign")
  72 |    ((igo-placement-p move)
  73 |     (if board
  74 |         (format "%s %s"
  75 |                 (1+ (igo-board-pos-to-x board move))
  76 |                 (1+ (igo-board-pos-to-y board move)))
  77 |       (format "%s" move)))
  78 |    (t "Not Move")))
  79 | 
  80 | ;;
  81 | ;; Color & Empty (Intersection State)
  82 | ;;
  83 | 
  84 | (defun igo-empty-p (obj) (eq obj 'empty))
  85 | (defun igo-black-p (obj) (eq obj 'black))
  86 | (defun igo-white-p (obj) (eq obj 'white))
  87 | 
  88 | (defun igo-intersection-state-p (obj)
  89 |   (or (eq obj 'empty) (eq obj 'black) (eq obj 'white)))
  90 | (defun igo-not-intersection-state-p (obj)
  91 |   (not (igo-intersection-state-p obj)))
  92 | (defun igo-same-intersection-state-p (obj1 obj2)
  93 |   (eq obj1 obj2))
  94 | (defun igo-diff-intersection-state-p (obj1 obj2)
  95 |   (not (eq obj1 obj2)))
  96 | 
  97 | (defun igo-color-p (obj) (or (eq obj 'black) (eq obj 'white)))
  98 | (defun igo-same-color-p (obj1 obj2) (eq obj1 obj2))
  99 | (defun igo-diff-color-p (obj1 obj2) (not (eq obj1 obj2)))
 100 | 
 101 | (defun igo-opposite-color (color)
 102 |   (cond ((eq color 'black) 'white)
 103 |         ((eq color 'white) 'black)
 104 |         (t color)))
 105 | 
 106 | 
 107 | ;;
 108 | ;; Board
 109 | ;;
 110 | 
 111 | (defvar igo-board-default-w 9)
 112 | (defvar igo-board-default-h 9)
 113 | 
 114 | (defun igo-board (w h &optional intersections turn prisoners ko-pos)
 115 |   (if (null w) (setq w igo-board-default-w)
 116 |     (igo-board-validate-w w))
 117 |   (if (null h) (setq h igo-board-default-h)
 118 |     (igo-board-validate-h h))
 119 |   (if (null intersections) (setq intersections (make-vector (* w h) 'empty))
 120 |     (igo-board-validate-intersections intersections w h))
 121 |   (if (null turn) (setq turn 'black)
 122 |     (igo-board-validate-turn turn))
 123 |   (if (null prisoners) (setq prisoners (cons 0 0))
 124 |     (igo-board-validate-prisoners prisoners))
 125 |   (if (null ko-pos) (setq ko-pos igo-npos)
 126 |     (igo-board-validate-ko-pos ko-pos))
 127 | 
 128 |   (vector w h intersections turn prisoners ko-pos))
 129 | 
 130 | (defconst igo-board--idx-w 0)
 131 | (defconst igo-board--idx-h 1)
 132 | (defconst igo-board--idx-intersections 2)
 133 | (defconst igo-board--idx-turn 3)
 134 | (defconst igo-board--idx-prisoners 4)
 135 | (defconst igo-board--idx-ko-pos 5)
 136 | 
 137 | (defun igo-board-clone (board)
 138 |   (let ((w (igo-board-w board))
 139 |         (h (igo-board-h board)))
 140 |     (igo-board
 141 |      w h
 142 |      (copy-sequence (igo-board-intersections board))
 143 |      (igo-board-turn board)
 144 |      (cons (igo-board-get-black-prisoners board)
 145 |            (igo-board-get-white-prisoners board))
 146 |      (igo-board-ko-pos board))))
 147 | 
 148 | (defun igo-board-validate-w (w)
 149 |   (if (not (and (integerp w) (> w 0) (<= w 52)))
 150 |       (error "Invalid argument igo-board w=%s" w)))
 151 | (defun igo-board-validate-h (h)
 152 |   (if (not (and (integerp h) (> h 0) (<= h 52)))
 153 |       (error "Invalid argument igo-board h=%s" h)))
 154 | (defun igo-board-validate-intersections (intersections w h)
 155 |   (if (not (and (vectorp intersections)
 156 |                 (= (length intersections) (* w h))
 157 |                 ;; all elements are valid
 158 |                 (null (seq-some #'igo-not-intersection-state-p intersections))))
 159 |       (error "Invalid argument igo-board intersections=%s" intersections)))
 160 | (defun igo-board-validate-turn (turn)
 161 |   (if (not (igo-color-p turn))
 162 |       (error "Invalid argument igo-board turn=%s" turn)))
 163 | (defun igo-board-validate-prisoners (prisoners)
 164 |   (if (not (and (consp prisoners)
 165 |                 (integerp (car prisoners))
 166 |                 (>= (car prisoners) 0)
 167 |                 (integerp (cdr prisoners))
 168 |                 (>= (cdr prisoners) 0)))
 169 |       (error "Invalid argument igo-board prisoners=%s" prisoners)))
 170 | (defun igo-board-validate-ko-pos (ko-pos)
 171 |   (if (not (and (integerp ko-pos)
 172 |                 (or (igo-pos-on-board-p ko-pos) (igo-npos-p ko-pos))))
 173 |       (error "Invalid argument igo-board ko-pos=%s" ko-pos)))
 174 | 
 175 | ;; Board - Basic Accessors
 176 | 
 177 | (defun igo-board-w (board) (aref board igo-board--idx-w))
 178 | (defun igo-board-h (board) (aref board igo-board--idx-h))
 179 | (defun igo-board-intersections (board) (aref board igo-board--idx-intersections))
 180 | (defun igo-board-turn (board) (aref board igo-board--idx-turn))
 181 | (defun igo-board-prisoners (board) (aref board igo-board--idx-prisoners))
 182 | (defun igo-board-ko-pos (board) (aref board igo-board--idx-ko-pos))
 183 | 
 184 | ;; Board - Intersections
 185 | 
 186 | (defun igo-board-intersection-count (board) (* (igo-board-w board)
 187 |                                                (igo-board-h board)))
 188 | (defun igo-board-get-at (board pos)
 189 |   (aref (igo-board-intersections board) pos))
 190 | (defun igo-board-set-at (board pos istate)
 191 |   (aset (igo-board-intersections board) pos istate))
 192 | (defun igo-board-empty-p-at (board pos)
 193 |   (and (not (igo-npos-p pos)) (igo-empty-p (igo-board-get-at board pos))))
 194 | (defun igo-board-remove-stone (board pos)
 195 |   (igo-board-set-at board pos 'empty))
 196 | 
 197 | ;; Board - Position(Index of Intersection)
 198 | 
 199 | (defun igo-board-xy-to-pos (board x y)
 200 |   (igo-xy-to-pos x y (igo-board-w board)))
 201 | (defun igo-board-pos-to-x (board pos)
 202 |   (igo-pos-to-x pos (igo-board-w board)))
 203 | (defun igo-board-pos-to-y (board pos)
 204 |   (igo-pos-to-y pos (igo-board-w board)))
 205 | (defun igo-board-pos-on-board-p (board pos)
 206 |   (and (integerp pos)
 207 |        (igo-pos-on-board-p pos (igo-board-w board) (igo-board-h board))))
 208 | (defun igo-board-left-of (board pos)
 209 |   (if (or (igo-npos-p pos) (= (% pos (igo-board-w board)) 0))
 210 |       igo-npos
 211 |     (1- pos)))
 212 | (defun igo-board-right-of (board pos)
 213 |   (if (or (igo-npos-p pos) (= (% (1+ pos) (igo-board-w board)) 0))
 214 |       igo-npos
 215 |     (1+ pos)))
 216 | (defun igo-board-above (board pos)
 217 |   (if (or (igo-npos-p pos) (< pos (igo-board-w board)))
 218 |       igo-npos
 219 |     (- pos (igo-board-w board))))
 220 | (defun igo-board-below (board pos)
 221 |   (let ((w (igo-board-w board))
 222 |         (h (igo-board-h board)))
 223 |     (if (or (igo-npos-p pos) (>= pos (* w (1- h))))
 224 |         igo-npos
 225 |       (+ pos w))))
 226 | 
 227 | ;; Board - Turn
 228 | 
 229 | (defun igo-board-set-turn (board color)
 230 |   (aset board igo-board--idx-turn color))
 231 | 
 232 | ;; Board - Prisoners
 233 | 
 234 | (defun igo-board-add-prisoners (board color num-prisoners)
 235 |   (let ((cell (igo-board-prisoners board)))
 236 |     (cond
 237 |      ((igo-black-p color) (setcar cell (+ (car cell) num-prisoners)))
 238 |      ((igo-white-p color) (setcdr cell (+ (cdr cell) num-prisoners))))))
 239 | (defun igo-board-remove-prisoners (board color num-prisoners)
 240 |   (igo-board-add-prisoners board color (- num-prisoners)))
 241 | (defun igo-board-get-prisoners (board color)
 242 |   (cond
 243 |    ((igo-black-p color) (car (igo-board-prisoners board)))
 244 |    ((igo-white-p color) (cdr (igo-board-prisoners board)))))
 245 | (defun igo-board-get-black-prisoners (board)
 246 |   (car (igo-board-prisoners board)))
 247 | (defun igo-board-get-white-prisoners (board)
 248 |   (cdr (igo-board-prisoners board)))
 249 | 
 250 | ;; Board - Move
 251 | 
 252 | (defun igo-board-pass (board &optional color allow-illegal-move)
 253 |   (if (null color) (setq color (igo-board-turn board)))
 254 | 
 255 |   ;; Check COLOR's pass is legal. If the pass is illegal, return nil
 256 |   (when (or allow-illegal-move
 257 |             (igo-same-color-p color (igo-board-turn board)))
 258 |     ;; legal
 259 |     (let ((ko-pos-old (igo-board-ko-pos board))
 260 |           (turn-old (igo-board-turn board)))
 261 |       (igo-board-set-ko-pos board igo-npos)
 262 |       (igo-board-set-turn board (igo-opposite-color color)) ;;not opposite turn, if allow illegal moves
 263 |       ;; return undo data
 264 |       (igo-board-changes nil nil nil ko-pos-old turn-old nil nil))))
 265 | 
 266 | (defun igo-board-put-stone (board pos &optional color allow-illegal-move)
 267 |   (if (null color) (setq color (igo-board-turn board)))
 268 | 
 269 |   ;; Check the move(pos, color) is legal. If the move is illegal, return nil
 270 |   (when (or allow-illegal-move
 271 |             (igo-board-legal-move-p board pos color))
 272 | 
 273 |     ;; Illegal move behavior is based on the SGF specification:
 274 |     ;;   SGF FF[5] - Move vs. Adding Stones
 275 |     ;;   https://www.red-bean.com/sgf/ff5/m_vs_ax.htm
 276 | 
 277 |     (let* (;; Put COLOR's stone at POS
 278 |            (istate-old (igo-board-get-at board pos))
 279 |            (_istate-new (igo-board-set-at board pos color))
 280 | 
 281 |            ;; Remove captured stones
 282 |            (removed-stones
 283 |             (append
 284 |              (igo-board-remove-string-if-surrounded board (igo-board-left-of board pos) color)
 285 |              (igo-board-remove-string-if-surrounded board (igo-board-right-of board pos) color)
 286 |              (igo-board-remove-string-if-surrounded board (igo-board-above board pos) color)
 287 |              (igo-board-remove-string-if-surrounded board (igo-board-below board pos) color)))
 288 |            ;; Remove suicide stones
 289 |            (suicide-stones
 290 |             (if allow-illegal-move
 291 |                 (igo-board-remove-string-if-surrounded board pos (igo-opposite-color color))))
 292 |            ;; Change ko-pos
 293 |            (ko-pos-old (igo-board-ko-pos board))
 294 |            (ko-pos-new (igo-board-get-new-ko-pos board pos color removed-stones))
 295 |            ;; Rotate turn
 296 |            (turn-old (igo-board-turn board))
 297 |            (turn-new (igo-opposite-color color)) ;;not opposite turn, if allow illegal moves
 298 |            )
 299 | 
 300 |       (igo-board-add-prisoners board color (length suicide-stones))
 301 |       (igo-board-add-prisoners board (igo-opposite-color color) (length removed-stones))
 302 |       (igo-board-set-ko-pos board ko-pos-new)
 303 |       (igo-board-set-turn board turn-new)
 304 |       ;; return undo data
 305 |       (igo-board-changes-make-move-undo color pos istate-old removed-stones suicide-stones ko-pos-old turn-old))))
 306 | 
 307 | (defun igo-board-legal-move-p (board pos color)
 308 |   (and
 309 |    board
 310 |    (igo-color-p color) ;; valid color
 311 |    (igo-board-pos-on-board-p board pos) ;; valid position
 312 |    (igo-same-color-p color (igo-board-turn board)) ;; color's turn
 313 |    (igo-board-empty-p-at board pos) ;; there is not already stone
 314 |    (not (igo-board-suicide-move-p board pos color)) ;; not suicide move
 315 |    (not (igo-board-ko-move-p board pos)) ;; pos is not ko
 316 |    ))
 317 | 
 318 | (defun igo-board-suicide-move-p (board pos color)
 319 |   ;; pre-conditions
 320 |   ;; - valid pos
 321 |   ;; - valid color
 322 |   ;; - pos is empty
 323 |   (if (or (igo-board-empty-p-at board (igo-board-left-of board pos))
 324 |           (igo-board-empty-p-at board (igo-board-right-of board pos))
 325 |           (igo-board-empty-p-at board (igo-board-above board pos))
 326 |           (igo-board-empty-p-at board (igo-board-below board pos)))
 327 |       nil
 328 |     ;; there are no empty point
 329 |     (let ((old-istate (igo-board-get-at board pos)))
 330 | 
 331 |       ;; put stone temporary
 332 |       (igo-board-set-at board pos color)
 333 | 
 334 |       (let ((suicide (and (igo-board-string-surrounded-p board pos)
 335 |                           (not (or (igo-board-string-surrounded-and-diff-color-p board (igo-board-left-of board pos) color)
 336 |                                    (igo-board-string-surrounded-and-diff-color-p board (igo-board-right-of board pos) color)
 337 |                                    (igo-board-string-surrounded-and-diff-color-p board (igo-board-above board pos) color)
 338 |                                    (igo-board-string-surrounded-and-diff-color-p board (igo-board-below board pos) color))))))
 339 | 
 340 |         ;; remove stone temporary puted
 341 |         (igo-board-set-at board pos old-istate)
 342 | 
 343 |         suicide))))
 344 | 
 345 | (defun igo-board-ko-move-p (board pos)
 346 |   (= pos (igo-board-ko-pos board)))
 347 | 
 348 | (defun igo-board-string-surrounded-p (board pos)
 349 |   "Return t if stones specified by pos are surrounded by any colors."
 350 |   (not (igo-board-find-liberty board pos)))
 351 | 
 352 | (defun igo-board-string-surrounded-and-diff-color-p (board pos color)
 353 |   (if (igo-board-pos-on-board-p board pos)
 354 |       (let ((pos-istate (igo-board-get-at board pos)))
 355 |         (and
 356 |          (not (igo-empty-p pos-istate)) ;; not empty
 357 |          (igo-diff-color-p pos-istate color) ;; different color
 358 |          (igo-board-string-surrounded-p board pos)))))
 359 | 
 360 | (defun igo-board-find-liberty (board pos)
 361 |   (if (igo-board-pos-on-board-p board pos)
 362 |       (let ((pos-istate (igo-board-get-at board pos)))
 363 |         (or (igo-empty-p pos-istate)
 364 |             (igo-board-find-liberty-recursive board pos pos-istate (make-vector (igo-board-intersection-count board) nil))))))
 365 | 
 366 | (defun igo-board-find-liberty-recursive (board pos color visited-arr)
 367 |   (if (or (igo-npos-p pos) ;; out of board
 368 |           (aref visited-arr pos)) ;; already visited
 369 |       nil
 370 |     (aset visited-arr pos t)
 371 |     (let ((istate (igo-board-get-at board pos)))
 372 |       (if (igo-empty-p istate)
 373 |           t
 374 |         (if (not (igo-same-color-p istate color))
 375 |             nil
 376 |           (or (igo-board-find-liberty-recursive board (igo-board-left-of board pos) color visited-arr)
 377 |               (igo-board-find-liberty-recursive board (igo-board-right-of board pos) color visited-arr)
 378 |               (igo-board-find-liberty-recursive board (igo-board-above board pos) color visited-arr)
 379 |               (igo-board-find-liberty-recursive board (igo-board-below board pos) color visited-arr)))))))
 380 | 
 381 | (defun igo-board-remove-string-if-surrounded (board pos turn)
 382 |   (if (igo-npos-p pos)
 383 |       nil
 384 |     (let ((istate (igo-board-get-at board pos)))
 385 |       (if (or (igo-empty-p istate) ;; empty
 386 |               (igo-same-color-p istate turn) ;; this turn's color
 387 |               (not (igo-board-string-surrounded-p board pos))) ;;not surrounded
 388 |           nil
 389 |         (igo-board-remove-string board pos istate)))))
 390 | 
 391 | (defun igo-board-remove-string (board pos color)
 392 |   (if (or (igo-npos-p pos) ;; out of board
 393 |           (not (igo-same-color-p (igo-board-get-at board pos) color))) ;; color changed
 394 |       nil
 395 |     (igo-board-remove-stone board pos)
 396 |     (append
 397 |      (list pos)
 398 |      (igo-board-remove-string board (igo-board-left-of board pos) color)
 399 |      (igo-board-remove-string board (igo-board-right-of board pos) color)
 400 |      (igo-board-remove-string board (igo-board-above board pos) color)
 401 |      (igo-board-remove-string board (igo-board-below board pos) color))))
 402 | 
 403 | ;; Board - ko-pos
 404 | 
 405 | (defun igo-board-set-ko-pos (board ko-pos)
 406 |   (aset board igo-board--idx-ko-pos ko-pos))
 407 | 
 408 | (defun igo-board-get-new-ko-pos (board pos color removed-stones)
 409 |   (if (or (igo-npos-p pos)
 410 |           (igo-empty-p color)
 411 |           (not (= (length removed-stones) 1))
 412 |           (not (igo-same-color-p (igo-board-get-at board pos) color)))
 413 |       igo-npos
 414 | 
 415 |     (let ((num-empty-or-same-color 0)
 416 |           (pos-empty-or-same-color igo-npos))
 417 |       (dolist (neighbor-pos (list (igo-board-left-of board pos)
 418 |                                   (igo-board-right-of board pos)
 419 |                                   (igo-board-above board pos)
 420 |                                   (igo-board-below board pos)))
 421 |         (if (not (igo-npos-p neighbor-pos))
 422 |             (let ((neighbor-istate (igo-board-get-at board neighbor-pos)))
 423 |               (when (or (igo-empty-p neighbor-istate) (igo-same-color-p neighbor-istate color))
 424 |                 (setq num-empty-or-same-color (1+ num-empty-or-same-color))
 425 |                 (setq pos-empty-or-same-color neighbor-pos)))))
 426 | 
 427 |       (if (= num-empty-or-same-color 1)
 428 |           pos-empty-or-same-color
 429 |         igo-npos))))
 430 | 
 431 | 
 432 | ;;
 433 | ;; Board Changes
 434 | ;;
 435 | 
 436 | (defun igo-board-changes (black white empty ko-pos turn black-prisoners white-prisoners)
 437 |   (vector (list black white empty) ko-pos turn black-prisoners white-prisoners))
 438 | 
 439 | ;; Board Changes - Basic Accessors
 440 | 
 441 | (defun igo-board-changes-pos-list-for-each-istate (changes) (aref changes 0))
 442 | (defun igo-board-changes-ko-pos (changes) (if changes (aref changes 1)))
 443 | (defun igo-board-changes-turn (changes) (if changes (aref changes 2)))
 444 | (defun igo-board-changes-black-prisoners (changes) (if changes (aref changes 3)))
 445 | (defun igo-board-changes-white-prisoners (changes) (if changes (aref changes 4)))
 446 | 
 447 | (defun igo-board-changes-turn-set (changes turn)
 448 |   (if changes
 449 |       (aset changes 2 turn)))
 450 | 
 451 | ;; Board Changes - Predicate
 452 | 
 453 | (defun igo-board-changes-empty-p (changes)
 454 |   (and
 455 |    (null (igo-board-changes-black changes))
 456 |    (null (igo-board-changes-white changes))
 457 |    (null (igo-board-changes-empty changes))
 458 |    (null (igo-board-changes-ko-pos changes))
 459 |    (null (igo-board-changes-turn changes))
 460 |    (null (igo-board-changes-black-prisoners changes))
 461 |    (null (igo-board-changes-white-prisoners changes))))
 462 | 
 463 | ;; Board Changes - Apply Changes
 464 | 
 465 | (defun igo-board-changes-apply (changes board)
 466 |   (when (and changes board)
 467 |     ;; Intersection States(Black Stones, White Stones, Empty Intersections)
 468 |     (igo-board-changes-apply-intersections
 469 |      (igo-board-changes-black changes) 'black board)
 470 |     (igo-board-changes-apply-intersections
 471 |      (igo-board-changes-white changes) 'white board)
 472 |     (igo-board-changes-apply-intersections
 473 |      (igo-board-changes-empty changes) 'empty board)
 474 | 
 475 |     (let ((ko-pos (igo-board-changes-ko-pos changes))
 476 |           (turn (igo-board-changes-turn changes))
 477 |           (black-prisoners (igo-board-changes-black-prisoners changes))
 478 |           (white-prisoners (igo-board-changes-white-prisoners changes)))
 479 | 
 480 |       (if (integerp ko-pos) (igo-board-set-ko-pos board ko-pos))
 481 |       (if (igo-color-p turn) (igo-board-set-turn board turn))
 482 |       (if (integerp black-prisoners) (igo-board-add-prisoners board 'black black-prisoners))
 483 |       (if (integerp white-prisoners) (igo-board-add-prisoners board 'white white-prisoners))
 484 |       )))
 485 | 
 486 | (defun igo-board-changes-apply-intersections (positions new-istate board)
 487 |   ;; ensure list
 488 |   (if (integerp positions)
 489 |       (setq positions (list positions)))
 490 | 
 491 |   (if (and board
 492 |            (igo-intersection-state-p new-istate)
 493 |            (listp positions))
 494 |       (dolist (pos positions)
 495 |         (if (and (integerp pos) (igo-board-pos-on-board-p board pos))
 496 |             (igo-board-set-at board pos new-istate)))))
 497 | 
 498 | ;; Board Changes - List of Intersection Positions
 499 | 
 500 | (defun igo-board-changes-black (changes)
 501 |   (nth 0 (igo-board-changes-pos-list-for-each-istate changes)))
 502 | (defun igo-board-changes-white (changes)
 503 |   (nth 1 (igo-board-changes-pos-list-for-each-istate changes)))
 504 | (defun igo-board-changes-empty (changes)
 505 |   (nth 2 (igo-board-changes-pos-list-for-each-istate changes)))
 506 | 
 507 | (defun igo-board-changes-istate-index (istate)
 508 |   (cond
 509 |    ((igo-black-p istate) 0)
 510 |    ((igo-white-p istate) 1)
 511 |    ((igo-empty-p istate) 2)))
 512 | 
 513 | (defun igo-board-changes-istate-list ()
 514 |   '(black white empty))
 515 | 
 516 | (defun igo-board-changes-pos-list-cell (changes istate)
 517 |   (nthcdr (igo-board-changes-istate-index istate)
 518 |           (igo-board-changes-pos-list-for-each-istate changes)))
 519 | 
 520 | (defun igo-board-changes-pos-list (changes istate)
 521 |   (car (igo-board-changes-pos-list-cell changes istate)))
 522 | 
 523 | ;; Board Changes - Intersection State
 524 | 
 525 | (defun igo--find-previous-of (pred elements)
 526 |   "Return the cell before the first element in ELEMENTS where (PRED
 527 | element) is non-nil."
 528 |   (let (prev-cell)
 529 |     (while (and elements (not (funcall pred (car elements))))
 530 |       (setq prev-cell elements)
 531 |       (setq elements (cdr elements)))
 532 |     prev-cell))
 533 | 
 534 | (defun igo-board-changes-get-at (changes pos)
 535 |   "Return the changed state(\\='black, \\='white, \\='empty) of the
 536 | intersection specified by POS."
 537 |   (when changes
 538 |     (cond
 539 |      ((member pos (igo-board-changes-black changes)) 'black)
 540 |      ((member pos (igo-board-changes-white changes)) 'white)
 541 |      ((member pos (igo-board-changes-empty changes)) 'empty)
 542 |      (t nil))))
 543 | 
 544 | (defun igo-board-changes-delete-at (changes pos)
 545 |   (if changes
 546 |       ;; Remove POS in position list for each istate
 547 |       (let ((pos-list (igo-board-changes-pos-list-for-each-istate changes)))
 548 |         (while pos-list
 549 |           (setcar pos-list (delete pos (car pos-list)))
 550 |           (setq pos-list (cdr pos-list))))))
 551 | 
 552 | (defun igo-board-changes-set-at (changes pos istate)
 553 |   (when changes
 554 |     (igo-board-changes-delete-at changes pos)
 555 | 
 556 |     ;; Insert in ascending order by POS
 557 |     (let* ((cell (igo-board-changes-pos-list-cell changes istate))
 558 |            (insertion-point (igo--find-previous-of
 559 |                              (lambda (elem) (> elem pos))
 560 |                              (car cell))))
 561 |       (if insertion-point
 562 |           (setcdr insertion-point (cons pos (cdr insertion-point)))
 563 |         (setcar cell (cons pos (car cell)))))))
 564 | 
 565 | ;; TEST: igo-board-changes-set-at
 566 | ;; (let ((c (igo-board-changes '(1 3 5) '(2 4 6) '(8 10 12) nil nil nil nil)))
 567 | ;;   (igo-board-changes-set-at c 0 'white)
 568 | ;;   c)
 569 | ;; => [((1 3 5) (0 2 4 6) (8 10 12)) nil nil nil nil]
 570 | 
 571 | 
 572 | 
 573 | ;; BoardChange - Creation
 574 | 
 575 | (defun igo-board-changes-diff-board (to-board from-board)
 576 |   "Return a igo-board-changes that change from FROM-BOARD to TO-BOARD."
 577 |   (let ((pos-lists (igo-board-changes--diff-intersections to-board from-board)))
 578 |     (igo-board-changes
 579 |      (cdr (assq 'black pos-lists))
 580 |      (cdr (assq 'white pos-lists))
 581 |      (cdr (assq 'empty pos-lists))
 582 |      (igo-board-changes--diff-value
 583 |       to-board from-board 'igo-board-ko-pos '=)
 584 |      (igo-board-changes--diff-value
 585 |       to-board from-board 'igo-board-turn 'igo-same-color-p)
 586 |      (igo-board-changes--diff-integer-delta
 587 |       to-board from-board 'igo-board-get-black-prisoners)
 588 |      (igo-board-changes--diff-integer-delta
 589 |       to-board from-board 'igo-board-get-white-prisoners))))
 590 | 
 591 | (defun igo-board-changes--diff-intersections (to-board from-board)
 592 |   (if (or (/= (igo-board-w to-board) (igo-board-w from-board))
 593 |           (/= (igo-board-h to-board) (igo-board-h from-board)))
 594 |       (error "Board sizes not match"))
 595 |   (let ((pos-lists (list (cons 'black nil)
 596 |                          (cons 'white nil)
 597 |                          (cons 'empty nil)))
 598 |         (num-intersections (igo-board-intersection-count to-board)))
 599 |     (dotimes (pos num-intersections)
 600 |       (let ((to-istate (igo-board-get-at to-board pos))
 601 |             (from-istate (igo-board-get-at from-board pos)))
 602 |         (if (not (igo-same-intersection-state-p to-istate from-istate))
 603 |             (let ((pos-list (assq to-istate pos-lists)))
 604 |               (push pos (cdr pos-list))))))
 605 |     (dolist (cell pos-lists)
 606 |       (setcdr cell (nreverse (cdr cell))))
 607 |     pos-lists))
 608 | 
 609 | (defun igo-board-changes--diff-value (to-board from-board getter fun-equal)
 610 |   (let ((to-value (funcall getter to-board))
 611 |         (from-value (funcall getter from-board)))
 612 |     (if (not (funcall fun-equal to-value from-value)) to-value)))
 613 | 
 614 | (defun igo-board-changes--diff-integer-delta (to-board from-board getter)
 615 |   (let ((to-value (funcall getter to-board))
 616 |         (from-value (funcall getter from-board)))
 617 |     (if (/= to-value from-value)
 618 |         (- to-value from-value))))
 619 | 
 620 | (defun igo-board-changes-make-initial-board (board)
 621 |   "Return a igo-board-changes that create BOARD from empty board."
 622 |   (igo-board-changes-diff-board
 623 |    board
 624 |    (igo-board (igo-board-w board) (igo-board-h board))))
 625 | 
 626 | (defun igo-board-changes-make-move-undo
 627 |     (color pos istate-old removed-stones suicide-stones ko-pos-old turn-old)
 628 |   "Return a igo-board-changes that revert move."
 629 | 
 630 |   (let* (;; Calculate number of prisoners increased
 631 |          (num-removed-stones (length removed-stones))
 632 |          (num-suicide-stones (length suicide-stones))
 633 |          (num-black-prisoners
 634 |           (if (igo-black-p color) num-suicide-stones num-removed-stones))
 635 |          (num-white-prisoners
 636 |           (if (igo-white-p color) num-suicide-stones num-removed-stones))
 637 |          ;; Guess current istate at POS
 638 |          (istate-new (if (member pos suicide-stones) 'empty color))
 639 |          ;; Remove POS from SUICIDE-STONES
 640 |          (suicide-stones-without-pos (remove pos suicide-stones))
 641 |          ;; Make pos-list
 642 |          (black-pos-list
 643 |           (if (igo-black-p color) suicide-stones-without-pos removed-stones))
 644 |          (white-pos-list
 645 |           (if (igo-white-p color) suicide-stones-without-pos removed-stones))
 646 |          (empty-pos-list nil))
 647 | 
 648 |     ;; Restore istate of POS
 649 |     (if (not (igo-same-intersection-state-p istate-new istate-old))
 650 |         (cond
 651 |          ((igo-black-p istate-old) (push pos black-pos-list))
 652 |          ((igo-white-p istate-old) (push pos white-pos-list))
 653 |          ((igo-empty-p istate-old) (push pos empty-pos-list))))
 654 | 
 655 |     ;;@todo sort pos-list?
 656 | 
 657 |     (igo-board-changes
 658 |      black-pos-list
 659 |      white-pos-list
 660 |      empty-pos-list
 661 |      ko-pos-old
 662 |      turn-old ;; Not necessarily the same as COLOR if allow illegal moves
 663 |      (if (> num-black-prisoners 0) (- num-black-prisoners))
 664 |      (if (> num-white-prisoners 0) (- num-white-prisoners)))))
 665 | 
 666 | ;; TEST
 667 | ;; (igo-board-changes-make-changes-undo 
 668 | ;;  (igo-board-changes '(1 2 3) nil nil nil 'white 2 0)
 669 | ;;  (let ((board (igo-board 9 9))) (igo-board-put-stone board 2 'black) (igo-board-put-stone board 3 'white) board))
 670 | ;; => [(nil (3) (1)) nil black -2 nil]
 671 | 
 672 | (defun igo-board-changes-make-changes-undo (changes board)
 673 |   "Return a igo-board-change that revert CHANGES."
 674 |   (let ((to-board (igo-board-clone board)))
 675 |     (igo-board-changes-apply changes to-board)
 676 |     (igo-board-changes-diff-board board to-board)))
 677 | 
 678 | 
 679 | ;;
 680 | ;; Node
 681 | ;;
 682 | 
 683 | (defun igo-node (prev &optional move color)
 684 |   (vector
 685 |    prev ;;0:prev
 686 |    (or move igo-nmove) ;;1:move
 687 |    color ;;2:color
 688 |    nil ;;3:properties
 689 |    nil ;;4:next nodes
 690 |    nil ;;5:last-visited
 691 |    ))
 692 | 
 693 | (defconst igo-node--idx-prev 0)
 694 | (defconst igo-node--idx-move 1)
 695 | (defconst igo-node--idx-color 2)
 696 | (defconst igo-node--idx-properties 3)
 697 | (defconst igo-node--idx-next-nodes 4)
 698 | (defconst igo-node--idx-last-visited 5)
 699 | 
 700 | (defun igo-node-prev (node) (aref node igo-node--idx-prev))
 701 | (defun igo-node-move (node) (aref node igo-node--idx-move))
 702 | (defun igo-node-color (node) (aref node igo-node--idx-color))
 703 | (defun igo-node-properties (node) (aref node igo-node--idx-properties))
 704 | (defun igo-node-next-nodes (node) (aref node igo-node--idx-next-nodes))
 705 | (defun igo-node-last-visited (node) (aref node igo-node--idx-last-visited))
 706 | 
 707 | (defun igo-node-clone-new-frame (old-node new-prev)
 708 |   (list
 709 |    nil ;;0:new-next-nodes
 710 |    old-node ;;1:old-node
 711 |    (igo-node new-prev
 712 |              (igo-node-move old-node)
 713 |              (igo-node-color old-node));;2:new-node
 714 |    (igo-node-next-nodes old-node) ;;3:old-next-nodes
 715 |    ))
 716 | 
 717 | (defun igo-node-clone (top-node &optional top-new-prev)
 718 |   (let ((stack (list (igo-node-clone-new-frame top-node top-new-prev)))
 719 |         result)
 720 | 
 721 |     (while stack
 722 |       (let* ((frame (car stack))
 723 |              (new-next-nodes (nth 0 frame))
 724 |              (old-node (nth 1 frame))
 725 |              (new-node (nth 2 frame)))
 726 |         (cl-symbol-macrolet ((old-next-nodes (nth 3 frame)))
 727 |           (if old-next-nodes
 728 |               ;; Clone sub-nodes
 729 |               (push (igo-node-clone-new-frame (pop old-next-nodes) new-node) stack)
 730 | 
 731 |             ;; Set subnodes
 732 |             (aset new-node igo-node--idx-next-nodes
 733 |                   (nreverse new-next-nodes))
 734 |             ;; Clone last-visited
 735 |             (when-let ((index (seq-position (igo-node-next-nodes old-node)
 736 |                                             (igo-node-last-visited old-node) #'eq)))
 737 |               (aset new-node igo-node--idx-last-visited
 738 |                     (nth index (igo-node-next-nodes new-node))))
 739 |             ;; Clone properties
 740 |             (aset new-node igo-node--idx-properties
 741 |                   (igo-node-clone-properties (igo-node-properties old-node)))
 742 |             ;; Return a new node
 743 |             (pop stack)
 744 |             (if stack
 745 |                 (push new-node (nth 0 (car stack))) ;;callee's new-next-nodes
 746 |               (setq result new-node))))))
 747 |     result))
 748 | 
 749 | ;; 再帰版 (max-lisp-eval-depth制限に引っかかる)
 750 | ;; (defun igo-node-clone (node &optional new-prev)
 751 | ;;   (let ((new-node (igo-node new-prev
 752 | ;;                             (igo-node-move node)
 753 | ;;                             (igo-node-color node))))
 754 | ;;     ;; clone properties
 755 | ;;     (aset new-node igo-node--idx-properties
 756 | ;;           (igo-node-clone-properties (igo-node-properties node)))
 757 | ;;     ;; clone next-nodes
 758 | ;;     (aset new-node igo-node--idx-next-nodes
 759 | ;;           (igo-node-clone-next-nodes (igo-node-next-nodes node) new-node))
 760 | ;;     ;; clone last-visited
 761 | ;;     (if-let ((index (seq-position (igo-node-next-nodes node)
 762 | ;;                                   (igo-node-last-visited node) #'eq)))
 763 | ;;         (aset new-node igo-node--idx-last-visited
 764 | ;;               (nth index (igo-node-next-nodes new-node))))
 765 | ;;     new-node))
 766 | ;;
 767 | ;; (defun igo-node-clone-next-nodes (next-nodes new-prev)
 768 | ;;   (mapcar (lambda (next)
 769 | ;;             (igo-node-clone next new-prev))
 770 | ;;           next-nodes))
 771 | 
 772 | (defun igo-node-clone-properties (props)
 773 |   ;; Copy properties
 774 |   ;; - ATOM (symbol, string, number)
 775 |   ;; - list
 776 |   ;; - vector
 777 |   ;; - igo-board-changes (vector)
 778 |   (copy-tree props))
 779 | 
 780 | 
 781 | ;; Node - Node Type(Setup or Move(Resign, Pass, Placement))
 782 | 
 783 | (defun igo-node-set-move-and-color (node move color)
 784 |   (aset node igo-node--idx-move move)
 785 |   (aset node igo-node--idx-color color))
 786 | (defun igo-node-setup-p (node) (igo-nmove-p (igo-node-move node)))
 787 | (defun igo-node-move-p (node) (not (igo-nmove-p (igo-node-move node))))
 788 | (defun igo-node-pass-p (node) (igo-pass-p (igo-node-move node)))
 789 | (defun igo-node-resign-p (node) (igo-resign-p (igo-node-move node)))
 790 | (defun igo-node-placement-p (node) (igo-placement-p (igo-node-move node)))
 791 | 
 792 | (defun igo-node-second-consecutive-pass-p (node)
 793 |   (and
 794 |    (igo-node-pass-p node)
 795 |    (let ((prev-node (igo-node-previous-move node)))
 796 |      (and prev-node
 797 |           (not (igo-same-color-p (igo-node-color node)
 798 |                                  (igo-node-color prev-node)))
 799 |           (igo-node-pass-p prev-node)))))
 800 | 
 801 | ;; Node - Make Root
 802 | 
 803 | (defun igo-node-make-root (node board)
 804 |   (when (not (igo-node-root-p node))
 805 |     (let ((old-root-node (igo-node-get-root node)))
 806 |       ;; Copy game info properties from old-root
 807 |       ;; (if igo-sgf-parser loaded)
 808 |       (if (boundp 'igo-sgf-game-info-properties)
 809 |           (dolist (prop igo-sgf-game-info-properties)
 810 |             (let* ((prop-id (igo-sgf-game-info-prop-id prop))
 811 |                    (value (igo-node-get-sgf-property old-root-node prop-id)))
 812 |               (if value
 813 |                   (igo-node-set-sgf-property node prop-id value)))))
 814 |       ;; Set move number property
 815 |       (if (null (igo-node-get-move-number-property node))
 816 |           (igo-node-set-move-number-property
 817 |            node
 818 |            (igo-node-move-number node)))
 819 |       ;; Unlink previous node
 820 |       (aset node igo-node--idx-prev nil)
 821 |       ;; Clear move (indicate this node is a setup node)
 822 |       (igo-node-set-move-and-color node igo-nmove nil)
 823 |       ;; Set setup property to reproduce BOARD (discard old setup if it exists)
 824 |       (igo-node-set-setup-property
 825 |        node
 826 |        (igo-board-changes-make-initial-board board))
 827 |       ))
 828 |   node)
 829 | 
 830 | ;; Node - Previous Node(Parent)
 831 | 
 832 | (defun igo-node-root-p (node)
 833 |   (null (igo-node-prev node)))
 834 | 
 835 | (defun igo-node-get-root (node)
 836 |   (let (prev)
 837 |     (while (setq prev (igo-node-prev node))
 838 |       (setq node prev))
 839 |     node))
 840 | 
 841 | (defun igo-node-previous-move (node)
 842 |   "Return previous move of NODE. Skip setup nodes."
 843 |   (setq node (igo-node-prev node))
 844 |   (while (and node (not (igo-node-move-p node)))
 845 |     (setq node (igo-node-prev node)))
 846 |   node)
 847 | 
 848 | (defun igo-node-number-of-siblings (node)
 849 |   "Return number of sibling nodes (including NODE itself)."
 850 |   (let ((prev (igo-node-prev node)))
 851 |     (if prev (length (igo-node-next-nodes prev))
 852 |       1)))
 853 | 
 854 | (defun igo-node-first-sibling-p (node)
 855 |   (let ((prev (igo-node-prev node)))
 856 |     (if prev (eq (car (igo-node-next-nodes prev)) node))))
 857 | 
 858 | (defun igo-node-last-sibling-p (node)
 859 |   (let ((prev (igo-node-prev node)))
 860 |     (if prev (eq (car (last (igo-node-next-nodes prev))) node))))
 861 | 
 862 | (defun igo-node-move-number (node)
 863 |   "Return the depth of NODE from the root node or previous MN
 864 | property, not include setup node."
 865 |   (let ((num 0) mn-prop)
 866 |     (while (and node (null (setq mn-prop (igo-node-get-move-number-property node))))
 867 |       (if (igo-node-move-p node)
 868 |           (setq num (1+ num)))
 869 |       (setq node (igo-node-prev node)))
 870 |     (+ (or mn-prop 0) num)))
 871 | 
 872 | (defun igo-node-depth (node)
 873 |   "Return the depth of NODE from the root node, including setup node."
 874 |   (let ((num 0))
 875 |     (while node
 876 |       (setq num (1+ num))
 877 |       (setq node (igo-node-prev node)))
 878 |     num))
 879 | 
 880 | (defun igo-node-next-color (node)
 881 |   (let (result)
 882 |     (while (and
 883 |             node
 884 |             (null
 885 |              (setq result
 886 |                    ;; opposite color or PL property
 887 |                    (if (igo-node-move-p node)
 888 |                        (igo-opposite-color (igo-node-color node))
 889 |                      (if-let ((changes (igo-node-get-setup-property node)))
 890 |                          (igo-board-changes-turn changes))))))
 891 |       (setq node (igo-node-prev node)))
 892 |     (or result 'black)))
 893 | 
 894 | (defun igo-node-path-from-root (node &optional fork-only)
 895 |   (let (dirs prev)
 896 |     (while (and node (setq prev (igo-node-prev node)))
 897 |       (if (or (not fork-only) (>= (length (igo-node-next-nodes prev)) 2))
 898 |           (push (seq-position (igo-node-next-nodes prev) node) dirs))
 899 |       (setq node prev))
 900 |     dirs))
 901 | 
 902 | (defun igo-node-find-move-back (node move)
 903 |   (while (and node (not (= (igo-node-move node) move)))
 904 |     (setq node (igo-node-prev node)))
 905 |   node)
 906 | 
 907 | (defun igo-node-move-number-at (node pos)
 908 |   (igo-node-move-number (igo-node-find-move-back node pos)))
 909 | 
 910 | (defun igo-node-prev-nth (node n &optional clamp-p)
 911 |   (let (next)
 912 |     (while (and (> n 0) node)
 913 |       (setq next node)
 914 |       (setq node (igo-node-prev node))
 915 |       (setq n (1- n)))
 916 |     (if (and clamp-p (null node)) next node)))
 917 | 
 918 | (defun igo-node-ancestor-p (node ancestor)
 919 |   (igo-node-descendant-p ancestor node))
 920 | 
 921 | ;; Node - Next Nodes(Children)
 922 | 
 923 | (defun igo-node-set-last-visited (node next-node)
 924 |   ;; check next-node is in next-nodes
 925 |   (if (or (null next-node)
 926 |           (seq-find (lambda (n) (eq n next-node)) (igo-node-next-nodes node)))
 927 |       (aset node igo-node--idx-last-visited next-node)))
 928 | 
 929 | (defun igo-node-next-node-default (node)
 930 |   (if node
 931 |       (or
 932 |        ;; last visited node
 933 |        (igo-node-last-visited node)
 934 |        ;; no branch
 935 |        (let ((next-nodes (igo-node-next-nodes node)))
 936 |          (if (= (length next-nodes) 1)
 937 |              (car next-nodes))))))
 938 | 
 939 | (defun igo-node-find-next-by-move (node move color)
 940 |   "Return the node that matches MOVE and COLOR from the next nodes."
 941 |   (seq-find (lambda (next) (and (= (igo-node-move next) move)
 942 |                                 (or (null color)
 943 |                                     (igo-same-color-p (igo-node-color next)
 944 |                                                       color))))
 945 |             (igo-node-next-nodes node)))
 946 | 
 947 | (defun igo-node-get-next-setup-node (node index)
 948 |   (let ((next-nodes (igo-node-next-nodes node))
 949 |         result)
 950 |     (while (and next-nodes (null result))
 951 |       (if (igo-node-setup-p (car next-nodes))
 952 |           (if (= index 0)
 953 |               (setq result (car next-nodes))
 954 |             (setq index (1- index))))
 955 |       (setq next-nodes (cdr next-nodes)))
 956 |     result))
 957 | 
 958 | (defun igo-node-add-next-node (node next-node)
 959 |   (aset node igo-node--idx-next-nodes
 960 |         (nconc (igo-node-next-nodes node)
 961 |                (list next-node)))
 962 |   next-node)
 963 | 
 964 | (defun igo-node-create-next-node (node &optional move color)
 965 |   (if (null move) (setq move igo-nmove))
 966 | 
 967 |   ;; Create a new node, add to NODE, return new node.
 968 |   (igo-node-add-next-node node (igo-node node move color)))
 969 | 
 970 | (defun igo-node-delete-next (node target-node)
 971 |   ;; remove TARGET-NODE from next-nodes
 972 |   (aset node igo-node--idx-next-nodes
 973 |         (delq target-node (igo-node-next-nodes node)))
 974 |   ;; ensure last-visited does not point to NODE
 975 |   (if (eq target-node (igo-node-last-visited node))
 976 |       (igo-node-set-last-visited node (car (igo-node-next-nodes node)))))
 977 | 
 978 | (defun igo-node-find-by-path (node dirs &optional fork-only)
 979 |   (while (and node dirs)
 980 |     (let* ((next-nodes (igo-node-next-nodes node))
 981 |            (len-next-nodes (length next-nodes))
 982 |            (dir (if (or (not fork-only) (>= len-next-nodes 2))
 983 |                    (pop dirs)
 984 |                  0)))
 985 |       (if (and (>= dir 0) (< dir len-next-nodes))
 986 |           (setq node (nth dir next-nodes))
 987 |         (setq dirs nil)
 988 |         (setq node nil))))
 989 |   node)
 990 | 
 991 | (defun igo-node-find-by-queries (node queries board-w board-h)
 992 |   (while queries
 993 |     (let ((q (car queries)))
 994 |       (cond
 995 |        ;; integer : nth node(choose first variation)
 996 |        ((integerp q)
 997 |         (setq node (igo-node-nth node q t)))
 998 |        ((stringp q)
 999 |         (cond
1000 |          ;; "xx" : find point breadth-first
1001 |          ((string-match-p "^[a-zA-Z][a-zA-Z]$" q)
1002 |           (let* ((pos (igo-sgf-value-as-move (igo-sgf-make-prop-value "" 0 q 0) board-w board-h))
1003 |                  (target (igo-node-find-breadth-first node (lambda (node) (= (igo-node-move node) pos)))))
1004 |             (if target
1005 |                 (setq node target))))
1006 |          ;; "X" : find next fork
1007 |          ((string-match-p "^[A-Z]$" q)
1008 |           (let ((index (- (elt q 0) ?A))
1009 |                 (fork (igo-node-find-first-fork-or-last node)))
1010 |             (if (and fork (< index (length (igo-node-next-nodes fork))))
1011 |                 (setq node (nth index (igo-node-next-nodes fork))))))
1012 |          ;; "_" : first fork
1013 |          ((string= "_" q)
1014 |           (setq node (igo-node-find-first-fork-or-last node)))
1015 |          ;; "123" : nth node(choose first variation)
1016 |          ((string-match-p "^-?[0-9]+$" q)
1017 |           (setq node (igo-node-nth node (string-to-number q) t))))
1018 |         )))
1019 |     (setq queries (cdr queries)))
1020 |   node)
1021 | 
1022 | (defun igo-node-nth (node n &optional clamp-p)
1023 |   (if (>= n 0)
1024 |       (igo-node-next-nth node n clamp-p)
1025 |     (igo-node-prev-nth node (- n) clamp-p)))
1026 | 
1027 | (defun igo-node-next-nth (node n &optional clamp-p)
1028 |   (let (prev)
1029 |     (while (and (> n 0) node)
1030 |       (setq prev node)
1031 |       (setq node (car (igo-node-next-nodes node)))
1032 |       (setq n (1- n)))
1033 |     (if (and clamp-p (null node)) prev node)))
1034 | 
1035 | (defun igo-node-find-first-fork-or-last (node)
1036 |   (while (= (length (igo-node-next-nodes node)) 1)
1037 |     (setq node (car (igo-node-next-nodes node))))
1038 |   ;; (length (igo-node-next-nodes node)) is 0 or 2 or more
1039 |   node)
1040 | 
1041 | (defun igo-node-find-breadth-first (node pred)
1042 |   (let ((curr (list node))
1043 |         next
1044 |         result)
1045 |     (while curr
1046 |       (while (and curr (not (funcall pred (car curr))))
1047 |         (setq next (append next (igo-node-next-nodes (car curr))))
1048 |         (setq curr (cdr curr)))
1049 | 
1050 |       (if curr
1051 |           (progn
1052 |             (setq result (car curr))
1053 |             (setq curr nil))
1054 |         (setq curr next)
1055 |         (setq next nil)))
1056 |     result))
1057 | 
1058 | (defun igo-node-change-next-node-order(node index delta)
1059 |   (let* ((next-nodes (igo-node-next-nodes node))
1060 |          (size (length next-nodes))
1061 |          target-node)
1062 | 
1063 |     (cond
1064 |      ((vectorp index)
1065 |       (setq target-node index)
1066 |       (setq index (seq-position next-nodes index #'eq)))
1067 | 
1068 |      ((integerp index)
1069 |       (if (and (>= index 0) (< index size))
1070 |           (setq target-node (nth index next-nodes))
1071 |         ;; index out of range
1072 |         (setq index nil))))
1073 | 
1074 |     (when (integerp index)
1075 |       (let ((new-index (max 0 (min (1- size) (+ index delta)))))
1076 |         (when (/= new-index index)
1077 |           ;; Remove
1078 |           (if (= index 0)
1079 |               (setq next-nodes (cdr next-nodes))
1080 |             (let ((cell (nthcdr (1- index) next-nodes)))
1081 |               (setcdr cell (cddr cell))))
1082 |           ;; Insert
1083 |           (if (= new-index 0)
1084 |               (setq next-nodes (cons target-node next-nodes))
1085 |             (let ((cell (nthcdr (1- new-index) next-nodes)))
1086 |               (setcdr cell (cons target-node (cdr cell)))))
1087 |           (aset node igo-node--idx-next-nodes next-nodes)
1088 |           t)))))
1089 | 
1090 | (defun igo-node-descendant-p (node descendant)
1091 |   (cond
1092 |    ((null node) nil)
1093 |    ((null descendant) nil)
1094 |    ((eq node descendant) nil)
1095 |    (t
1096 |     (setq descendant (igo-node-prev descendant))
1097 |     (while (and descendant (not (eq descendant node)))
1098 |       (setq descendant (igo-node-prev descendant)))
1099 |     (not (null descendant)))))
1100 | 
1101 | ;; Node - Properties
1102 | 
1103 | (defun igo-node-set-property (node symbol value)
1104 |   (if (stringp symbol)
1105 |       (setq symbol (intern symbol)))
1106 |   (aset node igo-node--idx-properties
1107 |         (plist-put (igo-node-properties node) symbol value)))
1108 | 
1109 | (defun igo-node-get-property (node symbol &optional default)
1110 |   (if (stringp symbol)
1111 |       (setq symbol (intern symbol)))
1112 |   (or (plist-get (igo-node-properties node) symbol) default))
1113 | 
1114 | ;; Node - Properties - Move Number
1115 | 
1116 | (defun igo-node-get-move-number-property (node)
1117 |   (let ((str (car (igo-node-get-sgf-property node "MN"))))
1118 |     (if (stringp str)
1119 |         (string-to-number str))))
1120 | 
1121 | (defun igo-node-set-move-number-property (node number)
1122 |   (igo-node-set-sgf-property
1123 |    node "MN" (number-to-string number)))
1124 | 
1125 | (defun igo-node-delete-move-number-property (node)
1126 |   (igo-node-delete-sgf-property node "MN"))
1127 | 
1128 | 
1129 | ;; Node - Properties - Comment
1130 | 
1131 | (defun igo-node-get-comment (node)
1132 |   (if node
1133 |       (let ((value (car (igo-node-get-sgf-property node "C"))))
1134 |         (if value
1135 |             (igo-sgf-value-as-text value)))))
1136 | 
1137 | (defun igo-node-set-comment (node text)
1138 |   (if (and node (stringp text))
1139 |       (igo-node-set-sgf-property node "C" (list (igo-sgf-text text))))
1140 |   text)
1141 | 
1142 | (defun igo-node-delete-comment (node)
1143 |   (igo-node-delete-sgf-property node "C"))
1144 | 
1145 | ;; Node - Properties - Setup
1146 | 
1147 | (defun igo-node-set-setup-property (node board-changes)
1148 |   (igo-node-set-property node :setup board-changes))
1149 | 
1150 | (defun igo-node-get-setup-property (node)
1151 |   (igo-node-get-property node :setup))
1152 | 
1153 | ;; Node - Properties - Marks
1154 | 
1155 | (defun igo-mark (type pos &optional text)
1156 |   (if text
1157 |       (list type pos text)
1158 |     (list type pos)))
1159 | (defun igo-mark-type (mark) (nth 0 mark))
1160 | (defun igo-mark-pos (mark) (nth 1 mark))
1161 | (defun igo-mark-text (mark) (nth 2 mark))
1162 | 
1163 | (defun igo-node-set-marks-property (node marks)
1164 |   (igo-node-set-property node :marks marks))
1165 | 
1166 | (defun igo-node-get-marks-property (node)
1167 |   (igo-node-get-property node :marks))
1168 | 
1169 | (defun igo-node-delete-mark-at (node pos)
1170 |   (let* ((mark-list (igo-node-get-marks-property node))
1171 |          (prev (igo--find-previous-of
1172 |                 (lambda (mark) (= (igo-mark-pos mark) pos))
1173 |                 mark-list))
1174 |          (cell (if prev (cdr prev) mark-list)))
1175 |     (when cell
1176 |       ;; remove cell from list
1177 |       (if prev
1178 |           (setcdr prev (cddr prev))
1179 |         (igo-node-set-marks-property node (cdr mark-list)))
1180 |       ;; deleted
1181 |       t)))
1182 | 
1183 | (defun igo-node-set-mark-at (node pos type &optional text)
1184 |   (let* ((mark-list (igo-node-get-marks-property node))
1185 |          (prev (igo--find-previous-of
1186 |                 (lambda (mark) (= (igo-mark-pos mark) pos))
1187 |                 mark-list))
1188 |          (cell (if prev (cdr prev) mark-list)))
1189 | 
1190 |     (if (and cell
1191 |              (eq (igo-mark-type (car cell)) type)
1192 |              (equal (igo-mark-text (car cell)) text))
1193 |         ;; already exists
1194 |         nil
1195 |       ;; remove cell from list
1196 |       (if cell
1197 |           (if prev
1198 |               (setcdr prev (cddr prev))
1199 |             (setq mark-list (cdr mark-list))))
1200 |       ;; add new mark
1201 |       (push (igo-mark type pos text) mark-list)
1202 |       (igo-node-set-marks-property node mark-list)
1203 |       ;; changed
1204 |       t)))
1205 | 
1206 | ;; Node - Properties - SGF Location
1207 | ;; 1)
1208 | ;; tree-begin-opt=>                    <=tree-end-opt
1209 | ;;                 (;B[aa];W[bb];B[cc])
1210 | ;;      node-begin=>      <=node-end
1211 | ;; 2)
1212 | ;;            node-begin=>      <=node-end (tree-begin-opt = tree-end-opt = nil)
1213 | (defun igo-node-set-sgf-location (node tree-begin-opt node-begin node-end tree-end-opt)
1214 |   (igo-node-set-property
1215 |    node
1216 |    :sgf-location
1217 |    (if (and (null tree-begin-opt) (null tree-end-opt))
1218 |        (list node-begin node-end)
1219 |      (list node-begin node-end tree-begin-opt tree-end-opt))))
1220 | (defun igo-node-get-sgf-location (node)
1221 |   (igo-node-get-property node :sgf-location))
1222 | (defun igo-node-sgf-begin (node-loc) (nth 0 node-loc))
1223 | (defun igo-node-sgf-end (node-loc) (nth 1 node-loc))
1224 | (defun igo-node-sgf-tree-begin (node-loc) (nth 2 node-loc))
1225 | (defun igo-node-sgf-tree-end (node-loc) (nth 3 node-loc))
1226 | 
1227 | ;; Node - Properties - SGF Properties
1228 | 
1229 | (defun igo-node-get-sgf-properties (node)
1230 |   (igo-node-get-property node :sgf-properties))
1231 | 
1232 | (defun igo-node-set-sgf-property (node prop-id-str prop-values)
1233 |   (if (stringp prop-values) (setq prop-values (list prop-values)))
1234 |   (igo-node-set-property
1235 |    node
1236 |    :sgf-properties
1237 |    (plist-put (igo-node-get-sgf-properties node) prop-id-str prop-values
1238 |               #'equal)))
1239 | 
1240 | (defun igo-node-get-sgf-property (node prop-id-str)
1241 |   (plist-get (igo-node-get-sgf-properties node) prop-id-str #'equal))
1242 | 
1243 | (defun igo-node-delete-sgf-property (node prop-id-str)
1244 |   (let ((props (igo-node-get-sgf-properties node))
1245 |         prev-cell)
1246 |     (while (and props
1247 |                 (not (string= (car props) prop-id-str)))
1248 |       (setq prev-cell (cdr props))
1249 |       (setq props (cddr props)))
1250 | 
1251 |     (if props
1252 |         (if prev-cell
1253 |             (setcdr prev-cell (cddr props))
1254 |           (igo-node-set-property node :sgf-properties (cddr props))))))
1255 | 
1256 | 
1257 | ;;
1258 | ;; Game
1259 | ;;
1260 | 
1261 | (defun igo-game (&optional w h game-tree)
1262 |   (let* ((root-node (or game-tree
1263 |                         (igo-node nil)))
1264 |          (board (igo-board w h)))
1265 | 
1266 |     ;; Apply root setup to board
1267 |     (if game-tree
1268 |         (igo-board-changes-apply (igo-node-get-setup-property game-tree) board))
1269 | 
1270 |     (vector
1271 |      nil ;;finished
1272 |      board ;;board
1273 |      nil ;;undo stack
1274 |      root-node ;;game tree
1275 |      root-node ;;current node
1276 | )))
1277 | 
1278 | (defconst igo-game--idx-finished 0)
1279 | (defconst igo-game--idx-board 1)
1280 | (defconst igo-game--idx-undo 2)
1281 | (defconst igo-game--idx-root-node 3)
1282 | (defconst igo-game--idx-current-node 4)
1283 | 
1284 | ;; Game - Finished
1285 | 
1286 | (defun igo-game-finished-p (game)
1287 |   (aref game igo-game--idx-finished))
1288 | (defun igo-game-set-finished (game)
1289 |   (aset game igo-game--idx-finished t))
1290 | (defun igo-game-cancel-finish (game)
1291 |   (aset game igo-game--idx-finished nil))
1292 | 
1293 | ;; Game - Board
1294 | 
1295 | (defun igo-game-board (game)
1296 |   (aref game igo-game--idx-board))
1297 | (defun igo-game-turn (game)
1298 |   (igo-board-turn (igo-game-board game)))
1299 | (defun igo-game-set-turn (game color)
1300 |   (igo-board-set-turn (igo-game-board game) color))
1301 | (defun igo-game-get-prisoners (game color)
1302 |   (igo-board-get-prisoners (igo-game-board game) color))
1303 | 
1304 | ;; Game - Move
1305 | 
1306 | (defun igo-game-resign (game color &optional allow-illegal-move)
1307 |   (if (null color) (setq color (igo-game-turn game)))
1308 |   (when (and game
1309 |              (not (igo-game-finished-p game))
1310 |              (or allow-illegal-move
1311 |                  (igo-same-color-p color (igo-game-turn game))))
1312 |     ;;legal
1313 |     (igo-game-set-finished game)
1314 |     ;; push undo stack & game tree node
1315 |     (igo-game-push-undo game nil)
1316 |     (igo-game-push-node game igo-resign color)
1317 |     t))
1318 | 
1319 | (defun igo-game-pass (game color &optional allow-illegal-move)
1320 |   (when (and game
1321 |              (not (igo-game-finished-p game)))
1322 |     (let ((undo (igo-board-pass (igo-game-board game) color allow-illegal-move)))
1323 |       (when undo
1324 |         (igo-game-push-undo game undo)
1325 |         (igo-game-push-node game igo-pass color)
1326 |         (if (igo-node-second-consecutive-pass-p
1327 |              (igo-game-current-node game))
1328 |             (igo-game-set-finished game))
1329 |         t))))
1330 | 
1331 | (defun igo-game-put-stone (game pos color &optional allow-illegal-move)
1332 |   (when (and game
1333 |              (not (igo-game-finished-p game)))
1334 |     ;; not finished
1335 |     (let ((undo (igo-board-put-stone (igo-game-board game) pos color allow-illegal-move)))
1336 |       (when undo
1337 |         ;;legal move
1338 |         (igo-game-push-undo game undo)
1339 |         (igo-game-push-node game pos color)
1340 |         t))))
1341 | 
1342 | (defun igo-game-legal-move-p (game pos color)
1343 |   (and game
1344 |        (not (igo-game-finished-p game))
1345 |        (igo-board-legal-move-p (igo-game-board game) pos color)))
1346 | 
1347 | ;; Game - Setup Node
1348 | 
1349 | (defun igo-game-add-setup-node (game)
1350 |   "Add a setup node to the current node. And change the current node to it."
1351 |   (when game
1352 |     (igo-game-push-undo game (igo-board-changes nil nil nil nil nil nil nil))
1353 |     (igo-game-push-node game igo-nmove nil)
1354 |     t))
1355 | 
1356 | ;; Game - Undo
1357 | 
1358 | (defun igo-game-clear-undo (game)
1359 |   (aset game igo-game--idx-undo nil))
1360 | 
1361 | (defun igo-game-push-undo (game undo-change)
1362 |   (aset game igo-game--idx-undo
1363 |         (cons undo-change (aref game igo-game--idx-undo))))
1364 | 
1365 | (defun igo-game-pop-undo (game)
1366 |   (let ((top (aref game igo-game--idx-undo)))
1367 |     (aset game igo-game--idx-undo (cdr top))
1368 |     (car top)))
1369 | 
1370 | (defun igo-game-empty-undo-p (game)
1371 |   (null (aref game igo-game--idx-undo)))
1372 | 
1373 | (defun igo-game-get-undo-board-changes (game)
1374 |   (car (aref game igo-game--idx-undo)))
1375 | 
1376 | (defun igo-game-undo (game)
1377 |   ;; Move current-node to previous node
1378 |   (if (not (igo-node-root-p (igo-game-current-node game)))
1379 |       (let ((popped-curr-node (igo-game-pop-node game)))
1380 |         ;; Undo finish flag
1381 |         (if (or
1382 |              (igo-node-resign-p popped-curr-node)
1383 |              (igo-node-second-consecutive-pass-p popped-curr-node))
1384 |             (igo-game-cancel-finish game))))
1385 | 
1386 |   ;; Pop undo board change
1387 |   (if (not (igo-game-empty-undo-p game))
1388 |       (let ((undo (igo-game-pop-undo game)))
1389 |         ;; Undo board
1390 |         (if undo
1391 |             (igo-board-changes-apply undo (igo-game-board game)))
1392 |         )))
1393 | 
1394 | (defun igo-game-undo-all (game)
1395 |   (while (or (not (igo-node-root-p (igo-game-current-node game)))
1396 |              (not (igo-game-empty-undo-p game)))
1397 |     (igo-game-undo game)))
1398 | 
1399 | (defun igo-game-undo-to (game ancester)
1400 |   (while (and (or (not (igo-node-root-p (igo-game-current-node game)))
1401 |                   (not (igo-game-empty-undo-p game)))
1402 |               (not (eq (igo-game-current-node game) ancester)))
1403 |     (igo-game-undo game)))
1404 | 
1405 | ;; Game - Game Tree
1406 | 
1407 | (defun igo-game-root-node (game)
1408 |   (aref game igo-game--idx-root-node))
1409 | 
1410 | (defun igo-game-current-node (game)
1411 |   (aref game igo-game--idx-current-node))
1412 | 
1413 | (defun igo-game-push-node (game move color)
1414 |   (let* ((curr-node (igo-game-current-node game))
1415 |          (next-node (or
1416 |                      ;; If MOVE is nmove(setup node), always add a new node
1417 |                      (if (igo-nmove-p move) (igo-node-create-next-node curr-node igo-nmove nil))
1418 |                      ;; If already added MOVE, use it
1419 |                      (igo-node-find-next-by-move curr-node move color)
1420 |                      ;; add a new node
1421 |                      (igo-node-create-next-node curr-node move color))))
1422 |     (igo-game-select-next-node game next-node)))
1423 | 
1424 | (defun igo-game-select-next-node (game next-node)
1425 |   ;; @todo check current-node contains next-node
1426 |   (igo-node-set-last-visited (igo-game-current-node game) next-node)
1427 |   (aset game igo-game--idx-current-node next-node))
1428 | 
1429 | (defun igo-game-pop-node (game)
1430 |   "Set current node to previsous node. Return current node before
1431 | function was called."
1432 |   (let ((curr-node (igo-game-current-node game)))
1433 |     (if (not (igo-node-root-p curr-node))
1434 |         (progn
1435 |           (aset game igo-game--idx-current-node (igo-node-prev curr-node))
1436 |           curr-node)
1437 |       nil)))
1438 | 
1439 | (defun igo-game-make-current-node-root (game)
1440 |   (let ((curr-node (igo-game-current-node game)))
1441 |     ;; make current node root
1442 |     (igo-node-make-root curr-node (igo-game-board game))
1443 |     (aset game igo-game--idx-root-node curr-node)
1444 |     ;; clear undo stack
1445 |     (igo-game-clear-undo game)))
1446 | 
1447 | ;; Game - Redo
1448 | 
1449 | (defun igo-game-redo-all (game)
1450 |   (while (igo-game-redo game)))
1451 | 
1452 | (defun igo-game-redo (game)
1453 |   (let ((current-node (igo-game-current-node game)))
1454 |     (igo-game-apply-node
1455 |      game
1456 |      (igo-node-next-node-default current-node))))
1457 | 
1458 | (defun igo-game-apply-node (game next-node)
1459 |   (cond
1460 |    ((null next-node) nil)
1461 |    ((igo-node-pass-p next-node) (igo-game-pass game (igo-node-color next-node) t)) ;;allow illegal move
1462 |    ((igo-node-resign-p next-node) (igo-game-resign game (igo-node-color next-node) t)) ;;allow illegal move
1463 |    ((igo-node-placement-p next-node) (igo-game-put-stone game (igo-node-move next-node) (igo-node-color next-node) t)) ;;allow illegal move
1464 |    ((igo-node-setup-p next-node) ;; setup node
1465 |     ;; @todo check current-node contains next-node
1466 |     (let* ((change (igo-node-get-setup-property next-node))
1467 |            ;; Create undo data
1468 |            (undo-change (if change
1469 |                             (igo-board-changes-make-changes-undo
1470 |                              change (igo-game-board game)))))
1471 |       ;; apply change
1472 |       (if change
1473 |           (igo-board-changes-apply change (igo-game-board game)))
1474 | 
1475 |       ;; push undo
1476 |       (igo-game-push-undo game undo-change)
1477 |       ;; select next-node to current
1478 |       ;; (next-node is already added to current-node)
1479 |       (igo-game-select-next-node game next-node)
1480 |       t
1481 |       ))))
1482 | 
1483 | (defun igo-game-redo-by-path (game dirs)
1484 |   (let (next-node)
1485 |     (while (and dirs (setq next-node (nth (car dirs) (igo-node-next-nodes (igo-game-current-node game)))))
1486 |       (igo-game-apply-node game next-node)
1487 |       (setq dirs (cdr dirs)))))
1488 | 
1489 | (defun igo-game-redo-by-queries (game queries)
1490 |   (let* ((board (igo-game-board game))
1491 |          (target (igo-node-find-by-queries
1492 |                   (igo-game-root-node game)
1493 |                   queries
1494 |                   (igo-board-w board)
1495 |                   (igo-board-h board))))
1496 |     (if target
1497 |         (igo-game-redo-by-path game (igo-node-path-from-root target)))))
1498 | 
1499 | 
1500 | 
1501 | ;;
1502 | ;; SGF
1503 | ;;
1504 | 
1505 | ;; SGF - Get Value As Igo Model
1506 | 
1507 | (defun igo-sgf-value-as-point-pos (value w h)
1508 |   (let ((xy (igo-sgf-value-as-point-xy value w h)))
1509 |     (igo-xy-to-pos (car xy) (cdr xy) w)))
1510 | 
1511 | (defun igo-sgf-value-as-move (value w h)
1512 |   (let ((value-str (igo-sgf-prop-value-content value)))
1513 | 
1514 |     (cond
1515 |      ((null value-str)
1516 |       (error "%sNo property value for move"
1517 |              (igo-sgf-prop-value-location-string value)))
1518 |      ((or (string= value-str "") (and (= w 19)
1519 |                                       (= h 19)
1520 |                                       (string= value-str "tt")))
1521 |       igo-pass)
1522 |      (t
1523 |       (igo-sgf-value-as-point-pos value w h)))))
1524 | 
1525 | (defun igo-sgf-values-as-point-pos-list (values w h)
1526 |   "ex: (igo-sgf-values-as-point-pos-list
1527 |  (mapcar
1528 |   (lambda (v) (igo-sgf-make-prop-value \"\" nil v nil))
1529 |   \\='(\"aa\" \"ba\" \"ab\" \"ca:da\")) 9 9) => (0 1 9 2 3)"
1530 |   (cl-loop for value in values nconc
1531 |            ;; convert (x . y) to pos
1532 |            (seq-map
1533 |             (lambda (xy) (igo-xy-to-pos (car xy) (cdr xy) w))
1534 |             ;; expand compose
1535 |             (igo-sgf-expand-compressed-point value w h))))
1536 | 
1537 | 
1538 | ;; SGF - Convert to igo-node
1539 | 
1540 | (defun igo-sgf-root-tree-to-game-tree (sgf-root-tree)
1541 |   (let* ((root-node (igo-sgf-tree-root-node sgf-root-tree))
1542 |          (size (igo-sgf-node-get-board-size root-node))
1543 |          (w (car size))
1544 |          (h (cdr size)))
1545 |     (igo-sgf-node-check-game-type root-node)
1546 |     (igo-sgf-tree-to-game-tree sgf-root-tree w h 0 'black nil)))
1547 | 
1548 | (defun igo-sgf-tree-to-game-tree (sgf-tree w h move-number turn prev-node)
1549 |   "Convert parsed SGF syntax tree to igo-node."
1550 |   (when sgf-tree
1551 |     (let (seq-head-node)
1552 |       ;; Sequence
1553 |       (dolist (sgf-node (igo-sgf-tree-nodes sgf-tree))
1554 |         ;; Create a node
1555 |         (let ((curr-node (if prev-node (igo-node-create-next-node prev-node) (igo-node nil)))
1556 |               (moved nil)
1557 |               setup-black setup-white setup-empty setup-turn
1558 |               marks)
1559 |           ;; For each properties
1560 |           (dolist (sgf-prop (igo-sgf-node-properties sgf-node))
1561 |             (let ((prop-id (igo-sgf-property-id sgf-prop))
1562 |                   (prop-values (igo-sgf-property-values sgf-prop)))
1563 |               (cond
1564 |                ;; Move Properties
1565 |                ((or (string= prop-id "B") (string= prop-id "W"))
1566 |                 (if moved
1567 |                     (error "%sOnly one move in one node"
1568 |                            (igo-sgf-property-location-string sgf-prop)))
1569 |                 (let ((color (if (string= prop-id "B") 'black 'white))
1570 |                       (move (igo-sgf-value-as-move (car prop-values) w h)))
1571 |                   ;; (if (not (igo-same-color-p turn color))
1572 |                   ;;     (error "%sTurn mismatch"
1573 |                   ;;            (igo-sgf-property-location-string sgf-prop)))
1574 |                   (igo-sgf-property-ensure-one-value sgf-prop)
1575 |                   (if (and prev-node (igo-node-find-next-by-move prev-node move color))
1576 |                       (error "%sMove %s already exists"
1577 |                              (igo-sgf-property-location-string sgf-prop)
1578 |                              (igo-sgf-prop-value-content (car prop-values))))
1579 |                   (igo-node-set-move-and-color curr-node move color)
1580 |                   (setq move-number (1+ move-number))
1581 |                   (setq turn (igo-opposite-color color)) ;;not opposite turn, if allow illegal moves
1582 |                   (setq moved t)))
1583 |                ;; Setup Properties
1584 |                ((string= prop-id "AE")
1585 |                 (setq setup-empty (nconc setup-empty (igo-sgf-values-as-point-pos-list prop-values w h))))
1586 |                ((string= prop-id "AB")
1587 |                 (setq setup-black (nconc setup-black (igo-sgf-values-as-point-pos-list prop-values w h))))
1588 |                ((string= prop-id "AW")
1589 |                 (setq setup-white (nconc setup-white (igo-sgf-values-as-point-pos-list prop-values w h))))
1590 |                ((string= prop-id "PL")
1591 |                 (setq setup-turn (igo-sgf-value-as-color (car prop-values))))
1592 |                ;; Markup Properties
1593 |                ;; see: igo-svg-marks
1594 |                ((or (string= prop-id "MA")
1595 |                     (string= prop-id "CR")
1596 |                     (string= prop-id "SQ")
1597 |                     (string= prop-id "TR"))
1598 |                 (let ((type (cdr (assoc prop-id '(("MA" . cross)
1599 |                                                   ("CR" . circle)
1600 |                                                   ("SQ" . square)
1601 |                                                   ("TR" . triangle))))))
1602 |                   (setq marks
1603 |                         (nconc
1604 |                          marks
1605 |                          (mapcar
1606 |                           (lambda (pos) (igo-mark type pos))
1607 |                           (igo-sgf-values-as-point-pos-list prop-values w h))))))
1608 |                ((string= prop-id "LB")
1609 |                 (setq marks
1610 |                       (nconc
1611 |                        marks
1612 |                        (mapcar (lambda (value)
1613 |                                  (let* ((value-pos-text (igo-sgf-split-compose
1614 |                                                          value))
1615 |                                         (pos (igo-sgf-value-as-point-pos
1616 |                                               (car value-pos-text) w h))
1617 |                                         (text (igo-sgf-value-as-simple-text
1618 |                                                (cdr value-pos-text))))
1619 |                                    (igo-mark 'text pos text)))
1620 |                                prop-values))))
1621 |                ;; Discard FF, GM, SZ Property
1622 |                ((string= prop-id "FF") )
1623 |                ((string= prop-id "GM") )
1624 |                ((string= prop-id "SZ") )
1625 |                ;; Other SGF Properties
1626 |                (t (igo-node-set-sgf-property curr-node prop-id
1627 |                                              (mapcar #'igo-sgf-prop-value-content prop-values)))
1628 |                )))
1629 |           ;; Record setup property
1630 |           (when (or setup-black setup-white setup-empty setup-turn)
1631 |             (if moved
1632 |                 (error "%sSetup properties and move properties cannot be mixed in same node"
1633 |                        (igo-sgf-node-location-string sgf-node) ))
1634 |             (igo-node-set-setup-property curr-node (igo-board-changes setup-black setup-white setup-empty nil setup-turn nil nil))
1635 |             (if setup-turn (setq turn setup-turn)) )
1636 |           ;; Record markup property
1637 |           (if marks
1638 |               (igo-node-set-marks-property curr-node marks))
1639 |           ;; Record location
1640 |           (igo-node-set-sgf-location
1641 |            curr-node
1642 |            (if (null seq-head-node) (igo-sgf-tree-begin sgf-tree))
1643 |            (igo-sgf-node-begin sgf-node)
1644 |            (igo-sgf-node-end sgf-node)
1645 |            (if (null seq-head-node) (igo-sgf-tree-end sgf-tree)))
1646 |           ;; Record head of sequence
1647 |           (if (null seq-head-node) (setq seq-head-node curr-node))
1648 |           ;; Curr to Prev
1649 |           (setq prev-node curr-node)))
1650 |       ;; Subtrees
1651 |       (dolist (sgf-subtree (igo-sgf-tree-subtrees sgf-tree))
1652 |         (igo-sgf-tree-to-game-tree sgf-subtree w h move-number turn prev-node))
1653 | 
1654 |       seq-head-node)))
1655 | 
1656 | 
1657 | ;; SGF - To igo-game
1658 | 
1659 | (defun igo-game-from-sgf-buffer (begin end)
1660 |   (let* ((sgf-tree
1661 |           (save-excursion
1662 |             (save-restriction
1663 |               (narrow-to-region begin end)
1664 |               (goto-char (point-min))
1665 |               (let* ((strm (current-buffer))
1666 |                      (tree (igo-sgf-parse-tree strm)))
1667 |                 ;; Check text after end of SGF.
1668 |                 ;; If there is unnecessary text, it will disappear when editing.
1669 |                 (igo-sgf-skip-ws strm)
1670 |                 (if (igo-sgf-scan strm)
1671 |                     (igo-sgf-error strm "Unnecessary text after end of SGF."))
1672 |                 tree))))
1673 |          (game-tree (igo-sgf-root-tree-to-game-tree sgf-tree))
1674 |          (size (igo-sgf-node-get-board-size (igo-sgf-tree-root-node sgf-tree)))
1675 |          (game (igo-game (car size) (cdr size) game-tree)))
1676 | 
1677 |     game))
1678 | 
1679 | 
1680 | ;; SGF - Igo Model To SGF String
1681 | 
1682 | (defun igo-sgf-color (color)
1683 |   (cond
1684 |    ((igo-black-p color) "B")
1685 |    ((igo-white-p color) "W")
1686 |    (t (error "Cannot convert to SGF from invalid color %s" color))))
1687 | 
1688 | (defun igo-sgf-point-letter (n)
1689 |   (cond
1690 |    ((and (>= n 0) (<= n 25)) (+ ?a n))
1691 |    ((and (>= n 26) (<= n 51)) (+ ?A (- n 26)))
1692 |    (t (error "Cannot convert to SGF from invalid point number %s" n))))
1693 | 
1694 | (defun igo-sgf-point (pos w)
1695 |   (string
1696 |    (igo-sgf-point-letter (igo-pos-to-x pos w))
1697 |    (igo-sgf-point-letter (igo-pos-to-y pos w))))
1698 | 
1699 | (defun igo-sgf-point-list-compressed (pos-list w)
1700 |   (mapconcat
1701 |    (lambda (rect)
1702 |      (let ((lt (igo-sgf-point (igo-xy-to-pos (caar rect) (cdar rect) w) w));;left-top
1703 |            (rb (igo-sgf-point (igo-xy-to-pos (cadr rect) (cddr rect) w) w)));;right-bottom
1704 |        (if (string= lt rb)
1705 |            (concat "[" lt "]")
1706 |          (concat "[" lt ":" rb "]"))))
1707 |    (igo-sgf-pos-list-to-rect-list pos-list w)
1708 |    ""))
1709 | 
1710 | (defun igo-sgf-pos-list-to-rect-list (pos-list w)
1711 |   "Convert to position list to rectangle list.
1712 | 
1713 | ex: pos-list=(0 1 3 4 9 10), w=9 => ( ((0 . 0) . (1 . 1)) ((3 . 0) . (4 . 0)) )"
1714 |   (setq pos-list (seq-sort #'< pos-list))
1715 |   (let (prev-line
1716 |         curr-line
1717 |         (curr-y 0)
1718 |         fixed-rects)
1719 | 
1720 |     (while pos-list
1721 |       (let* ((pos (car pos-list))
1722 |              (y (igo-pos-to-y pos w))
1723 |              (left (igo-pos-to-x pos w))
1724 |              (right left))
1725 | 
1726 |         ;; Find continuous range on the same line
1727 |         ;; (left y)-(right y)
1728 |         (setq pos-list (cdr pos-list)) ;;next pos
1729 |         (while (and pos-list
1730 |                     (= (igo-pos-to-x (car pos-list) w) (1+ right)) ;;to-x(pos) == right+1
1731 |                     (= (igo-pos-to-y (car pos-list) w) y)) ;;to-y(pos) == y
1732 |           (setq right (1+ right))
1733 |           (setq pos-list (cdr pos-list))) ;;next pos
1734 | 
1735 |         ;; If line changed
1736 |         (when (/= y curr-y)
1737 |           ;; Fix all remaining rects in prev-line
1738 |           (setq fixed-rects (nconc fixed-rects prev-line))
1739 |           (setq prev-line nil)
1740 |           ;; Move curr-line to prev-line or fix rects in curr-line
1741 |           (if (= (1- y) curr-y) ;;curr-y is prev line
1742 |               ;; If 1 line increased, set curr-line to prev-line
1743 |               (setq prev-line (nreverse curr-line))
1744 |             ;; If 2 or more lines increased, fix all rects in curr-line
1745 |             (setq fixed-rects (nconc fixed-rects (nreverse curr-line))))
1746 |           ;; Clear curr line
1747 |           (setq curr-line nil)
1748 |           (setq curr-y y))
1749 | 
1750 |         ;; Fix rect (rect.left < left) in prev-line
1751 |         (while (and prev-line (< (caar (car prev-line)) left)) ;; prev-line->left < left
1752 |           (push (car prev-line) fixed-rects)
1753 |           (setq prev-line (cdr prev-line)))
1754 | 
1755 |         ;; Find a rect continue from prev-line to curr-line
1756 |         ;; same horizontal range (rect.left == left && rect.right == right)
1757 |         (if (and prev-line
1758 |                  (= (caar (car prev-line)) left) ;;prev-line->left == left
1759 |                  (= (cadr (car prev-line)) right)) ;;prev-line->right == right
1760 |             ;; If found, extend bottom
1761 |             (progn
1762 |               (setcdr (cdr (car prev-line)) y) ;;bottom=y
1763 |               (push (car prev-line) curr-line)
1764 |               (setq prev-line (cdr prev-line)))
1765 |           ;; If not found, create a new rect
1766 |           (push (cons (cons left y) (cons right y)) curr-line))
1767 | 
1768 |         ;; Fix rect (rect.left <= right) in prev-line
1769 |         (while (and prev-line (<= (caar (car prev-line)) right)) ;;prev-line->left <= right
1770 |           (push (car prev-line) fixed-rects)
1771 |           (setq prev-line (cdr prev-line)))))
1772 | 
1773 |     (setq fixed-rects (nconc fixed-rects prev-line (nreverse curr-line)))
1774 | 
1775 |     (sort fixed-rects
1776 |           (lambda (r1 r2) (< (igo-xy-to-pos (caar r1) (cdar r1) w)
1777 |                              (igo-xy-to-pos (caar r2) (cdar r2) w))))))
1778 | 
1779 | (defun igo-sgf-stringify-node-contents (node w h)
1780 |   (concat
1781 |    ";"
1782 | 
1783 |    ;; Root Properties
1784 |    (if (igo-node-root-p node)
1785 |        (concat "FF[4]GM[1]SZ[" (if (= w h) (number-to-string w) (format "%s:%s" w h)) "]"))
1786 | 
1787 |    ;; Move Property
1788 |    (let ((move (igo-node-move node))
1789 |          (color (igo-node-color node)))
1790 |      (cond
1791 |       ((igo-placement-p move) (concat (igo-sgf-color color) "[" (igo-sgf-point move w) "]" ))
1792 |       ((igo-pass-p move) (concat (igo-sgf-color color) "[]"))
1793 |       ((igo-resign-p move) nil))) ;;Ignore
1794 | 
1795 |    ;; Properties
1796 |    ;; (let ((prop (igo-node-properties node)))
1797 |    ;;   (while prop
1798 |    ;;     (let ((key (car prop)) (value (cadr prop)))
1799 |    ;;       (cond
1800 |    ;;        ((eq key ??))))))
1801 | 
1802 |    ;; Setup Properties
1803 |    (let ((board-change (igo-node-get-setup-property node)))
1804 |      (when board-change
1805 |        (let ((change-black (igo-board-changes-black board-change))
1806 |              (change-white (igo-board-changes-white board-change))
1807 |              (change-empty (igo-board-changes-empty board-change))
1808 |              (change-turn (igo-board-changes-turn board-change)))
1809 | 
1810 |          (concat
1811 |           (if change-black (concat "AB" (igo-sgf-point-list-compressed change-black w)))
1812 |           (if change-white (concat "AW" (igo-sgf-point-list-compressed change-white w)))
1813 |           (if change-empty (concat "AE" (igo-sgf-point-list-compressed change-empty w)))
1814 |           (if change-turn (concat "PL[" (igo-sgf-color change-turn) "]"))))))
1815 | 
1816 |    ;; Markup Properties
1817 |    (let ((marks (igo-node-get-marks-property node)))
1818 |      (when marks
1819 |        (concat
1820 |         ;; MA CR SQ TR
1821 |         (mapconcat
1822 |          (lambda (type.pid)
1823 |            (let ((values-str
1824 |                   (mapconcat
1825 |                    (lambda (m)
1826 |                      (if (eq (igo-mark-type m) (car type.pid))
1827 |                          (concat "[" (igo-sgf-point (igo-mark-pos m) w) "]")))
1828 |                    marks "")))
1829 |              (if (not (string= values-str ""))
1830 |                  (concat (cdr type.pid) values-str))))
1831 |          '((cross . "MA")
1832 |            (circle . "CR")
1833 |            (square . "SQ")
1834 |            (triangle . "TR"))
1835 |          "")
1836 |         ;; LB
1837 |         (let ((values-str
1838 |                (mapconcat
1839 |                 (lambda (m)
1840 |                   (if (eq (igo-mark-type m) 'text)
1841 |                       (concat "[" (igo-sgf-point (igo-mark-pos m) w) ":"
1842 |                               (igo-sgf-simple-text (igo-mark-text m) t) "]")))
1843 |                 marks "")))
1844 |           (if (not (string= values-str ""))
1845 |               (concat "LB" values-str)))
1846 |         )))
1847 | 
1848 |    ;; Other SGF Properties
1849 |    (let ((props (igo-node-get-sgf-properties node))
1850 |          strs)
1851 |      (while props
1852 |        (let ((key (car props)) (values (cadr props)))
1853 |          (push (concat key (mapconcat (lambda (v) (concat "[" v "]")) values "")) strs))
1854 |        (setq props (cddr props)))
1855 |      (apply #'concat (nreverse strs)))))
1856 | 
1857 | (defun igo-sgf-string-from-game-tree (top-node w h)
1858 |   ;; 再帰を使うと max-lisp-eval-depth 制限に引っかかる。
1859 |   ;; (バイトコンパイルすればひっかからない)
1860 |   (let ((node-stack (list top-node))
1861 |         result)
1862 |     (while node-stack
1863 |       (let ((node (pop node-stack)))
1864 |         (cond
1865 | 
1866 |          ((stringp node)
1867 |           (setq result (concat result node)))
1868 | 
1869 |          (node
1870 |           (when (or (igo-node-root-p node) ;; is root
1871 |                     (> (igo-node-number-of-siblings node) 1)) ;;has siblings
1872 |             (setq result (concat result "("))
1873 |             (push ")" node-stack))
1874 | 
1875 |           ;; Node contents
1876 |           (setq result (concat result (igo-sgf-stringify-node-contents node w h)))
1877 | 
1878 |           ;; Sub-Nodes
1879 |           (setq node-stack
1880 |                 (append (igo-node-next-nodes node) node-stack))))))
1881 |     result))
1882 | 
1883 | 
1884 | (provide 'igo-model)
1885 | ;;; igo-model.el ends here
1886 | 


--------------------------------------------------------------------------------