All JACoW proceedings

(defun print-bib (event venue eventdate)
  "Print bibtex."
  (let* ((event-date (split-string eventdate "--"))
         (start-date (car event-date))
         (end-date (cadr event-date))
         (event-year (format-time-string "%Y" (org-read-date nil t start-date nil)))
         (event-year-short  (substring event-year -2 nil))
         (event-start (org-read-date nil nil start-date nil))
         (event-end (org-read-date nil nil end-date nil))
         )
    (concat
     "@proceedings{" event event-year ",\n"
     "  title      = \"Proc. " event "’" event-year-short "\",\n"
     "  eventtitle = \""       event "’" event-year-short "\",\n"
     "  venue      = \""       venue "\",\n"
     "  eventdate  = \""       event-start "/" event-end "\",\n"
     "}" "\n")))

(defun table-to-bibtex (ev tbl)
  "Write table to BibTeX."
  (if (and (car tbl) (cadr tbl))
      (concat (print-bib ev (car tbl) (cadr tbl))
              (table-to-bibtex ev (cddr tbl)))
    nil)
  )

(defun print-org (event venue eventdate ev-alist)
  "Print Org."
  (let* ((event-date (split-string eventdate "--"))
         (start-date (car event-date))
         (end-date (cadr event-date))
         (event-year (format-time-string "%Y" (org-read-date nil t start-date nil)))
         (event-year-short  (substring event-year -2 nil))
         (event-start (org-read-date nil nil start-date nil))
         (event-end (org-read-date nil nil end-date nil))
         (event-start-epoch (car (org-read-date nil t start-date nil)))
         (event-key (format-time-string "%04Y-%02m-%02d"  (org-read-date nil t start-date nil)))
         (event-val
          (concat
           "\n**** " event "’" event-year-short " :" event ":\n"
           ":PROPERTIES:\n"
           ":VENUE: " venue "\n"
           ":EVENTDATE: " eventdate "\n"
           ":END:\n\n"
           ))
         )
    (add-to-list ev-alist (cons event-key event-val))
    ))

(defun table-to-org (ev tbl ev-alist)
  "Write table to Org."
  (if (and (car tbl) (cadr tbl))
      (progn
        (print-org ev (car tbl) (cadr tbl) ev-alist)
        (table-to-org ev (cddr tbl) ev-alist))))

(defun print-html (event venue eventdate ev-alist)
  "Print Org."
  (let* ((event-date (split-string eventdate "--"))
         (start-date (car event-date))
         (end-date (cadr event-date))
         (event-year (format-time-string "%Y" (org-read-date nil t start-date nil)))
         (event-year-short  (substring event-year -2 nil))
         (event-start (org-read-date nil nil start-date nil))
         (event-end (org-read-date nil nil end-date nil))
         (event-start-epoch (car (org-read-date nil t start-date nil)))
         (event-key (format-time-string "%04Y-%02m-%02d"  (org-read-date nil t start-date nil)))
         (event-val
          (list event venue event-start event-end))
         )
    (add-to-list ev-alist (cons event-key event-val))
    ))

(defun table-to-html (ev tbl ev-alist)
  "Write table to Org."
  (if (and (car tbl) (cadr tbl))
      (progn
        (print-html ev (car tbl) (cadr tbl) ev-alist)
        (table-to-html ev (cddr tbl) ev-alist))))

