cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-diagram.el

   1 ;;; xwem-diagram.el --- Diagrams drawing for XWEM.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Sat Mar  6 17:09:58 MSK 2004
   7 ;; Keywords: xwem
   8 ;; X-CVS: $Id: xwem-diagram.el,v 1.6 2005-04-04 19:54:11 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;; Diagrams drawer, supports:
  32 ;;
  33 ;;   * Plain bar digrams.
  34 ;;   * 3D bar digrams.
  35 ;;   * Plain sectors diagrams.
  36 ;;   * 3D sectors diagrams.
  37
  38 ;;   * Many gnuplot like datasets drawing.
  39
  40 ;;; Code:
  41 \f
  42 (require 'xlib-xlib)
  43
  44 (require 'xwem-faces)
  45
  46 \f
  47 (defun xwem-diag-dot-distance (dot1 dot2)
  48   "Return distance betwean DOT1 and DOT2."
  49   (let ((w (abs (- (X-Point-x dot1) (X-Point-x dot2))))
  50         (h (abs (- (X-Point-y dot1) (X-Point-y dot2)))))
  51
  52     (sqrt (+ (* h h) (* w h)))))
  53
  54 (defun xwem-diag-dot-betwean-p (x-or-y dot dot1 dot2)
  55   "Return non-nil if X-OR-Y of DOT betwean DOT1 and DOT2.
  56 X-OR-Y can be 'x or 'y."
  57   (if (eq x-or-y 'x)
  58       (or (and (>= (X-Point-x dot) (X-Point-x dot1))
  59                (<= (X-Point-x dot) (X-Point-x dot2)))
  60           (and (<= (X-Point-x dot) (X-Point-x dot1))
  61                (>= (X-Point-x dot) (X-Point-x dot2))))
  62
  63     (or (and (>= (X-Point-y dot) (X-Point-y dot1))
  64              (<= (X-Point-y dot) (X-Point-y dot2)))
  65         (and (<= (X-Point-y dot) (X-Point-y dot1))
  66              (>= (X-Point-y dot) (X-Point-y dot2))))))
  67
  68 (defun xwem-diag-dot-< (x-or-y dot dot1)
  69   "Return non-nil if X-OR-Y of DOT is < DOT1."
  70   (if (eq x-or-y 'x)
  71       (< (X-Point-x dot) (X-Point-x dot1))
  72     (< (X-Point-y dot) (X-Point-y dot1))))
  73
  74 (defun xwem-diag-dot-<= (x-or-y dot dot1)
  75   "Return non-nil if X-OR-Y of DOT is <= DOT1."
  76   (if (eq x-or-y 'x)
  77       (<= (X-Point-x dot) (X-Point-x dot1))
  78     (<= (X-Point-y dot) (X-Point-y dot1))))
  79
  80 (defun xwem-diag-dot-> (x-or-y dot dot1)
  81   "Return non-nil if X-OR-Y of DOT is > DOT1."
  82   (if (eq x-or-y 'x)
  83       (> (X-Point-x dot) (X-Point-x dot1))
  84     (> (X-Point-y dot) (X-Point-y dot1))))
  85
  86 (defun xwem-diag-dot->= (x-or-y dot dot1)
  87   "Return non-nil if X-OR-Y of DOT is >= DOT1."
  88   (if (eq x-or-y 'x)
  89       (>= (X-Point-x dot) (X-Point-x dot1))
  90     (>= (X-Point-y dot) (X-Point-y dot1))))
  91
  92 (defun xwem-diag-calc-arc-dot-at (cnt-dot w h a)
  93   "Calculte dot position."
  94   (let* ((ra (/ (* a pi) 180))
  95          (cra (cos ra))
  96          (sra (sin ra))
  97          (rx (* w cra))
  98          (ry (* h sra)))
  99     (cons (round (+ (X-Point-x cnt-dot) rx))
 100           (round (+ (X-Point-y cnt-dot) (- ry))))))
 101
 102 (defun xwem-diag-draw-rect (d gc dot1 dot2 dot3 dot4 &optional fill-gc)
 103   "Draw parallelogram with vertexes at DOT1 DOT2 DOT3 and DOT4."
 104   (when (X-Gc-p fill-gc)
 105     (XFillPoly (X-Drawable-dpy d) d fill-gc (list dot1 dot2 dot3 dot4)))
 106
 107   (XDrawLines (X-Drawable-dpy d) d gc (list dot1 dot2 dot3 dot4 dot1)))
 108
 109 (defun xwem-diag-calc-sector-dots (x y w h a1 a2)
 110   (let* ((mcnt (cons (+ x (/ w 2))
 111                      (+ y (/ h 2))))
 112          (d1 (xwem-diag-calc-arc-dot-at mcnt (/ w 2) (/ h 2) a1))
 113          (d2 (xwem-diag-calc-arc-dot-at mcnt (/ w 2) (/ h 2) (+ a2 a1))))
 114     (list d1 mcnt d2)))
 115
 116 (defun xwem-diag-draw-sector (d gc x y w h a1 a2 &optional fill-gc)
 117   "Draw sector, return new dots."
 118   (let ((dots (xwem-diag-calc-sector-dots x y w h a1 a2)))
 119
 120     (when (X-Gc-p fill-gc)
 121       (XFillArc (X-Drawable-dpy d) d fill-gc x y w h a1 a2))
 122
 123     (XDrawLines (X-Drawable-dpy d) d gc dots)
 124     (XDrawArc (X-Drawable-dpy d) d gc x y w h a1 a2)
 125     dots))
 126
 127 (defun xwem-diag-calc-butt-center (ds1 ds2)
 128   "Evil stuff."
 129   (let* ((h1 (- (X-Point-x (nth 2 ds1))
 130                 (X-Point-x (nth 1 ds1))))
 131          (h2 (- (X-Point-x (nth 0 ds1))
 132                 (X-Point-x (nth 1 ds1))))
 133          (l (* (/ (float h1) h2)
 134                (- (X-Point-y (nth 1 ds2))
 135                   (X-Point-y (nth 0 ds2)))))
 136          (L (+ (- (X-Point-y (nth 2 ds1))
 137                   (X-Point-y (nth 1 ds2)))
 138                l))
 139          (a (- (X-Point-y (nth 1 ds2))
 140                (X-Point-y (nth 1 ds1))))
 141
 142          (T (xwem-diag-dot-distance
 143              (nth 1 ds2) (cons (X-Point-x (nth 2 ds1))
 144                                (+ (X-Point-y (nth 1 ds2))
 145                                   (truncate l)))))
 146          (tt (/ (* T a) (+ L a)))
 147
 148          (nx (* h1 (/ tt T)))
 149          (ny (* l (/ tt T))))
 150
 151     (cons (truncate (+ (X-Point-x (nth 1 ds2))
 152                        nx))
 153           (truncate (+ (X-Point-y (nth 1 ds2))
 154                        ny)))))
 155
 156 (defun xwem-diag-draw-3d-sector (d gc x y w h a1 a2 sector-width &optional fill-gc)
 157   "Draw 3d sector."
 158   (let ((ds1 (xwem-diag-calc-sector-dots x y w h a1 a2))
 159         (ds2 (xwem-diag-calc-sector-dots x (+ y sector-width) w h a1 a2))
 160         d0-adds1 d0-adds2 d2-adds1 d2-adds2
 161         buta1 buta2
 162         d0-buta1 d0-buta2
 163         d2-buta1 d2-buta2
 164         center-visible dot0-visible dot2-visible
 165         cd0-visible cd2-visible)
 166
 167     ;; Adjust a1 and a2
 168     (while (< a1 0)
 169       (setq a1 (+ a1 360)))
 170     (while (> a1 360)
 171       (setq a1 (- a1 360)))
 172     (while (> a2 360)
 173       (setq a2 (- a2 360)))
 174
 175     (when (or (and (<= a1 180)
 176                    (> (+ a1 a2) 180))
 177               (and (> a1 180)
 178                    (> (+ a1 a2) 540)))
 179       (setq d0-adds1 (cons (- (X-Point-x (nth 1 ds1)) (/ w 2))
 180                            (X-Point-y (nth 1 ds1))))
 181       (setq d0-adds2 (cons (- (X-Point-x (nth 1 ds2)) (/ w 2))
 182                            (X-Point-y (nth 1 ds2))))
 183       (if (and (<= a1 180)
 184                (> (+ a1 a2) 180))
 185           (progn
 186             (setq buta1 180)
 187             (setq buta2 (- a2 (- buta1 a1))))
 188
 189         (setq d0-buta1 180)
 190         (setq d0-buta2 (- (+ a1 a2) 270 270)))
 191       )
 192
 193     (when (> (+ (or buta1 a1) (or buta2 a2)) 360)
 194       (setq d2-adds1 (cons (+ (X-Point-x (nth 1 ds1)) (/ w 2))
 195                            (X-Point-y (nth 1 ds1))))
 196       (setq d2-adds2 (cons (+ (X-Point-x (nth 1 ds2)) (/ w 2))
 197                            (X-Point-y (nth 1 ds2))))
 198       (if (or (and (xwem-diag-dot-> 'y (nth 0 ds1) (nth 1 ds1))
 199                    (xwem-diag-dot-> 'y (nth 2 ds1) (nth 1 ds1)))
 200               (and d0-buta1 d0-buta2))
 201           (progn
 202             (setq d0-buta1 (or d0-buta1 buta1))
 203             (setq d0-buta2 (or d0-buta2 buta2))
 204             (setq d2-buta1 (or buta1 a1))
 205             (setq d2-buta2 (- 360 d2-buta1))
 206             (setq buta1 nil
 207                   buta2 nil))
 208
 209         (setq buta1 (or buta1 a1))
 210         (setq buta2 (- 360 buta1))
 211         ))
 212
 213     ;; Setup visibilities
 214     (unless (and (xwem-diag-dot-< 'x (nth 0 ds1) (nth 1 ds1))
 215                  (xwem-diag-dot-< 'y (nth 0 ds1) (nth 1 ds1)))
 216       (setq dot0-visible t))
 217
 218     (unless (and (xwem-diag-dot-> 'x (nth 2 ds1) (nth 1 ds1))
 219                  (xwem-diag-dot-< 'y (nth 2 ds1) (nth 1 ds1)))
 220       (setq dot2-visible t))
 221
 222     (when (or (and (xwem-diag-dot->= 'x (nth 0 ds1) (nth 1 ds1))
 223                    (xwem-diag-dot-<= 'y (nth 0 ds1) (nth 1 ds1))
 224                    (not (and (xwem-diag-dot->= 'x (nth 2 ds1) (nth 1 ds1))
 225                              (or (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
 226                                  (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))))))
 227               (and (xwem-diag-dot->= 'x (nth 0 ds1) (nth 1 ds1))
 228                    (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
 229                    (not (and (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))
 230                              (xwem-diag-dot->= 'x (nth 2 ds1) (nth 1 ds1))
 231                              (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1)))))
 232               (and (xwem-diag-dot-<= 'x (nth 0 ds1) (nth 1 ds1))
 233                    (xwem-diag-dot-<= 'y (nth 0 ds1) (nth 1 ds1))
 234                    (xwem-diag-dot-<= 'x (nth 2 ds1) (nth 1 ds1))
 235                    (or (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
 236                        (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))))
 237               (and (xwem-diag-dot-<= 'x (nth 0 ds1) (nth 1 ds1))
 238                    (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
 239                    (xwem-diag-dot-<= 'x (nth 2 ds1) (nth 1 ds1))
 240                    (and (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
 241                         (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1)))))
 242       (setq center-visible t)
 243
 244       (when dot0-visible
 245         (unless (and (xwem-diag-dot-> 'y (nth 2 ds2) (nth 1 ds2))
 246                      (xwem-diag-dot-betwean-p 'x (nth 2 ds2) (nth 1 ds2) (nth 0 ds2)))
 247           (setq cd0-visible t)))
 248
 249       (when dot2-visible
 250         (unless (and (xwem-diag-dot-> 'y (nth 0 ds2) (nth 1 ds2))
 251                      (xwem-diag-dot-betwean-p 'x (nth 0 ds2) (nth 1 ds2) (nth 2 ds2)))
 252           (setq cd2-visible t)))
 253       )
 254
 255     ;; Draw buttom arc
 256     (if (and buta1 buta2)
 257         (progn
 258           (when fill-gc
 259             (XFillArc (X-Drawable-dpy d) d fill-gc x (+ y sector-width) w h buta1 buta2))
 260           (XDrawArc (X-Drawable-dpy d) d gc x (+ y sector-width) w h buta1 buta2))
 261
 262       (if (or (and d0-buta1 d0-buta2)
 263               (and d2-buta1 d2-buta2))
 264           (progn
 265             (when (and d0-buta1 d0-buta2)
 266               (when fill-gc
 267                 (XFillArc (X-Drawable-dpy d) d fill-gc x (+ y sector-width) w h d0-buta1 d0-buta2))
 268               (XDrawArc (X-Drawable-dpy d) d gc x (+ y sector-width) w h d0-buta1 d0-buta2))
 269             (when (and d2-buta1 d2-buta2)
 270               (when fill-gc
 271                 (XFillArc (X-Drawable-dpy d) d fill-gc x (+ y sector-width) w h d2-buta1 d2-buta2))
 272               (XDrawArc (X-Drawable-dpy d) d gc x (+ y sector-width) w h d2-buta1 d2-buta2)))
 273
 274         (when (and (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
 275                    (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1)))
 276           (when fill-gc
 277             (XFillArc (X-Drawable-dpy d) d fill-gc x (+ y sector-width) w h a1 a2))
 278           (XDrawArc (X-Drawable-dpy d) d gc x (+ y sector-width) w h a1 a2))))
 279
 280     ;; fill other stuff
 281     (when fill-gc
 282       ;; main sector
 283       (XFillArc (X-Drawable-dpy d) d fill-gc x y w h a1 a2)
 284
 285       (xwem-diag-draw-rect d fill-gc
 286                            (nth 2 ds2) (nth 2 ds1)
 287                            (nth 1 ds1) (nth 1 ds2)
 288                            fill-gc)
 289       (xwem-diag-draw-rect d fill-gc
 290                            (nth 0 ds2) (nth 0 ds1)
 291                            (nth 1 ds1) (nth 1 ds2)
 292                            fill-gc)
 293
 294       (when (and d0-adds1 d0-adds2)
 295         (XFillPoly (X-Drawable-dpy d) d fill-gc
 296                    (list d0-adds1 d0-adds2 (nth 1 ds2) (nth 1 ds1)
 297                          d0-adds1)))
 298
 299       (when (and d2-adds1 d2-adds2)
 300         (XFillPoly (X-Drawable-dpy d) d fill-gc
 301                    (list d2-adds1 d2-adds2 (nth 1 ds2) (nth 1 ds1)
 302                          d2-adds1)))
 303       )
 304
 305     ;; Draw main sector
 306     (XDrawLines (X-Drawable-dpy d) d gc ds1)
 307     (XDrawArc (X-Drawable-dpy d) d gc x y w h a1 a2)
 308
 309     (xwem-diag-draw-sector d gc x y w h a1 a2 fill-gc) ; sector always visible
 310
 311     ;; Draw visibilities
 312     (when center-visible
 313       (XDrawLines (X-Drawable-dpy d) d gc (list (nth 1 ds1) (nth 1 ds2))))
 314     (when cd0-visible
 315       (XDrawLines (X-Drawable-dpy d) d gc (list (nth 1 ds2) (nth 0 ds2))))
 316     (when cd2-visible
 317       (XDrawLines (X-Drawable-dpy d) d gc (list (nth 1 ds2) (nth 2 ds2))))
 318     (when dot0-visible
 319       (XDrawLines (X-Drawable-dpy d) d gc (list (nth 0 ds1) (nth 0 ds2))))
 320     (when dot2-visible
 321       (XDrawLines (X-Drawable-dpy d) d gc (list (nth 2 ds1) (nth 2 ds2))))
 322     (when (and d0-adds1 d0-adds2)
 323       (XDrawLines (X-Drawable-dpy d) d gc (list d0-adds1 d0-adds2)))
 324     (when (and d2-adds1 d2-adds2)
 325       (XDrawLines (X-Drawable-dpy d) d gc (list d2-adds1 d2-adds2)))
 326     ))
 327
 328 (defun xwem-diag-draw-bar (d gc x y w h &optional fill-gc)
 329   "Draw plain bar."
 330   (xwem-diag-draw-rect d gc
 331                        (cons x y) (cons (+ x w) y)
 332                        (cons (+ x w) (+ y h)) (cons x (+ y h))
 333                        fill-gc))
 334
 335 (defun xwem-diag-draw-3d-bar (d gc x y w h bar-width &optional fill-gc)
 336   "Draw 3d bar."
 337   (let* ((d1 (cons x y))
 338          (d2 (cons (+ x w) y))
 339          (d3 (cons (+ x w) (+ y h)))
 340          (d4 (cons x (+ y h)))
 341          (x-off (/ bar-width 2))
 342          (y-off (/ bar-width 2))
 343          (dd1 (cons (+ x-off (car d1)) (- (cdr d1) y-off)))
 344          (dd2 (cons (+ x-off (car d2)) (- (cdr d2) y-off)))
 345          (dd3 (cons (+ x-off (car d3)) (- (cdr d3) y-off))))
 346
 347     (when fill-gc
 348       (XFillPoly (X-Drawable-dpy d) d fill-gc
 349                  (list d1 dd1 dd2 dd3 d3 d4 d1)))
 350
 351     (XDrawLines (X-Drawable-dpy d) d gc
 352                 (list d1 dd1 dd2 dd3 d3 d4 d1 d2 d3 d2 dd2))
 353   ))
 354
 355 (defun xwem-diag-draw-percentage (type spec d edge-gc x y width height
 356                                        &optional sector-width label-factor
 357                                        label-font override-gc)
 358   "Draw percentage sector of TYPE.
 359 TYPE is one of 'plain or '3d.
 360 SPEC specifies percentage to display, it is an array in form
 361 \[percents sector-label fill-color center-offset x-offset y-offset\]
 362   perecnts - is number betwean 0 and 100.
 363   sector-label - either string or t, t mean show percentage.
 364   fill-color - nil or color to fill sector.
 365   center-offset - sector's offset from center using bisector vector.
 366   x-offset - sector's x offset.
 367   y-offset - sector's y offest.
 368
 369 EDGE-GC used to draw sector edges.
 370 X, Y, WIDTH and HEIGHT specifies sector geometry coordinate inside
 371 drawable D.
 372 Optionally SECTOR-WIDTH may be specified (only for '3d TYPE).
 373 LABEL-FACTOR is float number used, when calculating label placement.
 374 LABEL-FONT is font used to draw label, default is font of EDGE-GC."
 375   (let ((xdpy (X-Drawable-dpy d))
 376         (temp-fill-face (make-face 'temp-fill-face))
 377         (start-angle 0)
 378         angle-begin curang)
 379
 380     ;; Validate spec
 381 ;    (when (> (apply '+ (mapcar (lambda (el) (aref el 0)) spec)) 100)
 382 ;      (error "XWEM Invalid spec" spec))
 383
 384     (let ((draw-sector
 385            (lambda (sel angbeg angle)
 386              (xwem-set-face-foreground temp-fill-face (aref sel 2))
 387              (let ((xint-off 0)
 388                    (yint-off 0))
 389
 390                (when (not (zerop (aref sel 3)))
 391                  (let ((ra (/ (* pi (+ angbeg (/ angle 2))) 180)))
 392                    (setq xint-off (round (* (aref sel 3) (cos ra))))
 393                    (setq yint-off (- (round (* (aref sel 3) (sin ra)))))))
 394
 395                (if (eq type 'plain)
 396                    (xwem-diag-draw-sector
 397                     d edge-gc (+ x xint-off (aref sel 4))
 398                     (+ y yint-off (aref sel 5)) width height
 399                     angbeg angle
 400                     (or override-gc (xwem-face-get-gc temp-fill-face)))
 401                  (xwem-diag-draw-3d-sector
 402                   d edge-gc (+ x xint-off (aref sel 4))
 403                   (+ y yint-off (aref sel 5)) width height
 404                   angbeg angle (or sector-width 10)
 405                   (or override-gc (xwem-face-get-gc temp-fill-face))))
 406
 407                ;; Draw label
 408                (when (aref sel 1)
 409                  (let* ((k (or label-factor 0.8))
 410                         (nw (* width k))
 411                         (nh (* height k))
 412                         (nx (+ (aref sel 4) x xint-off (/ (- width nw) 2)))
 413                         (ny (+ (aref sel 5) y yint-off (/ (- height nh) 2)))
 414                         (cd (xwem-diag-calc-sector-dots nx ny nw nh angbeg (/ angle 2)))
 415                         (gc edge-gc)
 416                         (text (if (stringp (aref sel 1)) (aref sel 1) (format "%d%%" (aref sel 0)))))
 417                    (XDrawString xdpy d gc
 418                                 (- (X-Point-x (nth 2 cd))
 419                                    (/ (X-Text-width xdpy (X-Gc-font gc) text) 2))
 420                                 (+ (/ (X-Text-height xdpy (X-Gc-font gc) text) 2)
 421                                    (X-Point-y (nth 2 cd)))
 422                                 text)))
 423                ))))
 424       ;; Sort SPEC by percentage
 425       (setq spec (sort spec (lambda (el1 el2) (> (aref el1 0) (aref el2 0)))))
 426
 427       ;; Special cases, when first sector is too big or too small
 428       (when (> (aref (car spec) 0) 75)
 429         (setq start-angle (* 360.0 (/ (- (aref (car spec) 0) 100) 100.0))))
 430       (when (< (aref (car spec) 0) 25)
 431         (setq start-angle (* 360.0 (/ (- 25 (aref (car spec) 0)) 100.0))))
 432
 433       (setq angle-begin start-angle)
 434       ;; Draw huge sectors
 435       (while (and spec (< (+ (* 100 (/ angle-begin 360.0))
 436                              (aref (car spec) 0))
 437                           75))
 438         (setq curang (* 360.0 (/ (aref (car spec) 0) 100.0)))
 439         (funcall draw-sector (car spec) angle-begin curang)
 440         (setq angle-begin (+ angle-begin curang))
 441         (setq spec (cdr spec)))
 442
 443       ;; Draw little sectors
 444       (setq angle-begin start-angle)
 445       (mapc (lambda (sss)
 446               (setq curang (* 360.0 (/ (aref sss 0) 100.0)))
 447               (setq angle-begin (- angle-begin curang))
 448               (funcall draw-sector sss angle-begin curang))
 449             (nreverse spec)))))
 450
 451 (defun xwem-diag-plot-coordinates (d gc x y w h x-step y-step &rest params)
 452   "Draw coordinates system."
 453   (let ((notch-len (or (plist-get params :notch-len) 4))
 454         (with-grid-p (plist-get params :with-grid))
 455         (grid-dash-even (or (plist-get params :grid-dash-even) 1))
 456         (grid-dash-odd (or (plist-get params :grid-dash-odd 3)))
 457         (with-labels-p (plist-get params :with-labels))
 458         (labels-offset (or (plist-get params :labels-offest) 4))
 459         (labels-gc (or (plist-get params :labels-gc) gc))
 460         (center-x (or (plist-get params :center-x) 0))
 461         (center-y (or (plist-get params :center-y) 0))
 462         (scale-x (or (plist-get params :scale-x) x-step))
 463         (scale-y (or (plist-get params :scale-y) y-step))
 464
 465         (xdpy (X-Drawable-dpy d))
 466         x-notches y-notches noff sls)
 467
 468     (setq noff (% center-x x-step))
 469     (while (< noff w)
 470       (setq x-notches (cons (cons (cons (+ x noff)
 471                                         (- y center-y))
 472                                   (cons (+ x noff) (- y center-y notch-len)))
 473                             x-notches))
 474       (setq noff (+ noff x-step)))
 475
 476     (setq noff (% center-y y-step))
 477     (while (< noff h)
 478       (setq y-notches (cons (cons (cons (+ x center-x)
 479                                         (- y noff))
 480                                   (cons (+ x center-x notch-len) (- y noff)))
 481                             y-notches))
 482       (setq noff (+ noff y-step)))
 483
 484     ;; Set dashes
 485     (when with-grid-p
 486       (setq sls (X-Gc-line-style gc))
 487       (setf (X-Gc-line-style gc) X-LineOnOffDash)
 488       (XChangeGC xdpy gc)
 489       (XSetDashes xdpy gc 0 (list grid-dash-even grid-dash-odd
 490                                   grid-dash-even grid-dash-odd))
 491
 492       (unwind-protect
 493           (progn
 494             (XDrawSegments xdpy d gc
 495                            (mapcar (lambda (s)
 496                                      (cons (cons x (X-Point-y (car s)))
 497                                            (cons (+ x w) (X-Point-y (cdr s)))))
 498                                    y-notches))
 499             (XDrawSegments xdpy d gc
 500                            (mapcar (lambda (s)
 501                                      (cons (cons (X-Point-x (car s)) (- y h))
 502                                            (cons (X-Point-x (car s)) y)))
 503                                    x-notches)))
 504         ;; Revert gc
 505         (setf (X-Gc-line-style gc) sls)
 506         (XChangeGC xdpy gc)))
 507
 508     (when with-labels-p
 509       (mapc (lambda (s)
 510               (let* ((txt (int-to-string (/ (* scale-x (- (X-Point-x (car s)) x center-x)) x-step)))
 511                      (tw (X-Text-width xdpy (X-Gc-font labels-gc) txt))
 512                      (th (X-Text-height xdpy (X-Gc-font labels-gc) txt)))
 513
 514                 (XDrawString xdpy d labels-gc (- (X-Point-x (car s)) (/ tw 2))
 515                              (+ y th labels-offset) txt)))
 516             x-notches)
 517       (mapc (lambda (s)
 518               (let* ((txt (int-to-string (/ (* scale-y (- y (X-Point-y (car s)) center-y)) y-step)))
 519                      (tw (X-Text-width xdpy (X-Gc-font labels-gc) txt))
 520                      (th (X-Text-height xdpy (X-Gc-font labels-gc) txt)))
 521
 522                 (XDrawString xdpy d labels-gc (- x tw labels-offset)
 523                              (+ (X-Point-y (car s)) (/ th 2)) txt)))
 524             y-notches)
 525       )
 526
 527     (XDrawSegments xdpy d gc (nconc (list (cons (cons x (- y center-y)) (cons (+ x w) (- y center-y)))
 528                                           (cons (cons (+ x center-x) y) (cons (+ x center-x) (- y h))))
 529                                     x-notches y-notches))
 530     ))
 531
 532 (defun xwem-diag-plot-points (point-type d gc dots &optional point-size)
 533   "Draw points of TYPE."
 534   (unless point-size
 535     (setq point-size 2))
 536
 537   (let ((xdpy (X-Drawable-dpy d)))
 538     (cond ((eq point-type 0)
 539            (XDrawArcs xdpy d gc
 540                       (mapcar (lambda (d)
 541                                 (make-X-Arc :x (- (X-Point-x d) point-size)
 542                                             :y (- (X-Point-y d) point-size)
 543                                             :width (+ point-size point-size)
 544                                             :height (+ point-size point-size)
 545                                             :angle1 0
 546                                             :angle2 360)) dots))
 547            (XDrawPoints xdpy d gc dots))
 548
 549           ((eq point-type 1)
 550            (XDrawSegments xdpy d gc
 551                           (apply 'nconc
 552                                  (mapcar (lambda (d)
 553                                            (list (cons (cons (- (X-Point-x d) point-size)
 554                                                              (X-Point-y d))
 555                                                        (cons (+ (X-Point-x d) point-size)
 556                                                              (X-Point-y d)))
 557                                                  (cons (cons (X-Point-x d)
 558                                                              (- (X-Point-y d) point-size))
 559                                                        (cons (X-Point-x d)
 560                                                              (+ (X-Point-y d) point-size)))))
 561                                          dots))))
 562
 563           ((eq point-type 2)
 564            (XDrawSegments xdpy d gc
 565                           (apply 'nconc
 566                                  (mapcar (lambda (d)
 567                                            (list (cons (cons (- (X-Point-x d) point-size)
 568                                                              (- (X-Point-y d) point-size))
 569                                                        (cons (+ (X-Point-x d) point-size)
 570                                                              (+ (X-Point-y d) point-size)))
 571                                                  (cons (cons (- (X-Point-x d) point-size)
 572                                                              (+ (X-Point-y d) point-size))
 573                                                        (cons (+ (X-Point-x d) point-size)
 574                                                              (- (X-Point-y d) point-size)))))
 575                                          dots))))
 576           )))
 577
 578 (defun xwem-diag-plot-dots (type d gc x y dots &optional point-type point-size)
 579   "Draw dots in cartesian coordinate system which has 0 at X Y."
 580   ;; Adjust dots, according to X Y
 581   (setq dots (mapcar (lambda (dot)
 582                        (cons (+ x (X-Point-x dot))
 583                              (- y (X-Point-y dot))))
 584                      dots))
 585
 586   ;; Default point/line types
 587   (unless point-type
 588     (setq point-type 0))
 589
 590   (let ((xdpy (X-Drawable-dpy d)))
 591     (cond ((eq type 'points)
 592            (xwem-diag-plot-points point-type d gc dots point-size))
 593
 594           ((eq type 'lines)
 595            (XDrawLines xdpy d gc dots))
 596
 597           ((eq type 'linespoints)
 598            (xwem-diag-plot-points point-type d gc dots point-size)
 599            (XDrawLines xdpy d gc dots))
 600
 601           ((eq type 'impulses)
 602            (XDrawSegments xdpy d gc
 603                           (mapcar (lambda (d)
 604                                     (cons (cons (X-Point-x d) y) d))
 605                                   dots)))
 606
 607           ((eq type 'dots)
 608            (XDrawPoints xdpy d gc dots))
 609
 610           ((eq type 'steps)
 611            (XDrawLines xdpy d gc
 612                        (apply 'nconc (mapcar* (lambda (d dn)
 613                                                 (if dn
 614                                                     (list d (cons (X-Point-x dn) (X-Point-y d)))
 615                                                   (list d)))
 616                                               dots (nconc (cdr dots) (list nil))))))
 617
 618           ((eq type 'fsteps)
 619            (XDrawLines xdpy d gc
 620                        (apply 'nconc (mapcar* (lambda (d dn)
 621                                                 (if dn
 622                                                     (list d (cons (X-Point-x d) (X-Point-y dn)))
 623                                                   (list d)))
 624                                               dots (nconc (cdr dots) (list nil))))))
 625
 626           ((eq type 'histeps)
 627            ;; TODO: write me
 628            )
 629
 630           ((eq type 'boxes)
 631            ;; TODO: write me
 632            ))
 633     ))
 634
 635 (defun xwem-diag-read-data-file (file &optional using x-scale y-scale)
 636   "Read data FILE and return list of dots lists.
 637 USING is cons cell that specifies which columns to use.
 638 X-SCALE is x coordinates scalling.
 639 Y-SCALE is y coordinates scalling."
 640   (unless using
 641     (setq using (cons 1 2)))
 642
 643   (with-temp-buffer
 644     (let (cdots dlist)
 645       (insert-file-contents file)
 646       (goto-char (point-min))
 647       (while (not (eobp))
 648         (cond ((looking-at "^#"))
 649
 650               ((looking-at "^[ \t]*$")
 651                ;; dots set delimiter
 652                (setq dlist (cons cdots dlist))
 653                (setq cdots nil))
 654
 655               (t
 656                (let ((sc (split-string (buffer-substring (point-at-bol) (point-at-eol)) "[ \t]+")))
 657                  (setq sc (delete "" sc))
 658                  (setq cdots (cons (cons (* (or x-scale 1) (string-to-int (nth (1- (car using)) sc)))
 659                                          (* (or y-scale 1) (string-to-int (nth (1- (cdr using)) sc))))
 660                                    cdots))))
 661               )
 662         (forward-line 1))
 663
 664       ;; Add last cdots, if any
 665       (when cdots
 666         (setq dlist (cons cdots dlist)))
 667       dlist)))
 668
 669 ;;; Testing:
 670
 671 ;(progn
 672 ;  (mapc (lambda (dots)
 673 ;          (xwem-diag-plot-dots 'lines (xwem-frame-xwin (nth 3 xwem-frames-list)) (xwem-face-get-gc 'green)
 674 ;                               600 600 dots))
 675 ;        (xwem-diag-read-data-file "/usr/local/share/doc/gnuplot/world.dat" nil 3 4))
 676
 677 ;  (xwem-diag-plot-dots 'points (xwem-frame-xwin (nth 3 xwem-frames-list)) (xwem-face-get-gc 'red)
 678 ;                       600 600 (car (xwem-diag-read-data-file "/usr/local/share/doc/gnuplot/world.cor" nil 3 4)) 1 3)
 679
 680 ;  (xwem-diag-plot-coordinates (xwem-frame-xwin (nth 3 xwem-frames-list)) (xwem-face-get-gc 'blue)
 681 ;                              60 1000 1200 800 50 50
 682 ;                              :center-x 600 :center-y 400 :with-grid t :grid-dash-even 1 :grid-dash-odd 4
 683 ;                              :with-labels t :labels-gc (xwem-face-get-gc 'bold))
 684 ;  )
 685
 686 \f
 687 (provide 'xwem-diagram)
 688
 689 ;;; xwem-diagram.el ends here