; 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")))
(defun part-tags (key children)
(h "div"
'(("class" "g-Part"))
(list
(if
(eql key 'all)
nil
(h "h3" nil (list (part-name key))))
children)))
; Chords
(defun chord-row (chords)
(h "tr" nil (mapcar (lambda (x) (h "td" nil (list (string x)))) chords)))
(defun chord-rows (xs)
(if
(eql xs nil)
nil
(cons (chord-row (car xs)) (chord-rows (cdr xs)))))
(defun chord-table (key row)
(part-tags
key
(h "table" '(("class" "g-Chords")) (chord-rows row))))
(defun chord-tables (xs)
(if
(eql xs nil)
nil
(let ((key (car (car xs)))
(rows (cdr (car xs))))
(cons (chord-table key rows) (chord-tables (cdr xs))))))
(defun chord-tags (chords)
(h "section" nil
(list
(h "h2" '(("class" "g-Subtitle")) '("Accords"))
(h "div" '(("class" "g-Parts")) (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)))))
; Main
(defun export-song (path)
(let ((data (with-open-file (in path) (read in))))
(let ((output (concatenate 'string "public/" (car (split path #\.)) ".html"))
(title (car (song-key 'title (cdr data))))
(from (car (song-key 'from (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)
(lyrics-tags lyrics))))))))
(export-song "songs/graeme-allwright/petit-garcon.lisp")
(export-song "songs/ben-e-king/stand-by-me.lisp")