ttn pushed a commit to branch ttn-xpm
in repository elpa.
commit 53398ce837939435037374d710c0939ca5030026
Author: Thien-Thi Nguyen <t...@gnu.org>
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 <t...@gnu.org>
+;; Maintainer: Thien-Thi Nguyen <t...@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 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
