Add preliminary version of streaks for habits

global.org

@@ -1377,12 +1377,35 @@
                   (lambda (params)
                     (list `(concat ,(car params) "\n"))))
     #+end_src
+    #+begin_src emacs-lisp
+      (defun wilder/delta-list (l op)
+        (unless (< (length l) 2)
+          (cons (funcall op (car l) (cadr l)) (wilder/delta-list (cdr l) op))))
+
+      (defun wilder/truncate-list-when (l predicate)
+        (unless (funcall predicate (car l))
+          (cons (car l) (wilder/truncate-list-when (cdr l) predicate))))
+
+      (defun wilder/habit-streak (habit)
+         (let* ((done-dates (sort (org-habit-done-dates habit) #'>))
+               (dead-rep (org-habit-deadline-repeat habit))
+               (sched-rep (org-habit-scheduled-repeat habit))
+               (today-date (time-to-days nil))
+               (done-list (append (list today-date) done-dates '(0)))
+               (delta-list (wilder/delta-list done-list #'-))
+               (truncated-list (wilder/truncate-list-when delta-list (lambda (x) (> x dead-rep)))))
+          (list (length truncated-list)
+                (list (car delta-list) sched-rep dead-rep))))
+
+    #+end_src
     Improve the org-habit graph thing
     #+begin_src emacs-lisp
       (setq org-habit-regular-glyph ?□
             org-habit-today-glyph ?
             org-habit-completed-glyph ?▣
-            org-habit-completed-today-glyph ?)
+            org-habit-completed-today-glyph ?
+            org-habit-preceding-days 6
+            org-habit-graph-column 62)
 
       (defun wilder/org-habit-build-graph (habit starting current ending)
         "Build a graph for the given HABIT, from STARTING to ENDING.
@@ -1475,16 +1498,22 @@
                          (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))
+
+          (let* ((streak (wilder/habit-streak habit))
+                 (streak-current (car streak))
+                 (streak-current-stats (nth 1 streak))
+                  (current-ok (< (car streak-current-stats) (nth 1 streak-current-stats)))
+                  (current-on-deadline (> (car streak-current-stats) (nth 2 streak-current-stats)))
+                 (streak-face (if (eq 0 streak-current) 'font-lock-comment-face
+                                  (if current-on-deadline 'org-habit-overdue-face
+                                       (if current-ok 'org-habit-ready-face
+                                         'org-habit-alert-face))))
+                 (streak-string (format "%4d" streak-current)))
+            (put-text-property 0 4 'face streak-face streak-string)
+            (concat streak-string "·" graph))))
 
       (advice-add 'org-habit-build-graph  :override #'wilder/org-habit-build-graph)
     #+end_src