| 1 | ;;; chart.el --- Draw charts (bar charts, etc) |
| 2 | |
| 3 | ;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2012 |
| 4 | ;; Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> |
| 7 | ;; Version: 0.2 |
| 8 | ;; Keywords: OO, chart, graph |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or |
| 15 | ;; (at your option) any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | ;; |
| 27 | ;; This package is an experiment of mine aiding in the debugging of |
| 28 | ;; eieio, and proved to be neat enough that others may like to use |
| 29 | ;; it. To quickly see what you can do with chart, run the command |
| 30 | ;; `chart-test-it-all'. |
| 31 | ;; |
| 32 | ;; Chart current can display bar-charts in either of two |
| 33 | ;; directions. It also supports ranged (integer) axis, and axis |
| 34 | ;; defined by some set of strings or names. These name can be |
| 35 | ;; automatically derived from data sequences, which are just lists of |
| 36 | ;; anything encapsulated in a nice eieio object. |
| 37 | ;; |
| 38 | ;; Current example apps for chart can be accessed via these commands: |
| 39 | ;; `chart-file-count' - count files w/ matching extensions |
| 40 | ;; `chart-space-usage' - display space used by files/directories |
| 41 | ;; `chart-emacs-storage' - Emacs storage units used/free (garbage-collect) |
| 42 | ;; `chart-emacs-lists' - length of Emacs lists |
| 43 | ;; `chart-rmail-from' - who sends you the most mail (in -summary only) |
| 44 | ;; |
| 45 | ;; Customization: |
| 46 | ;; |
| 47 | ;; If you find the default colors and pixmaps unpleasant, or too |
| 48 | ;; short, you can change them. The variable `chart-face-color-list' |
| 49 | ;; contains a list of colors, and `chart-face-pixmap-list' contains |
| 50 | ;; all the pixmaps to use. The current pixmaps are those found on |
| 51 | ;; several systems I found. The two lists should be the same length, |
| 52 | ;; as the long list will just be truncated. |
| 53 | ;; |
| 54 | ;; If you would like to draw your own stipples, simply create some |
| 55 | ;; xbm's and put them in a directory, then you can add: |
| 56 | ;; |
| 57 | ;; (setq x-bitmap-file-path (cons "~/mybitmaps" x-bitmap-file-path)) |
| 58 | ;; |
| 59 | ;; to your .emacs (or wherever) and load the `chart-face-pixmap-list' |
| 60 | ;; with all the bitmaps you want to use. |
| 61 | |
| 62 | (require 'eieio) |
| 63 | |
| 64 | ;;; Code: |
| 65 | (defvar chart-mode-map (make-sparse-keymap) "Keymap used in chart mode.") |
| 66 | (define-obsolete-variable-alias 'chart-map 'chart-mode-map "24.1") |
| 67 | |
| 68 | (defvar chart-local-object nil |
| 69 | "Local variable containing the locally displayed chart object.") |
| 70 | (make-variable-buffer-local 'chart-local-object) |
| 71 | |
| 72 | (defvar chart-face-color-list '("red" "green" "blue" |
| 73 | "cyan" "yellow" "purple") |
| 74 | "Colors to use when generating `chart-face-list'. |
| 75 | Colors will be the background color.") |
| 76 | |
| 77 | (defvar chart-face-pixmap-list |
| 78 | (if (and (fboundp 'display-graphic-p) |
| 79 | (display-graphic-p)) |
| 80 | '("dimple1" "scales" "dot" "cross_weave" "boxes" "dimple3")) |
| 81 | "If pixmaps are allowed, display these background pixmaps. |
| 82 | Useful if new Emacs is used on B&W display.") |
| 83 | |
| 84 | (defcustom chart-face-use-pixmaps nil |
| 85 | "*Non-nil to use fancy pixmaps in the background of chart face colors." |
| 86 | :group 'eieio |
| 87 | :type 'boolean) |
| 88 | |
| 89 | (defvar chart-face-list |
| 90 | (if (if (fboundp 'display-color-p) |
| 91 | (display-color-p) |
| 92 | window-system) |
| 93 | (let ((cl chart-face-color-list) |
| 94 | (pl chart-face-pixmap-list) |
| 95 | (faces ()) |
| 96 | nf) |
| 97 | (while cl |
| 98 | (setq nf (make-face |
| 99 | (intern (concat "chart-" (car cl) "-" (car pl))))) |
| 100 | (set-face-background nf (if (condition-case nil |
| 101 | (> (x-display-color-cells) 4) |
| 102 | (error t)) |
| 103 | (car cl) |
| 104 | "white")) |
| 105 | (set-face-foreground nf "black") |
| 106 | (if (and chart-face-use-pixmaps |
| 107 | pl |
| 108 | (fboundp 'set-face-background-pixmap)) |
| 109 | (condition-case nil |
| 110 | (set-face-background-pixmap nf (car pl)) |
| 111 | (error (message "Cannot set background pixmap %s" (car pl))))) |
| 112 | (push nf faces) |
| 113 | (setq cl (cdr cl) |
| 114 | pl (cdr pl))) |
| 115 | faces)) |
| 116 | "Faces used to colorize charts. |
| 117 | List is limited currently, which is ok since you really can't display |
| 118 | too much in text characters anyways.") |
| 119 | |
| 120 | (define-derived-mode chart-mode fundamental-mode "CHART" |
| 121 | "Define a mode in Emacs for displaying a chart." |
| 122 | (buffer-disable-undo) |
| 123 | (set (make-local-variable 'font-lock-global-modes) nil) |
| 124 | (font-lock-mode -1) ;Isn't it off already? --Stef |
| 125 | ) |
| 126 | |
| 127 | (defun chart-new-buffer (obj) |
| 128 | "Create a new buffer NAME in which the chart OBJ is displayed. |
| 129 | Returns the newly created buffer." |
| 130 | (with-current-buffer (get-buffer-create (format "*%s*" (oref obj title))) |
| 131 | (chart-mode) |
| 132 | (setq chart-local-object obj) |
| 133 | (current-buffer))) |
| 134 | |
| 135 | (defclass chart () |
| 136 | ((title :initarg :title |
| 137 | :initform "Emacs Chart") |
| 138 | (title-face :initarg :title-face |
| 139 | :initform 'bold-italic) |
| 140 | (x-axis :initarg :x-axis |
| 141 | :initform nil ) |
| 142 | (x-margin :initarg :x-margin |
| 143 | :initform 5) |
| 144 | (x-width :initarg :x-width |
| 145 | ) |
| 146 | (y-axis :initarg :y-axis |
| 147 | :initform nil) |
| 148 | (y-margin :initarg :y-margin |
| 149 | :initform 5) |
| 150 | (y-width :initarg :y-width |
| 151 | ) |
| 152 | (key-label :initarg :key-label |
| 153 | :initform "Key") |
| 154 | (sequences :initarg :sequences |
| 155 | :initform nil) |
| 156 | ) |
| 157 | "Superclass for all charts to be displayed in an Emacs buffer.") |
| 158 | |
| 159 | (defmethod initialize-instance :AFTER ((obj chart) &rest fields) |
| 160 | "Initialize the chart OBJ being created with FIELDS. |
| 161 | Make sure the width/height is correct." |
| 162 | (oset obj x-width (- (window-width) 10)) |
| 163 | (oset obj y-width (- (window-height) 12))) |
| 164 | |
| 165 | (defclass chart-axis () |
| 166 | ((name :initarg :name |
| 167 | :initform "Generic Axis") |
| 168 | (loweredge :initarg :loweredge |
| 169 | :initform t) |
| 170 | (name-face :initarg :name-face |
| 171 | :initform 'bold) |
| 172 | (labels-face :initarg :labels-face |
| 173 | :initform 'italic) |
| 174 | (chart :initarg :chart |
| 175 | :initform nil) |
| 176 | ) |
| 177 | "Superclass used for display of an axis.") |
| 178 | |
| 179 | (defclass chart-axis-range (chart-axis) |
| 180 | ((bounds :initarg :bounds |
| 181 | :initform '(0.0 . 50.0)) |
| 182 | ) |
| 183 | "Class used to display an axis defined by a range of values.") |
| 184 | |
| 185 | (defclass chart-axis-names (chart-axis) |
| 186 | ((items :initarg :items |
| 187 | :initform nil) |
| 188 | ) |
| 189 | "Class used to display an axis which represents different named items.") |
| 190 | |
| 191 | (defclass chart-sequece () |
| 192 | ((data :initarg :data |
| 193 | :initform nil) |
| 194 | (name :initarg :name |
| 195 | :initform "Data") |
| 196 | ) |
| 197 | "Class used for all data in different charts.") |
| 198 | |
| 199 | (defclass chart-bar (chart) |
| 200 | ((direction :initarg :direction |
| 201 | :initform vertical)) |
| 202 | "Subclass for bar charts (vertical or horizontal).") |
| 203 | |
| 204 | (defmethod chart-draw ((c chart) &optional buff) |
| 205 | "Start drawing a chart object C in optional BUFF. |
| 206 | Erases current contents of buffer." |
| 207 | (save-excursion |
| 208 | (if buff (set-buffer buff)) |
| 209 | (erase-buffer) |
| 210 | (insert (make-string 100 ?\n)) |
| 211 | ;; Start by displaying the axis |
| 212 | (chart-draw-axis c) |
| 213 | ;; Display title |
| 214 | (chart-draw-title c) |
| 215 | ;; Display data |
| 216 | (message "Rendering chart...") |
| 217 | (sit-for 0) |
| 218 | (chart-draw-data c) |
| 219 | ;; Display key |
| 220 | ; (chart-draw-key c) |
| 221 | (message "Rendering chart...done") |
| 222 | )) |
| 223 | |
| 224 | (defmethod chart-draw-title ((c chart)) |
| 225 | "Draw a title upon the chart. |
| 226 | Argument C is the chart object." |
| 227 | (chart-display-label (oref c title) 'horizontal 0 0 (window-width) |
| 228 | (oref c title-face))) |
| 229 | |
| 230 | (defmethod chart-size-in-dir ((c chart) dir) |
| 231 | "Return the physical size of chart C in direction DIR." |
| 232 | (if (eq dir 'vertical) |
| 233 | (oref c y-width) |
| 234 | (oref c x-width))) |
| 235 | |
| 236 | (defmethod chart-draw-axis ((c chart)) |
| 237 | "Draw axis into the current buffer defined by chart C." |
| 238 | (let ((ymarg (oref c y-margin)) |
| 239 | (xmarg (oref c x-margin)) |
| 240 | (ylen (oref c y-width)) |
| 241 | (xlen (oref c x-width))) |
| 242 | (chart-axis-draw (oref c y-axis) 'vertical ymarg |
| 243 | (if (oref (oref c y-axis) loweredge) nil xlen) |
| 244 | xmarg (+ xmarg ylen)) |
| 245 | (chart-axis-draw (oref c x-axis) 'horizontal xmarg |
| 246 | (if (oref (oref c x-axis) loweredge) nil ylen) |
| 247 | ymarg (+ ymarg xlen))) |
| 248 | ) |
| 249 | |
| 250 | (defmethod chart-axis-draw ((a chart-axis) &optional dir margin zone start end) |
| 251 | "Draw some axis for A in direction DIR with MARGIN in boundary. |
| 252 | ZONE is a zone specification. |
| 253 | START and END represent the boundary." |
| 254 | (chart-draw-line dir (+ margin (if zone zone 0)) start end) |
| 255 | (chart-display-label (oref a name) dir (if zone (+ zone margin 3) |
| 256 | (if (eq dir 'horizontal) |
| 257 | 1 0)) |
| 258 | start end (oref a name-face))) |
| 259 | |
| 260 | (defmethod chart-translate-xpos ((c chart) x) |
| 261 | "Translate in chart C the coordinate X into a screen column." |
| 262 | (let ((range (oref (oref c x-axis) bounds))) |
| 263 | (+ (oref c x-margin) |
| 264 | (round (* (float (- x (car range))) |
| 265 | (/ (float (oref c x-width)) |
| 266 | (float (- (cdr range) (car range)))))))) |
| 267 | ) |
| 268 | |
| 269 | (defmethod chart-translate-ypos ((c chart) y) |
| 270 | "Translate in chart C the coordinate Y into a screen row." |
| 271 | (let ((range (oref (oref c y-axis) bounds))) |
| 272 | (+ (oref c x-margin) |
| 273 | (- (oref c y-width) |
| 274 | (round (* (float (- y (car range))) |
| 275 | (/ (float (oref c y-width)) |
| 276 | (float (- (cdr range) (car range))))))))) |
| 277 | ) |
| 278 | |
| 279 | (defmethod chart-axis-draw ((a chart-axis-range) &optional dir margin zone start end) |
| 280 | "Draw axis information based upon a range to be spread along the edge. |
| 281 | A is the chart to draw. DIR is the direction. |
| 282 | MARGIN, ZONE, START, and END specify restrictions in chart space." |
| 283 | (call-next-method) |
| 284 | ;; We prefer about 5 spaces between each value |
| 285 | (let* ((i (car (oref a bounds))) |
| 286 | (e (cdr (oref a bounds))) |
| 287 | (z (if zone zone 0)) |
| 288 | (s nil) |
| 289 | (rng (- e i)) |
| 290 | ;; want to jump by units of 5 spaces or so |
| 291 | (j (/ rng (/ (chart-size-in-dir (oref a chart) dir) 4))) |
| 292 | p1) |
| 293 | (if (= j 0) (setq j 1)) |
| 294 | (while (<= i e) |
| 295 | (setq s |
| 296 | (cond ((> i 999999) |
| 297 | (format "%dM" (/ i 1000000))) |
| 298 | ((> i 999) |
| 299 | (format "%dK" (/ i 1000))) |
| 300 | (t |
| 301 | (format "%d" i)))) |
| 302 | (if (eq dir 'vertical) |
| 303 | (let ((x (+ (+ margin z) (if (oref a loweredge) |
| 304 | (- (length s)) 1)))) |
| 305 | (if (< x 1) (setq x 1)) |
| 306 | (chart-goto-xy x (chart-translate-ypos (oref a chart) i))) |
| 307 | (chart-goto-xy (chart-translate-xpos (oref a chart) i) |
| 308 | (+ margin z (if (oref a loweredge) -1 1)))) |
| 309 | (setq p1 (point)) |
| 310 | (insert s) |
| 311 | (chart-zap-chars (length s)) |
| 312 | (put-text-property p1 (point) 'face (oref a labels-face)) |
| 313 | (setq i (+ i j)))) |
| 314 | ) |
| 315 | |
| 316 | (defmethod chart-translate-namezone ((c chart) n) |
| 317 | "Return a dot-pair representing a positional range for a name. |
| 318 | The name in chart C of the Nth name resides. |
| 319 | Automatically compensates for direction." |
| 320 | (let* ((dir (oref c direction)) |
| 321 | (w (if (eq dir 'vertical) (oref c x-width) (oref c y-width))) |
| 322 | (m (if (eq dir 'vertical) (oref c y-margin) (oref c x-margin))) |
| 323 | (ns (length |
| 324 | (oref (if (eq dir 'vertical) (oref c x-axis) (oref c y-axis)) |
| 325 | items))) |
| 326 | (lpn (/ (+ 1.0 (float w)) (float ns))) |
| 327 | ) |
| 328 | (cons (+ m (round (* lpn (float n)))) |
| 329 | (+ m -1 (round (* lpn (+ 1.0 (float n)))))) |
| 330 | )) |
| 331 | |
| 332 | (defmethod chart-axis-draw ((a chart-axis-names) &optional dir margin zone start end) |
| 333 | "Draw axis information based upon A range to be spread along the edge. |
| 334 | Optional argument DIR is the direction of the chart. |
| 335 | Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." |
| 336 | (call-next-method) |
| 337 | ;; We prefer about 5 spaces between each value |
| 338 | (let* ((i 0) |
| 339 | (s (oref a items)) |
| 340 | (z (if zone zone 0)) |
| 341 | (r nil) |
| 342 | (p nil) |
| 343 | (odd nil) |
| 344 | p1) |
| 345 | (while s |
| 346 | (setq odd (= (% (length s) 2) 1)) |
| 347 | (setq r (chart-translate-namezone (oref a chart) i)) |
| 348 | (if (eq dir 'vertical) |
| 349 | (setq p (/ (+ (car r) (cdr r)) 2)) |
| 350 | (setq p (- (+ (car r) (/ (- (cdr r) (car r)) 2)) |
| 351 | (/ (length (car s)) 2)))) |
| 352 | (if (eq dir 'vertical) |
| 353 | (let ((x (+ (+ margin z) (if (oref a loweredge) |
| 354 | (- (length (car s))) |
| 355 | (length (car s)))))) |
| 356 | (if (< x 1) (setq x 1)) |
| 357 | (if (> (length (car s)) (1- margin)) |
| 358 | (setq x (+ x margin))) |
| 359 | (chart-goto-xy x p)) |
| 360 | (chart-goto-xy p (+ (+ margin z) (if (oref a loweredge) |
| 361 | (if odd -2 -1) |
| 362 | (if odd 2 1))))) |
| 363 | (setq p1 (point)) |
| 364 | (insert (car s)) |
| 365 | (chart-zap-chars (length (car s))) |
| 366 | (put-text-property p1 (point) 'face (oref a labels-face)) |
| 367 | (setq i (+ i 1) |
| 368 | s (cdr s)))) |
| 369 | ) |
| 370 | |
| 371 | (defmethod chart-draw-data ((c chart-bar)) |
| 372 | "Display the data available in a bar chart C." |
| 373 | (let* ((data (oref c sequences)) |
| 374 | (dir (oref c direction)) |
| 375 | (odir (if (eq dir 'vertical) 'horizontal 'vertical)) |
| 376 | ) |
| 377 | (while data |
| 378 | (if (stringp (car (oref (car data) data))) |
| 379 | ;; skip string lists... |
| 380 | nil |
| 381 | ;; display number lists... |
| 382 | (let ((i 0) |
| 383 | (seq (oref (car data) data))) |
| 384 | (while seq |
| 385 | (let* ((rng (chart-translate-namezone c i)) |
| 386 | (dp (if (eq dir 'vertical) |
| 387 | (chart-translate-ypos c (car seq)) |
| 388 | (chart-translate-xpos c (car seq)))) |
| 389 | (zp (if (eq dir 'vertical) |
| 390 | (chart-translate-ypos c 0) |
| 391 | (chart-translate-xpos c 0))) |
| 392 | (fc (if chart-face-list |
| 393 | (nth (% i (length chart-face-list)) chart-face-list) |
| 394 | 'default)) |
| 395 | ) |
| 396 | (if (< dp zp) |
| 397 | (progn |
| 398 | (chart-draw-line dir (car rng) dp zp) |
| 399 | (chart-draw-line dir (cdr rng) dp zp)) |
| 400 | (chart-draw-line dir (car rng) zp (1+ dp)) |
| 401 | (chart-draw-line dir (cdr rng) zp (1+ dp))) |
| 402 | (if (= (car rng) (cdr rng)) nil |
| 403 | (chart-draw-line odir dp (1+ (car rng)) (cdr rng)) |
| 404 | (chart-draw-line odir zp (car rng) (1+ (cdr rng)))) |
| 405 | (if (< dp zp) |
| 406 | (chart-deface-rectangle dir rng (cons dp zp) fc) |
| 407 | (chart-deface-rectangle dir rng (cons zp dp) fc)) |
| 408 | ) |
| 409 | ;; find the bounds, and chart it! |
| 410 | ;; for now, only do one! |
| 411 | (setq i (1+ i) |
| 412 | seq (cdr seq))))) |
| 413 | (setq data (cdr data)))) |
| 414 | ) |
| 415 | |
| 416 | (defmethod chart-add-sequence ((c chart) &optional seq axis-label) |
| 417 | "Add to chart object C the sequence object SEQ. |
| 418 | If AXIS-LABEL, then the axis stored in C is updated with the bounds of SEQ, |
| 419 | or is created with the bounds of SEQ." |
| 420 | (if axis-label |
| 421 | (let ((axis (eieio-oref c axis-label))) |
| 422 | (if (stringp (car (oref seq data))) |
| 423 | (let ((labels (oref seq data))) |
| 424 | (if (not axis) |
| 425 | (setq axis (make-instance chart-axis-names |
| 426 | :name (oref seq name) |
| 427 | :items labels |
| 428 | :chart c)) |
| 429 | (oset axis items labels))) |
| 430 | (let ((range (cons 0 1)) |
| 431 | (l (oref seq data))) |
| 432 | (if (not axis) |
| 433 | (setq axis (make-instance chart-axis-range |
| 434 | :name (oref seq name) |
| 435 | :chart c))) |
| 436 | (while l |
| 437 | (if (< (car l) (car range)) (setcar range (car l))) |
| 438 | (if (> (car l) (cdr range)) (setcdr range (car l))) |
| 439 | (setq l (cdr l))) |
| 440 | (oset axis bounds range))) |
| 441 | (if (eq axis-label 'x-axis) (oset axis loweredge nil)) |
| 442 | (eieio-oset c axis-label axis) |
| 443 | )) |
| 444 | (oset c sequences (append (oref c sequences) (list seq)))) |
| 445 | |
| 446 | ;;; Charting optimizers |
| 447 | |
| 448 | (defmethod chart-trim ((c chart) max) |
| 449 | "Trim all sequences in chart C to be at most MAX elements long." |
| 450 | (let ((s (oref c sequences))) |
| 451 | (while s |
| 452 | (let ((sl (oref (car s) data))) |
| 453 | (if (> (length sl) max) |
| 454 | (setcdr (nthcdr (1- max) sl) nil))) |
| 455 | (setq s (cdr s)))) |
| 456 | ) |
| 457 | |
| 458 | (defmethod chart-sort ((c chart) pred) |
| 459 | "Sort the data in chart C using predicate PRED. |
| 460 | See `chart-sort-matchlist' for more details." |
| 461 | (let* ((sl (oref c sequences)) |
| 462 | (s1 (car sl)) |
| 463 | (s2 (car (cdr sl))) |
| 464 | (s nil)) |
| 465 | (if (stringp (car (oref s1 data))) |
| 466 | (progn |
| 467 | (chart-sort-matchlist s1 s2 pred) |
| 468 | (setq s (oref s1 data))) |
| 469 | (if (stringp (car (oref s2 data))) |
| 470 | (progn |
| 471 | (chart-sort-matchlist s2 s1 pred) |
| 472 | (setq s (oref s2 data))) |
| 473 | (error "Sorting of chart %s not supported" (object-name c)))) |
| 474 | (if (eq (oref c direction) 'horizontal) |
| 475 | (oset (oref c y-axis) items s) |
| 476 | (oset (oref c x-axis) items s) |
| 477 | )) |
| 478 | ) |
| 479 | |
| 480 | (defun chart-sort-matchlist (namelst numlst pred) |
| 481 | "Sort NAMELST and NUMLST (both sequence objects) based on predicate PRED. |
| 482 | PRED should be the equivalent of '<, except it must expect two |
| 483 | cons cells of the form (NAME . NUM). See `sort' for more details." |
| 484 | ;; 1 - create 1 list of cons cells |
| 485 | (let ((newlist nil) |
| 486 | (alst (oref namelst data)) |
| 487 | (ulst (oref numlst data))) |
| 488 | (while alst |
| 489 | ;; this is reversed, but were are sorting anyway |
| 490 | (setq newlist (cons (cons (car alst) (car ulst)) newlist)) |
| 491 | (setq alst (cdr alst) |
| 492 | ulst (cdr ulst))) |
| 493 | ;; 2 - Run sort routine on it |
| 494 | (setq newlist (sort newlist pred) |
| 495 | alst nil |
| 496 | ulst nil) |
| 497 | ;; 3 - Separate the lists |
| 498 | (while newlist |
| 499 | (setq alst (cons (car (car newlist)) alst) |
| 500 | ulst (cons (cdr (car newlist)) ulst)) |
| 501 | (setq newlist (cdr newlist))) |
| 502 | ;; 4 - Store them back |
| 503 | (oset namelst data (reverse alst)) |
| 504 | (oset numlst data (reverse ulst)))) |
| 505 | |
| 506 | ;;; Utilities |
| 507 | |
| 508 | (defun chart-goto-xy (x y) |
| 509 | "Move cursor to position X Y in buffer, and add spaces and CRs if needed." |
| 510 | (let ((indent-tabs-mode nil) |
| 511 | (num (progn (goto-char (point-min)) (forward-line y)))) |
| 512 | (if (and (= 0 num) (/= 0 (current-column))) (newline 1)) |
| 513 | (if (eobp) (newline num)) |
| 514 | (if (< x 0) (setq x 0)) |
| 515 | (if (< y 0) (setq y 0)) |
| 516 | ;; Now, a quicky column moveto/forceto method. |
| 517 | (or (= (move-to-column x) x) |
| 518 | (let ((p (point))) |
| 519 | (indent-to x) |
| 520 | (remove-text-properties p (point) '(face)))))) |
| 521 | |
| 522 | (defun chart-zap-chars (n) |
| 523 | "Zap up to N chars without deleting EOLs." |
| 524 | (if (not (eobp)) |
| 525 | (if (< n (- (point-at-eol) (point))) |
| 526 | (delete-char n) |
| 527 | (delete-region (point) (point-at-eol))))) |
| 528 | |
| 529 | (defun chart-display-label (label dir zone start end &optional face) |
| 530 | "Display LABEL in direction DIR in column/row ZONE between START and END. |
| 531 | Optional argument FACE is the property we wish to place on this text." |
| 532 | (if (eq dir 'horizontal) |
| 533 | (let (p1) |
| 534 | (chart-goto-xy (+ start (- (/ (- end start) 2) (/ (length label) 2))) |
| 535 | zone) |
| 536 | (setq p1 (point)) |
| 537 | (insert label) |
| 538 | (chart-zap-chars (length label)) |
| 539 | (put-text-property p1 (point) 'face face) |
| 540 | ) |
| 541 | (let ((i 0) |
| 542 | (stz (+ start (- (/ (- end start) 2) (/ (length label) 2))))) |
| 543 | (while (< i (length label)) |
| 544 | (chart-goto-xy zone (+ stz i)) |
| 545 | (insert (aref label i)) |
| 546 | (chart-zap-chars 1) |
| 547 | (put-text-property (1- (point)) (point) 'face face) |
| 548 | (setq i (1+ i)))))) |
| 549 | |
| 550 | (defun chart-draw-line (dir zone start end) |
| 551 | "Draw a line using line-drawing characters in direction DIR. |
| 552 | Use column or row ZONE between START and END." |
| 553 | (chart-display-label |
| 554 | (make-string (- end start) (if (eq dir 'vertical) ?| ?\-)) |
| 555 | dir zone start end)) |
| 556 | |
| 557 | (defun chart-deface-rectangle (dir r1 r2 face) |
| 558 | "Colorize a rectangle in direction DIR across range R1 by range R2. |
| 559 | R1 and R2 are dotted pairs. Colorize it with FACE." |
| 560 | (let* ((range1 (if (eq dir 'vertical) r1 r2)) |
| 561 | (range2 (if (eq dir 'vertical) r2 r1)) |
| 562 | (y (car range2))) |
| 563 | (while (<= y (cdr range2)) |
| 564 | (chart-goto-xy (car range1) y) |
| 565 | (put-text-property (point) (+ (point) (1+ (- (cdr range1) (car range1)))) |
| 566 | 'face face) |
| 567 | (setq y (1+ y))))) |
| 568 | |
| 569 | ;;; Helpful `I don't want to learn eieio just now' washover functions |
| 570 | |
| 571 | (defun chart-bar-quickie (dir title namelst nametitle numlst numtitle |
| 572 | &optional max sort-pred) |
| 573 | "Wash over the complex EIEIO stuff and create a nice bar chart. |
| 574 | Create it going in direction DIR ['horizontal 'vertical] with TITLE |
| 575 | using a name sequence NAMELST labeled NAMETITLE with values NUMLST |
| 576 | labeled NUMTITLE. |
| 577 | Optional arguments: |
| 578 | Set the chart's max element display to MAX, and sort lists with |
| 579 | SORT-PRED if desired." |
| 580 | (let ((nc (make-instance chart-bar |
| 581 | :title title |
| 582 | :key-label "8-m" ; This is a text key pic |
| 583 | :direction dir |
| 584 | )) |
| 585 | (iv (eq dir 'vertical))) |
| 586 | (chart-add-sequence nc |
| 587 | (make-instance chart-sequece |
| 588 | :data namelst |
| 589 | :name nametitle) |
| 590 | (if iv 'x-axis 'y-axis)) |
| 591 | (chart-add-sequence nc |
| 592 | (make-instance chart-sequece |
| 593 | :data numlst |
| 594 | :name numtitle) |
| 595 | (if iv 'y-axis 'x-axis)) |
| 596 | (if sort-pred (chart-sort nc sort-pred)) |
| 597 | (if (integerp max) (chart-trim nc max)) |
| 598 | (switch-to-buffer (chart-new-buffer nc)) |
| 599 | (chart-draw nc))) |
| 600 | |
| 601 | ;;; Test code |
| 602 | |
| 603 | (defun chart-test-it-all () |
| 604 | "Test out various charting features." |
| 605 | (interactive) |
| 606 | (chart-bar-quickie 'vertical "Test Bar Chart" |
| 607 | '( "U1" "ME2" "C3" "B4" "QT" "EZ") "Items" |
| 608 | '( 5 -10 23 20 30 -3) "Values") |
| 609 | ) |
| 610 | |
| 611 | ;;; Sample utility function |
| 612 | |
| 613 | (defun chart-file-count (dir) |
| 614 | "Draw a chart displaying the number of different file extensions in DIR." |
| 615 | (interactive "DDirectory: ") |
| 616 | (if (not (string-match "/$" dir)) |
| 617 | (setq dir (concat dir "/"))) |
| 618 | (message "Collecting statistics...") |
| 619 | (let ((flst (directory-files dir nil nil t)) |
| 620 | (extlst (list "<dir>")) |
| 621 | (cntlst (list 0))) |
| 622 | (while flst |
| 623 | (let* ((j (string-match "[^\\.]\\(\\.[a-zA-Z]+\\|~\\|#\\)$" (car flst))) |
| 624 | (s (if (file-accessible-directory-p (concat dir (car flst))) |
| 625 | "<dir>" |
| 626 | (if j |
| 627 | (substring (car flst) (match-beginning 1) (match-end 1)) |
| 628 | nil))) |
| 629 | (m (member s extlst))) |
| 630 | (if (not s) nil |
| 631 | (if m |
| 632 | (let ((cell (nthcdr (- (length extlst) (length m)) cntlst))) |
| 633 | (setcar cell (1+ (car cell)))) |
| 634 | (setq extlst (cons s extlst) |
| 635 | cntlst (cons 1 cntlst))))) |
| 636 | (setq flst (cdr flst))) |
| 637 | ;; Let's create the chart! |
| 638 | (chart-bar-quickie 'vertical "Files Extension Distribution" |
| 639 | extlst "File Extensions" |
| 640 | cntlst "# of occurrences" |
| 641 | 10 |
| 642 | (lambda (a b) (> (cdr a) (cdr b)))) |
| 643 | )) |
| 644 | |
| 645 | (defun chart-space-usage (d) |
| 646 | "Display a top usage chart for directory D." |
| 647 | (interactive "DDirectory: ") |
| 648 | (message "Collecting statistics...") |
| 649 | (let ((nmlst nil) |
| 650 | (cntlst nil) |
| 651 | (b (get-buffer-create " *du-tmp*"))) |
| 652 | (set-buffer b) |
| 653 | (erase-buffer) |
| 654 | (insert "cd " d ";du -sk * \n") |
| 655 | (message "Running `cd %s;du -sk *'..." d) |
| 656 | (call-process-region (point-min) (point-max) shell-file-name t |
| 657 | (current-buffer) nil) |
| 658 | (goto-char (point-min)) |
| 659 | (message "Scanning output ...") |
| 660 | (while (re-search-forward "^\\([0-9]+\\)[ \t]+\\([^ \n]+\\)$" nil t) |
| 661 | (let* ((nam (buffer-substring (match-beginning 2) (match-end 2))) |
| 662 | (num (buffer-substring (match-beginning 1) (match-end 1)))) |
| 663 | (setq nmlst (cons nam nmlst) |
| 664 | ;; * 1000 to put it into bytes |
| 665 | cntlst (cons (* (string-to-number num) 1000) cntlst)))) |
| 666 | (if (not nmlst) |
| 667 | (error "No files found!")) |
| 668 | (chart-bar-quickie 'vertical (format "Largest files in %s" d) |
| 669 | nmlst "File Name" |
| 670 | cntlst "File Size" |
| 671 | 10 |
| 672 | (lambda (a b) (> (cdr a) (cdr b)))) |
| 673 | )) |
| 674 | |
| 675 | (defun chart-emacs-storage () |
| 676 | "Chart the current storage requirements of Emacs." |
| 677 | (interactive) |
| 678 | (let* ((data (garbage-collect)) |
| 679 | (names '("strings/2" "vectors" |
| 680 | "conses" "free cons" |
| 681 | "syms" "free syms" |
| 682 | "markers" "free mark" |
| 683 | ;; "floats" "free flt" |
| 684 | )) |
| 685 | (nums (list (/ (nth 3 data) 2) |
| 686 | (nth 4 data) |
| 687 | (car (car data)) ; conses |
| 688 | (cdr (car data)) |
| 689 | (car (nth 1 data)) ; syms |
| 690 | (cdr (nth 1 data)) |
| 691 | (car (nth 2 data)) ; markers |
| 692 | (cdr (nth 2 data)) |
| 693 | ;(car (nth 5 data)) ; floats are Emacs only |
| 694 | ;(cdr (nth 5 data)) |
| 695 | ))) |
| 696 | ;; Let's create the chart! |
| 697 | (chart-bar-quickie 'vertical "Emacs Runtime Storage Usage" |
| 698 | names "Storage Items" |
| 699 | nums "Objects"))) |
| 700 | |
| 701 | (defun chart-emacs-lists () |
| 702 | "Chart out the size of various important lists." |
| 703 | (interactive) |
| 704 | (let* ((names '("buffers" "frames" "processes" "faces")) |
| 705 | (nums (list (length (buffer-list)) |
| 706 | (length (frame-list)) |
| 707 | (length (process-list)) |
| 708 | (length (face-list)) |
| 709 | ))) |
| 710 | (if (fboundp 'x-display-list) |
| 711 | (setq names (append names '("x-displays")) |
| 712 | nums (append nums (list (length (x-display-list)))))) |
| 713 | ;; Let's create the chart! |
| 714 | (chart-bar-quickie 'vertical "Emacs List Size Chart" |
| 715 | names "Various Lists" |
| 716 | nums "Objects"))) |
| 717 | |
| 718 | (defun chart-rmail-from () |
| 719 | "If we are in an rmail summary buffer, then chart out the froms." |
| 720 | (interactive) |
| 721 | (if (not (eq major-mode 'rmail-summary-mode)) |
| 722 | (error "You must invoke chart-rmail-from in an rmail summary buffer")) |
| 723 | (let ((nmlst nil) |
| 724 | (cntlst nil)) |
| 725 | (save-excursion |
| 726 | (goto-char (point-min)) |
| 727 | (while (re-search-forward "\\-[A-Z][a-z][a-z] +\\(\\w+\\)@\\w+" nil t) |
| 728 | (let* ((nam (buffer-substring (match-beginning 1) (match-end 1))) |
| 729 | (m (member nam nmlst))) |
| 730 | (message "Scanned username %s" nam) |
| 731 | (if m |
| 732 | (let ((cell (nthcdr (- (length nmlst) (length m)) cntlst))) |
| 733 | (setcar cell (1+ (car cell)))) |
| 734 | (setq nmlst (cons nam nmlst) |
| 735 | cntlst (cons 1 cntlst)))))) |
| 736 | (chart-bar-quickie 'vertical "Username Occurrence in RMAIL box" |
| 737 | nmlst "User Names" |
| 738 | cntlst "# of occurrences" |
| 739 | 10 |
| 740 | (lambda (a b) (> (cdr a) (cdr b)))) |
| 741 | )) |
| 742 | |
| 743 | |
| 744 | (provide 'chart) |
| 745 | |
| 746 | ;;; chart.el ends here |