;;; journal.el --- some simple machinery for keeping a text-based research journal in emacs.

;; Copyright (C) 2008 James Wright

;; Author: James Wright <james@chumsley.org>
;; Created: 22 Jul 2008

;; This file is not yet part of GNU Emacs.

;; journal.el 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.

;; journal.el 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; I keep a research journal that is basically a bunch of little todo
;; items plus thoughts that have occured to me in the course of the
;; week.  This file contains code to help manage that.
;;
;; Todo items are lines that begin with [ ].  Once a todo is done, the
;; space is replaced with an X like so: [X].  A journal file is a text
;; file that contains the journal for a week.  Unfinished todo's are
;; automatically copied from one week to the next.
;;
;; To get started, type `M-x journal'.  A new journal file is created
;; and populated with some standard (customizable) headings, plus
;; carried-over todo items if necessary.  If the file already exists,
;; a new heading will be created for today.

;;; Code:

;;;; ============================================ Parameters ============================================

(defcustom journal-directory "~/journal"
  "Directory where journal files should be created."
  :type 'directory
  :group 'journal)

(defcustom journal-filename-template "%Y%m%d.text"
  "Date/time format string that is used to generate the filenames for the weekly file.
See `format-time-string' for replacement codes."
  :type 'string
  :group 'journal)

