(ql:quickload :cl-who)
(use-package 'cl-who)

(defun punnett (parent-a parent-b &optional (type :mono))
  (declare (string parent-a parent-b)
           (keyword type))
  (case type
    (:mono
     (let* ((a (map 'list #'identity
                    parent-a))
            (b (map 'list #'identity
                    parent-b))
            (lena (length a))
            (lenb (length b)))
       (if (not (= lena lenb))
           (if (< lena lenb)
               (error "a < b, ~a < ~a" lena lenb)
               (error "a > b, ~a > ~a" lena lenb))
           (loop for from-b in b
                 collect (loop for from-a in a
                               collect (if (upper-case-p from-b)
                                           (format nil "~c~c" from-b from-a)
                                           (format nil "~c~c" from-a from-b)))))))))

(defun punnett-html (string-a string-b &optional (type :mono))
  (declare (ignore type))
  (with-html-output-to-string (out)
    (:table
     (loop for line in (punnett string-a string-b)
        do (htm (:tr (loop for cell in line
                          do (htm (:td (str cell))))))))))