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

(defpackage :rosalind/lcsq (:use :cl :rosalind :losh :iterate))
(in-package :rosalind/lcsq)

(defparameter *input* ">Rosalind_23
AACCTTGG
>Rosalind_64
ACACTGTGA")

(defparameter *output* "AACTTG")

(defun print-2d-array (array)
  (check-type array (array * (* *)))
  ;; This will cons a lot.
  (iterate
    (with strings = (make-array (array-dimensions array)))
    (for el :across-flat-array array :with-index i)
    (for s = (princ-to-string el))
    (setf (row-major-aref strings i) (princ-to-string el))
    (maximizing (length s) :into len)
    (finally (dotimes (row (array-dimension strings 0))
               (dotimes (col (array-dimension strings 1))
                 (format t " ~V@A" len (aref strings row col)))
               (terpri))))
  array)

(defun build-table (a b)
  ;; From CLRS 15.4
  (iterate
    (with-result table = (make-array (list (1+ (length a))
                                           (1+ (length b)))
                           :initial-element 0))
    (for ca :in-string a)
    (for i :from 1)
    (iterate
      (for cb :in-string b)
      (for j :from 1)
      (for up = (aref table (1- i) j))
      (for left = (aref table i (1- j)))
      (for upleft = (aref table (1- i) (1- j)))
      (setf (aref table i j)
            (cond ((char= ca cb) (1+ upleft))
                  ((>= up left) up)
                  (t left))))))

(defun reconstruct-lcs-from-table (a b table)
  (nreverse
    (iterate
      (with i = (length a))
      (with j = (length b))
      (until (or (zerop i) (zerop j)))
      (for ca = (aref a (1- i)))
      (for cb = (aref b (1- j)))
      (for up = (aref table (1- i) j))
      (for left = (aref table i (1- j)))
      (cond ((char= ca cb) (progn (collect ca :result-type string)
                                  (decf i)
                                  (decf j)))
            ((>= up left) (decf i))
            (t (decf j))))))

(defun least-common-subsequence (a b)
  (check-type a string)
  (check-type b string)
  (reconstruct-lcs-from-table a b (build-table a b)))


(define-problem lcsq (data stream) *input* *output*
  (destructuring-bind (a b) (mapcar #'cdr (u:read-fasta-into-alist data))
    (least-common-subsequence a b)))

#; Scratch --------------------------------------------------------------------