1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

(define-module (svg-template-gregorian)
 #:use-module (srfi srfi-19) ;; time/date
 #:export (svg-template-gregorian))

(define day-w 11)
(define day-h day-w)
(define day-p 2)

(define month-w (* 6 (+ day-p day-w)))
(define month-h (* 7 day-w))
(define month-p (* 2 day-p))

(define month-max 12)

(define (is-leap-year date)
  (let ((year (date-year date)))
    (and (= 0 (remainder year 4))
         (or (not (= 0 (remainder year 100)))
             (=  0 (remainder year 400))))))

(define (days-in-month date)
  (let ((month (date-month date)))
    (cond ((= month 2) (if (is-leap-year date) 29 28))
          ((< month 8) (if (even? month) 30 31))
          (else (if (even? month) 31 30)))))

(define (translate-str x y)
  (string-append "translate("
                 (number->string x) ","
                 (number->string y) ")"))

(define (generate-month month)
  (let ((x (* (- month 1) (+ month-p month-w)))
        (y (* 0 (- month 1) month-h))) ;; no y for now
    `(g (@ (transform ,(translate-str x y)))
        (text (@ ;; (fill "#ffffbb")
               (x ,(/ month-w 2))
               (text-anchor "middle")
               (font-family "Sans"))
              ,(date->string (make-date 0 0 0 0 0 month 1970 0) "~b")))))

(define (make-tooltip date)
  (string-append (date->string date "~4")))

(define (generate-day date day-details-lam)
  (let* ((day (date-day date))
         (month-date (make-date 0 0 0 0 0 (date-month date) (date-year date) 0))
         (in-month (remainder day (days-in-month date)))
         (first-week-offset (- 6 (date-week-day month-date)))
         (week-of-m (if (and (= 1 (date-month date))
                             (> (date-day date) first-week-offset))
                        (+ (date-week-number date       0) 1)
                        (- (date-week-number date       0)
                           (date-week-number month-date 0))))
         (week-day (date-week-day date))
         (month-label-offset (* 1 day-p))
         (x (+ month-label-offset
               (* (if (eqv? week-day 0)
                      (- week-of-m 1) ; sunday shift (make sunday last day)
                      week-of-m)
                  (+ day-p day-w))))
         (y (+ day-p (* (shifted-week-day week-day) (+ day-p day-h))))
         (custom (day-details-lam date)))
    `(g (@ (transform ,(translate-str x y)) ,(assoc 'class custom))
        ,(assoc 'title custom)
        ,(assoc 'desc custom)
        (rect (@
               ;; (data-day-in-year ,day)
               ;; (data-day-in-month ,in-month)
               (height ,day-h)
               (width ,day-w)
               ,(assoc 'fill custom)))
        (text (@ (y ,(- day-h 1))
                 (x ,(/ day-w 2.0))
                 (font-size ,(- day-h 1)) (font-weight "bold")
                 (font-family "Mono") (text-anchor "middle") (fill "#ffffbb"))
              ,day))))

(define (shifted-week-day number)
  "By default Sunday is at 0, shift it up to 6."
  (if (eqv? number 0)
      6
      (- number 1)))

(define (generate-days month-n year day-details-lam)
  (let ((day-tags '()) ;; this code is a shit
        (days-in-m (days-in-month (make-date 0 0 0 0 0 month-n year 0))))
    (do ((day-n 1 (1+ day-n))) ((> day-n days-in-m))
      (let ((day-tag (generate-day (make-date 0 0 0 0 day-n month-n year 0) day-details-lam)))
        (set! day-tags (cons day-tag day-tags))
        day-tags))
    day-tags))

(define (generate-months year day-details-lam)
  (let ((month-tags '())) ;; this code is a shit
    (do ((month-n 1 (1+ month-n))) ((> month-n month-max))
      (let* ((month-tag (generate-month month-n)))
        (set! month-tag (append month-tag (generate-days month-n year day-details-lam)))
        (set! month-tags (cons month-tag month-tags))
        month-tags))
    month-tags))

(define (legend)
  `(g (@ (transform "translate(2, 27)"))
    (text (@ (y ,(number->string (* 0 (+ day-p day-h)))) (font-family "Sans")) "Mon")
    (text (@ (y ,(number->string (* 1 (+ day-p day-h)))) (font-family "Sans")) "Tur")
    (text (@ (y ,(number->string (* 2 (+ day-p day-h)))) (font-family "Sans")) "Wed")
    (text (@ (y ,(number->string (* 3 (+ day-p day-h)))) (font-family "Sans")) "Thu")
    (text (@ (y ,(number->string (* 4 (+ day-p day-h)))) (font-family "Sans")) "Fri")
    (text (@ (y ,(number->string (* 5 (+ day-p day-h)))) (font-family "Sans")) "Sat")
    (text (@ (y ,(number->string (* 6 (+ day-p day-h)))) (font-family "Sans")) "Sun")))

(define (generate-svg-gregorian year day-details-lam)
  (let ((month-tags (generate-months year day-details-lam))
        (total-width (+ 30 (* month-max (+ month-p month-w))))
        (total-height 115))
    `(svg (@ (width ,total-width) (height ,total-height)
             (viewBox ,(string-append
                        "0 0 "
                        (number->string total-width) " "
                        (number->string total-height)))
             (xmlns "http://www.w3.org/2000/svg"))
          (title ,(string-append "git activity calendar " (number->string year)))
      ,(legend)
      (g (@ (transform "translate(30,15)") (class "gregorian"))
         ,month-tags))))

(define svg-template-gregorian
  `((fn . ,generate-svg-gregorian)
    (theme . ((day-bg . "rgba(100,100,100,0.9)")))))