|
|
@@ -1,25 +1,30 @@
|
|
|
(ql:quickload :cl-who)
|
|
|
-(import 'cl-who:with-html-output-to-string)
|
|
|
+(use-package 'cl-who)
|
|
|
|
|
|
-(defun punnet (stringa stringb)
|
|
|
- (declare (string stringa stringb))
|
|
|
- (let* ((a (map 'list #'(lambda (x) (format nil "~c" x)) stringa))
|
|
|
- (b (map 'list #'(lambda (x) (format nil "~c" x)) stringb))
|
|
|
- (lena (length a))
|
|
|
- (lenb (length b)))
|
|
|
- (if (not (= lena lenb))
|
|
|
- (if (< lena lenb)
|
|
|
- (error "a < b, ~a < ~b" lena lenb)
|
|
|
- (error "a > b, ~a > ~b" lena lenb))
|
|
|
- (loop for index-b from 0 to (1- lena)
|
|
|
- collect (loop for index-a from 0 to (1- lena)
|
|
|
- collect (if (= index-b index-a)
|
|
|
- (nth index-b b)
|
|
|
- (nth index-a a)))))))
|
|
|
+(defun punnett (parent-a parent-b &optional (type :mono))
|
|
|
+ (declare (string parent-a parent-b)
|
|
|
+ (keyword type))
|
|
|
+ (case type
|
|
|
+ (:mono
|
|
|
+ (let* ((a (map 'list #'(lambda (x) (format nil "~c" x))
|
|
|
+ parent-a))
|
|
|
+ (b (map 'list #'(lambda (x) (format nil "~c" x))
|
|
|
+ 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 (concatenate 'string from-a from-b))))))))
|
|
|
|
|
|
-(defun punnet-html (string-a string-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 (punnet string-a string-b)
|
|
|
+ (loop for line in (punnett string-a string-b)
|
|
|
do (htm (:tr (loop for cell in line
|
|
|
do (htm (:td (str cell))))))))))
|
|
|
+
|
