1 ;;; gnugo-imgen.el --- image generation -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
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.
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.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;; This file provides func `gnugo-imgen-create-xpms', suitable as
24 ;; value for `gnugo-xpms', and several variables to configure it:
26 ;; `gnugo-imgen-styles'
27 ;; `gnugo-imgen-style'
28 ;; `gnugo-imgen-sizing-function'
30 ;; There is also one command: `gnugo-imgen-clear-cache'.
38 (defvar gnugo-imgen-styles
40 :background "#FFFFC7C75252"
41 :grid-lines "#000000000000"
42 :circ-edges "#C6C6C3C3C6C6"
43 :white-fill "#FFFFFFFFFFFF"
44 :black-fill "#000000000000")
45 (ttn ; this guy must live in a cave
46 :background "#000000000000"
47 :grid-lines "#AAAA88885555"
48 :circ-edges "#888888888888"
49 :white-fill "#CCCCCCCCCCCC"
50 :black-fill "#444444444444"))
51 "Alist of styles suitable for `gnugo-imgen-create-xpms'.
52 The key is a symbol naming the style. The value is a plist.
53 Here is a list of recognized keywords and their meanings:
55 :background -- string that names a color in XPM format, such as
56 :grid-lines \"#000000000000\" or \"black\"; the special string
57 :circ-edges \"None\" makes that component transparent
61 All keywords are required and color values cannot be nil.
62 This restriction may be lifted in the future.")
64 (defvar gnugo-imgen-style nil
65 "Which style in `gnugo-imgen-styles' to use.
66 If nil, `gnugo-imgen-create-xpms' defaults to the first one.")
68 (defvar gnugo-imgen-sizing-function 'gnugo-imgen-fit-window-height
69 "Function to compute XPM image size from board size.
70 This is called with one arg, integer BOARD-SIZE, and should return
71 a number (float or integer), the number of pixels for the side of
72 a square position on the board. A value less than 8 is taken as 8.")
74 (defvar gnugo-imgen-cache (make-hash-table :test 'equal))
76 (defun gnugo-imgen-clear-cache ()
79 (clrhash gnugo-imgen-cache))
81 (defun gnugo-imgen-fit-window-height (board-size)
82 "Return the dimension (in pixels) of a square for BOARD-SIZE.
83 This uses the TOP and BOTTOM components as returned by
84 `window-inside-absolute-pixel-edges' and subtracts twice
85 the `frame-char-height' (to leave space for the grid)."
86 (cl-destructuring-bind (L top R bot)
87 (window-inside-absolute-pixel-edges)
89 (/ (float (- bot top (* 2 (frame-char-height))))
92 (defconst gnugo-imgen-palette '((32 . :background)
98 (defun gnugo-imgen-create-xpms-1 (square style)
99 (let* ((kws (mapcar 'cdr gnugo-imgen-palette))
100 (roles (mapcar 'symbol-name kws))
102 for px in (mapcar 'car gnugo-imgen-palette)
104 collect (cons px (format "s %s" role))))
106 with parms = (copy-sequence style)
109 collect (cons role (plist-get parms kw))))
112 (half-m1 (truncate (- half 0.5)))
113 (half-p1 (truncate (+ half 0.5)))
114 (background (make-vector 10 nil))
115 (foreground (make-vector 4 nil))
119 (xpm-generate-buffer (format "%d_%d" n square)
120 square square 1 palette))
121 (replace-from (buffer)
123 (insert-buffer-substring buffer)
125 (nine-from-four (N E W S)
137 (apply 'xpm-put-points px coord))))
140 for place from 1 to 9
143 ((vline (x y1 y2) (list (list x (cons y1 y2))))
144 (v-expand (y1 y2) (append (vline half-m1 y1 y2)
145 (vline half-p1 y1 y2)))
146 (hline (y x1 x2) (list (list (cons x1 x2) y)))
147 (h-expand (x1 x2) (append (hline half-m1 x1 x2)
148 (hline half-p1 x1 x2))))
149 (nine-from-four (v-expand 0 half-p1)
150 (h-expand half-m1 sq-m1)
152 (v-expand half-m1 sq-m1)))
153 do (aset background place
154 (with-current-buffer (workbuf place)
156 (mput-points ?. part))
161 (xpm-m2z-circle half half radius)))
163 with stone = (circ (truncate half))
164 with minim = (circ (/ square 9))
166 do (aset foreground n
167 (with-current-buffer (workbuf n)
176 (replace-from (aref foreground (1- n)))
178 (current-buffer))))))
181 ((ok (place type finish)
183 (delete-char (- (skip-chars-forward "^1-9")))
185 (insert (format "%s%d" type place))
186 (push (cons (cons type place)
189 :color-symbols resolved))
191 (with-current-buffer (workbuf 5)
192 (replace-from (aref background 5))
194 ;; yes, using an ellipse is bizarre; no, we don't mind;
195 ;; maybe, ‘artist-ellipse-generate-quadrant’ is stable.
196 (xpm-m2z-ellipse half half 4 4.5)
198 (ok 5 'hoshi 'xpm-finish))
200 for place from 1 to 9
201 for decor in (let ((friends (cons half-m1 half-p1)))
202 (nine-from-four (list friends 0)
205 (list friends sq-m1)))
206 do (with-current-buffer (aref background place)
207 (ok place 'empty 'xpm-finish))
210 (mput-points px decor)))
213 for type in '(bmoku bpmoku wmoku wpmoku)
214 do (with-current-buffer (aref foreground n)
216 (ok place type 'xpm-as-xpm)
218 (mapc 'kill-buffer foreground)
222 (defun gnugo-imgen-create-xpms (board-size)
223 "Return a list of XPM images suitable for BOARD-SIZE.
224 The size and style of the images are determined by
225 `gnugo-imgen-sizing-function' (rounded down to an even number)
226 and `gnugo-imgen-style', respectively. See `gnugo-xpms'.
228 The returned list is cached; see also `gnugo-imgen-clear-cache'."
229 (let* ((square (let ((n (funcall gnugo-imgen-sizing-function
232 (error "Invalid BOARD-SIZE: %s" board-size))
233 (max 8 (logand (lognot 1) (truncate n)))))
234 (style (or (unless gnugo-imgen-style (cdar gnugo-imgen-styles))
235 (cdr (assq gnugo-imgen-style gnugo-imgen-styles))
236 (error "No style selected")))
237 (key (cons square style)))
238 (or (gethash key gnugo-imgen-cache)
239 (puthash key (gnugo-imgen-create-xpms-1 square style)
240 gnugo-imgen-cache))))
242 ;;;---------------------------------------------------------------------------
245 (provide 'gnugo-imgen)
247 ;;; gnugo-imgen.el ends here