summaryrefslogtreecommitdiff
path: root/src/guile
diff options
context:
space:
mode:
authorLudovic Courtes2006-07-23 20:50:31 +0000
committerLudovic Courtes2006-07-23 20:50:31 +0000
commit4758a8261ef5e4a55372a686ae8a50f104292b12 (patch)
treec8a698ae0b194c1e0495c3816c7ba5f8b8ba96a8 /src/guile
parent6d7a8dbae57f06b883bab6e57728d07a9d072c22 (diff)
downloadskribilo-4758a8261ef5e4a55372a686ae8a50f104292b12.tar.gz
skribilo-4758a8261ef5e4a55372a686ae8a50f104292b12.tar.lz
skribilo-4758a8261ef5e4a55372a686ae8a50f104292b12.zip
Added a pie-chart package that can use either Ploticus or Lout.
* doc/user/user.skb: Use the `pie' package and include `pie.skb'. git-archimport-id: lcourtes@laas.fr--2005-libre/skribilo--devo--1.2--patch-24
Diffstat (limited to 'src/guile')
-rw-r--r--src/guile/skribilo/package/pie.scm313
-rw-r--r--src/guile/skribilo/package/pie/lout.scm131
2 files changed, 444 insertions, 0 deletions
diff --git a/src/guile/skribilo/package/pie.scm b/src/guile/skribilo/package/pie.scm
new file mode 100644
index 0000000..2644cb7
--- /dev/null
+++ b/src/guile/skribilo/package/pie.scm
@@ -0,0 +1,313 @@
+;;; pie.scm -- An pie-chart formatting package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; 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 2 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, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+(define-module (skribilo package pie)
+ :autoload (skribilo ast) (markup? markup-ident)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib) ;; `skribe-error' et al.
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (skribilo utils strings) ;; `make-string-replace'
+ :use-module (skribilo module)
+ :autoload (skribilo color) (skribe-color->rgb)
+ :autoload (skribilo skribe api) (bold)
+ :autoload (skribilo engine lout) (lout-illustration)
+ :autoload (ice-9 popen) (open-output-pipe)
+ :use-module (ice-9 optargs)
+ :export (pie-sliceweight-value pie-remove-markup))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Markup.
+;;;
+
+(define-markup (pie :rest opts
+ :key (ident #f) (title "Pie Chart")
+ (initial-angle 0) (total #f) (radius 3)
+ (fingers? #t) (labels 'outside)
+ (class "pie"))
+ (new container
+ (markup 'pie)
+ (ident (or ident (symbol->string (gensym "pie"))))
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (slice :rest opts
+ :key (ident #f) (weight 1) (color "white") (detach? #f))
+ (new container
+ (markup 'slice)
+ (ident (or ident (symbol->string (gensym "slice"))))
+ (weight weight)
+ (color color)
+ (detach? detach?)
+ (options (the-options opts))
+ (body (the-body opts))))
+
+(define-markup (sliceweight :rest opts
+ :key (ident #f) (percentage? #f))
+ (new markup
+ (markup 'sliceweight)
+ (ident (or ident (symbol->string (gensym "sliceweight"))))
+ (percentage? percentage?)
+ (options (the-options opts))
+ (body '())))
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (make-rounder pow10)
+ ;; Return a procedure that round to 10 to the -POW10.
+ (let ((times (expt 10.0 pow10)))
+ (lambda (x)
+ (/ (round (* x times)) times))))
+
+(define (pie-sliceweight-value sw-node pct?)
+ "Return the value that should be displayed by `sw-node', a
+ `sliceweight' markup node. If `pct?' is true, then this value
+ should be a percentage."
+ (let* ((the-slice (ast-parent sw-node))
+ (weight (and the-slice (markup-option the-slice :weight))))
+ (if (not the-slice)
+ (skribe-error 'lout
+ "`sliceweight' node not within a `slice' body"
+ sw-node)
+ (if pct?
+ (let* ((the-pie (ast-parent the-slice))
+ (total (and the-pie
+ (markup-option the-pie
+ '&total-weight))))
+ (if (not the-pie)
+ (skribe-error 'lout
+ "`slice' not within a `pie' body"
+ the-slice)
+ (* 100.0 (/ weight total)))) ;; flonum (FIXME: precision)
+
+ weight))))
+
+(define (pie-remove-markup node)
+ "Remove markup from `node', ie. turn something like `(it \"hello\")' into
+the string \"hello\". Implement `sliceweight' markups too."
+ (define percentage-round (make-rounder 2))
+
+ (if (markup? node)
+ (if (and node (is-markup? node 'sliceweight))
+ (let* ((pct? (markup-option node :percentage?))
+ (value (pie-sliceweight-value node pct?)))
+ (number->string (percentage-round value)))
+ (pie-remove-markup (markup-body node)))
+ (if (list? node)
+ (apply string-append (map pie-remove-markup node))
+ node)))
+
+(define strip-newlines (make-string-replace '((#\newline " "))))
+
+(define (select-output-format engine)
+ ;; Choose an ouptut format suitable for ENGINE.
+ (define %supported-formats '("png" "ps" "eps" "svg" "svgz"))
+ (define %default-format "png")
+
+ (let ((fmt (engine-custom engine 'image-format)))
+ (cond ((string? fmt) fmt)
+ ((and (list? fmt) (not (null? fmt)))
+ (let ((f (car fmt)))
+ (if (member f %supported-formats)
+ f
+ %default-format)))
+ (else %default-format))))
+
+
+;;;
+;;; Default implementation (`base' engine).
+;;;
+
+;; Ploticus-based implementation of pie charts, suitable for most engines.
+;; See http://ploticus.sf.net for info about Ploticus.
+
+(define %ploticus-program "ploticus")
+(define %ploticus-debug? #f)
+
+(define (color-spec->ploticus color-spec)
+ (define round (make-rounder 2))
+
+ (call-with-values (lambda () (skribe-color->rgb color-spec))
+ (lambda (r g b)
+ (format #f "rgb(~a,~a,~a)"
+ (round (/ r 255.0))
+ (round (/ g 255.0))
+ (round (/ b 255.0))))))
+
+(define (ploticus-script pie)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body pie)))
+ (colors (map (lambda (slice)
+ (let ((c (markup-option slice :color)))
+ (string-append (color-spec->ploticus c)
+ " ")))
+ (markup-body pie)))
+ (total-weight (or (if (number? (markup-option pie
+ :total))
+ (markup-option pie :total)
+ #f)
+ (apply + weights)))
+
+ ;; Attach useful information to the pie and its slices
+ (-/- (markup-option-add! pie '&total-weight total-weight))
+
+ ;; One slice label per line -- so we need to remove
+ ;; newlines from labels.
+ (labels (map (lambda (b)
+ (strip-newlines (pie-remove-markup b)))
+ (markup-body pie)))
+
+; (flat-title (map pie-remove-markup
+; (markup-option pie :title)))
+ (detached (map (lambda (slice)
+ (let ((d (markup-option slice
+ :detach?)))
+ (cond ((number? d) d)
+ (d 0.5) ;; default
+ (#t 0))))
+ (markup-body pie)))
+
+ (initial-angle (or (markup-option pie :initial-angle)
+ 0))
+ (radius (or ;;FIXME
+ (markup-option pie :radius) 3))
+ (max-radius (+ radius (apply max detached)))
+
+ ;; center coordinates must take into account (i) the
+ ;; maxium radius when detached slices are considered and
+ ;; (ii) the fact that labels may get displayed to the
+ ;; left of the pie.
+ ;; FIXME: labels to the left (ii) end up being truncated
+ ;; when the radius is e.g. < 2.
+ (center `(,(+ max-radius
+ (* max-radius max-radius)) .
+ ,(* max-radius max-radius))))
+
+ (apply string-append
+ (append (list "#proc getdata\n" "data: ")
+ (map (lambda (weight)
+ (string-append (number->string weight)
+ "\n"))
+ weights)
+ `("\n"
+; "#proc page\n"
+; "title " ,@flat-title
+; "\n"
+ "#proc pie\n"
+ "total: "
+ ,(number->string total-weight)
+ "\n"
+ "datafield: " "1" "\n")
+ `("firstslice: " ,(number->string initial-angle) "\n")
+ `("radius: " ,(number->string radius) "\n")
+ `("center: " ,(number->string (car center))
+ " " ,(number->string (cdr center)) "\n")
+ `("labelmode: "
+ ,(case (markup-option
+ pie :labels)
+ ((outside) "line+label")
+ ((inside) "labelonly")
+ ((legend) "legend")
+ (else "legend"))
+ "\n"
+ "labels: " ,@(map (lambda (label)
+ (string-append label "\n"))
+ labels)
+ "\n")
+ `("explode: "
+ ,@(map (lambda (number)
+ (string-append (number->string number)
+ " "))
+ detached)
+ "\n")
+ `("colors: " ,@colors "\n")))))
+
+(markup-writer 'pie (find-engine 'base)
+ :action (lambda (node engine)
+ (let* ((fmt (select-output-format engine))
+ (pie-file (string-append (markup-ident node) "."
+ fmt))
+ (port (open-output-pipe
+ (string-append %ploticus-program
+ " -o " pie-file
+ " -cm -" fmt " -stdin")))
+ (script (ploticus-script node)))
+
+
+ (if %ploticus-debug?
+ (format (current-error-port) "** Ploticus script: ~a"
+ script))
+
+ (display script port)
+
+ (let ((exit-val (status:exit-val (close-pipe port))))
+ (if (not (eqv? 0 exit-val))
+ (skribe-error 'pie/ploticus
+ "ploticus exited with error code"
+ exit-val)))
+
+ (if (not (file-exists? pie-file))
+ (skribe-error 'ploticus
+ "Ploticus did not create the image file"
+ script))
+
+ (if (markup-option node :title)
+ (output (list (bold (markup-option node :title))
+ (linebreak))
+ engine))
+
+ (output (image :file pie-file
+ :class (markup-option node :class)
+ (or (markup-option node :title)
+ "A Pie Chart"))
+ engine))))
+
+(markup-writer 'slice (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here
+ (error "slice: this writer should never be invoked")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ :action (lambda (node engine)
+ ;; Nothing to do here.
+ (error "sliceweight: this writer should never be invoked")))
+
+
+;;;
+;;; Initialization.
+;;;
+
+(when-engine-is-loaded 'lout
+ (lambda ()
+ (resolve-module '(skribilo package pie lout))))
+
+
+;;; arch-tag: 8095d8f6-b810-4619-9fdb-23fb94a77ee3
diff --git a/src/guile/skribilo/package/pie/lout.scm b/src/guile/skribilo/package/pie/lout.scm
new file mode 100644
index 0000000..e6c4eb3
--- /dev/null
+++ b/src/guile/skribilo/package/pie/lout.scm
@@ -0,0 +1,131 @@
+;;; lout.scm -- Lout implementation of the `pie' package.
+;;;
+;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; 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 2 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, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+;;; USA.
+
+(define-module (skribilo package pie lout)
+ :use-module (skribilo package pie)
+ :use-module (skribilo ast)
+ :autoload (skribilo output) (output)
+ :use-module (skribilo writer)
+ :use-module (skribilo engine)
+ :use-module (skribilo lib)
+ :use-module (skribilo utils syntax)
+ :use-module (skribilo utils keywords) ;; `the-options', etc.
+ :use-module (ice-9 optargs))
+
+(fluid-set! current-reader %skribilo-module-reader)
+
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(let ((lout (find-engine 'lout)))
+ (if lout
+ (engine-custom-set! lout 'includes
+ (string-append (engine-custom lout 'includes)
+ "\n@SysInclude { pie } # Pie Charts\n"))))
+
+
+
+;;;
+;;; Writers.
+;;;
+
+(markup-writer 'pie (find-engine 'lout)
+ :before (lambda (node engine)
+ (let* ((weights (map (lambda (slice)
+ (markup-option slice :weight))
+ (markup-body node)))
+ (total-weight (or (if (number? (markup-option node
+ :total))
+ (markup-option node :total)
+ #f)
+ (apply + weights))))
+
+ (if (= 0 total-weight)
+ (skribe-error 'lout
+ "Slices weight sum should not be zero"
+ total-weight))
+
+ ;; Attach useful information to the pie and its slices
+ (markup-option-add! node '&total-weight total-weight)
+
+ (display "\n@Pie\n")
+ (display " abovecaption { ")
+ (if (markup-option node :title)
+ (output (markup-option node :title) engine))
+ (display " }\n")
+ (format #t " totalweight { ~a }\n" total-weight)
+ (format #t " initialangle { ~a }\n"
+ (or (markup-option node :initial-angle) 0))
+ (format #t " finger { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside) (if (markup-option node :fingers?)
+ "yes" "no"))
+ (else "no")))
+
+ ;; We assume `:radius' to be centimeters
+ (if (markup-option node :radius)
+ (printf " radius { ~ac }\n"
+ (markup-option node :radius)))
+
+ (format #t " labelradius { ~a }\n"
+ (case (markup-option node :labels)
+ ((outside #f) "external") ; FIXME: options are
+ ; not availble within
+ ; :before? (hence the #f)
+
+ ((inside) "internal")
+ (else
+ (skribe-error 'lout
+ "`:labels' should be one of 'inside or 'outside."
+ (markup-option node :labels)))))
+ (display "{\n")))
+ :after "\n} # @Pie\n")
+
+(markup-writer 'slice (find-engine 'lout)
+ :options '(:weight :detach? :color)
+ :action (lambda (node engine)
+ (display " @Slice\n")
+ (format #t " detach { ~a }\n"
+ (if (markup-option node :detach?)
+ "yes"
+ "no"))
+ (format #t " paint { ~a }\n"
+ (lout-color-specification (markup-option node
+ :color)))
+ (format #t " weight { ~a }\n"
+ (markup-option node :weight))
+
+ (display " label { ")
+ (output (markup-body node) engine)
+ (display " }\n")))
+
+(markup-writer 'sliceweight (find-engine 'base)
+ ;; This writer should work for every engine, provided the `pie' markup has
+ ;; a proper `&total-weight' option.
+ :action (lambda (node engine)
+ (let ((pct? (markup-option node :percentage?)))
+ (output (number->string
+ (pie-sliceweight-value node pct?))
+ engine))))
+
+;;; arch-tag: b5221e30-f80e-4b72-a281-83ce19ddb755