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

(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"))
              ,(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))
         (x (+ day-p (* week-of-m (+ day-p day-w))))
         (y (+ day-p (* 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 (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, 25)"))
    (text (@ (y ,(number->string (* 0 (+ day-p day-h))))) "Sun")
    (text (@ (y ,(number->string (* 1 (+ day-p day-h))))) "Mon")
    (text (@ (y ,(number->string (* 2 (+ day-p day-h))))) "Tur")
    (text (@ (y ,(number->string (* 3 (+ day-p day-h))))) "Wed")
    (text (@ (y ,(number->string (* 4 (+ day-p day-h))))) "Thu")
    (text (@ (y ,(number->string (* 5 (+ day-p day-h))))) "Fri")
    (text (@ (y ,(number->string (* 6 (+ day-p day-h))))) "Sat")))

(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)")))))