(import (scheme base)
        (scheme file)
        (scheme cxr)
        (scheme char)
        (scheme time)
        (srfi 13)
        (scm datetime)
        (scm module)
        (scm compile)
        (scm system)
        (scm fs)
        (scm io)
        (scm list))

(define script-dir (directory-name (absolute-path script-name)))
(define base-dir (directory-name script-dir))
(module-search-path! (list (join-path base-dir "scm")))

(import (splg utils)
        (splg options)
        (splg grouper)
        (splg case filter)
        (splg license))

(define *batch-size* 500)
(define *cpu-cores* (sys-num-cpu-cores))
(define *max-cases* #f)

(define fmts
  '(excel csv json xml scm))

(define (valid-fmt? fmt) (memq fmt fmts))

(define splits
  '(no burnr burnr-plz kanton kanton-burnr kanton-burnr-plz
       kanton-plz kanton-skz kanton-sn plz skz sn wohnkanton
       burnr-wohnkanton skz-wohnkanton sn-wohnkanton))

(define (valid-split? split) (memq split splits))

(define languages '(de fr it))

(define (valid-language? lang) (memq lang languages))

(define (valid-path? path)
  (or (directory-exists? path)
      (file-exists? path)))

(define (valid-dir? dir)
  (directory-exists? dir))

(define (valid-file? dir)
  (file-exists? dir))

(define (valid-int? s)
  (string->integer s))

(define (string->integer s)
  (let ((n (string->number s)))
    (if (and n (integer? n))
        (exact n)
        #f)))

(define (parse-options args)
  (define (options-with-output-dir options)
    (let ((input (get-property options 'input))
          (output-dir (get-property options 'output-dir)))
      (if (not output-dir)
          (if (file-exists? input)
              ;; we have a file as input, set output to subfolder
              ;; of containing directory
              (set-option options 'output-dir
                          (join-path (directory-name input) "output"))
              ;; we have a dir as input, set output to subfolder
              (set-option options 'output-dir
                          (join-path input "output")))
          options)))
  (let loop ((args args)
             (options `((cfg-dir ,(join-path base-dir "cfg"))
                        (input ,(join-path "data" "input"))
                        (output-dir #f)
                        (parameters ,args)
                        (spitallisten ())
                        (inline-sls ())
                        (max-cases ,*max-cases*)
                        (batch-size ,*batch-size*)
                        (parallel ,*cpu-cores*)
                        (fmt excel)
                        (filter-cases-sl #f)
                        (case-filters ())
                        (year-shift #f))))
    (if (null? args)
        (options-with-output-dir options)
        (let ((arg (car args)))
          (cond ((equal? arg "--cfg-dir")
                 (let ((dir (cadr args)))
                   (if (valid-dir? dir)
                       (loop (cddr args) (set-option options 'cfg-dir dir))
                       (begin
                         (format #t "Invalid --cfg-dir ~a~%" dir)
                         #f))))
                ((equal? arg "--input")
                 (let ((path (cadr args)))
                   (if (valid-path? path)
                       (loop (cddr args) (set-option options 'input path))
                       (begin
                         (format #t "Invalid --input ~a~%" path)
                         #f))))
                ((equal? arg "--input-dir")
                 (let ((path (cadr args)))
                   (if (valid-dir? path)
                       (loop (cddr args) (set-option options 'input path))
                       (begin
                         (format #t "Invalid --input-dir ~a~%" path)
                         #f))))
                ((equal? arg "--input-file")
                 (let ((path (cadr args)))
                   (if (valid-file? path)
                       (loop (cddr args) (set-option options 'input path))
                       (begin
                         (format #t "Invalid --input-file ~a~%" path)
                         #f))))
                ((equal? arg "--output")
                 (loop (cddr args)
                       (set-option options 'output-dir (cadr args))))
                ((equal? arg "--output-dir")
                 (loop (cddr args)
                       (set-option options 'output-dir (cadr args))))
                ((equal? arg "--release")
                 (loop (cddr args)
                       (set-option options 'release
                                   (string->symbol (cadr args)))))
                ((equal? arg "--spitalliste")
                 (loop (cddr args)
                       (set-option options 'spitallisten
                                   (append (get-property options 'spitallisten)
                                           (list (cadr args))))))
                ((equal? arg "--sl")
                 (loop (cddr args)
                       (set-option options 'inline-sls
                                   (append (get-property options 'inline-sls)
                                           (list (cadr args))))))
                ((equal? arg "--wohnkanton-override")
                 (loop (cddr args)
                       (set-option options 'wohnkanton-override
                                   (string->symbol (cadr args)))))
                ((equal? arg "--max-cases")
                 (if (or (equal? (cadr args) "#f")
                         (equal? (cadr args) "all"))
                     (loop (cddr args)
                           (set-option options 'max-cases #f))
                     (loop (cddr args)
                           (set-option options 'max-cases
                                       (string->number (cadr args))))))
                ((equal? arg "--parallel")
                 (let ((n (string->integer (cadr args))))
                   (if n
                       (loop (cddr args) (set-option options 'parallel n))
                       (begin
                         (format #t "Invalid --parallel ~a~%" (cadr args))
                         #f))))
                ((equal? arg "--batch-size")
                 (let ((n (string->integer (cadr args))))
                   (if n
                       (loop (cddr args) (set-option options 'batch-size n))
                       (begin
                         (format #t "Invalid --batch-size ~a~%" (cadr args))
                         #f))))
                ((equal? arg "--fmt")
                 (let ((fmt (string->symbol (cadr args))))
                   (if (valid-fmt? fmt)
                       (loop (cddr args) (set-option options 'fmt fmt))
                       (begin
                         (format #t "Invalid --fmt ~a~%" (cadr args))
                         (format #t "Valid formats: ~a~%" (string-join fmts ", "))
                         #f))))
                ((equal? arg "--fmt-gaf")
                 (let ((fmt (string->symbol (cadr args))))
                   (if (valid-fmt? fmt)
                       (loop (cddr args) (set-option options 'fmt-gaf fmt))
                       (begin
                         (format #t "Invalid --fmt-gaf ~a~%" (cadr args))
                         (format #t "Valid formats: ~a~%" (string-join fmts ", "))
                         #f))))
                ((equal? arg "--fmt-splg")
                 (let ((fmt (string->symbol (cadr args))))
                   (if (valid-fmt? fmt)
                       (loop (cddr args) (set-option options 'fmt-splg fmt))
                       (begin
                         (format #t "Invalid --fmt-splg ~a~%" (cadr args))
                         (format #t "Valid formats: ~a~%" (string-join fmts ", "))
                         #f))))
                ((equal? arg "--fmt-summary")
                 (let ((fmt (string->symbol (cadr args))))
                   (if (valid-fmt? fmt)
                       (loop (cddr args) (set-option options 'fmt-summary fmt))
                       (begin
                         (format #t "Invalid --fmt-summary ~a~%" (cadr args))
                         (format #t "Valid formats: ~a~%" (string-join fmts ", "))
                         #f))))
                ((equal? arg "--split")
                 (let ((split (string->symbol (cadr args))))
                   (if (valid-split? split)
                       (loop (cddr args) (set-option options 'split split))
                       (begin
                         (format #t "Invalid --split ~a~%" (cadr args))
                         (format #t "Valid splits: ~a~%" (string-join splits ", "))
                         #f))))
                ((equal? arg "--split-gaf")
                 (let ((split (string->symbol (cadr args))))
                   (if (valid-split? split)
                       (loop (cddr args) (set-option options 'split-gaf split))
                       (begin
                         (format #t "Invalid --split-gaf ~a~%" (cadr args))
                         (format #t "Valid splits: ~a~%" (string-join splits ", "))
                         #f))))
                ((equal? arg "--split-splg")
                 (let ((split (string->symbol (cadr args))))
                   (if (valid-split? split)
                       (loop (cddr args) (set-option options 'split-splg split))
                       (begin
                         (format #t "Invalid --split-splg ~a~%" (cadr args))
                         (format #t "Valid splits: ~a~%" (string-join splits ", "))
                         #f))))
                ((equal? arg "--gaf")
                 (if (and (not (null? (cdr args)))
                          (not (string-prefix? "--" (cadr args))))
                     (case (string->symbol (cadr args))
                       ((standard)
                        (loop (cddr args) (set-option options 'gaf 'standard)))
                       ((verbose)
                        (loop (cddr args) (set-option options 'gaf 'verbose)))
                       (else
                        (format #t "Invalid --gaf ~a~%" (cadr args))
                        #f))
                     (loop (cdr args) (set-option options 'gaf 'standard))))
                ((equal? arg "--tech-output")
                 (loop (cdr args) (set-option options 'tech-output #t)))
                ((equal? arg "--lang")
                 (let ((lang (string->symbol (cadr args))))
                   (if (valid-language? lang)
                       (loop (cddr args) (set-option options 'language lang))
                       (begin
                         (format #t "Invalid --lang ~a~%" (cadr args))
                         (format #t "Valid languages: ~a~%"
                                 (string-join (map symbol->string languages) ", "))
                         #f))))
                ((equal? arg "--filter-cases-sl")
                 (loop (cdr args) (set-option options 'filter-cases-sl #t)))
                ((equal? arg "--year-shift")
                 (loop (cdr args) (set-option options 'year-shift #t)))
                ((and (string-prefix? "--filter-" arg)
                      (member (substring arg 9 (string-length arg))
                              (case-filter-field-names)))
                 (let* ((suffix (substring arg 9 (string-length arg)))
                        (raw (cadr args))
                        (parsed (parse-case-filter-option suffix raw)))
                   (cond ((procedure? parsed)
                          (loop (cddr args)
                                (set-option options 'case-filters
                                            (append
                                             (get-property options 'case-filters)
                                             (list (cons suffix parsed))))))
                         (else
                          (format #t "~a~%" parsed)
                          #f))))
                ((equal? arg "--profile")
                 (loop (cdr args) (set-option options 'profile #t)))
                ((equal? arg "--quiet")
                 (loop (cdr args) (set-option options 'quiet #t)))
                ((equal? arg "--skip-case-log")
                 (loop (cdr args) (set-option options 'skip-case-log #t)))
                ((equal? arg "--help")
                 (display-help)
                 #f)
                ((equal? arg "--version")
                 (format #t "~a~%" grouper-version)
                 #f)
                ((equal? arg "--license")
                 (let* ((cfgdir (get-property options 'cfg-dir))
                        (lic (find-license cfgdir)))
                   (if lic
                       (if (is-license-valid lic)
                           (let ((licensee (get-property lic 'licensee))
                                 (version (get-property lic 'version))
                                 (type (get-property lic 'type)))
                             (format #t "Valid license found (~a ~a ~a)~%"
                                     licensee type version))
                           (format #t "Invalid license found~%"))
                       (format #t "No license found~%")))
                 #f)
                (else
                 (format #t "Unknown option ~a~%" arg)
                 #f))))))

(define (display-help)
  (format #t "--input <path>~%")
  (format #t "--output-dir <dir>~%")
  (format #t "--release <release>~%")
  (format #t "    if omitted, the release is auto-detected from the input~%")
  (format #t "    files (first case per file: tarifsystem and austritt year)~%")
  (format #t "--spitalliste <file>~%")
  (format #t "--sl <string>~%")
  (format #t "    add an inline spitalliste entry; format:~%")
  (format #t "      burnr,plz,standort,referenz,kanton,year[,splg[:vfrom[:vto]],...]~%")
  (format #t "    repeatable to add multiple hospital entries~%")
  (format #t "--wohnkanton-override <kanton>~%")
  (format #t "--filter-cases-sl~%")
  (format #t "    only group cases with a burnr contained in the spitalliste~%")
  (format #t "--year-shift~%")
  (format #t "    simulate by shifting every case date field so the case~%")
  (format #t "    year matches the definition year; age/days preserved~%")
  (format #t "--filter-abc-fall <values>~%")
  (format #t "--filter-alter <values>~%")
  (format #t "--filter-wohnkanton <values>~%")
  (format #t "--filter-standortkanton <values>~%")
  (format #t "--filter-burnr <values>~%")
  (format #t "--filter-tarif <values>~%")
  (format #t "--filter-eintrittsdatum <values>~%")
  (format #t "--filter-austrittsdatum <values>~%")
  (format #t "--filter-eintrittsart <values>~%")
  (format #t "--filter-austrittsart <values>~%")
  (format #t "--filter-grundversicherung <values>~%")
  (format #t "    keep only cases matching the given case-field filters.~%")
  (format #t "    <values> is a comma-separated list (OR within an option).~%")
  (format #t "    Multiple --filter-* options are AND-combined.~%")
  (format #t "    --filter-alter accepts numbers or ranges (e.g. 18-65).~%")
  (format #t "    Date filters accept YYYYMMDD or YYYYMMDD-YYYYMMDD ranges.~%")
  (format #t "    --filter-tarif accepts abbreviations (case-insensitive):~%")
  (format #t "      akut=1,2  reha=3,4  psy=5,6~%")
  (format #t "      swissdrg=1  streha=3  tarpsy=5  pflegetaxe=7~%")
  (format #t "--fmt <fmt>~%")
  (format #t "    set general output format, one of:~%")
  (format #t "      excel,csv,json,xml,scm, default excel~%")
  (format #t "--fmt-splg <fmt>~%")
  (format #t "    set splg output format, one of:~%")
  (format #t "      excel,csv,json,xml,scm, default excel~%")
  (format #t "--fmt-gaf <fmt>~%")
  (format #t "    set gaf output format, one of:~%")
  (format #t "      excel,csv,json,xml,scm, default excel~%")
  (format #t "--fmt-summary <fmt>~%")
  (format #t "    set summary output format, one of:~%")
  (format #t "      excel,csv,json,xml,scm, default excel~%")
  (format #t "--gaf~%")
  (format #t "    enable standard gaf generation~%")
  (format #t "--gaf standard~%")
  (format #t "    enable standard gaf generation~%")
  (format #t "--gaf verbose~%")
  (format #t "    enable verbose gaf generation~%")
  (format #t "--split~%")
  (format #t "    set general split, one of:~%")
  (format #t "      no burnr burnr-plz kanton kanton-burnr kanton-burnr-plz~%")
  (format #t "      kanton-plz kanton-skz kanton-sn plz skz sn~%")
  (format #t "      wohnkanton burnr-wohnkanton sn-wohnkanton skz-wohnkanton~%")
  (format #t "--split-gaf~%")
  (format #t "    set gaf split, one of:~%")
  (format #t "      no burnr burnr-plz kanton kanton-burnr kanton-burnr-plz~%")
  (format #t "      kanton-plz kanton-skz kanton-sn plz skz sn~%")
  (format #t "      wohnkanton burnr-wohnkanton sn-wohnkanton skz-wohnkanton~%")
  (format #t "--split-splg~%")
  (format #t "    set splg split, one of:~%")
  (format #t "      no burnr burnr-plz kanton kanton-burnr kanton-burnr-plz~%")
  (format #t "      kanton-plz kanton-skz kanton-sn plz skz sn~%")
  (format #t "      wohnkanton burnr-wohnkanton sn-wohnkanton skz-wohnkanton~%")
  (format #t "--lang <de|fr|it>~%")
  (format #t "    set the language of the codetext column in the GAF output,~%")
  (format #t "    default de. Falls back to de if the requested language~%")
  (format #t "    text is missing for a code.~%")
  (format #t "--cfg-dir <path>~%")
  (format #t "--max-cases <n>~%")
  (format #t "--parallel <n>~%")
  (format #t "--batch-size <n>~%")
  (format #t "--tech-output~%")
  (format #t "--quiet~%")
  (format #t "--skip-case-log~%")
  (format #t "    do not write log-case.txt to the output directory~%")
  (format #t "--version~%")
  (format #t "--license~%")
  (format #t "--help~%")
  (format #t "--analyze-input <path>~%")
  (format #t "    scan the input directory and report file types and counts~%")
  (format #t "--convert-files <path>~%")
  (format #t "    convert non-native input files (e.g. spiges-csv) to the~%")
  (format #t "    native format in place~%")
  (format #t "--create-testcase-for <burnr> <fallid>~%")
  (format #t "    emit a testcase file for the matching case to~%")
  (format #t "    <output-dir>/testcase-<burnr>-<fallid>-<datetime>.txt~%")
  (format #t "--testcase <file>~%")
  (format #t "    read a testcase file, group it, write a fresh~%")
  (format #t "    testcase to standard output~%")
  (format #t "--service [--host <h>] [--port <n>]~%")
  (format #t "    start a local REST service on http://<host>:<port>/ that~%")
  (format #t "    accepts /version (GET) and /group/<release> (POST) requests~%"))


(let ((options (if (null? script-arguments)
                   (begin (display-help) #f)
                   (parse-options script-arguments))))
  (when options
    (let ((start-ts (timestamp))
          (result (run-grouper options)))
      (cond
       ((get-property options 'quiet)
        ;; nothing
        )
       ((get-property options 'tech-output)
        (format #t "ELAPSED|~a~%" (get-elapsed-seconds start-ts)))
       (else (elapsed start-ts)))
      result)))
