;-*- Mode: Lisp; Package: (graph :use (common-lisp ccl g)) -*-
; Source Code for Graph.lisp, a quick-graphing tool for
; for Macintosh Common Lisp. See http://www.cs.ualberta.ca/~sutton/graph.html.
(defpackage :graph
(:use :common-lisp :ccl :g))
(in-package :graph)
(export '(graph graph+ graph- add-to-graph subtract-from-graph grid-graph x-graph-limits y-graph-limits
x-tick-marks y-tick-marks choose-graph print-graph graph-data))
; A graph is a window with various state vars. The simplest way to use this is:
; (graph data)
; and then, possibly, (graph+ data)
; The graph involved defaults to the frontmost graph or a newly created graph
; if their are no graphs yet (or if graph is t). Alternatively, you can make
; multiple graphs, and specify the graph as a last argument to all graph routines.
; Data can be a simple list of y's (heights) or a list of list of y's.
; Or it can be a list of (x y) coordinates, e.g., ((x1 y1) (x2 y2) ...)
; Or a list of those!
; The span of the graph is initially set from the data. Alternatively:
; (x-graph-limits xmin xmax) does it manually (same for y-graph-limits)
; (x-graph-limits) sets it back to auto
; Tick marks are initially just at the min and max. Alternatively:
; (x-tick-marks tick1 tick2 tick3 ...) sets them manually (same for y-tick-marks)
; (x-tick-marks) sets them back to auto
; Tick marks are specified by values, e.g., (x-tick-marks 0 .5 1.0)
; or by a list of value-label pairs, e.g., (x-tick-marks '(0 "0") '(1.0 "1"))
(defclass graph (g-window)
((data-view :accessor data-view)
(data :initform nil)
(auto-limits-x :initform t) ; limiting x values from data,
(auto-limits-y :initform t) ; or from user and tick-marks?
(x-max :initform 1.0)
(x-min :initform 0.0)
(y-max :initform 1.0)
(y-min :initform 0.0)
(x-tick-marks :initform nil) ; initial tick marks auto from limits
(y-tick-marks :initform nil)
(main-color)
(character-style :initform '("Geneva" 9 :plain))
(character-width :initform 6)
(character-height :initform 8)
(x-label-space)
(y-label-space)
(zero-space :initform 10)
(x-end-space :initform 50)
(y-end-space :initform 10)
(tick-length :initform t)
(boxy :initform nil)
(grid-density :initform nil)
(highlight-p :initform nil)
(highlight-color)
(highlight-line :initform 0)))
;; The data is a list of lists. Each list is either a list of y-values or
;; a list of xy-pairs.
(defmethod initialize-instance ((graph graph) &key (data-view-type 'data-view))
(without-event-processing
(call-next-method)
(with-slots (main-color highlight-color data-view x-label-space y-label-space character-width
character-height tick-length zero-space
x-min y-min x-max y-max) graph
(setq data-view (make-instance data-view-type :parent graph))
(g-set-coordinate-system data-view x-min y-min x-max y-max :lower-left)
(setq x-label-space (* 11 character-width))
(setq y-label-space (+ 10 character-height))
(setq tick-length (/ zero-space 2))
(setq main-color (g-color-on data-view))
(setq highlight-color (g-color-pen data-view (g-color-flip data-view) nil nil 2 2))
(g-accept-new-viewport-size graph))))
(defmethod g-accept-new-viewport-size :before ((graph graph))
(g-set-cs-scale graph 0 0 1 1 :lower-left))
(defmethod g-accept-new-viewport-size :after ((graph graph))
(with-slots (x-label-space zero-space y-label-space zero-space x-end-space y-end-space
data-view) graph
(multiple-value-bind (x1 y1 x2 y2) (g-get-coordinate-system graph)
(declare (ignore x1 y1))
(g-set-viewport data-view
(+ x-label-space zero-space)
(+ y-label-space zero-space)
(- x2 x-end-space)
(- y2 y-end-space)))
(g-clear graph)
(g-draw-view graph)))
(defclass data-view (g-view) ())
(defun graph (new-data &optional color graph) ;[Doc]
"Establishes some data for a graph, then draws it"
(if (OR (null new-data) (loop for d in new-data never d))
(print "No graphing data")
(let ((original-front-window (front-window)))
(setq new-data (loop for d in new-data for n from 0 when d collect d
when (null d) do (format t "~%Warning: Nth data-to-be-graphed is nil for N=~A" n)))
(cond ((stringp color) (setq graph color) (setq color nil))
((keywordp color) (setq color (color-from-keyword color))))
(setq graph (choose-graph graph))
(with-slots (data highlight-line highlight-p) graph
(setf data (fillin-nil-colors (regularize-data new-data color)))
(setq highlight-line 0)
(setq highlight-p nil)
(compute-limits-from-data graph)
(g-clear graph)
(g-draw-view graph)
(unless (eq graph (front-window)) (window-select graph))
(window-select original-front-window)))))
(defun regularize-data (data color)
"regular form is a list of lines, each of which is a list or list of pairs, preceded by color"
(cond ((atom (first data)) ; simple list
(list (cons color data)))
((listp (first (first data))) ; list of lists of pairs
(loop for d in data collect (cons color d)))
((= 2 (length (first data))) ; list of pairs
(list (cons color data)))
(t ; list of lists
(loop for d in data collect (cons color d)))))
(defun fillin-nil-colors (data)
(loop for color-line in data
when (null (first color-line))
do (setf (first color-line) (first-unused-color data)))
data)
(defun graph-data (&optional graph)
"Returns the data plotted in graph, with color stripped away of course"
(loop for (color . line) in (slot-value (choose-graph graph) 'data)
collect line))
(defun first-x (data)
"returns the x-value of the first point in data"
(let* ((line (loop for line in data until line finally return line))
(first-point (second line)))
(if (not (consp first-point))
1
(first first-point))))
(defun first-y (data)
"returns the y-value of the first point in data"
(let* ((line (loop for line in data until line finally return line))
(first-point (second line)))
(if (not (consp first-point))
first-point
(second first-point))))
(defun graph+ (new-data &optional color graph) ;[Doc]
(add-to-graph new-data color graph))
(defun add-to-graph (new-data &optional color graph) ;[Doc]
"Adds additional data to a graph"
(if (OR (null new-data) (loop for d in new-data never d))
(print "No graphing data added")
(let ((original-front-window (front-window)))
(setq new-data (loop for d in new-data for n from 0 when d collect d
when (null d) do (format t "~%Warning: Nth data-to-be-graphed is nil for N=~A" n)))
(cond ((stringp color) (setq graph color) (setq color nil))
((keywordp color) (setq color (color-from-keyword color))))
(setq graph (choose-graph graph))
(with-slots (data) graph
(setf data (fillin-nil-colors (append data (regularize-data new-data color))))
(compute-limits-from-data graph)
(g-clear graph)
(g-draw-view graph)
(unless (eq graph (front-window)) (window-select graph))
(window-select original-front-window)))))
(defun graph- (&optional color-keyword graph) ;[Doc]
"Remove a line of data points from the graph. Defaults to last line"
(if (not color-keyword)
(subtract-from-graph nil graph)
(with-slots (data) (setq graph (choose-graph graph))
(loop with remove-color = (color-from-keyword color-keyword)
for (color . list) in data
for line-num from 0
when (eq color remove-color)
do (subtract-from-graph line-num graph)
(return-from graph-)
finally (print "No such color used in this graph")))))
(defun subtract-from-graph (&optional line-num graph) ;[Doc]
"Remove a line of data points from the graph. Line-num is from zero or defaults to last line"
(let ((original-front-window (front-window)))
(setq graph (choose-graph graph))
(with-slots (data) graph
(unless line-num (setq line-num (- (length data) 1)))
(setf data (loop for line in data
for num from 0
unless (eq num line-num) collect line))
(compute-limits-from-data graph)
(g-clear graph)
(g-draw-view graph)
(unless (eq graph (front-window)) (window-select graph))
(window-select original-front-window))))
(defun x-graph-limits (&optional xmin xmax (graph (choose-graph))) ;[Doc]
(setq graph (choose-graph graph))
(with-slots (auto-limits-x data-view x-min y-min x-max y-max) graph
(if (or xmin xmax)
(progn (setf auto-limits-x nil)
(if xmin (setf x-min xmin))
(if xmax (setf x-max xmax))
(g-set-coordinate-system data-view x-min y-min x-max y-max :lower-left))
(progn (setf auto-limits-x t)
(compute-limits-from-data graph)))
(g-clear graph)
(g-draw-view graph)))
(defun y-graph-limits (&optional ymin ymax (graph (choose-graph))) ;[Doc]
(setq graph (choose-graph graph))
(with-slots (auto-limits-y data-view x-min y-min x-max y-max) graph
(if (or ymin ymax)
(progn (setf auto-limits-y nil)
(if ymin (setf y-min ymin))
(if ymax (setf y-max ymax))
(g-set-coordinate-system data-view x-min y-min x-max y-max :lower-left))
(progn (setf auto-limits-y t)
(compute-limits-from-data graph)))
(g-clear graph)
(g-draw-view graph)))
(defun x-tick-marks (&rest x-ticks) ;[Doc]
"Sets the ticks marks and possibly resets limits."
(let ((graph (choose-graph)))
(with-slots (data-view x-tick-marks x-min y-min x-max y-max) graph
(if x-ticks
(progn (setf x-tick-marks (regularize-tick-marks x-ticks))
(setq x-min (min x-min (min-tick-mark x-tick-marks)))
(setq x-max (max x-max (max-tick-mark x-tick-marks)))
(g-set-coordinate-system data-view x-min y-min x-max y-max :lower-left))
(progn (setq x-tick-marks nil)
(compute-limits-from-data graph)))
(g-clear graph)
(g-draw-view graph))))
(defun y-tick-marks (&rest y-ticks) ;[Doc]
"Sets the ticks marks and possibly resets limits."
(let ((graph (choose-graph)))
(with-slots (y-tick-marks) graph
(if y-ticks
(progn (setf y-tick-marks (regularize-tick-marks y-ticks))
(compute-limits-from-data graph))
(progn (setq y-tick-marks nil)
(compute-limits-from-data graph)))
(g-clear graph)
(g-draw-view graph))))
(defun regularize-tick-marks (ticks &optional (format-string "~A"))
(loop for tick in ticks
when (atom tick) collect (list tick (format nil format-string tick))
else collect tick))
(defun min-tick-mark (ticks)
(let ((first (first ticks)))
(if (atom first)
first
(first first))))
(defun max-tick-mark (ticks)
(let ((last (first (last ticks))))
(if (atom last)
last
(first last))))
(defmethod g-draw-view ((graph graph))
"Draws the graph"
(with-slots (data grid-density highlight-p) graph
(draw-axes graph)
(loop for (color . list) in data
for line-num from 0
do (draw-line graph list color))
(when highlight-p (draw-highlight graph))
(if grid-density (grid-graph nil graph))))
(defvar colors (list (g-color-red t)
(g-color-green t)
(g-color-blue t)
(g-color-black t)
(g-color-yellow t)
(g-color-pink t)
(g-color-cyan t)
(g-color-purple t)
(g-color-magenta t)
(g-color-orange t)
(g-color-brown t)
(g-color-light-blue t)
(g-color-gray t)
(g-color-dark-green t)
(g-color-tan t)))
(defun nth-color (n) ;[Doc]
(nth (mod n (length colors)) colors))
(defun color-from-keyword (color-keyword)
(case color-keyword
(:blue g::blue)
(:red g::red)
(:green g::green)
(:black g::black)
(:yellow g::yellow)
(:pink g::pink)
(:cyan g::cyan)
(:purple g::purple)
(:magenta g::magenta)
(:orange g::orange)
(:brown g::brown)
(:light-blue g::light-blue)
(:gray g::gray)
(:dark-green g::dark-green)
(:tan g::tan)
(:white g::white)
(:light-gray g::light-gray)
(:dark-gray g::dark-gray)
(t (error "Unrecognized color keyword: ~A" color-keyword))))
(defun first-unused-color (data)
"Returns first color in the list of colors that is least used in data"
(loop for permitted-times-used from 0 do
(loop for color in colors
when (<= (times-color-used color data) permitted-times-used)
do (return-from first-unused-color color))))
(defun times-color-used (color data)
(loop for (c . list) in data count (eq c color)))
(defun choose-graph (&optional graph) ;[Doc]
"Select a graph based on input 'graph'"
(cond ((typep graph 'graph)
graph)
((typep graph 'string)
(or (find-window graph 'graph)
(make-instance 'graph :window-title graph)))
((null graph)
(or (front-window :class 'graph)
(make-instance 'graph :window-title "Graph")))
((eq graph t)
(make-instance 'graph :window-title "Graph"))
(t (error "Can't chose graph" graph))))
(defun draw-axes (&optional graph)
(setq graph (choose-graph graph))
(with-slots (x-label-space y-label-space data-view x-max y-max main-color) graph
(g-draw-line graph
x-label-space y-label-space
(g-convert-x data-view graph x-max) y-label-space
main-color)
(g-draw-line graph
x-label-space y-label-space
x-label-space (g-convert-y data-view graph y-max)
main-color)
(draw-tick-marks graph)))
(defun draw-tick-marks (graph)
(with-slots (main-color x-tick-marks y-tick-marks x-label-space y-label-space
data-view tick-length character-style x-min y-min x-max y-max
character-width character-height) graph
(loop for (x label) in (or x-tick-marks (regularize-tick-marks (list x-min x-max)))
for gx = (g-convert-x data-view graph x)
when (<= x-min x x-max)
do
(g-draw-line-r graph gx y-label-space 0 tick-length main-color)
(g-draw-text graph label character-style
(- gx (/ (* character-width (length label)) 2))
(- y-label-space 5 character-height) main-color))
(loop for (y label) in (or y-tick-marks (regularize-tick-marks (list y-min y-max) "~7F"))
for gy = (g-convert-y data-view graph y)
when (<= y-min y y-max)
do
(g-draw-line-r graph x-label-space gy tick-length 0 main-color)
(g-draw-text graph label character-style
(- x-label-space 5 (* character-width (length label)))
(- gy (/ character-height 2)) main-color))))
(defun draw-segment (graph x1 y1 x2 y2 color)
(with-slots (data-view boxy) graph
(if boxy
(progn (g-draw-line data-view x1 y1 x2 y1 color)
(g-draw-line data-view x2 y1 x2 y2 color))
(g-draw-line data-view x1 y1 x2 y2 color))))
(defun draw (graph y-list color)
(loop for x1 from 1 below (length y-list)
for x2 from 2 upto (length y-list)
for y1 in y-list
for y2 in (cdr y-list)
do
(draw-segment graph x1 y1 x2 y2 color)))
(defun draw-xy (graph xylist color)
(loop for (x1 y1) in xylist
for (x2 y2) in (cdr xylist)
do
(draw-segment graph x1 y1 x2 y2 color)))
(defun compute-limits-from-data (graph)
(with-slots (auto-limits-x auto-limits-y data-view data x-min x-max y-min y-max
x-tick-marks y-tick-marks) graph
(when auto-limits-x
(setq x-min (or (min-tick-mark x-tick-marks) (first-x data)))
(setq x-max (or (max-tick-mark x-tick-marks) (first-x data))))
(when auto-limits-y
(setq y-min (or (min-tick-mark y-tick-marks) (first-y data)))
(setq y-max (or (max-tick-mark y-tick-marks) (first-y data))))
(when (or auto-limits-x auto-limits-y)
(loop for list in data do
(setq list (rest list))
(cond ((atom (first list))
(when auto-limits-y
(loop for y in list do
(if (< y y-min) (setq y-min y))
(if (> y y-max) (setq y-max y))))
(when auto-limits-x
(if (< 1 x-min) (setq x-min 1))
(if (> (length list) x-max) (setq x-max (length list)))))
(t (loop for (x y) in list do
(when auto-limits-y
(if (< y y-min) (setq y-min y))
(if (> y y-max) (setq y-max y)))
(when auto-limits-x
(if (< x x-min) (setq x-min x))
(if (> x x-max) (setq x-max x)))))))
(when (= y-min y-max)
(format t "~%Warning: all lines are flat at ~A" y-min)
(if (> y-max 0)
(setq y-min 0)
(setq y-min (- y-max 1))))
(g-set-coordinate-system data-view x-min y-min x-max y-max :lower-left))))
(defun grid-graph (&optional grid-densit graph) ;[Doc]
(setq graph (choose-graph graph))
(with-slots (data-view grid-density x-tick-marks y-tick-marks
x-max x-min y-max y-min main-color) graph
(when grid-densit (setq grid-density grid-densit))
(setq grid-density (or grid-density 5))
(loop for (x label) in x-tick-marks
for dx = (gd-coord-x data-view x)
when (<= x-min x x-max)
do label ; to prevent warning that label is ignored
(loop for dy from (gd-coord-y data-view y-min)
downto (gd-coord-y data-view y-max) by grid-density do
(gd-draw-point data-view dx dy main-color)))
(loop for (y label) in y-tick-marks
for dy = (gd-coord-y data-view y)
when (<= y-min y y-max)
do label ; to prevent warning that label is ignored
(loop for dx from (gd-coord-x data-view x-min)
to (gd-coord-x data-view x-max) by grid-density do
(gd-draw-point data-view dx dy main-color)))))
(defmethod g-cursor ((v data-view) x y)
(declare (ignore x y))
*cross-hair-cursor*)
(defmethod g-click-event-handler ((v data-view) x y)
(print (list x y)))
(defmethod view-key-event-handler ((graph graph) char)
(with-slots (data highlight-p highlight-line) graph
(case char
((#\h #\Space)
(setq highlight-p (not highlight-p))
(draw-highlight graph))
(#\ ; back arrow
(when highlight-p
(draw-highlight graph)
(setf highlight-line (mod (- highlight-line 1) (length data)))
(draw-highlight graph)))
(#\ ; space or forward arrow
(when highlight-p
(draw-highlight graph)
(setf highlight-line (mod (+ highlight-line 1) (length data)))
(draw-highlight graph))))))
(defun draw-highlight (graph)
(with-slots (data highlight-line highlight-color) graph
(draw-line graph (rest (nth highlight-line data)) highlight-color)))
(defun draw-line (graph line color)
(if (atom (first line))
(draw graph line color)
(draw-xy graph line color)))
(defmethod window-hardcopy ((graph graph) &optional (show-dialog? t))
(let (picture)
(start-picture graph)
(g-draw-view graph)
(setq picture (get-picture graph))
(sleep .5)
(picture-hardcopy picture show-dialog?)
(kill-picture picture)))
(export '(histogram histogram+))
; A histogram is a graph, created in a particular way
; (histogram data num-bins min max graph)
(defun histogram (data &key num-bins min max-excl color graph) ;[Doc]
"plots histogram of data, min <= data < max-excl, in a color on a graph named graph"
(unless data (error "No graphing data"))
(when (= (length data) 1) (error "Can't histogram a single datum"))
(unless min (setq min (loop for d in data minimize d)))
(let ((max (loop for d in data maximize d)))
(when (= max min) (error "Data min=max; no histogram possible"))
(when (and (integerp max) (integerp min))
(unless max-excl (setq max-excl (+ 1 max)))
(unless (or num-bins (> (- max min) 200))
(setq num-bins (- max-excl min))))
(unless num-bins (setq num-bins 30))
(unless max-excl (setq max-excl (+ max (* .00001 (/ (- max min) num-bins))))))
(setq graph (choose-graph graph))
(when (string= "Graph" (window-title graph)) (set-window-title graph "Histogram"))
(setf (slot-value graph 'boxy) t)
(loop with bins = (make-array num-bins :initial-element 0)
with num-too-small = 0 and num-too-big = 0
with scale-factor = (/ num-bins (- max-excl min))
for d in data
for bin = (truncate (* (- d min) scale-factor))
do (cond ((< bin 0) (incf num-too-small))
((>= bin num-bins) (incf num-too-big))
(t (incf (aref bins bin))))
finally (progn (graph (loop for i below num-bins
collect (list (+ min (/ i scale-factor))
(aref bins i))
when (= i (- num-bins 1))
collect (list max-excl (aref bins i)))
color graph)
(unless (= 0 num-too-big)
(format t "~%~A data points were above the range" num-too-big))
(unless (= 0 num-too-small)
(format t "~%~A data points were below the range" num-too-small)))))
(defun histogram+ (data &key num-bins min max-excl color graph) ;[Doc]
"adds histogram of data, min <= data < max-excl, in a color to a graph named graph"
(unless data (error "No graphing data"))
(when (= (length data) 1) (error "Can't histogram a single datum"))
(unless min (setq min (loop for d in data minimize d)))
(let ((max (loop for d in data maximize d)))
(when (= max min) (error "Data min=max; no histogram possible"))
(when (and (integerp max) (integerp min))
(unless max-excl (setq max-excl (+ 1 max)))
(unless (or num-bins (> (- max min) 200))
(setq num-bins (- max-excl min))))
(unless num-bins (setq num-bins 30))
(unless max-excl (setq max-excl (+ max (* .00001 (/ (- max min) num-bins))))))
(setq graph (choose-graph graph))
(when (string= "Graph" (window-title graph)) (set-window-title graph "Histogram"))
(setf (slot-value graph 'boxy) t)
(loop with bins = (make-array num-bins :initial-element 0)
with num-too-small = 0 and num-too-big = 0
with scale-factor = (/ num-bins (- max-excl min))
for d in data
for bin = (truncate (* (- d min) scale-factor))
do (cond ((< bin 0) (incf num-too-small))
((>= bin num-bins) (incf num-too-big))
(t (incf (aref bins bin))))
finally (progn (graph+ (loop for i below num-bins
collect (list (+ min (/ i scale-factor))
(aref bins i))
when (= i (- num-bins 1))
collect (list max-excl (aref bins i)))
color graph)
(unless (= 0 num-too-big)
(format t "~%~A data points were above the range" num-too-big))
(unless (= 0 num-too-small)
(format t "~%~A data points were below the range" num-too-small)))))
#| EXAMPLES:
(graph '(1 2 3 3 2 1)) ;Graphs the numbers, as heights
(graph (loop for x from 0 to 20 by .1 collect (sin x))) ;Graphs (sin x)
(graph '((1 5) (7 8) (4 2))) ;Graphs line by x,y coordinates
(graph (loop for x from 0 to 3.14 by .01 ;Detailed graph of (sin x)
collect (list x (sin x))))
(graph (list (loop for x from 0 to 20 collect (sin x)) ;Graphs (sin x) and (cos x)
(loop for x from 0 to 20 collect (cos x)))) ;as 2 lines on the same graph
(graph (loop for x below 20 collect (sin x)) "Sine") ; new graph window
(graph (loop for x below 20 collect (cos x)) "Cosine") ; 2nd graph window
(graph (loop for x from 0 to 3.14 by .01 collect (sin x)) "Sine")
;; ADDING TO EXISTING GRAPH
(graph (loop for x below 20 collect (sin x)) :red) ; red sin line
(graph+ (loop for x below 20 collect (cos x)) :blue) ; second blue line on same graph
;; HISTOGRAM
(histogram (loop repeat 100 collect (random 10)))
|#
;