WIP: saver plugin

plugins/saver.lisp

@@ -0,0 +1,218 @@
+(in-package #:chatikbot)
+
+(defstruct saver/payment name amount schedule started)
+
+(defun saver/parse-schedule (schedule)
+  (labels ((parse (text &optional def-min def-max)
+             (let ((dash-pos (position #\- text))
+                   (star-pos (position #\* text))
+                   (slash-pos (position #\/ text)))
+               (if (or dash-pos star-pos slash-pos)
+                   (let ((min (if star-pos def-min
+                                  (when dash-pos (parse-integer text :end dash-pos))))
+                         (max (if star-pos def-max
+                                  (when dash-pos (parse-integer text :start (1+ dash-pos) :end slash-pos))))
+                         (step (or (when slash-pos (parse-integer text :start (1+ slash-pos))) 1)))
+                     (list nil min max step))
+                   (list (sort (mapcar #'parse-integer (split-sequence:split-sequence #\, text)) #'<))))))
+    (destructuring-bind (&optional day-sched month-sched year-sched)
+        (split-sequence:split-sequence #\Space schedule :remove-empty-subseqs t)
+      (list (if day-sched (parse day-sched 1 31) (list nil 1 31))
+            (if month-sched (parse month-sched 1 12) (list nil 1 12))
+            (if year-sched (parse year-sched 1900) (list nil 1900))))))
+
+(defun saver/get-next-time (schedule universal-time &optional (dir t))
+  (labels ((leapp (year)
+             (or (and (zerop (mod year 4))
+                      (not (zerop (mod year 100))))
+                 (zerop (mod year 400))))
+           (clamp-day-rule (day-rule month year)
+             (destructuring-bind (lst &optional (min 0) max (step 1)) day-rule
+               (let ((max-day (case month
+                                (2 (if (leapp year) 29 28))
+                                ((1 3 5 7 8 10 12) 31)
+                                (otherwise 30))))
+                 (if (consp lst)
+                     (list (remove-duplicates (mapcar (lambda (d) (min d max-day)) lst)))
+                     (list nil (min min) (when max (min max max-day)) step)))))
+           (next (from rule)
+             (destructuring-bind (lst &optional (min 0) max (step 1)) rule
+               (if (consp lst)
+                   (let ((nv (find from lst :test (if dir #'<= #'>=) :from-end (not dir))))
+                     (if nv
+                         (values nv nil)
+                         (values (car (if dir lst (last lst))) t)))
+                   (let* ((m (mod (- from min) step))
+                          (nv (if (zerop m) from
+                                  (funcall (if dir #'+ #'-) from
+                                           (if dir (- step m) m)))))
+                     (cond
+                       ((and max (> nv max))
+                        (if dir
+                            (values min t)
+                            (values max nil)))
+                       ((and min (< nv min))
+                        (if dir
+                            (values min nil)
+                            (values max t)))
+                       (t (values nv nil)))))))
+           (add (v of)
+             (funcall (if dir #'+ #'-) v (if of 1 0)))
+           (reset-rule (rule)
+             (destructuring-bind (lst &optional (min 0) max (step 1)) rule
+               (if (consp lst)
+                   (car (if dir lst (last lst)))
+                   (if dir min
+                       (let ((m (mod (- max min) step)))
+                         (- max (if (zerop m) 0 m))))))))
+    (multiple-value-bind (second minute hour day month year dow dst-p tz) (decode-universal-time universal-time)
+      (declare (ignore second minute hour dow dst-p tz))
+      (destructuring-bind (&optional (day-rule '(nil 1 31)) (month-rule '(nil 1 12)) (year-rule '(nil 1900)))
+          schedule
+        (multiple-value-bind (next-day of-day) (next (add day t) (clamp-day-rule day-rule month year))
+          (multiple-value-bind (next-month of-month) (next (add month of-day) month-rule)
+            (multiple-value-bind (next-year of-year) (next (add year of-month) year-rule)
+              (unless of-year
+                (let ((next-month (if (= next-year year) next-month (reset-rule month-rule))))
+                  (encode-universal-time
+                   0 0 0
+                   (if (and (= next-month month) (= next-year year)) next-day
+                       (reset-rule (clamp-day-rule day-rule next-month next-year)))
+                   next-month
+                   next-year))))))))))
+
+(defun saver/count-events (from to schedule)
+  (loop for ut = (saver/get-next-time schedule from) then (saver/get-next-time schedule ut)
+     while (< ut to)
+     counting ut))
+
+(defun saver/get-payment-info (payment salary &optional (moment (get-universal-time)))
+  (let* ((salary (saver/parse-schedule salary))
+         (schedule (saver/parse-schedule (saver/payment-schedule payment)))
+         (next-payment (saver/get-next-time schedule moment))
+         (prev-payment (max (saver/get-next-time schedule moment nil)
+                            (or (saver/payment-started payment) 0))))
+    (when next-payment
+      (let* ((total-periods (saver/count-events prev-payment next-payment salary))
+             (saved-periods (saver/count-events prev-payment moment salary))
+             (period-amount (floor (saver/payment-amount payment) (max 1 total-periods)))
+             (saved-amount (* saved-periods period-amount)))
+        (list :total-periods total-periods
+              :period-amount period-amount
+              :saved-periods saved-periods
+              :saved-amount saved-amount
+              :left-periods (- total-periods saved-periods)
+              :left-amount (- (saver/payment-amount payment) saved-amount))))))
+
+(defun saver/get-period-info (salary payments &optional (moment (get-universal-time)))
+  (let ((next-salary (saver/get-next-time (saver/parse-schedule salary) moment)))
+    (when next-salary
+      (let ((total-period-amount
+             (loop for payment in payments
+                for info = (saver/get-payment-info payment salary moment)
+                summing (if (> (getf info :left-periods) 1) (getf info :period-amount) (getf info :left-amount)))))
+        (list :next-salary next-salary :total-period-amount total-period-amount)))))
+
+;; Database
+(def-db-init
+    (db-execute "create table if not exists saver_payments (chat_id, name, amount, schedule, started, notified)")
+    (db-execute "create unique index if not exists saver_payments_chat_id_name_idx on saver_payments (chat_id, name)")
+    (db-execute "create table if not exists saver_salaries (chat_id, schedule, notified)")
+    (db-execute "create unique index if not exists saver_salaries_chat_id_idx on saver_salaries (chat_id)"))
+
+(defun %db/saver/make-payment (row)
+  (when row
+    (make-saver/payment :name (nth 0 row)
+                        :amount (nth 1 row)
+                        :schedule (nth 2 row)
+                        :started (nth 3 row))))
+
+(defun db/saver/get-payments (chat-id)
+  (mapcar #'%db/saver/make-payment
+          (db-select "select name, amount, schedule, started from saver_payments where chat_id = ? order by started" chat-id)))
+
+(defun db/saver/add-payment (chat-id payment)
+  (with-slots (name amount schedule started) payment
+    (db-execute "insert into saver_payments (chat_id, name, amount, schedule, started) values (?, ?, ?, ?, ?)"
+                chat-id name amount schedule started)))
+
+(defun db/saver/del-payment (chat-id name)
+  (db-execute "delete from saver_payments where chat_id = ? and name = ?" chat-id name))
+
+(defun db/saver/get-salary (chat-id)
+  (caar (db-select "select schedule from saver_salaries where chat_id = ?" chat-id)))
+
+(defun db/saver/set-salary (chat-id schedule)
+  (db-transaction
+    (db-execute "delete from saver_salaries where chat_id = ?" chat-id)
+    (db-execute "insert into saver_salaries (chat_id, schedule) values (?, ?)" chat-id schedule)))
+
+;; Cron
+;;;; TODO
+
+;; Hooks
+
+;; Bot subcommands
+(defun %saver/format-info (payments salary)
+  (let ((payments-info
+         (loop for payment in payments
+            for info = (saver/get-payment-info payment salary)
+            collect (format nil "~A on [~A]: saved ~$ of ~$, left ~$ in ~A periods"
+                            (saver/payment-name payment)
+                            (saver/payment-schedule payment)
+                            (/ (getf info :saved-amount) 100)
+                            (/ (saver/payment-amount payment) 100)
+                            (/ (getf info :left-amount) 100)
+                            (getf info :left-periods))))
+        (period-info (saver/get-period-info salary payments)))
+    (multiple-value-bind (sec min hour day month year dow dst-p tz)
+        (decode-universal-time (getf period-info :next-salary))
+      (declare (ignore sec min hour dow dst-p tz))
+      (format nil "~{~A~^~%~}~%~%Next save on ~4,'0D-~2,'0D-~2,'0D with ~$" payments-info
+              year month day (/ (getf period-info :total-period-amount) 100)))))
+
+(defun saver/send-info (chat-id)
+  (let ((payments (db/saver/get-payments chat-id))
+        (salary (db/saver/get-salary chat-id)))
+    (if salary
+        (if payments
+            (send-response chat-id (%saver/format-info payments salary))
+            (send-response chat-id (format nil "No payments yet, salary: ~A" salary)))
+        (send-response chat-id "No salary set, /saver salary <cron>"))))
+
+(defun saver/set-salary (chat-id args)
+  (let ((sched (spaced args)))
+    (saver/parse-schedule sched)
+    (db/saver/set-salary chat-id sched)
+    (send-response chat-id (format nil "Salary is now '~A'" sched))))
+
+(defparameter +saver/add-scanner+ (cl-ppcre:create-scanner "^(.+?) (\\d+(?:\\.\\d*)?) ((?:\\d+(?:,\\d+)*(?:-\\d+)?|\\*)(?:\\/\\d+)?(?: (?:\\d+(?:,\\d+)*(?:-\\d+)?|\\*)(?:\\/\\d+)?){0,2})(?: (\\d{4}-\\d{2}-\\d{2}))?$"))
+
+(defun saver/add-payment (chat-id args)
+  (multiple-value-bind (matched groups) (cl-ppcre:scan-to-strings +saver/add-scanner+ (spaced args))
+    (if matched
+        (let ((payment (make-saver/payment :name (elt groups 0)
+                                           :amount (round (* 100 (read-from-string (elt groups 1))))
+                                           :schedule (elt groups 2)
+                                           :started (if (elt groups 3)
+                                                        (destructuring-bind (year month day)
+                                                            (mapcar #'parse-integer
+                                                                    (split-sequence:split-sequence
+                                                                     #\- (elt groups 3)))
+                                                          (encode-universal-time 0 0 0 day month year))
+                                                        (get-universal-time)))))
+          (saver/parse-schedule (elt groups 2))
+          (db/saver/add-payment chat-id payment)
+          (saver/send-info chat-id))
+        (send-response chat-id "Bad format. /saver add <title> <amount> <cron> [started]"))))
+
+(defun saver/del-payment (chat-id args))
+
+(def-message-cmd-handler handler-cmd-save (:save :saver)
+  (if (null args)
+      (saver/send-info chat-id)
+      (case (keyify (car args))
+        (:salary (saver/set-salary chat-id (rest args)))
+        (:add (saver/add-payment chat-id (rest args)))
+        (:del (saver/del-payment chat-id (rest args)))
+        (t (send-response chat-id "Unknown command")))))

plugins/saver.org

@@ -0,0 +1,30 @@
+* Entities
+** payment schedule (name occurence amount)
+** payment (payment-schedule date )
+** transaction (amount date)
+
+* Use cases
+** Set income dates
+Store dates for periods calculations
+
+** Add payment
+Set name, schedule (due date), amount. System calculates required per-period payments to get the
+ amount till due date.
+
+** Transfer money to
+Update balance, top up all pending payments based on their calculated per-period payments
+
+** When payment is soon
+Alert user about the payment, decrease balance (transfer money from) and start saving for next
+payment instance based on schedule.
+
+** List payments
+Show pending payments with up-to-date savings and total balance.
+
+** Delete pending payment
+Show saved amount for this payment to remove from saving account. Income period requirements descreased.
+
+* Example
+Now it's 17th of April. I set up salary schedule on 5th and 20th of each month. Then add new
+recurring payment on 16th of April each year for 9000rub. This means we have 24 periods to save
+9000rub, meaning that we have to save 375rub per salary.

utils.lisp

@@ -139,6 +139,9 @@ is replaced with replacement."
          (cmd (subseq (car args) 0 (position #\@ (car args)))))
     (values (intern (string-upcase cmd) "KEYWORD") (rest args))))
 
+(defun spaced (list)
+  (format nil "~{~A~^ ~}" list))
+
 (defun http-default (url)
   (let ((uri (quri:uri url)))
     (quri:render-uri