I have a problem with my medical database in Scheme. I want to write a function that takes X symptoms and searches through my database for a match with a diagnose.
This is what I've done so far:
(define helper-match
(lambda (ls)
(reverse
(let loop ([ls ls] [found '()] [acc '()])
(cond
[(null? ls)
acc]
[(memq (car ls) found)
(loop (cdr ls)
found
(if (memq (car ls) acc)
acc
(cons (car ls) acc)))]
[else
(loop (cdr ls)
(cons (car ls) found)
acc)])))))
Above is a function that check for duplicates but I don't know how to write it so it compares with my database.
the structure of the database looks like this:
(define *medical-db-2*
'((1
(disease (meningit)
(symptom (fever) (headache) (vertigo) (vomiting) (stiffness) (light sensitivity))))
(2
(disease (encefalit)
(symptom (fever) (headache) (vertigo) (vomiting) (disorientation) (cramps))))
Related
I'm trying to learn how to do this, and I know it involves stacks, but I can't wrap my head around it unless I see a function in action. We've been given this example of a function to create and I need some help. Here it is:
;leafpile takes a list and returns the result of pushing all
;occurrences of the symbol 'leaf to the end of the list
> (leafpile '(rock grass leaf leaf acorn leaf))
(list 'rock 'grass 'acorn 'leaf 'leaf 'leaf)
We can use a helper function but the function needs to be written in a way to minimize recursive passes
update (heres what I got so far)
(define (leafpile/help ls pile)
(local
[
(define (helper 2ls leafpile)
(cond
[(empty? 2ls) (filter ls 'leaf)]
[(equal? (first 2ls) 'leaf)
(cons (first 2ls) (helper (rest 2ls) leafpile))]
[else (helper (rest 2ls) leafpile)]))]
(helper ls pile)))
OK snow I have this:
(define (helper lsh)
(cond
[(empty? lsh) '()]
[(not(equal? (first lsh) 'leaf))
(cons (first lsh) (helper (rest lsh)))]
[else (helper (rest lsh))]))
(define (count-leaf ls)
(cond
[(empty? ls) 0]
[(not (equal? 'leaf (first ls))) (count-leaf (rest ls))]
[else (add1 (count-leaf (rest ls)))]))
(define (leafpile ls)
(append (helper ls) (make-list (count-leaf ls) 'leaf)))
but I need it in one simple function with the least recursive passes possible.
Here is the solution I came up with:
(define (leafpile lst)
(for/fold ([pile (filter (lambda (leaf?) (not (equal? leaf? 'leaf))) lst)])
([i (build-list (for/fold ([leaves 0])
([leaf? lst])
(if (equal? leaf? 'leaf)
(add1 leaves)
leaves)) values)])
(append pile '(leaf))))
How it works:
The main for/fold loop iterates over a list with a length of the number of leaves there are, and the 'collection value' is a list of all the elements in lst that aren't the symbol 'leaf (achieved by filter).
Sample input/output:
> (leaf-pile '(rock grass leaf leaf acorn leaf))
'(rock grass acorn leaf leaf leaf)
Really simple way to do this:
(define (leaf? v)
(eq? v 'leaf))
(define (leafpile lst)
(append (filter (compose not leaf?) lst)
(filter leaf? lst)))
It really doesn't need to be more to it unless you experience performance issues and I usually don't for small lists. I tend to think of lists with fewer than a million elements as small. The obvious recursive one that might not be faster:
(define (leafpile lst)
(local [(define (leafpile lst n) ; screaming for a named let here!
(cond
((null? lst) (make-list n 'leaf))
((leaf? (car lst)) (leafpile (cdr lst) (add1 n)))
(else (cons (car lst) (leafpile (cdr lst) n)))))]
(leafpile lst 0)))
A tail recursive one that accumulates non leaf values, counts leaf values and uses srfi/1 append-reverse! to produce the end result:
(require srfi/1)
(define (leafpile lst)
(local [(define (leafpile lst acc n) ; I'm still screaming
(cond
((null? lst) (append-reverse! acc (make-list n 'leaf)))
((leaf? (car lst)) (leafpile (cdr lst) acc (add1 n)))
(else (leafpile (cdr lst) (cons (car lst) acc) n))))]
(leafpile lst '() 0)))
tScheme novice question:
I need to determine if a list contains an even or odd amount of atoms using recursion. I know the easy way is to get list length and determine if it is even or odd, but I would like to see hows it's done using recursion.
(oddatom
(LIST 'x 'y 'v 'd 'r 'h 'y))
should return #t, while
(oddatom
'((n m) (f p) l (u k p)))
should return #f
appreciate the help.
Here's my version of the solution:
(define (oddatom? lst)
(let recur ((odd #f)
(x lst))
(cond ((null? x) odd)
((pair? x) (recur (recur odd (car x)) (cdr x)))
(else (not odd)))))
I like Chris Jester-Young's answer, but I think it's worth providing a tail-recursive version that maintains its own stack as well. Note that this is an exercise in converting non-tail recursion into tail recursion, which is an imporant technique for some algorithms in Scheme. In this case, though, it's probably not all that important, and the code in Chris Jester-Young's answer does feel much more natural. So take this as an exercise, not necessarily a significant improvement.
The idea here is that the inner function, odd?, takes a list of things, and a value indicating whether an odd number of atoms (other than the empty list) have been seen so far.
(define (oddatom? thing)
(let odd? ((things (list thing))
(result #f))
(cond
;; We're out of things to see. Did we see an odd number of things?
((null? things)
result)
;; Our list of things has the form ((x . y) …), so we recurse on
;; (x y …), with the *same* value for result, since we haven't
;; "seen" x or y yet, we've just "unwrapped" them.
((pair? (car things))
(odd? (cons (caar things) (cons (cdar things) (cdr things))) result))
;; Our list of things has the form (() …), so we recurse on
;; (…), with the *same* value for result, since we haven't "seen" any
;; additional atoms.
((null? (car things))
(odd? (cdr things) result))
;; Our list of things has the form (<atom> …), so we recurse on (…),
;; but with a flipped value for result, since we've seen one more atom.
(else
(odd? (cdr things) (not result))))))
The last two cases could be combined, making the second recursive argument based on the value of (null? (car things)) as:
(define (oddatom? thing)
(let odd? ((things (list thing))
(result #f))
(cond
((null? things)
result)
((pair? (car things))
(odd? (cons (caar things) (cons (cdar things) (cdr things))) result))
(else
(odd? (cdr things) (if (null? (car things))
result
(not result)))))))
I'd go for this:
(define (oddatom lst)
(cond
((null? lst) #f)
((not (pair? lst)) #t)
(else (not (eq? (oddatom (car lst)) (oddatom (cdr lst)))))))
which means:
the empty list is not odd (#f)
an atom is odd (#t)
otherwise, one and only one of the car or the cdr of the list may be odd (exclusive or).
Test cases (in Racket), including improper lists:
(require rackunit)
(check-equal? (oddatom (list 'x 'y 'v 'd 'r 'h 'y)) #t)
(check-equal? (oddatom '((n m) (f p) l (u k p))) #f)
(check-equal? (oddatom '(a (b) c)) #t)
(check-equal? (oddatom (cons 1 2)) #f)
(check-equal? (oddatom 1) #t)
(check-equal? (oddatom '(1 (2 . 3))) #t)
Here is one:
(define (odd-atom? obj)
(and (not (null? obj))
(or (not (pair? obj))
(let ((this? (odd-atom? (car obj)))
(rest? (odd-atom? (cdr obj))))
(or (and (not this?) rest?)
(and (not rest?) this?))))))
or, learning from #uselpa to simplify the 'or this? rest?' logic above, another one:
(define (odd-atom? obj)
(and (not (null? obj))
(or (not (pair? obj))
(not (eq? (odd-atom? (car obj))
(odd-atom? (cdr obj)))))))
If '() is an atom (like it is in CommonLisp where '() is also T), it should be (odd-atom? '(() () ())) is #t:
(define (odd-atom? obj)
(and (not (null? obj))
(or (not (pair? obj))
(let ((this? (or (null? (car obj))
(odd-atom? (car obj))))
(rest? (odd-atom? (cdr obj))))
(not (eq? this? rest?))))))
> (odd-atom? '())
#f
> (odd-atom? '(()))
#t
> (odd-atom? '(() () ()))
#t
> (odd-atom? '(() ()))
#f
> (odd-atom? '(() (a)))
#f
> (odd-atom? '(() (a b)))
#t
> (odd-atom? '((a) (a b)))
#t
> (odd-atom? '((a b) (a b)))
#f
>
This code replaces first person words with second person words and vice versa. However, it goes through each pair for each word in the phrase, so sometimes it will change back.
Here is the code:
(define (replace pattern replacement lst replacement-pairs)
(cond ((null? lst) '())
((equal? (car lst) pattern)
(cons replacement
(many-replace (cdr replacement-pairs) (cdr lst))))
(else (cons (car lst)
(many-replace (cdr replacement-pairs) (cdr lst))))))
(define (many-replace replacement-pairs lst)
(cond ((null? replacement-pairs) lst)
(else (let ((pat-rep (car replacement-pairs)))
(replace (car pat-rep)
(cadr pat-rep)
(many-replace (cdr replacement-pairs)
lst) replacement-pairs)))))
(define (change-person phrase)
(many-replace '((i you) (me you) (am are) (my your) (are am) (you i) (your my))
phrase))
For example if I entered
(change-person '(you are not being very helpful to me))
it would change you to i but then back to you. How do I fix this?
The procedures replace and many-replace are overly complicated, and the mutual recursion is not doing what you think. If we simplify those procedures and make sure that only a single pass is performed over the input list, we can get a correct answer:
(define (replace replacement-pairs pattern)
(cond ((null? replacement-pairs)
pattern)
((equal? (caar replacement-pairs) pattern)
(cadar replacement-pairs))
(else
(replace (cdr replacement-pairs) pattern))))
(define (many-replace replacement-pairs lst)
(if (null? lst)
'()
(cons (replace replacement-pairs (car lst))
(many-replace replacement-pairs (cdr lst)))))
The keen eye will notice that the previous procedures can be expressed in a succinct way by using some higher-order procedures. A more idiomatic solution could look like this:
(define (replace replacement-pairs pattern)
(cond ((assoc pattern replacement-pairs) => cadr)
(else pattern)))
(define (many-replace replacement-pairs lst)
(map (curry replace replacement-pairs) lst))
Either way, it works as expected:
(change-person '(you are not being very helpful to me))
=> '(i am not being very helpful to you)
I've written a slightly easier solution:
(define (many-replace pattern phrase)
(let loop ((phrase phrase) (result '()))
(if (empty? phrase) (reverse result)
(let* ((c (car phrase)) (a (assoc c pattern)))
(if a
(loop (cdr phrase) (cons (cadr a) result))
(loop (cdr phrase) (cons c result)))))))
(change-person '(you are not being very helpful to me))
=> '(i am not being very helpful to you)
I'm trying to learn how to use match in scheme. I sort of understand how it works with really short problems (ie: defining length is just two lines) but not with problems where there's more than one input, and helper programs. For example, here's a popular way of defining union:
(define ele?
(lambda (ele ls)
(cond
[(null? ls) #f]
[(eq? ele (car ls)) #t]
[else (ele? ele (cdr ls))])))
(define union
(lambda (ls1 ls2)
(cond
[(null? ls2) ls1]
[(ele? (car ls2) ls1) (union ls1 (cdr ls2))]
[else (union (cons (car ls2) ls1) (cdr ls2))])))
How do you do this using match in both programs? (or would you even need two programs?)
the first one could be implemented like that:
(define ele?
(lambda (a b)
(let ((isa? (lambda (x) (eq? (car x) a))))
(match b [(? null?) #f]
[(? isa?) #t]
[_ (ele? a (cdr b))]))))
then the second is easy
(define uni
(lambda (ls1 ls2)
(let ((carinls2? (lambda (x) (ele? (car x) ls1))))
(match ls2 [(? null?) ls1]
[(? carinls2?) (uni ls1 (cdr ls2))]
[_ (uni (cons (car ls2) ls1) (cdr ls2))]))))
maybe there is a smarter way to avoid these one argument let lambdas but i'm still learning ;)
I have been working on the following function flatten and so far have it working for just lists. I was wondering if someone could provide me with some insight on how to get it work with pairs? For example (flatten '(a .a)) would return (a a). Thanks.
(define (flatten list)
(cond ((null? list) null)
((list? (car list)) (append (flatten (car list)) (flatten (cdr list))))
(else
(cons (car list) (flatten (cdr list))))))
Here's one option:
(define (flatten x)
(cond ((null? x) '())
((pair? x) (append (flatten (car x)) (flatten (cdr x))))
(else (list x))))
This does what you want, without requiring append, making it o(n). I walks the list as a tree. Some schemes might throw a stack overflow error if the list is too deeply nested. In guile this is not the case.
I claim no copyright for this code.
(define (flatten lst)
(let loop ((lst lst) (acc '()))
(cond
((null? lst) acc)
((pair? lst) (loop (car lst) (loop (cdr lst) acc)))
(else (cons lst acc)))))
(define (flatten l)
(cond
[(empty? l) empty]
[(list? l)
(append (flatten (first l))
(flatten (rest l)))]
[else (list l)]))