largely works; annoying problems remain

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