;;
;; members-print.scm
;;
;; Procedures working with complete member record (as loaded by the
;; members-base).
;;
;; 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-print))

(module
 members-print
 (
  print-member-info
  print-member-table
  print-member-source
  member-records->string
  print-members-base-info
  print-members-base-table
  print-members-base-stats
  print-members-ids-stats
  print-members-fees-table
  print-unpaired-table
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken sort)
	 (chicken format)
	 util-dict-list
	 member-record
	 month
	 util-list
	 table
	 listing
	 ansi
	 period
	 primes
	 members-base
	 configuration
	 bank-account
	 member-fees
	 members-payments)

 ;; Prints human-readable information
 (define (print-member-info mr)
   (let* ((id (ldict-ref mr 'id))
	  (aliases (ldict-ref mr 'symlinks))
	  (info (ldict-ref mr 'info))
	  (sinfo (sort info
		       (lambda (a b)
			 (string<?
			  (symbol->string (car a))
			  (symbol->string (car b)))))))
     (print "User " id " alias(es): "
	    (string-intersperse
	     (map symbol->string aliases)
	     ", "))
     (when (member-suspended? mr)
       (print "  Suspended for " (member-suspended-months mr) " months."))
     (newline)
     (let loop ((sinfo sinfo))
       (when (not (null? sinfo))
	 (let* ((kv (car sinfo))
		(k (car kv))
		(v (cdr kv)))
	   (loop (cdr sinfo)))))))

 ;; Returns nicely formatted table
 (define (member-info->table mr)
   (let* ((aliases (ldict-ref mr 'symlinks))
	  (mid (member-id mr))
	  (head (list (if (is-4digit-prime? mid)
			  (list "ID:" mid)
			  (list (ansi-string #:red #:bold "ID:")
				(ansi-string #:red #:bold (number->string mid) " (not prime)")))
		      (list (sprintf "Alias~A:" (if (> (length aliases) 1) "es" ""))
			    (string-intersperse (map symbol->string aliases) ", "))
		      (if (member-suspended? mr)
			  (list "Suspended for:"
				(let ((msm (member-suspended-months mr)))
				  (sprintf "~A month~A" msm
					   (if (> msm 1) "s" ""))))
			  #f)))
	  (info (ldict-ref mr 'info))
	  (sikeys (sort (ldict-keys info)
			(lambda (a b)
			  (string<?
			   (symbol->string a)
			   (symbol->string b)))))
	  (body (map (lambda (k)
		       (let ((v (ldict-ref info k)))
			 (case k
			   ((card desfire credit)
			    (list k 
				  (table->string
				   (map
				    (lambda (c)
				      (list (car c) (cdr c)))
				    v)
				   #:col-border #t)))
			   ((suspend student member)
			    (list k
				  (table->string
				   (cons (list "Since" "Until")
					 (map
					  (lambda (p)
					    (list
					     (string-append (month->string (period-since p)) " "
							    (or (period-scomment p) ""))
					     (string-append (month->string (period-before p)) " "
							    (or (period-bcomment p) ""))))
					  v))
				   #:col-border #t)))
			   (else
			    (if v
				(list k v)
				(list (ansi-string #:red #:bold (symbol->string k))
				      (ansi-string #:red #:bold "---")))))))
		     sikeys))
	  (mailman (list (list "Mailing Lists"
			       (string-intersperse (member-mailman mr) "\n"))))
	  (result (filter identity (append head body mailman))))
     (table->string result #:table-border #f #:row-border #t #:col-border #t #:ansi #t)))

 ;; Prints nicely formatted table
 (define (print-member-table mr)
   (print
    (table->string
     (list (list "Basic Information" "Payments" "Membership Status")
	   (list (member-info->table mr)
		 (member-payments->table mr)
		 (member-calendar->table mr))
	   )
     #:row0-border #t
     #:col-border #t))
   (let* ((balance (member-balance mr))
	  (fees (ldict-ref balance 'fees))
	  (credit (ldict-ref balance 'credit))
	  (payment (ldict-ref balance 'payment))
	  (total (- (+ credit payment) fees)))
     (print "Total fees: " fees)
     (print "Total credit: " credit)
     (print "Total payments: " payment)
     (print "Balance: " total)
     ))

 ;; Nicely prints the member source with any errors recorded.
 (define (print-member-source mr)
   (let* ((lines (member-source mr))
	  (file-name (ldict-ref mr 'file-name))
	  (hls (ldict-ref mr 'highlights '())))
     (print file-name ":")
     (print-source-listing
      lines
      hls
      #:context -1
      )))

 ;; Prints nicely printed payments
 (define (member-payments->table mr)
   (table->string (cons
		   (list "Var" "Amount" "Cur" "Date" "TrId")
		   (map (lambda (tr)
			  (list (sprintf "\t~A" (bank-transaction-varsym tr))
				(sprintf "\t~A" (bank-transaction-amount tr))
				(bank-transaction-currency tr)
				(bank-transaction-date tr)
				(bank-transaction-id tr)))
			(member-payments mr)))
		  #:row0-border #t
		  #:col-border #t
		  ))

 ;; Converts member records to string, optional arguments are format
 ;; and separator. Format defaults to "~N" and separator to ", ".
 (define (member-records->string mrs . args)
   (let ((fmt (if (null? args) "~N" (car args)))
	 (sep (if (or (null? args)
		      (null? (cdr args)))
		  ", "
		  (cadr args))))
     (string-intersperse
      (map (lambda (mr)
	     (member-format fmt mr))
	   mrs)
      sep)))

 ;; Basic information about members-base in human-readable form.
 (define (print-members-base-info mb)
   (let ((nicks (list-members-nicks mb))
	 (ids (list-members-ids mb)))
     (print "Known members: "
	    (length nicks))
     (let* ((bi (members-base-info mb))
	    (invalid-mrs (ldict-ref bi 'invalid))
	    (active-mrs (ldict-ref bi 'active))
	    (suspended-mrs (ldict-ref bi 'suspended))
	    (destroyed-mrs (ldict-ref bi 'destroyed))
	    (student-mrs (ldict-ref bi 'students)))
       (print a:success "  Active (" (length active-mrs) "): " a:default
	      (member-records->string (sort active-mrs member<?) "~N~E"))
       (print a:warning "  Suspended (" (length suspended-mrs) "): " a:default
	      (member-records->string (sort suspended-mrs member<?) "~N~E"))
       (print a:warning "  Destroyed (" (length destroyed-mrs) "): " a:default
	      (member-records->string (sort destroyed-mrs member<?) "~N~E"))
       (print a:highlight "  Students (" (length student-mrs) "): " a:default
	      (member-records->string (sort student-mrs member<?)))
       (let ((suspended2 (filter
			  (lambda (mr)
			    (>= (member-suspended-months mr) 24))
			  suspended-mrs)))
	 (when (not (null? suspended2))
	   (print (ansi #:magenta) "  Suspended for at least 24 months ("
		  (length suspended2) "): " a:default
		  (member-records->string (sort suspended2 member<?) "~N (~S)"))))
       (when (not (null? invalid-mrs))
	 (print a:error "  Invalid Id (" (length invalid-mrs) "): "
		(member-records->string (sort invalid-mrs member<?) "~N (~I)")
		a:default)))))

 ;; Helper function for pretty-formatting the filtered members lists
 ;; in a table.
 (define (members-table-row a:? label mrs fmt)
   (list (string-append "\t" a:? label)
	 (length mrs)
	 (ansi-paragraph-format
	  (member-records->string
	   (sort mrs member<?)
	   fmt)
	  60)))

 ;; Prints nicely aligned members base info
 (define (print-members-base-table mb)
   (let* ((bi (members-base-info mb))
	  (all-mrs (ldict-ref bi 'total))
	  (invalid-mrs (ldict-ref bi 'invalid))
	  (active-mrs (ldict-ref bi 'active))
	  (suspended-mrs (ldict-ref bi 'suspended))
	  (destroyed-mrs (ldict-ref bi 'destroyed))
	  (student-mrs (ldict-ref bi 'students)))
     (print "Known members: " (length all-mrs))
     (newline)
     (print
      (table->string
       (filter
	identity
	(list (list "Type" "Count" "List")
	      (members-table-row a:success "Active:" active-mrs "~N~E")
	      (members-table-row a:highlight "Students:" student-mrs "~N~E")
	      (members-table-row a:warning "Suspended:" suspended-mrs "~N~E")
	      (members-table-row a:warning "Destroyed:" destroyed-mrs "~N~E")
	      (let ((suspended2 (filter
				 (lambda (mr)
				   (>= (member-suspended-months mr)
				       (*member-suspend-max-months*)))
				 suspended-mrs)))
		(if (null? suspended2)
		    #f
		    (members-table-row (ansi #:magenta) "Suspended (long):" suspended2 "~N (~S)")))
	      ))
       #:ansi #t
       #:row-border #t
       #:col-border #t
       )))
   (let ((pmrs (filter-members-by-predicate mb member-has-problems?)))
     (when (not (null? pmrs))
       (newline)
       (print "Member files with errors (" (length pmrs) "): "
	      (string-intersperse
	       (map member-file-path pmrs)
	       ", "))))
   (let ((pmrs (filter-members-by-predicate mb (lambda (mr)
						 (and (member-has-highlights? mr)
						      (not (member-has-problems? mr)))))))
     (when (not (null? pmrs))
       (newline)
       (print "Member files with issues: "
	      (string-intersperse
	       (map member-file-path pmrs)
	       ", ")))))

 ;; Prints the stats in format used by gnuplot.
 (define (print-members-base-stats ms)
   (let ((keys (car ms))
	 (data (cadr ms)))
     (print "# " (string-intersperse (map symbol->string keys) " "))
     (let loop ((rows data))
       (when (not (null? rows))
	 (let* ((row (car rows))
		(month (month->string (car row)))
		(vals (cdr row)))
	   (print month " " (string-intersperse (map number->string vals) " "))
	   (loop (cdr rows)))))))

 ;; Prints statistics about allocated and unused valid/invalid IDs.
 (define (print-members-ids-stats MB)
   (print "Allocated IDs: "
	  (length (list-members-ids MB))
	  "/"
	  (length (gen-all-4digit-primes))
	  " ("
	  (length (get-free-members-ids MB))
	  " free)")
   (let ((iids (filter (compose not is-4digit-prime?) (list-members-ids MB))))
     (when (not (null? iids))
       (print "      Invalid: "
	      (length iids)
	      " ("
	      (string-intersperse
	       (map (lambda (id)
		      (let ((mr (find-member-by-id MB id)))
			(member-format
			 "~I - ~N"
			 mr)))
		    iids)
	       ", ")
	      ")"))))

 ;; Prints summary table of all fees and credits for all members
 (define (print-members-fees-table MB . ds)
   (let ((destroyed? (if (null? ds)
			 #f
			 (car ds))))
     (let* ((members ;; Pass 1
	     (map
	      (lambda (mr)
		(let* ((balance (member-balance mr))
		       (fees (ldict-ref balance 'fees))
		       (credit (ldict-ref balance 'credit))
		       (payment (ldict-ref balance 'payment))
		       (total (- (+ credit payment) fees)))
		  (list (member-nick mr)
			(if (member-suspended? mr)
			    'suspended
			    (if (member-student? mr)
				'student
				(if (member-destroyed? mr)
				    'destroyed
				    'active)))
			fees
			credit
			payment
			total
			balance
			)))
	      (sort
	       (if destroyed?
		   (members-base-members MB)
		   (filter (lambda (mr)
			     (not (member-destroyed? mr)))
			   (members-base-members MB)))
	       member<?)))
	    (balances (map (lambda (m)
			     (list-ref m 6))
			   members)))
       (print
	(table->string
	 (cons
	  (list (ansi-string #:bgblue #:brightyellow #:bold "Member")
		(ansi-string #:bgblue #:brightyellow #:bold "Status")
		(ansi-string #:bgblue #:brightyellow #:bold "Fees")
		(ansi-string #:bgblue #:brightyellow #:bold "Credit")
		(ansi-string #:bgblue #:brightyellow #:bold "Payments")
		(ansi-string #:bgblue #:brightyellow #:bold "Balance"))
	  (append
	   (map ;; Pass 2
	    (lambda (member)
	      (let ((total (list-ref member 5)))
		(list (list-ref member 0)
		      (list-ref member 1)
		      (sprintf "\t~A" (list-ref member 2))
		      (sprintf "\t~A" (list-ref member 3))
		      (sprintf "\t~A" (list-ref member 4))
		      (sprintf "\t~A~A~A"
			       (if (< total -500)
				   a:error
				   (if (< total 0)
				       a:warning
				       a:success))
			       (exact->inexact total)
			       a:default)
		      )))
	    members)
	   (let* ((fees (foldl + 0 (map (lambda (b) (ldict-ref b 'fees)) balances)))
		  (credit (foldl + 0 (map (lambda (b) (ldict-ref b 'credit)) balances)))
		  (payment (foldl + 0 (map (lambda (b) (ldict-ref b 'payment)) balances)))
		  (total (- (+ credit payment) fees)))
	     (list (list (ansi-string #:bold "Total")
			 ""
			 (ansi-string "\t" #:bold (sprintf "~A" fees))
			 (ansi-string "\t" #:bold (sprintf "~A" credit))
			 (ansi-string "\t" #:bold (sprintf "~A" payment))
			 (ansi-string "\t" #:bold
				      (sprintf "~A~A"
					       (if (< total 0)
						   a:error
						   a:success)
					       total))
			 )))))
	 #:col-border #t #:row0-border #t #:ansi #t))
       (print "Credit: "
	      (foldl + 0
		     (map (lambda (member)
			    (list-ref member 5))
			  members)))
       (print "Advance: "
	      (foldl + 0
		     (map (lambda (member)
			    (max 0 (list-ref member 5)))
			  members)))
       (print "Debt: "
	      (foldl + 0
		     (map (lambda (member)
			    (min 0 (list-ref member 5)))
			  members)))
       (let* ((ns (foldl (lambda (acc member)
			   (cons (+ (car acc) (if (eq? 'student (cadr member)) 1 0))
				 (+ (cdr acc) (if (eq? 'active (cadr member)) 1 0))))
			 (cons 0 0)
			 members))
	      (students (car ns))
	      (full (cdr ns)))
	 (print "Expected income: "
		(+ (* (lookup-member-fee 'normal) full)
		   (* (lookup-member-fee 'student) students))
		" (" full " full members + " students " students)"))
       )
     ))

 ;; Prints all transactions which the members base considers unpaired.
 (define (print-unpaired-table mb)
   (print
    (table->string
     (cons
      (list "Id" "Date" "Amount" "" "VS" "Type" "Message" "Account" "Bank")
      (map
       (lambda (tr)
	 (list (bank-transaction-id tr)
	       (bank-transaction-date tr)
	       (sprintf "\t~A" (bank-transaction-amount tr))
	       (bank-transaction-currency tr)
	       (sprintf "\t~A" (bank-transaction-varsym tr))
	       (bank-transaction-type tr)
	       (bank-transaction-message tr)
	       (bank-transaction-account tr)
	       (bank-transaction-bank tr)
	       ))
       (members-base-unpaired mb)))
     #:row0-border #t
     #:col-border #t)))

 )