a95ed046cc2c

--- a/rosalind.asd	Thu Aug 04 22:30:18 2022 -0400
+++ b/rosalind.asd	Fri Aug 05 00:16:11 2022 -0400
@@ -29,8 +29,9 @@
                :drakma
                :iterate
                :losh
+               :parse-float
+               :parsnip
                :str
-               :parse-float
 
                )
 

--- a/src/problems/corr.lisp	Thu Aug 04 22:30:18 2022 -0400
+++ b/src/problems/corr.lisp	Fri Aug 05 00:16:11 2022 -0400
@@ -25,8 +25,7 @@
 (defparameter *output*
   "GAGGA->GATGA
 TTCAT->TTGAT
-TTTCC->TTTCA
-")
+TTTCC->TTTCA")
 
 
 ;;;; Problem ------------------------------------------------------------------

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/nwck.lisp	Fri Aug 05 00:16:11 2022 -0400
@@ -0,0 +1,89 @@
+(defpackage :rosalind/nwck (:use :cl :rosalind :parsnip))
+(in-package :rosalind/nwck)
+
+(defparameter *input* "(cat)dog;
+dog cat
+
+(dog,cat);
+dog cat")
+
+(defparameter *output* "1 2")
+
+
+(defstruct node
+  (label nil)
+  (adjacent (list)))
+
+(defmethod print-object ((o node) s)
+  (print-unreadable-object (o s)
+    (format s "~A" (node-label o))))
+
+
+(defparser end ()
+  (char-of #\;))
+
+(defparser label-char ()
+  (char-if (lambda (ch)
+             (or (alpha-char-p ch)
+                 (char= ch #\_)))))
+
+(defparser label ()
+  (let! ((name (collect-into-string 'label-char)))
+    (ok (if (string= "" name)
+          (gensym)
+          (alexandria:symbolicate name)))))
+
+(defparser leaf ()
+  (let! ((label 'label))
+    (ok (make-node :label label))))
+
+(defparser branches ()
+  (sep 'subtree (char-of #\,)))
+
+(defparser internal ()
+  (let! ((branches (prog2! (char-of #\()
+                           'branches
+                           (char-of #\))))
+         (label 'label))
+    (ok (let ((result (make-node :label label :adjacent branches)))
+          (dolist (child (node-adjacent result))
+            (push result (node-adjacent child)))
+          result))))
+
+(defparser subtree ()
+  (or! 'internal 'leaf))
+
+(defparser newick ()
+  (prog1! 'subtree))
+
+(defun parse-newick (string)
+  (with-input-from-string (stream string)
+    (parse 'newick stream)))
+
+
+(defun astar-tree (start goal-label)
+  (losh:astar
+    :start start
+    :neighbors #'node-adjacent
+    :goalp (lambda (node)
+             (eql goal-label (node-label node)))
+    :cost (constantly 1)
+    :heuristic (constantly 0)
+    :test #'eql))
+
+(defun path-length (tree a b)
+  (let ((start (car (last (astar-tree tree a))))) ; meh
+    (1- (length (astar-tree start b)))))
+
+
+(define-problem nwck (data stream) *input* *output*
+  (losh:string-join
+    " "
+    (loop
+      :for line = (read-line data nil nil)
+      :while line
+      :collect (let ((tree (parse-newick line))
+                     (points (mapcar #'alexandria:symbolicate (str:words (read-line data)))))
+                 (read-line data nil nil) ; chomp separator line, if any
+                 (destructuring-bind (start end) points
+                   (path-length tree start end))))))