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