hackerbase/member-fees.scm

;;
;; member-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 member-fees))

(module
 member-fees
 (
  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
  )

 (import scheme
	 (chicken base)
	 (chicken format)
	 (chicken sort)
	 configuration
	 member-record
	 month
	 ansi
	 table
	 members-base
	 period)

 ;; Convert into lookups - a list of (list period regular student)
 (define member-fees-lookup-table
   (make-period-lookup-table
    '(((2010 1) 500 250))))

 ;; Returns a matching list of (list regular student)
 (define (lookup-member-fees)
   (lookup-by-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 (period-since (car (member-record-info mr 'member)))))
     (let loop ((cm first-month)
		(cal '()))
       (if (month>? cm last-month)
	   (reverse cal)
	   (loop (month-add cm)
		 (cons (list cm
			     (parameterize ((*current-month* cm))
			       (member-flags 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 "  ") ; Suspended
	       (if (member 'destroyed (cadr e))
		   (ansi-string #:bgblack "~~") ; Destroyed
		   (if (member 'student (cadr e))
		       (ansi-string #:bgyellow "  ") ; Student
		       (ansi-string #:bggreen "  ")))) ; Normal
	   "  ") ; Nonexistent - should not happen
       "  ")) ; 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
		       (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 (month-year fm))
	      (ly (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-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 (member-record-info mr 'credit '()))
	  (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)))
     (table->string (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-border #f
			       #:row-border #t
			       #:col-border #t
			       #:ansi #t
			       )))
 
 )