diff --git a/hsmusic.lisp b/hsmusic.lisp index d9dfee7..0095cef 100644 --- a/hsmusic.lisp +++ b/hsmusic.lisp @@ -1,29 +1,69 @@ -(ql:quickload '(:cl-yaml :alexandria :cl-ppcre)) +(ql:quickload '(:alexandria :cl-yaml :cl-json :yason)) (defpackage :hsmusic (:use :common-lisp :alexandria)) (in-package :hsmusic) +(defpackage :track) + (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))) + appending + (let* ((parsed (yaml:parse path :multi-document-p t)) + (album (gethash "Album" (cadr parsed)))) + (loop for entry in parsed + when (and (not (symbolp entry)) (gethash "Track" entry)) + collect (progn (setf (gethash "Album" entry) album) + entry))))) + +(defun tracks-with-name (name) + (loop for track in tracks + when (equal name (gethash "Track" track)) + collect track)) + +; does a macro really make sense like come on +; w/e +(defmacro apply-regices (target &body regices) + (with-gensyms (new) + `(let ((,new (copy-array ,target))) + ,@(loop for (from to) in regices + collecting `(setf ,new (ppcre:regex-replace-all ,from ,new ,to))) + ,new))) + +(defun default-href (name) + (apply-regices (string-downcase name) + (" " "-") + + ("&" "-and-") + ("\\+" "-plus-") + ("%" "-percent-") + + ("(\\b[^\\s-.]{2,})\\." "\\1-") + ("/\\.([^\\s-.]{2,})\\b" "-\\1") + + ("[/@#$%*()_=,[\\]{}|\\\\;:<>?`~]" "-") + + ("[áâäàå]" "a") + ("[çč]" "c") + ("[éêëè]" "e") + ("[íîïì]" "i") + ("[óôöò]" "o") + ("[úûüù]" "u") + + ("[^a-z0-9-]" "") + + ("-{2,}" "-") + + ("^-+|-+$" ""))) -; 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)))) + (default-href (gethash "Track" track)))) + +(defun href->url (href) + (format nil "https://hsmusic.wiki/track/~a" href)) (defun track->url (track) - (format nil "https://hsmusic.wiki/track/~a" (track->href track))) + (href->url (track->href track))) ; let's just store the href because that's unambiguous and links are desirable anyway @@ -32,8 +72,26 @@ ; there's ambiguity here! so consult only when not given a track:! (defparameter hrefs (make-hash-table :test 'equal)) +; TODO: logically flawed +(defparameter href->track-table (make-hash-table)) + (loop for track in tracks - do (setf (gethash (gethash "Track" track) hrefs) (track->href track))) + ; works? no. e.g. Buy NAK Sell DOOF has a Directory but is referred to without track: + ; track: is a disambiguator + ; how do we decide which one is "canon" then? idk! no clue. help + ; tomorrow problem + unless (gethash "Directory" track) + do (let ((href (intern (track->href track) :track))) + (setf (gethash (gethash "Track" track) hrefs) href) + (setf (gethash href href->track-table) track))) + +(defun track-name->href (name) + (if (string= (ignore-errors (subseq name 0 6)) "track:") + (intern (subseq name 6) :track) + (gethash name hrefs))) + +(defun href->track (href) + (gethash href href->track-table)) ; a -> b <-> a references b ; screw it! let's use symbols. why not? (LKFDSJKFDJ) @@ -42,13 +100,15 @@ (defparameter <- (make-hash-table)) (loop for track in tracks - do (let ((from-name (intern (track-normalized-name track) :keyword))) + do (let ((from-name (intern (track->href track) :track))) (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))))))) + do (let ((to-name (track-name->href ref))) + (when (not to-name) (print ref)) + (if (eq from-name to-name) + (format t "https://hsmusic.wiki/track/~a~%" from-name) + (progn + (unionf (gethash from-name ->) (list to-name)) + (unionf (gethash to-name <-) (list from-name)))))))) (defun tree (src from depth) (let ((succs (gethash from src))) @@ -57,10 +117,10 @@ from))) (defun ->tree (from depth) - (tree -> from depth)) + (tree -> (track-name->href from) depth)) (defun <-tree (from depth) - (tree <- from depth)) + (tree <- (track-name->href from) depth)) (defun pp-tree (tree &key (stream t) (indent 0) (indent-increment 2)) (let ((ind (make-string indent :initial-element #\ ))) @@ -72,3 +132,27 @@ do (pp-tree to :stream stream :indent (+ indent indent-increment) :indent-increment indent-increment)))))) + +(defun archive (url) + (sb-ext:run-program + "/usr/bin/env" + (list "curl" "--insecure" "-F" (format nil "url=~a" "url=") "-F" "capture_all=on" url))) + +(defparameter exif (yason:parse #p"/home/mbk/Music/exif-data.json")) + +(defun track->path (track) + (loop for e in exif + when (and (equal (gethash "Title" e) (gethash "Track" track)) + (equal (gethash "Album" e) (gethash "Album" track))) + do (return-from track->path (pathname (gethash "SourceFile" e))))) + +; TODO: <- & higher-order +; reversed bc personal preference :] +(defun ->m3u (from &optional (depth 413) (stream t)) + (dolist (href (reverse (flatten (->tree from depth)))) + (let ((path (track->path (href->track href)))) + (when path (format stream "~a~%" path))))) + +(defun ->link-list (from &optional (depth 413) (stream t)) + (dolist (href (reverse (flatten (->tree from depth)))) + (format stream "~a~%" (href->url href))))