org: ox-texinfo and account

* org-conf.el: Require ox-texinfo, and delete the parts about
  accounts.  Those configurations are outdated now, and the new
  configurations are now in the new file "account.el".

* account.el: Configurations for capturing and reviewing account
  information.

1 files changed, 766 insertions, 0 deletions

diff --git a/account.el b/account.el
new file mode 100644
index 0000000..8df7477
--- /dev/null
+++ b/account.el
@@ -0,0 +1,766 @@
+;;; account.el --- My configurations for recording my acconuts  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2023  Jean Sévère Durand
+
+;; Author: Jean Sévère Durand <durand@jsdurand.xyz>
+;; Keywords: convenience, files
+
+;; This program 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.
+
+;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file implements my preferred interface to record expenses and
+;; to review my expenses.
+;;
+;; This is assumed to be called from the file "org-conf.el", so is not
+;; an independent configuration file.
+
+;;; Code:
+
+;;; Recording account information
+
+(defvar account-date-heading-regex nil
+  "A regular expression that matches the heading of a date line.
+The first capture group is the date string.")
+
+(setq account-date-heading-regex
+      (rx-to-string
+       (list
+        'seq
+        'bol
+        "* "
+        (list
+         'group-n 1
+         (list '= 4 'digit)
+         ?-
+         (list '= 2 'digit)
+         ?-
+         (list '= 2 'digit))
+        'eol)
+       t))
+
+(defvar account-shop-heading-regex nil
+  "A regular expression that matches the heading of a shop.
+The first capture group is the name of the shop.")
+
+(setq account-shop-heading-regex
+      (rx-to-string
+       (list
+        'seq
+        'bol
+        "** "
+        (list
+         'group-n 1
+         (list 'zero-or-more 'not-newline))
+        'eol)
+       t))
+
+(defvar account-item-heading-regex nil
+  "A regular expression that matches the heading of an item.
+The first capture group is the name of the item.")
+
+(setq account-item-heading-regex
+      (rx-to-string
+       (list
+        'seq
+        'bol
+        "*** "
+        (list
+         'group-n 1
+         (list 'zero-or-more 'not-newline))
+        'eol)
+       t))
+
+(defvar account-purposes-list
+  (list
+   "breakfast" "brunch" "brunverage" "lunch"
+   "dinner" "beverage" "snack" "fruit")
+  "The list of purposes of accounts.")
+
+(defun account-shop-item-alist ()
+  "Return an associative list of all shops and associated items."
+  (save-excursion
+    (save-match-data
+      (save-restriction
+        (widen)
+        (goto-char (point-min))
+        (let ((result-table (make-hash-table :test #'equal :size 650))
+              result-alist
+              shop-end shop
+              item item-set item-list item-cost
+              next-shop next-date)
+          (while (re-search-forward account-shop-heading-regex nil t)
+            (setq shop (match-string-no-properties 1))
+            (setq item-set (cond ((gethash shop result-table))
+                                 ((make-hash-table :test #'equal))))
+            (setq
+             next-shop
+             (save-match-data
+               (save-excursion
+                 (cond
+                  ((re-search-forward
+                    account-shop-heading-regex nil t)
+                   (forward-line 0)
+                   (point))))))
+            (setq
+             next-date
+             (save-match-data
+               (save-excursion
+                 (cond
+                  ((re-search-forward
+                    account-date-heading-regex nil t)
+                   (forward-line 0)
+                   (point))))))
+            (setq
+             shop-end
+             (cond
+              ((and next-shop next-date) (min next-shop next-date))
+              (next-shop)
+              (next-date)))
+            (while (re-search-forward
+                    account-item-heading-regex shop-end t)
+              (setq item (match-string-no-properties 1))
+              (forward-line 1)
+              (setq item-cost nil)
+              (cond
+               ((looking-at-p
+                 (rx-to-string
+                  (list 'seq 'bol ":PROPERTIES:" 'eol)
+                  t))
+                (forward-line 1)
+                (cond
+                 ((looking-at
+                   (rx-to-string
+                    (list 'seq 'bol ":cost: "
+                          (list 'zero-or-more 'space)
+                          (list
+                           'group-n 1
+                           (list 'one-or-more (list 'any 'digit ?.)))
+                          'eol)
+                    t))
+                  (setq item-cost
+                        (string-to-number
+                         (match-string-no-properties 1)))))))
+              (puthash item item-cost item-set))
+            (puthash shop item-set result-table))
+          (maphash
+           (lambda (k v)
+             (setq item-list nil)
+             (maphash
+              (lambda (vk vv)
+                (setq item-list (cons (cons vk vv) item-list)))
+              v)
+             (setq result-alist
+                   (cons (cons k item-list) result-alist)))
+           result-table)
+          result-alist)))))
+
+(defun account-one-newline ()
+  "Newline but enforce to have no blank lines around the point.
+The function adds two newline characters, and deletes any blank
+lines around the point."
+  (interactive)
+  (newline 2)
+  (delete-blank-lines))
+
+(defvar account-capture-history nil
+  "History for capturing account information.")
+
+(defvar account-capture-item-cost-history nil
+  "History for recording the costs of items.")
+
+(defun account-capture-content ()
+  "Org capture template for account."
+  (let* ((shops-and-items
+          (with-temp-buffer
+            (insert-file-contents
+             (expand-file-name "account/account.org" org-directory))
+            (account-shop-item-alist)))
+         (shops (mapcar #'car shops-and-items))
+         (shop (completing-read
+                "Which shop? " shops
+                nil nil nil 'account-capture-history))
+         (purpose (completing-read
+                   "Purpose? " account-purposes-list nil t))
+         (record-time (format-time-string "[%Y-%m-%d %a %H:%M]"))
+         (from (completing-read "From: " (list "cash" "card"))))
+    (format
+     "** %s\n:PROPERTIES:\n:purpose: %s\n:from: %s\n\
+:record_time: %s\n:END:\n"
+     shop purpose from record-time)))
+
+(defun account-capture-location ()
+  (let ((date-string (format "* %s" (org-read-date))))
+    (save-match-data
+      (goto-char (point-min))
+      (cond
+       ((re-search-forward
+         (rx-to-string (list 'seq 'bol date-string 'eol)
+          t)
+         nil t)
+        (cond
+         ((re-search-forward account-date-heading-regex nil t)
+          (forward-line 0))
+         ((goto-char (point-max))))
+        (account-one-newline))
+       ((goto-char (point-max))
+        (account-one-newline)
+        (insert date-string)
+        (account-one-newline))))))
+
+(defvar account-capture-template
+  (list "Account" 'plain
+        (list
+         'file+function
+         "account/account.org" #'account-capture-location)
+        (list 'function #'account-capture-content)
+        :jump-to-captured t
+        :empty-lines 0
+        :hook #'account-capture-mode)
+  "The template for capturing account information.")
+
+(cond
+ ((assoc "m" org-capture-templates #'equal)
+  (setcdr (assoc "m" org-capture-templates #'equal)
+          account-capture-template))
+ ((add-to-list 'org-capture-templates
+               (cons "m" account-capture-template))))
+
+(defvar account-capture-mode-map (make-sparse-keymap)
+  "The keymap that provides useful functions for recording account \
+information.")
+
+(define-minor-mode account-capture-mode
+  "A minor mode for recording account information."
+  :keymap account-capture-mode-map)
+
+(define-key account-capture-mode-map (vector 3 ?i)
+            #'account-capture-add-item)
+
+(defun account-capture-add-item ()
+  "Add an item when recording account information."
+  (interactive)
+  (let* ((shops (account-shop-item-alist))
+         (shop (save-match-data
+                 (goto-char (point-min))
+                 (cond
+                  ((re-search-forward
+                    account-shop-heading-regex nil t)
+                   (match-string-no-properties 1)))))
+         (items (cond (shop (cdr (assoc shop shops #'equal)))))
+         (item (completing-read "Item: " items))
+         (item-cost (cdr (assoc item items #'equal)))
+         (cost (read-number
+                "Cost: "
+                item-cost
+                'account-capture-item-cost-history)))
+    (goto-char (point-max))
+    (account-one-newline)
+    (insert (format
+             "*** %s\n:PROPERTIES:\n:cost: %d\n:END:\n"
+             item cost))))
+
+;;; Reviewing account information
+
+;; I remember I had written this display once, but I cannot find the
+;; codes now, so I have to write it again.
+
+(defun account-is-item-p (obj)
+  "Return t if and only if OBJ is a valid item.
+An item is a list whose `car' is the symbol `account-item' and
+whose `cdr' is a property list with the following keys.
+
+- date
+- shop name
+- item name
+- cost
+- purpose
+- payment method (from)
+- record-time"
+  (and
+   (consp obj)
+   (eq (car obj) 'account-item)
+   (let ((date (plist-get (cdr obj) :date)))
+     (type-break-timep date))
+   (let ((shop (plist-get (cdr obj) :shop-name)))
+     (and (stringp shop) (not (string= shop ""))))
+   (let ((item (plist-get (cdr obj) :item-name)))
+     (and (stringp item) (not (string= item ""))))
+   (let ((cost (plist-get (cdr obj) :cost)))
+     (and (numberp cost) (>= cost 0)))
+   (let ((purpose (plist-get (cdr obj) :purpose)))
+     (and (stringp purpose) (not (string= purpose ""))))
+   (let ((method (or (plist-get (cdr obj) :payment-method)
+                     (plist-get (cdr obj) :from))))
+     (and (stringp method) (not (string= method ""))))
+   (let ((time (plist-get (cdr obj) :record-time)))
+     (type-break-timep time))
+   t))
+
+(defun account-find-next-heading ()
+  "Go to the next heading and return the number of leading stars.
+If no heading is found, the point will not be moved, and nil will
+be returned.
+
+If a heading is found, the point will be placed one character
+after the leading stars."
+  (cond
+   ((save-match-data
+      (re-search-forward
+       (rx-to-string
+        (list 'seq 'bol (list 'or "*" "**" "***") 32)
+        t)
+       nil t))
+    (- (point) (pos-bol) 1))))
+
+(defun account-collect-into-vec (vec collector)
+  "Return the vector of items in the current buffer.
+See `account-is-item-p' for the definition of a valid item.
+
+VEC is a vector of titles.
+
+The COLLECTOR is responsible for collecting the items.  More
+precisely, it should be a function with one argument, which is an
+item, and the collector should return a list of the form:
+
+\(n value shop-name)
+
+Here N is the index in the vector, and VALUE is the cost of the
+item.
+
+The N-th element of the vector VEC will be a list
+
+\(TITLE VALUE ALIST-OF-SHOPS),
+
+where TITLE is the original title, VALUE is the sum of all items
+for which the collector gives N as its index, and ALIST-OF-SHOPS
+is the associative list of all associated shop-names and
+respective costs, if SHOP-NAME is non-nil.
+
+This function does not move point, nor does it modify match data."
+  (save-match-data
+    (save-excursion
+      (goto-char (point-min))
+      (let* ((len (length vec))
+             (result (make-vector len nil))
+             (date-markers
+              (make-hash-table :size account-number-of-days
+                               :test #'equal))
+             account-item
+             shop-marker date-marker 
+             level date shop item cost purpose from time)
+        (let ((n 0))
+          (while (< n len)
+            (let ((title (aref vec n)))
+              (aset result n (list title 0 nil)))
+            (setq n (1+ n))))
+        (while (setq level (account-find-next-heading))
+          (save-match-data
+            (cond
+             ((= level 1)
+              (cond
+               ((looking-at
+                 (rx-to-string
+                  (list
+                   'seq
+                   (list 'group-n 1 (list '= 4 'digit))
+                   ?-
+                   (list 'group-n 2 (list '= 2 'digit))
+                   ?-
+                   (list 'group-n 3 (list '= 2 'digit)))
+                  t))
+                (setq date (encode-time
+                            (list
+                             0 0 0
+                             (string-to-number
+                              (match-string-no-properties 3))
+                             (string-to-number
+                              (match-string-no-properties 2))
+                             (string-to-number
+                              (match-string-no-properties 1)))))
+                (setq
+                 date-marker
+                 (save-excursion
+                   (goto-char (pos-bol)) (point-marker)))
+                (puthash date date-marker date-markers))
+               ((user-error "Level one without date?"))))
+             ((= level 2)
+              (setq shop (buffer-substring-no-properties
+                          (point) (pos-eol)))
+              (setq shop-marker
+                    (save-excursion
+                      (goto-char (pos-bol))
+                      (point-marker)))
+              (setq purpose nil)
+              (setq from nil)
+              (setq time nil)
+              (forward-line 1)
+              (cond
+               ((not (looking-at-p "^:PROPERTIES:$"))
+                (user-error
+                 "No properties for shop %s found" shop)))
+              (forward-line 1)
+              (cond
+               ((not (looking-at-p "^:purpose: "))
+                (user-error
+                 "No purposes for shop %s found" shop))
+               ((setq purpose (buffer-substring-no-properties
+                               (+ (point) 10) (pos-eol)))))
+              (forward-line 1)
+              (setq
+               from
+               (cond
+                ((looking-at-p "^:from: ")
+                 (buffer-substring-no-properties
+                  (+ (point) 7) (pos-eol)))))
+              (forward-line 1)
+              (setq
+               time
+               (cond
+                ((looking-at-p "^:record_time: ")
+                 (encode-time
+                  (take
+                   6
+                   (parse-time-string
+                    (buffer-substring-no-properties
+                     (+ (point) 15) (1- (pos-eol))))))))))
+             ((= level 3)
+              (setq item (buffer-substring-no-properties
+                          (point) (pos-eol)))
+              (forward-line 1)
+              (cond
+               ((not (looking-at-p "^:PROPERTIES:$"))
+                (user-error
+                 "No properties for item %s found" item)))
+              (forward-line 1)
+              (cond
+               ((not (looking-at-p "^:cost: "))
+                (user-error "No cost for item %s found" item))
+               ((setq cost (string-to-number
+                            (buffer-substring-no-properties
+                             (+ (point) 7) (pos-eol))))))
+              (setq
+               account-item
+               (list 'account-item
+                     :date date
+                     :shop-name shop
+                     :item-name item
+                     :cost cost
+                     :purpose purpose
+                     :payment-method from
+                     :record-time time))
+              (let* ((collector-result
+                      (funcall collector account-item))
+                     (n (car collector-result))
+                     (value (cadr collector-result))
+                     (name (caddr collector-result)))
+                (cond
+                 (collector-result
+                  (let* ((res-element (aref result n))
+                         (res-value (cadr res-element))
+                         (res-list (caddr res-element))
+                         (name-old-value
+                          (or (car-safe
+                               (alist-get name res-list))
+                              0)))
+                    (setcar (cdr res-element)
+                            (+ res-value value))
+                    (cond
+                     (name
+                      (setf
+                       (alist-get name (car (cddr res-element)))
+                       (cons
+                        (+ name-old-value value)
+                        shop-marker)))))))))
+             ((user-error "Invalid level %d" level)))))
+        (let ((n 0))
+          (while (< n len)
+            (let* ((element (aref result n))
+                   (title (car element))
+                   (date
+                    (get-text-property 0 'date title))
+                   (date-encoded
+                    (encode-time
+                     (list 0 0 0
+                           (cadr date)
+                           (car date)
+                           (caddr date))))
+                   (date-marker
+                    (gethash date-encoded date-markers)))
+              (cond
+               (date-marker
+                (aset
+                 result n
+                 (cons
+                  (propertize title 'org-marker date-marker)
+                  (cdr element))))))
+            (setq n (1+ n))))
+        result))))
+
+(defun account-agenda-command (match)
+  "The command for inserting acccount information to agenda.
+The vector of titles is provided by the variable
+`account-day-offsets' and the collector function is provided by
+the variable `account-agenda-collector'.
+
+MATCH is required by Org-agenda, and relentlessly ignored by us."
+  (ignore match)
+  (setq
+   account-day-offsets
+   (number-sequence 0 (1- account-number-of-days)))
+  (insert
+   (propertize
+    "Account:"
+    'face 'org-agenda-structure
+    'org-agenda-structural-header t
+    'org-agenda-type 'account
+    'org-date-line t))
+  (newline)
+  (let* ((titles (make-vector (length account-day-offsets) nil))
+         (all-cost 0)
+         (file (expand-file-name
+                "account.org"
+                (expand-file-name "account" org-directory)))
+         (buffer (progn (org-check-agenda-file file)
+                        (org-get-agenda-file-buffer file)))
+         info)
+    (mapc
+     (lambda (n)
+       (let* ((date (decode-time))
+              (day (nth 3 date))
+              (month (nth 4 date))
+              (year (nth 5 date)))
+         (aset
+          titles
+          n
+          (account-agenda-format-date
+           (calendar-gregorian-from-absolute
+            (calendar-absolute-from-gregorian
+             (list month (- day n) year)))))))
+     account-day-offsets)
+    (setq
+     info
+     (with-current-buffer buffer
+       (account-collect-into-vec
+        titles account-agenda-collector)))
+    (mapc
+     (lambda (element)
+       (let* ((title (car element))
+              (cost (car (cdr element)))
+              (date (get-text-property 0 'date title))
+              (date-face (org-agenda-get-day-face date)))
+         (setq all-cost (+ all-cost cost))
+         (insert (propertize title 'face date-face))
+         (newline)
+         (mapc
+          (lambda (shop-info)
+            (insert
+             (propertize
+              (format
+               "  %s: %d"
+               (car shop-info)
+               (cadr shop-info))
+              'face 'org-agenda-calendar-event
+              'org-marker (cddr shop-info)))
+            (newline))
+          (caddr element))
+         (insert
+          (propertize
+           (format "  all: %d" cost)
+           'face 'org-agenda-calendar-event
+           'daily-cost cost
+           'date date)))
+       (newline))
+     info)
+    (newline 2)
+    (insert
+     (propertize
+      (format "all: %d" all-cost)
+      'face 'org-agenda-calendar-event))
+    (newline)
+    (goto-char (point-min))
+    (account-mode)))
+
+(defvar account-number-of-days 7
+  "The number of days to display.")
+
+(defvar account-day-offsets nil
+  "The list of offsets for getting days to display in agenda.")
+
+(setq
+ account-day-offsets
+ (number-sequence 0 (1- account-number-of-days)))
+
+(defvar account-agenda-collector #'account-agenda-last-n-days
+  "The function for collecting account information.
+See the function `account-collect-into-vec' for how the collector
+should behave.")
+
+(defun account-agenda-last-n-days (item)
+  "Collect ITEM if its date is within last `account-number-of-days' \
+days."
+  (let ((days
+         (days-between
+          (format-time-string "%F" (current-time))
+          (format-time-string "%F" (plist-get (cdr item) :date)))))
+    (cond ((and (<= 0 days) (< days account-number-of-days))
+           (list
+            days
+            (plist-get (cdr item) :cost)
+            (plist-get (cdr item) :shop-name))))))
+
+(defun account-agenda-format-date (date)
+  "Return the string for the DATE.
+DATE should be a list (MONTH DAY YEAR) as returned from the
+function `calendar-gregorian-from-absolute'."
+  (require 'cal-iso)
+  (let* ((calendar-day-name-array
+          (vector
+           "Dimanche" "Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi"
+           "Samedi"))
+         (calendar-month-name-array
+          (vector
+           "Janvier" "Février" "Mars" "Avril" "Mai" "Juin" "Juillet"
+           "Août" "Septembre" "Octobre" "Novembre" "Décembre"))
+         (dayname (calendar-day-name date))
+         (day (car (cdr date)))
+         (day-of-week (calendar-day-of-week date))
+         (month (car date))
+         (month-name (calendar-month-name month))
+         (year (car (cdr (cdr date))))
+         (iso-week (org-days-to-iso-week
+                    (calendar-absolute-from-gregorian date)))
+         (weekstring (cond ((= day-of-week 1)
+                            ;; S stands for Semaine
+                            (format " S%02d" iso-week))
+                           (""))))
+    (propertize
+     (format "%-11s%2d %s %4d%s"
+             dayname day month-name year weekstring)
+     'date date)))
+
+(define-derived-mode account-mode org-agenda-mode "Account"
+  "Major mode for viewing my account information.
+The main purpose is to provide a dedicated keymap to manipulate
+the displayed information.")
+
+(define-key account-mode-map (vector 3 5)
+            #'account-agenda-export-to-svg)
+
+(add-to-list
+ 'org-agenda-custom-commands
+ '("m" "account" ((account-agenda-command))))
+
+;;; Exporting information as graphs
+
+(defun account-agenda-export-to-svg ()
+  "Export the current agenda into an SVG image."
+  (interactive)
+  (save-restriction
+    (save-excursion
+      (save-match-data
+        (widen)
+        (goto-char (point-min))
+        (let ((svg-buffer-name "*account-svg*")
+              (max-cost 0)
+              prop cost date result temp)
+          (while (setq
+                  prop
+                  (text-property-search-forward
+                   'daily-cost nil
+                   (lambda (_ val)
+                     (and (numberp val) (>= val 0)))
+                   t))
+            (forward-char -1)
+            (setq cost (prop-match-value prop))
+            (setq max-cost (max max-cost cost))
+            (setq date (get-text-property (point) 'date))
+            (cond
+             ((= cost 0))
+             ((setq result
+                    (cons (cons date cost)
+                          result)))))
+          (let ((temp result) temp-cost)
+            (while (consp temp)
+              (setq temp-cost (cdr (car temp)))
+              (setcdr
+               (car temp)
+               (cons
+                (* (/ (float temp-cost) max-cost) 600)
+                temp-cost))
+              (setq temp (cdr temp))))
+          (require 'svg)
+          (let* ((len (length result))
+                 (block-width (/ 800.0 len))
+                 (index 0)
+                 (start 0)
+                 (svg (svg-create 800 700 :stroke-width 10)))
+            (mapc
+             (lambda (cell)
+               (setq start (+ (* block-width index) 10))
+               (svg-rectangle
+                svg
+                start (- 650 (cadr cell))
+                (- block-width 20) (cadr cell)
+                :stroke-width 2
+                :stroke-color "blue"
+                :fill-color "blue")
+               (svg-text
+                svg
+                (format-time-string
+                 "%F"
+                 (encode-time
+                  (list
+                   0 0 0
+                   (cadr (car cell))
+                   (car (car cell))
+                   (caddr (car cell)))))
+                :text-anchor "middle"
+                :font-size "15"
+                :font-weight "bold"
+                :stroke "red"
+                :fill "red"
+                :letter-spacing "1pt"
+                :x (+ start (/ (- block-width 20) 2.0))
+                :y 675
+                :stroke-width 1)
+               (svg-text
+                svg
+                (format "%d" (cddr cell))
+                :text-anchor "middle"
+                :font-size "15"
+                :font-weight "bold"
+                :stroke "red"
+                :fill "red"
+                :letter-spacing "1pt"
+                :x (+ start (/ (- block-width 20) 2.0))
+                :y (- 625 (cadr cell))
+                :stroke-width 1)
+               (setq index (1+ index)))
+             result)
+            (with-current-buffer
+                (get-buffer-create svg-buffer-name)
+              (svg-print svg)
+              (image-mode))
+            (display-buffer
+             svg-buffer-name
+             (list
+              (list #'display-buffer-in-direction)
+              (cons 'direction 'right)
+              (cons 'window 'main)
+              (cons 'window-width 0.75)))
+            (select-window (get-buffer-window svg-buffer-name))))))))
+
+(provide 'account)
+;;; account.el ends here