my-emacs-d/elpa/gnugo-3.0.0/gnugo-imgen.el
2016-09-26 19:35:49 +02:00

248 lines
9.7 KiB
EmacsLisp
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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