;;(defun draw-year-to-svg (current-year svg &optional size)
;;  "Draw calendar to svg obj."
;;  (let* (
;;         (day-wd (or size 50))
;;         (month-wd (* 7 day-wd))
;;         (month-gap (/ day-wd 3))
;;         (month-pos (lambda (n) (+ (* n month-wd) (* (1+ n) month-gap))))
;;         (day-font-size (/ day-wd 4.0))
;;         (month-font-size (* day-wd 4))
;;         )
;;    ;; Calendar frame
;;    (svg-rectangle svg 0 0 (funcall month-pos 4) (funcall month-pos 3) :fill "transparent" :stroke "green")
;;    (dotimes (i 3)
;;      (dotimes (j 4)
;;        (let (
;;              ;; (x0,y0): top-left anchor
;;              (x0 (funcall month-pos j))
;;              (y0 (funcall month-pos i))
;;              (current-month (+ 1 j (* i 4)))
;;              )
;;          ;; 12 Months
;;          (svg-rectangle svg x0 y0 month-wd month-wd :fill-opacity 0 :stroke "lightblue")
;;          (svg-text svg (number-to-string current-month) :font-size month-font-size :x (+ x0 (/ month-wd 2)) :y (+ y0 (/ month-wd 2)) :class "month-text")
;;          ;; For each month:
;;          ;;   1st day to 1st of next month (not included)
;;          (let* (
;;                 (first-weekday
;;                  (string-to-number
;;                   (format-time-string
;;                    "%u"
;;                    (org-read-date nil t (format "%04d-%02d-01" current-year current-month)))))
;;                 (first-day   (org-time-string-to-absolute (format "%04d-%02d-01" current-year current-month)))
;;                 (last-day    (org-time-string-to-absolute (format "%04d-%02d-01" current-year (1+ current-month))))
;;                 (current-day (org-time-string-to-absolute (format "%04d-%02d-01" current-year current-month)))
;;                 (ii 0)
;;                 ;; (x1,y1): top-right anchor of
;;                 ;;   the first cell (which is Monday)
;;                 ;; 1st day of the month is
;;                 ;;   the first cell shifted to the left by `first-weekday' - 1
;;                 (x1 x0)
;;                 (y1 (+ y0 day-wd))
;;                 xx
;;                 yy
;;                 is-weekend
;;                 )
;;            (while (< current-day last-day)
;;              (setq xx (+ x1 (* (% (+ ii first-weekday -1) 7) day-wd))
;;                    yy (+ y1 (* (/ (+ ii first-weekday -1) 7) day-wd))
;;                    is-weekend (cond
;;                                ((= (% (+ ii first-weekday) 7) 6) "weekend") ;; Saturday
;;                                ((= (% (+ ii first-weekday) 7) 0) "weekend") ;; Sunday
;;                                (t "workday") ;; workday
;;                                )
;;                    )
;;              (svg-rectangle svg xx yy day-wd day-wd :stroke "lightgrey" :class (concat is-weekend "-frame"))
;;              (svg-text svg (format "%02s" (1+ ii)) :font-size day-font-size :x (+ xx day-wd) :y yy :class "day-text")
;;              (setq current-day (1+ current-day)
;;                    ii          (1+ ii)
;;                    )))
;;          )))
;;    ))

(defun eventdate-to-shape (bev eev)
  "Calculate the shape of the event in a month."
  (let* ((start-days (org-time-string-to-absolute bev))
         (end-days   (org-time-string-to-absolute eev))
         (start-date (calendar-gregorian-from-absolute start-days))
         (current-year  (elt start-date 2))
         (current-month (elt start-date 0))
         (first-days (org-time-string-to-absolute (format "%04d-%02d-01" current-year current-month)))
         (first-week      (elt (calendar-iso-from-absolute first-days) 0))
         (start-week   (- (elt (calendar-iso-from-absolute start-days) 0) first-week))
         (end-week     (- (elt (calendar-iso-from-absolute end-days  ) 0) first-week))
         (start-day (% (+ (elt (calendar-iso-from-absolute start-days) 1) 6) 7))
         (end-day   (% (+ (elt (calendar-iso-from-absolute end-days  ) 1) 6) 7))
         ev-shape
         )
    (while (< start-week end-week) ;;)
      (push (list start-day start-week (- 7 start-day)) ev-shape)
      (setq start-week (1+ start-week) ;; move pointer to next week Monday
            start-day  0)
      )
    (push (list start-day start-week (+ end-day 1)) ev-shape)
    )
  )

(setq jacow-list '("eeFACT" "eCloud" "ERL" "FLS" "HB" "HF" "APAC" "BIW" "COOL" "CYCLOTRONS" "DIPAC" "ECRIS" "EPAC" "FEL" "HIAT" "IBIC" "ICALEPCS" "ICAP" "IPAC" "LINAC" "MEDSI" "NAPAC" "PAC" "PCaPAC" "RuPAC" "SAP" "SRF"))

(setq jacow-color-list '("blueviolet" "crimson" "darkcyan" "deeppink" "dimgray" "forestgreen" "indianred" "lightsalmon" "olive" "orange"))

(let* ((dir "texmf/bibtex/bib/biblatex-jacow")
       (file-name (concat dir "/jacow-conferences.bib")))
  (when (not (file-exists-p dir))
    (make-directory dir t))
  (when (file-exists-p file-name)
    (delete-file file-name))
  (append-to-file
   (mapconcat
    (lambda (x)
      (let ((series-info (mapcar #'org-no-properties (org-table-get-remote-range x "@I$1..@>$2"))))
        (table-to-bibtex x series-info)))
    jacow-list "\n\n\n")
   nil file-name))

(let* ((file-name "./jacow-events.org"))
  (when (file-exists-p file-name)
    (delete-file file-name))
  (let (events-alist)
    (dolist (series jacow-list events-alist)
      (table-to-org series (mapcar #'org-no-properties (org-table-get-remote-range series "@I$1..@>$2")) 'events-alist))
    (setq events-alist (sort events-alist (lambda (a b) (string-lessp (car a) (car b)))))
    (let (current-year)
      (dolist (my-event events-alist)
        (if (not (string-equal current-year (substring (car my-event) 0 4)))
            (progn
              (setq current-year (substring (car my-event) 0 4))
              (append-to-file
               (concat "*** " current-year " :" current-year ":\n\n")
               nil file-name)))
        (append-to-file (cdr my-event) nil file-name)))))

@import url(https://fonts.googleapis.com/css2?family=Zen+Dots);
@import url(https://fonts.googleapis.com/css2?family=Barlow+Condensed);

text { 
    font-family:'Barlow Condensed';
}

.month-text {font-family:'Zen Dots'; font-weight:bold; text-anchor:middle; dominant-baseline:middle; stroke:black; stroke-width:0; fill:pink; }
.day-text   {font-family:'Zen Dots'; font-weight:normal; text-anchor:end; dominant-baseline:hanging; stroke:black; stroke-width:0; fill:black;}
.event-text {font-family:'Barlow Condensed'; font-weight:bold; text-anchor:start; dominant-baseline:middle;  stroke:white; stroke-width:0.1; fill:white;}

.day-frame     {stroke:lightgrey; stroke-width:2; stroke-dasharray:10 5; fill:white; fill-opacity:0;  }
.workday-frame {stroke:lightgrey;                                        fill:white; fill-opacity:0.1;}
.weekend-frame {stroke:lightgrey; stroke-width:0; stroke-opacity:0;      fill:grey;  fill-opacity:0.1;}
.month-frame   {stroke:orange;    stroke-width:3; stroke-opacity:0.3;    fill:white; fill-opacity:0;  }
.month-box     {stroke:orange;    stroke-width:0; stroke-opacity:0;      fill:wheat; fill-opacity:0.1;}

(let* ((file-name "./jacow-events.html")
       (cal-dir "cal")
       my-html
       ;;(css-file  "./calendar.css")
       ;;(js-file   "./calendar.js")
       (years-list nil))
  (setq my-html '(html
                  (head
                   (title "JACoW Calendar")
                   (meta :something "hi"))))
  (nconc my-html '((body (h1 "JACoW Calendar"))))
  (require 'svg)
  (require 'xmlgen)
  (when (file-exists-p file-name)
    (delete-file file-name))
  (make-directory cal-dir :parents)
  (let (events-alist)
    (dolist (series jacow-list events-alist)
      (table-to-html series (mapcar #'org-no-properties (org-table-get-remote-range series "@I$1..@>$2")) 'events-alist))
    (setq events-alist (sort events-alist (lambda (a b) (string-lessp (car a) (car b)))))
    (let* (this-year
           event-info
           (event-start "")
           (event-end "")
           svg-file
           svg
           (cell-size 50)
           (month-wd (* 7 cell-size))
           (month-gap (/ cell-size 3))
           (month-pos (lambda (n) (+ (* n month-wd) (* (1+ n) month-gap))))
           (date-pos (lambda (date-str)
                       (let* (
                              (the-current-days   (org-time-string-to-absolute date-str))
                              ;;(the-current-iso    (calendar-iso-from-absolute       the-current-days))
                              (the-current-date   (calendar-gregorian-from-absolute the-current-days))
                              (the-current-year   (elt the-current-date 2))
                              (the-current-month  (elt the-current-date 0))
                              (the-current-day    (elt the-current-date 1))
                              (the-first-iso      (calendar-iso-from-absolute (- the-current-days the-current-day -1)))
                              (the-current-offset (1+ (% (+ 6 (elt the-first-iso  1)) 7)))
                              (days-since-monday  (+ the-current-offset the-current-day -1))
                              )
                         (list
                          (% (1- the-current-month) 4) (/ (1- the-current-month) 4) ;; month x,y
                          (% (1- days-since-monday) 7) (/ (1- days-since-monday) 7) ;; day   x,y
                          )
                         )))
           (day-font-size   (/ cell-size 4.0))
           (month-font-size (* cell-size 4))
           (event-priority 1)
           (event-color 0)
           )
      (dolist (my-event events-alist)
        (setq event-info (cdr my-event))
        ;; start a new year calendar
        ;; draw the frame
        ;; --------
        (if (not (string-equal this-year (substring (car my-event) 0 4)))
            (progn
              (when svg ;; `nil' means we are at the beginning of the list
                ;; otherwise, dump `svg' to a file before starting a new one
                (with-temp-file svg-file
                  (set-buffer-multibyte nil)
                  (svg-print svg)))
              (setq this-year (substring (car my-event) 0 4))
              (add-to-list 'years-list this-year)
              (setq svg-file  (concat cal-dir "/" this-year ".svg"))
              (nconc (nth 2 my-html) `((h2 ,this-year)))
              (nconc (nth 2 my-html) `((object :data ,svg-file :type "image/svg+xml" ,this-year)))
              (setq event-color 1)
              (when (file-exists-p svg-file)
                (delete-file svg-file))
              ;; create svg
              (setq svg (svg-create (funcall month-pos 4) (funcall month-pos 3) :stroke-width 2))
              ;; add css
              (svg-node svg 'link :type "text/css" :rel "stylesheet" :href "../css/calendar.css" :xmlns "http://www.w3.org/1999/xhtml")
              ;; add js
              (svg-node svg 'script :type "text/javascript" :href  "calendar.js")
              ;;(print this-year)
              ;;(draw-year-to-svg (string-to-number this-year) svg cell-size)
              ;;
              ;; Calendar frame
              (svg-rectangle svg 0 0 (funcall month-pos 4) (funcall month-pos 3) :fill "transparent" :stroke "green")
              (dotimes (i 3)
                (dotimes (j 4)
                  (let* (
                         ;; (x0,y0): top-left anchor
                         (x0 (funcall month-pos j))
                         (x-min x0)
                         (x-max (+ x0 (* 7 cell-size)))
                         (x-mid (+ x0 (* 5 cell-size)))
                         (y0 (funcall month-pos i))
                         (current-month (+ 1 j (* i 4)))
                         (current-year (string-to-number this-year))
                         )
                    ;; 12 Months
                    (svg-rectangle svg x0 y0 month-wd month-wd :class "month-box")
                    (svg-text svg (number-to-string current-month) :font-size month-font-size :x (+ x0 (/ month-wd 2)) :y (+ y0 (/ month-wd 2)) :class "month-text")
                    ;; For each month:
                    ;;   1st day to 1st of next month (not included)
                    (let* (
                           (first-weekday
                            (string-to-number
                             (format-time-string
                              "%u"
                              (org-read-date nil t (format "%04d-%02d-01" current-year current-month)))))
                           (first-day   (org-time-string-to-absolute (format "%04d-%02d-01" current-year current-month)))
                           (last-day    (org-time-string-to-absolute (format "%04d-%02d-01" current-year (1+ current-month))))
                           (current-day (org-time-string-to-absolute (format "%04d-%02d-01" current-year current-month)))
                           (ii 0)
                           ;; (x1,y1): top-right anchor of
                           ;;   the first cell (which is Monday)
                           ;; 1st day of the month is
                           ;;   the first cell shifted to the left by `first-weekday' - 1
                           (x1 x0)
                           (y1 (+ y0 cell-size))
                           xx
                           yy
                           is-weekend
                           (p-x0 (+ x0 (* (% (1- first-weekday) 7) cell-size)))
                           (p-y0 (+ y0 cell-size))
                           p-x1
                           p-y1
                           )
                      (while (< current-day last-day) ;;)
                        (setq xx (+ x1 (* (% (+ ii first-weekday -1) 7) cell-size))
                              yy (+ y1 (* (/ (+ ii first-weekday -1) 7) cell-size))
                              is-weekend (cond
                                          ((= (% (+ ii first-weekday) 7) 6) "weekend") ;; Saturday
                                          ((= (% (+ ii first-weekday) 7) 0) "weekend") ;; Sunday
                                          (t "workday") ;; workday
                                          )
                              )
                        ;;(svg-rectangle svg xx yy cell-size cell-size :stroke "lightgrey" :class (concat is-weekend "-frame"))
                        (svg-text svg (format "%02s" (1+ ii)) :font-size day-font-size :x (+ xx cell-size) :y yy :class "day-text")
                        (setq current-day (1+ current-day)
                              ii          (1+ ii)
                              p-x1        (+ xx cell-size)
                              p-y1        (+ yy cell-size)
                              ))
                      (svg-polygon
                       svg
                       `((,p-x0  . ,p-y0)
                         (,x-max . ,p-y0)
                         (,x-max . ,(- p-y1 cell-size))
                         (,p-x1  . ,(- p-y1 cell-size))
                         (,p-x1  . ,p-y1)
                         (,x-min . ,p-y1)
                         (,x-min . ,(+ p-y0 cell-size))
                         (,p-x0  . ,(+ p-y0 cell-size))
                         )
                       :class "month-frame"
                       )
                      (svg-polygon
                       svg
                       `((,(max x-mid p-x0) . ,p-y0)
                         (,x-max            . ,p-y0)
                         (,x-max            . ,(- p-y1 cell-size))
                         (,(max x-mid p-x1) . ,(- p-y1 cell-size))
                         (,(max x-mid p-x1) . ,p-y1)
                         (,x-mid            . ,p-y1)
                         (,x-mid            . ,(+ p-y0 cell-size))
                         (,(max x-mid p-x0) . ,(+ p-y0 cell-size))
                         )
                       :class "weekend-frame"
                       )
                      (dotimes (i 6)
                        (let* ((current-x (+ x-min (* (1+ i) cell-size)))
                               (current-y0 (if (< p-x0 current-x) p-y0 (+ p-y0 cell-size)))
                               (current-y1 (if (> p-x1 current-x) p-y1 (- p-y1 cell-size)))
                               )
                          (svg-line svg current-x current-y0 current-x current-y1
                                    :class "day-frame")
                          )
                        )
                      (dotimes (i 5)
                        (let* ((current-y (+ p-y0 (* (1+ i) cell-size)))
                               (current-x0 (if (< (+ p-y0 cell-size) current-y) x-min p-x0))
                               (current-x1 (if (> (- p-y1 cell-size) current-y) x-max p-x1))
                               )
                          (if (< current-y p-y1) ;;)
                              (svg-line svg current-x0 current-y current-x1 current-y
                                        :class "day-frame")
                            )
                          )
                        )
                      )
                    )))
              ))
        ;; --------
        ;; event
        (setq event-start (caddr event-info))
        (if (string-lessp event-start event-end)
            (setq event-priority (1+ event-priority))
          (setq event-priority 1)
          )
        (setq event-color (1+ event-color))
        (setq event-end (cadddr event-info))
        (let* (
               (date-coord (funcall date-pos event-start))
               (m-x0 (funcall month-pos (car   date-coord)))
               (m-y0 (funcall month-pos (cadr  date-coord)))
               (d-x0 (* (caddr  date-coord) cell-size))
               (d-y0 (* (1+ (cadddr date-coord)) cell-size))
               (start-days (org-time-string-to-absolute event-start))
               (end-days   (org-time-string-to-absolute event-end  ))
               (start-week (org-days-to-iso-week start-days))
               (end-week   (org-days-to-iso-week end-days  ))
               )
          (dolist (my-event (eventdate-to-shape event-start event-end))
            (svg-rectangle
             svg
             (+ m-x0 (* cell-size (car my-event))) (+ m-y0 cell-size (* event-priority day-font-size) (* cell-size (cadr my-event))) (* cell-size (caddr my-event)) day-font-size
             :fill (nth event-color jacow-color-list)
             :rx (/ day-font-size 4.0)
             :ry (/ day-font-size 4.0)
             )
            )
          ;; --------
          (svg-text svg (if (and (string= (car event-info) "CYCLOTRONS") (= (caddr date-coord) 6)) "CYC" (car event-info))
                    :font-size (/ day-font-size 1.2)
                    :x (+ m-x0 d-x0 (/ day-font-size 2.0))
                    :y (+ m-y0 d-y0 (* event-priority day-font-size)  (/ day-font-size 2.0))
                    :class "event-text")
          )
        )
      ;;(print (reverse years-list))
      (with-temp-file svg-file
        (set-buffer-multibyte nil)
        (svg-print svg))
      )
    )
  (append-to-file
   (xmlgen my-html)
   nil file-name)
  ;;(princ (xmlgen my-html))
  ;;(print my-html)
  )