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

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