howm-date.el

   1 ;;; howm-date.el --- Wiki-like note-taking tool
   2 ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2016, 2017
   3 ;;;   HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
   4 ;;; $Id: howm-date.el,v 1.35 2011-12-31 15:07:29 hira Exp $
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 1, or (at your option)
   9 ;;; any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; The GNU General Public License is available by anonymouse ftp from
  17 ;;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
  18 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
  19 ;;; USA.
  20 ;;--------------------------------------------------------------------
  21
  22 (provide 'howm-date)
  23 (require 'howm)
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;; insert & action-lock
  27
  28 (defvar howm-insert-date-pass-through nil)
  29 (defvar howm-action-lock-date-future nil)
  30
  31 (defun howm-insert-date ()
  32   (interactive)
  33   (let ((date (format-time-string howm-date-format)))
  34     (insert (format howm-insert-date-format date))
  35     (howm-action-lock-date date t howm-insert-date-future)))
  36
  37 (defun howm-insert-dtime ()
  38   (interactive)
  39   (insert (format-time-string howm-dtime-format)))
  40
  41 ;; Sorry for ugly behavior around "new" to keep backward compatibility.
  42 (defun howm-action-lock-date (date &optional new future-p)
  43   (let* ((pass-through (and new howm-insert-date-pass-through))
  44          (prompt (howm-action-lock-date-prompt date new pass-through))
  45          (immediate-chars (if pass-through "" "."))
  46          (c (howm-read-string prompt immediate-chars "+-~0123456789"
  47                               pass-through pass-through)))
  48     (cond
  49      ((null c) nil) ;; pass through
  50      ((string= c "")
  51       (if new
  52           t
  53         (howm-action-lock-date-search date)))
  54      ((string-match "^[-+][0-9]+$" c)
  55       (howm-action-lock-date-shift (string-to-number c) date))
  56      ((string-match "^[0-9]+$" c)
  57       (howm-action-lock-date-set c date
  58                                  (or future-p howm-action-lock-date-future)))
  59      ((string-match "^~\\([0-9]+\\)$" c)
  60       (howm-action-lock-date-repeat (match-string-no-properties 1 c) date))
  61      ((string-match "^[.]$" c)
  62       (howm-datestr-replace (howm-time-to-datestr)))
  63      ((and (string-match "^[-+~]$" c) pass-through)
  64       (insert c))
  65      (t (error (format "Can't understand %s." c))))))
  66
  67 (defun howm-action-lock-date-prompt (date new pass-through)
  68   (let* ((dow (howm-datestr-day-of-week date))
  69          (common-help "+num(shift), yymmdd(set), ~yymmdd(repeat)")
  70          (today-help ", .(today)")
  71          (help (cond ((and new pass-through)
  72                       common-help)
  73                      ((and new (not pass-through))
  74                       (concat "RET(ok), " common-help today-help))
  75                      ((not new)
  76                       (concat "RET(list), " common-help today-help))
  77                      (t
  78                       (error "Can't happen.")))))
  79     (format "[%s] %s: " dow help)))
  80
  81 (defvar howm-date-current nil)
  82 (make-variable-buffer-local 'howm-date-current)
  83
  84 (defun howm-action-lock-date-search (date)
  85   (howm-set-command 'howm-action-lock-date-search)
  86   (prog1
  87       (howm-search date t)
  88     (howm-action-lock-forward-escape)
  89     (setq howm-date-current date)))
  90
  91 (defun howm-search-today ()
  92   (interactive)
  93   (howm-search-past 0))
  94
  95 (defun howm-search-past (&optional days-before)
  96   (interactive "P")
  97   (let* ((n (or days-before 0))
  98          (today (format-time-string howm-date-format))
  99          (target (howm-datestr-shift today 0 0 (- n))))
 100     (howm-action-lock-date-search target)))
 101
 102 (defun howm-action-lock-date-shift (n date)
 103   (howm-datestr-replace (howm-datestr-shift date 0 0 n)))
 104
 105 (defun howm-action-lock-date-set (val date &optional future-p)
 106   (howm-datestr-replace (howm-datestr-expand val date future-p)))
 107
 108 (defvar howm-action-lock-date-repeat-max 200)
 109 (defun howm-action-lock-date-repeat (until date)
 110   (let ((every (read-from-minibuffer "Every? [RET(all), num(days), w(week), m(month), y(year)] ")))
 111     (let ((max-d (howm-datestr-expand until date t))
 112           (offset-y (if (string= every "y") 1 0))
 113           (offset-m (if (string= every "m") 1 0))
 114           (offset-d (or (cdr (assoc every '(("y" . 0) ("m" . 0) ("w" . 7))))
 115                         (max (string-to-number every) 1))))
 116       (let ((d date)
 117             (i 0)
 118             (check t))
 119         (catch 'too-many
 120           (while (progn
 121                    (setq d (howm-datestr-shift d offset-y offset-m offset-d))
 122                    (howm-datestr<= d max-d))
 123             (when (and check (>= i howm-action-lock-date-repeat-max))
 124               (if (y-or-n-p (format "More than %d lines. Continue? " i))
 125                   (setq check nil)
 126                 (throw 'too-many nil)))
 127             (howm-duplicate-line)
 128             (howm-datestr-replace d)
 129             (setq i (+ i 1))))))))
 130
 131 (defun howm-make-datestr (y m d)
 132   (let ((ti (encode-time 0 0 0 d m y)))
 133     (format-time-string howm-date-format ti)))
 134
 135 (defun howm-datestr-parse (date)
 136   (string-match howm-date-regexp date)
 137   (mapcar (lambda (pos)
 138             (string-to-number (match-string-no-properties pos date)))
 139           (list howm-date-regexp-year-pos
 140                 howm-date-regexp-month-pos
 141                 howm-date-regexp-day-pos)))
 142
 143 (defun howm-datestr-to-time (date)
 144   (let* ((ymd (howm-datestr-parse date))
 145          (y (car ymd))
 146          (m (cadr ymd))
 147          (d (cl-caddr ymd)))
 148     (encode-time 0 0 0 d m y)))
 149
 150 (defun howm-time-to-datestr (&optional time)
 151   (let ((x (decode-time time)))
 152     (howm-make-datestr (nth 5 x) (nth 4 x) (nth 3 x))))
 153
 154 (defun howm-datestr-day-of-week (date)
 155   (format-time-string "%a" (howm-datestr-to-time date)))
 156
 157 (defun howm-datestr-expand (date base &optional future-p)
 158   (let* ((raw (howm-datestr-expand-general date base nil))
 159          (future (howm-datestr-expand-general date base t))
 160          (ret
 161           (cond ((eq future-p 'closer)
 162                  (cl-labels ((to-f (d) (float-time (howm-datestr-to-time d)))
 163                              (delta (d1 d2) (abs (- (to-f d1) (to-f d2)))))
 164                    (if (< (delta raw base) (delta future base)) raw future)))
 165                 (future-p future)
 166                 (t raw))))
 167     (unless (string= raw ret)
 168       (message "Assume future date"))
 169     ret))
 170
 171 (defun howm-datestr-expand-general (date base &optional future-p)
 172   (let* ((base-ymd (howm-datestr-parse base))
 173          (nval (format "%8s" date))
 174          (given-ymd-str (mapcar (lambda (r)
 175                                   (substring nval (car r) (cadr r)))
 176                                 '((0 4) (4 6) (6 8))))
 177          (ys (car given-ymd-str))
 178          (ms (cadr given-ymd-str))
 179          (ds (cl-caddr given-ymd-str)))
 180      (when (string-match "^ +0+$" ys)
 181        (setq ys "2000"))
 182      (let* ((given-ymd (mapcar #'string-to-number (list ys ms ds)))
 183             (carry nil) ;; to force future date
 184             (dmy (cl-mapcar (lambda (ox nx)
 185                                     (when future-p
 186                                       (when (and carry (= nx 0))
 187                                         (setq ox (+ ox 1)))
 188                                       (setq carry
 189                                             (cond ((= nx 0) nil)
 190                                                   ((= nx ox) carry)
 191                                                   ((< nx ox) t)
 192                                                   (t nil))))
 193                                     (if (= nx 0) ox nx))
 194                                   (reverse base-ymd) (reverse given-ymd)))
 195          (d (car dmy))
 196          (m (cadr dmy))
 197          (y (cl-caddr dmy)))
 198        (howm-make-datestr (if (<= y 99) (+ y 2000) y) m d))))
 199
 200 (defun howm-datestr-shift (date y m d)
 201   (let* ((ymd (howm-datestr-parse date))
 202          (oy (car ymd))
 203          (om (cadr ymd))
 204          (od (cl-caddr ymd)))
 205     (howm-make-datestr (+ oy y) (+ om m) (+ od d))))
 206
 207 (defun howm-datestr<= (date1 date2)
 208   (or (string< date1 date2)
 209       (string= date1 date2)))
 210
 211 (defun howm-datestr-replace (date)
 212   (let ((p (point)))
 213     (while (not (looking-at howm-date-regexp))
 214       (backward-char))
 215     (replace-match date t t)
 216     (goto-char p)))
 217
 218 (defun howm-duplicate-line ()
 219   (let ((c (current-column))
 220         (s (buffer-substring (line-beginning-position) (line-end-position))))
 221     (end-of-line)
 222     (insert "\n" s)
 223     (move-to-column c)))
 224
 225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 226 ;; search for next/previous date
 227
 228 (defvar howm-date-forward-ymd-msg "Searching %s...")
 229 (defvar howm-date-forward-ymd-limit 35)
 230 (defun howm-date-forward-ymd (y m d)
 231   (when (not howm-date-current)
 232     (error "Not in date search."))
 233   (let* ((new-date (howm-datestr-shift howm-date-current y m d))
 234          (b (current-buffer))
 235          (step (if (> (+ y m d) 0) +1 -1))
 236          (c 0))
 237     (when (catch :found
 238             (while (progn
 239                    (when (howm-action-lock-date-search new-date)
 240                      (throw :found t))
 241                    (< c howm-date-forward-ymd-limit))
 242             (setq new-date (howm-datestr-shift new-date 0 0 step))
 243             (setq c (1+ c))
 244             (when howm-date-forward-ymd-msg
 245               (format howm-date-forward-ymd-msg new-date)))
 246           (error "Not found within %d days." howm-date-forward-ymd-limit))
 247       (when (not (eq (current-buffer) b))
 248         (with-current-buffer b
 249           (howm-view-kill-buffer)))
 250       (howm-view-summary-check t))))
 251
 252 (defmacro howm-date-defun-f/b (func y m d)
 253   `(defun ,func (&optional k)
 254      (interactive "P")
 255      (let ((n (or k 1)))
 256        (howm-date-forward-ymd ,y ,m ,d))))
 257
 258 (howm-date-defun-f/b howm-date-forward       0 0 n)
 259 (howm-date-defun-f/b howm-date-forward-month 0 n 0)
 260 (howm-date-defun-f/b howm-date-forward-year  n 0 0)
 261 (howm-date-defun-f/b howm-date-backward       0 0 (- n))
 262 (howm-date-defun-f/b howm-date-backward-month 0 (- n) 0)
 263 (howm-date-defun-f/b howm-date-backward-year  (- n) 0 0)
 264
 265 (let ((m howm-view-summary-mode-map))
 266   (define-key m "+" 'howm-date-forward)
 267   (define-key m "-" 'howm-date-backward)
 268   (define-key m ")" 'howm-date-forward)
 269   (define-key m "(" 'howm-date-backward)
 270   (define-key m "}" 'howm-date-forward-month)
 271   (define-key m "{" 'howm-date-backward-month)
 272   (define-key m "]" 'howm-date-forward-year)
 273   (define-key m "[" 'howm-date-backward-year)
 274   )
 275
 276 ;;; howm-date.el ends here