code.delx.au - gnu-emacs-elpa/blob - packages/gnugo/gnugo-imgen.el

   1 ;;; gnugo-imgen.el --- image generation         -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
   6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
   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 <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; This file provides func `gnugo-imgen-create-xpms', suitable as
  24 ;; value for `gnugo-xpms', and several variables to configure it:
  25 ;;
  26 ;;  `gnugo-imgen-styles'
  27 ;;  `gnugo-imgen-style'
  28 ;;  `gnugo-imgen-sizing-function'
  29 ;;
  30 ;; There is also one command: `gnugo-imgen-clear-cache'.
  31
  32 ;;; Code:
  33
  34 (require 'xpm)
  35 (require 'xpm-m2z)
  36 (require 'cl-lib)
  37
  38 (defvar gnugo-imgen-styles
  39   '((d-bump                             ; thanks
  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:
  54
  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
  58  :white-fill
  59  :black-fill
  60
  61 All keywords are required and color values cannot be nil.
  62 This restriction may be lifted in the future.")
  63
  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.")
  67
  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.")
  73
  74 (defvar gnugo-imgen-cache (make-hash-table :test 'equal))
  75
  76 (defun gnugo-imgen-clear-cache ()
  77   "Clear the cache."
  78   (interactive)
  79   (clrhash gnugo-imgen-cache))
  80
  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)
  88     (ignore L R)
  89     (/ (float (- bot top (* 2 (frame-char-height))))
  90        board-size)))
  91
  92 (defconst gnugo-imgen-palette '((32 . :background)
  93                                 (?. . :grid-lines)
  94                                 (?X . :circ-edges)
  95                                 (?- . :black-fill)
  96                                 (?+ . :white-fill)))
  97
  98 (defun gnugo-imgen-create-xpms-1 (square style)
  99   (let* ((kws (mapcar 'cdr gnugo-imgen-palette))
 100          (roles (mapcar 'symbol-name kws))
 101          (palette (cl-loop
 102                    for px in (mapcar 'car gnugo-imgen-palette)
 103                    for role in roles
 104                    collect (cons px (format "s %s" role))))
 105          (resolved (cl-loop
 106                     with parms = (copy-sequence style)
 107                     for role in roles
 108                     for kw in kws
 109                     collect (cons role (plist-get parms kw))))
 110          (sq-m1 (1- square))
 111          (half (/ sq-m1 2.0))
 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))
 116          rv)
 117     (cl-flet
 118         ((workbuf (n)
 119                   (xpm-generate-buffer (format "%d_%d" n square)
 120                                        square square 1 palette))
 121          (replace-from (buffer)
 122                        (erase-buffer)
 123                        (insert-buffer-substring buffer)
 124                        (xpm-grok t))
 125          (nine-from-four (N E W S)
 126                          (list (list   E   S)
 127                                (list   E W S)
 128                                (list     W S)
 129                                (list N E   S)
 130                                (list N E W S)
 131                                (list N   W S)
 132                                (list N E    )
 133                                (list N E W  )
 134                                (list N   W  )))
 135          (mput-points (px ls)
 136                       (dolist (coord ls)
 137                         (apply 'xpm-put-points px coord))))
 138       ;; background
 139       (cl-loop
 140        for place from 1 to 9
 141        for parts
 142        in (cl-flet*
 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)
 151                             (h-expand 0       half-p1)
 152                             (v-expand half-m1   sq-m1)))
 153        do (aset background place
 154                 (with-current-buffer (workbuf place)
 155                   (dolist (part parts)
 156                     (mput-points ?. part))
 157                   (current-buffer))))
 158       ;; foreground
 159       (cl-flet
 160           ((circ (radius)
 161                  (xpm-m2z-circle half half radius)))
 162         (cl-loop
 163          with stone = (circ (truncate half))
 164          with minim = (circ (/ square 9))
 165          for n below 4
 166          do (aset foreground n
 167                   (with-current-buffer (workbuf n)
 168                     (cl-flet
 169                         ((rast (form b w)
 170                                (xpm-raster form ?X
 171                                            (if (> 2 n)
 172                                                b
 173                                              w))))
 174                       (if (cl-evenp n)
 175                           (rast stone ?- ?+)
 176                         (replace-from (aref foreground (1- n)))
 177                         (rast minim ?+ ?-))
 178                       (current-buffer))))))
 179       ;; do it
 180       (cl-flet
 181           ((ok (place type finish)
 182                (goto-char 25)
 183                (delete-char (- (skip-chars-forward "^1-9")))
 184                (delete-char 1)
 185                (insert (format "%s%d" type place))
 186                (push (cons (cons type place)
 187                            (funcall finish
 188                                     :ascent 'center
 189                                     :color-symbols resolved))
 190                      rv)))
 191         (with-current-buffer (workbuf 5)
 192           (replace-from (aref background 5))
 193           (xpm-raster
 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)
 197            ?. t)
 198           (ok 5 'hoshi 'xpm-finish))
 199         (cl-loop
 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)
 203                                         (list sq-m1   friends)
 204                                         (list 0       friends)
 205                                         (list friends   sq-m1)))
 206          do (with-current-buffer (aref background place)
 207               (ok place 'empty 'xpm-finish))
 208          do (cl-flet
 209                 ((decorate (px)
 210                            (mput-points px decor)))
 211               (cl-loop
 212                for n below 4
 213                for type in '(bmoku bpmoku wmoku wpmoku)
 214                do (with-current-buffer (aref foreground n)
 215                     (decorate ?.)
 216                     (ok place type 'xpm-as-xpm)
 217                     (decorate 32)))))
 218         (mapc 'kill-buffer foreground)
 219         (nreverse rv)))))
 220
 221 ;;;###autoload
 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'.
 227
 228 The returned list is cached; see also `gnugo-imgen-clear-cache'."
 229   (let* ((square (let ((n (funcall gnugo-imgen-sizing-function
 230                                    board-size)))
 231                    (unless (numberp n)
 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))))
 241
 242 ;;;---------------------------------------------------------------------------
 243 ;;; that's it
 244
 245 (provide 'gnugo-imgen)
 246
 247 ;;; gnugo-imgen.el ends here