; Helpers
(defun lines (str)
(split str #\linefeed))
(defun split (str c)
(loop
for i = 0 then (1+ j)
as j = (position c str :start i)
collect (subseq str i j)
while j))
(defun write-file (filename s)
(ensure-directories-exist filename)
(with-open-file (str filename
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format str "~A" s)))
; Data
(defun song-key (key song)
(let ((tuple (car song)))
(cond
((eql tuple nil) nil)
((eql (car tuple) key) (cdr tuple))
(t (song-key key (cdr song))))))
; HTML
(defun page (title body)
(format
nil
"~A~A"
title
body))
(defun h (node attrs children)
(format
nil
"<~A ~A>~A"
node
(apply #'concatenate 'string (mapcar (lambda (x) (format nil " ~A=\"~A\"" (car x) (car (cdr x)))) attrs))
(apply #'concatenate 'string children)
node))
; Title
(defun title-tags (title from)
(h "section" nil
(list
(h "h1" '(("class" "g-Title")) (list title))
(h "div" '(("class" "g-Author")) (list from)))))
; Part
(defun part-name (key)
(ecase key
('intro "Intro")
('verse "Couplet")
('chorus "Refrain")
('interlude "Interlude")
('bridge "Pont")
('outro "Outro")))
(defun part-tags (key children)
(h "div"
'(("class" "g-Part"))
(list
(if
(eql key 'all)
nil
(h "h3" '(("class" "g-Part__Title")) (list (part-name key))))
children)))
; Chords
(defun chord-name (x)
(h "span" '(("class" "g-Chords__Name")) (list (string x))))
(defun rhythm (x)
(h "img"
(list
'("class" "g-Chords__Rhythm")
(list "src" (format nil "/rhythms/~S.png" x)))
nil))
(defun chord-div (x)
(h "span" '(("class" "g-Chords__Chord"))
(if
(listp x)
(cons (chord-name (car x)) (mapcar #'rhythm (cdr x)))
(list (chord-name x)))))
(defun chord-cell (x)
(h "td" '(("class" "g-Chords__Cell"))
(if
(listp x)
(mapcar #'chord-div x)
(list (chord-div x)))))
(defun chord-row (xs)
(h "tr" nil (mapcar #'chord-cell xs)))
(defun chord-rows (xs)
(if
(eql xs nil)
nil
(cons (chord-row (car xs)) (chord-rows (cdr xs)))))
(defun chord-table (key x)
(let* ((is-repeat (eql (car x) :repeat))
(n (if is-repeat (second x) 1))
(rows (if is-repeat (cddr x) x)))
(part-tags
key
(h
"div"
'(("class" "g-Chords__Section"))
(list
(h "table" '(("class" "g-Chords__Table")) (chord-rows rows))
(if (> n 1) (h "div" '(("class" "g-Chords__Multiplier")) (list (write-to-string n))) nil))))))
(defun chord-tables (xs)
(if
(eql xs nil)
nil
(let ((key (caar xs))
(rows (cdar xs)))
(cons (chord-table key rows) (chord-tables (cdr xs))))))
(defun chord-tags (chords tonality)
(h "section" nil
(list
(h "h2" '(("class" "g-Subtitle")) '("Accords"))
(h "div" '(("class" "g-Parts"))
(cons
(h "label" '(("class" "g-Chords__Tonality"))
(list
"Tonalité :"
(h "span" '(("id" "g-Tonality")) (list (string tonality)))))
(chord-tables chords))))))
; Lyrics
(defun emph (str cs)
(apply #'concatenate 'string
(loop for c across str collect
(if (member c cs) (h "emph" nil (list (make-string 1 :initial-element c))) (make-string 1 :initial-element c)))))
(defun lyrics-line (line)
(h "div" nil (list (emph line (list #\, #\. #\? #\! #\-)))))
(defun lyrics-section (s)
(let ((p (car (cdr s))))
(part-tags
(car s)
(if p
(h "div" '(("class" "g-Lyrics__Paragraph")) (mapcar #'lyrics-line (lines p)))
nil))))
(defun lyrics-tags (lyrics)
(h "section" nil
(list
(h "h2" '(("class" "g-Subtitle")) '("Paroles"))
(h "div" '(("class" "g-Parts")) (mapcar #'lyrics-section lyrics)))))
; Export songs
(defun export-song (path)
(let* ((data (with-open-file (in path) (read in)))
(output (concatenate 'string "public/" (car (split path #\.)) ".html"))
(title (car (song-key 'title (cdr data))))
(from (car (song-key 'from (cdr data))))
(tonality (car (song-key 'tonality (cdr data))))
(chords (song-key 'chords (cdr data)))
(lyrics (song-key 'lyrics (cdr data))))
(write-file output (page
(format nil "~A – ~A" title from)
(h
"body"
nil
(list
(h "a" '(("class" "g-Back") ("href" "/")) '("Retour à l’accueil"))
(title-tags title from)
(chord-tags chords tonality)
(lyrics-tags lyrics)))))))
(dolist (path (cdr *posix-argv*))
(export-song path))
; Export index
(write-file "public/index.html" (page
"Music"
(h
"body"
nil
(list
(h "h1" '(("class" "g-Title")) '("Music"))
(h "ul" '(("class" "g-Songs"))
(mapcar
(lambda (path)
(let* ((data (with-open-file (in path) (read in)))
(href (concatenate 'string (car (split path #\.)) ".html"))
(title (car (song-key 'title (cdr data))))
(from (car (song-key 'from (cdr data)))))
(h "li" nil (list (h "a" (list (list "href" href)) (list (format nil "~A – ~A" from title)))))))
(cdr *posix-argv*)))))))