punnet-squares.lisp 1.1 KB

1234567891011121314151617181920212223242526272829303132
  1. (ql:quickload :cl-who)
  2. (use-package 'cl-who)
  3. (defun punnett (parent-a parent-b &optional (type :mono))
  4. (declare (string parent-a parent-b)
  5. (keyword type))
  6. (case type
  7. (:mono
  8. (let* ((a (map 'list #'identity
  9. parent-a))
  10. (b (map 'list #'identity
  11. parent-b))
  12. (lena (length a))
  13. (lenb (length b)))
  14. (if (not (= lena lenb))
  15. (if (< lena lenb)
  16. (error "a < b, ~a < ~a" lena lenb)
  17. (error "a > b, ~a > ~a" lena lenb))
  18. (loop for from-b in b
  19. collect (loop for from-a in a
  20. collect (if (upper-case-p from-b)
  21. (format nil "~c~c" from-b from-a)
  22. (format nil "~c~c" from-a from-b)))))))))
  23. (defun punnett-html (string-a string-b &optional (type :mono))
  24. (declare (ignore type))
  25. (with-html-output-to-string (out)
  26. (:table
  27. (loop for line in (punnett string-a string-b)
  28. do (htm (:tr (loop for cell in line
  29. do (htm (:td (str cell))))))))))