;;; Sample functions from the lecture Scheme.ppt ;;; Dave Reed 4/5/15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (my-length lst) (if (null? lst) 0 (+ 1 (my-length (cdr lst))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define NAMES '((Smith Pat Q) (Jones Chris J) (Walker Kelly T) (Thompson Shelly P))) (define (my-assoc key assoc-list) (cond ((null? assoc-list) #f) ((equal? key (caar assoc-list)) (car assoc-list)) (else (my-assoc key (cdr assoc-list))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define MENU '((bean-burger 2.99) (tofu-dog 2.49) (fries 0.99) (medium-soda 0.79) (large-soda 0.99))) (define (price item) (cadr (assoc item MENU))) (define (meal-price1 meal) (if (null? meal) 0.0 (+ (price (car meal)) (meal-price1 (cdr meal))))) (define (meal-price2 meal) (apply + (map price meal))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require scheme/list) (define FRIENDS '((amy (bob dan elle)) (bob (amy dan)) (chaz (dan elle)) (dan (chaz)) (elle (amy bob chaz dan)) (fred (dan)))) (define (get-friends person) (cadr (assoc person FRIENDS))) (define (get-circle person distance) (if (= distance 1) (get-friends person) (let ((circle (get-circle person (- distance 1)))) (remove person (remove-duplicates (append circle (apply append (map get-friends circle)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (craps1) (define (roll-until point) (let ((next-roll (+ (random 6) (random 6) 2))) (cond ((= next-roll 7) 'LOSER) ((= next-roll point) 'WINNER) (else (roll-until point))))) (let ((roll (+ (random 6) (random 6) 2))) (cond ((or (= roll 2) (= roll 12)) 'LOSER) ((= roll 7) 'WINNER) (else (roll-until roll))))) (define (craps2) (define (roll-until point) (let ((next-roll (+ (random 6) (random 6) 2))) (cond ((= next-roll 7) (list next-roll 'LOSER)) ((= next-roll point) (list next-roll 'WINNER)) (else (cons next-roll (roll-until point)))))) (let ((roll (+ (random 6) (random 6) 2))) (cond ((or (= roll 2) (= roll 12)) (list roll 'LOSER)) ((= roll 7) (list roll 'WINNER)) (else (cons roll (roll-until roll)))))) (define (craps3) (define (roll-until point) (let ((next-roll (+ (random 6) (random 6) 2))) (begin (display "Roll: ")(display next-roll) (newline) (cond ((= next-roll 7) 'LOSER) ((= next-roll point) 'WINNER) (else (roll-until point)))))) (let ((roll (+ (random 6) (random 6) 2))) (begin (display "Point: ") (display roll) (newline) (cond ((or (= roll 2) (= roll 12)) 'LOSER) ((= roll 7) 'WINNER) (else (roll-until roll)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define TREE1 ' (dog (bird (aardvark () ()) (cat () ())) (possum (frog () ()) (wolf () ())))) (define (empty-tree? tree) (null? tree)) (define (root tree) (if (empty-tree? tree) 'ERROR (car tree))) (define (left-subtree tree) (if (empty-tree? tree) 'ERROR (cadr tree))) (define (right-subtree tree) (if (empty-tree? tree) 'ERROR (caddr tree))) (define (bst-contains? bstree sym) (cond ((empty-tree? bstree) #f) ((= (root bstree) sym) #t) ((> (root bstree) sym) (bst-contains? (left-subtree bstree) sym)) (else (bst-contains? (right-subtree bstree) sym)))) (define (pre-order tree) (if (empty-tree? tree) '() (append (list (car tree)) (pre-order (cadr tree)) (pre-order (caddr tree))))) (define (in-order tree) (if (empty-tree? tree) '() (append (in-order (cadr tree)) (list (car tree)) (in-order (caddr tree))))) (define (post-order tree) (if (empty-tree? tree) '() (append (post-order (cadr tree)) (post-order (caddr tree)) (list (car tree))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (account balance) (define (withdraw amount) (if (>= balance amount) (begin (set! balance (- balance amount)) balance) "Insufficient funds")) (define (deposit amount) (begin (set! balance (+ balance amount)) balance)) (define (menu message arg) (cond ((equal? message 'deposit) (deposit arg)) ((equal? message 'withdraw) (withdraw arg)) ((else "Unknown operation")))) menu)