#!/bin/sh
exec guile -s $0 "$@" # -*- scheme -*-
!#
;; time-stamp: <2010-08-18 09:19:50 ttn>

;;; Copyright (C) 1999-2010 Thien-Thi Nguyen
;;; This program is provided under the terms of the GNU GPL, version 3.
;;; See http://www.fsf.org/copyleft/gpl.html for details.

(use-modules
 ((ice-9 regex) #:select (string-match
                          match:prefix))
 ((ttn-do cron-walk) #:select (cron!))
 ((ttn-do zzz filesystem) #:select (file-newer-than-file?
                                    filtered-files))
 ((ttn-do zzz xhtml-tree))
 ((ttn-do zzz publishing) #:select (spew-html!)))

(set! *random-state* (seed->random-state (current-time)))

(define *sources*
  (sort (filtered-files (lambda (file)
                          (and (string-match "^thud-.*tar.gz$" file)
                               file))
                        ".")
        string>?))

(define thud-screenshots
  '("adder.png" "adder"))

(define thud-elems
  '("README"                               "about"
    "http://www.fsf.org/copyleft/gpl.html" "license"
    "doc/index.html"                       "manual"
    "THANKS"                               "thanks"
    "WHIRLPOOLSUMS"                        "sum"
    "scm-html/"                            "decoration"
    "frisk.out.html"                       "frisk"
    ))

(define other-elems
  '("http://www-swiss.ai.mit.edu/~jaffer/SIMSYNCH.html" "SIMSYNCH"
    "http://www.geda.seul.org/"                         "gEDA"
    "../guile/"                                         "Guile-1.4.x"
    "http://opencollector.org/"                         "OpenCollector"
    ))

(define triggers '(".cron"              ; car not rendered
                   "NEWS" "BUGS"))

(define (index.html-data)

  (define (~body/centered . x)
    (~body (~div 'align "center" x)))

  (define (~- x)
    (let ((rv x))
      (let loop ((ls x))
        (if (null? (cdr ls))
            rv
            (begin
              (set-cdr! ls (cons " " (cdr ls)))
              (loop (cddr ls)))))))

  (define (~s proc ls)
    (~- (map proc ls)))

  (define (~happy url text)
    (list "(" (~a 'href url text) ")"))

  (define (shuffle-pairs elems)
    (let loop ((range (iota (/ (length elems) 2))) (acc '()))
      (if (null? range)
          (~- acc)
          (let ((pair-idx (list-ref range (random (length range)))))
            (loop (delete pair-idx range)
                  (cons (~happy (list-ref elems (+ 0 (* 2 pair-idx)))
                                (list-ref elems (+ 1 (* 2 pair-idx))))
                        acc))))))

  (define (xhtml . x)
    (list
     (~?xml "iso-8859-1")
     (~!DOCTYPE #:strict)
     (~html
      'xmlns "http://www.w3.org/1999/xhtml"
      'xml:lang "en"
      'lang "en"
      x)))

  (xhtml
   (~head (~title "THUD Homepage"))
   (~body/centered
    (~a 'href "RANDOM" "THUD") " "
    (let ((latest (car *sources*)))
      (~a 'href latest (substring latest 5 (- (string-length latest) 7))))
    (~p)
    (~s (lambda (file)
          (~happy file
                  (list
                   (string-downcase
                    (or (and=> (string-match "\\." file) match:prefix)
                        file))
                   " . "
                   (strftime "%Y-%m-%d" (localtime (stat:mtime (stat file)))))))
        (cdr triggers))
    (~p)
    "(-8 " (shuffle-pairs thud-screenshots) " 8-)"
    (~p)
    (map (lambda (x)
           (list x (if (= 0 (random 3)) (~br) '())))
         (shuffle-pairs thud-elems))
    (~hr)
    "See Also"
    (~p)
    (shuffle-pairs other-elems)
    (~hr)
    ;; what egotistical code!
    (~happy ".cron.html.gz" "Source") " "
    (~happy "../" "Up"))))

(define (generate-index.html-maybe)
  (and (or-map (lambda (file)
                 (file-newer-than-file? file "index.html"))
               triggers)
       (spew-html! (index.html-data) "index.html"))
  #t)

(cron! ((now hourly) (generate-index.html-maybe)))

;;; .cron ends here