[elpa] externals/gnugo 2d4e59e 292/357: [gnugo imgen] New feature: gnugo-imgen

[Stefan Monnier]

branch: externals/gnugo
commit 2d4e59e2fc01a25c5669fec943084f37e6c92df1
Author: Thien-Thi Nguyen <ttn@gnu.org>
Commit: Thien-Thi Nguyen <ttn@gnu.org>

    [gnugo imgen] New feature: gnugo-imgen
    
    * packages/gnugo/gnugo-imgen.el: New file.
    * packages/gnugo/gnugo.el [Package-Requires]: Mention ‘xpm’.
---
 gnugo-imgen.el | 243 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 gnugo.el       |   4 +-
 2 files changed, 245 insertions(+), 2 deletions(-)

diff --git a/gnugo-imgen.el b/gnugo-imgen.el
new file mode 100644
index 0000000..0954c40
--- /dev/null
+++ b/gnugo-imgen.el
@@ -0,0 +1,243 @@
+;;; 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)."
+  (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 (loop
+                   for px in (mapcar 'car gnugo-imgen-palette)
+                   for role in roles
+                   collect (cons px (format "s %s" role))))
+         (resolved (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
+      (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)))
+        (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))
+        (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)))
+              (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)))))
+
+(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
diff --git a/gnugo.el b/gnugo.el
index f6fafaa..24cd470 100644
--- a/gnugo.el
+++ b/gnugo.el
@@ -5,7 +5,7 @@
 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
 ;; Version: 2.3.1
-;; Package-Requires: ((ascii-art-to-unicode "1.5"))
+;; Package-Requires: ((ascii-art-to-unicode "1.5") (xpm "1.0.0"))
 
 ;; 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
@@ -68,7 +68,7 @@
 ;;                    `gnugo-mode-line'
 ;;                    `gnugo-X-face' `gnugo-O-face' `gnugo-grid-face'
 ;;                    `gnugo-undo-reaction'
-;;                    `gnugo-xpms'
+;;                    `gnugo-xpms' (see also gnugo-imgen.el)
 ;;   normal hooks:    `gnugo-board-mode-hook'
 ;;                    `gnugo-frolic-mode-hook'
 ;;                    `gnugo-start-game-hook'