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