diff options
Diffstat (limited to 'elpa/org-9.5.2/org-habit.el')
-rw-r--r-- | elpa/org-9.5.2/org-habit.el | 476 |
1 files changed, 0 insertions, 476 deletions
diff --git a/elpa/org-9.5.2/org-habit.el b/elpa/org-9.5.2/org-habit.el deleted file mode 100644 index 3ce8068..0000000 --- a/elpa/org-9.5.2/org-habit.el +++ /dev/null @@ -1,476 +0,0 @@ -;;; org-habit.el --- The habit tracking code for Org -*- lexical-binding: t; -*- - -;; Copyright (C) 2009-2021 Free Software Foundation, Inc. - -;; Author: John Wiegley <johnw at gnu dot org> -;; Keywords: outlines, hypermedia, calendar, wp -;; Homepage: https://orgmode.org -;; -;; This file is part of GNU Emacs. -;; -;; GNU Emacs 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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs 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. If not, see <https://www.gnu.org/licenses/>. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: - -;; This file contains the habit tracking code for Org mode - -;;; Code: - -(require 'cl-lib) -(require 'org) -(require 'org-agenda) - -(defgroup org-habit nil - "Options concerning habit tracking in Org mode." - :tag "Org Habit" - :group 'org-progress) - -(defcustom org-habit-graph-column 40 - "The absolute column at which to insert habit consistency graphs. -Note that consistency graphs will overwrite anything else in the buffer." - :group 'org-habit - :type 'integer) - -(defcustom org-habit-preceding-days 21 - "Number of days before today to appear in consistency graphs." - :group 'org-habit - :type 'integer) - -(defcustom org-habit-following-days 7 - "Number of days after today to appear in consistency graphs." - :group 'org-habit - :type 'integer) - -(defcustom org-habit-show-habits t - "If non-nil, show habits in agenda buffers." - :group 'org-habit - :type 'boolean) - -(defcustom org-habit-show-habits-only-for-today t - "If non-nil, only show habits on today's agenda, and not for future days. -Note that even when shown for future days, the graph is always -relative to the current effective date." - :group 'org-habit - :type 'boolean) - -(defcustom org-habit-show-all-today nil - "If non-nil, will show the consistency graph of all habits on -today's agenda, even if they are not scheduled." - :group 'org-habit - :type 'boolean) - -(defcustom org-habit-today-glyph ?! - "Glyph character used to identify today." - :group 'org-habit - :version "24.1" - :type 'character) - -(defcustom org-habit-completed-glyph ?* - "Glyph character used to show completed days on which a task was done." - :group 'org-habit - :version "24.1" - :type 'character) - -(defcustom org-habit-show-done-always-green nil - "Non-nil means DONE days will always be green in the consistency graph. -It will be green even if it was done after the deadline." - :group 'org-habit - :type 'boolean) - -(defcustom org-habit-scheduled-past-days nil - "Value to use instead of `org-scheduled-past-days', for habits only. - -If nil, `org-scheduled-past-days' is used. - -Setting this to say 10000 is a way to make habits always show up -as a reminder, even if you set `org-scheduled-past-days' to a -small value because you regard scheduled items as a way of -\"turning on\" TODO items on a particular date, rather than as a -means of creating calendar-based reminders." - :group 'org-habit - :type '(choice integer (const nil)) - :package-version '(Org . "9.3") - :safe (lambda (v) (or (integerp v) (null v)))) - -(defface org-habit-clear-face - '((((background light)) (:background "#8270f9")) - (((background dark)) (:background "blue"))) - "Face for days on which a task shouldn't be done yet." - :group 'org-habit - :group 'org-faces) -(defface org-habit-clear-future-face - '((((background light)) (:background "#d6e4fc")) - (((background dark)) (:background "midnightblue"))) - "Face for future days on which a task shouldn't be done yet." - :group 'org-habit - :group 'org-faces) - -(defface org-habit-ready-face - '((((background light)) (:background "#4df946")) - (((background dark)) (:background "forestgreen"))) - "Face for days on which a task should start to be done." - :group 'org-habit - :group 'org-faces) -(defface org-habit-ready-future-face - '((((background light)) (:background "#acfca9")) - (((background dark)) (:background "darkgreen"))) - "Face for days on which a task should start to be done." - :group 'org-habit - :group 'org-faces) - -(defface org-habit-alert-face - '((((background light)) (:background "#f5f946")) - (((background dark)) (:background "gold"))) - "Face for days on which a task is due." - :group 'org-habit - :group 'org-faces) -(defface org-habit-alert-future-face - '((((background light)) (:background "#fafca9")) - (((background dark)) (:background "darkgoldenrod"))) - "Face for days on which a task is due." - :group 'org-habit - :group 'org-faces) - -(defface org-habit-overdue-face - '((((background light)) (:background "#f9372d")) - (((background dark)) (:background "firebrick"))) - "Face for days on which a task is overdue." - :group 'org-habit - :group 'org-faces) -(defface org-habit-overdue-future-face - '((((background light)) (:background "#fc9590")) - (((background dark)) (:background "darkred"))) - "Face for days on which a task is overdue." - :group 'org-habit - :group 'org-faces) - -(defun org-habit-duration-to-days (ts) - (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts) - ;; lead time is specified. - (floor (* (string-to-number (match-string 1 ts)) - (cdr (assoc (match-string 2 ts) - '(("d" . 1) ("w" . 7) - ("m" . 30.4) ("y" . 365.25)))))) - (error "Invalid duration string: %s" ts))) - -(defun org-is-habit-p (&optional pom) - "Is the task at POM or point a habit?" - (string= "habit" (org-entry-get (or pom (point)) "STYLE"))) - -(defun org-habit-parse-todo (&optional pom) - "Parse the TODO surrounding point for its habit-related data. -Returns a list with the following elements: - - 0: Scheduled date for the habit (may be in the past) - 1: \".+\"-style repeater for the schedule, in days - 2: Optional deadline (nil if not present) - 3: If deadline, the repeater for the deadline, otherwise nil - 4: A list of all the past dates this todo was mark closed - 5: Repeater type as a string - -This list represents a \"habit\" for the rest of this module." - (save-excursion - (if pom (goto-char pom)) - (cl-assert (org-is-habit-p (point))) - (let* ((scheduled (org-get-scheduled-time (point))) - (scheduled-repeat (org-get-repeat (org-entry-get (point) "SCHEDULED"))) - (end (org-entry-end-position)) - (habit-entry (org-no-properties (nth 4 (org-heading-components)))) - closed-dates deadline dr-days sr-days sr-type) - (if scheduled - (setq scheduled (time-to-days scheduled)) - (error "Habit %s has no scheduled date" habit-entry)) - (unless scheduled-repeat - (error - "Habit `%s' has no scheduled repeat period or has an incorrect one" - habit-entry)) - (setq sr-days (org-habit-duration-to-days scheduled-repeat) - sr-type (progn (string-match "[\\.+]?\\+" scheduled-repeat) - (match-string-no-properties 0 scheduled-repeat))) - (unless (> sr-days 0) - (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) - (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) - (setq dr-days (org-habit-duration-to-days - (match-string-no-properties 1 scheduled-repeat))) - (if (<= dr-days sr-days) - (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" - habit-entry scheduled-repeat)) - (setq deadline (+ scheduled (- dr-days sr-days)))) - (org-back-to-heading t) - (let* ((maxdays (+ org-habit-preceding-days org-habit-following-days)) - (reversed org-log-states-order-reversed) - (search (if reversed 're-search-forward 're-search-backward)) - (limit (if reversed end (point))) - (count 0) - (re (format - "^[ \t]*-[ \t]+\\(?:State \"%s\".*%s%s\\)" - (regexp-opt org-done-keywords) - org-ts-regexp-inactive - (let ((value (cdr (assq 'done org-log-note-headings)))) - (if (not value) "" - (concat "\\|" - (org-replace-escapes - (regexp-quote value) - `(("%d" . ,org-ts-regexp-inactive) - ("%D" . ,org-ts-regexp) - ("%s" . "\"\\S-+\"") - ("%S" . "\"\\S-+\"") - ("%t" . ,org-ts-regexp-inactive) - ("%T" . ,org-ts-regexp) - ("%u" . ".*?") - ("%U" . ".*?"))))))))) - (unless reversed (goto-char end)) - (while (and (< count maxdays) (funcall search re limit t)) - (push (time-to-days - (org-time-string-to-time - (or (match-string-no-properties 1) - (match-string-no-properties 2)))) - closed-dates) - (setq count (1+ count)))) - (list scheduled sr-days deadline dr-days closed-dates sr-type)))) - -(defsubst org-habit-scheduled (habit) - (nth 0 habit)) -(defsubst org-habit-scheduled-repeat (habit) - (nth 1 habit)) -(defsubst org-habit-deadline (habit) - (let ((deadline (nth 2 habit))) - (or deadline - (if (nth 3 habit) - (+ (org-habit-scheduled habit) - (1- (org-habit-scheduled-repeat habit))) - (org-habit-scheduled habit))))) -(defsubst org-habit-deadline-repeat (habit) - (or (nth 3 habit) - (org-habit-scheduled-repeat habit))) -(defsubst org-habit-done-dates (habit) - (nth 4 habit)) -(defsubst org-habit-repeat-type (habit) - (nth 5 habit)) - -(defsubst org-habit-get-priority (habit &optional moment) - "Determine the relative priority of a habit. -This must take into account not just urgency, but consistency as well." - (let ((pri 1000) - (now (if moment (time-to-days moment) (org-today))) - (scheduled (org-habit-scheduled habit)) - (deadline (org-habit-deadline habit))) - ;; add 10 for every day past the scheduled date, and subtract for every - ;; day before it - (setq pri (+ pri (* (- now scheduled) 10))) - ;; add 50 if the deadline is today - (if (and (/= scheduled deadline) - (= now deadline)) - (setq pri (+ pri 50))) - ;; add 100 for every day beyond the deadline date, and subtract 10 for - ;; every day before it - (let ((slip (- now (1- deadline)))) - (if (> slip 0) - (setq pri (+ pri (* slip 100))) - (setq pri (+ pri (* slip 10))))) - pri)) - -(defun org-habit-get-faces (habit &optional now-days scheduled-days donep) - "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. -NOW-DAYS defaults to the current time's days-past-the-epoch if nil. -SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. - -Habits are assigned colors on the following basis: - Blue Task is before the scheduled date. - Green Task is on or after scheduled date, but before the - end of the schedule's repeat period. - Yellow If the task has a deadline, then it is after schedule's - repeat period, but before the deadline. - Orange The task has reached the deadline day, or if there is - no deadline, the end of the schedule's repeat period. - Red The task has gone beyond the deadline day or the - schedule's repeat period." - (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) - (s-repeat (org-habit-scheduled-repeat habit)) - (d-repeat (org-habit-deadline-repeat habit)) - (deadline (if scheduled-days - (+ scheduled-days (- d-repeat s-repeat)) - (org-habit-deadline habit))) - (m-days (or now-days (time-to-days nil)))) - (cond - ((< m-days scheduled) - '(org-habit-clear-face . org-habit-clear-future-face)) - ((< m-days deadline) - '(org-habit-ready-face . org-habit-ready-future-face)) - ((= m-days deadline) - (if donep - '(org-habit-ready-face . org-habit-ready-future-face) - '(org-habit-alert-face . org-habit-alert-future-face))) - ((and org-habit-show-done-always-green donep) - '(org-habit-ready-face . org-habit-ready-future-face)) - (t '(org-habit-overdue-face . org-habit-overdue-future-face))))) - -(defun org-habit-build-graph (habit starting current ending) - "Build a graph for the given HABIT, from STARTING to ENDING. -CURRENT gives the current time between STARTING and ENDING, for -the purpose of drawing the graph. It need not be the actual -current time." - (let* ((all-done-dates (sort (org-habit-done-dates habit) #'<)) - (done-dates all-done-dates) - (scheduled (org-habit-scheduled habit)) - (s-repeat (org-habit-scheduled-repeat habit)) - (start (time-to-days starting)) - (now (time-to-days current)) - (end (time-to-days ending)) - (graph (make-string (1+ (- end start)) ?\s)) - (index 0) - last-done-date) - (while (and done-dates (< (car done-dates) start)) - (setq last-done-date (car done-dates) - done-dates (cdr done-dates))) - (while (< start end) - (let* ((in-the-past-p (< start now)) - (todayp (= start now)) - (donep (and done-dates (= start (car done-dates)))) - (faces - (if (and in-the-past-p - (not last-done-date) - (not (< scheduled now))) - (if (and all-done-dates (= (car all-done-dates) start)) - ;; This is the very first done of this habit. - '(org-habit-ready-face . org-habit-ready-future-face) - '(org-habit-clear-face . org-habit-clear-future-face)) - (org-habit-get-faces - habit start - (and in-the-past-p - last-done-date - ;; Compute scheduled time for habit at the time - ;; START was current. - (let ((type (org-habit-repeat-type habit))) - (cond - ;; At the last done date, use current - ;; scheduling in all cases. - ((null done-dates) scheduled) - ((equal type ".+") (+ last-done-date s-repeat)) - ((equal type "+") - ;; Since LAST-DONE-DATE, each done mark - ;; shifted scheduled date by S-REPEAT. - (- scheduled (* (length done-dates) s-repeat))) - (t - ;; Compute the scheduled time after the - ;; first repeat. This is the closest time - ;; past FIRST-DONE which can reach SCHEDULED - ;; by a number of S-REPEAT hops. - ;; - ;; Then, play TODO state change history from - ;; the beginning in order to find current - ;; scheduled time. - (let* ((first-done (car all-done-dates)) - (s (let ((shift (mod (- scheduled first-done) - s-repeat))) - (+ (if (= shift 0) s-repeat shift) - first-done)))) - (if (= first-done last-done-date) s - (catch :exit - (dolist (done (cdr all-done-dates) s) - ;; Each repeat shifts S by any - ;; number of S-REPEAT hops it takes - ;; to get past DONE, with a minimum - ;; of one hop. - (cl-incf s (* (1+ (/ (max (- done s) 0) - s-repeat)) - s-repeat)) - (when (= done last-done-date) - (throw :exit s)))))))))) - donep))) - markedp face) - (cond - (donep - (aset graph index org-habit-completed-glyph) - (setq markedp t) - (while (and done-dates (= start (car done-dates))) - (setq last-done-date (car done-dates)) - (setq done-dates (cdr done-dates)))) - (todayp - (aset graph index org-habit-today-glyph))) - (setq face (if (or in-the-past-p todayp) - (car faces) - (cdr faces))) - (when (and in-the-past-p - (not (eq face 'org-habit-overdue-face)) - (not markedp)) - (setq face (cdr faces))) - (put-text-property index (1+ index) 'face face graph) - (put-text-property index (1+ index) - 'help-echo - (concat (format-time-string - (org-time-stamp-format) - (time-add starting (days-to-time (- start (time-to-days starting))))) - (if donep " DONE" "")) - graph)) - (setq start (1+ start) - index (1+ index))) - graph)) - -(defun org-habit-insert-consistency-graphs (&optional line) - "Insert consistency graph for any habitual tasks." - (let ((inhibit-read-only t) - (buffer-invisibility-spec '(org-link)) - (moment (org-time-subtract nil - (* 3600 org-extend-today-until)))) - (save-excursion - (goto-char (if line (point-at-bol) (point-min))) - (while (not (eobp)) - (let ((habit (get-text-property (point) 'org-habit-p)) - (invisible-prop (get-text-property (point) 'invisible))) - (when habit - (move-to-column org-habit-graph-column t) - (delete-char (min (+ 1 org-habit-preceding-days - org-habit-following-days) - (- (line-end-position) (point)))) - (insert-before-markers - (org-habit-build-graph - habit - (time-subtract moment (days-to-time org-habit-preceding-days)) - moment - (time-add moment (days-to-time org-habit-following-days)))) - ;; Inherit invisible state of hidden entries. - (when invisible-prop - (put-text-property - (- (point) org-habit-graph-column) (point) - 'invisible invisible-prop)))) - (forward-line))))) - -(defun org-habit-toggle-habits () - "Toggle display of habits in an agenda buffer." - (interactive) - (org-agenda-check-type t 'agenda) - (setq org-habit-show-habits (not org-habit-show-habits)) - (org-agenda-redo) - (org-agenda-set-mode-name) - (message "Habits turned %s" - (if org-habit-show-habits "on" "off"))) - -(defun org-habit-toggle-display-in-agenda (arg) - "Toggle display of habits in agenda. -With ARG toggle display of all vs. undone scheduled habits. -See `org-habit-show-all-today'." - (interactive "P") - (if (not arg) - (org-habit-toggle-habits) - (org-agenda-check-type t 'agenda) - (setq org-habit-show-all-today (not org-habit-show-all-today)) - (when org-habit-show-habits (org-agenda-redo)))) - -(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-display-in-agenda) - -(provide 'org-habit) - -;;; org-habit.el ends here |