(module blogue-world mzscheme
  (require (lib "time.ss" "srfi" "19")
           (lib "xml.ss" "xml")
           (lib "string.ss")
           (lib "list.ss")
           (lib "etc.ss")
           (lib "file.ss")
           (lib "plt-match.ss"))
  (require (planet "path.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "list.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "hash-table.ss" ("jaymccarthy" "mmss.plt" 1)))
  (require "blogue-post.ss")
  (provide (all-defined))
  
  ; Util
  (define (category->parents c)
    (map (lambda (p)
           (path->bytes (apply build-path p)))
         (filter cons? (path->subpaths (bytes->path (bytes-append #"/" c))))))
  
  ; Load posts
  (define (fold/posts f init root)
    (fold-files
     (lambda (p t a)
       (cond
         [(eq? t 'dir)
          (printf "~a~n" p)
          a]
         [(and (eq? t 'file)
               (equal? #"txt" (filename-extension p)))
          (with-input-from-file p
            (lambda ()
              (let ([xexpr (xml->xexpr (document-element (read-xml)))])
                (match xexpr
                  [(list 'blogue (list)
                         (list 'title (list) Title ...)
                         (list 'created (list) Created)
                         (list 'publish (list) Published)
                         (list 'category (list) Maybe-Category ...)
                         (list 'content (list) Content ...))
                   (let ([BaseCategory (list (bytes-append #"/" (path->bytes (chop-prefix root (path-only p)))))]
                         [Category (or (and (not (empty? Maybe-Category)) (first Maybe-Category)) "")])
                     (f (new-Post Title
                                  Content
                                  (string->date Created "~a, ~d ~b ~Y ~H:~M:~S ~z")
                                  (foldl cons BaseCategory
                                         (filter (lambda (x) (not (or (member x BaseCategory)
                                                                      (equal? x #""))))
                                                 (map string->bytes/utf-8 (regexp-split "," Category)))))
                        a))]))))]))
     init
     root))
  
  ; World
  (define-struct World (Posts 
                        CategoryMap CategoryChildMap CategoryAccount 
                        DateMap))
  (define (empty-World)
    (make-World (make-hash-table 'equal)
                (make-hash-table 'equal) (make-hash-table 'equal) (make-hash-table 'equal)
                (make-hash-table 'equal)))
  
  (define (World-Post w pi)
    (hash-table-get (World-Posts w) pi (lambda () #f)))
  (define (set-World-Post! w p)
    (hash-table-put! (World-Posts w) (Post-Id p) p))
  
  ; Indices
  (define (World-DateMap-add! w Y M D h m s pid)
    (let* ([Ym (hash-table-get/set-default! (World-DateMap w) Y (make-hash-table 'equal))]
           [Mm (hash-table-get/set-default! Ym M (make-hash-table 'equal))]
           [Dm (hash-table-get/set-default! Mm D (make-hash-table 'equal))])
      (hash-table-put! Dm (format "~a~a~a" h m s) pid)))
  
  (define (World-DateMap-Years w)
    (quicksort
     (hash-table->key-list (World-DateMap w))
     string<?))
  
  (define (World-DateMap-Year/Months w Y)
    (quicksort
     (hash-table->key-list (hash-table-get* (World-DateMap w) Y))
     string<?))
  (define (World-DateMap-Months w)
    (telescoping-map
     (lambda (w Y M) (format "~a/~a" Y M))
     (list (list w))
     (list World-DateMap-Years
           World-DateMap-Year/Months)))
  
  (define (World-DateMap-Year/Month/Days w Y M)
    (quicksort
     (hash-table->key-list (hash-table-get* (World-DateMap w) Y M))
     string<?))
  (define (World-DateMap-Days w)
    (telescoping-map
     (lambda (w Y M D) (format "~a/~a/~a" Y M D))
     (list (list w))
     (list World-DateMap-Years
           World-DateMap-Year/Months
           World-DateMap-Year/Month/Days)))
  
  (define (World-DateMap-Year/Month/Day-Posts? w Y M D)
    (hash-table-get* (World-DateMap w) Y M D))
  (define (World-DateMap-Year/Month/Day-Posts w Y M D)
    (quicksort
     (hash-table->value-list (hash-table-get* (World-DateMap w) Y M D))
     string<?))      
  (define (World-DateMap-Posts w)
    (telescoping-map
     (lambda (w Y M D PI) PI)
     (list (list w))
     (list World-DateMap-Years
           World-DateMap-Year/Months
           World-DateMap-Year/Month/Days
           World-DateMap-Year/Month/Day-Posts)))
  
  (define (iter/World-Category iter f w)
    (iter (World-CategoryAccount w)
          (lambda (k v)
            (f k
               (hash-table-get (World-CategoryChildMap w) k (lambda () (list)))
               (hash-table-get (World-CategoryMap w) k (lambda () (list)))))))
  (define (for-each/World-Category f w)
    (iter/World-Category hash-table-for-each f w))
  (define (map/World-Category f w)
    (iter/World-Category hash-table-map f w))  
  
  (define (update-indices! w p)
    ; Index by Post Id
    (set-World-Post! w p)
    ; Index and Account by Category
    (for-each 
     (lambda (c)
       (for-each/triple (lambda (p_pc pc n_pc)
                          (when (and p_pc pc
                                     (not (member p_pc (hash-table-get (World-CategoryChildMap w) pc (lambda () (list))))))
                            (hash-table-append! (World-CategoryChildMap w) pc p_pc))
                          (hash-table-put! (World-CategoryAccount w) pc #t))
                        (category->parents c))
       (hash-table-append! (World-CategoryMap w) c (Post-Id p)))
     (Post-Category p))
    ; Index and Account by Date
    (match (regexp-match "/Post/(....)/(..)/(..)/(..)(..)(..)" (Post-Id p))
      [(list _ Y M D h m s)
       (World-DateMap-add! w Y M D h m s (Post-Id p))])
    w)
  
  (define load-World
    (opt-lambda (PostRoot [f (lambda (w pi) w)])
      (fold/posts
       (lambda (p w)
         (f (update-indices! w p) (Post-Id p)))
       (empty-World)
       PostRoot)))
  
  )