saver: multiple salaries

plugins/saver.lisp

@@ -3,9 +3,7 @@
 (defsetting *saver-default-timezone* -3 "Default timezone for *saver-notify-hour* calculation. GMT+3")
 (defsetting *saver-notify-hour* 11 "Notify with upcoming payments and saves at this time")
 
-(defstruct saver/payment name amount schedule started)
-
-(defun saver/parse-schedule (schedule)
+(defun %saver/parse-schedule (schedule)
   (labels ((parse (text &optional def-min def-max)
              (let ((dash-pos (position #\- text))
                    (star-pos (position #\* text))
@@ -24,7 +22,7 @@
             (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))
+(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))))
@@ -85,48 +83,78 @@
                    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 86400))
+(defstruct saver/payment name amount schedule started)
+
+(defun saver/payment-income-p (payment)
+  (> (saver/payment-amount payment) 0))
+
+(defun saver/payment-next-time (payment moment &optional (dir t))
+  (%saver/get-next-time (%saver/parse-schedule (saver/payment-schedule payment)) moment dir))
+
+(defun saver/payment-count-events (payment from to)
+  (loop for ut = (saver/payment-next-time payment from) then (saver/payment-next-time payment (+ ut 86400))
      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)
+(defun saver/find-next-payment (payments &optional (moment (get-universal-time)))
+  (loop for payment in payments
+     for next-time = (saver/payment-next-time payment moment)
+     with closest-time and closest-payment
+     when (and next-time
+               (or (null closest-time)
+                   (< next-time closest-time)))
+     do (setf closest-time next-time
+              closest-payment payment)
+     finally (return closest-payment)))
+
+(defun saver/get-expense-info (payment incomes &optional (moment (get-universal-time)))
+  (let* ((next-payment (saver/payment-next-time payment moment))
+         (prev-payment (max (saver/payment-next-time payment 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 :next-payment next-payment
-              :prev-payment prev-payment
-              :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
-      (loop for payment in payments
-         for cur-info = (saver/get-payment-info payment salary moment)
-         for next-info = (saver/get-payment-info payment salary next-salary)
-         summing (getf cur-info :saved-amount) into total-saved
-         summing (getf cur-info :left-amount) into total-left
-         summing (if (> (getf next-info :left-periods) 1)
-                     (getf next-info :period-amount)
-                     (getf next-info :left-amount)) into total-period
-         finally (return
-                   (list :next-salary next-salary
-                         :total-saved total-saved
-                         :total-left total-left
-                         :total-period total-period))))))
+      (multiple-value-bind (total-periods total-income)
+          (loop for income in incomes
+             for periods = (saver/payment-count-events income prev-payment next-payment)
+             summing periods into total-periods
+             summing (* periods (saver/payment-amount income)) into total-income
+             finally (return (values total-periods total-income)))
+        (let ((payment-income-fracture (/ (saver/payment-amount payment) total-income -1)))
+          (loop for income in incomes
+             for periods = (saver/payment-count-events income prev-payment moment)
+             summing periods into saved-periods
+             summing (floor (* periods (saver/payment-amount income)
+                               payment-income-fracture)) into saved-amount
+             finally (return
+                       (list :next-payment next-payment
+                             :prev-payment prev-payment
+                             :total-periods total-periods
+                             :total-income total-income
+                             :payment-income-fracture payment-income-fracture
+                             :saved-periods saved-periods
+                             :saved-amount (if (= total-periods saved-periods)
+                                               (* -1 (saver/payment-amount payment))
+                                               saved-amount)
+                             :left-periods (- total-periods saved-periods)
+                             :left-amount (if (= total-periods saved-periods) 0
+                                              (- (- 0 (saver/payment-amount payment))
+                                                 saved-amount))))))))))
+
+
+(defun saver/get-income-info (income payments &optional (moment (get-universal-time)))
+  (let ((incomes (remove-if-not #'saver/payment-income-p payments))
+        (expenses (remove-if #'saver/payment-income-p payments)))
+    (loop for payment in expenses
+       for cur-info = (saver/get-expense-info payment incomes moment)
+       for nxt-info = (saver/get-expense-info payment incomes (saver/payment-next-time income moment))
+       summing (getf cur-info :saved-amount) into cur-saved
+       summing (getf cur-info :left-amount) into cur-left
+       summing (if (> (getf nxt-info :left-periods) 1)
+                   (floor (* (saver/payment-amount income) (getf cur-info :payment-income-fracture)))
+                   (getf nxt-info :left-amount)) into next-save
+       finally (return
+                 (list :cur-saved cur-saved
+                       :cur-left cur-left
+                       :next-save next-save)))))
 
 (defun %saver/format-time (universal-time)
   (when universal-time
@@ -138,9 +166,7 @@
 ;; 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)"))
+    (db-execute "create unique index if not exists saver_payments_chat_id_name_idx on saver_payments (chat_id, name)"))
 
 (defun %db/saver/make-payment (row)
   (when row
@@ -151,15 +177,7 @@
 
 (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/get-not-notified-payments (notified)
-  (loop for row in (db-select "select name, amount, schedule, started, chat_id from saver_payments where notified is null or notified != ?" (%saver/format-time notified))
-     collect (cons (nth 4 row) (%db/saver/make-payment row))))
-
-(defun db/saver/set-payment-notified (chat-id name moment)
-  (db-execute "update saver_payments set notified = ? where chat_id = ? and name = ?"
-              (%saver/format-time moment) chat-id name))
+          (db-select "select name, amount, schedule, started from saver_payments where chat_id = ? order by amount > 0, started" chat-id)))
 
 (defun db/saver/add-payment (chat-id payment)
   (with-slots (name amount schedule started) payment
@@ -169,128 +187,110 @@
 (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/get-not-notified-salaries (notified)
-  (loop for row in (db-select "select chat_id, schedule from saver_salaries where notified is null or notified != ?" (%saver/format-time notified))
-     collect (cons (nth 0 row) (nth 1 row))))
+(defun db/saver/get-not-notified-payments (notified)
+  (loop for row in (db-select "select name, amount, schedule, started, chat_id from saver_payments where notified is null or notified != ?" (%saver/format-time notified))
+     collect (cons (nth 4 row) (%db/saver/make-payment row))))
 
-(defun db/saver/set-salary-notified (chat-id moment)
-  (db-execute "update saver_salaries set notified = ? where chat_id = ?"
-              (%saver/format-time moment) chat-id))
+(defun db/saver/set-payment-notified (chat-id name moment)
+  (db-execute "update saver_payments set notified = ? where chat_id = ? and name = ?"
+              (%saver/format-time moment) chat-id name))
 
-(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
 (defun saver/find-today-payments (&optional (moment (get-universal-time)))
   (remove-if-not (lambda (p) (string= (%saver/format-time moment)
                                       (%saver/format-time
-                                       (saver/get-next-time
-                                        (saver/parse-schedule (saver/payment-schedule p))
-                                        moment))))
+                                       (saver/payment-next-time p moment))))
                  (db/saver/get-not-notified-payments moment)
                  :key #'cdr))
 
-(defun %saver/format-payment-notification (payment moment)
+(defun %saver/format-expense-notification (expense moment)
   (format nil "'~A' надо оплатить *~A* на сумму _~$_"
-          (saver/payment-name payment)
-          (%saver/format-time moment)
-          (/ (saver/payment-amount payment) 100)))
-
-(defun saver/find-today-salaries (&optional (moment (get-universal-time)))
-  (remove-if-not (lambda (p) (string= (%saver/format-time moment)
-                                      (%saver/format-time (saver/get-next-time
-                                                           (saver/parse-schedule p) moment))))
-                 (db/saver/get-not-notified-salaries moment)
-                 :key #'cdr))
+          (saver/payment-name expense)
+          (%saver/format-time (saver/payment-next-time expense moment))
+          (/ (saver/payment-amount expense) -100)))
 
-(defun %saver/format-salary-notification (salary payments moment)
-  (let ((period-info (saver/get-period-info salary payments moment)))
-    (format nil "*~A* зарплата. Отложи _~$_!"
-            (%saver/format-time (getf period-info :next-salary))
-            (/ (getf period-info :total-period) 100))))
+(defun %saver/format-income-notification (income payments moment)
+  (let ((income-info (saver/get-income-info income payments moment)))
+    (format nil "*~A* ~A. Отложи _~$_!"
+            (%saver/format-time (saver/payment-next-time income moment))
+            (saver/payment-name income)
+            (/ (getf income-info :next-save) 100))))
 
 (defun %saver/is-ok-to-notify (chat-id &optional (moment (get-universal-time)))
-  (let ((tz (or
-             (when (boundp '*chat-locations*)
-               (let ((chat-loc (aget chat-id (symbol-value '*chat-locations*))))
-                 (when chat-loc
-                   (round (- 7.5 (aget "latitude" chat-loc)) 15)))) ;; Nautical time
-             *saver-default-timezone*)))
+  (let ((tz (or (alexandria:when-let
+                    (chat-loc (aget chat-id (and (boundp '*chat-locations*) (symbol-value '*chat-locations*))))
+                  (round (- 7.5 (aget "latitude" chat-loc)) 15)) ;; Nautical time
+                *saver-default-timezone*)))
     (>= (nth 2 (multiple-value-list (decode-universal-time moment tz)))
        *saver-notify-hour*)))
 
 (defcron process-saver (:hour '*)
   (let ((moment (get-universal-time)))
-    (dolist (cp (saver/find-today-payments moment))
-      (when (%saver/is-ok-to-notify (car cp) moment)
-        (db-transaction
-          (bot-send-message (car cp) (%saver/format-payment-notification (cdr cp) moment) :parse-mode "markdown")
-          (db/saver/set-payment-notified (car cp) (saver/payment-name (cdr cp)) moment))))
-    (dolist (cs (saver/find-today-salaries moment))
-      (when (%saver/is-ok-to-notify (car cs) moment)
-        (db-transaction
-          (bot-send-message (car cs)
-                            (%saver/format-salary-notification (cdr cs)
-                                                               (db/saver/get-payments (car cs))
-                                                               moment)
-                            :parse-mode "markdown")
-          (db/saver/set-salary-notified (car cs) moment))))))
+    (loop for (chat-id . payment) in (saver/find-today-payments moment)
+       when (%saver/is-ok-to-notify chat-id moment)
+       do (let ((payments (db/saver/get-payments chat-id)))
+            (db-transaction
+              (bot-send-message chat-id
+                                (if (saver/payment-income-p payment)
+                                    (%saver/format-income-notification payment payments moment)
+                                    (%saver/format-expense-notification payment moment))
+                                :parse-mode "markdown")
+              (db/saver/set-payment-notified chat-id (saver/payment-name payment) moment))))))
 
 
 ;; Bot subcommands
-(defun %saver/format-info (payments salary &optional (moment (get-universal-time)))
-  (let* (closest-time
-         closest-payment
-         (payments-info
-          (loop for payment in payments
+(defun %saver/format-info (payments &optional (moment (get-universal-time)))
+  (let* ((expenses (remove-if #'saver/payment-income-p payments))
+         (incomes (remove-if-not #'saver/payment-income-p payments))
+         (expenses-info
+          (loop for payment in expenses
              for idx from 1
-             for info = (saver/get-payment-info payment salary moment)
+             for info = (saver/get-expense-info payment incomes moment)
              when info
-             when (or (null closest-time)
-                      (< (getf info :next-payment) closest-time))
-             do (setf closest-time (getf info :next-payment)
-                      closest-payment payment)
-             collect (format nil "~D) ~A по [[~A]]: накоплено _~$_ из _~$_, осталось _~$_ за ~A платежа"
+             collect (format nil "~D) ~A по [[~A]]: накоплено _~$_ из _~$_, осталось _~$_ к *~A* за ~A платежа"
                              idx
                              (saver/payment-name payment)
                              (saver/payment-schedule payment)
                              (/ (getf info :saved-amount) 100)
-                             (/ (saver/payment-amount payment) 100)
+                             (/ (saver/payment-amount payment) -100)
                              (/ (getf info :left-amount) 100)
+                             (%saver/format-time (saver/payment-next-time payment moment))
                              (getf info :left-periods))))
-        (period-info (saver/get-period-info salary payments moment)))
-    (if payments-info
-        (format nil "*Платежи*~%~{~A~^~%~}~%~%Накоплено должно быть _~$_~%Следующее накопление *~A* на _~$_~%Следующий платёж '~A' *~A*, _~$_"
-                payments-info
-                (/ (getf period-info :total-saved) 100)
-                (%saver/format-time (getf period-info :next-salary))
-                (/ (getf period-info :total-period) 100)
-                (saver/payment-name closest-payment)
-                (%saver/format-time closest-time)
-                (/ (saver/payment-amount closest-payment) 100))
+         (closest-expense (saver/find-next-payment expenses moment))
+         (incomes-info
+          (loop for payment in incomes
+             for idx from (1+ (length expenses))
+             for info = (saver/get-income-info payment payments moment)
+             when info
+             collect (format nil "~D) ~A по [[~A]]: отложить _~$_ *~A*"
+                             idx
+                             (saver/payment-name payment)
+                             (saver/payment-schedule payment)
+                             (/ (getf info :next-save) 100)
+                             (%saver/format-time (saver/payment-next-time payment moment)))))
+         (closest-income (saver/find-next-payment incomes moment))
+         (closest-income-info (and closest-income (saver/get-income-info closest-income payments moment))))
+    (if (or expenses-info incomes-info)
+        (format nil "*Платежи*~%~{~A~^~%~}~%*Следующий платёж*~%'~A' *~A*, заплатить _~$_~%~%*Накопления*~%~{~A~^~%~}~%*Следующее накопление*~%'~A' *~A*, отложить _~$_~%~%*Накоплено должно быть* _~$_"
+                expenses-info
+                (and closest-expense (saver/payment-name closest-expense))
+                (and closest-expense (%saver/format-time (saver/payment-next-time closest-expense moment)))
+                (and closest-expense (/ (saver/payment-amount closest-expense) -100))
+                incomes-info
+                (and closest-income (saver/payment-name closest-income))
+                (and closest-income (%saver/format-time (saver/payment-next-time closest-income moment)))
+                (and closest-income-info (/ (getf closest-income-info :next-save) 100))
+                (and closest-income-info (/ (getf closest-income-info :cur-saved) 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
-            (bot-send-message chat-id (%saver/format-info payments salary) :parse-mode "markdown")
-            (bot-send-message chat-id (format nil "Платежей нет, зарплата: ~A" salary)))
-        (send-response chat-id "Зарплата не задана, /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 "Зарплата теперь '~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}))?$"))
+  (let ((payments (db/saver/get-payments chat-id)))
+    (if payments
+        (bot-send-message chat-id (%saver/format-info payments) :parse-mode "markdown")
+        (bot-send-message chat-id (format nil "Платежей нет, /saver add ...")))))
+
+(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))
@@ -305,25 +305,26 @@
                                                                      #\- (elt groups 3)))
                                                           (encode-universal-time 0 0 0 day month year))
                                                         (get-universal-time)))))
-          (saver/get-next-time (saver/parse-schedule (saver/payment-schedule payment))
-                               (get-universal-time))
+          (saver/payment-next-time payment (get-universal-time))
           (handler-case
               (db/saver/add-payment chat-id payment)
-            (error (e) (send-response chat-id (format nil "Платёж '~A' уже есть!"
+            (error () (send-response chat-id (format nil "Платёж '~A' уже есть!"
                                                       (saver/payment-name payment)))))
           (saver/send-info chat-id))
         (send-response chat-id "Неправильно. /saver add <title> <amount> <cron> [started]"))))
 
 (defun saver/del-payment (chat-id args)
   (handler-case
-      (let ((payment (elt (db/saver/get-payments chat-id) (1- (parse-integer (car args)))))
-            (salary (db/saver/get-salary chat-id)))
+      (let* ((payments (db/saver/get-payments chat-id))
+             (payment (elt payments (1- (parse-integer (car args)))))
+             (incomes (remove-if-not #'saver/payment-income-p payments)))
         (db/saver/del-payment chat-id (saver/payment-name payment))
         (bot-send-message chat-id
                           (format nil "'~A' удалил.~@[ Забрать _~$_ из накопленого.~]"
                                   (saver/payment-name payment)
-                                  (and salary
-                                       (/ (getf (saver/get-payment-info payment salary) :saved-amount)
+                                  (and (not (saver/payment-income-p payment))
+                                       incomes
+                                       (/ (getf (saver/get-expense-info payment incomes) :saved-amount)
                                           100)))
                           :parse-mode "markdown"))
     (error (e) (send-response chat-id (format nil "/saver del <idx> [~A]" e)))))
@@ -333,7 +334,6 @@
   (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 "Чот не понял")))))
+        (t (send-response chat-id "Надо /saver add ... или /saver del <idx>")))))