#lang racket

;;; --------------------------------------------------------------------;;;
;;;                     kameindex v1.1 source code                      ;;;
;;; Author: Antoine Bossard (Kanagawa University, Japan)                ;;;
;;; Licence: MIT licence                                                ;;;
;;; Usage: kameindex indexfile.idx [stylefile.ist]                      ;;;
;;; Homepage: https://www.sci.kanagawa-u.ac.jp/info/abossard/kameindex/ ;;;
;;;                 Copyright (c) 2018-2019 - A. Bossard                ;;;
;;; --------------------------------------------------------------------;;;

; returns a list of entries, each of the form (key (pages) (ranges) (subentries)), ie. with one new or updated entry
(define (insert subitems pagenumber-format type entries)
  ; subitems: a non-empty list of entry keys, eg. ("hello" "ecole@école" ...)
  ; pagenumber, format, type: page or range number, number format (eg. "textit"), entry type (0: page, 1: range...)
  ; entries: a list of entries, each of the form (key (pages) (ranges) (subentries))

  ; search for an entry in entries whose key is the current entry key. If not found, entries-right is '()
  (let-values ([(entries-left entries-right)
                (splitf-at entries (lambda (e) (not (equal? (car subitems) (first e)))))])
    (if (null? entries-right)
        ; create a new entry (repeat entry creation until no more subitem)
        (let* ([items (reverse subitems)]
               [new-entry
                (foldl
                 (lambda (item acc) ; return a new entry with acc as (unique) subentry
                   (list item '() '() (list acc)))
                 ; initial value: the last entry, with page number and format
                 (if (= type 1)
                     (list (car items) '() (list pagenumber-format) '()) ; range
                     (list (car items) (list pagenumber-format) '() '())) ; page number (incl. see / see also cross-ref.)
                 (cdr items))]) ; all but the first item, which has been processed as initial value for fold
          (cons new-entry entries))
        ; existing entry: add a new page/range number or subentry
        (let* ([cur-entry (car entries-right)] ; current entry (ie. the one matching (car subitems))
               [new-entry ; create a new entry based on the current entry (ie. update page/range number or subentries)
                (if (null? (cdr subitems))
                    ; last subitem: recreate entry with a new page/range number
                    (if (= type 1) ; range
                        (list (first cur-entry) ; same key
                              (second cur-entry) ; same page numbers
                              (cons pagenumber-format (third cur-entry)) ; add a new range page number
                              (fourth cur-entry)) ; same subentries
                        ; otherwise, page number (incl. see / see also cross-ref.)
                        (list (first cur-entry) ; same key
                              (cons pagenumber-format (second cur-entry)) ; add a new page number
                              (third cur-entry) ; same range page numbers
                              (fourth cur-entry))) ; same subentries                    
                    ; not last subitem: recursively update subentries
                    (list (first cur-entry) ; same key as the current entry
                          (second cur-entry) ; same pages as the current entry
                          (third cur-entry) ; same ranges as the current entry
                          (insert (cdr subitems) pagenumber-format type (fourth cur-entry))) ; updated subentries
                    )])
          (cons new-entry (append entries-left (cdr entries-right))) ; return the new entries
          ))))

