diff options
author | Craig Earls <enderw88@gmail.com> | 2013-03-19 09:16:07 -0700 |
---|---|---|
committer | Craig Earls <enderw88@gmail.com> | 2013-03-19 09:16:07 -0700 |
commit | 06579c504d051f9609e7377ae7db4f451bdb44b7 (patch) | |
tree | f1d4cdccce8029266733fe8431a1e3fd728d0d41 /lisp | |
parent | 124058d26aa976ca3b8bc2969c16cff6881f8155 (diff) | |
download | fork-ledger-06579c504d051f9609e7377ae7db4f451bdb44b7.tar.gz fork-ledger-06579c504d051f9609e7377ae7db4f451bdb44b7.tar.bz2 fork-ledger-06579c504d051f9609e7377ae7db4f451bdb44b7.zip |
Check 'auto' package name to 'schedule'
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/ldg-auto.el | 301 |
1 files changed, 0 insertions, 301 deletions
diff --git a/lisp/ldg-auto.el b/lisp/ldg-auto.el deleted file mode 100644 index ffc6ee7d..00000000 --- a/lisp/ldg-auto.el +++ /dev/null @@ -1,301 +0,0 @@ -;;; ldg-auto.el --- Helper code for use with the "ledger" command-line tool - -;; Copyright (C) 2013 Craig Earls (enderw88 at gmail dot com) - -;; This file is not part of GNU Emacs. - -;; This 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 2, or (at your option) -;; any later version. -;; -;; This 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; This module provides for automatically adding transactions to a -;; ledger buffer on a periodic basis. Recurrence expressions are -;; inspired by Martin Fowler's "Recurring Events for Calendars", -;; martinfowler.com/apsupp/recurring.pdf - -;; use (fset 'VARNAME (macro args)) to put the macro definition in the -;; function slot of the symbol VARNAME. Then use VARNAME as the -;; function without have to use funcall. - -(defgroup ledger-auto nil - "Support for automatically recommendation transactions." - :group 'ledger) - -(defcustom ledger-auto-look-forward 14 - "Number of days auto look forward to recommend transactions" - :type 'integer - :group 'ledger-auto) - - -(defsubst between (val low high) - (and (>= val low) (<= val high))) - -(defun ledger-auto-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) - (if (and year (date-leap-year-p year) (= 2 month)) - 29 - (nth (1- month) '(31 28 31 30 31 30 31 31 30 31 30 31))) - (error "Month out of range, MONTH=%S" month))) - -;; Macros to handle date expressions - -(defmacro ledger-auto-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 -COUNT 0) means EVERY day-of-week (eg. every Saturday)" - (if (and (between count -6 6) (between day-of-week 0 6)) - (cond ((zerop count) ;; Return true if day-of-week matches - `(eq (nth 6 (decode-time date)) ,day-of-week)) - ((> count 0) ;; Positive count - (let ((decoded (gensym))) - `(let ((,decoded (decode-time date))) - (if (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - ,(* (1- count) 7) - ,(* count 7))) - t - nil)))) - ((< count 0) - (let ((days-in-month (gensym)) - (decoded (gensym))) - `(let* ((,decoded (decode-time date)) - (,days-in-month (ledger-auto-days-in-month - (nth 4 ,decoded) - (nth 5 ,decoded)))) - (if (and (eq (nth 6 ,decoded) ,day-of-week) - (between (nth 3 ,decoded) - (+ ,days-in-month ,(* count 7)) - (+ ,days-in-month ,(* (1+ count) 7)))) - t - nil)))) - (t - (error "COUNT out of range, COUNT=%S" count))) - (error "Invalid argument to ledger-auto-day-in-month-macro %S %S" - count - day-of-week))) - -(defmacro ledger-auto-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." - ;; Do bounds checking to make sure the incoming date constraint is sane - (if - (if (eval month) ;; if we have a month - (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 31)) ;; no month specified, assume 31 days. - `'(and ,(if (eval year) - `(if (eq (nth 5 (decode-time date)) ,(eval year)) t) - `t) - ,(if (eval month) - `(if (eq (nth 4 (decode-time date)) ,(eval month)) t) - `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)))) - - - -(defmacro ledger-auto-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))))) - (if (eq start-day day-of-week) ;; good, can proceed - `(if (zerop (mod (- (time-to-days date) ,(time-to-days (eval start-date))) ,(* skip 7))) - t - nil) - (error "START-DATE day of week doesn't match DAY-OF-WEEK")))) - -(defmacro ledger-auto-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)) - (target-day (gensym))) - `(let* ((,decoded (decode-time date)) - (,target-month (nth 4 decoded)) - (,target-day (nth 3 decoded))) - (and (and (> ,target-month ,month1) - (< ,target-month ,month2)) - (and (> ,target-day ,day1) - (< ,target-day ,day2)))))) - - -(defun ledger-auto-is-holiday (date) - "Return true if DATE is a holiday.") - -(defun ledger-auto-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 - (find-file-noselect auto-file) - (goto-char (point-min)) - (while (re-search-forward "^\\[\\(.*\\)\\] " nil t) - (let ((date-descriptor "") - (transaction nil) - (xact-start (match-end 0))) - (setq date-descriptors - (ledger-auto-read-descriptor-tree - (buffer-substring-no-properties - (match-beginning 0) - (match-end 0)))) - (forward-paragraph) - (setq transaction (list date-descriptors - (buffer-substring-no-properties - xact-start - (point)))) - (setq xact-list (cons transaction xact-list)))) - xact-list))) - -(defun ledger-auto-replace-brackets () - "Replace all brackets with parens" - (goto-char (point-min)) - (while (search-forward "]" nil t) - (replace-match ")" nil t)) - (goto-char (point-min)) - (while (search-forward "[" nil t) - (replace-match "(" nil t))) - -(defun ledger-auto-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 - ;; copy the descriptor string into a temp buffer for manipulation - (let (pos) - ;; Replace brackets with parens - (insert descriptor-string) - (ledger-auto-replace-brackets) - - (goto-char (point-max)) - ;; double quote all the descriptors for string processing later - (while (re-search-backward - (concat "\\(20[0-9][0-9]\\|[\*]\\)[/\\-]" ;; Year slot - "\\([\*EO]\\|[01][0-9]\\)[/\\-]" ;; Month slot - "\\([\*]\\|\\([0-3][0-9]\\)\\|" - "\\([0-5]" - "\\(\\(Su\\)\\|" - "\\(Mo\\)\\|" - "\\(Tu\\)\\|" - "\\(We\\)\\|" - "\\(Th\\)\\|" - "\\(Fr\\)\\|" - "\\(Sa\\)\\)\\)\\)") nil t) ;; Day slot - (goto-char - (match-end 0)) - (insert ?\") - (goto-char (match-beginning 0)) - (insert "\"" ))) - - ;; read the descriptor string into a lisp object the transform the - ;; string descriptor into useable things - (ledger-transform-auto-tree - (read (buffer-substring (point-min) (point-max)))))) - -(defun ledger-transform-auto-tree (tree) -"Takes a lisp list of date descriptor strings, TREE, and returns a string with a lambda function of date." -;; use funcall to use the lambda function spit out here - (if (consp tree) - (let (result) - (while (consp tree) - (let ((newcar (car tree))) - (if (consp newcar) - (setq newcar (ledger-transform-auto-tree (car tree)))) - (if (consp newcar) - (push newcar result) - (push (ledger-auto-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) - "Return a list with the year, month and day fields split" - (let ((fields (split-string descriptor-string "[/\\-]" t)) - constrain-year constrain-month constrain-day) - (if (string= (car fields) "*") - (setq constrain-year nil) - (setq constrain-year (car fields))) - (if (string= (cadr fields) "*") - (setq constrain-month nil) - (setq constrain-month (cadr fields))) - (if (string= (nth 2 fields) "*") - (setq constrain-day nil) - (setq constrain-day (nth 2 fields))) - (list constrain-year constrain-month constrain-day))) - -(defun ledger-string-to-number-or-nil (str) - (if str - (string-to-number str) - nil)) - -(defun ledger-auto-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 - year-constraint - month-constraint - day-constraint))) - -(defun ledger-auto-parse-date-descriptor (descriptor) - "Parse the date descriptor, return the evaluator" - (ledger-auto-compile-constraints - (ledger-auto-split-constraints descriptor))) - - -(defun ledger-auto-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 test-date (cdr candidate))))))) - items)) -;; -;; Test harnesses for use in ielm -;; -(defvar auto-items) - -(defun ledger-auto-test-setup () - (setq auto-items - (ledger-auto-scan-transactions "~/FinanceData/ledger-auto.ledger"))) - - -(defun ledger-auto-test-predict () - (let ((today (current-time)) - test-date items) - - (loop for day from 0 to ledger-auto-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) - -;;; ldg-auto.el ends here |