Move sources to separate directory.

src/member-fees.scm

@@ -0,0 +1,185 @@
+;;
+;; 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
+			       )))
+ 
+ )