(define (merge entry)
  ; input: 1 entry, ie. of the form (key (pages) (ranges) (subentries))
  ; output: 1 entry, with ranges merged (including ranges of subentries)
  (let ([ranges (third entry)])
    (if (null? ranges)
        ; recreate entry as is, removing duplicates for pages, except for subentries that are recursively merged
        (list (first entry) (remove-duplicates (second entry) #:key car) '() (map merge (fourth entry)))
        ; otherwise
        (let ([range-pairs ; create ranges as (beg . end) pairs
               (let aux ([l (reverse ranges)] [res '()])
                 (if (null? l) res
                     (aux (cddr l) (cons (cons (car l) (cadr l)) res))))])
          (let-values ([(pages range-pairs)
                        (let aux ([ranges range-pairs] [res-pages (second entry)] [res-ranges '()]) ; iterate ranges until no change
                          (if (null? ranges)
                              ; all range passes done. Lastly, remove page duplicates (some may have been created while looping)
                              (values (remove-duplicates res-pages #:key car) res-ranges)
                              ; otherwise, continue processing ranges
                              (let* ([cur-range (car ranges)] [beg (caar cur-range)] [end (cadr cur-range)])
                                (if (= beg end)
                                    ; a range with same beg & end is transformed into a page number
                                    (aux (append res-ranges (cdr ranges)) (cons (car cur-range) res-pages) '()) ; reset ranges & res
                                    ; otherwise
                                    (let* (; 1. extend the current range if possible
                                           [new-beg (let ([beg-1 (sub1 beg)])
                                                      (if (memf (lambda (page) (= (car page) beg-1)) res-pages) beg-1 beg))]
                                           [new-end (let ([end+1 (add1 end)])
                                                      (if (memf (lambda (page) (= (car page) end+1)) res-pages) end+1 end))]
                                           ; 2. remove page numbers that are included in the current range
                                           [new-res-pages (filter-not (lambda (page)
                                                                        (let ([page-number (car page)])
                                                                          (<= new-beg page-number new-end)))
                                                                      res-pages)]
                                           )
                                      (if (and (= beg new-beg) (= end new-end) (= (length res-pages) (length new-res-pages)))
                                          ; no change happened (ie. pages & ranges) with respect to the current range
                                          (aux (cdr ranges) res-pages (cons cur-range res-ranges))
                                          ; some changes happened (ie. pages or ranges): reset ranges & res
                                          (aux (append res-ranges
                                                       (list (cons (cons new-beg (cdar cur-range)) (cons new-end (cddr cur-range))))
                                                       ranges)
                                               new-res-pages '())
                                          ))))))])
            ; merge consecutive & overlapping ranges (in one pass since ranges are sorted)
            (let* ([sorted-pairs (sort range-pairs < #:key caar)]
                   [range-pairs (if (null? sorted-pairs) '()
                                    (reverse
                                     (foldl (lambda (r2 acc)
                                              (let* ([r2-beg (caar r2)]
                                                     [r2-end (cadr r2)]
                                                     [r1 (car acc)]
                                                     [r1-beg (caar r1)]
                                                     [r1-end (cadr r1)])
                                                (if (> (- r2-beg r1-end) 1)
                                                    ; no merge
                                                    (cons r2 acc)
                                                    ; else, merge r1 & r2 by creating a new range in place of both
                                                    (cons (cons (cons r1-beg (cdar r1))
                                                                (if (>= r1-end r2-end)
                                                                    (cons r1-end (cddr r1))
                                                                    (cons r2-end (cddr r2))))
                                                          (cdr acc)))))
                                            (list (car sorted-pairs)) ; initial accumulator value
                                            (cdr sorted-pairs))))])
              ; recreate entry with the new ranges (and possibly page numbers)
              (list (first entry) pages range-pairs (map merge (fourth entry))))
            )))))

(define (unescape str) (string-replace (string-replace str #rx"(?<!\")\"(?!\")" "") "\"\"" "\"")) ; remove the escaping char "
(define (print-item key pages ranges)
  ; output: formatted string for the current item
  (let* ([split (string-split key #rx"(?<!\")@")]
         [label (unescape (if (null? (cdr split)) key (cadr split)))]
         [pages (sort pages < #:key car)]
         [ranges (sort ranges < #:key caar)]
         [print-page (lambda (page) (if (cdr page)
                                        (format ", \\~a{~a}" (cdr page) (car page))
                                        (format ", ~a" (car page))))]
         [print-range (lambda (range) (if (cdar range)
                                          (format ", \\~a{~a--~a}" (cdar range) (caar range) (cadr range))
                                          (format ", ~a--~a" (caar range) (cadr range))))])
    (let aux ([p pages] [r ranges] [res label])
      (cond [(null? p) ; consume the remaining ranges
             (foldl (lambda (range acc) (string-append acc (print-range range))) res r)]
            [(null? r) ; consume the remaining pages
             (foldl (lambda (page acc) (string-append acc (print-page page))) res p)]
            [(< (caar p) (caaar r))
             (aux (cdr p) r (string-append res (print-page (car p))))]
            [else ; (caaar r) <= (caar p)
             (aux p (cdr r) (string-append res (print-range (car r))))])
      )))

(define (print-subitems entries level)
  (string-append* (map (lambda (entry)
                         (format "\\~aitem ~a~a"
                                 (string-append* (make-list level "sub"))
                                 (print-item (first entry) (second entry) (third entry))
                                 (print-subitems (fourth entry) (add1 level))))
                       entries)))

(define (generate-ind entries style)
  ; input: a list of entries (key (pages) (ranges) (subentries)). style is optional: a list of style entries.
  ; output: the string corresponding to the .ind file
  (let* ([headings (let ([flag (if style (assq 'headings_flag style) #f)]) (if flag (cdr flag) #f))]
         [heading-prefix (let ([pre (if headings (assq 'heading_prefix style) #f)]) (if pre (cdr pre) ""))]
         [heading-suffix (let ([suf (if headings (assq 'heading_suffix style) #f)]) (if suf (cdr suf) ""))]
         [preamble (let ([pre (if style (assq 'preamble style) #f)]) (if pre (cdr pre) "\\begin{theindex}\n"))]
         [postamble (let ([post (if style (assq 'postamble style) #f)]) (if post (cdr post) "\n\n\\end{theindex}\n"))]
         
         [print-entry (lambda (entry) (format "\\item ~a~a~n"
                                              (print-item (first entry) (second entry) (third entry))
                                              (print-subitems (sort (fourth entry) string-ci<? #:key first) 1)))] ; sort sub-entries
         [entries-string ; insert \indexspace (or sections)
          (let aux ([l (sort entries string-ci<? #:key first)] [prev #f] [res ""]) ; sort entries before display
            (if (null? l) res
                (let* ([entry (car l)]
                       [letter (string-ref (first entry) 0)]
                       [entry-string
                        ; headings && (!prev || prev!=letter): if prev \indexspace\large a else \large a
                        ; (prev && prev==letter) || (!prev && !headings): printentry
                        ; prev: \indexspace, printentry
                        (cond [(and headings (not (and prev (char-ci=? prev letter))))
                               (let* ([split (string-split (first entry) #rx"(?<!\")@")] ; don't split if @ preceeded by "
                                      [font (if (null? (cdr split)) #f
                                                ; font commands are declared as \fntxxx
                                                ; this way, we can detect in the regexp below font commands
                                                ; (regex to look for the first \fnt command, either \fntxx{...} or {\fntxx ...})
                                                (regexp-match #rx"(?:\\\\fnt.*?{|{\\\\fnt.*? )" (cadr split))
                                                )])
                                 (string-append
                                  (if prev "\\indexspace\n" "")
                                  heading-prefix
                                  (if font (car font) "")
                                  (string (char-upcase letter))
                                  (if font "}" "")
                                  heading-suffix
                                  (print-entry entry))
                                 )]
                              [(or (and prev (char-ci=? prev letter)) (not (or prev headings)))
                               (print-entry entry)]
                              [else ; prev
                               (string-append "\\indexspace\n" (print-entry entry))]
                              )
                        ; ; (prev && prev==letter) || (!prev && !headings): printentry
; ; prev && headings: \indexspace\large a, printentry
; ; prev: \indexspace, printentry
; ; headings: \large a, printentry
; (cond [(or (and prev (char-ci=? prev letter)) (and (not prev) (not headings)))
;        (print-entry entry)]
;       [(and prev headings) ; not first entry && different letter
;        ; TODO: automatically set the section letter font to that specified after @, if any
;        (format "\\indexspace{\\bfseries\\large ~a}\\nopagebreak~n~a" (char-upcase letter) (print-entry entry))]
;       [prev (string-append "\\indexspace\n" (print-entry entry))]
;       [else ; headings
;        ; TODO: automatically set the section letter font to that specified after @, if any
;        (format "{\\bfseries\\large ~a}\\nopagebreak~n~a" (char-upcase letter) (print-entry entry))])

                        ])
                  (aux (cdr l) letter (string-append res entry-string))
                  )))])
    (string-append preamble entries-string postamble)))

; main function: input one or two file names 
(define (run idx-file [style-file #f])
  (let* ([f (open-input-file idx-file #:mode 'text)]
         ; by default, regexp-match* returns only the full pattern matches, WITHOUT subpatterns
         [entries (regexp-match* #rx"\\\\indexentry{(.*?)}{([0-9]+?)}" f
                                 #:match-select cdr)] ; cdr: subpatterns only; values (ie. Identity): full pattern & subpatterns
         [table ; each table entry of the form (key (pages) (ranges) (subentries))
          ; page of the form (number . "format"); range of the form (start end start end start end). Later transformed to (beg . end).
          (let aux ([l entries] [res '()]) ; for each \indexentry
            (if (null? l) res
                (let* ([e (map bytes->string/utf-8 (car l))] ; convert from bytes #"..." to string "..."
                       [label (car e)] ; index entry label, eg. hello|textit
                       [pagenumber (string->number (cadr e))]
                       [pipesplit (regexp-split #rx"(?<!\")\\|" label)] ; #rx"(?<!\")\\|" for pipe not following a quote
                       [subitems (string-split (car pipesplit) "!")]
                       )
                  (let-values ([(pageformat type) ; type: 0 for page number (incl. see / see also cross-ref.), 1 for range
                                (cond [(or (null? (cdr pipesplit)) (equal? (cadr pipesplit) "")) (values #f 0)] ; no format, no range
                                      [(or (string-prefix? (cadr pipesplit) "(") (string-prefix? (cadr pipesplit) ")")) ; range
                                       (let ([format (string-trim (substring (cadr pipesplit) 1))])
                                         (values (if (equal? format "") #f format) 1))] ; format possible (hyperref)
                                      [else (values (string-trim (cadr pipesplit)) 0)])] ; format (page number)
                               )
                    (aux (cdr l) (insert subitems (cons pagenumber pageformat) type res))       
                    ))))]
         [table-merge (map merge table)] ; table with ranges merged

         [style ; style file loading
          (if style-file
              (let aux ([style-f (open-input-file style-file #:mode 'text)] [res '()])
                (let ([line (read-line style-f)])
                  (if (eof-object? line)
                      (begin (close-input-port style-f) res)
                      (cond [(string-prefix? line "headings_flag")
                             (aux style-f (cons (cons 'headings_flag
                                                      (if (eq? (string-ref (string-trim (substring line 14)) 0) #\1) #t #f))
                                                res))]
                            [(string-prefix? line "heading_prefix")
                             (aux style-f (cons (cons 'heading_prefix
                                                      (read (open-input-string (substring line 14)))) ; unescape string
                                                res))]
                            [(string-prefix? line "heading_suffix")
                             (aux style-f (cons (cons 'heading_suffix
                                                      (read (open-input-string (substring line 14)))) ; unescape string
                                                res))]
                            [(string-prefix? line "preamble")
                             (aux style-f (cons (cons 'preamble
                                                      (read (open-input-string (substring line 8)))) ; unescape string
                                                res))]
                            [(string-prefix? line "postamble")
                             (aux style-f (cons (cons 'postamble
                                                      (read (open-input-string (substring line 9)))) ; unescape string
                                                res))]
                            
                            [else (aux style-f res)]) ; unhandled style directive
                      )))
              #f)])
    (close-input-port f)
    (generate-ind table-merge style)
    ))

; entry point
;(display (run "test2.idx" "style.ist")) ; for direct execution (not via an executable file)
(let* ([argv (current-command-line-arguments)] [argc (vector-length argv)])
  (displayln "This is kameindex v1.1. (A. Bossard, 2018-2019)")
  (if (= argc 0)
      (begin (display "Error: wrong number of arguments.") 1)
      (let* ([idx-file (vector-ref argv 0)]
             [ind-file (if (string-suffix? idx-file ".idx")
                           (string-append (string-trim idx-file ".idx" #:left? #f) ".ind")
                           (string-append idx-file ".ind"))]
             [f (open-output-file ind-file #:mode 'text #:exists 'replace)]
             )
        (display (run (vector-ref argv 0) (if (= argc 2) (vector-ref argv 1) #f)) f)
        (close-output-port f)
        0
        ))
  )