chatikbot/plugins/saver.lisp

(in-package :cl-user)
(defpackage chatikbot.plugins.saver
  (:use :cl :chatikbot.common))
(in-package :chatikbot.plugins.saver)

(defsetting *saver-notify-hour* 11 "Notify with upcoming payments and saves at this time")

(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 (ignore-errors (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))))
	   (month-days (month year)
	     (case month
	       (2 (if (leapp year) 29 28))
	       ((1 3 5 7 8 10 12) 31)
	       (otherwise 30)))
           (clamp-day-rule (day-rule month year)
             (destructuring-bind (lst &optional (min 0) max (step 1)) day-rule
               (let ((max-day (month-days month year)))
                 (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 def-min def-max)
             (destructuring-bind (lst &optional min max (step 1)) rule
	       (let ((min (or min def-min))
		     (max (or max def-max)))
		 (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) (decode-universal-time universal-time)
      (declare (ignore second minute hour))
      (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 (not dir))
                                                     (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 1 12))))
                  (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) 1
				   (month-days next-month next-year)))
                   next-month
                   next-year))))))))))

(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/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 (or (saver/payment-next-time payment moment nil) 0)
                            (or (saver/payment-started payment) 0))))
    (when next-payment
      (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 (unless (zerop total-income)
                                         (/ (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 (round (* periods (saver/payment-amount income)
                               (or payment-income-fracture 0))) 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))
       when cur-info
       summing (getf cur-info :saved-amount) into cur-saved and
       summing (getf cur-info :left-amount) into cur-left and
       summing (if (> (getf nxt-info :left-periods 0) 1)
                   (round (* (saver/payment-amount income)
                             (or (getf cur-info :payment-income-fracture) 0)))
                   (getf nxt-info :left-amount 0)) 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
    (multiple-value-bind (sec min hour day month year dow dst-p tz)
        (decode-universal-time universal-time)
      (declare (ignore sec min hour dow dst-p tz))
      (format nil "~4,'0D-~2,'0D-~2,'0D" year month day))))

;; 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)"))

(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 amount > 0, 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-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))


;; 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/payment-next-time p moment))))
                 (db/saver/get-not-notified-payments moment)
                 :key #'cdr))

(defun %saver/format-expense-notification (expense moment)
  (format nil "'~A' надо оплатить *~A* на сумму _~$_"
          (saver/payment-name expense)
          (%saver/format-time (saver/payment-next-time expense moment))
          (/ (saver/payment-amount expense) -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 (get-chat-timezone chat-id)))
    (>= (nth 2 (multiple-value-list (decode-universal-time moment tz)))
       *saver-notify-hour*)))

(defcron process-saver (:hour '*)
  (let ((moment (get-universal-time)))
    (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 &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-expense-info payment incomes moment)
             when info
             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)
                             (/ (getf info :left-amount) 100)
                             (%saver/format-time (saver/payment-next-time payment moment))
                             (getf info :left-periods))))
         (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)
                             (%saver/format-time (saver/payment-next-time payment moment))
                             (/ (getf info :next-save) 100)
                             (/ (saver/payment-amount payment) 100))))
         (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)))
    (if (find t payments :key #'saver/payment-income-p)
        (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))
    (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/payment-next-time payment (get-universal-time))
          (handler-case
              (db/saver/add-payment chat-id payment)
            (error () (bot-send-message chat-id (format nil "Платёж '~A' уже есть!"
                                                        (saver/payment-name payment)))))
          (saver/send-info chat-id))
        (bot-send-message chat-id "Неправильно. /saver add <title> <amount> <cron> [started]"))))

(defun saver/del-payment (chat-id args)
  (handler-case
      (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 (not (saver/payment-income-p payment))
                                       incomes
                                       (/ (getf (saver/get-expense-info payment incomes) :saved-amount)
                                          100)))
                          :parse-mode "markdown"))
    (error (e) (bot-send-message chat-id (format nil "/saver del <idx> [~A]" e)))))

;; Hooks
(def-message-cmd-handler handler-cmd-save (:save :saver)
  (if (null args)
      (saver/send-info chat-id)
      (case (keyify (car args))
        (:add (saver/add-payment chat-id (rest args)))
        (:del (saver/del-payment chat-id (rest args)))
        (t (bot-send-message chat-id "Надо /saver add ... или /saver del <idx>")))))