hsmusic/hsmusic.lisp

(ql:quickload '(:cl-yaml :alexandria :cl-ppcre))
(defpackage :hsmusic
  (:use :common-lisp :alexandria))
(in-package :hsmusic)

(defparameter tracks
  (loop for path in (directory #p"hsmusic-data/album/*.yaml")
        appending (loop for entry in (yaml:parse path :multi-document-p t)
                        when (and (not (symbolp entry)) (gethash "Track" entry))
                          collect entry)))

; terrible, idc
; lossy! (not surprising)
; upcase for nice interning
(defun track->href (track)
  (or (gethash "Directory" track)
      (let ((r (copy-array (gethash "Track" track))))
        (setf r (ppcre:regex-replace-all " " r "-"))
        (setf r (ppcre:regex-replace-all "&"   r "and"))
        (setf r (ppcre:regex-replace-all "[^a-zA-Z0-9-]" r ""))
        (setf r (ppcre:regex-replace-all "-{2,}"   r ""))
        (setf r (ppcre:regex-replace-all "^-+|-+$" r ""))
        (nstring-downcase r))))

(defun track->url (track)
  (format nil "https://hsmusic.wiki/track/~a" (track->href track)))

; let's just store the href because that's unambiguous and links are desirable anyway

; string name -> href 
; so we don't have to research over and over
; there's ambiguity here! so consult only when not given a track:! 
(defparameter hrefs (make-hash-table :test 'equal))

(loop for track in tracks
      do (setf (gethash (gethash "Track" track) hrefs) (track->href track)))

; a -> b <-> a references b
; screw it! let's use symbols. why not? (LKFDSJKFDJ)
; it's a finite set it's FINE
(defparameter -> (make-hash-table))
(defparameter <- (make-hash-table))

(loop for track in tracks
      do (let ((from-name (intern (track-normalized-name track) :keyword)))
           (loop for ref in (append (gethash "Referenced Tracks" track) (gethash "Sampled Tracks" track))
                 do (let ((to-name (intern (normalize-name ref) :keyword)))
                      ; bodge
                      (unless (eq from-name to-name)
                        (unionf (gethash from-name ->)   (list to-name))
                        (unionf (gethash   to-name <-) (list from-name)))))))

(defun tree (src from depth)
  (let ((succs (gethash from src)))
    (if (and (plusp depth) (consp succs))
        (list from (mapcar (lambda (x) (tree src x (- depth 1))) succs))
        from)))

(defun ->tree (from depth)
  (tree -> from depth))

(defun <-tree (from depth)
  (tree <- from depth))

(defun pp-tree (tree &key (stream t) (indent 0) (indent-increment 2))
  (let ((ind (make-string indent :initial-element #\ )))
    (if (symbolp tree)
        (format stream "~a~a~%" ind tree)
        (destructuring-bind (from tos) tree
          (format stream "~a~a~%" ind from)
          (loop for to in tos
                do (pp-tree to :stream stream
                               :indent (+ indent indent-increment)
                               :indent-increment indent-increment))))))