(defcustom journal-daily-heading-template "%A (%b %1e)"
  "Date/time format string that is used to generate the day-headings in the weekly file.
See `format-time-string' for replacement codes."
  :type 'string
  :group 'journal)

(defcustom journal-weekly-heading-template "Journal for week of %B %1e/%Y"
  "Date/time format string that is used to generate the week headings.
See `format-time-string' for replacement codes."
  :type 'string
  :group 'journal)

(defcustom journal-todo-max-carryover-weeks 4
  "Maximum number of weeks to search into the past for old TODO items to carry over."
  :type 'number
  :group 'journal)

(defcustom journal-base-day 1
  "Day to begin the week on.  Ie, this is the day that we generate a new weekly file."
  :type '(choice
          (const :tag "Sunday" 0)
          (const :tag "Monday" 1)
          (const :tag "Tuesday" 2)
          (const :tag "Wednesday" 3)
          (const :tag "Thursday" 4)
          (const :tag "Friday" 5)
          (const :tag "Saturday" 6))
  :group 'journal)

(defcustom journal-carryover-headings t
  "Whether to include 3rd-level headings when carrying over old todos to a new weekly file"
  :type 'boolean
  :group 'journal)

;;;; ============================================= Commands =============================================

(defvar journal-date-history nil)

;;;###autoload
(defun journal (&optional time)
  "TODO docstring" ;TODO
  (interactive (when current-prefix-arg
                 (list (parse-date (read-from-minibuffer "Journal date: " (format-time-string "%Y-%m-%d") nil nil 'journal-date-history)))))
  (setq time (or time (current-time)))
  (let ((monday (journal-monday time)))
    (find-file (journal-filename monday))

    ;; Fill in the template if necessary
    (unless (or (file-readable-p (journal-filename monday))
                (> (- (point-max) (point-min)) 0))
      (insert (journal-week-heading monday)
              "\nTODO\n----\n"
              (journal-unfinished-todos (journal-previous-file monday))))
    
    ;; Add a section heading for today if none already exists
    (unless (save-excursion
              (goto-char (point-min))
              (re-search-forward (regexp-quote (journal-today-heading time)) nil t))
      (goto-char (point-max))
      (unless (save-excursion
                (forward-line -1)
                (goto-char (point-at-bol))
                (looking-at "\n"))
        (insert "\n"))
      (insert (journal-today-heading time)))))

(defun journal-summarize-todos (&optional checkmark-filter)
  "TODO docstring" ;TODO
  (interactive (when current-prefix-arg
                 (list (read-from-minibuffer "Checkmark filter: " " X-"))))
  (setq checkmark-filter (or checkmark-filter " X-"))
  (let ((summ (journal-todos checkmark-filter)))
    (switch-to-buffer "*Journal summary*")
    (delete-region (point-min) (point-max))
    (insert summ)
    (journal-move-todos-to-top "-")
    (journal-move-todos-to-top "X")))

(defun journal-unfinished-todos (prev-file)
  (if prev-file
    (with-temp-buffer
      (insert-file-contents prev-file)
      (journal-todos " " journal-carryover-headings))
    ""))

(defun journal-move-todos-to-top (&optional type-re)
  "Move all TODOs with type matching TYPE-RE to the top of the buffer (defaults to completed)"
  (setq type-re (or type-re "X"))
  (let ((next-insertion (make-marker))
        (re (format "[ \t]*\\[%s\\]" type-re)))
    (set-marker next-insertion (point-min))
    (goto-char (point-min))
    (while (and next-insertion
                (zerop (forward-line)))
      (when (looking-at re)
        (let* ((s (make-marker))
               (e (make-marker)))
          (set-marker s (point-at-bol))
          (journal-end-of-todo)
          (set-marker e (point))
          
          (goto-char next-insertion)
          (insert (buffer-substring s e))
          (set-marker next-insertion (point))

          (goto-char e)
          (delete-region s e)
          (goto-char (point-at-bol))
          (forward-line -1))))))

(defun journal-todos (&optional allowable-checkmarks include-headings)
  "Returns all the todo items in the current buffer.
  ALLOWABLE-CHECKMARKS is a string indicating what characters may
  be within the brackets (sometimes we want completed todos and
  sometimes we don't). INCLUDE-HEADINGS indicates whether
  3rd-level headings should be included (at the moment only
  single-line headings are supported)"
  (setq allowable-checkmarks (or allowable-checkmarks " "))
  (let ((out "")
        (saw-todo nil)
        (saw-blank nil)
        (regexp (format "\\([ \t]*\\)\\(\\[[%s]\\]\\) " allowable-checkmarks)))
    (save-excursion
      (goto-char (point-min))
      (while (zerop (forward-line))
        (cond
          ((looking-at regexp)
           (setq saw-todo t)
           (setq saw-blank nil)
           (setq out (concat out (buffer-substring (point-at-bol) (point-at-eol)) "\n")))
          ((and saw-todo saw-blank (looking-at "\n"))
           (setq saw-todo nil))
          ((and saw-todo (looking-at "\n"))
           (setq out (concat out "\n"))
           (setq saw-blank t))
          ((and saw-todo (looking-at "[ \t]+[^ \t\n]"))
           (setq out (concat out (buffer-substring (point-at-bol) (point-at-eol)) "\n"))
           (setq saw-blank nil))
          ((and include-headings (looking-at "=== .* ==="))
           (setq out (concat out (buffer-substring (point-at-bol) (point-at-eol)) "\n"))
           (setq saw-todo nil)
           (setq saw-blank nil))
          (t
           (setq saw-todo nil))))
      out)))

(defun journal-end-of-todo ()
  "Advance to the line just after this todo.  Assumes that current line is a todo line."
  (let ((saw-todo t)
        (saw-blank nil))
    (goto-char (point-at-bol))
    (while (and saw-todo
                (zerop (forward-line)))
      (cond
        ((and saw-blank (looking-at "\n"))
         (setq saw-todo nil))
        ((looking-at "[ \t]*\n")
         (setq saw-blank t))
        ((looking-at "[ \t]+[^ \t\n]")
         (setq saw-blank nil))
        (t
         (setq saw-todo nil))))))
    

(defun journal-week-heading (monday)
  (let* ((heading-str (journal-format-time journal-weekly-heading-template monday))
         (len (length heading-str)))
    (setq heading-str (concat "\n" heading-str "\n"))
    (while (> len 0)
      (setq heading-str (concat "=" heading-str "="))
      (setq len (- len 1)))
    (setq heading-str (concat heading-str "\n"))
    heading-str))
  
(defun journal-today-heading (time)
  (let* ((heading-str (journal-format-time journal-daily-heading-template time))
         (len (length heading-str)))
    (when (string-match "\n\\([^\n]+$\\)" heading-str)
      (setq len (length (match-string 1 heading-str))))
    (setq heading-str (concat heading-str "\n"))
    (while (> len 0)
      (setq heading-str (concat heading-str "-"))
      (setq len (- len 1)))
    (setq heading-str (concat heading-str "\n"))
    heading-str))

(defun journal-previous-file (monday)
  "Find the first journal file before MONDAY.  Only searches up
  to JOURNAL-TODO-MAX-CARRYOVER-WEEKS into the past."
  (let* ((week (seconds-to-time (* -1 7 24 60 60)))
         (prev-monday (journal-monday (time-add monday week)))
         (fname nil)
         (n journal-todo-max-carryover-weeks))
    (while (and (> n 0)
                (null fname))
      (setq fname (journal-filename prev-monday))
      (unless (file-readable-p fname)
        (setq fname nil)
        (setq n (- n 1))
        (setq prev-monday (time-add prev-monday week))))
    fname))

(defun journal-filename (monday-time)
  "Returns a canonical absolute filename for a file named based on MONDAY-TIME in the journal directory."
  (expand-file-name (journal-format-time journal-filename-template monday-time)
                    journal-directory))

(defun journal-monday (&optional time)
  "Returns a time representing the first monday that happens on or before TIME."
  (setq time (or time (current-time)))
  (let* ((dow (nth 6 (decode-time time)))
         (monday (time-add time
                           (seconds-to-time (* -1 60 60 24 (mod (- dow journal-base-day) 7))))))
    monday))

(defun parse-date (date-str)
  (let ((raw (parse-time-string date-str)))
    (unless (car (last raw))
      (setcar (last raw) (current-time-zone)))
    (apply 'encode-time (mapcar (lambda (x) (or x 0)) raw))))

;; HACK Yes I really am this obsessive
(defun journal-format-time (str &optional time)
  "Just like `format-time-string', except that it respects '%1e' as requesting no padding."
  (setq time (or time (current-time)))
  (let ((out (format-time-string str time)))
    (if (and (null (string-match "  " str))
             (string-match "%1e" str)
             (string-match "  " out))
      (concat (substring out 0 (match-beginning 0)) " " (substring out (match-end 0)))
      out)))

(provide 'journal)
;;; journal.el ends here