path: root/account.el

;;; 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