;;
;; members-base.scm
;;
;; Storage for member files.
;;
;; 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-base))

(module
 members-base
 (
  load-members
  find-member-by-id
  find-member-by-nick
  list-members-ids
  filter-members-by-predicate
  list-members-nicks
  members-base-stats
  print-members-base-info
  print-members-base-table
  print-members-base-stats
  get-free-members-ids
  print-members-ids-stats
  gen-member-id
  )

 (import scheme
	 (chicken base)
	 (chicken pathname)
	 (chicken sort)
	 (chicken string)
	 (chicken format)
	 (chicken random)
	 testing
	 utils
	 dictionary
	 member-parser
	 primes
	 member-record
	 ansi
	 period
	 month
	 configuration
	 progress
	 table
	 members-dir)
 
 ;; Returns a dictionary containing file-name, symlinks, id and info
 ;; keys. The info key contains whatever load-member-file from the
 ;; member-file module returns. The id key contains whatever is the
 ;; first 4-digit symbol in (cons fname aliases) list.
 (define (members-base-load-member mdir fname symlinks)
   (let* ((mr0 (make-member-record fname
				   (make-pathname mdir (symbol->string fname))
				   symlinks)))
     (load-member-file mr0)))

 ;; Loads members database, if the second argument is true, shows
 ;; progress. Members database is a dictionary with id being the key
 ;; (number) and member record being the value.
 (define (load-members dn . opts)
   (let ((progress? (and (not (null? opts))
			 (car opts))))
     (with-progress
      progress? "Loading-members " " ok."
      (let* ((fss (load-members-dir dn))
	     (mb0 (dict-map
		   (lambda (symfn symlinks)
		     (when progress?
		       (progress-advance "."))
		     (members-base-load-member dn
					       symfn
					       symlinks))
		   fss))
	     (mb1 (dict-reduce (make-dict)
			       (lambda (acc symfn mr)
				 (dict-set acc (dict-ref mr 'id) mr))
			       mb0))
	     (mb (dict-reduce '()
			      (lambda (acc id mr)
				(cons mr acc))
			      mb1)))
	mb))))

 ;; Gets member based by generic predicate
 (define (find-member-by-predicate mb pred)
   (let loop ((mdb mb))
     (if (null? mdb)
	 #f
	 (let ((mr (car mdb)))
	   (if (pred mr)
	       mr
	       (loop (cdr mdb)))))))

 ;; Returns member record found by id
 (define (find-member-by-id mb id)
   (find-member-by-predicate
    mb
    (lambda (mr)
      (eq? (dict-ref mr 'id) id))))

 ;; Returns member record found by id
 (define (find-member-by-nick mb nick)
   (find-member-by-predicate
    mb
    (lambda (mr)
      (string-ci=?
       (dict-ref
	(dict-ref mr 'info)
	'nick)
       nick))))

 ;; Returns all ids found in the database
 (define (list-members-ids mb)
   (map (lambda (mr) (dict-ref mr 'id)) mb))

 ;; Returns a list of members which match given predicate.
 (define (filter-members-by-predicate mb pred)
   (let loop ((mb mb)
	      (res '()))
     (if (null? mb)
	 res
	 (let ((mr (car mb)))
	   (loop (cdr mb)
		 (if (pred mr)
		     (cons mr res)
		     res))))))

 ;; Returns all nicks found in the database
 (define (list-members-nicks mb)
   (map (lambda (mr) (dict-ref (dict-ref mr 'info) 'nick)) mb))

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

 ;; Returns dictionary with statistics about the members base.
 (define (members-base-info mb)
   (let* ((di0 (make-dict))
	  (di1 (dict-set di0 'invalid
			 (filter-members-by-predicate mb
						      (compose not is-4digit-prime? member-id))))
	  (di2 (dict-set di1 'active
			 (filter-members-by-predicate mb member-active?)))
	  (di3 (dict-set di2 'suspended
			 (filter-members-by-predicate mb member-suspended?)))
	  (di4 (dict-set di3 'students
			 (filter-members-by-predicate mb member-student?)))
	  (di5 (dict-set di4 'destroyed
			 (filter-members-by-predicate mb member-destroyed?)))
	  (di6 (dict-set di5 'month (*current-month*)))
	  (di7 (dict-set di6 'total mb)))
     di7))

 ;; Returns a list two lists: keys, data.
 ;; Each data record contains values for all keys.
 (define (members-base-stats mb)
   (let ((keys '(month total active suspended students destroyed invalid)))
     (let mloop ((data '())
		 (month (*member-default-joined*)))
       (if (month<? month (*current-month*))
	   (let ((bi (parameterize ((*current-month* month))
		       (members-base-info mb))))
	     (let kloop ((row (list (dict-ref bi 'month)))
			 (keys (cdr keys)))
	       (if (null? keys)
		   (mloop (cons (reverse row) data)
			  (month-add month 1))
		   (kloop (cons (length (dict-ref bi (car keys))) row)
			  (cdr keys)))))
	   (list keys (reverse data))))))

 ;; 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 (dict-ref bi 'invalid))
	   (active-mrs (dict-ref bi 'active))
	   (suspended-mrs (dict-ref bi 'suspended))
	   (destroyed-mrs (dict-ref bi 'destroyed))
	   (student-mrs (dict-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-members-by-predicate
			 suspended-mrs
			 (lambda (mr)
			   (>= (member-suspended-months mr) 24)))))
	(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 (dict-ref bi 'total))
	  (invalid-mrs (dict-ref bi 'invalid))
	  (active-mrs (dict-ref bi 'active))
	  (suspended-mrs (dict-ref bi 'suspended))
	  (destroyed-mrs (dict-ref bi 'destroyed))
	  (student-mrs (dict-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-members-by-predicate
				 suspended-mrs
				 (lambda (mr)
				   (>= (member-suspended-months mr)
				       (*member-suspend-max-months*))))))
		(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)))))))

 ;; Returns all free ids
 (define (get-free-members-ids mb)
   (let ((ids (list-members-ids mb)))
     (filter
      (lambda (id)
	(not (member id ids)))
      (gen-all-4digit-primes))))

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

 ;; Generates random vector id.
 (define (gen-member-id mb)
   (let* ((fids (get-free-members-ids mb))
	  (vfids (list->vector fids)))
     (vector-ref vfids (pseudo-random-integer (vector-length vfids)))))

 )