mismatch-count

mismatch-count-test.lisp

(ql:quickload "lisp-unit")

(defpackage #:mismatch-count-test
  (:use #:cl #:lisp-unit)
  (:export #:run))

(in-package #:mismatch-count-test)

;;; Tests

(define-test no-difference-between-empty-sequences
  (assert-equal 0 (mismatch-count:count-mismatches "" "" :test #'char-equal)))

(define-test no-difference-between-identical-sequences
  (assert-equal 0 (mismatch-count:count-mismatches "GGACTGA"
						   "GGACTGA" :test #'char-equal)))

(define-test complete-count-in-small-sequence
  (assert-equal 3 (mismatch-count:count-mismatches "ACT"
						   "GGA" :test #'char-equal)))

(define-test small-count-in-middle-somewhere
  (assert-equal 1 (mismatch-count:count-mismatches "GGACG"
						   "GGTCG" :test #'char-equal)))

(define-test larger-distance
  (assert-equal 2 (mismatch-count:count-mismatches "ACCAGGG"
						   "ACTATGG" :test #'char-equal)))

(define-test invalid-to-get-distance-for-different-length-sequences
  (assert-equal nil (mismatch-count:count-mismatches "AGACAACAGCCAGCCGCCGGATT"
						     "AGGCAA"
						     :test #'char-equal))
  (assert-equal nil (mismatch-count:count-mismatches "AGACAACAGCCAGCCGCCGGATT"
						     "AGACATCTTTCAGCCGCCGGATTAGGCAA"
						      :test #'char-equal))
  (assert-equal nil (mismatch-count:count-mismatches "AGG"
						     "AGACAACAGCCAGCCGCCGGATT"
						      :test #'char-equal)))


(defun run (&key (test-name :all) (counter-names :all)
	      (print-errs t) (print-fail t))
  (when (eq counter-names :all)
    (setf counter-names (mismatch-count:counter-names)))
  (loop
     for counter-name in counter-names
     do
       (mismatch-count:set-counter counter-name)
       (format t "~&-----~%~&Testing counter implmentation ~S.~2%" counter-name)
       (let ((*print-errors* print-errs)
	     (*print-failures* print-fail))
	 (run-tests test-name :mismatch-count-test))))

mismatch-count.lisp

(defpackage #:mismatch-count
  (:use #:cl)
  (:export #:validation-behavior-names
	   #:set-validation-behavior
	   #:validation-behavior)
  (:export #:counter-names
	   #:set-counter
	   #:counter
	   #:count-mismatches))

(in-package #:mismatch-count)

;;; Counter definitions

(defun using-reduce (seq1 seq2 &key (test #'eql))
  "Count symbol mismatches in two sequences with `reduce' and `map'."
  (flet ((match-to-bit (sym1 sym2)
	   (if (funcall test sym1 sym2) 0 1)))
    (reduce #'+
	    (map 'list #'match-to-bit seq1 seq2))))

(defun using-count (seq1 seq2 &key (test #'eql))
  "Count symbol mismatches in two sequences with `count' and `map'."
  (count-if #'null
	    (map 'list test seq1 seq2)))

(defun using-loop (seq1 seq2 &key (test #'eql))
  "Count symbol mismatches in two sequences with `loop'."
  (etypecase seq1
    (list (loop
	     for sym1 in seq1
	     for sym2 in seq2
	     count (funcall (complement test) sym1 sym2)))
    (vector (loop
	       for sym1 across seq1
	       for sym2 across seq2
	       count (funcall (complement test) sym1 sym2)))))

(defun using-do (seq1 seq2 &key (test #'eql))
  "Count symbol mismatches in two sequences with `do'."
  (let ((count 0))
    (flet ((count-if-match (sym1 sym2)
	     (unless (funcall test sym1 sym2)
	       (incf count))))
      (etypecase seq1
	(list (do ((s1 seq1 (rest s1))
		   (s2 seq2 (rest s1)))
		  ((or (endp s1) (endp s2)) count)
		(count-if-match (car s1) (car s2)))) 
	(vector (dotimes (index (length seq1) count)
		  (count-if-match (aref seq1 index) (aref seq2 index))))))))

(defun using-recursion (seq1 seq2 &key (test #'eql))
  "Count symbol mismatches in two sequences with recursive function."
  (labels ((mismatch-count-r (s1 s2 acc)
	     (let ((next-mismatch (mismatch s1 s2 :test test)))
	       (if (null next-mismatch)
		   acc
		   (mismatch-count-r (subseq s1 (1+ next-mismatch))
				     (subseq s2 (1+ next-mismatch))
				     (1+ acc))))))
    (mismatch-count-r seq1 seq2 0)))

(defparameter *mismatch-counter*
  #'using-count
  "The function used by `count-mismatches'.")

(defparameter *counter-names*
  '(using-reduce using-count using-loop using-do using-recursion)
  "List of counters defined.")


;;; Validation definitions

(defparameter *validation-behaviors*
  '(:return-nil :issue-warn nil)
  "List of validation behavior values.")

(defparameter *validation-behavior*
  nil
  "What to do when input validations fail. Default `nil'.")


;;; Message definitions

(defconstant +messages+
  (list
   :expecting-known-parameter-value "Unrecognized value ~S for parameter ~S."
   :expecting-equal-sequence-lengths "Unequal lengths for sequences ~S and ~S."
   :expecting-same-sequence-type "Incompatible types for sequences ~S and ~S."))

(defun get-message (key)
  "Get message string from messages."
  (getf +messages+ key))


;;; Validation interface

(defun validation-behavior-names ()
  "List of validation behaviors."
  *validation-behaviors*)

(defun validation-behavior ()
  "Current validation behavior."
  *validation-behavior*)

(defun set-validation-behavior (behavior-name)
  "Set validation behavior."
  (assert (or (null behavior-name)
	      (find behavior-name (validation-behavior-names)))
	  (behavior-name)
	  (get-message :expecting-known-parameter-value)
	  behavior-name '*validation-behavior*)
  (setf *validation-behavior* behavior-name))


;;; Counter interface

(defun counter-names ()
  "List the mismatch counters available."
  *counter-names*)

(defun set-counter (name)
  "Set the counter."
  (setf name (find-symbol (symbol-name name) '#:mismatch-count))
  (assert (find name (counter-names))
	  (name)
	  (get-message :expecting-known-parameter-value)
	  name '*counter-names*)
  (setf *mismatch-counter* (symbol-function name)))

(defun counter ()
  "The current mismatch counter."
  *mismatch-counter*)

(defun count-mismatches (seq1 seq2 &key (test #'eql))
  "Count mismatches between two sequences."
  (flet ((validation-handler (condition)
	   (ecase *validation-behavior*
	     (:return-nil (return-from count-mismatches nil))
	     (:issue-warn
	      (or (warn (simple-condition-format-control condition)
			(values-list
			 (simple-condition-format-arguments condition)))
		  t))
	     (otherwise (warn (get-message :expecting-known-parameter-value)
			      *validation-behavior* '*validation-behavior*)))))
    (handler-bind ((error (lambda (c)
			    (when (validation-behavior)
			      (validation-handler c)))))
      (assert (= (length seq1) (length seq2))
	      (seq1 seq2)
	      (get-message :expecting-equal-sequence-lengths) seq1 seq2)
      (assert (typep seq2 (type-of seq1))
	      (seq1 seq2)
	      (get-message :expecting-same-sequence-types) seq1 seq2))
    (funcall *mismatch-counter* seq1 seq2 :test test)))