;;
;; members-fees.scm
;;
;; Member fees manipulation.
;;
;; ISC License
;;
;; Copyright 2023 Brmlab, z.s.
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
;;
;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.
;; 
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
;;

(declare (unit members-fees))

(module
 members-fees
 (
  lookup-member-fee
  member-calendar
  member-calendar-first-month
  member-calendar-last-month
  member-calendar-query
  member-calendar->years-table
  member-calendar->fees
  member-fees-total
  member-credit-total
  member-calendar->table
  members-summary
  member-calendar-entry->fee
  )

 (import scheme
	 (chicken base)
	 (chicken format)
	 (chicken sort)
	 srfi-1
	 configuration
	 brmember
	 cal-month
	 ansi
	 table
	 mbase
	 cal-period
	 specification)

 ;; Returns a matching list of (list regular student)
 (define (lookup-member-fees)
   (lookup-by-cal-period member-fees-lookup-table))

 ;; Returns time-based fee for given type
 (define (lookup-member-fee type)
   (let ((fees (lookup-member-fees)))
     (if (eq? type 'student)
	 (cadr fees)
	 (car fees))))

 ;; Returns a list of months where each month is a list containing:
 ;; * month (from month module)
 ;; * flags - a list of symbols: student, suspended, destroyed
 ;; The list contains all months from 'joined until (*current-month*).
 (define (member-calendar mr . args)
   (let ((last-month (if (null? args)
			 (*current-month*)
			 (car args)))
	 (first-month (cal-ensure-month
		       (cal-period-since (car (brmember-info mr 'member))))))
     (let loop ((cm first-month)
		(cal '()))
       (if (cal-month>? cm last-month)
	   (reverse cal)
	   (loop (cal-month-add cm)
		 (cons (list cm
			     (with-current-month
			      cm
			      (brmember-flags mr))
			     (with-current-month
			      cm
			      (brmember-spec-fee mr)))
		       cal))))))

 ;; Returns the first month of the calendar
 (define (member-calendar-first-month mc)
   (caar mc))

 ;; Returns the last month of the calendar
 (define (member-calendar-last-month mc)
   (caar (reverse mc)))

 ;; Returns the calendar entry which matches given month or #f if none
 ;; found.
 (define (member-calendar-query mc m)
   (assoc m mc))

 ;; Formats the calendar entry for visualization
 (define (member-calendar-entry->string e)
   (if e
       (if (member 'existing (cadr e))
	   (if (member 'suspended (cadr e))
	       (ansi-string #:bgdarkgrey "\xc2\xa0\xc2\xa0") ; Suspended
	       (if (member 'destroyed (cadr e))
		   (ansi-string #:bgblack "\xc2\xa0\xc2\xa0") ; Destroyed
		   (if (member 'student (cadr e))
		       (ansi-string #:bgyellow "\xc2\xa0\xc2\xa0") ; Student
		       (if (caddr e)
			   (ansi-string #:bgblue (format "~a" (caddr e)))
			   (ansi-string #:bggreen "\xc2\xa0\xc2\xa0"))))) ; Normal
	   "\xc2\xa0\xc2\xa0") ; Nonexistent - should not happen
       "\xc2\xa0\xc2\xa0")) ; Nonexistent

 ;; Converts the entry into the fee
 (define (member-calendar-entry->fee e)
   (if e
       (if (member 'existing (cadr e))
	   (if (member 'suspended (cadr e))
	       0 ; Suspended
	       (if (member 'destroyed (cadr e))
		   0 ; Destroyed
		   (if (member 'student (cadr e))
		       (lookup-member-fee 'student) ; Student
		       (if (caddr e)
			   (caddr e)
			   (lookup-member-fee 'regular))))) ; Normal
	   0) ; Nonexistent - should not happen
       0)) ; Nonexistent

 ;; Converts the calendar into a table where rows represent years and
 ;; contain the year in the first cell and 12 cells for months after
 ;; it.
 (define (member-calendar->years-table mc)
   (if (null? mc)
       '()
       (let* ((fm (member-calendar-first-month mc))
	      (lm (member-calendar-last-month mc))
	      (fy (cal-month-year fm))
	      (ly (cal-month-year lm)))
	 (let loop ((y fy)
		    (rows '()))
	   (if (> y ly)
	       (reverse rows)
	       (loop (add1 y)
		     (cons (let mloop ((m 1)
				       (row (list y)))
			     (if (> m 12)
				 (reverse row)
				 (mloop (add1 m)
					(cons (member-calendar-entry->string
					       (member-calendar-query mc (make-cal-month y m)))
					      row))))
			   rows)))))))

 ;; Converts the whole calendar into a list of amounts (fees)
 (define (member-calendar->fees mc)
   (map member-calendar-entry->fee mc))

 ;; Returns the total sum of fees for all months relevant for given
 ;; member
 (define (member-fees-total mr)
   (foldl + 0 (member-calendar->fees
	       (member-calendar mr))))

 ;; Total credit manually recorded in member record
 (define (member-credit-total mr)
   (let* ((credit (brmember-credit mr))
	  (amounts (map car credit)))
     (foldl + 0 amounts)))

 ;; Nicely print calendar for given member
 (define (member-calendar->table mr)
   (let* ((mc (member-calendar mr))
	  (fees (member-calendar->fees mc))
	  (data (cons (map (lambda (c)
			     (sprintf "\t~A\t" c))
			   (list "" 1 2 3 4 5 6 7 8 9 10 11 12))
		      (member-calendar->years-table mc))))
     (table->string data
		    #:ansi-reset? #t
		    #:border '(((light #:top #:left none) (light #:top none) ... (light #:top #:right none))
			       ((light #:left none) light ... (light #:right none)) ...
			       ((light #:bottom #:left none) (light #:bottom none) ... (light #:bottom #:right none)))
		    )))

 ;; Summarizes (cons students full) counts
 (define (members-summary mb)
   (let ((members (find-members-by-predicate mb brmember-active?)))
     (foldl (lambda (acc mr)
	      (cons (+ (car acc) (if (brmember-student? mr) 1 0))
		    (+ (cdr acc) (if (brmember-student? mr) 0 1))))
	    (cons 0 0)
	    members)))
 
 )