;;; fulminate-gnugo-xpms.el ;;; ;;; Copyright (C) 2004, 2007, 2008 Thien-Thi Nguyen ;;; ;;; This file is part of ttn's personal elisp library, released under ;;; the terms of the GNU General Public License as published by the ;;; Free Software Foundation; either version 3, or (at your option) any ;;; later version. There is NO WARRANTY. See file COPYING for details. ;;; Description: Parameterized XPM fulmination for gnugo.el display. ;;; Commentary: ;; There is not a lot of parameterization possible, but it's a start. ;; One less reason to have a filesystem... ;;; Code: (require 'artist-subpixel) (require 'xpm-fulmination) (eval-when-compile (require 'cl)) (defvar fulminated-gnugo-xpm-styles '((d-bump ; thanks :square 24 :background "#FFFFC7C75252" :grid-lines "#000000000000" :circ-edges "#C6C6C3C3C6C6" :white-fill "#FFFFFFFFFFFF" :black-fill "#000000000000") (ttn ; this guy must live in a cave :square 42 :background "#000000000000" :grid-lines "#AAAA88885555" :circ-edges "#888888888888" :white-fill "#CCCCCCCCCCCC" :black-fill "#444444444444")) "*Alist of styles suitable for first arg to `fulminate-gnugo-xpms'. The key is a symbol naming the style. The value is a plist. Here is a list of recognized keywords and their meanings: :square -- integer specifying the dimension of the XPM; should be an even number (modulo 2 => 0) :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.") ;;;###autoload (defun fulminate-gnugo-xpms (style &rest tweaks) "Return a list of XPM images fulminated in STYLE, perhaps w/ some TWEAKS. STYLE is a symbol naming an entry in `fulminated-gnugo-xpm-styles'. TWEAKS are a sequence of keyword/value pairs to override those in STYLE. The returned list is suitable for setting as the value of global variable `gnugo-xpms', or as the value of a GNUGO Board buffer property `:local-xpms'. Here is an example of the latter usage: (defvar big-xpm-set nil \"When playing go is more fun than finding my spectacles.\") (add-hook 'gnugo-board-mode-hook (lambda () (when (< (gnugo-get :board-size) 11) (unless big-xpm-set (setq big-xpm-set (fulminate-gnugo-xpms 'd-bump :square 50))) (gnugo-put :local-xpms big-xpm-set)))) This example arranges for the games on boards of size less than 11 to use a larger XPM set for easier viewing." (let (parms shared-colors) (setq parms (copy-sequence (or (cdr (assq style fulminated-gnugo-xpm-styles)) (error "No such fulminated-gnugo-xpm style: %s" style)))) (while tweaks (plist-put parms (car tweaks) (cadr tweaks)) (setq tweaks (cddr tweaks))) ;; todo: not all of these are used -- opportunity for compaction; also, ;; we may wish to support `nil' to mean "omit" (for even more compaction) (push (cons 32 (plist-get parms :background)) shared-colors) (push (cons ?. (plist-get parms :grid-lines)) shared-colors) (push (cons ?X (plist-get parms :circ-edges)) shared-colors) (push (cons ?- (plist-get parms :black-fill)) shared-colors) (push (cons ?+ (plist-get parms :white-fill)) shared-colors) ;; do it (let* ((square (plist-get parms :square)) (odd-squarep (= 1 (% square 2))) (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)) (half-when-odd (truncate half)) (NS-when-odd (lambda (x) `((,x . ,half-when-odd)))) (NS-normally (lambda (x) `((,x . ,half-m1) (,x . ,half-p1)))) (gN (apply 'append (mapcar (if odd-squarep NS-when-odd NS-normally) (number-sequence 0 half-p1)))) (gS (apply 'append (mapcar (if odd-squarep NS-when-odd NS-normally) (number-sequence half-m1 sq-m1)))) (WE-when-odd (lambda (y1 y2) `((,half-when-odd . ,y1) (,half-when-odd . ,y2)))) (WE-normally (lambda (y1 y2) `((,half-m1 . ,y1) (,half-m1 . ,y2) (,half-p1 . ,y1) (,half-p1 . ,y2)))) (gW (funcall (if odd-squarep WE-when-odd WE-normally) 0 half-p1)) (gE (funcall (if odd-squarep WE-when-odd WE-normally) half-m1 sq-m1)) (hline (lambda (x y1 y2) (mapcar (lambda (y) (cons x y)) (number-sequence y1 y2)))) (vline (lambda (y x1 x2) (mapcar (lambda (x) (cons x y)) (number-sequence x1 x2)))) (circ (lambda (buf r edge fill) (xpmfulm-raster buf (circle-placed r half half) edge fill))) (rv (mapcar (lambda (key) (cons key (xpmfulm-buffer (format "%s%d" (car key) (cdr key)) square square shared-colors))) (cons '(hoshi . 5) (apply 'append (mapcar (lambda (place) (mapcar (lambda (type) (cons type place)) '(empty bmoku bpmoku wmoku wpmoku))) (number-sequence 1 9))))))) (dolist (x rv) (let* ((key (car x)) (type (car key)) (place (cdr key)) (buf (cdr x))) ;; background (mapc (lambda (part) (xpmfulm-raster buf part ?. t)) (case place (1 (list (funcall hline half-m2 half-m2 sq-m1) (funcall vline half-m2 half-m2 sq-m1) gE gS)) (2 (list (funcall hline half-m2 0 sq-m1) gE gS gW)) (3 (list (funcall hline half-m2 0 half-p2) (funcall vline half-p2 half-m2 sq-m1) gS gW)) (4 (list (funcall vline half-m2 0 sq-m1) gS gN gE)) (5 (list gS gW gN gE)) (6 (list (funcall vline half-p2 0 sq-m1) gS gW gN)) (7 (list (funcall hline half-p2 half-m2 sq-m1) (funcall vline half-m2 0 half-p2) gN gE)) (8 (list (funcall hline half-p2 0 sq-m1) gW gN gE)) (9 (list (funcall hline half-p2 0 half-p2) (funcall vline half-p2 0 half-p2) gW gN)))) ;; foreground (case type ((bmoku bpmoku) (funcall circ buf (truncate half) ?X ?-) (when (eq 'bpmoku type) (funcall circ buf (/ square 9) ?X ?+))) ((wmoku wpmoku) (funcall circ buf (truncate half) ?X ?+) (when (eq 'wpmoku type) (funcall circ buf (/ square 9) ?X ?-))) ((hoshi) (let* ((m1 half-m1) (m2 half-m2) (m3 (1- m2)) (m4 (1- m3)) (p1 half-p1) (p2 half-p2) (p3 (1+ p2)) (p4 (1+ p3))) (xpmfulm-raster buf `((,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)))) ;; jam it (setcdr x (xpmfulm-as-xpm buf :ascent 'center)))) rv))) (provide 'fulminate-gnugo-xpms) ;;; fulminate-gnugo-xpms.el ends here