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 normalize-name (name)
  (ppcre:regex-replace-all
   "(^TRACK:|^-+|-+$)"
   (ppcre:regex-replace-all
    "[^A-Z0-9]+"
    (sb-unicode:normalize-string (string-upcase name) :nfkd)
    "-")
   ""))

;; (defun track-ref-p)

;; (defun track-ref)

(defun track-normalized-name (track)
  (normalize-name (gethash "Track" 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))))))