initial version

LICENSE

@@ -0,0 +1,17 @@
+Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation files
+(the "Software"), to deal in the Software without restriction,
+including without limitation the rights to use, copy, modify, merge,
+publish, distribute, sublicense, and/or sell copies of the Software,
+and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

adw-charting-google.asd

@@ -0,0 +1,38 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :net.acceleration.charting.system)
+    (defpackage :net.acceleration.charting.system
+      (:use :common-lisp :asdf))))
+
+(in-package :net.acceleration.charting.system)
+
+
+(defsystem :adw-charting-google
+  :description "Charting package to make graphs and charts using the Google chart API"
+  :author "Ryan Davis <ryan@acceleration.net>"
+  :licence "LGPL (or talk to me)"
+  :version "0.2"
+  :depends-on (#:drakma #:adw-charting)
+  :components ((:module :src
+			:components
+			((:module :google
+				  :components ((:file "packages")
+					       (:file "gchart" :depends-on ("packages"))))))))
+

adw-charting-vecto.asd

@@ -0,0 +1,43 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :net.acceleration.charting.system)
+    (defpackage :net.acceleration.charting.system
+      (:use :common-lisp :asdf))))
+
+(in-package :net.acceleration.charting.system)
+
+
+(defsystem :adw-charting-vecto
+  :description "Charting package to make pretty graphs and charts using Vecto"
+  :author "Ryan Davis <ryan@acceleration.net>"
+  :licence "LGPL (or talk to me)"
+  :version "0.2"
+  :depends-on (#:vecto #:adw-charting)
+  :components ((:module :src
+			:components
+			((:module :vecto
+				  :components ((:file "packages")
+					       (:file "charts" :depends-on ("packages"))
+					       (:file "pie-charts" :depends-on ("charts"))
+					       (:file "line-charts" :depends-on ("charts"))
+					       (:file "bar-charts" :depends-on ("line-charts"))
+					       (:file "star-rating-chart" :depends-on ("charts"))
+					       ))))))
+

adw-charting.asd

@@ -0,0 +1,37 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package :net.acceleration.charting.system)
+    (defpackage :net.acceleration.charting.system
+      (:use :common-lisp :asdf))))
+
+(in-package :net.acceleration.charting.system)
+
+
+(defsystem :adw-charting
+  :description "Charting package to make pretty graphs and charts"
+  :author "Ryan Davis <ryan@acceleration.net>"
+  :licence "LGPL (or talk to me)"
+  :version "0.2"
+  :depends-on (#:iterate)
+  :components ((:module :src
+			:components ((:file "packages")
+				     (:file "utils" :depends-on ("packages"))
+				     (:file "charting" :depends-on ("utils"))))))
+

doc/doc.lisp

@@ -0,0 +1,391 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(require 'cl-who)
+(require 'cl-ppcre)
+(require 'adw-charting)
+
+(defpackage :net.acceleration.documenter
+    (:nicknames #:adw-doc)
+  (:use #:cl #:cl-who #:cl-ppcre))
+
+(in-package :adw-doc)
+
+(defvar *root* (merge-pathnames #P"doc/"
+				(asdf:component-pathname
+				 (asdf:find-system :adw-charting))))
+
+(defvar *tree* )
+(defvar *stream* nil)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro defhtmlfun (name lambda-list &rest body)
+    `(defun ,name ,lambda-list
+      (with-html-output (*stream*)
+	,@body )))
+
+  (defmacro defhtmlmethod (name lambda-list &rest body)
+    `(defmethod ,name ,lambda-list
+      (with-html-output (*stream*)
+	,@body ))))
+
+(defhtmlfun stub ()
+  (:blink "STUB"))
+
+(defhtmlfun overview ()
+  (htm
+   (:p "ADW-Charting is a library that provides a simple interface to the "
+     (vecto-link)
+     " vector drawing library. It supports drawing on a canvas and saving the
+results to a PNG file. The API was designed to eliminate as many decisions as possible, and simply
+produce a reasonable result with minimal fuss.  It tries to scale various elements of the chart to
+fit nicely, but sometimes this goes awry." )
+   (:p "ADW-Charting depends on the following libraries:"
+     (:ul
+	 (:li (vecto-link))))
+
+   (:p "ADW-Charting's function interface is similar to "
+     (vecto-link)
+     "'s interface: you
+create charts by setting up a chart context and adding or setting information on that chart.")
+   (:p "There are many known limitations at this point. We've got some plans on how to solve
+some of these, and other aren't priorities for me, and might stay around for ahwile.")
+   (:ul 
+       (:li "All colors are RGB, represented as a list of 3 numbers between 0 and 1, eg:"
+	 (:code "'(1 .5 .3)"))
+     (:li "The bounds on a pie chart are a bit goofy, as the radius of the pie is currently 
+only determined by the height of the chart.  This means a square image will cut off the 
+legend.")
+     (:li "Another issue is with printing axis labels.  There's some code to try to keep 
+those reasonably spaces, but sometimes the labels start overlapping.  Making the graph
+in two passes should let us calculate everything before starting to draw on the canvas,
+preventing this issue.")
+     (:li "The font used for all the text is included in the distribution, some random .ttf file
+pulled from the debian freefont library.  You can specify the font file using the 
+*default-font-file* unexported variable.  I'm using a with-font macro internally that
+could solve this one."))
+   (:p "Related libraries"
+     (:ul
+	 (:li (:a :href "http://common-lisp.net/project/cl-plplot/" "cl-plplot"))))))
+
+(defhtmlfun examples ()
+  (htm
+   (:p "All examples are available in "
+     (:tt "test/examples.lisp")
+     " in the distribution.")))
+
+(defhtmlfun feedback ()
+  (htm
+   (:p "If you have any questions, comments, bug reports, or other feedback
+regarding ADW-Charting, please email "
+     (:a :href "mailto:ryan@acceleration.net" "Ryan Davis"))))
+
+(defhtmlfun vecto-link ()
+  (:a :href "http://www.xach.com/lisp/vecto/" "Vecto"))
+
+(defhtmlfun acknowledgements ()
+  (htm
+   (:p "Thanks to:")
+   (:ul (:li "Zach Beane for creating "
+	  (vecto-link))
+     (:li "Peter Seibel for his excellent book, "
+       (:a :href "http://gigamonkeys.com/book/" "Practical Common Lisp"))
+     (:li "Edi Weitz and Zach Beane for providing good examples on how to write and document lisp libraries")
+     (:li "Co-workers Nathan, Russ, and Rebecca for advice and code reviews"))))
+
+(defhtmlfun dictionary ()
+  (:p "The following symbols are exported from the ADW-CHARTING package."))
+
+(defclass section ()
+  ((title :accessor title :initarg :title)
+   (anchor :accessor anchor :initform (princ-to-string (gensym)))
+   (children :accessor children :initarg :children :initform nil)
+   (content-fn :accessor content-fn :initarg :content-fn :initform #'stub)))
+
+(defclass code (section)
+  ((code-type :accessor code-type :initarg :type)
+   (args :accessor args :initarg :args)
+   (return-val :accessor return-val :initarg :return-val)))
+
+(defun make-section (title content-fn &rest children)
+  (make-instance 'section :title title :children children :content-fn content-fn))
+
+(defun make-code (title content-fn code-type args &optional (return-val nil))
+  (make-instance 'code
+		 :title title
+		 :content-fn content-fn
+		 :type code-type
+		 :return-val return-val
+		 :args args))
+(defgeneric toc-entry (s))
+(defgeneric heading (s depth))
+
+(defhtmlmethod toc-entry ((s section))
+  (str (title s)))
+
+(defhtmlmethod toc-entry ((s code))
+  (:tt (str (title s))))
+
+(defhtmlfun toc (sections &optional (depth 0))
+  (flet ((fn ()
+	   (dolist (section sections)
+	     (let ((sub-sect (children section)))
+	       (htm (:li (:a :href (format nil "#~a" (anchor section))
+			     (toc-entry section))
+		      (when sub-sect (toc sub-sect (1+ depth)))))))))
+    (if (eq 0 depth)
+	(htm (:ol (fn)))
+	(htm (:ul (fn))))))
+
+
+(defhtmlmethod heading ((s section) depth)
+  (htm (:a :name (anchor s))
+       (cond
+	 ((eq 0 depth) (htm (:h2 (str (title s)))))
+	 ((eq 1 depth) (htm (:h3 (str (title s)))))
+	 ((eq 2 depth) (htm (:h4 (str (title s)))))
+	 (t (htm (:strong (str (title s))))))))
+
+(defhtmlmethod heading ((s code) depth)
+  (htm (:a :name (anchor s))
+       (:div "[" (str (code-type s)) "]")
+       (:strong (str (title s)))
+       (when (args s)
+	 (str " ")
+	 (show-args (args s)))
+       (when (return-val s)
+	 (htm (str " => ")
+	      (show-args (return-val s))))))
+
+(defhtmlfun show-args (args)
+  (loop for arg in args
+	counting T into i
+	do (show-arg arg)
+	(when (< i (length args))
+	  (htm (str " ")))))
+
+(defhtmlfun show-arg (arg)
+  (typecase arg
+    (null (htm (:em "nil")))
+    (list (if (symbolp (first arg))
+	      (let ((name (symbol-name (first arg))))
+		(cond 
+		  ((equal "QUOTE" name) (htm "'("
+					     (show-args (second arg))
+					     ")"))
+		  ((equal "FUNCTION" name) (htm "#'"
+						(show-arg (second arg))))
+		  (t (htm "("		
+			  (show-args arg)
+			  ")"))))
+	      (htm "("
+		   (show-args arg)
+		   ")")))
+    (number (str (princ-to-string arg)))
+    (symbol (let ((name (string-downcase (symbol-name arg))))
+	      (cond
+		((equal #\& (aref name 0)) (htm (:tt (str name))))
+		((equal "function" name) (str "#'"))
+		(t (htm (:em (str name)))))))))
+
+(defhtmlfun content (sections &optional (depth 0))
+  (dolist (sec sections)
+    (heading sec depth)
+    (htm (:div (funcall (content-fn sec))))
+    (when (children sec)
+      (content (children sec) (1+ depth)))))
+
+(defun get-sections ()
+  (list (make-section "Overview and Limitations" #'overview)
+	(make-section "Examples" #'examples
+		      (make-section "Minimal Pie Chart" #'minimal-pie)
+		      (make-section "Minimal Line Chart" #'minimal-line)
+		      (make-section "Customized Line Chart" #'customized-line)
+		      (make-section "Boinkmark" #'boinkmark)
+		      (make-section "Stuart Mackey 1" #'stuart-mackey-1))
+	(make-section "Dictionary" #'dictionary
+		      (make-code "with-pie-chart" #'with-chart "Macro"
+				 '((width height &key (background '(1 1 1))) &body body))
+		      (make-code "add-slice" #'add-slice "Function"
+				 '(label value &key color))
+		      (make-code "with-line-chart" #'with-chart "Macro"
+				 '((width height &key (background '(1 1 1))) &body body))
+		      (make-code "add-series" #'add-series "Function"
+				 '(label data &key (color nil)))
+		      (make-code "set-axis" #'set-axis "Function"
+				 '(axis title &key (draw-gridlines-p T)
+				   (label-formatter #'princ-to-string)
+				   (data-interval nil)))
+		      (make-code "save-file" #'save-file "Function"
+				 '(filename)
+				 '(truename)))
+	(make-section "Acknowledgements" #'acknowledgements)
+	(make-section "Feedback" #'feedback)))
+
+(defhtmlfun save-file ()
+  (:blockquote "Draws the chart as a png file to the given path."))
+
+(defhtmlfun set-axis ()
+  (:blockquote "Sets the axis on the current line chart.  "
+    (:em "axis")
+    " must be either "
+    (:tt ":x") " or " (:tt ":y") ".  The " (:tt "label-formatter")
+    " must be either a format control string or a function of 1 argument that
+returns a string with the desired axis label.  The axis printer will try to 
+pick decent intervals for labels, but it's still pretty dumb.  You can specify
+a data interval using the "
+    (:tt ":data-interval")
+    " parameter."))
+
+(defhtmlfun add-series ()
+  (:blockquote "Add another series to the line chart.  "
+    (:em "data")
+    " is a list of (x y) pairs.  A color will
+be automatically assigned if none is specified."))
+
+(defhtmlfun with-chart ()
+  (:blockquote
+      "Evaluates body with a chart established with the specified
+dimensions as the target for chart commands, with the specified background."))
+
+(defhtmlfun minimal-pie ()
+  (let ((filename (file-namestring
+		   (adw-charting-tests::minimal-pie-chart))))
+    (htm (:pre :style "height:210px"
+	       (:img :border 0 :align "right" :src (str filename))
+	       "(with-pie-chart (300 200)
+    (add-slice \"A\" 5.0d0)
+    (add-slice \"B\" 2.0d0)
+    (save-file \"minimal-pie-chart.png\"))"))))
+
+
+(defhtmlfun minimal-line ()
+  (let ((filename (file-namestring
+		   (adw-charting-tests::minimal-line-chart))))
+    (htm (:pre :style "height:310px"
+	       (:img :border 0 :align "right" :src (str filename))
+	       "(with-line-chart (400 300)
+    (add-series \"A\" '((-1 -2) (0 4) (1 5) (4 6) (5 -3)))
+    (add-series \"B\" '((-1 4) (0 -2) (1 6) (5 -2) (6 5)))
+    (save-file \"minimal-line-chart.png\"))"))))
+
+
+(defhtmlfun customized-line ()
+  (let ((filename (file-namestring
+		   (adw-charting-tests::customized-line-chart))))
+    (htm (:pre :style "height:310px"
+	       (:img :border 0 :align "right" :src (str filename))
+	       "(with-line-chart (400 300 :background '(.7 .5 .7))
+    (add-series \"A\" '((-.1 -.2) (0 .4) (.1 .5) (.4 .6) (.5 -.3)))
+    (add-series \"B\" '((-.1 .4) (0 -.2) (.1 .6) (.5 -.2) (.6 .5)))
+    (add-series \"C\"
+		'((-.1 0) (0 .3) (.1 .1) (.2 .5) (.4 -.6))
+		:color '(.3 .7 .9))
+    (set-axis :y \"widgets\" :label-formatter \"~,2F\")
+    (set-axis :x nil
+	      :draw-gridlines-p nil
+	      :label-formatter #'(lambda (v)
+				   ;;could do something more interesting here
+				   (format nil \"~,1F\" (expt 2 v))))
+    (save-file \"customized-line-chart.png\"))"
+	      ))))
+
+(defhtmlfun boinkmark ()
+  (let ((filename (file-namestring
+		   (adw-charting-tests::boinkmark))))
+    (htm (:pre :style "height:310px"
+	       (:img :border 0 :align "right" :src (str filename))
+"(with-line-chart (400 300)
+    (add-series \"baker: SBCL\"
+		(loop for row in +boink-data+
+		      for i from 0
+		      collect (list i (nth 4 row))))
+    (set-axis :y \"seconds\" :label-formatter \"~,2F\")
+    (set-axis :x nil
+	      :draw-gridlines-p nil
+	      :label-formatter #'(lambda (i)
+				   (nth 3 (nth i +boink-data+))))
+    (save-file \"boink.png\"))"
+	      ))))
+
+(defhtmlfun stuart-mackey-1()
+  (let ((filename (file-namestring
+		   (adw-charting-tests::stuart-mackey-1))))
+    (htm (:pre :style "height:310px"
+	       (:img :border 0 :align "right" :src (str filename))
+"(with-line-chart (400 300)
+    (add-series \"test\" '((1 0.0) (2 2.0) (3 3.0) (4 1.5)) :color '(0 0 1))
+    (set-axis :y \"amount\" :label-formatter \"~,2f\")
+    (set-axis :x \"days\" :data-interval 1
+	      :draw-gridlines-p nil	   
+	      :label-formatter (lambda (v) (format nil \"~d\" (round v))))
+    (save-file \"stuart-mackey-1.png\"))"
+
+
+	      ))))
+
+(defhtmlfun add-slice ()
+  (:blockquote "Adds a slice to the chart, with an optional color.  A color will
+be automatically assigned if none is specified."))
+
+
+
+(defun adw-charting-doc ()
+  (let ((title "ADW-Charting - simple chart drawing with Common Lisp")
+	(canonical-url "http://common-lisp.net/project/adw-charting/")
+	(download-url "http://common-lisp.net/project/adw-charting/adw-charting.tar.gz")
+	(sections (get-sections))
+	(outfile (merge-pathnames *root* #P"./index.html")))
+    (setf adw-charting-tests::*root* *root*)
+    (with-open-file (*stream* outfile
+			      :direction :output
+			      :if-exists :supersede
+			      :if-does-not-exist :create)
+      (with-html-output (*stream* nil :prologue T)
+	(:html
+	    (:head
+		(:title (str title))
+	      (:style :type "text/css"
+		      (str "
+      a, a:visited { text-decoration: none }
+      a[href]:hover { text-decoration: underline }
+      pre { background: #DDD; padding: 0.25em }
+      p.download { color: red }
+      a.top {font-size:smallest;}"))
+	      )
+	  (:body (:h1 (str title))
+	    (:blockquote (:h2 "Abstract")
+	      (:p "ADW-Charting is a simple chart drawing library for quickly
+creating nice-looking pie charts and line charts.  It presents a function-oriented
+interface similar to "
+		(vecto-link)
+		", and saves results to PNG.  Since ADW-Charting and all supporting
+libraries are written completely in Common Lisp, without depending on external
+non-Lisp libraries, it should work in any Common Lisp environment. ADW-Charting is
+available under a BSD-like license. The 'ADW' in the name is referencing my
+employer, "
+		(:a :href "http://www.acceleration.net" "Acceleration.net")
+		", who has sponsored much of this work.  The current version is 0.7,
+released on January 28th, 2008.")
+	      (:p "The canonical location for ADW-Charting is "
+		(:a :href canonical-url (str canonical-url)))
+	      (:p :class "download" "Download shortcut:")
+	      (:a :href download-url (str download-url)))
+	    (:h2 "Contents")
+	    (toc sections)
+	    (content sections)
+	    ))))))

doc/docs.org

@@ -0,0 +1,312 @@
+#ADW-CHARTING -*- mode:org -*-
+#+TITLE: ADW-Charting: simple charts in Common Lisp
+#+AUTHOR: Ryan Davis
+#+EMAIL: ryan@acceleration.net
+#+OPTIONS: toc:2
+	 
+* Introduction
+ADW-Charting is a simple chart drawing library for quickly creating 
+reasonable-looking charts. It presents a 
+function-oriented interface similar to [[http://www.xach.com/lisp/vecto/][Vecto]], 
+and saves results to PNG. Since ADW-Charting and all supporting 
+libraries are written completely in Common Lisp, without 
+depending on external non-Lisp libraries, it should work 
+in any Common Lisp environment. ADW-Charting is available 
+under a BSD-like license. The 'ADW' in the name is 
+referencing my employer, [[http://www.acceleration.net][Acceleration.net]], who has 
+sponsored much of this work. The current version is 0.8, 
+released on August 25th, 2009.
+
+The canonical location for ADW-Charting is http://common-lisp.net/project/adw-charting/
+
+Download shortcut:
+http://common-lisp.net/project/adw-charting/adw-charting.tar.gz
+
+* Installation
+ADW-Charting is not yet asdf-installable, but that is on the [[file:todo.org][todo list]].
+For now, download the tarball at http://common-lisp.net/project/adw-charting/adw-charting.tar.gz
+or go straight to the darcs repository located at http://common-lisp.net/project/adw-charting/darcs/adw-charting
+
+* Rendering Backends
+ADW-Charting has two rendering backends, one using Vecto to create PNG
+files directly, another using the Google Chart API to let Google
+handle the drawing duties.  Each has it's pros and cons, and is
+activated by loading a different .asd file.  You can use both at the
+same time.  They are both actively developed (albeit at a snail's
+pace).
+** Vecto backend, adw-charting-vecto.asd
+Pros:
+- pure lisp solution, total control is available
+- size and data density are only limited by computing resources 
+Cons:
+- conses an awful lot
+- generated PNGs don't display in Microsoft image viewer, must be
+  viewed via a browser (IE shows them fine)
+** Google backend, adw-charting-google.asd
+With this renderer, adw-charting assembles the url parameters and
+makes HTTP calls (using Drakma) to Google's chart service, or can give
+you the url directly.
+
+Pros:
+- much less CPU intensive
+- images are served using Google's bandwidth, not yours
+- simple charts frequently look better
+- more chart features are available, although many aren't yet implemented in the vecto backend
+Cons:
+- limited to 300,000 pixels per image (which is smaller than you think)
+- Google's label placement can be screwy sometimes
+- requires the lisp be connected to the internet
+- depends on a third party service that might be shut off tomorrow
+- any sensitive information would travel to another server via http
+- can't graph large datasets (all data has to be passed on the
+  querystring)
+** Which one should you use?
+The answer is always "it depends".  I generally use the google backend
+for public data, or if I want to use a chart feature that is not
+implemented in the Vecto backend.  I use vecto backend for private
+data, when I want a very large chart, or when I want to work
+disconnected.
+
+Eventually, I would like to improve the performance and functionality
+of the vecto backend to the point that the google backend is
+redundant.
+* Sample Usage
+Here are a very basic examples.  More can be found in the [[file:gallery.org][gallery]].
+** loading adw-charting into your lisp
+To use the Vecto backend:
+#+begin_src lisp
+(asdf:oos 'asdf:load-op 'adw-charting-vecto)
+#+end_src
+
+To use the Google backend:
+#+begin_src lisp
+(asdf:oos 'asdf:load-op 'adw-charting-google)
+#+end_src
+You can use both at once if you want to mix-and-match backends.
+** minimal pie chart
+A simple pie chart using Vecto to generate the PNG file:
+*** vecto backend
+#+INCLUDE "../examples/minimal-pie-chart-vecto.lisp" src lisp
+[[file:minimal-pie-chart-vecto.png]]
+ 
+*** google backend
+The same pie chart using the Google Chart API to generate the PNG:
+#+INCLUDE "../examples/minimal-pie-chart-google.lisp" src lisp
+file:minimal-pie-chart-google.png
+
+** minimal line chart
+*** vecto backend
+#+INCLUDE "../examples/minimal-line-chart-vecto.lisp" src lisp
+[[file:minimal-line-chart-vecto.png]]
+
+*** google backend
+#+INCLUDE "../examples/minimal-line-chart-google.lisp" src lisp
+[[file:minimal-line-chart-google.png]]
+
+** minimal bar chart
+*** vecto backend
+#+INCLUDE "../examples/minimal-bar-chart-vecto.lisp" src lisp
+[[file:minimal-bar-chart-vecto.png]]
+
+*** google backend
+#+INCLUDE "../examples/minimal-bar-chart-google.lisp" src lisp
+[[file:minimal-bar-chart-google.png]]
+
+** star ratings
+This is a vecto-only chart:
+#+INCLUDE "../examples/star-rating.lisp" src lisp
+[[file:star-rating.png]]
+
+Be sure the width is at least 5 times the height.
+
+* Caveats / Gotchas
+#<<colors>>
+- All colors are RGB, represented as a list of 3 numbers between 0 and 1, eg: =(list 1 .5 .3)=
+- The bounds on a pie chart are a bit goofy, as the radius of the pie is currently only determined by the height of the chart. This means a square image will cut off the legend.
+- The font used for all the text is included in the distribution, some random .ttf file pulled from the debian freefont library. You can specify the font file using the =*default-font-file*= unexported variable. I'm using a with-font macro internally that could solve this one.
+- Many things should be converted to vectors.  See the [[file:todo.org][todo]] for other caveats along these lines.
+
+* Known Bugs
+** bar charts with many series (lots of bars) can run over the right edge of the graph
+** 
+* Feedback
+If you have any questions, comments, bug reports, or other 
+feedback regarding ADW-Charting, please [[mailto:ryan@acceleration.net][email me]].
+
+Progress and previews are occasionally available on my blog:
+http://ryepup.unwashedmeme.com/blog/category/adw-charting/
+
+* API reference
+adw-charting is split into 3 .asd files:
+- adw-charting.asd: covers a common based used by the backends
+- adw-charting-vecto.asd: covers rendering with Vecto
+- adw-charting-google.asd: covers rendering with Google
+
+These all export functions into the adw-charting package.
+
+In most cases, to render a chart you call some =with-*= variant to
+create a chart context, call functions in that context to configure
+the chart, then call a =save-*= function to perform the rendering.  Most
+functions will not work if they called outside a chart context, with a
+few exceptions.
+
+If something below is marked as _experimental_, that means it probably doesn't work.
+
+Many functions unintentionally return values.  Only intentional return values are listed below.
+** Creating a chart
+*** with-chart
+#+begin_src lisp
+(defmacro with-chart ((type width height &key (background '(1 1 1))) &body body))
+#+end_src
+Initializes a vecto chart.
+**** =type= determines how the chart is rendered.  Must be one of:
+- :line - normal line chart
+- :bar - normal bar chart
+- :pie - normal pie chart
+- :star-rating - displays a percentage as partially filled stars.  See the [[*star%20rating][star rating example]].  Be sure the width is at least 5 times the height for this chart type.
+**** =width= image width in pixels
+**** =height= image height in pixels
+**** =background= is an optional background color for the chart, defaulting to white.
+*** with-gchart 
+#+begin_src lisp
+(defmacro with-gchart ((type width height &key (background '(1 1 1))) &body body))
+#+end_src
+Initializes a google chart.
+**** =type= determines how the chart is rendered.  Must be one of:
+- :pie - normal pie chart
+- :pie-3d - 3d pie chart
+- :line - normal line chart
+- :v-bar - bar chart with bars rising vertically (stacked)
+- :h-bar - bar chart with bars rising horizontally
+- :v-gbar - ?
+- :h-gbar - ?
+**** =width= image width in pixels
+**** =height= image height in pixels
+**** =background= is an optional background color for the chart, defaulting to white.
+*** google-o-meter
+#+begin_src lisp
+(defun google-o-meter (percentage width &key label colors show-percentage)) => url
+#+end_src
+The meter is very different from other charts types, so has it's own little function.  Image height is calculated from the width.
+
+It currently only returns the URL needed to fetch the chart from google, and creating a PNG from that is not part of this library.
+**** =percentage= returns the URL to request to get the google-o-meter chart
+**** =width= image width in pixels
+**** =label= a title to have on the meter
+**** =colors= a list of [[colors]] used to make the gradient on the meter
+**** =show-percentage= when non-nil, print the =percentage= on the meter
+*** deprecated
+- =with-pie-chart=: use =(with-chart (:pie ...= 
+- =with-line-chart=: use =(with-chart (:line ...=  
+- =with-bar-chart=: use =(with-chart (:bar ...= 
+** Modifying a chart
+*** pie charts
+**** add-slice
+#+begin_src lisp
+(defun add-slice (label value &key color))
+#+end_src
+Adds a slice to the pie.  
+***** =label= a string to identify this slice
+***** =value= any number
+***** =color= a color for this slice, see [[colors]].  A unique color will be automatically assigned.
+*** bar and line charts
+**** add-series
+#+begin_src lisp
+(defun add-series (label data &key color (mode 'default)))
+#+end_src
+***** =label= a string to identify this series
+***** =data= a list of =(x y)= pairs
+***** =color= a color for this series, see [[colors]].  A unique color will be automatically assigned.
+***** =mode= _experimental_ use =:line= on bar charts to render this series as a line instead of a bar.
+**** set-axis
+#+begin_src lisp
+(defun set-axis (axis title &key draw-gridlines-p
+		 (label-formatter #'default-label-formatter)
+		 (mode :value)
+		 data-interval
+		 scalefn
+		 draw-zero-p
+		 angle))
+#+end_src
+***** =axis= which axis you'd like to configur, must be =:x= or =:y=
+***** =title= a string used to label the axis.  nil for no axis label
+***** =draw-gridlines-p= when non-nil, draws fairly ugly lines that match with the axis labels
+***** =label-formatter= determines how values from your data is converted to axis labels.  You can pass this:
+ 1) a function of 1 argument
+ 2) a string to be used as the control string to a =format= call
+
+The default tries to format values in usually acceptable way.
+***** =draw-zero-p= if non-nil, force this axis to show 0, even if it is notcontained within the data.
+***** =data-interval= a number that should be used as the interval whendrawing axis labels.  If nil, a suitable interval will be chosenautomatically.
+***** =mode= _experimental_ determines how the axis values are calculated, intended be used to specify non-ordered axis values in the future.
+***** =scalefn= _experimental_ a function used to scale data on this axis before rendering.  Currently only respected by the google backend, and I'm not sure why.
+***** =angle= _experimental_ used to rotate axis label text
+*** vecto star-rating charts
+**** set-rating
+#+begin_src lisp
+(defun set-rating (rating))
+#+end_src
+Determines how much of the stars are filled in.
+***** =rating= the number of stars to fill, as a number, with a max of 5.
+**** set-color
+#+begin_src lisp
+(defun set-color (color))
+#+end_src
+Determines star color.
+***** =color= a color for the stars, see [[colors]].
+*** google charts
+**** <<add-feature>>
+#+begin_src lisp
+(defgeneric add-feature (feature-name))
+#+end_src
+Google charts have many options that can be turned on, and these are modeled as features
+***** =feature-name= a keyword indicating what google option to enable.
+=feature-name= must be one of:
+
+ 1) =:label= adds slice/series labels
+ 2) =:transparent-background= renders the png with a transparent background
+ 3) =:adjusted-zero= adjust the zero line of the chart to match your data.  See [[http://code.google.com/apis/chart/styles.html#zero_line][bar chart zero line]].
+ 4) =:data-scaling= calculate graph bounds based on your data.  See [[http://code.google.com/apis/chart/formats.html#data_scaling][data scaling]].
+ 5) =:label-percentages= add percentages after labels on pie charts (automatically adds the =:label= feature)
+**** add-features
+#+begin_src lisp
+(defun add-features (&rest names))
+#+end_src
+Calls [[add-feature][=add-feature=]] for each item in =names=.
+***** =names= list of keywords applicable for [[add-feature][=add-feature=]]. 
+**** add-title
+#+begin_src lisp
+(defmethod add-title (title))
+#+end_src
+Sets the [[http://code.google.com/apis/chart/labels.html#chart_title][chart title]].
+***** =title= string to be used for the title of the chart
+** Saving the chart
+These methods are implemented for google and vecto backends.  All output is in PNG format.
+*** save-file
+#+begin_src lisp
+(defun save-file (filename)) => truename
+#+end_src
+Returns the truename of the newly written file.
+**** =filename= the path to save as, will automatically overwrite
+*** save-stream
+#+begin_src lisp
+(defun save-stream (stream))
+#+end_src
+**** =stream= the stream to write PNG output to
+** Google misc functions
+*** make-color
+#+begin_src lisp
+(defun make-color (html-color)) => color
+#+end_src
+Converts a string into a [[colors][color]].
+**** =html-color= a hex string like an html color (eg: "aa4422")
+*** chart-url
+#+begin_src lisp
+(defun chart-url ()) => url
+#+end_src
+Calculates the URL needed to generate the google chart, returns it as a string.
+* Acknowledgements
+- Zach Beane for creating [[http://www.xach.com/lisp/vecto/][Vecto]]
+- Peter Seibel for his excellent book, [[http://gigamonkeys.com/book][Practical Common Lisp]]
+- Edi Weitz and Zach Beane for providing good examples on how to write and document lisp libraries
+- Co-workers [[http://the.unwashedmeme.com][Nathan]], [[http://russ.unwashedmeme.com/blog][Russ]], and Rebecca for advice and code reviews

doc/gallery.org

@@ -0,0 +1,66 @@
+#ADW-CHARTING -*- mode:org -*-
+#+TITLE: ADW-Charting: gallery of example charts
+#+AUTHOR: Ryan Davis
+#+EMAIL: ryan@acceleration.net
+#+OPTIONS: toc:2
+
+This page has some sample charts.  I use this largely as a way to tell if things are working or not.  Most bug reports end up in this file.
+* Vecto backend
+** minimal pie
+#+INCLUDE "../examples/minimal-pie-chart-vecto.lisp" src lisp
+[[file:minimal-pie-chart-vecto.png]]
+
+** larger pie
+#+INCLUDE "../examples/larger-pie-vecto.lisp" src lisp
+file:larger-pie-vecto.png
+** minimal line
+#+INCLUDE "../examples/minimal-line-chart-vecto.lisp" src lisp
+[[file:minimal-line-chart-vecto.png]]
+
+** larger line
+#+INCLUDE "../examples/larger-line-vecto.lisp" src lisp
+file:larger-line-vecto.png
+** minimal bar
+#+INCLUDE "../examples/minimal-bar-chart-vecto.lisp" src lisp
+[[file:minimal-bar-chart-vecto.png]]
+
+** too many bars
+#+INCLUDE "../examples/too-many-bars-vecto.lisp" src lisp
+[[file:too-many-bars-vecto.png]]
+
+** star rating
+#+INCLUDE "../examples/star-rating.lisp" src lisp
+[[file:star-rating.png]]
+
+** Mackey
+#+INCLUDE "../examples/mackey.lisp" src lisp
+file:mackey.png
+
+This came from a bug report from Stuart Mackey.
+** Seibel
+These charts are too big for google to generate.
+#+INCLUDE "../examples/seibel.lisp" src lisp
+file:seibel-1.png
+file:seibel-2.png
+
+This came from a bug report from Peter Seibel.
+
+* Google backend
+** minimal pie
+#+INCLUDE "../examples/minimal-pie-chart-google.lisp" src lisp
+file:minimal-pie-chart-google.png
+** minimal bar
+#+INCLUDE "../examples/minimal-bar-chart-google.lisp" src lisp
+[[file:minimal-bar-chart-google.png]]
+
+** 3-D pie chart
+#+INCLUDE "../examples/pie-3d-google.lisp" src lisp
+file:pie-3d-google.png
+
+** various bar chart types
+#+INCLUDE "../examples/bar-chart-google.lisp" src lisp
+file:bar-chart-google-V-BAR.png file:bar-chart-google-H-BAR.png file:bar-chart-google-V-GBAR.png
+
+** minimal line
+#+INCLUDE "../examples/minimal-line-chart-google.lisp" src lisp
+[[file:minimal-line-chart-google.png]]

doc/make-docs.lisp

@@ -0,0 +1,51 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;load up both backends
+(require 'adw-charting-vecto)
+(require 'adw-charting-google)
+(require 'cl-fad)
+
+
+(defpackage #:make-docs
+  (:use #:cl #:adw-charting))
+
+(in-package #:make-docs)
+
+
+;; run all the snippets
+(defun load-examples ()
+  (dolist (file (cl-fad:list-directory
+		   (merge-pathnames
+		    "examples/"
+		    (asdf:component-pathname
+		     (asdf:find-system :adw-charting)))))
+    (when (string-equal "lisp"
+			(pathname-type file))
+      (ignore-errors (load file))
+      (format T "Loaded ~a~%" (pathname-name file)))))
+
+#|
+(load-examples)
+;;move *.png to
+(merge-pathnames
+ "doc/"
+ (asdf:component-pathname
+  (asdf:find-system :adw-charting)))
+(quit)
+|#

doc/todo.org

@@ -0,0 +1,31 @@
+#ADW-CHARTING -*- mode:org -*-
+#+STARTUP: hidestars
+#+STARTUP: logdone
+#+AUTHOR: Ryan Davis
+#+EMAIL: ryan@acceleration.net
+#+TITLE: ADW-Charting: Plans
+#+OPTIONS: num:nil
+
+* Fall 2009
+** process incoming patches
+   have gotten a few via email
+** get it asdf-installable
+* Spring 2010
+** convert repo to git
+** cleanup dead code
+** review vecto backend, refactor with current knowledge
+   when I wrote a lot of this I was obsessed with mapcar and unfamilair with loop/iterate,
+   and much code can be eliminated or made much clearer with loop/iterate
+** signal an error when specifying a google chart that is too big for the google service
+   maybe provide a restart to use the biggest valid height/width that keeps the aspect ratio?
+** pull in alexandria for common utils
+   might not be needed
+* Summer 2010
+** look at a smarter way to pick points/labels/bounds
+   - change the order in which elements are drawn and keep counters to manage visual dependencies
+* Future
+** move into a different place on clnet containing other ADW libraries
+   We have a growing number of libraries at work that could be opened up,
+   and it might be best to have an "ADW" umbrella project similar to arnesi to
+   contain our many sub-projects.
+   

examples/bar-chart-google.lisp

@@ -0,0 +1,7 @@
+(dolist (chart-type '(:v-bar :h-bar :v-gbar))
+  (with-gchart (chart-type 400 300)
+    (add-series "A" '((-1 -2) (0 4) (1 5) (4 6) (5 -3)))
+    (add-series "B" '((-1 4) (0 -2) (1 6) (5 -2) (6 5)) :color (make-color "ff0000"))
+    (add-features :label)
+    (add-title chart-type)
+    (save-file (format nil "bar-chart-google-~a.png" chart-type))))

examples/benchmarking.lisp

@@ -0,0 +1,73 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+(require 'cl-ppcre)
+(defpackage #:net.acceleration.adw-charting-benchmarking
+  (:use #:cl))
+
+(in-package #:net.acceleration.adw-charting-benchmarking)
+
+(defun timing-graph ()
+  (adw-charting:with-line-chart (300 400)
+    (adw-charting:set-axis :x "series")
+    (adw-charting:set-axis :y "real time (ms)")
+
+    (loop for x from 1 to 3
+       do
+	 (let ((dp (* 10 x)))
+	   (adw-charting:add-series
+	    (format nil "~ap" dp)
+	    (loop for i from 1 to 20
+	       collect (list i (first (timings i dp)))))
+	   (format T "done with ~a run" dp)))
+
+    (adw-charting:save-file "series-real-time.png")
+    ))
+
+(defun timings (series points)
+  (let* ((trc (with-output-to-string (*trace-output*)
+	       (time (lines series points))))
+	 (rt (cl-ppcre:register-groups-bind (rt)
+		 ("([\\d\\.]+) seconds of real" trc)
+	       (parse-integer (cl-ppcre:regex-replace-all "\\." rt ""))))
+	 (bc (cl-ppcre:register-groups-bind (rt)
+		 ("([\\d\\,]+) bytes" trc)
+	       (parse-integer (cl-ppcre:regex-replace-all "\\," rt "")))))
+    (list rt bc)))
+
+(defun lines (num-series points-per-series)
+  (adw-charting:with-line-chart (300 400)
+    (dotimes (s num-series)
+      (adw-charting:add-series (format nil "s~a" s)
+			       (random-series points-per-series
+					      0 -100 100 100))
+      )
+    (adw-charting:save-file "benchmarking")))
+
+(defun random-between (min max)
+  (+ min
+     (random (float (- max min)))))
+
+(defun random-point (min-x min-y max-x max-y)
+  (list (random-between min-x max-x)
+	(random-between min-y max-y)))
+
+(defun random-series (n min-x min-y max-x max-y)
+  (sort 
+   (loop for i from 1 to n
+      collect (random-point min-x min-y max-x max-y))
+   #'< :key #'first))

examples/examples.lisp

@@ -0,0 +1,197 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(defpackage #:net.acceleration.adw-charting-examples
+  (:use #:cl #:adw-charting))
+
+(in-package #:net.acceleration.adw-charting-examples)
+
+(defvar +boink-data+ '((3220487700 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.0"
+                 9.179666666666666d0 0.039405685894399696d0)
+                (3221090100 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.1"
+                 9.539666666666667d0 0.007055336829103466d0)
+                (3225916800 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.2"
+                 10.753d0 0.003999999999687438d0)
+                (3228681600 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.3"
+                 10.614333333333335d0 0.013920408678669564d0)
+                (3231187200 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.4"
+                 10.520666666666665d0 0.015452435982315785d0)
+                (3233834588 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.5"
+                 4.021333333333334d0 0.003527668414327933d0)
+                (3236416994 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.6" 0.636d0
+                 0.0027325202042536483d0)
+                (3239264050 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.7"
+                 0.6373333333333333d0 0.001333333333343252d0)
+                (3242035118 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.8"
+                 0.6346666666666666d0 0.0026666666666726262d0)
+                (3244543999 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.9" 0.636d0
+                 0.004000000000002d0)
+                (3247393629 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.10"
+                 0.6346666666666666d0 0.001333333333343252d0)
+                (3250352729 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.11"
+                 0.6373333333333333d0 0.003527668414751055d0)
+                (3252508216 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.12"
+                 0.6306666666666666d0 0.001333333333343252d0)
+                (3255207859 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.13"
+                 0.6306666666666666d0 0.001333333333343252d0)
+                (3257502170 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.7.14"
+                 1.168d0 0.0d0)
+                (3260700452 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8alpha.0"
+                 1.1833333333333333d0 0.0023333333333272308d0)
+                (3262809600 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.0"
+                 1.1765d0 0.001962141687032421d0)
+                (3265401600 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.1"
+                 1.1726666666666667d0 0.0028713140623054215d0)
+                (3268166400 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.2" 1.17d0
+                 0.0028751811537286397d0)
+                (3270758400 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.3"
+                 1.1793333333333333d0 0.001173787790758412d0)
+                (3274128000 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.4"
+                 1.1716666666666666d0 0.0022310934040787145d0)
+                (3276028800 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.5"
+                 1.3576666666666666d0 0.07292218074388936d0)
+                (3278707200 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.6"
+                 1.1906666666666668d0 0.0018196458751748993d0)
+                (3281644800 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.7"
+                 0.6421666666666667d0 0.001939358427709689d0)
+                (3286648345 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.8"
+                 0.6383333333333333d0 8.819171036882883d-4)
+                (3289119215 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.9"
+                 0.6416666666666667d0 0.0022900752049719864d0)
+                (3291898308 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.10"
+                 0.6426666666666666d0 0.0032110918876810885d0)
+                (3295630912 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.11"
+                 0.6416666666666667d0 0.001873795909670684d0)
+                (3297188109 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.12"
+                 0.6365d0 0.0010567244989399649d0)
+                (3299770631 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.13"
+                 0.6415000000000001d0 0.0028017851452220664d0)
+                (3302885185 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.14"
+                 0.6415000000000001d0 0.0020124611797470242d0)
+                (3310671599 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.17"
+                 0.6451666666666668d0 0.0028684103224187445d0)
+                (3313262280 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.18"
+                 0.6411666666666666d0 0.0012758439472729923d0)
+                (3315681384 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.19"
+                 0.6441666666666667d0 0.0030704686576772137d0)
+                (3318629528 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.20"
+                 0.6486666666666666d0 0.003158762064130637d0)
+                (3320916959 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.8.21"
+                 0.6503333333333333d0 0.002905932629030691d0)
+                (3323359736 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.0"
+                 0.6558888888888889d0 0.010010334166423676d0)
+                (3326119900 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.1"
+                 0.6521666666666667d0 0.00805834155933214d0)
+                (3328891845 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.2"
+                 0.6515000000000001d0 0.007651005083508171d0)
+                (3331319566 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.3"
+                 0.6654444444444445d0 0.006815602161582924d0)
+                (3334064418 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.4"
+                 0.6653888888888889d0 0.00645048454829305d0)
+                (3336814695 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.5" 0.664d0
+                 0.006476698159372025d0)
+                (3339362596 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.6"
+                 0.6683809523809523d0 0.0062241756732752465d0)
+                (3342185572 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.7"
+                 0.6665000000000001d0 0.006690765267835046d0)
+                (3344689134 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.8"
+                 0.6602777777777777d0 0.006360522420458006d0)
+                (3347288951 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.9"
+                 0.6913333333333335d0 0.02761568870454336d0)
+                (3349994883 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.10"
+                 0.6886666666666666d0 0.026655300608041676d0)
+                (3352402754 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.11"
+                 0.6636666666666666d0 0.007523028618579228d0)
+                (3355054163 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.12"
+                 0.6662499999999999d0 0.00794023604717486d0)
+                (3357748000 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.13"
+                 0.66825d0 0.007894306540638947d0)
+                (3360332432 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.14"
+                 0.6666666666666666d0 0.008575275711914507d0)
+                (3362932220 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.15"
+                 0.66575d0 0.008568905202162075d0)
+                (3365526402 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.16"
+                 0.666d0 0.008520919000087585d0)
+                (3368276815 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.17"
+                 0.6604166666666667d0 0.006870510471676585d0)
+                (3370773520 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "0.9.18"
+                 0.663d0 0.008255393094911835d0)
+                (3373839403 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0"
+                 0.6686666666666666d0 0.006528879124801801d0)
+                (3376130264 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.1"
+                 0.6531666666666667d0 0.008683695391742307d0)
+                (3378725494 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.2"
+                 0.6606666666666666d0 0.00855404683011041d0)
+                (3381591822 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.3"
+                 0.6629999999999999d0 0.007874007874012367d0)
+                (3386771278 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.5"
+                 0.6925d0 0.007027327609647438d0)
+                (3389213608 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.6"
+                 0.6803333333333333d0 0.009360890055238592d0)
+                (3391973049 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.7"
+                 0.6866666666666666d0 0.007913675671029945d0)
+                (3394355973 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.8"
+                 0.6823333333333333d0 0.007343656645656509d0)
+                (3397158615 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.9"
+                 0.6728333333333333d0 0.007504375827852276d0)
+                (3399722304 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.10"
+                 0.6616666666666666d0 0.009451096884660209d0)
+                (3402332883 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.11"
+                 0.6703333333333333d0 0.010286305498480806d0)
+                (3405022435 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.12"
+                 0.6683333333333333d0 0.008534540634292589d0)
+                (3407746349 "baker" "SBCL,(:ARCH :EMULATED-X86 :FEATURES NIL)" "1.0.13"
+                 0.6656666666666667d0 0.008647414514048853d0)))
+
+(defun boinkmark ()
+  (with-line-chart (400 300)
+    (add-series "baker: SBCL"
+		(loop for row in +boink-data+
+		      for i from 0
+		      collect (list i (nth 4 row))))
+    (set-axis :y "seconds" :label-formatter "~,2F")
+    (set-axis :x nil
+	      :draw-gridlines-p nil
+	      :label-formatter #'(lambda (i)
+				   (nth 3 (nth i +boink-data+))))
+    (save-file "boink.png")))
+
+(defun random-between (min max)
+  (+ min
+     (random (float (- max min)))))
+
+(defun random-point (min-x min-y max-x max-y)
+  (list (random-between min-x max-x)
+	(random-between min-y max-y)))
+
+(defun random-series (n min-x min-y max-x max-y)
+  (sort 
+   (loop for i from 1 to n
+      collect (random-point min-x min-y max-x max-y))
+   #'< :key #'first))
+
+(defun mixed-mode ()
+  "uses the :mode argument to add-series to mix different types of charts"
+  (with-line-chart (400 300)
+    (add-series "line" (random-series 20 0 -10 20 10))
+
+    (set-axis :y "foos" :label-formatter "~,2f")
+    (set-axis :x "bars"
+			   :label-formatter "~,2f"
+			   :draw-gridlines-p nil)
+    (save-file "mixed-mode.png")))

examples/larger-line-vecto.lisp

@@ -0,0 +1,11 @@
+(with-chart (:line 400 300 :background '(.7 .5 .7))
+  (add-series "A" '((-.1 -.2) (0 .4) (.1 .5) (.4 .6) (.5 -.3)))
+  (add-series "B" '((-.1 .4) (0 -.2) (.1 .6) (.5 -.2) (.6 .5)))
+  (add-series "C" '((-.1 0) (0 .3) (.1 .1) (.2 .5) (.4 -.6))
+	      :color '(.3 .7 .9))
+  (set-axis :y "widgets" :label-formatter "~,2F")
+  (set-axis :x nil
+	    :label-formatter #'(lambda (v)
+				 ;;could do something more interesting here
+				 (format nil "~,1F" (expt 2 v))))
+  (save-file "larger-line-vecto.png"))

examples/larger-pie-vecto.lisp

@@ -0,0 +1,8 @@
+(with-chart (:pie 300 200)
+    (loop for (label value) in '(("A" 400)
+				 ("B" 217)
+				 ("C" 212.5)
+				 ("D" 350)
+				 ("E" 1000))
+	  do (add-slice label value))
+    (save-file "larger-pie-vecto.png"))

examples/mackey.lisp

@@ -0,0 +1,6 @@
+(with-chart (:line 400 300)
+  (add-series "test" '((1 0.0) (2 2.0) (3 3.0) (4 1.5)) :color '(0 0 1))
+  (set-axis :y "amount" :label-formatter "~,2f")
+  (set-axis :x "days" :data-interval 1
+	    :label-formatter (lambda (v) (format nil "~d" (round v))))
+  (save-file "mackey.png"))

examples/minimal-bar-chart-google.lisp

@@ -0,0 +1,6 @@
+(with-gchart (:v-bar 300 200)
+  (add-series "Rank" '((0 10) (1 18) (2 19) (3 17)))
+  (set-axis :y "Bang")
+  (set-axis :x "Buck")
+  (add-feature :label)
+  (save-file "minimal-bar-chart-google.png"))

examples/minimal-bar-chart-vecto.lisp

@@ -0,0 +1,5 @@
+(with-chart (:bar 300 200)
+  (add-series "Rank" '((0 10) (1 18) (2 19) (3 17)))
+  (set-axis :y "Bang")
+  (set-axis :x "Buck")
+  (save-file "minimal-bar-chart-vecto.png"))

examples/minimal-line-chart-google.lisp

@@ -0,0 +1,6 @@
+(with-gchart (:line 300 200)
+  (add-series "Rank" '((0 10) (1 18) (2 19) (3 17)))
+  (set-axis :y "Bang")
+  (set-axis :x "Buck")
+  (add-feature :label)
+  (save-file "minimal-line-chart-google.png"))

examples/minimal-line-chart-vecto.lisp

@@ -0,0 +1,5 @@
+(with-chart (:line 300 200)
+  (add-series "Rank" '((0 10) (1 18) (2 19) (3 17)))
+  (set-axis :y "Bang")
+  (set-axis :x "Buck")
+  (save-file "minimal-line-chart-vecto.png"))

examples/minimal-pie-chart-google.lisp

@@ -0,0 +1,5 @@
+(with-gchart (:pie 300 200)
+  (add-slice "A" 5.0d0)
+  (add-slice "B" 2.0d0)
+  (add-features :label)
+  (save-file "minimal-pie-chart-google.png"))

examples/minimal-pie-chart-vecto.lisp

@@ -0,0 +1,4 @@
+(with-chart (:pie 300 200)
+  (add-slice "A" 5.0d0)
+  (add-slice "B" 2.0d0)
+  (save-file "minimal-pie-chart-vecto.png"))

examples/pie-3d-google.lisp

@@ -0,0 +1,6 @@
+(with-gchart (:pie-3d 400 200)
+  (add-slice "foo" 10d0)
+  (add-slice "bar" 10d0)
+  (add-slice "baz" 20d0)
+  (add-features :label)
+  (save-file "pie-3d-google.png"))

examples/seibel.lisp

@@ -0,0 +1,17 @@
+
+(let ((width 1264)
+      (height 632))
+  (with-chart (:line width height)
+    (add-series "Rank" '((0 10) (1 18) (2 6) (3 17)))
+    (add-series "25" '((0 25) (3 25)))
+    (set-axis :y "Rank")
+    (set-axis :x "" :data-interval 1)
+    (save-file "seibel-1.png"))
+
+  (with-chart (:line width height)
+    (add-series "Rank" '((0 10) (1 18) (2 19) (3 17)))
+    ;(add-series "Rank" '((0 10) (1 18) (2 6) (3 17)))
+    (add-series "25" '((0 25) (3 25)))
+    (set-axis :y "Rank")
+    (set-axis :x "" :data-interval 1)
+    (save-file "seibel-2.png")))

examples/star-rating.lisp

@@ -0,0 +1,3 @@
+(with-chart (:star-rating 300 60)
+  (set-rating 4.5)
+  (save-file "star-rating.png"))

examples/too-many-bars-vecto.lisp

@@ -0,0 +1,13 @@
+(with-chart (:bar 600 400)
+  (flet ((random-data (min max)	   
+	   (loop for i from 0 to 48
+		 collect (list i (+ min (random (float (- max min))))))))
+    (add-series "A" (random-data 0 100))
+    (add-series "B" (random-data -100 100))
+    (add-series "C" (random-data -50 50))
+    (add-series "D" (random-data -100 0))
+    (add-series "E" (random-data -75 75)))
+  (set-axis :y nil :draw-zero-p T)
+  (set-axis :x nil :data-interval 1)
+  
+  (save-file "too-many-bars-vecto.png"))

publish.sh

@@ -0,0 +1,15 @@
+#!/bin/sh
+
+echo "sync with cl-user"
+darcs push rdavis@common-lisp.net:/project/adw-charting/public_html/darcs/adw-charting
+echo "Compile the help"
+read -p "hit enter when everything is ready in the doc folder, org files exported, etc"
+echo "Publish the help"
+scp doc/docs.html rdavis@common-lisp.net:/project/adw-charting/public_html/index.html
+scp doc/*.html rdavis@common-lisp.net:/project/adw-charting/public_html/
+scp doc/*.png rdavis@common-lisp.net:/project/adw-charting/public_html/
+echo "Make the distribution tarball"
+darcs dist -d adw-charting
+echo "publish the distribution tarball"
+scp adw-charting.tar.gz rdavis@common-lisp.net:/project/adw-charting/public_html/
+echo "all done.  Now go blog and post to the mailing list."

src/charting.lisp

@@ -0,0 +1,245 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+
+(defparameter +default-colors+ '((0.7 0.21960784 0.29803923)
+				 (.4 0.5 0.9)
+				 (0.8 0.8 0.4745098)
+				 (0.52156866 0.7 0.30588236)
+				 (0.17254902 0.101960786 0.3372549)
+				 (0.3372549 0.5294118 0.65882355))
+  "rgb 0-1.0 triples")
+
+(defvar *color-stack* +default-colors+)
+(defvar *current-chart* nil
+  "The currently active chart. Bound for the
+      duration of WITH-CHART.")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-color-stack (() &body body)
+    "resets *color-stack* to the initial list"
+    `(let ((*color-stack* (copy-list +default-colors+)))
+       ,@body)))
+
+(defclass area ()
+  ((width :accessor width
+	  :initarg :width
+	  :type integer
+	  :initform nil)
+   (height :accessor height
+	   :initarg :height
+	   :type integer
+	   :initform nil)))
+
+(defclass point ()
+  ((x :accessor x
+      :initarg :x)
+   (y :accessor y
+      :initarg :y)))
+
+(defmethod x ((lst list))
+  (first lst))
+(defmethod y ((lst list))
+  (second lst))
+
+(defmethod clone ((p point))
+  (make-instance 'point 
+		 :x (x p)
+		 :y (y p)))
+
+(defun make-point (x y)
+  (make-instance 'point :x x :y y))
+
+(defclass chart (area)
+  ((label-size :accessor label-size
+	       :initarg :label-size
+	       :initform 12)
+   (margin :accessor margin
+	   :initarg :margin
+	   :initform 10)
+   (draw-legend-p :accessor draw-legend-p
+		  :initarg :draw-legend-p
+		  :initform T)
+   (background :accessor background
+	       :initarg :background
+	       :initform '(1 1 1))
+   (chart-elements :accessor chart-elements
+		   :initarg :chart-elements
+		   :initform nil))
+  (:default-initargs :width 200 :height 200))
+
+
+(defgeneric draw-chart (chart)
+  (:documentation "draws the chart, assuming a vecto canvas is open"))
+
+(defclass chart-element ()
+  ((color :accessor color :initarg :color :initform nil)
+   (label :accessor label :initarg :label :initform "none"))
+  (:documentation "this is a super-class for various chart elements"))
+
+(defmethod color ((item chart-element))
+  (if-let (color (slot-value item 'color))
+	  color
+	  (let ((c (pop *color-stack*)))
+	    (setf *color-stack* (nconc *color-stack*				       
+				       (list (mapcar #'(lambda (x)
+						   (/ (+ (if (eq 1 x)
+							     .7
+							     1) x) 2))
+					       c))))
+	    (setf (color item) c))))
+
+
+(defgeneric save-chart-to-file (filename chart)
+  (:documentation "saves the chart to the given file"))
+
+(defun save-file (filename)
+  "saves the *current-chart* to the given file."
+  (save-chart-to-file filename *current-chart*))
+
+(defgeneric save-chart-to-stream (stream chart)
+  (:documentation "saves the chart to the given stream"))
+
+(defun save-stream (stream)
+  "saves the *current-chart* to the given stream."
+  (save-chart-to-stream stream *current-chart*))
+
+
+
+(defclass slice (chart-element)  
+  ((value :accessor value :initarg :value))
+  (:documentation "this is a slice of a pie chart"))
+
+(defun add-slice (label value &key color)
+  "add a slice to the pie"
+  (push (make-instance 'slice :color color :label label :value value)
+	(chart-elements *current-chart*)))
+
+(defclass series (chart-element)
+  ((data :accessor data
+	 :initarg :data
+	 :documentation "a list of (x y) pairs (as lists, not cons cells)")
+   (mode :accessor mode
+	 :initarg :mode
+	 :initform 'default
+	 :documentation "a flag for how to render this series"))  
+  (:documentation "represents a line on a line chart"))
+
+(defun default-label-formatter (value)
+  (typecase value
+    ((or float ratio) (format nil "~,1F" value))
+    (integer (princ-to-string value))
+    (t (progn
+	 (break "don't know how to format ~a~%" (type-of value))
+	 (princ-to-string value)))
+    )
+  )
+
+(defclass axis ()
+  ((label :accessor label
+	  :initarg :label
+	  :initform nil
+	  :documentation "description of this axis, usually the unit
+of measurement ($, s, km, etc)")   
+   (label-formatter :accessor label-formatter
+		    :initarg :label-formatter
+		    :initform #'default-label-formatter
+		    :documentation "a function to format data points, for
+printing periodic values along the axis")
+   (draw-gridlines-p :accessor draw-gridlines-p
+		     :initarg :draw-gridlines-p
+		     :initform T
+		     :documentation "determines if grid-lines are drawn
+across the chart")
+   (data-interval :accessor data-interval
+		  :initarg :data-interval
+		  :initform nil)
+   (draw-zero-p :accessor draw-zero-p
+		:initarg :draw-zero-p
+		:documentation "Should we draw a line along the 0 of this axis?")
+   (mode :accessor mode
+	 :initarg :mode)
+   (angle :accessor angle
+	  :initarg :angle)
+   (scalefn :accessor scalefn
+	  :initarg :scalefn
+	  :documentation "Values will be passed through this function for scaling prior to display"))
+  (:documentation "represents an axis on a line chart"))
+
+(defmethod axis-label ((axis axis) data)
+  (funcall (label-formatter axis) data))
+
+
+(defun add-series (label data &key color (mode 'default))
+  "adds a series to the *current-chart*."
+  (push (make-instance 'series :label label :data data :color color :mode mode)
+	(chart-elements *current-chart*)))
+
+(defun set-axis (axis title &key draw-gridlines-p
+		 (label-formatter #'default-label-formatter)
+		 (mode :value)
+		 data-interval
+		 scalefn
+		 draw-zero-p
+		 angle)
+  "set the axis on the *current-chart*.  axis is either :x or :y.
+label-formatter is either a format-compatible control string or
+a function of 1 argument to control label formatting"
+  (let ((ax (make-instance 'axis
+			   :label title
+			   :draw-gridlines-p draw-gridlines-p
+			   :mode mode
+			   :scalefn scalefn
+			   :angle angle
+			   :draw-zero-p draw-zero-p
+			   :data-interval data-interval
+			   :label-formatter (etypecase label-formatter
+					      (string #'(lambda (v)
+							  (format nil label-formatter v)))
+					      (function label-formatter)))))
+    (ccase axis
+      (:x (setf (x-axis *current-chart*) ax))
+      (:y (setf (y-axis *current-chart*) ax)))))
+
+(defun find-chart-extremes (chart)
+  (let ((data-minmax (find-extremes
+		      (mapcan #'(lambda (series)
+				  (find-extremes (data series)))
+			      (chart-elements chart))))
+	(x-zero (ignore-errors
+		  (draw-zero-p (x-axis chart))))
+	(y-zero (ignore-errors
+		  (draw-zero-p (y-axis chart)))))
+    (if (or x-zero y-zero)
+	(destructuring-bind ((min-x min-y) (max-x max-y)) data-minmax
+	  (declare (ignore max-x max-y))
+	  (when x-zero (push (list 0 min-y) data-minmax))
+	  (when y-zero (push (list min-x 0) data-minmax))
+	  (find-extremes data-minmax))
+	data-minmax)))
+
+(defun find-extremes (data)
+  "takes a list of (x y) pairs, and returns the ((x-min y-min) (x-max y-max))"
+  (loop for (x y) in data
+	maximizing x into x-max
+	minimizing x into x-min
+	maximizing y into y-max
+	minimizing y into y-min
+	finally (return (list (list x-min y-min)
+			      (list x-max y-max)))))

src/google/gchart.lisp

@@ -0,0 +1,395 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+
+(defun make-parameter-collection ()
+  (make-hash-table :test 'equal))
+
+(defclass gchart (chart)
+  ((chart-type :accessor chart-type
+	       :initarg :chart-type)
+   (parameters :accessor parameters
+	       :initform (make-parameter-collection)
+	       :initarg :parameters)
+   (x-axis :accessor x-axis
+	   :initarg :x-axis
+	   :initform nil
+	   :documentation "an axis object to determine formatting for
+the X axis")
+   (y-axis :accessor y-axis
+	   :initarg :y-axis
+	   :initform nil
+	   :documentation "and axis object to determine formatting for
+the Y axis")
+   (axes :accessor axes
+	 :initform (make-hash-table))))
+
+(defvar *chart-types* '((:pie . "p")
+			(:pie-3d . "p3")
+			(:line . "lxy")
+			(:v-bar .  "bvs")
+			(:h-bar . "bhs")
+			(:v-gbar .  "bvg")
+			(:h-gbar . "bhg")
+			(:google-meter . "gom")))
+
+(defparameter +google-chart-url+ "http://chart.apis.google.com/chart")
+
+(defun make-color (html-color)
+  "takes an html color and returns the closest (r g b) list equivalent"
+  (let ((*read-base* 16))
+    (loop
+       for start in '(0 2 4)
+       collect (interpolate 0 255.0 
+		(read-from-string (subseq html-color start (+ 2 start)))
+		:interpolated-max 1.0))))
+
+(defun make-html-color (color)
+  "takes a standard (r g b) color list and returns the closest HTML equivalent"
+  (format nil "~{~2,'0X~}"
+	  (mapcar #'(lambda (c)
+		      (ceiling (interpolate 0 1.0 c :interpolated-max 255)))
+		  color)))
+
+(defmethod build-data ((chart gchart))
+  "helper to build the list of data"
+  (case (chart-type chart)
+    (:google-meter (format nil
+			   "t:~D"
+			   (value (first (chart-elements chart)))))
+    ((:pie :pie-3d) (format nil
+			    "t:~{~F~^,~}"
+			    (normalize-elements chart)))
+    (:line
+       ;;pairs of X | Y, normalized to 0-100 for google's chart algorithms
+       (format nil "t:~{~a~^|~}"
+	       (loop for (exes wyes series) in (normalized-series chart)
+		     collect (format nil
+				     "~{~,2F~^,~}|~{~,2F~^,~}"
+				     exes wyes))))
+    ((:v-bar :h-bar :v-gbar :h-gbar)
+       ;;these want the bars specified as wyes1|wyes2|wyesN, so
+       ;;get all the lists of wyes sorted out with 0s for the missing values
+       (format nil "t:~{~a~^|~}"
+	       (let ((xys (normalized-series chart))
+		     (all-exes nil))
+		 ;;assemble list of all exes
+		 (dolist (xy xys)
+		   (dolist (x (first xy))
+		     (unless (member x all-exes)
+		       (push x all-exes))))
+		 (setf all-exes (sort all-exes #'<))
+		 (loop for (exes wyes series) in xys
+		       for idx from 0
+		       do
+		    (when (eql (mode series) :line)
+		      (append-parameter :chm
+					(format nil "D,~a,~D,0,2,1"
+						(make-html-color (color series))
+						idx)
+
+					chart))
+			 
+		       collect
+		    (format nil "~{~D~^,~}"
+				(mapcar #'(lambda (x)					    
+					    (or (when-let (idx (position x exes))
+						  (truncate (nth idx wyes)))
+						0))
+					all-exes))))))))
+
+(defun interpolate (min max val &key (interpolated-max 100) (interpolated-min 0))
+  (+ interpolated-min
+     (* (- interpolated-max interpolated-min) (/ (- val min)
+			    (- max min)))))
+
+(defun normalize-elements (chart)
+  (let ((sum (reduce #'+
+		     (chart-elements chart)
+		     :key #'value)))
+    (loop for elem in (chart-elements chart)
+	  collect (/ (value elem) sum))))
+
+(defun normalized-series (chart)
+  (destructuring-bind ((min-x min-y) (max-x max-y))
+      (find-chart-extremes chart)
+    (loop for series in (chart-elements chart)
+       for exes = nil then nil
+       for wyes = nil then nil
+       do
+	 (loop for (x y) in (reverse (data series))
+	    do
+	      (push (interpolate min-x max-x x) exes)
+	      (push (interpolate min-y max-y y) wyes))
+       collect (list exes wyes series))))
+
+(defmethod build-labels ((chart gchart))
+  "helper to build the list of labels"
+  (format nil "~{~a~^|~}"
+	  (mapcar #'label
+		  (chart-elements chart))))
+
+(defun prepare-key (key)
+  (string-downcase (princ-to-string key)))
+
+(defmethod set-parameter ((chart gchart) key value)
+  (setf (gethash key
+		 (parameters chart))
+	value))
+
+(defmacro set-parameters ((chart) &body params)
+  `(progn
+    ,@(loop for (k v) in params
+     collect 
+       `(set-parameter ,chart ,k ,v))))
+
+(defmethod ensure-default-parameters ((chart gchart))
+  (set-parameters (chart)
+    (:chs (format nil "~ax~a"
+		  (width chart)
+		  (height chart)))
+    (:cht (cdr (assoc (chart-type chart)
+		      *chart-types*)))
+    (:chd (build-data chart))
+    (:chco (format nil "~{~a~^,~}"
+		   (mapcar #'make-html-color
+			   (mapcar #'color (chart-elements chart)))))))
+
+(defparameter +chart-features+ '(:label :transparent-background :adjusted-zero :data-scaling :label-percentages))
+
+(defgeneric add-feature (feature-name))
+
+(defmethod add-feature ((feature-name (eql :label)))
+  (set-parameter *current-chart* (case (chart-type *current-chart*)
+				   ((:pie :pie-3d :google-meter) :chl)
+				   (T :chdl))
+		 (build-labels *current-chart*)))
+
+(defmethod add-feature ((feature-name (eql :transparent-background)))
+  (set-parameter *current-chart*
+		 :chf
+		 "bg,s,00000000"))
+
+(defmethod add-feature ((feature-name (eql :adjusted-zero)))
+  (destructuring-bind ((min-x min-y) (max-x max-y))
+      (find-chart-extremes *current-chart*)
+    (declare (ignore min-x max-x))
+    (set-parameter *current-chart*
+		 :chp
+		 (interpolate min-y max-y 0.0 :interpolated-max 1.0))))
+
+(defmethod add-feature ((feature-name (eql :data-scaling)))
+  (let ((totals (make-hash-table))
+	(min-y 0))
+    (loop for (exes wyes series) in (normalized-series *current-chart*)
+	  do
+	  (loop for x in exes
+		for y in wyes
+		do		
+		(if (plusp y)
+		    (incf (gethash x totals 0) y)
+		    (if (< y min-y)
+			(setf min-y y)))))
+    (set-parameter *current-chart*
+		   :chds
+		   (format nil "~,2F,~,2F" min-y
+			   (loop for k being the hash-keys in totals
+				 using (hash-value v)
+				 maximizing v into max
+				 finally (return max))))))
+
+(defmethod add-feature ((feature-name (eql :label-percentages)))
+  (loop for elem in (chart-elements *current-chart*)
+	for normalized in (normalize-elements *current-chart*)
+	do
+	(setf (label elem)
+	      (format nil "~a - ~,2F%" (label elem) (* 100 normalized))))
+  (add-feature :label))
+
+
+(defmethod add-title (title)
+  "adds the given title, ignores if the title is nil"
+  (if title
+      (set-parameter *current-chart*
+		   :chtt
+		   title)
+      (warn "trying to set nil title")))
+
+(defun bar-spacing (bar-width-px &optional bar-seperation-px group-seperation-px)
+  (set-parameter *current-chart*
+		 :chbh
+		 (format nil "~{~D~^,~}"
+			 (loop for x in (list bar-width-px bar-seperation-px group-seperation-px)
+			      when x
+			      collect x))))
+
+(defun grid (x-step y-step line-length blank-length)
+  (set-parameter *current-chart* :chg (list x-step y-step line-length blank-length)))
+
+(defun append-parameter (key val &optional (chart *current-chart*))
+  "adds an axis, and returns the index of that axis"
+  (setf (gethash key (parameters chart))
+	(append (gethash key (parameters chart))
+		(list val)))
+  (position val (gethash key (parameters chart))))
+
+
+(defun add-axis (val valfn axis &optional (chart *current-chart*))
+  "adds an axis, and returns the index of that axis"
+    (let ((idx (append-parameter :chxt val chart))
+	  (param (if (eql :auto (data-interval axis))
+		     :chxr :chxl)))
+      (setf (gethash idx (axes chart)) axis)
+      (append-parameter param (list idx valfn (label-formatter axis) (draw-zero-p axis)))))
+
+(defmethod (setf x-axis) :before (ax (chart gchart))
+  (add-axis "x" #'x ax chart))
+
+(defmethod (setf y-axis) :before (ax (chart gchart))
+  (add-axis "y" #'y ax chart))
+
+(defun add-features (&rest names)
+  (mapc #'add-feature names))
+
+(defmethod finalize-parameter (key val)
+  (princ-to-string val))
+
+(defmethod finalize-parameter (key (val float))
+  (format nil "~,2F" val))
+
+(defmethod finalize-parameter (key (val string))
+  val)
+
+(defmethod finalize-parameter (key (val list))
+ (format nil "~{~a~^,~}" val))
+
+(defun inline-break (format-string &rest args)
+  "call BREAK with the given format and args, then return the args"
+  (apply #'break format-string args)
+  (apply #'values args))
+
+(defmethod finalize-parameter ((key (eql :chxl)) val)
+  (format nil "~{~a~^|~}"
+	  (loop for (idx valfn formatfn draw-zero-p) in val
+		collect (format nil "~D:|~{~a~^|~}" idx
+				(mapcar formatfn
+					(sort
+					 (remove-duplicates
+					  (let ((vals (loop for elem in (chart-elements *current-chart*)
+							    nconc (mapcar valfn (data elem)))))
+					    ;;if we want to draw 0, add it to the list
+					    (when draw-zero-p (push 0 vals))
+					    vals))
+					 #'<))))))
+
+(defmethod finalize-parameter ((key (eql :chxr)) val)
+  (let ((all-data (mapcan #'data (chart-elements *current-chart*))))
+    (format nil "~{~a~^|~}"
+	    (loop for (idx valfn formatfn draw-zero-p) in val		 
+	       collect (format nil "~D,~{~,2F~^,~}" idx			       
+
+			       (let ((vals (mapcar valfn all-data)))
+				 ;;add zero if we want to
+				 (when draw-zero-p (push 0 vals))
+				 ;;find the global min/max				 
+				 (let ((minmax (loop for x in vals
+						     minimizing x into min
+						     maximizing x into max
+						     finally (return (list min max)))))
+				   
+				   ;;find the function for scaling this axis, scale
+				   (if-let (scalefn (scalefn (gethash idx (axes *current-chart*))))
+				     (mapcar scalefn minmax)
+				     minmax))))))))
+
+
+(defmethod build-parameters ((chart gchart))  
+  "returns an alist that defines to google what
+it should be rendering"
+  (build-parameters (parameters chart)))
+
+(defmethod build-parameters ((params hash-table))  
+  "returns an alist that defines to google what
+it should be rendering"
+  (loop for k being the hash-keys in params using (hash-value v)
+	collect (cons (prepare-key k) (finalize-parameter k v))))
+
+(defmethod save-chart-to-stream (stream (chart gchart))
+  (ensure-default-parameters chart)
+  (write-sequence (drakma:http-request
+		   +google-chart-url+
+		   :parameters (build-parameters chart))
+		  stream))
+
+(defmethod save-chart-to-file (filename (chart gchart))
+  "makes the call to google, saves the result in the file"
+  (with-open-file (dst filename :direction :output
+		       :element-type 'unsigned-byte
+		       :if-does-not-exist :create
+		       :if-exists :supersede)
+    (save-chart-to-stream dst chart)
+    (truename filename)))
+
+(defun chart-url ()
+  "returns the URL for the current google chart"
+  (build-chart-url *current-chart*))
+
+(defgeneric build-chart-url (thing)
+  (:method ((chart gchart))
+    (ensure-default-parameters chart)
+    (build-chart-url (parameters chart)))
+  (:method ((params hash-table))
+    (concatenate 'string
+		 +google-chart-url+
+		 "?"
+		 (drakma::alist-to-url-encoded-string
+		  (build-parameters params)
+		  drakma:*drakma-default-external-format*))))
+
+(defmacro with-gchart ((type width height) &body body)
+  "creates a new context with a gchart of the given type, width, and height."
+  `(let ((*current-chart*
+	  (make-instance 'gchart
+			 :chart-type ,type
+			 :width ,width
+			 :height ,height)))
+     (with-color-stack ()
+       ,@body)))
+
+
+(defun google-o-meter (percentage width &key label colors show-percentage)
+  (let ((params (make-parameter-collection))
+	;;if the percentage is specifed as 0-1, multiply by 100
+	(percentage (if (> 1 percentage)
+			(* 100 percentage)
+			percentage)))
+    
+    (flet ((add-param (k v)
+	     (setf (gethash k params) v)))
+      (add-param :chs (format nil "~ax~a" width (truncate (* width .5))))
+      (add-param :cht "gom")
+      (add-param :chd (format nil "t:~a" (truncate percentage)))
+      (when (and colors (< 1 (length colors)))
+	(add-param :chco (format nil "~{~a~^,~}" colors)))
+      (if label
+	  (add-param :chl label)
+	  (when show-percentage
+	    (add-param :chl (format nil "~D%" (truncate percentage)))))
+      
+      (build-chart-url params))))

src/google/packages.lisp

@@ -0,0 +1,3 @@
+(in-package :adw-charting)
+
+(export '(with-gchart chart-url add-feature add-features add-title make-color google-o-meter))

src/packages.lisp

@@ -0,0 +1,29 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(defpackage :net.acceleration.charting
+    (:documentation "Charting library to make pretty graphs")
+    (:nicknames #:adw-charting)
+    (:use #:cl #:iterate)
+    (:export
+       :save-file
+       :save-stream
+       :add-slice
+       :add-series
+       :set-axis
+    ))

src/utils.lisp

@@ -0,0 +1,33 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+;;pulled from drakma
+(defmacro when-let ((var expr) &body body)
+  "Evaluates EXPR, binds it to VAR, and executes BODY if VAR has
+a true value."
+  `(let ((,var ,expr))
+    (when ,var
+      ,@body)))
+
+(defmacro if-let ((var expr) if-form else-form)
+  "Evaluates EXPR, binds it to VAR, and uses
+VAR as the first argument to IF, executing the if-form
+or else-form depending on VAR"
+  `(let ((,var ,expr))
+    (if ,var ,if-form ,else-form)))

src/vecto/bar-charts.lisp

@@ -0,0 +1,79 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+
+(defclass bar-chart (line-chart) ())
+
+(defmethod calculate-graph-bounds :after ((chart bar-chart) graph)
+  ;;make some room for the bars   
+  (incf (x (data-max graph))
+	(/ (data-distance #'x graph)
+	   (number-of-bars chart))))
+
+(defvar *bar-width* 1)
+
+(defun calculate-bar-width (chart graph)
+  (setf *bar-width*
+	(max 1 (truncate
+		(/ (* 0.5 (width graph))
+		   (number-of-bars chart)))))
+  )
+
+(defun number-of-bars (chart)
+  (loop for series in (chart-elements chart)
+	sum (length (data series))))
+
+(defmethod draw-series ((chart bar-chart) graph)
+  (let ((bars-drawn (make-hash-table))
+	(*bar-width*
+	 (max 1
+	      (truncate (/ (* 0.5 (width graph))
+			   (number-of-bars chart))))))
+    (dolist (series (chart-elements chart))
+      (if (eq (mode series) 'default)
+	  (draw-bar-series series graph bars-drawn)
+	  (draw-line-series series graph)))))
+
+(defun draw-bar-series (series graph bars-drawn)
+;;  (decf (width graph) (* 2 *bar-width*))
+  (with-graphics-state
+    (set-line-width 2)
+    (set-fill series)
+    (iter (with ry = (y (dp->gp graph 0 0)))
+	  (for (x y) in (data series))
+	  (for num-bars-drawn = (gethash x bars-drawn 0))
+	  (for gp = (dp->gp graph x y))
+	  (for rx = (+ (x gp)
+		       (* num-bars-drawn
+			  *bar-width*)))
+	  (for rh = (- (y gp) ry))
+	  (rectangle rx ry *bar-width* rh)
+	  (fill-path)  
+	  (incf (gethash x bars-drawn 0))))
+  ;;(incf (width graph) (* 2 *bar-width*))
+  )
+
+(defmacro with-bar-chart ((width height &key (background ''(1 1 1))) &body body)
+  "Evaluates body with a chart established with the specified
+dimensions as the target for chart commands, with the specified background."
+  `(let ((*current-chart*  (make-instance 'bar-chart
+					  :width ,width
+					  :height ,height
+					  :background ,background)))
+     ,@body))

src/vecto/charts.lisp

@@ -0,0 +1,146 @@
+(in-package :adw-charting)
+
+(defvar *default-font-file*
+  (merge-pathnames
+   "FreeSans.ttf"
+   (asdf:component-pathname
+    (asdf:find-system :adw-charting))))
+
+(defvar *current-font* nil "a font object")
+(defvar *font* nil "a font object")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-font ((&optional font-file) &body body)
+    "ensures *font* is a valid font loader."
+    `(let ((*font* (or *font* (get-font (or ,font-file *default-font-file*)))))
+      ,@body)))
+
+(defclass vchart (chart)
+  ())
+
+(defmethod move ((p point))
+  (move-to (x p) (y p)))
+
+(defmethod line ((p point))
+  (line-to (x p) (y p)))
+
+(defmethod font-bounding-box ((chart chart) text)
+  "gets the bounding box for the given text on the given chart."  
+  (with-font ()
+    (string-bounding-box (if (stringp text) text
+			     (princ-to-string text))
+			 (label-size chart)
+			 *font*)))
+
+(defmethod font-height ((chart chart))
+  "gets the pixel height of the default font, at
+the size specified in the chart's label-size"
+  (aref (font-bounding-box chart "A") 3))
+
+(defmethod font-width ((chart chart) text)
+  "gets the pixel width of the default font, as the size
+specified in the chart's label-size"
+  (aref (font-bounding-box chart text) 2))
+
+(defgeneric set-fill (obj)
+  (:documentation "shortcuts for setting the vecto fill color"))
+
+(defmethod set-fill ((lst cons))
+  (apply #'set-rgb-fill lst))
+
+(defmethod set-fill ((chart chart))
+  (when-let (bg (background chart))
+    (set-fill bg)))
+
+(defmethod set-fill ((elem chart-element))
+  (set-fill (color elem)))
+
+(defgeneric set-stroke (obj)
+  (:documentation "shortcuts for setting the vecto stroke color"))
+
+(defmethod set-stroke ((lst cons))
+  (apply #'set-rgb-stroke lst))
+
+(defmethod set-stroke ((elem chart-element))
+  (set-stroke (color elem)))
+
+(defun %render-chart (&optional (chart *current-chart*))
+  (set-fill chart) 
+  (clear-canvas);;fills in the background
+  
+  ;;ensure we have colors to auto-assign
+  (with-color-stack ()
+    (draw-chart chart)
+    (when (draw-legend-p chart)
+      (draw-legend chart))))
+
+
+
+(defgeneric draw-legend (elem)
+  (:documentation "handles drawing legends for the given chart")
+  (:method ((chart chart))
+	   (draw-legend-labels chart)))
+
+(defgeneric legend-start-coords (chart box-size label-spacing)
+  (:documentation "specifies where legends should start drawing"))
+
+(defgeneric translate-to-next-label (chart w h)
+  (:documentation "translates the active vecto canvas to the next
+place a label should go")
+  (:method ((chart chart) w h)
+	   (declare (ignore chart w h))))
+
+(defun draw-legend-labels (chart)
+  "handles drawing legend labels"
+  (with-graphics-state
+    (with-font ()
+      (let* ((elems (chart-elements chart))
+	     (text-height (font-height chart))
+	     (box-size (* 2 text-height))
+	     (label-spacing (/ text-height 2)))
+	(set-font *font* (label-size chart)) ;set the font
+	(set-rgb-fill 0 0 0)		;text should be black
+	(apply #'translate (legend-start-coords chart box-size label-spacing))
+	(dolist (elem elems)
+	  ;;translate the origin to the next label
+	  (with-graphics-state
+	    (set-fill (color elem))
+	    (rounded-rectangle 0 label-spacing box-size box-size label-spacing text-height)
+	    (fill-and-stroke))
+	  (draw-string (+ box-size label-spacing)
+		       text-height
+		       (label elem))
+	  (translate-to-next-label chart
+				   (+ box-size label-spacing label-spacing
+				      (font-width chart (label elem)))
+				   (+ box-size label-spacing)))))))
+
+
+(defmethod save-chart-to-file (filename (chart chart))
+  "saves the chart to the file"
+  (with-canvas (:width (width chart)
+		       :height (height chart))
+    (setf (chart-elements chart)
+	  (reverse (chart-elements chart)) )
+    (%render-chart)
+    (save-png filename)))
+
+(defmethod save-chart-to-stream (stream (chart chart))
+  (with-canvas (:width (width chart) :height (height chart))
+    (%render-chart)
+    (save-png-stream stream)))
+
+(defparameter +chart-types+ '((:line line-chart)
+			      (:bar bar-chart)
+			      (:pie pie-chart)
+			      (:star-rating star-rating-chart)))
+
+
+(defmacro with-chart ((type width height &key (background ''(1 1 1))) &body body)
+  "Evaluates body with a chart established with the specified
+dimensions as the target for chart commands, with the specified background."
+  `(let ((*current-chart*  (make-instance (find-class (cadr (assoc ,type +chart-types+)))
+					  :width ,width
+					  :height ,height
+					  :background ,background)))
+    ,@body))

src/vecto/line-charts.lisp

@@ -0,0 +1,383 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+
+
+
+(defclass line-chart (vchart)
+  ((x-axis :accessor x-axis
+	   :initarg :x-axis
+	   :initform nil
+	   :documentation "an axis object to determine formatting for
+the X axis")
+   (y-axis :accessor y-axis
+	   :initarg :y-axis
+	   :initform nil
+	   :documentation "and axis object to determine formatting for
+the Y axis")))
+
+(defclass graph-region (point area)
+  ((chart :accessor chart
+	  :initarg :chart)
+   (data-min :accessor data-min 
+	     :initform nil)
+   (data-max :accessor data-max 
+	     :initform nil)))
+
+(defmethod offset-y ((gr graph-region) offset)
+  (let ((offset (floor offset)))
+    (incf (y gr) offset)
+    (decf (height gr) offset)))
+
+(defmethod offset-x ((gr graph-region) offset)
+  (let ((offset (floor offset)))
+    (incf (x gr) offset)
+    (decf (width gr) offset)))
+
+(defmethod data-scale ((gr graph-region))
+  (with-accessors ((w width)
+		   (h height)
+		   (min data-min)
+		   (max data-max)) gr
+    (make-point (/ w (max 1 (- (x max) (x min))))
+		(/ h (max 1 (- (y max) (y min)))))))
+
+(defmethod data-origin ((graph graph-region))
+  (with-accessors ((x x)
+		   (y y)
+		   (d-s data-scale)
+		   (min data-min)
+		   (max data-max)) graph
+    (let ((d-o (make-point x y)))
+      ;;if we have a negative min y, move the y 0 point up
+      (when (minusp (y min))
+	(incf (y d-o) (abs (* (y d-s) (y min)))))
+
+      ;;if we have a positive min y, move the y 0 down
+      (when (plusp (y min))
+	(decf (y d-o) (abs (* (y d-s) (y min)))))
+    
+      ;;if we have a negative min x, move the x 0 point right
+      (when (minusp (x min))
+	(incf (x d-o) (abs (* (x d-s) (x min)))))
+
+      ;;if we have a positive min x, move the x 0 point left
+      (when (plusp (x min))
+	(decf (x d-o) (* (x d-s) (x min))))
+      d-o)))
+
+(defmethod has-data-p ((chart line-chart))
+  (and (chart-elements chart)
+       (some #'data (chart-elements chart))))
+
+(defun draw-axes (graph y-axis-labels-x text-height x-axis-labels-y)
+  "draws the axes"
+  (let (gridlines)
+    (macrolet ((draw-gridline ((axis) &body gridline)
+		 `(when (draw-gridlines-p ,axis)
+		    (push #'(lambda ()
+			    (with-graphics-state
+				(set-line-width 1)
+			      (set-stroke '(0 0 0))
+			      (set-dash-pattern #(10 2) 0)
+			      ,@gridline
+			      (stroke)))
+			  gridlines))))
+
+      (when-let (axis (y-axis (chart graph)))
+	(iter (for (txt x y) in (calculate-y-axes graph text-height y-axis-labels-x))
+	      (maximizing (font-width (chart graph) txt) into label-width)
+	      (for half-text = (/ text-height 2))
+	      (draw-string x (- y half-text)
+			   (if (stringp txt) txt (princ-to-string txt)))
+	      (let ((y y))
+		(draw-gridline (axis)
+			       (move-to (x graph) y)
+			       (line-to (+ (x graph) 
+					   (width graph)) 
+					y)))
+	      (finally (incf *current-x* label-width)))
+
+	(offset-x graph *current-x*)
+      
+	(when (draw-zero-p axis)
+	  (push (lambda ()
+		  (with-graphics-state
+		    (set-line-width 1)
+		    (set-rgb-stroke 0 0 0)
+		    (move (dp->gp graph (x (data-min graph)) 0))
+		    (line (dp->gp graph (x (data-max graph)) 0))
+		    (stroke)))
+		gridlines)))
+
+      (when-let (axis (x-axis (chart graph)))
+	(loop for (txt x) in (calculate-x-axes graph)
+	      do (progn
+		   (draw-centered-string x  
+					 x-axis-labels-y
+					 (if (stringp txt) txt (princ-to-string txt)))
+		   (let ((x x))
+		     (draw-gridline (axis)
+				    (move-to x (y graph))
+				    (line-to x
+					     (+ (y graph) (height graph)))))))
+	(when (draw-zero-p axis)
+	  (push (lambda ()
+		  (with-graphics-state
+		    (set-line-width 2)
+		    (set-rgb-stroke 0 0 0)
+		    (move (dp->gp graph 0 (y (data-min graph))))
+		    (line (dp->gp graph 0 (y (data-max graph))))
+		    (stroke)))
+		gridlines))))
+    gridlines)) 
+
+(defun calculate-x-axes (graph)
+  (let ((axis (x-axis (chart graph))))  
+    (ccase (mode axis)
+      (:value (calculate-value-x graph))
+      (:category (break "should draw in order"))
+      )))
+
+(defun order-of-magnitude (n)
+  (if (zerop n)
+      1
+      (expt 10 (floor (log n 10)))))
+
+(defun data-distance (axis-fn graph)
+  (let ((min-val (funcall axis-fn (data-min graph)))
+	(max-val (funcall axis-fn (data-max graph))))
+    (abs (- min-val max-val))))
+
+(defun calculate-value-x (graph)  
+  (let* ((min-x (x (data-min graph)))
+	 (max-x (x (data-max graph)))
+	 (diff (data-distance #'x graph))
+	 (axis (x-axis (chart graph)))
+	 (data-interval (or (data-interval axis)
+			    (/ (order-of-magnitude diff) 8)))
+	 (current-x (x graph))
+	 lst)
+    ;;start drawing at 0, see how much we have
+    (loop for x = min-x then (+ x data-interval)
+	  for gx = (round (x (dp->gp graph x 0)))
+	  until (> x max-x)
+	  do (when (<= current-x gx)
+	       ;;record + increment current-x
+	       (let* ((txt (axis-label axis x))
+		      (width (font-width (chart graph) txt)))
+		 
+		 (push (list txt gx) lst)
+		 (setf current-x (+ gx width
+				    (margin (chart graph)))))))
+    lst))
+
+(defun calculate-y-axes (graph text-height y-axis-labels-x)
+  (let* ((min-y (y (data-min graph)))
+	 (axis (y-axis (chart graph)))
+	 (diff (data-distance #'y graph))
+	 (data-interval (or (data-interval axis)
+			    (/ (order-of-magnitude diff) 8)))
+	 (desired-text-space (* 2 text-height)))
+
+    ;;be sure the interval has plenty of room in it for our text-height
+    (iter (with scalar = (y (data-scale graph)))
+	  (summing data-interval into new-interval)
+	  (until (< desired-text-space
+		    (* new-interval scalar)))
+	  (finally
+	   (setf data-interval new-interval)))
+    
+    (let* ((interval-magnitude (order-of-magnitude data-interval))
+	   (initial-y (* interval-magnitude
+			 (truncate (/ min-y interval-magnitude)))))
+
+      (loop for y = initial-y then (+ y data-interval)
+	    for gy = (y (dp->gp graph 0 y))
+	    until (> gy (+ (height graph) (y graph)))
+	    when (> gy (y graph))
+	      collect (list (axis-label axis y)
+			  y-axis-labels-x
+			  gy)))))
+
+(defun draw-graph-area (graph)
+  "draws the graph area"
+  (with-graphics-state
+    ;;set the chart background as the avg
+    ;;between the background color and 1
+    (set-rgb-stroke 0 0 0)    
+    (rectangle (1- (x graph)) (1- (y graph))
+	       (1+ (width graph)) (1+ (height graph)))
+        
+    (set-fill (mapcar #'(lambda (c)
+			  (/ (+ (if (eq 1 c) .9 1)
+				c)
+			     2))
+		      (background (chart graph))))
+    (fill-and-stroke)))
+
+(defun draw-graph-outline (graph)
+  (with-graphics-state
+    (set-rgb-stroke 0 0 0)
+    (rectangle (1- (x graph)) (1- (y graph))
+	       (1+ (width graph)) (1+ (height graph)))
+    (stroke)))
+
+
+(defmethod dp->gp ((graph graph-region) x y)
+  "convert a point from data space to graph space"
+  (with-accessors ((d-o data-origin)
+		   (d-s data-scale)
+		   (gy y)
+		   (height height)) graph
+    (make-point (+ (x d-o) 
+		   (* (x d-s) x))
+		(max (y graph)
+		     (+ (y d-o) 
+			(* (y d-s) y))))))
+
+(defmethod gp->dp ((graph graph-region) x y)
+  "convert a point from graph space to data space"
+  (with-accessors ((d-o data-origin)
+		   (d-s data-scale)) graph
+    (make-point (/ (- x (x d-o)) 
+		   (x d-s))
+		(/ (- y (y d-o)) 
+		   (y d-s)))))
+
+(defmethod calculate-graph-bounds ((chart line-chart) graph)
+  (destructuring-bind ((min-x min-y) (max-x max-y))
+	    (find-chart-extremes chart)
+	  
+	  (setf (data-min graph)
+		(make-point min-x
+			    (* 0.99
+			       (if (draw-zero-p (y-axis chart))
+				   (min 0 min-y)
+				   min-y)))
+		(data-max graph)
+		(make-point max-x (* 1.01 max-y)))
+	  
+	  
+
+	  ;;TODO: make this a property of the series
+)
+  )
+
+(defvar *current-x* nil "keeps track of the current x coordinate for layout")
+
+(defmethod draw-chart ((chart line-chart))
+  (with-font ()
+    (let* ((width (width chart))
+	   (height (height chart))
+	   (graph-margin (margin chart))
+	   (text-height (font-height chart))
+	   (legend-space (* 4 text-height))
+	   (graph (make-instance 'graph-region 
+				 :x graph-margin
+				 :y (floor (+ legend-space graph-margin)) 
+				 :width (- width graph-margin graph-margin graph-margin)
+				 :height (- height graph-margin graph-margin 
+					    legend-space)
+				 :chart chart))
+	   (x-axis-labels-y nil)
+	   (*current-x* graph-margin))
+
+      ;;if we're going to be drawing any axes, set the font and color
+      (when (or (y-axis chart) (x-axis chart))      
+	(set-font *font* (label-size chart))
+	(set-rgb-fill 0 0 0)
+
+	;;move the graph region about
+	(when-let (axis (x-axis chart))
+	  (offset-y graph (* text-height
+			     (if (label axis)
+				 3
+				 2)))
+	    
+	  (setf x-axis-labels-y (- (y graph) graph-margin text-height))
+	  ;;draw the x-label
+	  (when-let (label (label axis))
+	    (draw-centered-string (+ (x graph) (/ (width graph) 2))
+				  (+ (/ graph-margin 2) legend-space)
+				  label)))
+
+	;;draw the y-label
+	(when-let (label (and (y-axis chart) 
+			      (label (y-axis chart))))
+	  (with-graphics-state
+	    ;;move to the site of the y axis label
+	    (translate (+ graph-margin text-height)
+		       (+ (y graph) (/ (height graph) 2)))
+	   
+	    ;;rotate the canvas so we're sideways	
+	    (rotate (/ pi 2))
+	    (draw-centered-string 0 0 label))
+	  (incf *current-x* (+ text-height graph-margin))))
+
+      (when (has-data-p chart)
+	;;figure out the right scaling factors so we fill the graph    
+					;find the min/max x/y across all series
+
+	(calculate-graph-bounds chart graph)
+	(let ((gridline-fns
+	       (when (or (y-axis chart) (x-axis chart))
+		 ;;set the drawing for grid-lines 
+		 (draw-axes graph *current-x*
+			    text-height
+			    x-axis-labels-y))))	  
+	  (draw-graph-area graph)
+	  (mapcar #'funcall gridline-fns))
+	(draw-series chart graph)
+	(draw-graph-outline graph)))))
+
+(defgeneric draw-series (chart graph))
+
+(defmethod draw-series ((chart line-chart) graph) 
+  (dolist (series (chart-elements chart))
+    (draw-line-series series graph)))
+
+(defun draw-line-series (series graph)
+  (with-graphics-state
+    (set-line-width 2)
+    (set-stroke series)
+    (loop for (x y) in (data series)
+	  for firstp = T then nil
+	  do (funcall (if firstp #'move #'line)
+		      (dp->gp graph x y)))
+    (stroke)))
+
+(defmethod translate-to-next-label ((chart line-chart) w h)
+  "moves the cursor right to the next legend position"
+  (declare (ignore chart h))
+  (translate w 0))
+
+(defmethod legend-start-coords ((chart line-chart) box-size label-spacing)
+  "starts the legends on the bottom row"
+  (declare (ignore box-size label-spacing))
+  (list (margin chart) (margin chart)))
+
+(defmacro with-line-chart ((width height &key (background ''(1 1 1))) &body body)
+  "Evaluates body with a chart established with the specified
+dimensions as the target for chart commands, with the specified background."
+  `(let ((*current-chart*  (make-instance 'line-chart
+					  :width ,width
+					  :height ,height
+					  :background ,background)))
+    ,@body))

src/vecto/packages.lisp

@@ -0,0 +1,4 @@
+(in-package :adw-charting)
+(use-package :vecto)
+(export '(with-pie-chart with-line-chart with-bar-chart with-chart
+	  set-rating set-color))

src/vecto/pie-charts.lisp

@@ -0,0 +1,90 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting)
+
+(defclass pie-chart (vchart)
+  ((total :accessor total :initarg :total :initform nil))
+  (:default-initargs :width 400))
+
+(defmethod total ((chart pie-chart))
+  "computes the pie-chart total based on the data, if no value is explicitly set"
+  (if-let (total (slot-value chart 'total))
+	  total
+	  (setf (total chart)
+		(loop for item in 
+		      (chart-elements chart)
+		      summing (value item)))))
+
+(defmethod radius ((chart pie-chart))
+  (truncate (/ (- (height chart) 10)
+	       2)))
+
+(defmethod translate-to-next-label ((chart pie-chart) w h)
+  (declare (ignore chart w))
+  (translate 0 (- h)))
+
+(defmethod legend-start-coords ((chart pie-chart) box-size label-spacing)
+  (list (* 2 (+ (radius chart) (margin chart)))
+	(- (height chart) box-size box-size label-spacing)))
+
+(defmethod has-data-p ((chart pie-chart))
+  (chart-elements chart))
+
+(defmethod draw-chart ((chart pie-chart))
+  (let* ((radius (radius chart))
+	 (width (width chart))
+	 (height (height chart))
+	 (cy (- height (+ 5 radius)))
+	 (cx (+ 5 radius))
+	 (slices (chart-elements chart)))
+    ;;draw the background circle
+    (set-rgb-stroke 0 0 0)
+    (set-rgb-fill 0 0 0)
+    (centered-circle-path cx cy (1+ radius))
+    (fill-and-stroke)
+    
+
+
+    (if (has-data-p chart)	  
+	(if (= 1 (length slices)) ;;only one slice, draw all over the damn thing and call it good.
+	    (progn
+	      (set-fill (first slices))
+	      (rectangle 0 0 width height)
+	      (fill-path))
+	    ;; more than one slice, go for it
+	    (let ((angle1 0)
+		  (val-to-radians (/ (* 2 pi) (total chart))))
+	      (dolist (item slices)
+		(let ((angle2 (+ angle1 (* val-to-radians (value item)))))
+		  (set-fill (color item))
+		  ;;start in the center
+		  (move-to cx cy)
+		  (arc cx cy radius angle1 angle2)
+		  (fill-and-stroke)
+		  (setf angle1 angle2))))) 
+	(setf (draw-legend-p chart) nil) ;;no data, supress the legend
+	)))
+
+(defmacro with-pie-chart ((width height &key (background ''(1 1 1))) &body body)
+  `(let ((*current-chart* (make-instance 'pie-chart
+					 :width ,width
+					 :height ,height
+					 :background ,background)))
+    ,@body))
+

src/vecto/star-rating-chart.lisp

@@ -0,0 +1,81 @@
+(in-package :adw-charting)
+
+(defclass star-rating-chart (chart chart-element)
+  ((number-of-stars :initform 5 :initarg :number-of-stars :accessor number-of-stars)
+   (rating :initform 0 :initarg :rating :accessor rating))
+  (:default-initargs
+      :draw-legend-p nil
+      )
+  )
+
+(defun set-rating (rating)
+  "Sets the rating for this star-rating chart"
+  (setf (rating *current-chart*) rating))
+
+(defun set-color (color)
+  "Sets the color for this star-rating chart"
+  (setf (color *current-chart*) color))
+
+(defvar *star-width* 0)
+
+(defun %draw-star-path (percent-of-width)
+  (let ((size (* percent-of-width *star-width*))
+	(angle 0)
+	(step (* 2 (/ (* pi 2) 5))))
+    (translate (/ *star-width* 2)
+	       (/ *star-width* 2))
+    (move-to 0 size)
+    (dotimes (i 5)
+      (setf angle (+ angle step))
+      (line-to (* (sin angle) size)
+	       (* (cos angle) size)))))
+
+(defun draw-star (filled-percent)
+  "draws one star, filling it a given percent"
+
+
+  (with-graphics-state
+    (set-fill (color *current-chart*))
+    
+    ;;draw a fully-filled in star
+    (with-graphics-state
+      (%draw-star-path .5)
+      (fill-path))
+
+    (when (< filled-percent 1)
+      ;;draw a slightly smaller star to wipe out the
+      ;;interior of the full star, leaving a border
+      (with-graphics-state
+	(set-fill (background *current-chart*))
+	(%draw-star-path .4)
+	(fill-path))
+
+      ;;re-fill in the full star, clipped to how full we're supposed to be
+      ;;wiping out part of the blanked interior
+      (when (plusp filled-percent)
+	(rectangle 0 0 (* filled-percent *star-width*) (height *current-chart*))
+	(clip-path)
+	(end-path-no-op)
+	(%draw-star-path .5)
+	(fill-path)))))
+
+(defmethod draw-chart ((chart star-rating-chart))
+  ;;figure out some basic measurements
+  (with-accessors ((width width)
+		   (height height)
+		   (number-of-stars number-of-stars)) chart
+    
+    (let* ((*star-width* height) ;;assume stars need to be square
+	   ;; calculate the spacing between stars, assuming num stars + 1 spacers
+	   (star-spacing (max 1
+				(truncate
+				 (/ (- width (* number-of-stars *star-width*))
+				    (1+ number-of-stars))))))
+      ;;draw our stars
+      (with-graphics-state
+	(translate star-spacing 0)
+	(loop for i from 1 to (number-of-stars chart)
+	      for fullness = (rating chart) then (1- fullness)
+	      do
+	   (draw-star (max 0 (min 1 fullness)))
+	   (translate (+ *star-width* star-spacing) 0))))))

test/lisp-unit.lisp

@@ -0,0 +1,429 @@
+;;;-*- Mode: Lisp; Package: LISP-UNIT -*-
+
+#|
+Copyright (c) 2004-2005 Christopher K. Riesbeck
+
+Permission is hereby granted, free of charge, to any person obtaining 
+a copy of this software and associated documentation files (the "Software"), 
+to deal in the Software without restriction, including without limitation 
+the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+and/or sell copies of the Software, and to permit persons to whom the 
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included 
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+
+;;; A test suite package, modelled after JUnit.
+;;; Author: Chris Riesbeck
+;;; 
+;;; Update history:
+;;;
+;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
+;;; 04/06/06 added ~<...~> to compact error output better [CKR]
+;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
+;;;          by Daniel Edward Burke) [CKR]
+;;; 02/08/06 added newlines to error output [CKR]
+;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
+;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
+;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, 
+;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
+;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
+;;; 08/30/05 added license notice [CKR]
+;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
+;;; 02/21/05 removed length check from SET-EQUAL [CKR]
+;;; 02/17/05 added RUN-ALL-TESTS [CKR]
+;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
+;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] 
+;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
+;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
+;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
+;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
+;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
+;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
+;;; 12/02/04 changed to group tests under packages [CKR]
+;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
+;;; 11/30/04 improved error handling and summarization [CKR]
+;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
+;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
+;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
+;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
+;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
+;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
+;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
+;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
+
+
+#|
+How to use
+----------
+
+1. Read the documentation in lisp-unit.html.
+
+2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
+examples. If you want, start your test file with (REMOVE-TESTS) to
+clear any previously defined tests.
+
+2. Load this file.
+
+2. (use-package :lisp-unit)
+
+3. Load your code file and your file of tests.
+
+4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
+or simply (RUN-TESTS) to run all defined tests.
+
+A summary of how many tests passed and failed will be printed,
+with details on the failures.
+
+Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
+functions or even macros does not require reloading any tests.
+
+For more information, see lisp-unit.html. 
+
+|#
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cl:defpackage #:lisp-unit
+  (:use #:common-lisp)
+  (:export #:define-test #:run-all-tests #:run-tests
+           #:assert-eq #:assert-eql #:assert-equal #:assert-equalp
+           #:assert-error #:assert-expands #:assert-false 
+           #:assert-equality #:assert-prints #:assert-true
+           #:get-test-code #:get-tests
+           #:remove-all-tests #:remove-tests
+           #:logically-equal #:set-equal
+           #:use-debugger
+           #:with-test-listener)
+  )
+
+(in-package #:lisp-unit)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Globals
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defparameter *test-listener* nil)
+
+(defparameter *tests* (make-hash-table))
+
+;;; Used by RUN-TESTS to collect summary statistics
+(defvar *test-count* 0)
+(defvar *pass-count* 0)
+
+;;; Set by RUN-TESTS for use by SHOW-FAILURE
+(defvar *test-name* nil)
+
+;;; If nil, errors in tests are caught and counted.
+;;; If :ask, user is given option of entering debugger or not.
+;;; If true and not :ask, debugger is entered.
+(defparameter *use-debugger* nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DEFINE-TEST
+
+(defmacro define-test (name &body body)
+  `(progn
+     (store-test-code ',name ',body)
+     ',name))
+
+;;; ASSERT macros
+
+(defmacro assert-eq (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eq))
+
+(defmacro assert-eql (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eql))
+
+(defmacro assert-equal (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equal))
+
+(defmacro assert-equalp (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equalp))
+
+(defmacro assert-error (condition form &rest extras)
+ (expand-assert :error form (expand-error-form form)
+                condition extras))
+
+(defmacro assert-expands (&environment env expansion form &rest extras)
+  (expand-assert :macro form 
+                 (expand-macro-form form #+lispworks nil #-lispworks env)
+                 expansion extras))
+
+(defmacro assert-false (form &rest extras)
+  (expand-assert :result form form nil extras))
+ 
+(defmacro assert-equality (test expected form &rest extras)
+ (expand-assert :equal form form expected extras :test test))
+
+(defmacro assert-prints (output form &rest extras)
+  (expand-assert :output form (expand-output-form form)
+                 output extras))
+
+(defmacro assert-true (form &rest extras)
+  (expand-assert :result form form t extras))
+
+
+(defun expand-assert (type form body expected extras &key (test #'eql))
+  `(internal-assert
+    ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
+  
+(defun expand-error-form (form)
+  `(handler-case ,form
+     (condition (error) error)))
+
+(defun expand-output-form (form)
+  (let ((out (gensym)))
+    `(let* ((,out (make-string-output-stream))
+            (*standard-output* (make-broadcast-stream *standard-output* ,out)))
+       ,form
+       (get-output-stream-string ,out))))
+
+(defun expand-macro-form (form env)
+  `(macroexpand-1 ',form ,env))
+
+(defun expand-extras (extras)
+  `#'(lambda ()
+       (list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
+    
+
+;;; RUN-TESTS
+
+(defmacro run-all-tests (package &rest tests)
+  `(let ((*package* (find-package ',package)))
+     (run-tests
+      ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
+          tests))))
+
+(defmacro run-tests (&rest names)
+  `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
+
+(defun get-test-thunks (names &optional (package *package*))
+  (mapcar #'(lambda (name) (get-test-thunk name package))
+    names))
+
+(defun get-test-thunk (name package)
+  (assert (get-test-code name package) (name package)
+          "No test defined for ~S in package ~S" name package)
+  (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
+
+(defun use-debugger (&optional (flag t))
+  (setq *use-debugger* flag))
+
+;;; WITH-TEST-LISTENER
+(defmacro with-test-listener (listener &body body)
+  `(let ((*test-listener* #',listener)) ,@body))
+  
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Public functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun get-test-code (name &optional (package *package*))
+  (let ((table (get-package-table package)))
+    (unless (null table)
+      (gethash name table))))
+
+(defun get-tests (&optional (package *package*))
+  (let ((l nil)
+        (table (get-package-table package)))
+    (cond ((null table) nil)
+          (t
+           (maphash #'(lambda (key val)
+                        (declare (ignore val))
+                        (push key l))
+                    table)
+           (sort l #'string< :key #'string)))))
+
+
+(defun remove-tests (names &optional (package *package*))
+  (let ((table (get-package-table package)))
+    (unless (null table)
+      (if (null names)
+          (clrhash table)
+        (dolist (name names)
+          (remhash name table))))))
+
+(defun remove-all-tests (&optional (package *package*))
+  (if (null package)
+      (clrhash *tests*)
+    (remhash (find-package package) *tests*)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Private functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; DEFINE-TEST support
+
+(defun get-package-table (package &key create)
+  (let ((table (gethash (find-package package) *tests*)))
+    (or table
+        (and create
+             (setf (gethash package *tests*)
+                   (make-hash-table))))))
+
+(defun get-test-name (form)
+  (if (atom form) form (cadr form)))
+
+(defun store-test-code (name code &optional (package *package*))
+  (setf (gethash name
+                 (get-package-table package :create t))
+        code))
+
+
+;;; ASSERTION support
+
+(defun internal-assert (type form code-thunk expected-thunk extras test)
+  (let* ((expected (multiple-value-list (funcall expected-thunk)))
+         (actual (multiple-value-list (funcall code-thunk)))
+         (passed (test-passed-p type expected actual test)))
+    
+    (incf *test-count*)
+    (when passed
+      (incf *pass-count*))
+    
+    (record-result passed type form expected actual extras)
+    
+    passed))
+
+(defun record-result (passed type form expected actual extras)
+  (funcall (or *test-listener* 'default-listener)
+           passed type *test-name* form expected actual 
+           (and extras (funcall extras))
+           *test-count* *pass-count*))
+
+(defun default-listener
+    (passed type name form expected actual extras test-count pass-count)
+  (declare (ignore test-count pass-count))
+  (unless passed
+    (show-failure type (get-failure-message type)
+                  name form expected actual extras)))
+
+(defun test-passed-p (type expected actual test)
+  (ecase type
+    (:error
+     (or (eql (car actual) (car expected))
+         (typep (car actual) (car expected))))
+    (:equal
+     (and (<= (length expected) (length actual))
+          (every test expected actual)))
+    (:macro
+     (equal (car actual) (car expected)))
+    (:output
+     (string= (string-trim '(#\newline #\return #\space) 
+                           (car actual))
+              (car expected)))
+    (:result
+     (logically-equal (car actual) (car expected)))
+    ))
+
+
+;;; RUN-TESTS support
+
+(defun run-test-thunks (test-thunks)
+  (unless (null test-thunks)
+    (let ((total-test-count 0)
+          (total-pass-count 0)
+          (total-error-count 0))
+      (dolist (test-thunk test-thunks)
+        (multiple-value-bind (test-count pass-count error-count)
+            (run-test-thunk (car test-thunk) (cadr test-thunk))
+          (incf total-test-count test-count)
+          (incf total-pass-count pass-count)
+          (incf total-error-count error-count)))
+      (unless (null (cdr test-thunks))
+        (show-summary 'total total-test-count total-pass-count total-error-count))
+      (values))))
+
+(defun run-test-thunk (*test-name* thunk)
+  (if (null thunk)
+      (format t "~&    Test ~S not found" *test-name*)
+    (prog ((*test-count* 0)
+           (*pass-count* 0)
+           (error-count 0))
+      (handler-bind 
+          ((error #'(lambda (e)
+                      (let ((*print-escape* nil))
+                        (setq error-count 1)         
+                        (format t "~&    ~S: ~W" *test-name* e))
+                      (if (use-debugger-p e) e (go exit)))))
+        (funcall thunk)
+        (show-summary *test-name* *test-count* *pass-count*))
+      exit
+      (return (values *test-count* *pass-count* error-count)))))
+
+(defun use-debugger-p (e)
+  (and *use-debugger*
+       (or (not (eql *use-debugger* :ask))
+           (y-or-n-p "~A -- debug?" e))))
+
+;;; OUTPUT support
+
+(defun get-failure-message (type)
+  (case type
+    (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
+    (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    ))
+
+(defun show-failure (type msg name form expected actual extras)
+  (format t "~&~@[~S: ~]~S failed: " name form)
+  (format t msg expected actual)
+  (format t "~{~&   ~S => ~S~}~%" extras)
+  type)
+
+(defun show-summary (name test-count pass-count &optional error-count)
+  (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
+          name pass-count (- test-count pass-count) error-count))
+
+(defun collect-form-values (form values)
+  (mapcan #'(lambda (form-arg value)
+              (if (constantp form-arg)
+                  nil
+                (list form-arg value)))
+          (cdr form)
+          values))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Useful equality predicates for tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (LOGICALLY-EQUAL x y) => true or false
+;;;   Return true if x and y both false or both true
+
+(defun logically-equal (x y)
+  (eql (not x) (not y)))
+
+;;; (SET-EQUAL l1 l2 :test) => true or false
+;;;   Return true if every element of l1 is an element of l2
+;;;   and vice versa.
+
+(defun set-equal (l1 l2 &key (test #'equal))
+  (and (listp l1)
+       (listp l2)
+       (subsetp l1 l2 :test test)
+       (subsetp l2 l1 :test test)))
+
+
+(provide "lisp-unit")

test/test-package.lisp

@@ -0,0 +1,21 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(defpackage :net.acceleration.charting.tests
+    (:nicknames #:adw-charting-tests)
+    (:use #:cl #:adw-charting #:lisp-unit))

test/tests.lisp

@@ -0,0 +1,38 @@
+;; Copyright (c) 2008 Accelerated Data Works, Ryan Davis
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation files
+;; (the "Software"), to deal in the Software without restriction,
+;; including without limitation the rights to use, copy, modify, merge,
+;; publish, distribute, sublicense, and/or sell copies of the Software,
+;; and to permit persons to whom the Software is furnished to do so,
+;; subject to the following conditions:
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(in-package :adw-charting-tests)
+
+(define-test pie-chart-total
+  (assert-equal 10 (adw-charting::total (make-instance 'adw-charting::pie-chart :total 10))))
+
+(define-test pie-chart-calculated-total
+  "tests summing the pie-chart total from the data items"
+  (assert-equal 45
+		(with-pie-chart (400 400)
+		  (add-slice "A" 10)
+		  (add-slice "B" 15)
+		  (add-slice "C" 20)
+		  (adw-charting::total adw-charting::*current-chart*))))
+
+;;;;test that the example programs run
+(define-test examples
+  (assert-true (and (minimal-pie-chart)
+		    (minimal-line-chart)
+		    (customized-line-chart)
+		    (boinkmark))))