Disclaimer: Dieser Thread wurde aus dem alten Forum importiert. Daher werden eventuell nicht alle Formatierungen richtig angezeigt. Der ursprüngliche Thread beginnt im zweiten Post dieses Threads.
noch eine lsg fuer 10.5
(define (complement-base base) ; +
(cond
((equal? base 'a) 't)
((equal? base 't) 'a)
((equal? base 'g) 'c)
((equal? base 'c) 'g)
(else (error (string-append "Invalid base " (symbol->string base))))))
(define (complement-strand dna) ; +
(define (iter dna result)
(if (null? dna)
result
(iter (cdr dna) (append result (list (complement-base (car dna)))))))
(iter dna '()))
(complement-strand '(a g g t))
(define (make-double dna)
(define (iter dna result)
(if (null? dna)
result
(iter (cdr dna) (append result (list (cons (car dna) (complement-base (car dna))))))))
(iter dna '()))
(make-double '(g g a c t))
(define (is-double? dna)
(if (null? dna)
#t
(pair? (car dna))))
(is-double? '(a g c))
(is-double? '((cons a t) (cons g c)))
(is-double? '((a t) (g c)))
(define (count-bases dna)
(define (count-helper double-dna?)
(define (increase base value dna)
(if double-dna?
(if (or (equal? (car (car dna)) base) (equal? (car (car dna)) (complement-base base)))
(+ value 1)
value)
(if (equal? (car dna) base)
(+ value 1)
value)))
(define (iter dna a t g c)
(if (null? dna)
(list (cons 'a a) (cons 't t) (cons 'g g) (cons 'c c))
(iter (cdr dna)
(increase 'a a dna)
(increase 't t dna)
(increase 'g g dna)
(increase 'c c dna))))
(iter dna 0 0 0 0))
(count-helper (is-double? dna)))
(count-bases '((g c) (g c) (a t) (c g)))
(count-bases '(a g t a c t c t))
(count-bases (make-double '(a g t a c t c t)))
(define (prefix? dna reference-dna)
(define (iter dna reference-dna)
(if (or (null? dna) (null? reference-dna))
#t
(if (equal? (car dna) (car reference-dna))
(iter (cdr dna) (cdr reference-dna))
#f)))
(iter dna reference-dna))
(prefix? '(g t c) '(g t c a t))
(prefix? '(g t c) '(a g g t c))
(define (appears? dna reference-dna)
(define (iter-reference-dna reference-dna)
(define (iter-dna dna reference-dna)
(if (null? dna)
#t
(if (equal? (car dna) (car reference-dna))
(iter-dna (cdr dna) (cdr reference-dna))
#f)))
(if (null? reference-dna)
#f
(if (iter-dna dna reference-dna)
#t
(iter-reference-dna (cdr reference-dna)))))
(iter-reference-dna reference-dna))
(appears? '(c a t) '(t c a t g))
(appears? '(c a t) '(t c c g t a))
(define (list-count list)
(define (iter list count)
(if (null? list)
count
(iter (cdr list) (+ count 1))))
(iter list 0))
(define (covers? dna reference-dna)
(let ((dna-count (list-count dna)))
(define (iter-step reference-dna)
(define (iter dna reference-dna)
(cond
((and (null? dna) (null? reference-dna)) #t)
((and (not (null? dna)) (null? reference-dna) )#f)
((and (null? dna) (not (null? reference-dna))) #t)
(else
(if (equal? (car dna) (car reference-dna))
(iter (cdr dna) (cdr reference-dna))
#f))))
(if (null? reference-dna)
#t
(if (iter dna reference-dna)
(iter-step (list-tail reference-dna dna-count))
#f)))
(iter-step reference-dna)))
(covers? '(a g c) '(a g c a g c a g c))
(covers? '(a g c) '(a g c a g c a g))
(covers? '(a g c) '(a g c t t g))
(define (prefix n dna)
(define (iter n dna)
(if (= n 0)
'()
(cons (car dna) (iter (- n 1) (cdr dna)))))
(iter n dna))
(prefix 4 '(c g a c t t a g))
(define (is-wiederholungsabdeckung? prefix dna)
(define (iter? my-dna my-prefix)
; (display "dna:")(display my-dna) (display " pfx:")(display my-prefix) (newline)
(if (null? my-dna)
(if (null? my-prefix)
#t
#f)
(if (null? my-prefix)
(iter? my-dna prefix)
(if (equal? (car my-dna) (car my-prefix))
(iter? (cdr my-dna) (cdr my-prefix))
#f))))
(if (null? prefix)
#f
(iter? dna prefix)))
(is-wiederholungsabdeckung? '(a g c d) '(a g c a g c a g c))
(define (kernel dna)
(let ((dna-count (list-count dna)))
(define (is-wiederholungsabdeckung? prefix)
(define (iter? my-dna my-prefix)
; (display "dna:")(display my-dna) (display " pfx:")(display my-prefix) (newline)
(if (null? my-dna)
(if (null? my-prefix)
#t
#f)
(if (null? my-prefix)
(iter? my-dna prefix)
(if (equal? (car my-dna) (car my-prefix))
(iter? (cdr my-dna) (cdr my-prefix))
#f))))
(if (null? prefix)
#f
(iter? dna prefix)))
(define (find-prefix)
(define (iter prefix)
(if (is-wiederholungsabdeckung? prefix)
prefix
(let ((prefix-count (list-count prefix)))
; (display "no prefix: ") (display prefix) (newline)
(if (= (+ prefix-count 1) dna-count)
dna
(iter
(if (null? prefix)
(list (list-ref dna 0))
(append prefix (list (list-ref dna prefix-count)))))))))
(iter '()))
(find-prefix)))
(kernel '(a g c a g c a g c))
(define (draw-dna dna)
(define (iter dna double? line-up chain-up base-up chain-middle base-down chain-down line-down)
(if (null? dna)
(begin
(display line-up) (newline)
(display chain-up) (newline)
(display base-up) (newline)
(if double?
(begin
(display chain-middle) (newline)
(display base-down) (newline)
(display chain-down) (newline)
(display line-down) (newline))))
(let* ((my-base-up (if double?
(caar dna)
(car dna)))
(my-base-down (if double?
(cdar dna)
'invalid-base)))
(iter
(cdr dna)
double?
(string-append line-up "-----")
(string-append chain-up " ! ")
(string-append base-up " " (symbol->string my-base-up) " ")
(string-append chain-middle " : ")
(string-append base-down " " (symbol->string my-base-down) " ")
(string-append chain-down " ! ")
(string-append line-up "-----")))))
(iter dna (is-double? dna) "" "" "" "" "" "" ""))
(draw-dna '(a g g t c))
'()
(draw-dna (make-double '(a g g t c)))