Common Lisp：符号计算引论 第十一章 键盘练习

;;; Common Lisp: A Gentle Introduction to Symbolic Computation
;;; Chapter 11 Keyboard Exercise: program about DNA & RNA
;;; A - 腺嘌呤 G - 鸟嘌呤 C - 胞嘧啶 T - 胸腺嘧啶

;; 计算四种核酸对应值
(defun complement-base (base)
  (cond ((equal base 'a) 't)
	((equal base 't) 'a)
	((equal base 'c) 'g)
	((equal base 'g) 'c)))

;; 计算核糖核酸的互补序列 (A C C T G) --> (T G G A C) 
(defun complement-strand (strand)
  (do ((strd strand (rest strd))
       (result nil (cons (complement-base (first strd))
			 result)))
      ((null strd) (reverse result))))

;; 将核糖核酸单序列补充为DNA双序列
(defun make-double (strand)
  (do ((strd strand (rest strd))
       (result nil (cons (list (first strd) 
			       (complement-base (first strd)))
			 result)))
      ((null strd) (reverse result))))

;; 计算核糖核酸（单序列或双序列）中各含氮碱基的数目
(defun count-bases (strand)
  (let ((num-of-a 0) (num-of-g 0)
	(num-of-c 0) (num-of-t 0))
    (dolist (elem strand)
      (cond ((listp elem) (cond ((equal (first elem) 'a) (incf num-of-a) (incf num-of-t))
				((equal (first elem) 'g) (incf num-of-g) (incf num-of-c))
				((equal (first elem) 'c) (incf num-of-c) (incf num-of-g))
				((equal (first elem) 't) (incf num-of-t) (incf num-of-a))))
	    (t (cond ((equal elem 'a) (incf num-of-a))
		     ((equal elem 'g) (incf num-of-g))
		     ((equal elem 'c) (incf num-of-c))
		     ((equal elem 't) (incf num-of-t))))))
    (list (list 'a num-of-a) (list 'g num-of-g) (list 'c num-of-c) (list 't num-of-t))))

;; 书上的方法观察到了双序列和单序列的计算共性——都需要增加相应的值，无重复代码
;(defun count-bases (dna)
;  (let ((acnt 0) (tcnt 0) (gcnt 0) (ccnt 0))
;    (labels ((count-one-base (base)
;	       (cond ((equal base 'a) (incf acnt))
;		     ((equal base 't) (incf tcnt))
;		     ((equal base 'g) (incf gcnt))
;		     ((equal base 'c) (incf ccnt)))))
;      (dolist (element dna)
;	(cond ((atom element) (count-one-base element))
;	      (t (count-one-base (first element))
;		 (count-one-base (second element)))))
;      (list (list 'a acnt)
;	     (list 't tcnt)
;	     (list 'g gcnt)
;	     (list 'c ccnt)))))

;; 判断核糖序列1是否为核糖序列2的前缀
(defun prefixp (strand1 strand2)
  (do ((strd1 strand1 (rest strd1))
       (strd2 strand2 (rest strd2)))
      ((null strd1) t)
    (if (not (equal (first strd1)
		    (first strd2)))
	(return nil))))

;; 判断核糖序列1是否在核糖序列2中出现
(defun appearsp (strand1 strand2)
  (do ((strd1 strand1)
       (strd2 strand2 (rest strd2)))
      ((> (length strd1) (length strd2)) nil)
    (if (prefixp strd1 strd2) (return t))))

;; 判断核糖序列1是否在核糖序列2中重复出现如 （A G C） 在（A G C A G C A G C）中重复出现
(defun coverp (strand1 strand2)
  (do ((strd1 strand1)
       (strd2 strand2 (nthcdr (length strand1) strd2)))
      ((null strd2) t)
    (if (not (prefixp strd1 strd2)) (return nil))))

;; 求核糖序列strand中最左边的n个含氮碱基
(defun prefix (n strand)
  (let ((result nil))
    (dotimes (i n (reverse result))
      (setf result (cons (nth i strand) result)))))

;; 计算核糖序列的“核”（重复出现的最小含氮碱基单元）
(defun kernel (strand)
  (do* ((len 1 (+ len 1))
	(pre (prefix len strand) (prefix len strand)))
       ((equal len (length strand)) strand)
    (if (coverp pre strand) (return pre))))

;; 画双螺旋DNA图，如下所示
;; ----------------------------------------------------
;; !   !   !   !   !   !   !   !   !   !   !   !   !   
;; A   G   C   T   G   A   T   C   A   G   C   T   C   
;; .   .   .   .   .   .   .   .   .   .   .   .   .   
;; .   .   .   .   .   .   .   .   .   .   .   .   .   
;; T   C   G   A   C   T   A   G   T   C   G   A   G   
;; !   !   !   !   !   !   !   !   !   !   !   !   !   
;; ----------------------------------------------------
(defun draw-dna (strand)
  (let ((comple-strd (complement-strand strand))
	(len (length strand)))
    (dotimes (i len) (format t "----"))
    (format t "~%")
    (dotimes (i len) (format t "!   "))
    (format t "~%")
    (dolist (s strand) (format t "~S   " s))
    (format t "~%")
    (dotimes (i len) (format t ".   "))
    (format t "~%")
    (dotimes (i len) (format t ".   "))
    (format t "~%")
    (dolist (s comple-strd) (format t "~S   " s))
    (format t "~%")
    (dotimes (i len) (format t "!   "))
    (format t "~%")
    (dotimes (i len) (format t "----"))
    (format t "~%")))