diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/ldg-schedule.el (renamed from lisp/ldg-auto.el) | 111 |
1 files changed, 86 insertions, 25 deletions
diff --git a/lisp/ldg-auto.el b/lisp/ldg-schedule.el index 33a2cdba..b6b94308 100644 --- a/lisp/ldg-auto.el +++ b/lisp/ldg-schedule.el @@ -1,4 +1,4 @@ -;;; ldg-auto.el --- Helper code for use with the "ledger" command-line tool +;;; ldg-schedule.el --- Helper code for use with the "ledger" command-line tool ;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com) @@ -30,10 +30,23 @@ ;; function slot of the symbol VARNAME. Then use VARNAME as the ;; function without have to use funcall. +(defgroup ledger-schedule nil + "Support for automatically recommendation transactions." + :group 'ledger) + +(defcustom ledger-schedule-look-forward 14 + "Number of days auto look forward to recommend transactions" + :type 'integer + :group 'ledger-schedule) + +(defcustom ledger-schedule-file "ledger-schedule.ledger" + "File to find scheduled transactions." + :type 'file + :group 'ledger-schedule) (defsubst between (val low high) (and (>= val low) (<= val high))) -(defun ledger-auto-days-in-month (month year) +(defun ledger-schedule-days-in-month (month year) "Return number of days in the MONTH, MONTH is from 1 to 12. If year is nil, assume it is not a leap year" (if (between month 1 12) @@ -44,7 +57,7 @@ If year is nil, assume it is not a leap year" ;; Macros to handle date expressions -(defmacro ledger-auto-constrain-day-in-month-macro (count day-of-week) +(defmacro ledger-schedule-constrain-day-in-month-macro (count day-of-week) "Return a form that evaluates DATE that returns true for the COUNT DAY-OF-WEEK. For example, return true if date is the 3rd Thursday of the month. Negative COUNT starts from the end of the month. (EQ @@ -65,7 +78,7 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)" (let ((days-in-month (gensym)) (decoded (gensym))) `(let* ((,decoded (decode-time date)) - (,days-in-month (ledger-auto-days-in-month + (,days-in-month (ledger-schedule-days-in-month (nth 4 ,decoded) (nth 5 ,decoded)))) (if (and (eq (nth 6 ,decoded) ,day-of-week) @@ -76,11 +89,11 @@ COUNT 0) means EVERY day-of-week (eg. every Saturday)" nil)))) (t (error "COUNT out of range, COUNT=%S" count))) - (error "Invalid argument to ledger-auto-day-in-month-macro %S %S" + (error "Invalid argument to ledger-schedule-day-in-month-macro %S %S" count day-of-week))) -(defmacro ledger-auto-constrain-numerical-date-macro (year month day) +(defmacro ledger-schedule-constrain-numerical-date-macro (year month day) "Return a function of date that is only true if all constraints are met. A nil constraint matches any input, a numerical entry must match that field of date." @@ -90,7 +103,7 @@ of date." (and (between (eval month) 1 12) ;; make sure it is between 1 ;; and twelve and the number ;; of days are ok - (between (eval day) 1 (ledger-auto-days-in-month (eval month) (eval year)))) + (between (eval day) 1 (ledger-schedule-days-in-month (eval month) (eval year)))) (between (eval day) 1 31)) ;; no month specified, assume 31 days. `'(and ,(if (eval year) `(if (eq (nth 5 (decode-time date)) ,(eval year)) t) @@ -100,11 +113,11 @@ of date." `t) ,(if (eval day) `(if (eq (nth 3 (decode-time date)) ,(eval day)) t))) - (error "ledger-auto-constraint-numerical-date-macro: date out of range %S %S %S" (eval year) (eval month) (eval day)))) + (error "ledger-schedule-constraint-numerical-date-macro: date out of range %S %S %S" (eval year) (eval month) (eval day)))) -(defmacro ledger-auto-constrain-every-count-day-macro (day-of-week skip start-date) +(defmacro ledger-schedule-constrain-every-count-day-macro (day-of-week skip start-date) "Return a form that is true for every DAY skipping SKIP, starting on START. For example every second Friday, regardless of month." (let ((start-day (nth 6 (decode-time (eval start-date))))) @@ -114,7 +127,7 @@ For example every second Friday, regardless of month." nil) (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) -(defmacro ledger-auto-constrain-date-range-macro (month1 day1 month2 day2) +(defmacro ledger-schedule-constrain-date-range-macro (month1 day1 month2 day2) "Return a form of DATE that is true if DATE falls between MONTH1 DAY1 and MONTH2 DAY2." (let ((decoded (gensym)) (target-month (gensym)) @@ -128,10 +141,13 @@ For example every second Friday, regardless of month." (< ,target-day ,day2)))))) -(defun ledger-auto-is-holiday (date) +(defun ledger-schedule-is-holiday (date) "Return true if DATE is a holiday.") -(defun ledger-auto-scan-transactions (auto-file) +(defun ledger-schedule-scan-transactions (auto-file) + "Scans AUTO_FILE and returns a list of transactions with date predicates. +The car of each item is a fuction of date that returns true if +the transaction should be logged for that day." (interactive "fFile name: ") (let ((xact-list (list))) (with-current-buffer @@ -142,7 +158,7 @@ For example every second Friday, regardless of month." (transaction nil) (xact-start (match-end 0))) (setq date-descriptors - (ledger-auto-read-descriptor-tree + (ledger-schedule-read-descriptor-tree (buffer-substring-no-properties (match-beginning 0) (match-end 0)))) @@ -154,7 +170,7 @@ For example every second Friday, regardless of month." (setq xact-list (cons transaction xact-list)))) xact-list))) -(defun ledger-auto-replace-brackets () +(defun ledger-schedule-replace-brackets () "Replace all brackets with parens" (goto-char (point-min)) (while (search-forward "]" nil t) @@ -163,7 +179,7 @@ For example every second Friday, regardless of month." (while (search-forward "[" nil t) (replace-match "(" nil t))) -(defun ledger-auto-read-descriptor-tree (descriptor-string) +(defun ledger-schedule-read-descriptor-tree (descriptor-string) "Take a date descriptor string and return a function that returns true if the date meets the requirements" (with-temp-buffer @@ -171,7 +187,7 @@ returns true if the date meets the requirements" (let (pos) ;; Replace brackets with parens (insert descriptor-string) - (ledger-auto-replace-brackets) + (ledger-schedule-replace-brackets) (goto-char (point-max)) ;; double quote all the descriptors for string processing later @@ -209,12 +225,14 @@ returns true if the date meets the requirements" (setq newcar (ledger-transform-auto-tree (car tree)))) (if (consp newcar) (push newcar result) - (push (ledger-auto-parse-date-descriptor newcar) result)) ) + (push (ledger-schedule-parse-date-descriptor newcar) result)) ) (setq tree (cdr tree))) + + ;; tie up all the clauses in a big or and lambda `(lambda (date) ,(nconc (list 'or) (nreverse result) tree))))) -(defun ledger-auto-split-constraints (descriptor-string) +(defun ledger-schedule-split-constraints (descriptor-string) "Return a list with the year, month and day fields split" (let ((fields (split-string descriptor-string "[/\\-]" t)) constrain-year constrain-month constrain-day) @@ -234,20 +252,63 @@ returns true if the date meets the requirements" (string-to-number str) nil)) -(defun ledger-auto-compile-constraints (constraint-list) +(defun ledger-schedule-compile-constraints (constraint-list) (let ((year-constraint (ledger-string-to-number-or-nil (nth 0 constraint-list))) (month-constraint (ledger-string-to-number-or-nil (nth 1 constraint-list))) (day-constraint (ledger-string-to-number-or-nil (nth 2 constraint-list)))) - (ledger-auto-constrain-numerical-date-macro + (ledger-schedule-constrain-numerical-date-macro year-constraint month-constraint day-constraint))) -(defun ledger-auto-parse-date-descriptor (descriptor) +(defun ledger-schedule-parse-date-descriptor (descriptor) "Parse the date descriptor, return the evaluator" - (ledger-auto-compile-constraints - (ledger-auto-split-constraints descriptor))) + (ledger-schedule-compile-constraints + (ledger-schedule-split-constraints descriptor))) + + +(defun ledger-schedule-list-upcoming-xacts (candidate-items early horizon) + "Search CANDIDATE-ITEMS for xacts that occur within the perios today - EARLY to today + HORIZON" + (let ((start-date (time-subtract (current-time) (days-to-time early))) + test-date items) + (loop for day from 0 to (+ early horizon) by 1 do + (setq test-date (time-add start-date (days-to-time day))) + (dolist (candidate candidate-items items) + (if (funcall (car candidate) test-date) + (setq items (append items (list (list test-date (cadr candidate)))))))) + items)) + +(defun ledger-schedule-create-auto-buffer (candidate-items early horizon) + "Format CANDIDATE-ITEMS for display." + (let ((candidates (ledger-schedule-list-upcoming-xacts candidate-items early horizon)) + (auto-buf (get-buffer-create "*Ledger Auto*")) + (date-format (cdr (assoc "date-format" ledger-environment-alist)))) + (with-current-buffer auto-buf + (erase-buffer) + (dolist (candidate candidates) + (insert (format-time-string date-format (car candidate) ) " " (cadr candidate) "/n"))))) +;; +;; Test harnesses for use in ielm +;; +(defvar auto-items) + +(defun ledger-schedule-test-setup () + (setq auto-items + (ledger-schedule-scan-transactions "~/FinanceData/ledger-schedule.ledger"))) + + +(defun ledger-schedule-test-predict () + (let ((today (current-time)) + test-date items) + + (loop for day from 0 to ledger-schedule-look-forward by 1 do + (setq test-date (time-add today (days-to-time day))) + ;;(message "date: %S" (decode-time test-date)) + (dolist (item auto-items items) + (if (funcall (car item) test-date) + (setq items (append items (list (decode-time test-date) (cdr item))))))) + items)) -(provide 'ldg-auto) +(provide 'ldg-schedule) -;;; ldg-auto.el ends here +;;; ldg-schedule.el ends here |