248 lines
9.7 KiB
EmacsLisp
248 lines
9.7 KiB
EmacsLisp
|
;;; gnugo-imgen.el --- image generation -*- lexical-binding: t -*-
|
|||
|
|
|
|||
|
|
;; Copyright (C) 2014 Free Software Foundation, Inc.
|
|||
|
|
|
|||
|
|
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
|||
|
|
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
|
|||
|
|
|
|||
|
|
;; This program is free software; you can redistribute it and/or modify
|
|||
|
|
;; it under the terms of the GNU General Public License as published by
|
|||
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|||
|
|
;; (at your option) any later version.
|
|||
|
|
|
|||
|
|
;; This program is distributed in the hope that it will be useful,
|
|||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|||
|
|
;; GNU General Public License for more details.
|
|||
|
|
|
|||
|
|
;; You should have received a copy of the GNU General Public License
|
|||
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
|
|
|||
|
|
;;; Commentary:
|
|||
|
|
|
|||
|
|
;; This file provides func `gnugo-imgen-create-xpms', suitable as
|
|||
|
|
;; value for `gnugo-xpms', and several variables to configure it:
|
|||
|
|
;;
|
|||
|
|
;; `gnugo-imgen-styles'
|
|||
|
|
;; `gnugo-imgen-style'
|
|||
|
|
;; `gnugo-imgen-sizing-function'
|
|||
|
|
;;
|
|||
|
|
;; There is also one command: `gnugo-imgen-clear-cache'.
|
|||
|
|
|
|||
|
|
;;; Code:
|
|||
|
|
|
|||
|
|
(require 'xpm)
|
|||
|
|
(require 'xpm-m2z)
|
|||
|
|
(require 'cl-lib)
|
|||
|
|
|
|||
|
|
(defvar gnugo-imgen-styles
|
|||
|
|
'((d-bump ; thanks
|
|||
|
|
:background "#FFFFC7C75252"
|
|||
|
|
:grid-lines "#000000000000"
|
|||
|
|
:circ-edges "#C6C6C3C3C6C6"
|
|||
|
|
:white-fill "#FFFFFFFFFFFF"
|
|||
|
|
:black-fill "#000000000000")
|
|||
|
|
(ttn ; this guy must live in a cave
|
|||
|
|
:background "#000000000000"
|
|||
|
|
:grid-lines "#AAAA88885555"
|
|||
|
|
:circ-edges "#888888888888"
|
|||
|
|
:white-fill "#CCCCCCCCCCCC"
|
|||
|
|
:black-fill "#444444444444"))
|
|||
|
|
"Alist of styles suitable for `gnugo-imgen-create-xpms'.
|
|||
|
|
The key is a symbol naming the style. The value is a plist.
|
|||
|
|
Here is a list of recognized keywords and their meanings:
|
|||
|
|
|
|||
|
|
:background -- string that names a color in XPM format, such as
|
|||
|
|
:grid-lines \"#000000000000\" or \"black\"; the special string
|
|||
|
|
:circ-edges \"None\" makes that component transparent
|
|||
|
|
:white-fill
|
|||
|
|
:black-fill
|
|||
|
|
|
|||
|
|
All keywords are required and color values cannot be nil.
|
|||
|
|
This restriction may be lifted in the future.")
|
|||
|
|
|
|||
|
|
(defvar gnugo-imgen-style nil
|
|||
|
|
"Which style in `gnugo-imgen-styles' to use.
|
|||
|
|
If nil, `gnugo-imgen-create-xpms' defaults to the first one.")
|
|||
|
|
|
|||
|
|
(defvar gnugo-imgen-sizing-function 'gnugo-imgen-fit-window-height
|
|||
|
|
"Function to compute XPM image size from board size.
|
|||
|
|
This is called with one arg, integer BOARD-SIZE, and should return
|
|||
|
|
a number (float or integer), the number of pixels for the side of
|
|||
|
|
a square position on the board. A value less than 8 is taken as 8.")
|
|||
|
|
|
|||
|
|
(defvar gnugo-imgen-cache (make-hash-table :test 'equal))
|
|||
|
|
|
|||
|
|
(defun gnugo-imgen-clear-cache ()
|
|||
|
|
"Clear the cache."
|
|||
|
|
(interactive)
|
|||
|
|
(clrhash gnugo-imgen-cache))
|
|||
|
|
|
|||
|
|
(defun gnugo-imgen-fit-window-height (board-size)
|
|||
|
|
"Return the dimension (in pixels) of a square for BOARD-SIZE.
|
|||
|
|
This uses the TOP and BOTTOM components as returned by
|
|||
|
|
`window-inside-absolute-pixel-edges' and subtracts twice
|
|||
|
|
the `frame-char-height' (to leave space for the grid)."
|
|||
|
|
(cl-destructuring-bind (L top R bot)
|
|||
|
|
(window-inside-absolute-pixel-edges)
|
|||
|
|
(ignore L R)
|
|||
|
|
(/ (float (- bot top (* 2 (frame-char-height))))
|
|||
|
|
board-size)))
|
|||
|
|
|
|||
|
|
(defconst gnugo-imgen-palette '((32 . :background)
|
|||
|
|
(?. . :grid-lines)
|
|||
|
|
(?X . :circ-edges)
|
|||
|
|
(?- . :black-fill)
|
|||
|
|
(?+ . :white-fill)))
|
|||
|
|
|
|||
|
|
(defun gnugo-imgen-create-xpms-1 (square style)
|
|||
|
|
(let* ((kws (mapcar 'cdr gnugo-imgen-palette))
|
|||
|
|
(roles (mapcar 'symbol-name kws))
|
|||
|
|
(palette (cl-loop
|
|||
|
|
for px in (mapcar 'car gnugo-imgen-palette)
|
|||
|
|
for role in roles
|
|||
|
|
collect (cons px (format "s %s" role))))
|
|||
|
|
(resolved (cl-loop
|
|||
|
|
with parms = (copy-sequence style)
|
|||
|
|
for role in roles
|
|||
|
|
for kw in kws
|
|||
|
|
collect (cons role (plist-get parms kw))))
|
|||
|
|
(sq-m1 (1- square))
|
|||
|
|
(half (/ sq-m1 2.0))
|
|||
|
|
(half-m1 (truncate (- half 0.5)))
|
|||
|
|
(half-p1 (truncate (+ half 0.5)))
|
|||
|
|
(background (make-vector 10 nil))
|
|||
|
|
(foreground (make-vector 4 nil))
|
|||
|
|
rv)
|
|||
|
|
(cl-flet
|
|||
|
|
((workbuf (n)
|
|||
|
|
(xpm-generate-buffer (format "%d_%d" n square)
|
|||
|
|
square square 1 palette))
|
|||
|
|
(replace-from (buffer)
|
|||
|
|
(erase-buffer)
|
|||
|
|
(insert-buffer-substring buffer)
|
|||
|
|
(xpm-grok t))
|
|||
|
|
(nine-from-four (N E W S)
|
|||
|
|
(list (list E S)
|
|||
|
|
(list E W S)
|
|||
|
|
(list W S)
|
|||
|
|
(list N E S)
|
|||
|
|
(list N E W S)
|
|||
|
|
(list N W S)
|
|||
|
|
(list N E )
|
|||
|
|
(list N E W )
|
|||
|
|
(list N W )))
|
|||
|
|
(mput-points (px ls)
|
|||
|
|
(dolist (coord ls)
|
|||
|
|
(apply 'xpm-put-points px coord))))
|
|||
|
|
;; background
|
|||
|
|
(cl-loop
|
|||
|
|
for place from 1 to 9
|
|||
|
|
for parts
|
|||
|
|
in (cl-flet*
|
|||
|
|
((vline (x y1 y2) (list (list x (cons y1 y2))))
|
|||
|
|
(v-expand (y1 y2) (append (vline half-m1 y1 y2)
|
|||
|
|
(vline half-p1 y1 y2)))
|
|||
|
|
(hline (y x1 x2) (list (list (cons x1 x2) y)))
|
|||
|
|
(h-expand (x1 x2) (append (hline half-m1 x1 x2)
|
|||
|
|
(hline half-p1 x1 x2))))
|
|||
|
|
(nine-from-four (v-expand 0 half-p1)
|
|||
|
|
(h-expand half-m1 sq-m1)
|
|||
|
|
(h-expand 0 half-p1)
|
|||
|
|
(v-expand half-m1 sq-m1)))
|
|||
|
|
do (aset background place
|
|||
|
|
(with-current-buffer (workbuf place)
|
|||
|
|
(dolist (part parts)
|
|||
|
|
(mput-points ?. part))
|
|||
|
|
(current-buffer))))
|
|||
|
|
;; foreground
|
|||
|
|
(cl-flet
|
|||
|
|
((circ (radius)
|
|||
|
|
(xpm-m2z-circle half half radius)))
|
|||
|
|
(cl-loop
|
|||
|
|
with stone = (circ (truncate half))
|
|||
|
|
with minim = (circ (/ square 9))
|
|||
|
|
for n below 4
|
|||
|
|
do (aset foreground n
|
|||
|
|
(with-current-buffer (workbuf n)
|
|||
|
|
(cl-flet
|
|||
|
|
((rast (form b w)
|
|||
|
|
(xpm-raster form ?X
|
|||
|
|
(if (> 2 n)
|
|||
|
|
b
|
|||
|
|
w))))
|
|||
|
|
(if (cl-evenp n)
|
|||
|
|
(rast stone ?- ?+)
|
|||
|
|
(replace-from (aref foreground (1- n)))
|
|||
|
|
(rast minim ?+ ?-))
|
|||
|
|
(current-buffer))))))
|
|||
|
|
;; do it
|
|||
|
|
(cl-flet
|
|||
|
|
((ok (place type finish)
|
|||
|
|
(goto-char 25)
|
|||
|
|
(delete-char (- (skip-chars-forward "^1-9")))
|
|||
|
|
(delete-char 1)
|
|||
|
|
(insert (format "%s%d" type place))
|
|||
|
|
(push (cons (cons type place)
|
|||
|
|
(funcall finish
|
|||
|
|
:ascent 'center
|
|||
|
|
:color-symbols resolved))
|
|||
|
|
rv)))
|
|||
|
|
(with-current-buffer (workbuf 5)
|
|||
|
|
(replace-from (aref background 5))
|
|||
|
|
(xpm-raster
|
|||
|
|
;; yes, using an ellipse is bizarre; no, we don't mind;
|
|||
|
|
;; maybe, ‘artist-ellipse-generate-quadrant’ is stable.
|
|||
|
|
(xpm-m2z-ellipse half half 4 4.5)
|
|||
|
|
?. t)
|
|||
|
|
(ok 5 'hoshi 'xpm-finish))
|
|||
|
|
(cl-loop
|
|||
|
|
for place from 1 to 9
|
|||
|
|
for decor in (let ((friends (cons half-m1 half-p1)))
|
|||
|
|
(nine-from-four (list friends 0)
|
|||
|
|
(list sq-m1 friends)
|
|||
|
|
(list 0 friends)
|
|||
|
|
(list friends sq-m1)))
|
|||
|
|
do (with-current-buffer (aref background place)
|
|||
|
|
(ok place 'empty 'xpm-finish))
|
|||
|
|
do (cl-flet
|
|||
|
|
((decorate (px)
|
|||
|
|
(mput-points px decor)))
|
|||
|
|
(cl-loop
|
|||
|
|
for n below 4
|
|||
|
|
for type in '(bmoku bpmoku wmoku wpmoku)
|
|||
|
|
do (with-current-buffer (aref foreground n)
|
|||
|
|
(decorate ?.)
|
|||
|
|
(ok place type 'xpm-as-xpm)
|
|||
|
|
(decorate 32)))))
|
|||
|
|
(mapc 'kill-buffer foreground)
|
|||
|
|
(nreverse rv)))))
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defun gnugo-imgen-create-xpms (board-size)
|
|||
|
|
"Return a list of XPM images suitable for BOARD-SIZE.
|
|||
|
|
The size and style of the images are determined by
|
|||
|
|
`gnugo-imgen-sizing-function' (rounded down to an even number)
|
|||
|
|
and `gnugo-imgen-style', respectively. See `gnugo-xpms'.
|
|||
|
|
|
|||
|
|
The returned list is cached; see also `gnugo-imgen-clear-cache'."
|
|||
|
|
(let* ((square (let ((n (funcall gnugo-imgen-sizing-function
|
|||
|
|
board-size)))
|
|||
|
|
(unless (numberp n)
|
|||
|
|
(error "Invalid BOARD-SIZE: %s" board-size))
|
|||
|
|
(max 8 (logand (lognot 1) (truncate n)))))
|
|||
|
|
(style (or (unless gnugo-imgen-style (cdar gnugo-imgen-styles))
|
|||
|
|
(cdr (assq gnugo-imgen-style gnugo-imgen-styles))
|
|||
|
|
(error "No style selected")))
|
|||
|
|
(key (cons square style)))
|
|||
|
|
(or (gethash key gnugo-imgen-cache)
|
|||
|
|
(puthash key (gnugo-imgen-create-xpms-1 square style)
|
|||
|
|
gnugo-imgen-cache))))
|
|||
|
|
|
|||
|
|
;;;---------------------------------------------------------------------------
|
|||
|
|
;;; that's it
|
|||
|
|
|
|||
|
|
(provide 'gnugo-imgen)
|
|||
|
|
|
|||
|
|
;;; gnugo-imgen.el ends here
|