src/problems/nwck.lisp @ 97dda08645b3 default tip

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