Commits

Anonymous committed 376b657

* lisp/addons/xwem-rooter.el (Initial): Handle xwem clients on
root window.

* lisp/addons/xwem-xfig.el (Initial): XFIG stuff for XWEM.

* lisp/addons/xwem-worklog.el (Initial): Worklog mode for XWEM.
Snapshot at http://lgarc.narod.ru/xwem/xwem-worklog.png

* lisp/addons/xwem-diagram.el (Initial): Diagram drawer for XWEM.

* lisp/xwem-keyboard.el (xwem-kbd-process-after-lookup): Some
major changes, get rid of evil lkm symbol props.

* lisp/xwem-interactive.el (xwem-interactive): ?* added to wait
keyrelease.

* Makefile (Module): xwem-diagram, xwem-worklog, xwem-xfig added.

Comments (0)

Files changed (23)

+2004-03-09  Zajcev Evgeny  <zevlg@yandex.ru>
+
+	* lisp/addons/xwem-rooter.el (Initial): Handle xwem clients on
+	root window.
+
+	* lisp/addons/xwem-xfig.el (Initial): XFIG stuff for XWEM.
+
+	* lisp/addons/xwem-worklog.el (Initial): Worklog mode for XWEM.
+	Snapshot at http://lgarc.narod.ru/xwem/xwem-worklog.png
+
+	* lisp/addons/xwem-diagram.el (Initial): Diagram drawer for XWEM.
+
+	* lisp/xwem-keyboard.el (xwem-kbd-process-after-lookup): Some
+	major changes, get rid of evil lkm symbol props.
+
+	* lisp/xwem-interactive.el (xwem-interactive): ?* added to wait
+	keyrelease.
+
+	* Makefile (Module): xwem-diagram, xwem-worklog, xwem-xfig added.
+
 2004-02-15  Zajcev Evgeny  <zevlg@yandex.ru>
 	
 	* XWEM: Many improvements, window configurations, keyboard macros,
 
 ELCS_1 = lisp/addons/xwem-edmacro.elc lisp/addons/xwem-clswi.elc lisp/addons/xwem-time.elc \
         lisp/addons/xwem-osd.elc lisp/addons/xwem-holer.elc lisp/addons/xwem-framei.elc \
-        lisp/addons/xwem-register.elc lisp/addons/xwem-gamma.elc
+        lisp/addons/xwem-register.elc lisp/addons/xwem-gamma.elc lisp/addons/xwem-rooter.elc \
+	lisp/addons/xwem-diagram.elc lisp/addons/xwem-worklog.elc lisp/addons/xwem-xfig.elc
 
 ELCS_1_DEST = $(PACKAGE)/addons
 ELCS_1_FILES = $(ELCS_1) $(ELCS_1:.elc=.el)

lisp/addons/xwem-diagram.el

