(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)
                         (? string?) ...
                         (list 'title (list) Title ...)
                         (? string?) ...
                         (list 'created (list) Created)
                         (? string?) ...
                         (list 'publish (list) Published)
                         (? string?) ...
                         (list 'category (list) Maybe-Category ...)
                         (? string?) ...
                         (list 'content (list) Content ...)
                         (? string?) ...)
                   (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))]))))]
         [else
          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)))
  
  )