[elpa] 01/01: [gnugo] add gnugo-d0.el

[Thien-Thi Nguyen]

ttn pushed a commit to branch ttn-xpm
in repository elpa.

commit 53398ce837939435037374d710c0939ca5030026
Author: Thien-Thi Nguyen <address@hidden>
Date:   Tue May 13 12:46:51 2014 +0200

    [gnugo] add gnugo-d0.el
---
 packages/gnugo/gnugo-d0.el |  204 ++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 204 insertions(+), 0 deletions(-)

diff --git a/packages/gnugo/gnugo-d0.el b/packages/gnugo/gnugo-d0.el
new file mode 100644
index 0000000..eeff64d
--- /dev/null
+++ b/packages/gnugo/gnugo-d0.el
@@ -0,0 +1,204 @@
+;;; gnugo-d0.el --- gnugo.el display protocol 0   -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; Author: Thien-Thi Nguyen <address@hidden>
+;; Maintainer: Thien-Thi Nguyen <address@hidden>
+
+;; 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 makes use of xpm.el (et al)
+
+;;; Code:
+
+(require 'xpm)
+(require 'xpm-m2z-circle)
+(require 'cl-lib)
+(eval-when-compile (require 'cl))
+
+(defvar gnugo-d0-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-d0-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\" to mean \"black\"; you may be able
+  :circ-edges    to use an actual color name but that hasn't been tested
+  :white-fill
+  :black-fill
+
+At this time, all keywords are required and color values cannot be nil.
+This restriction may be lifted in the future.")
+
+(defvar gnugo-d0-style nil
+  "Which style in `gnugo-d0-styles' to use.
+If nil, `gnugo-d0-create-xpms' defaults to the first one.")
+
+(defvar gnugo-d0-sizing-function 'gnugo-d0-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).
+A value less than 8 is taken as 8.")
+
+(defvar gnugo-d0-cache (make-hash-table :test 'equal))
+
+(defun gnugo-d0-clear-cache ()
+  "Clear the cache."
+  (interactive)
+  (clrhash gnugo-d0-cache))
+
+(defun gnugo-d0-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)))
+
+(defun gnugo-d0-create-xpms-1 (square style)
+  (let* ((colors (loop
+                  with parms = (copy-sequence style)
+                  for (char . kw) in '((32 . :background)
+                                       (?. . :grid-lines)
+                                       (?X . :circ-edges)
+                                       (?- . :black-fill)
+                                       (?+ . :white-fill))
+                  collect (cons char (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)))
+         (half-m2 (1- half-m1))
+         (half-p2 (1+ half-p1))
+         (stone-radius (truncate half))
+         (highlight-radius (/ square 9)))
+    (loop
+
+     with inhibit-read-only = t         ; ugh
+
+     with background =
+     (cl-flet*
+         ((vline (x y1 y2)
+                 (list (cons x (cons y1 y2))))
+          (v-expand (y1 y2)
+                    (loop for x from half-m2 to half-p1
+                          append (vline x y1 y2)))
+          (hline (y x1 x2)
+                 (list (cons (cons x1 x2) y)))
+          (h-expand (x1 x2)
+                    (loop for y from half-m1 to half-p1
+                          append (hline y x1 x2))))
+       (let ((N (v-expand 0       half-p1))
+             (S (v-expand half-m1   sq-m1))
+             (W (h-expand 0       half-p1))
+             (E (h-expand half-m1   sq-m1)))
+         (list
+          (list 1   E   S)
+          (list 2   E W S)
+          (list 3     W S)
+          (list 4 N E   S)
+          (list 5 N E W S)
+          (list 6 N   W S)
+          (list 7 N E    )
+          (list 8 N E W  )
+          (list 9 N   W  ))))
+
+     for (type . place)
+     in (cons '(hoshi . 5)
+              (loop for place from 1 to 9
+                    append (loop for type
+                                 in '(empty
+                                      bmoku bpmoku
+                                      wmoku wpmoku)
+                                 collect (cons type place))))
+
+     collect
+     (with-current-buffer (xpm-buffer
+                           (format "%s%d" type place)
+                           square square 1 colors)
+       ;; background
+       (loop for part
+             in (cdr (assq place background))
+             do (loop for (x . y)
+                      in part
+                      do (xpm-put-points ?. x y)))
+       ;; foreground
+       (cl-flet*
+           ((circ (fill radius)
+                  (xpm-raster (xpm-m2z-circle half half radius)
+                              ?X fill))
+            (stone (fill)
+                   (circ fill stone-radius))
+            (highlight (fill)
+                       (circ fill highlight-radius)))
+         (case type
+           (bmoku  (stone ?-))
+           (bpmoku (stone ?-) (highlight ?+))
+           (wmoku  (stone ?+))
+           (wpmoku (stone ?+) (highlight ?-))
+           (hoshi (let* ((m2 half-m2) (m3 (1- m2)) (m4 (1- m3))
+                         (p2 half-p2) (p3 (1+ p2)) (p4 (1+ p3)))
+                    (xpm-raster `((,m4 . ,m2) (,m4 . ,p2)
+                                  (,m3 . ,m3) (,m3 . ,p3)
+                                  (,m2 . ,m4) (,m2 . ,p4)
+                                  (,p2 . ,m4) (,p2 . ,p4)
+                                  (,p3 . ,m3) (,p3 . ,p3)
+                                  (,p4 . ,m2) (,p4 . ,p2))
+                                ?. t)))))
+       (cons (cons type place)
+             (xpm-finish :ascent 'center))))))
+
+(defun gnugo-d0-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-d0-sizing-function' (rounded down to an even number)
+and `gnugo-d0-style', respectively.
+
+The returned list is cached; see also `gnugo-d0-clear-cache'."
+  (let* ((square (let ((n (funcall gnugo-d0-sizing-function
+                                   board-size)))
+                   (unless (numberp n)
+                     (error "Invalid SQUARE: %s" n))
+                   (max 8 (logand (lognot 1) (truncate n)))))
+         (style (or (unless gnugo-d0-style (cdar gnugo-d0-styles))
+                    (cdr (assq gnugo-d0-style gnugo-d0-styles))
+                    (error "No style selected")))
+         (key (cons square style)))
+    (or (gethash key gnugo-d0-cache)
+        (puthash key (gnugo-d0-create-xpms-1 square style)
+                 gnugo-d0-cache))))
+
+;;;---------------------------------------------------------------------------
+;;; that's it
+
+(provide 'gnugo-d0)
+
+;;; gnugo-d0.el ends here