From 19e3ddf0acdd73011f78ece6f99b5a0c850bd347 Mon Sep 17 00:00:00 2001 From: JSDurand Date: Wed, 23 Aug 2023 01:39:16 +0800 Subject: 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. --- account.el | 766 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ org-conf.el | 62 ++--- 2 files changed, 799 insertions(+), 29 deletions(-) create mode 100644 account.el 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 +;; 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 . + +;;; 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 diff --git a/org-conf.el b/org-conf.el index 455d2dc..0d2d0c6 100644 --- a/org-conf.el +++ b/org-conf.el @@ -10,6 +10,8 @@ (require 'ox) +(require 'ox-texinfo) + ;;; org capture bookmark (setq org-capture-bookmark nil) @@ -261,35 +263,37 @@ in Lisp code use `org-set-tags' instead." ;;; Accounts -;;;###autoload -(defvar durand-org-capture-account-which-list - '("breakfast" "brunch" "brunverage" "lunch" "dinner" "beverage" "snack" "fruit") - "The list of purposes of accounts in the capture-template for accounting.") - -;;;###autoload -(defun durand-org-capture-account-template () - "Org capture template for account." - (let* ((shop-and-items (durand-org-complete-capture-account)) - (which (completing-read - "For what? " - durand-org-capture-account-which-list)) - (cost (number-to-string - (read-number "Cost: " 0))) - (from (completing-read "From: " '("Cash" "etique"))) - (active-time (format-time-string - (cdr org-time-stamp-formats))) - (inactive-time - (let ((temp active-time)) - (while (string-match "<\\|>" temp) - (setf temp - (replace-match - (cond - ((string= (match-string-no-properties 0 temp) "<") "[") - ((string= (match-string-no-properties 0 temp) ">") "]")) - nil nil temp))) - temp))) - (format "%s\n :PROPERTIES:\n :cost: %s\n :FROM: %s\n :RECORD_TIME: %s\n :END: \n %s%%?" - which cost from inactive-time shop-and-items))) +(load-file "account.el") + +;; ;;;###autoload +;; (defvar durand-org-capture-account-which-list +;; '("breakfast" "brunch" "brunverage" "lunch" "dinner" "beverage" "snack" "fruit") +;; "The list of purposes of accounts in the capture-template for accounting.") + +;; ;;;###autoload +;; (defun durand-org-capture-account-template () +;; "Org capture template for account." +;; (let* ((shop-and-items (durand-org-complete-capture-account)) +;; (which (completing-read +;; "For what? " +;; durand-org-capture-account-which-list)) +;; (cost (number-to-string +;; (read-number "Cost: " 0))) +;; (from (completing-read "From: " '("Cash" "etique"))) +;; (active-time (format-time-string +;; (cdr org-time-stamp-formats))) +;; (inactive-time +;; (let ((temp active-time)) +;; (while (string-match "<\\|>" temp) +;; (setf temp +;; (replace-match +;; (cond +;; ((string= (match-string-no-properties 0 temp) "<") "[") +;; ((string= (match-string-no-properties 0 temp) ">") "]")) +;; nil nil temp))) +;; temp))) +;; (format "%s\n :PROPERTIES:\n :cost: %s\n :FROM: %s\n :RECORD_TIME: %s\n :END: \n %s%%?" +;; which cost from inactive-time shop-and-items))) (require 'org-protocol) -- cgit v1.2.3-18-g5258