+;;; xwem-diagram.el --- Diagrams drawing for XWEM.
+
+;; Copyright (C) 2004 by Free Software Foundation, Inc.
+
+;; Author: Zajcev Evgeny <zevlg@yandex.ru>
+;; Created: Sat Mar  6 17:09:58 MSK 2004
+;; Keywords: xwem
+
+;; This file is part of XWEM.
+
+;; XWEM is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XWEM is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
+;; License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
+
+(defun xwem-diag-dot-distance (dot1 dot2)
+  "Return distance betwean DOT1 and DOT2."
+  (let ((w (abs (- (X-Point-x dot1) (X-Point-x dot2))))
+        (h (abs (- (X-Point-y dot1) (X-Point-y dot2)))))
+
+    (sqrt (+ (* h h) (* w h)))))
+
+(defun xwem-diag-dot-betwean-p (x-or-y dot dot1 dot2)
+  "Return non-nil if X-OR-Y of DOT betwean DOT1 and DOT2.
+X-OR-Y can be 'x or 'y."
+  (if (eq x-or-y 'x)
+      (or (and (>= (X-Point-x dot) (X-Point-x dot1))
+               (<= (X-Point-x dot) (X-Point-x dot2)))
+          (and (<= (X-Point-x dot) (X-Point-x dot1))
+               (>= (X-Point-x dot) (X-Point-x dot2))))
+
+    (or (and (>= (X-Point-y dot) (X-Point-y dot1))
+             (<= (X-Point-y dot) (X-Point-y dot2)))
+        (and (<= (X-Point-y dot) (X-Point-y dot1))
+             (>= (X-Point-y dot) (X-Point-y dot2))))))
+
+(defun xwem-diag-dot-< (x-or-y dot dot1)
+  "Return non-nil if X-OR-Y of DOT is < DOT1."
+  (if (eq x-or-y 'x)
+      (< (X-Point-x dot) (X-Point-x dot1))
+    (< (X-Point-y dot) (X-Point-y dot1))))
+
+(defun xwem-diag-dot-<= (x-or-y dot dot1)
+  "Return non-nil if X-OR-Y of DOT is <= DOT1."
+  (if (eq x-or-y 'x)
+      (<= (X-Point-x dot) (X-Point-x dot1))
+    (<= (X-Point-y dot) (X-Point-y dot1))))
+
+(defun xwem-diag-dot-> (x-or-y dot dot1)
+  "Return non-nil if X-OR-Y of DOT is > DOT1."
+  (if (eq x-or-y 'x)
+      (> (X-Point-x dot) (X-Point-x dot1))
+    (> (X-Point-y dot) (X-Point-y dot1))))
+
+(defun xwem-diag-dot->= (x-or-y dot dot1)
+  "Return non-nil if X-OR-Y of DOT is >= DOT1."
+  (if (eq x-or-y 'x)
+      (>= (X-Point-x dot) (X-Point-x dot1))
+    (>= (X-Point-y dot) (X-Point-y dot1))))
+    
+(defun xwem-diag-calc-arc-dot-at (cnt-dot w h a)
+  "Calculte dot position."
+  (let* ((ra (/ (* a pi) 180))
+         (cra (cos ra))
+         (sra (sin ra))
+         (rx (* w cra))
+         (ry (* h sra)))
+    (cons (round (+ (X-Point-x cnt-dot) rx))
+          (round (+ (X-Point-y cnt-dot) (- ry))))))
+
+(defun xwem-diag-draw-rect (xwin gc dot1 dot2 dot3 dot4 &optional fill-gc)
+  "Draw parallelogram with vertexes at DOT1 DOT2 DOT3 and DOT4."
+  (when (X-Gc-p fill-gc)
+    (XFillPoly (X-Win-dpy xwin) xwin fill-gc (list dot1 dot2 dot3 dot4)))
+
+  (XDrawLines (X-Win-dpy xwin) xwin gc (list dot1 dot2 dot3 dot4 dot1)))
+
+(defun xwem-diag-calc-sector-dots (x y w h a1 a2)
+  (let* ((mcnt (cons (+ x (/ w 2))
+                     (+ y (/ h 2))))
+         (d1 (xwem-diag-calc-arc-dot-at mcnt (/ w 2) (/ h 2) a1))
+         (d2 (xwem-diag-calc-arc-dot-at mcnt (/ w 2) (/ h 2) (+ a2 a1))))
+    (list d1 mcnt d2)))
+
+(defun xwem-diag-draw-sector (xwin gc x y w h a1 a2 &optional fill-gc)
+  "Draw sector, return new dots."
+  (let ((dots (xwem-diag-calc-sector-dots x y w h a1 a2)))
+
+    (when (X-Gc-p fill-gc)
+      (XFillArc (X-Win-dpy xwin) xwin fill-gc x y w h a1 a2))
+
+    (XDrawLines (X-Win-dpy xwin) xwin gc dots)
+    (XDrawArc (X-Win-dpy xwin) xwin gc x y w h a1 a2)
+    dots
+    ))
+
+(defun xwem-diag-calc-butt-center (ds1 ds2)
+  "Evil stuff."
+  (let* ((h1 (- (X-Point-x (nth 2 ds1))
+                (X-Point-x (nth 1 ds1))))
+         (h2 (- (X-Point-x (nth 0 ds1))
+                (X-Point-x (nth 1 ds1))))
+         (l (* (/ (float h1) h2)
+               (- (X-Point-y (nth 1 ds2))
+                  (X-Point-y (nth 0 ds2)))))
+         (L (+ (- (X-Point-y (nth 2 ds1))
+                  (X-Point-y (nth 1 ds2)))
+               l))
+         (a (- (X-Point-y (nth 1 ds2))
+               (X-Point-y (nth 1 ds1))))
+
+         (T (xwem-diag-dot-distance
+             (nth 1 ds2) (cons (X-Point-x (nth 2 ds1))
+                               (+ (X-Point-y (nth 1 ds2))
+                                  (truncate l)))))
+         (tt (/ (* T a) (+ L a)))
+         
+         (nx (* h1 (/ tt T)))
+         (ny (* l (/ tt T))))
+
+    (cons (truncate (+ (X-Point-x (nth 1 ds2))
+                       nx))
+          (truncate (+ (X-Point-y (nth 1 ds2))
+                       ny)))))
+            
+(defun xwem-diag-draw-3d-sector (xwin gc x y w h a1 a2 sector-width &optional fill-gc)
+  "Draw 3d sector."
+  (let ((ds1 (xwem-diag-calc-sector-dots x y w h a1 a2))
+        (ds2 (xwem-diag-calc-sector-dots x (+ y sector-width) w h a1 a2))
+        d0-adds1 d0-adds2 d2-adds1 d2-adds2
+        buta1 buta2
+        d0-buta1 d0-buta2
+        d2-buta1 d2-buta2
+        center-visible dot0-visible dot2-visible
+        cd0-visible cd2-visible)
+
+    ;; Adjust a1 and a2
+    (while (< a1 0)
+      (setq a1 (+ a1 360)))
+    (while (> a1 360)
+      (setq a1 (- a1 360)))
+    (while (> a2 360)
+      (setq a2 (- a2 360)))
+
+    (when (or (and (<= a1 180)
+                   (> (+ a1 a2) 180))
+              (and (> a1 180)
+                   (> (+ a1 a2) 540)))
+      (setq d0-adds1 (cons (- (X-Point-x (nth 1 ds1)) (/ w 2))
+                           (X-Point-y (nth 1 ds1))))
+      (setq d0-adds2 (cons (- (X-Point-x (nth 1 ds2)) (/ w 2))
+                           (X-Point-y (nth 1 ds2))))
+      (if (and (<= a1 180)
+               (> (+ a1 a2) 180))
+          (progn
+            (setq buta1 180)
+            (setq buta2 (- a2 (- buta1 a1))))
+
+        (setq d0-buta1 180)
+        (setq d0-buta2 (- (+ a1 a2) 270)))
+      )
+
+    (when (> (+ (or buta1 a1) (or buta2 a2)) 360)
+      (setq d2-adds1 (cons (+ (X-Point-x (nth 1 ds1)) (/ w 2))
+                           (X-Point-y (nth 1 ds1))))
+      (setq d2-adds2 (cons (+ (X-Point-x (nth 1 ds2)) (/ w 2))
+                           (X-Point-y (nth 1 ds2))))
+      (if (or (and (xwem-diag-dot-> 'y (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot-> 'y (nth 2 ds1) (nth 1 ds1)))
+              (and d0-buta1 d0-buta2))
+          (progn
+            (setq d0-buta1 (or d0-buta1 buta1))
+            (setq d0-buta2 (or d0-buta2 buta2))
+            (setq d2-buta1 (or buta1 a1))
+            (setq d2-buta2 (- 360 d2-buta1))
+            (setq buta1 nil
+                  buta2 nil))
+
+        (setq buta1 (or buta1 a1))
+        (setq buta2 (- 360 buta1))
+        ))
+
+    ;; Setup visibilities
+    (unless (and (xwem-diag-dot-< 'x (nth 0 ds1) (nth 1 ds1))
+                 (xwem-diag-dot-< 'y (nth 0 ds1) (nth 1 ds1)))
+      (setq dot0-visible t))
+
+    (unless (and (xwem-diag-dot-> 'x (nth 2 ds1) (nth 1 ds1))
+                 (xwem-diag-dot-< 'y (nth 2 ds1) (nth 1 ds1)))
+      (setq dot2-visible t))
+
+    (when (or (and (xwem-diag-dot->= 'x (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot-<= 'y (nth 0 ds1) (nth 1 ds1))
+                   (not (and (xwem-diag-dot->= 'x (nth 2 ds1) (nth 1 ds1))
+                             (or (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
+                                 (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))))))
+              (and (xwem-diag-dot->= 'x (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
+                   (not (and (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))
+                             (xwem-diag-dot->= 'x (nth 2 ds1) (nth 1 ds1))
+                             (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1)))))
+              (and (xwem-diag-dot-<= 'x (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot-<= 'y (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot-<= 'x (nth 2 ds1) (nth 1 ds1))
+                   (or (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
+                       (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1))))
+              (and (xwem-diag-dot-<= 'x (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot-<= 'x (nth 2 ds1) (nth 1 ds1))
+                   (and (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1))
+                        (xwem-diag-dot->= 'y (nth 2 ds1) (nth 0 ds1)))))
+      (setq center-visible t)
+
+      (when dot0-visible
+        (unless (and (xwem-diag-dot-> 'y (nth 2 ds2) (nth 1 ds2))
+                     (xwem-diag-dot-betwean-p 'x (nth 2 ds2) (nth 1 ds2) (nth 0 ds2)))
+          (setq cd0-visible t)))
+
+      (when dot2-visible
+        (unless (and (xwem-diag-dot-> 'y (nth 0 ds2) (nth 1 ds2))
+                     (xwem-diag-dot-betwean-p 'x (nth 0 ds2) (nth 1 ds2) (nth 2 ds2)))
+          (setq cd2-visible t)))
+      )
+
+    ;; Draw buttom arc
+    (if (and buta1 buta2)
+        (progn
+          (when fill-gc
+            (XFillArc (X-Win-dpy xwin) xwin fill-gc x (+ y sector-width) w h buta1 buta2))
+          (XDrawArc (X-Win-dpy xwin) xwin gc x (+ y sector-width) w h buta1 buta2))
+
+      (if (or (and d0-buta1 d0-buta1)
+              (and d2-buta1 d2-buta2))
+          (progn
+            (when (and d0-buta1 d0-buta1)
+              (when fill-gc
+                (XFillArc (X-Win-dpy xwin) xwin fill-gc x (+ y sector-width) w h d0-buta1 d0-buta2))
+              (XDrawArc (X-Win-dpy xwin) xwin gc x (+ y sector-width) w h d0-buta1 d0-buta2))
+            (when (and d2-buta1 d2-buta2)
+              (when fill-gc
+                (XFillArc (X-Win-dpy xwin) xwin fill-gc x (+ y sector-width) w h d2-buta1 d2-buta2))
+              (XDrawArc (X-Win-dpy xwin) xwin gc x (+ y sector-width) w h d2-buta1 d2-buta2)))
+
+        (when (and (xwem-diag-dot->= 'y (nth 0 ds1) (nth 1 ds1))
+                   (xwem-diag-dot->= 'y (nth 2 ds1) (nth 1 ds1)))
+          (when fill-gc
+            (XFillArc (X-Win-dpy xwin) xwin fill-gc x (+ y sector-width) w h a1 a2))
+          (XDrawArc (X-Win-dpy xwin) xwin gc x (+ y sector-width) w h a1 a2))))
+
+    ;; fill other stuff
+    (when fill-gc
+      ;; main sector
+      (XFillArc (X-Win-dpy xwin) xwin fill-gc x y w h a1 a2)
+
+      (xwem-diag-draw-rect xwin fill-gc
+                           (nth 2 ds2) (nth 2 ds1)
+                           (nth 1 ds1) (nth 1 ds2)
+                           fill-gc)
+      (xwem-diag-draw-rect xwin fill-gc
+                           (nth 0 ds2) (nth 0 ds1)
+                           (nth 1 ds1) (nth 1 ds2)
+                           fill-gc)
+
+      (when (and d0-adds1 d0-adds2)
+        (XFillPoly (X-Win-dpy xwin) xwin fill-gc
+                   (list d0-adds1 d0-adds2 (nth 1 ds2) (nth 1 ds1)
+                         d0-adds1)))
+
+      (when (and d2-adds1 d2-adds2)
+        (XFillPoly (X-Win-dpy xwin) xwin fill-gc
+                   (list d2-adds1 d2-adds2 (nth 1 ds2) (nth 1 ds1)
+                         d2-adds1)))
+      )
+
+    ;; Draw main sector
+    (XDrawLines (X-Win-dpy xwin) xwin gc ds1)
+    (XDrawArc (X-Win-dpy xwin) xwin gc x y w h a1 a2)
+
+    (xwem-diag-draw-sector xwin gc x y w h a1 a2 fill-gc) ; sector always visible
+
+    ;; Draw visibilities
+    (when center-visible
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list (nth 1 ds1) (nth 1 ds2))))
+    (when cd0-visible
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list (nth 1 ds2) (nth 0 ds2))))
+    (when cd2-visible
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list (nth 1 ds2) (nth 2 ds2))))
+    (when dot0-visible
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list (nth 0 ds1) (nth 0 ds2))))
+    (when dot2-visible
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list (nth 2 ds1) (nth 2 ds2))))
+    (when (and d0-adds1 d0-adds2)
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list d0-adds1 d0-adds2)))
+    (when (and d2-adds1 d2-adds2)
+      (XDrawLines (X-Win-dpy xwin) xwin gc (list d2-adds1 d2-adds2)))
+    ))
+
+(defun xwem-diag-draw-percentage (type spec d edge-gc x y width height &optional sector-width label-factor label-font)
+  "Draw percentage sector of TYPE.
+TYPE is one of 'plain or '3d.
+SPEC specifies percentage to display, it is an array in form
+\[percents sector-label fill-color center-offset x-offset y-offset\]
+  perecnts - is number betwean 0 and 100.
+  sector-label - either string or t, t mean show percentage.
+  fill-color - nil or color to fill sector.
+  center-offset - sector's offset from center using bisector vector.
+  x-offset - sector's x offset.
+  y-offset - sector's y offest.
+
+EDGE-GC used to draw sector edges.
+X, Y, WIDTH and HEIGHT specifies sector geometry coordinate inside
+drawable D.
+Optionally SECTOR-WIDTH may be specified (only for '3d TYPE).
+LABEL-FACTOR is float number used, when calculating label placement.
+LABEL-FONT is font used to draw label, default is font of EDGE-GC."
+  (let ((xdpy (X-Drawable-dpy d))
+        (temp-fill-face (make-face 'temp-fill-face))
+        (start-angle 0)
+        angle-begin
+        curel curang)
+    
+    ;; Validate spec
+    (when (> (apply '+ (mapcar (lambda (el) (aref el 0)) spec)) 100)
+      (error "Invalid spec" spec))
+
+    (let ((draw-sector (lambda (sel angbeg angle)
+                         (xwem-face-set-foreground temp-fill-face (aref sel 2))
+                         (let ((xint-off 0)
+                               (yint-off 0))
+
+                           (when (not (zerop (aref sel 3)))
+                             (let ((ra (/ (* pi (+ angbeg (/ angle 2))) 180)))
+                               (setq xint-off (round (* (aref sel 3) (cos ra))))
+                               (setq yint-off (- (round (* (aref sel 3) (sin ra)))))))
+
+                           (if (eq type 'plain)
+                               (xwem-diag-draw-sector d edge-gc (+ x xint-off (aref sel 4))
+                                                      (+ y yint-off (aref sel 5)) width height
+                                                      angbeg angle (xwem-face-get-gc temp-fill-face))
+
+                             (xwem-diag-draw-3d-sector d edge-gc (+ x xint-off (aref sel 4))
+                                                       (+ y yint-off (aref sel 5)) width height
+                                                       angbeg angle (or sector-width 10)
+                                                       (xwem-face-get-gc temp-fill-face)))
+
+                           ;; Draw label
+                           (when (aref sel 1)
+                             (let* ((k (or label-factor 0.8))
+                                    (nw (* width k))
+                                    (nh (* height k))
+                                    (nx (+ (aref sel 4) x xint-off (/ (- width nw) 2)))
+                                    (ny (+ (aref sel 5) y yint-off (/ (- height nh) 2)))
+                                    (cd (xwem-diag-calc-sector-dots nx ny nw nh angbeg (/ angle 2)))
+                                    (gc edge-gc)
+                                    (text (if (stringp (aref sel 1)) (aref sel 1) (format "%d%%" (aref sel 0)))))
+                               (XDrawString xdpy d gc
+                                            (- (X-Point-x (nth 2 cd)) (/ (X-Text-width xdpy (X-Gc-font gc) text) 2))
+                                            (+ (/ (X-Text-height xdpy (X-Gc-font gc) text) 2)
+                                               (X-Point-y (nth 2 cd)))
+                                            text)))
+                               ))))
+
+      ;; Sort SPEC by percentage
+      (setq spec (sort spec (lambda (el1 el2) (> (aref el1 0) (aref el2 0)))))
+
+      ;; Special cases, when first sector is too big or too small
+      (when (> (aref (car spec) 0) 75)
+        (setq start-angle (* 360.0 (/ (- (aref (car spec) 0) 100) 100.0))))
+      (when (< (aref (car spec) 0) 25)
+        (setq start-angle (* 360.0 (/ (- 25 (aref (car spec) 0)) 100.0))))
+
+      (setq angle-begin start-angle)
+      ;; Draw huge sectors
+      (while (and spec (< (+ (* 100 (/ angle-begin 360.0))
+                             (aref (car spec) 0))
+                          75))
+        (setq curel (car spec))
+        (setq curang (* 360.0 (/ (aref curel 0) 100.0)))
+
+        (funcall draw-sector curel angle-begin curang)
+
+        (setq angle-begin (+ angle-begin curang))
+        (setq spec (cdr spec)))
+        
+      ;; Draw little sectors
+      (setq angle-begin start-angle)
+      (setq spec (nreverse spec))
+      (while spec
+        (setq curel (car spec))
+        (setq curang (* 360.0 (/ (aref curel 0) 100.0)))
+        (setq angle-begin (- angle-begin curang))
+      
+        (funcall draw-sector curel angle-begin curang)
+
+        (setq spec (cdr spec)))
+
+      ;; Draw other sectors, XXX not used
+      (setq angle-begin 0)
+      (mapc (lambda (el)
+              (setq curang (* 360.0 (/ (aref el 0) 100.0)))
+              (funcall draw-sector el angle-begin curang)
+              (setq angle-begin (+ angle-begin curang)))
+            spec)
+
+      (X-Dpy-message-buffer xdpy)
+      )))
+
+
+(provide 'xwem-diagram)
+
+;;; xwem-diagram.el ends here

lisp/addons/xwem-edmacro.el

 
 
 (eval-and-compile
+  (require 'xwem-macros)
   (require 'edmacro))
 
 (defgroup xwem-edmacro nil

lisp/addons/xwem-holer.el

 			 width height xwem-holer-outline-width
 			 nil nil nil (make-X-Attr :override-redirect t
 						  :border-pixel (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-										  xwem-holer-outline-color (make-X-Color)))))
+										  xwem-holer-outline-color))))
     (X-Win-put-prop (xwem-holer-outliner-win holer) 'xwem-holer holer)
     (XMapWindow xdpy (xwem-holer-outliner-win holer))
 

lisp/addons/xwem-osd.el

 			 0 nil nil nil
 			 (make-X-Attr :override-redirect t
 				      :background-pixel (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-									  color (make-X-Color)))))
+									  color))))
     (setf (xwem-osd-instance-xmask osin)
 	  (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy))
 			 (xwem-osd-instance-xwin osin) 1
     (setf (xwem-osd-instance-color osin) new-color)
     (XSetWindowBackground xdpy (xwem-osd-instance-xwin osin)
 			  (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-					    new-color (make-X-Color)))
+					    new-color))
     (XClearArea xdpy (xwem-osd-instance-xwin osin)
 		0 0 (xwem-osd-width (xwem-osd-instance-osd osin))
 		(xwem-osd-height (xwem-osd-instance-osd osin)) nil)))
 	  (XCreateGC xdpy (xwem-osd-xwin osd)
 		     (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
 				:foreground (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-							      xwem-osd-default-color (make-X-Color))
+							      xwem-osd-default-color)
 				:font (X-Font-get xdpy xwem-osd-default-font))))
 
     (X-Win-put-prop (xwem-osd-xwin osd) 'osd-ctx osd)
   (let ((xdpy (xwem-osd-xdpy osd)))
     (XSetWindowBackground xdpy (xwem-osd-xwin osd)
 			  (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-					    color-name (make-X-Color)))))
+					    color-name))))
 
 (defun xwem-osd-set-gc-color (osd color-name)
   "Set OSD's gc foreground color to COLOR-NAME."
   (let ((xdpy (xwem-osd-xdpy osd)))
     (setf (X-Gc-foreground (xwem-osd-gc osd))
 	  (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-			    color-name (make-X-Color)))
+			    color-name))
     (XChangeGC xdpy (xwem-osd-gc osd))))
 
 (defun xwem-osd-set-color (osd color-name)
   "Set both OSD's background and OSD's gc foreground color to COLOR-NAME."
   (let* ((xdpy (xwem-osd-xdpy osd))
 	 (col (XAllocNamedColor xdpy (XDefaultColormap xdpy)
-				color-name (make-X-Color))))
+				color-name)))
     (XSetWindowBackground xdpy (xwem-osd-xwin osd) col)
     (xwem-osd-clear-xwin osd)
     (setf (X-Gc-foreground (xwem-osd-gc osd)) col)

lisp/addons/xwem-rooter.el

+;;; xwem-rooter.el --- OnRoot clients support.
+
+;; Copyright (C) 2004 by Free Software Foundation, Inc.
+
+;; Author: Zajcev Evgeny <zevlg@yandex.ru>
+;; Created: Sat Feb 21 03:41:02 MSK 2004
+;; Keywords: xwem
+;; X-CVS: $Id$
+
+;; This file is part of XWEM.
+
+;; XWEM is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XWEM is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
+
+(defvar xwem-rooter-keymap
+  (let ((map (make-sparse-keymap)))
+    (define-key map (xwem-kbd "C-<button1>") 'xwem-rooter-move)
+    (define-key map (xwem-kbd "C-<button2>") 'xwem-rooter-destroy)
+    (define-key map (xwem-kbd "C-<button3>") 'xwem-rooter-resize)
+    (define-key map (xwem-kbd "C-Sh-<button1>") 'xwem-rooter-raise)
+    (define-key map (xwem-kbd "C-Sh-<button3>") 'xwem-rooter-lower)
+    map)
+  "Keymap for rooter clients.")
+
+(defmacro xwem-rooter-add-client (name class-name &optional class-instance wm-name)
+  "Define client which class name matches CLASS-NAME regexp.
+And class instance matches CLASS-INS regexp, and WM_NAME matches
+WM-NAME as rooter client."
+  `(define-xwem-manda ,name (xwem-class-matcher ,class-name ,class-instance ,wm-name)
+     0 t nil 'xwem-rooter-manage))
+
+(define-xwem-command xwem-rooter-move ()
+  "Interactively move client clicked by button event MEV."
+  (xwem-interactive "_")
+
+  (let* ((mev xwem-last-xevent)
+         (xwin (X-Event-xbutton-event mev))
+         (x-clic (X-Event-xbutton-event-x mev))
+         (y-clic (X-Event-xbutton-event-y mev)))
+
+    (XGrabPointer (xwem-dpy) xwin (Xmask-or XM-ButtonMotion XM-ButtonRelease XM-ButtonPress)
+                  xwem-cursor-move)
+    (unwind-protect
+        (let ((done nil)
+              xev)
+          (while (not done)
+            (setq xev (XNextEvent (xwem-dpy)))
+
+            (X-Event-CASE xev
+              (:X-ButtonRelease
+               (setq done t))
+
+              (:X-MotionNotify
+               (XMoveWindow (xwem-dpy) xwin
+                            (- (X-Event-xmotion-root-x xev) x-clic)
+                            (- (X-Event-xmotion-root-y xev) y-clic))))))
+      
+      (XUngrabPointer (xwem-dpy)))))
+
+(define-xwem-command xwem-rooter-resize ()
+  "Resize rooter client."
+  (xwem-interactive "_")
+
+  (let* ((mev xwem-last-xevent)
+         (xwin (X-Event-xbutton-event mev))
+         (x-clic (X-Event-xbutton-event-x mev))
+         (y-clic (X-Event-xbutton-event-y mev)))
+
+    (XGrabPointer (xwem-dpy) xwin (Xmask-or XM-ButtonMotion XM-ButtonRelease XM-ButtonPress)
+                  xwem-cursor-resize)
+    (unwind-protect
+        (let (done xev)
+          (XResizeWindow (xwem-dpy) xwin x-clic y-clic)
+          (while (not done)
+            (setq xev (XNextEvent (xwem-dpy)))
+            (X-Event-CASE xev
+              (:X-ButtonRelease
+               (setq done t))
+              (:X-MotionNotify
+               (let ((xoff (X-Event-xmotion-event-x xev))
+                     (yoff (X-Event-xmotion-event-y xev)))
+                 ;; XXX workaround INT/CARD bug
+                 (xwem-message 'info "x=%d, y=%d" xoff yoff)
+                 (when (and (< xoff 40000) (< yoff 40000))
+                   (XResizeWindow (xwem-dpy) xwin xoff yoff))))
+              )))
+      (XUngrabPointer (xwem-dpy)))))
+
+(define-xwem-command xwem-rooter-destroy ()
+  "Destroy rooter client."
+  (xwem-interactive "_")
+
+  (let* ((mev xwem-last-xevent)
+         (xwin (X-Event-xbutton-event mev))
+         (x-clic (X-Event-xbutton-event-x mev))
+         (y-clic (X-Event-xbutton-event-y mev)))
+
+    (when (X-Win-p xwin)
+      (XDestroyWindow (X-Win-dpy xwin) xwin))))
+  
+(define-xwem-command xwem-rooter-raise ()
+  "Raise rooter window."
+  (xwem-interactive "_")
+
+  (XRaiseWindow (xwem-dpy) xwem-event-window))
+
+(define-xwem-command xwem-rooter-lower ()
+  "Lower rooter window."
+  (xwem-interactive "_")
+
+  (XLowerWindow (xwem-dpy) xwem-event-window))
+
+(defun xwem-rooter-manage (cl &rest args)
+  "Manage rooter client CL."
+  (let ((xdpy (xwem-dpy))
+        (xwin (xwem-cl-xwin cl))
+        (xgeom (xwem-cl-xgeom cl)))
+
+    (xwem-focus-mode-set cl nil)        ; no focus mode
+
+    (XReparentWindow xdpy xwin (xwem-rootwin) (X-Geom-x xgeom) (X-Geom-y xgeom))
+    (XLowerWindow xdpy xwin)
+    (XMapWindow xdpy xwin)
+
+    ;; Install client local keymap
+    (xwem-focus-excursion xwin
+      (map-keymap (lambda (key bind)
+                    (xwem-local-set-key key bind cl))
+                  xwem-rooter-keymap))
+    ))
+
+
+(provide 'xwem-rooter)
+
+;;; xwem-rooter.el ends here

lisp/addons/xwem-worklog.el

+;;; xwem-worklog.el --- Worklog for XWEM.
+
+;; Copyright (C) 2004 by Free Software Foundation, Inc.
+
+;; Author: Zajcev Evgeny <zevlg@yandex.ru>
+;; Created: Thu Feb 26 01:00:25 MSK 2004
+;; Keywords: xwem
+;; X-CVS: $Id$
+
+;; This file is part of XWEM.
+
+;; XWEM is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XWEM is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; Inspired by `worklog.el'.
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+
+(require 'xwem-diagram)
+
+(defstruct xwem-worklog-pause
+  (type 'pause)                         ; type of pause, can be 'pause or 'list
+  prefix-arg                            ; prefix arg, when entering pause
+  pwin                                  ; xwin that shows pause stuff
+  pbuf                                  ; buffer to render
+  start-time
+  end-time
+  
+  itimer                                ; content updater itimer
+  )
+
+(defstruct xwem-worklog-task
+  name                                  ; task name
+  times                                 ; list of cons cells in form (start-time . stop-time)
+  (total-time '(0 0))                   ; total time spended on this task
+  (today-time '(0 0))                   ; today's time spended on task
+  
+  last-comment                          ; last comment to this task
+  )
+
+(defgroup xwem-worklog nil
+  "Group to customize xwem worklog."
+  :prefix "xwem-worklog-"
+  :group 'xwem)
+
+(defcustom xwem-worklog-file "worklog"
+  "*File to store xwem worklogs."
+  :type 'file
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-load-hook nil
+  "*Hooks to run when worklog loaded."
+  :type 'hook
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-auto-continue nil
+  "*Non-nil mean auto continue, when task started/stoped while in pause."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pause-dont-stop t
+  "*Non-nil mean do not suspend current task when entering pause."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-register-new-tasks t
+  "*Non-nil mean register new tasks in `xwem-worklog-tasks-description'.
+Task not registered if it is already in `xwem-worklog-tasks-description'."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-auto-worklog-file nil
+  "*Non-nil mean save changes all the time to `xwem-worklog-file'.
+Note that `xwem-worklog-task-time-decrease' and
+`xwem-worklog-task-time-increase' wont change file entries."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-save-worklog-file-on-logout t
+  "*Non-nil mean save current tasks state to `xwem-worklog-file', when you logout."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-read-worklog-file-on-login t
+  "*Non-nil mean read `xwem-worklog-file', when you login."
+  :type 'boolean
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-day-start 9
+  "*Hour number when your workday starts."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-day-ends 18
+  "*Hour number when your workday ends."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-logout-notify-period 5
+  "*Period in minutes to notify, that your workday is end, and you need to logout."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-logout-auto-period 60
+  "*Period in minutes to autologout, after your workday is end."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-login-notify-period 5
+  "*Period in minutes to notify that your workday started."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-login-stop-period 45
+  "*Period in minites when login notifying stops."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pwin-background (face-background-name 'default)
+  "*Color used as background color for xwem worklog pause window."
+  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pwin-width 500
+  "*Width of pause window."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pwin-height 500
+  "*Height of xwem worklog pause window."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pwin-border-width 2
+  "*Border width for xwem worklog pause window."
+  :type 'number
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pwin-border-color "red4"
+  "*Border color for xwem worklog pause window."
+  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
+  :group 'xwem-worklog)
+  
+(defcustom xwem-worklog-pause-cursor-shape 'X-XC-gumby
+  "*Shape of cursor while in xwem worklog pause."
+  :type (xwem-cursor-shape-choice)
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pause-cursor-foreground-color "#777777"
+  "*Cursor's foreground color, while in xwem worklog pause."
+  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-pause-cursor-background-color nil
+  "*Cursor's background color, while in xwem worklog pause."
+  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
+  :group 'xwem-worklog)
+
+(defcustom xwem-worklog-tasks-description
+  (list (vector "News/Mail/Web reading" (xwem-kbd "H-w") "blue")
+        (vector "Info/man reading" (xwem-kbd "H-i") "cyan")
+        (vector "Emacs lisping" (xwem-kbd "H-e") "yellow2")
+        (vector "C for fun" (xwem-kbd "H-f") "tomato")
+        (vector "C for profit" (xwem-kbd "H-p") "magenta")
+        (vector "WorkProject" (xwem-kbd "H-c") "green2")
+        (vector "Administrativa" (xwem-kbd "H-a") "lightblue")
+        (vector "Smoke" (xwem-kbd "H-s") "red3")
+        (vector "Nothing" (xwem-kbd "H-n") "gray80"))
+  "Alist with elements in form (name . key)."
+  :type 'alist
+  :group 'xwem-worklog)
+
+(xwem-define-prefix-command 'xwem-worklog-prefix t)
+(defvar xwem-worklog-map (symbol-function 'xwem-worklog-prefix)
+  "Keymap for xwem worklog (\\<xwem-global-map>\\[xwem-worklog-prefix]) commands.
+Bindings:
+\\{xwem-worklog-map}")
+
+(define-key xwem-worklog-map (xwem-kbd "<tab>") 'xwem-worklog-login)
+(define-key xwem-worklog-map (xwem-kbd "i") 'xwem-worklog-login)
+(define-key xwem-worklog-map (xwem-kbd "<backspace>") 'xwem-worklog-logout)
+(define-key xwem-worklog-map (xwem-kbd "o") 'xwem-worklog-logout)
+
+(define-key xwem-worklog-map (xwem-kbd "b") 'xwem-worklog-begin-task)
+(define-key xwem-worklog-map (xwem-kbd "s") 'xwem-worklog-end-task)
+(define-key xwem-worklog-map (xwem-kbd "e") 'xwem-worklog-end-task)
+(define-key xwem-worklog-map (xwem-kbd "p") 'xwem-worklog-pause)
+(define-key xwem-worklog-map (xwem-kbd "l") 'xwem-worklog-task-list)
+
+;; Scan throught `xwem-worklog-tasks-description' to install custom
+;; keybindings.
+(defun xwem-worklog-create-cmd (template)
+  "Create symbol from TEMPLATE string."
+  (let ((fsym (make-symbol (concat "xwem-worklog-custom-" (replace-in-string template " " "-")))))
+    (fset fsym `(lambda ()
+                  (interactive)
+                  (xwem-worklog-begin-task ,template)))
+    fsym))
+
+(mapc (lambda (el)
+        (define-key xwem-worklog-map (aref el 1) (xwem-worklog-create-cmd (aref el 0))))
+      xwem-worklog-tasks-description)
+
+(defvar xwem-worklog-pause-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-default-binding map 'xwem-worklog-continue)
+
+    (define-key map (xwem-kbd "-") 'xwem-worklog-task-time-decrease)
+    (define-key map (xwem-kbd "+") 'xwem-worklog-task-time-increase)
+
+    (define-key map (xwem-kbd "0") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "1") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "2") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "3") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "4") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "5") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "6") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "7") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "8") 'xwem-universal-digit)
+    (define-key map (xwem-kbd "9") 'xwem-universal-digit)
+    (define-key map xwem-universal-key 'xwem-universal-argument)
+
+    (set-keymap-parents map (list xwem-worklog-map))
+    map)
+  "Keymap used when worklog in pause state.")
+
+(defvar xwem-worklog-pause-cursor nil
+  "Cursor used while in xwem worklog pause.")
+
+(defvar xwem-worklog-pause-p nil
+  "Non-nil when worklog in pause state.
+Internal variable, do not modify!.")
+
+(defvar xwem-worklog-current-task nil
+  "Current task.")
+
+(defvar xwem-worklog-task-list nil
+  "List of tasks.")
+
+(defvar xwem-worklog-pause-window-update-hook nil
+  "Hooks called when updating pause window contents.
+For internal usage only.")
+
+
+(defun xwem-worklog-register-task (name &optional no-binding)
+  "Register new task with NAME in `xwem-worklog-tasks-description'.
+Query for keybinding unless NO-BINDING is non-nil."
+  (let ((tal xwem-worklog-tasks-description))
+    (while (and tal (not (string= (aref (car tal) 0) name)))
+      (setq tal (cdr tal)))
+    
+    (unless tal
+      (let ((key (and (not no-binding)
+                      (xwem-read-key (format "Key for '%s' task: " name)))))
+        (when key
+          (setq key (events-to-keys (vector key)))
+          (define-key xwem-worklog-map key (xwem-worklog-create-cmd name)))
+        
+        (setq xwem-worklog-tasks-description (cons (vector name key nil) xwem-worklog-tasks-description))))
+    ))
+
+(defun xwem-worklog-find-task (name &optional create)
+  "Search for task with NAME in tasks list."
+  (let ((tasks xwem-worklog-task-list))
+    (while (and tasks (not (string= name (xwem-worklog-task-name (car tasks)))))
+      (setq tasks (cdr tasks)))
+
+    (if (or tasks (not create))
+        (car tasks)
+
+      (let ((task (make-xwem-worklog-task :name name)))
+        (setq xwem-worklog-task-list (cons task xwem-worklog-task-list))
+        task))))
+
+(defun xwem-worklog-lookup-description (name)
+  "Lookup description for task named by NAME."
+  (let ((tal xwem-worklog-tasks-description))
+    (while (and tal (not (string= (aref (car tal) 0) name)))
+      (setq tal (cdr tal)))
+    (car tal)))
+  
+(define-xwem-command xwem-worklog-begin-task (name &optional arg)
+  "Start new worklog task named after NAME.
+If prefix ARG is specified, and we are in pause, than resume."
+  (xwem-interactive (list (xwem-completing-read "Task name: "
+                                                (mapcar (lambda (el)
+                                                          (list (aref el 0)))
+                                                        xwem-worklog-tasks-description))
+                          xwem-prefix-arg))
+
+  (when xwem-worklog-current-task
+    ;; Some task runned
+    (xwem-worklog-end-task xwem-worklog-current-task))
+
+  ;; Register in `xwem-worklog-tasks-description'
+  (when (and (xwem-interactive-p)
+             xwem-worklog-register-new-tasks)
+    (xwem-worklog-register-task name))
+
+  ;; go go go!
+  (setq xwem-worklog-current-task
+        (xwem-worklog-find-task name t))
+  
+  (unless (and xwem-worklog-pause-p
+               (not (or xwem-worklog-pause-dont-stop
+                        (xwem-worklog-pause-prefix-arg xwem-worklog-pause-p))))
+    (xwem-worklog-resume-task xwem-worklog-current-task))
+
+  (when (and (or arg xwem-worklog-auto-continue)
+             xwem-worklog-pause-p)
+    (xwem-worklog-pause-stop)
+    (xwem-worklog-resume-task xwem-worklog-current-task))
+    
+  (xwem-message 'info "WORKLOG: new task '%s' started." name))
+
+(define-xwem-command xwem-worklog-end-task (task &optional arg)
+  "Stop TASK.
+By default `xwem-worklog-current-task' assumed.
+If prefix ARG is specified, and we are in pause, than resume."
+  (xwem-interactive (list xwem-worklog-current-task xwem-prefix-arg))
+
+  (when (or arg xwem-worklog-auto-continue)
+    (xwem-worklog-pause-stop))
+
+  (when task
+    (xwem-worklog-pause-task task)
+    (xwem-worklog-task-update-total-time task)
+    (xwem-worklog-task-update-today-time task)
+
+    (xwem-message 'info "WORKLOG: task '%s' stoped." (xwem-worklog-task-name xwem-worklog-current-task))
+    (setq xwem-worklog-current-task nil))
+  )
+
+(defun xwem-worklog-task-change-time (how arg)
+  "Change runtime of current task by ARG minutes.
+HOW is one of '- or '+."
+  (when (and xwem-worklog-current-task
+             (caar (xwem-worklog-task-times xwem-worklog-current-task)))
+    (let ((ctime (decode-time (caar (xwem-worklog-task-times xwem-worklog-current-task)))))
+      (setcar (cdr ctime)
+              (funcall how (cadr ctime) arg))
+      (setcar (car (xwem-worklog-task-times xwem-worklog-current-task))
+              (apply 'encode-time ctime)))))
+
+(define-xwem-command xwem-worklog-task-time-increase (arg)
+  "Increase runtime of current task by ARG minutes."
+  (xwem-interactive "p")
+
+  (xwem-worklog-task-change-time '- arg))
+
+(define-xwem-command xwem-worklog-task-time-decrease (arg)
+  "Decrease runtime of current task by ARG minutes."
+  (xwem-interactive "p")
+
+  (xwem-worklog-task-change-time '+ arg))
+
+(defun xwem-worklog-pause-task (task)
+  "Pause task named by NAME."
+  (unless (cdr (car (xwem-worklog-task-times task)))
+    (setcdr (car (xwem-worklog-task-times task))
+            (current-time))
+
+    (when xwem-worklog-auto-worklog-file
+      ;; XXX logout/login is special tasks that does not need to be
+      ;; stoped
+      (unless (or (string= (xwem-worklog-task-name task) "logout")
+                  (string= (xwem-worklog-task-name task) "login"))
+        (xwem-worklog-add-entry "stop")))
+  ))
+
+(defun xwem-worklog-resume-task (task)
+  "Resume TASK."
+  (when (or (null (xwem-worklog-task-times task))
+            (cdr (car (xwem-worklog-task-times task))))
+    (setf (xwem-worklog-task-times task)
+          (cons (cons (current-time) nil) (xwem-worklog-task-times task)))
+    (when xwem-worklog-auto-worklog-file
+      (xwem-worklog-add-entry (xwem-worklog-task-name task)))
+    ))
+
+(defun xwem-worklog-task-update-total-time (task)
+  "Update total-time entry of TASK."
+  (setf (xwem-worklog-task-total-time task)
+        (apply 'xwem-worklog-calc-time
+               (mapcar (lambda (el)
+                         (xwem-worklog-time-diff (cdr el) (car el)))
+                       (xwem-worklog-task-times task)))))
+
+(defun xwem-worklog-task-update-today-time (task)
+  "Update today-time entry of TASK."
+  (let ((ttimes (xwem-worklog-task-times task))
+        (ctime (decode-time (current-time)))
+        stime etime rttimes)
+    ;; Set secs, mins, hours to 0
+    (setcar ctime 0)
+    (setcar (cdr ctime) 0)
+    (setcar (cddr ctime) 0)
+    (setq stime (apply 'encode-time ctime))
+
+    ;; Set secs=59, mins=59, hours=23
+    (setcar ctime 59)
+    (setcar (cdr ctime) 59)
+    (setcar (cddr ctime) 23)
+    (setq etime (apply 'encode-time ctime))
+
+    (while ttimes
+      (setq ctime (car ttimes))
+      (if (and (car ctime) (cdr ctime)
+               (xwem-worklog-time-> (car ctime) stime)
+               (xwem-worklog-time-< (cdr ctime) etime))
+          (setq rttimes (cons ctime rttimes)))
+      (setq ttimes (cdr ttimes)))
+
+    (setf (xwem-worklog-task-today-time task)
+          (and rttimes
+               (apply 'xwem-worklog-calc-time
+                      (mapcar (lambda (el)
+                                (xwem-worklog-time-diff (cdr el) (car el)))
+                              rttimes))))))
+
+(defun xwem-worklog-calc-time (ct &rest diffs)
+  "Calculate total time."
+  (if (or (null diffs) (null (car diffs)))
+      ct
+
+    (let ((a (+ (nth 0 ct) (nth 0 (car diffs))))
+          (b (+ (nth 1 ct) (nth 1 (car diffs)))))
+      (when (> b 65535)
+        (setq a (1+ a))
+        (setq b (- b 65536)))
+
+      (apply 'xwem-worklog-calc-time (cons (list a b) (cdr diffs))))))
+
+(define-xwem-command xwem-worklog-pause (arg &optional type)
+  "Pause task counting.
+If called with prefix ARG, than do not pause current task, if any."
+  (xwem-interactive "P")
+
+  (xwem-message 'info "worklog PAUSE")
+
+  ;; Since we will block here, we need to reset `xwem-prefix-arg'
+  (setq xwem-prefix-arg nil)
+
+  (if xwem-worklog-pause-p
+      ;; Already paused .. so just change type
+      (progn
+        (setf (xwem-worklog-pause-prefix-arg xwem-worklog-pause-p) arg)
+        (setf (xwem-worklog-pause-type xwem-worklog-pause-p) (or type 'pause)))
+
+    ;; Pause current task, if we are not already in pause
+    (when (and xwem-worklog-current-task
+               (not (or arg xwem-worklog-pause-dont-stop)))
+      (xwem-worklog-pause-task xwem-worklog-current-task)
+      (xwem-worklog-task-update-total-time xwem-worklog-current-task)
+      (xwem-worklog-task-update-today-time xwem-worklog-current-task))
+
+    (xwem-worklog-pause-start (or type 'pause) arg)
+    (let ((xwem-override-map xwem-worklog-pause-map)
+          xev)
+      (xwem-kbd-stop-grabbing)
+      (xwem-kbd-start-grabbing xwem-worklog-pause-cursor)
+      (setq xwem-this-command-keys [])
+      (unwind-protect
+          (while xwem-worklog-pause-p
+            (setq xev (XNextEvent (xwem-dpy) 1))
+            (if (not xev)
+                ;; Timeout
+                (xwem-worklog-pause-update)
+
+              ;; Event arrived
+              (X-Event-CASE xev
+                (:X-KeyPress
+                 (unless (xwem-kbd-kcode-modifier-p (X-Event-xkey-keycode xev))
+                   (xwem-kbd-handle-keybutton xev)
+
+                   ;; XXX
+                   (if (eq (xwem-kbd-current-map) xwem-worklog-pause-map)
+                       (setq xwem-this-command-keys [])
+                     (setq xwem-override-map xwem-worklog-pause-map))
+
+                   (when xwem-worklog-pause-p
+                     (xwem-worklog-pause-update t))))
+
+                ((:X-ButtonPress :X-ButtonRelease)
+                 (xwem-kbd-handle-keybutton xev)
+                 (when xwem-worklog-pause-p
+                   (xwem-worklog-pause-update t)))
+
+                (:X-Expose
+                 (when (= (X-Win-id (X-Event-xexpose-window xev)) (X-Win-id xwem-worklog-pause-p))
+                   (xwem-worklog-pause-update)
+                   (run-hooks 'xwem-worklog-pause-window-update-hook))
+                 ))
+              ))
+
+        ;; Ungrab keyboard and stop pauser if any
+        (xwem-worklog-pause-stop)
+        (xwem-kbd-stop-grabbing))
+      )))
+
+(define-xwem-command xwem-worklog-task-list (arg)
+  "Display task list using pause window."
+  (xwem-interactive "P")
+
+  (let ((xwem-worklog-pause-window-update-hook (list 'xwem-worklog-show-color-breaks 'xwem-worklog-draw-today-diagram)))
+    (xwem-worklog-pause arg 'list)))
+
+(define-xwem-command xwem-worklog-continue (arg)
+  "Continue run current task."
+  (xwem-interactive "P")
+
+  (xwem-worklog-pause-stop)
+
+  (when xwem-worklog-current-task
+    (xwem-worklog-resume-task xwem-worklog-current-task)
+    (xwem-message 'info "WORKLOG: continuing '%s' task" (xwem-worklog-task-name xwem-worklog-current-task)))
+  )
+
+(defun xwem-worklog-pause-start (type arg)
+  "Start xwem worklog pausing."
+  (if xwem-worklog-pause-p
+      ;; Already exists, so just change type
+      (setf (xwem-worklog-pause-type xwem-worklog-pause-p) type)
+
+    ;; Create new pause window
+    (setq xwem-worklog-pause-p
+          (make-xwem-worklog-pause :type type
+                                   :prefix-arg arg
+                                   :pwin (xwem-worklog-pause-create-xwin)
+                                   :pbuf (get-buffer-create " *worklog-pause*")
+                                   :start-time (current-time)))
+
+    ;; Wait for expose to start timer
+    (XSync (xwem-dpy))
+    (XIfEvent (xwem-dpy)
+              (lambda (xev)
+                (and (= (X-Event-type xev) X-Expose)
+                     (= (X-Win-id (X-Event-xexpose-window xev))
+                        (X-Win-id (xwem-worklog-pause-pwin xwem-worklog-pause-p))))))
+
+    (xwem-worklog-pause-update t)
+    ))
+
+(defun xwem-worklog-pause-stop ()
+  "Stop xwem worklog pausing."
+
+  (when xwem-worklog-pause-p
+    (when (X-Win-p (xwem-worklog-pause-pwin xwem-worklog-pause-p))
+      (XDestroyWindow (xwem-dpy) (xwem-worklog-pause-pwin xwem-worklog-pause-p)))
+    (when (bufferp (xwem-worklog-pause-pbuf xwem-worklog-pause-p))
+      (kill-buffer (xwem-worklog-pause-pbuf xwem-worklog-pause-p)))
+
+    (setq xwem-worklog-pause-p nil)))
+                           
+(defun xwem-worklog-pause-create-xwin ()
+  "Create pause window in center of selected frame.."
+  ;; Create cursor
+  (unless xwem-worklog-pause-cursor
+    (setq xwem-worklog-pause-cursor
+          (xwem-make-cursor (eval xwem-worklog-pause-cursor-shape)
+                            xwem-worklog-pause-cursor-foreground-color
+                            xwem-worklog-pause-cursor-background-color)))
+
+  (let* ((xfgeom (xwem-frame-xgeom (xwem-frame-selected)))
+         (xwin (XCreateWindow (xwem-dpy) nil
+                              (+ (X-Geom-x xfgeom) (/ (- (X-Geom-width xfgeom) xwem-worklog-pwin-width) 2))
+                              (+ (X-Geom-y xfgeom) (/ (- (X-Geom-height xfgeom) xwem-worklog-pwin-height) 2))
+                              xwem-worklog-pwin-width xwem-worklog-pwin-height xwem-worklog-pwin-border-width nil nil nil
+                              (make-X-Attr :override-redirect t
+                                           :background-pixel (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
+                                                                               xwem-worklog-pwin-background)
+                                           :border-pixel (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
+                                                                           xwem-worklog-pwin-border-color)
+                                           :event-mask (Xmask-or XM-Exposure
+                                                                 XM-StructureNotify
+                                                                 XM-ButtonPress XM-ButtonRelease)))))
+    (XMapWindow (xwem-dpy) xwin)
+    (XRaiseWindow (xwem-dpy) xwin)
+    xwin))
+
+(defun xwem-worklog-time-diff (a b)
+  "Return the difference between two times.
+This function requires the second argument B to be earlier in time
+than the first argument A."
+  (cond ((= (nth 0 a) (nth 0 b)) (list 0 (- (nth 1 a) (nth 1  b))))
+        ((> (nth 1 b) (nth 1 a)) (list (- (nth 0 a) (nth 0 b) 1)
+                                       (- (+ 65536 (nth 1 a)) (nth 1 b))))
+        (t (list (- (nth 0 a) (nth 0 b))
+                 (- (nth 1 a) (nth 1 b))))))
+
+(defun xwem-worklog-format-time (time &optional padlen)
+  "Return string."
+  (let (rawtime days hours minutes seconds lfm)
+    ;; XXX can't deal with car
+    (if (not (zerop (car time)))
+        (setq rawtime (+ (* 65536.0 (car time)) (cadr time)))
+      (setq rawtime (float (cadr time))))
+
+    (setq days (truncate (/ rawtime (* 60 60 24))))
+    (setq rawtime (- rawtime (* 60 60 24 days)))
+    (setq hours (truncate (/ rawtime (* 60 60))))
+    (setq rawtime (- rawtime (* 60 60 hours)))
+    (setq minutes (truncate (/ rawtime 60)))
+    (setq rawtime (- rawtime (* 60 minutes)))
+    (setq seconds (truncate rawtime))
+
+    (setq lfm
+          (cond ((not (zerop days)) (format "%dd %dh" days hours))
+                ((not (zerop hours)) (format "%dh %dm" hours minutes))
+                (t (format "%dm %ds" minutes seconds))))
+    (if padlen
+        (if (> padlen (length lfm))
+            (concat lfm (make-string (- padlen (length lfm)) ?\x20))
+          (substring lfm 0 padlen))
+      lfm)))
+
+(defun xwem-worklog-pause-update (&optional full)
+  "Redraw pause win."
+  (with-current-buffer (xwem-worklog-pause-pbuf xwem-worklog-pause-p)
+    (erase-buffer)
+
+    (insert "XWEM Worklog mode ")
+    (insert-face "PAUSE: " 'red)
+    (insert (xwem-worklog-format-time
+             (xwem-worklog-time-diff (current-time)
+                                     (xwem-worklog-pause-start-time xwem-worklog-pause-p))
+             20))
+    (insert "\n\n")
+
+    (if (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'pause)
+        (xwem-worklog-insert-current-task)
+      (xwem-worklog-insert-task-list))
+
+    (insert "\n")
+    (insert "Press any key to continue with current task.\n")
+    (if (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'list)
+        (insert (substitute-command-keys "Press ``\\<xwem-worklog-pause-map>\\[xwem-worklog-pause]'' to show pause buffer.\n"))
+
+      (insert "Bindings:\n")
+      (insert "Key             Binding\n")
+      (insert "---             -------\n")
+      (describe-bindings-internal xwem-worklog-pause-map))
+
+    (X-Dpy-send-excursion (xwem-dpy)
+      (when full
+        (XClearArea (xwem-dpy) (xwem-worklog-pause-pwin xwem-worklog-pause-p)
+                    0 0 xwem-worklog-pwin-width xwem-worklog-pwin-height nil))
+      (xwem-misc-textsp-show (xwem-worklog-pause-pwin xwem-worklog-pause-p)
+                             20 20       ; XXX
+                             (xwem-misc-buffer->textsp 'default))
+
+      (when full
+        ;; XXX 
+        (run-hooks 'xwem-worklog-pause-window-update-hook))
+    )))
+
+(defun xwem-worklog-last-time-string (task &optional padlen)
+  "Return time string of last time of TASK was runned."
+  (let ((ctime (or (cdr (car (xwem-worklog-task-times task))) (current-time))))
+    (if (caar (xwem-worklog-task-times xwem-worklog-current-task))
+        (xwem-worklog-format-time
+         (xwem-worklog-time-diff ctime
+                                 (caar (xwem-worklog-task-times xwem-worklog-current-task)))
+         padlen)
+
+      (if padlen
+          (concat "---" (make-string (- padlen 3) ?\x20)) ; XXX
+        "---"))))
+    
+(defun xwem-worklog-get-today-time (task)
+  "Return time TASK was runned today."
+  (if (cdr (car (xwem-worklog-task-times task)))
+      (or (xwem-worklog-task-today-time task) '(0 0))
+
+    ;; Task not paused
+    (if (caar (xwem-worklog-task-times task))
+         (xwem-worklog-calc-time
+          (xwem-worklog-time-diff (current-time) (caar (xwem-worklog-task-times task)))
+          (xwem-worklog-task-today-time task))
+      '(0 0))))
+  
+(defun xwem-worklog-today-time-string (task &optional padlen)
+  "Return time string for today time of TASK."
+  (if (cdr (car (xwem-worklog-task-times task)))
+      (if (xwem-worklog-task-today-time task)
+          (xwem-worklog-format-time (xwem-worklog-task-today-time task) padlen)
+
+        (if padlen
+            (concat "---" (make-string (- padlen 3) ?\x20)) ; XXX
+          "---"))
+
+    ;; Task not paused
+    (if (caar (xwem-worklog-task-times task))
+        (xwem-worklog-format-time
+         (xwem-worklog-calc-time
+          (xwem-worklog-time-diff (current-time) (caar (xwem-worklog-task-times task)))
+          (xwem-worklog-task-today-time task))
+         padlen)
+      
+      (if padlen
+          (concat "---" (make-string (- padlen 3) ?\x20)) ; XXX
+        "---"))))
+
+(defun xwem-worklog-total-time-string (task &optional padlen)
+  "Return time string for total time of TASK."
+  (if (cdr (car (xwem-worklog-task-times task)))
+      (if (xwem-worklog-task-total-time task)
+          (xwem-worklog-format-time (xwem-worklog-task-total-time task) padlen)
+
+        (if padlen
+            (concat "---" (make-string (- padlen 3) ?\x20)) ; XXX
+          "---"))
+
+    ;; Task not paused
+    (if (caar (xwem-worklog-task-times task))
+        (xwem-worklog-format-time
+         (xwem-worklog-calc-time
+          (xwem-worklog-time-diff (current-time) (caar (xwem-worklog-task-times task)))
+          (xwem-worklog-task-total-time task))
+         padlen)
+
+      (if padlen
+          (concat "---" (make-string (- padlen 3) ?\x20)) ; XXX
+        "---"))))
+  
+(defun xwem-worklog-insert-task-list ()
+  "Insert into pause buffer list of registered tasks and their values."
+  (let* ((noff 10)
+         (mlen (or (and xwem-worklog-task-list
+                        (+ (apply 'max (mapcar (lambda (el)
+                                                 (length (xwem-worklog-task-name el)))
+                                               xwem-worklog-task-list))
+                           noff))
+                   20))
+         (task-hdr "Task"))
+    (insert task-hdr)
+    (insert (make-string (- mlen (length task-hdr)) ?\x20))
+    (insert "Today Time    Total time\n")
+    (insert (make-string (length task-hdr) ?-))
+    (insert (make-string (- mlen (length task-hdr)) ?\x20))
+    (insert "----- ----    ----- ----\n")
+
+    (mapc (lambda (task)
+            (if (eq task xwem-worklog-current-task)
+                (insert-face (xwem-worklog-task-name task) 'bold)
+              (insert (xwem-worklog-task-name task)))
+
+            (move-to-column mlen t)
+
+            ;; Insert today time
+            (insert (xwem-worklog-today-time-string task 14))
+                         
+            ;; Insert total time
+            (insert (xwem-worklog-total-time-string task 10))
+
+            (insert "\n"))
+          xwem-worklog-task-list)
+
+    (insert "\n")))
+
+(defun xwem-worklog-insert-current-task ()
+  "Insert state of current task into pause buffer."
+  (if (not xwem-worklog-current-task)
+      (insert "  No active task.\n")
+
+    ;; Got active task
+    (insert "  Current task: ")
+    (insert-face (xwem-worklog-task-name xwem-worklog-current-task) 'bold)
+    (insert "\n")
+
+    (unless (cdr (car (xwem-worklog-task-times xwem-worklog-current-task)))
+      ;; Task not paused
+      (insert (format "  Task time:    %s\n"
+                      (xwem-worklog-last-time-string xwem-worklog-current-task 20)))
+      (insert (format "  Today time:   %s\n"
+                      (xwem-worklog-today-time-string xwem-worklog-current-task 20)))
+      (insert (format "  Total time:   %s\n"
+                      (xwem-worklog-total-time-string xwem-worklog-current-task 20)))
+      )))
+
+(defun xwem-worklog-time-> (a-time b-time)
+  "Return non-nil if A-TIME is >= than B-TIME."
+  (or (> (nth 0 a-time) (nth 0 b-time))
+      (and (= (nth 0 a-time) (nth 0 b-time))
+           (>= (nth 1 a-time) (nth 1 b-time)))))
+
+(defun xwem-worklog-time-< (a-time b-time)
+  "Return non-nil if A-TIME is <= than B-TIME."
+  (or (< (nth 0 a-time) (nth 0 b-time))
+      (and (= (nth 0 a-time) (nth 0 b-time))
+           (<= (nth 1 a-time) (nth 1 b-time)))))
+
+(defun xwem-worklog-add-entry (string &optional time)
+  "Add entry to `xwem-worklog-file'."
+  (require 'worklog)
+
+  (let ((buf (find-file-noselect (concat xwem-dir "/" xwem-worklog-file))))
+    (save-excursion
+      (unwind-protect
+          (with-current-buffer buf
+            ;; Avoid using `end-of-buffer'
+            (goto-char (point-max))
+            (unless (bolp)
+              (newline))
+            (insert (worklog-make-date-time) " ")
+
+            (insert (concat string "\n"))
+            (save-buffer))
+        (kill-buffer buf)))))
+
+(defun xwem-worklog-show ()
+  "Show xwem worklog file."
+  (interactive)
+  
+  (require 'worklog)
+  (find-file (concat xwem-dir "/" xwem-worklog-file))
+  (worklog-mode))
+
+(defun xwem-worklog-summarize ()
+  "Just like `worklog-summarize-tasks', but uses xwem worklog file."
+  (interactive)
+  (require 'worklog)
+
+  (let ((worklog-file (concat xwem-dir "/" xwem-worklog-file)))
+    (worklog-summarize-tasks)))
+
+(defun xwem-worklog-write-file (&optional file)
+  "Write FILE in `worklog.el' format.
+If FILE is not given, `xwem-worklog-file' from `xwem-dir' will be used."
+  (require 'worklog)
+
+  (let ((buf (find-file-noselect (or file (concat xwem-dir "/" xwem-worklog-file)))))
+    (unwind-protect
+        (with-current-buffer buf
+          (goto-char (point-max))       ; append to the end of buffer
+
+          ;; TODO:
+          ;;   - write me
+          (save-buffer))
+      (kill-buffer buf))))
+
+(defun xwem-worklog-read-file (&optional time)
+  "Read FILE in `worklog.el' format.
+If FILE is not given, `xwem-worklog-file' from `xwem-dir' will be used."
+  (require 'worklog)
+
+  (let ((buf (find-file-noselect (concat xwem-dir "/" xwem-worklog-file))))
+    (unwind-protect
+        (with-current-buffer buf
+          (goto-char (point-min))
+
+          ;; TODO:
+          ;;   - write me
+          )
+      (kill-buffer buf))))
+
+;; Worklog notification facilities
+(defvar xwem-worklog-notifier-timer nil
+  "itimer used to notify you.
+Internal variable, DO NOT MODIFY.")
+
+(defvar xwem-worklog-auto-timer nil
+  "itimer used to autologout or to stop login notifier.
+Internal variable, DO NOT MODIFY.")
+
+(defun xwem-worklog-notifier-stop ()
+  "Login notifier stopper."
+  (when (itimerp xwem-worklog-auto-timer)
+    (delete-itimer xwem-worklog-auto-timer)
+    (setq xwem-worklog-auto-timer nil))
+
+  (when (itimerp xwem-worklog-notifier-timer)
+    (delete-itimer xwem-worklog-notifier-timer)
+    (setq xwem-worklog-notifier-timer nil)))
+  
+(define-xwem-command xwem-worklog-login ()
+  "Stop login notifier, start logout notifier."
+  (xwem-interactive)
+
+  (xwem-worklog-notifier-stop)
+    
+  ;; Install logout notifier
+  (setq xwem-worklog-notifier-timer
+        (xwem-worklog-today-start-at xwem-worklog-day-ends 0
+                                     'xwem-worklog-logout-notifier
+                                     (* 60 xwem-worklog-logout-notify-period)))
+
+  ;; Recalculate today time for every task
+  (mapc (lambda (task)
+          (xwem-worklog-task-update-today-time task))
+        xwem-worklog-task-list)
+          
+  (xwem-worklog-begin-task "login"))
+
+(define-xwem-command xwem-worklog-logout ()
+  "Stop logout notifier, start login notifier."
+  (xwem-interactive)
+
+  (xwem-worklog-notifier-stop)
+
+  ;; Install login notifier
+  (setq xwem-worklog-notifier-timer
+        (xwem-worklog-tomorow-start-at xwem-worklog-day-start 0
+                                       'xwem-worklog-login-notifier
+                                       (* 60 xwem-worklog-login-notify-period)))
+
+  (xwem-worklog-begin-task "logout"))
+    
+(defun xwem-worklog-login-notifier ()
+  "Notify that you must login."
+  (unless (itimerp xwem-worklog-auto-timer)
+    ;; Start login notify stopper
+    (setq xwem-worklog-auto-timer
+          (start-itimer "xwem-worklog-login-notify-stopper"
+                        'xwem-worklog-notifier-stop
+                        (* 60 xwem-worklog-login-stop-period))))
+
+  (xwem-message 'asis (concat (xwem-str-with-faces "XWEM WORKLOG: " '(red bold))
+                              "Workday started, but you're not logged in."))
+  (xwem-play-sound 'alarm))
+
+(defun xwem-worklog-logout-notifier ()
+  "Notify that you need to logout."
+  (unless (itimerp xwem-worklog-auto-timer)
+    ;; Start autologouter
+    (setq xwem-worklog-auto-timer
+          (start-itimer "xwem-worklog-autologout"
+                        'xwem-worklog-logout
+                        (* 60 xwem-worklog-logout-auto-period))))
+
+  (xwem-message 'asis (concat (xwem-str-with-faces "XWEM WORKLOG: " '(red bold))
+                              "Workday ended, but you're still working."))
+  (xwem-play-sound 'alarm))
+
+(defun xwem-worklog-doat (time func &optional restart)
+  "Run function FUNC at a given TIME.
+Return itimer handler."
+  (let ((ctime (current-time))
+        rtime)
+    (when (xwem-worklog-time-> time ctime)
+      (setq rtime (xwem-worklog-time-diff time ctime))
+      (setq rtime (+ (* (float (car rtime)) 65536)
+                     (cadr rtime)))
+
+      (start-itimer "doat" func rtime restart))
+    ))
+
+(defun xwem-worklog-tomorow-start-at (hour min fun &optional restart)
+  "Run function FUN tomorow at HOUR and MIN."
+  (let ((ctime (decode-time (current-time))))
+    (setcar ctime 0)
+    (setcar (cdr ctime) min)
+    (setcar (cddr ctime) hour)
+    (setcar (cdddr ctime) (1+ (nth 3 ctime)))
+
+    (xwem-worklog-doat (apply 'encode-time ctime) fun restart)))
+
+(defun xwem-worklog-today-start-at (hour min fun &optional restart)
+  "Run function FUN today at HOUR and MIN."
+  (let ((ctime (decode-time (current-time))))
+    (setcar ctime 0)
+    (setcar (cdr ctime) min)
+    (setcar (cddr ctime) hour)
+
+    (xwem-worklog-doat (apply 'encode-time ctime) fun restart)))
+
+;; Diagram drawing
+(defun xwem-worklog-show-color-breaks ()
+  "Show color breaks."
+  (when (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'list)
+    ;; Do it only in listing
+    (let* ((tmp-face (make-face 'tmp-face))
+           (face-height (font-height (face-font 'default)))
+           (w 10)
+           (y (- (* 5 face-height) (/ w 2)))
+           (x 6))
+      (mapc (lambda (task)
+              (let ((d (xwem-worklog-lookup-description (xwem-worklog-task-name task))))
+                (xwem-face-set-foreground tmp-face (or (and d (aref d 2)) "black"))
+                (xwem-diag-draw-rect (xwem-worklog-pause-pwin xwem-worklog-pause-p)
+                                     (xwem-face-get-gc 'default)
+                                     (cons x y) (cons (+ x w) y)
+                                     (cons (+ x w) (+ y w)) (cons x (+ y w)) (xwem-face-get-gc tmp-face))
+                (setq y (+ y face-height))))
+            xwem-worklog-task-list)
+      )))
+
+(defun xwem-worklog-draw-today-diagram ()
+  ""
+  (when (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'list)
+    ;; Do it only in listing
+    (let* ((buf-lines (with-current-buffer (xwem-worklog-pause-pbuf xwem-worklog-pause-p) (count-lines (point-min) (point-max))))
+           (face-height (font-height (face-font 'default)))
+           (t-off 2)
+           (y-off (* face-height (+ t-off buf-lines)))
+           (x-off 50)
+           (sec-hei 20)
+           (wwid (- xwem-worklog-pwin-width (* x-off 2)))
+           (whei (- xwem-worklog-pwin-height y-off (* face-height 2 t-off) sec-hei))
+           (today-seconds (* 60.0 60 (- xwem-worklog-day-ends xwem-worklog-day-start)))
+           spec spec1)
+      (setq spec1 (mapcar (lambda (task)
+                            (let* ((d (xwem-worklog-lookup-description (xwem-worklog-task-name task)))
+                                   (tt (xwem-worklog-get-today-time task))
+                                   (ts (+ (* (car tt) 65536.0) (cadr tt)))
+                                   (per (truncate (* 100.0 (/ ts today-seconds))))
+                                   (rv (and d (> per 0)
+                                            (vector per t (aref d 2) 0 0
+                                                    (if (eq task xwem-worklog-current-task) (- (/ sec-hei 2)) 0)))))
+                              rv))
+                          xwem-worklog-task-list))
+
+      ;; Remove invalid fields
+      (while spec1
+        (when (car spec1)
+          (setq spec (cons (car spec1) spec)))
+        (setq spec1 (cdr spec1)))
+
+      ;; XXX
+      (when spec
+        (xwem-diag-draw-percentage '3d spec (xwem-worklog-pause-pwin xwem-worklog-pause-p)
+                                   (xwem-face-get-gc 'default)
+                                   x-off y-off wwid whei sec-hei))
+      spec)))
+    
+
+(run-hooks 'xwem-worklog-load-hook)
+
+(provide 'xwem-worklog)
+
+;;; xwem-worklog.el ends here

lisp/addons/xwem-xfig.el

+;;; xwem-xfig.el --- xfig stuff for XWEM.
+
+;; Copyright (C) 2004 by Free Software Foundation, Inc.
+
+;; Author: Zajcev Evgeny <zevlg@yandex.ru>
+;; Created: Sat Mar  6 13:32:11 MSK 2004
+;; Keywords: xwem
+;; X-CVS: $Id$
+
+;; This file is part of XWEM.
+
+;; XWEM is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XWEM is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
+;; License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF
+
+;;; Commentary:
+
+;; Some xfig functionality.
+
+;;; Code:
+
+
+(defconst xwem-xfig-orientations '("Landscape" "Portrait"))
+(defconst xwem-xfig-justifications '("Center" "Flush Left"))
+(defconst xwem-xfig-units '("Metric" "Inches"))
+(defconst xwem-xfig-papersizes '("Letter" "Legal" "Ledger" "Tabloid" "A" "B" "C" "D" "E" "A4" "A3" "A2" "A1" "A0" "B5"))
+(defconst xwem-xfig-multiple-pages '("Single" "Multiple"))
+
+(defconst xwem-xfig-class-types
+  '((0 . color)
+    (1 . ellipse)
+    (2 . poly)
+    (3 . spline)
+    (4 . text)
+    (5 . arc)
+    (6 . compound)))
+
+(defconst xwem-xfig-colors
+  '((-1 . default)
+    (0 . "black")
+    (1 . "blue")
+    (2 . "green")
+    (3 . "cyan")
+    (4 . "red")
+    (5 . "magenta")
+    (6 . "yellow")
+    (7 . "white")
+
+    ;; 4 blue shades
+    (8 . "#000033")
+    (9 . "#000066")
+    (10 . "#000099")
+    (11 . "#0000cc")
+
+    ;; 3 green shades
+    (12 . "#004400")
+    (13 . "#008800")
+    (14 . "#00cc00")
+
+    ;; 3 cyan shades
+    (15 . "#004444")
+    (16 . "#008888")
+    (17 . "#00cccc")
+
+    ;; 3 red shades
+    (18 . "#440000")
+    (19 . "#880000")
+    (20 . "#cc0000")
+    
+    ;; 3 magenta shades
+    (21 . "#440044")
+    (22 . "#880088")
+    (23 . "#cc00cc")
+
+    ;; 3 brown shades
+    (24 . "#ff4444")
+    (25 . "#ff8888")
+    (26 . "#ffcccc")
+
+    ;; 4 ping shades
+    (27 . "#ff3344")
+    (28 . "#ff6688")
+    (29 . "#ff99cc")
+    (30 . "#ffccff")
+
+    ;; gold
+    (31 . "#ffd700")))
+
+(defconst xwem-xfig-line-styles
+  '((-1 . default)
+    (0 . solid)
+    (1 . dashed)
+    (2 . dotted)
+    (3 . dash-dotted)
+    (4 . dash-double-dotted)
+    (5 . dash-triple-dotted)))
+
+(defconst xwem-xfig-join-styles
+  '((0 . X-JoinMiter)
+    (1 . X-JoinRound)
+    (2 . X-JoinBevel)))
+
+(defconst xwem-xfig-cap-styles
+  '((0 . X-CapButt)
+    (1 . X-CapRound)
+    (2 . X-CapProjecting)))
+
+(defconst xwem-xfig-arrow-types
+  '((0 . stick)
+    (1 . closed-triangle)
+    (2 . closed-indented-butt)
+    (3 . closed-pointed-butt)))
+
+(defconst xwem-xfig-arrow-styles
+  '((0 . hollow)                        ; filled with white
+    (1 . pen)))                         ; filled with pen
+
+(defstruct xwem-xfig-arrow
+  type                                  ; defined in `xwem-xfig-arrow-types'
+  style                                 ; defined in `xwem-xfig-arrow-styles'
+  thickness                             ; float
+  width                                 ; float
+  height)                               ; float
+
+(defstruct xwem-xfig-picture
+  flipped
+  filename)
+
+(defconst xwem-xfig-poly-subtypes
+  '((1 . polyline)
+    (2 . box)
+    (3 . polygon)
+    (4 . arc-box)
+    (5 . picture)))
+
+(defstruct xwem-xfig-poly
+  (object 2)
+  (sub-type 'polyline)
+  picture                               ; only for sub-type == picture
+  line-style                            ; defined in `xwem-xfig-line-styles'
+  thickness
+  pen-color
+  fill-color
+  depth
+  pen-style
+  area-fill
+  style-val                             ; float (1/80 inch)
+  join-style                            ; defined in `xwem-xfig-join-styles'
+  cap-style                             ; defined in `xwem-xfig-cap-styles'
+  radius                                ; radius of arc-boxes (1/80 inch)
+  forward-arrow                         ; nil or xwem-xfig-arrow
+  backward-arrow                        ; nil or xwem-xfig-arrow
+  points)
+
+(defconst xwem-xfig-spline-subtypes
+  '((0 . open-approximated)
+    (1 . closed-approximated)
+    (2 . open-interpolated)
+    (3 . closed-interpolated)
+    (4 . open-x-spline)
+    (5 . closed-x-spline)))
+
+(defstruct xwem-xfig-spline
+  (object 3)
+  (sub-type 'open-approximated)
+  line-style
+  thickness
+  pen-color
+  fill-color
+  depth
+  pen-style
+  area-fill
+  style-val
+  cap-style
+  forward-arrow
+  backward-arrow
+  points)
+
+(defstruct xwem-xfig-text
+  (object 4)
+  (sub-type 'center)
+  color
+  depth
+  pen-style
+  font
+  font-size
+  angle
+  font-flags
+  height
+  length
+  x y
+  string)
+
+(defconst xwem-xfig-arc-subtypes
+  '((1 . open)                          ; open ended arc
+    (2 . closed)))                      ; pie-wedge closed
+
+(defconst xwem-xfig-arc-directions
+  '((0 . clockwise)
+    (1 . counter-clockwise)))
+
+(defstruct xwem-xfig-arc
+  (object 5)
+  (sub-type 'open)
+  line-style
+  line-thickness
+  pen-color
+  fill-color
+  depth
+  pen-style
+  area-fill
+  style-val
+  cap-style
+  direction
+  forward-arrow
+  backward-arrow
+  center-x center-y
+  x1 y1
+  x2 y2
+  x3 y3)
+
+(defstruct xwem-xfig-comound
+  (object 6)
+  x y x1 y1
+  xfig-objects)
+
+;; Define xfig object
+(defstruct xwem-xfig
+  data                                  ; data lives here
+  (colors xwem-xfig-colors)             ; colors definitions
+  objects)
+  
+
+(defun xwem-xfig-add-color (xfig color)
+  "In XFIG's colors add COLOR."
+  (push color (xwem-xfig-colors xfig))
+  )
+
+;; Drawing routines
+(defun xwem-xfig-draw-text (xfig text)
+  "In XFIG's window draw xfig TEXT."
+  )
+
+(defun xwem-xfig-draw-spline (xfig spline)
+  "In XFIG's window draw SPLINE."
+  )
+
+(defun xwem-xfig-draw-poly (xfig poly)
+  "In XFIG's window draw POLY."
+  )
+
+(defun xwem-xfig-draw-ellipse (xfig ellipse)
+  "In XFIG's window draw ELLIPSE."
+  )
+
+(defun xwem-xfig-draw-arc (xfig arc)
+  "In XFIG's window draw ARC."
+  )
+
+(defun xwem-xfig-draw-compound (xfig compound)
+  "In XFIG's window draw COMPOUND."
+  )
+
+;; Parsing xfig file
+(defun xwem-xfig-parse-arc (line)
+  )
+
+(defun xwem-xfig-parse-ellipse (line)
+  )
+
+(defun xwem-xfig-parse-poly (line)
+  )
+
+(defun xwem-xfig-parse-spline (line)
+  )
+
+(defun xwem-xfig-parse-text (line)
+  )
+
+(defun xwem-xfig-parse-compound (line)
+  )
+
+(defun xwem-xfig-parse-color (line)
+  )
+
+(defun xwem-xfig-parse (xfig line)
+  (let ((ob (string-to-int line)))
+    (push (cond ((= ob 0) (xwem-xfig-parse-color line))
+                ((= ob 1) (xwem-xfig-parse-ellipse line))
+                ((= ob 2) (xwem-xfig-parse-poly line))
+                ((= ob 3) (xwem-xfig-parse-spline line))
+                ((= ob 4) (xwem-xfig-parse-text line))
+                ((= ob 5) (xwem-xfig-parse-arc line))
+                ((= ob 6) (xwem-xfig-parse-compound line))
+                (t (error "Invalid line format" line)))
+          (xwem-xfig-objects xfig))))
+
+
+(provide 'xwem-xfig)