Permalink
Browse files

more example scheme code

  • Loading branch information...
1 parent ad316bb commit c0b4bb49ef500a19bd75364f499c6f6ea7a33f50 Ezra Zygmuntowicz committed Nov 24, 2010
Showing with 164 additions and 0 deletions.
  1. +44 −0 examples/bintree.scm
  2. +13 −0 examples/closure.scm
  3. +13 −0 examples/equality.scm
  4. +13 −0 examples/func.scm
  5. +5 −0 examples/let.scm
  6. +29 −0 examples/list.scm
  7. +47 −0 examples/queue.scm
View
@@ -0,0 +1,44 @@
+; Abstraction of a binary tree. Each tree is recursively defined as a list
+; with the entry (data), left subtree and right subtree. Left and right can
+; be null.
+;
+(define (entry tree) (car tree))
+(define (left-branch tree) (cadr tree))
+(define (right-branch tree) (caddr tree))
+(define (make-tree entry left right)
+ (list entry left right))
+
+(define (make-new-set)
+ '())
+
+(define (element-of-set? x set)
+ (cond
+ ((null? set) #f)
+ ((= x (entry set)) #t)
+ ((< x (entry set)) (element-of-set? x (left-branch set)))
+ ((> x (entry set)) (element-of-set? x (right-branch set)))))
+
+(define (adjoin-set x set)
+ (cond
+ ((null? set) (make-tree x '() '()))
+ ((= x (entry set)) set)
+ ((< x (entry set))
+ (make-tree (entry set)
+ (adjoin-set x (left-branch set))
+ (right-branch set)))
+ ((> x (entry set))
+ (make-tree (entry set)
+ (left-branch set)
+ (adjoin-set x (right-branch set))))))
+
+
+(define myset
+ (adjoin-set 25
+ (adjoin-set 13
+ (adjoin-set 72
+ (adjoin-set 4 (make-new-set))))))
+
+(write (element-of-set? 4 myset))
+(write (element-of-set? 5 myset))
+(write (element-of-set? 26 myset))
+(write (element-of-set? 25 myset))
View
@@ -0,0 +1,13 @@
+(define (make-withdraw balance)
+ (lambda (amount)
+ (if (>= balance amount)
+ (begin (set! balance (- balance amount))
+ balance)
+ 'no-funds)))
+
+(define W1 (make-withdraw 100))
+(define W2 (make-withdraw 500))
+(write (W1 20))
+(write (W2 30))
+(write (W1 80))
+(write (W2 100))
View
@@ -0,0 +1,13 @@
+(write (eqv? #f #t))
+(write (eqv? #f #f))
+(write (eqv? '() '()))
+(write (eqv? 5 (+ 1 4)))
+(write (eqv? 6 #f))
+
+(define zara 'zara)
+(write (eqv? zara 'zara))
+(write (eqv? 'zara 'zara))
+
+(define joe '(1 2 3))
+(write (eqv? joe '(1 2 3)))
+(write (eqv? joe joe))
View
@@ -0,0 +1,13 @@
+(define (map proc lst)
+ (if (null? lst)
+ '()
+ (cons (proc (car lst)) (map proc (cdr lst)))))
+
+(define (filter proc lst)
+ (cond
+ ((null? lst) '())
+ ((proc (car lst)) (cons (car lst) (filter proc (cdr lst))))
+ (else (filter proc (cdr lst)))))
+
+(write (map (lambda (x) (* x x)) '(1 2 3 4)))
+(write (filter (lambda (x) (> x 2)) '(1 2 3 4)))
View
@@ -0,0 +1,5 @@
+(let ((x 2) (y 3))
+ (let ((x 7) (z 8))
+ (write (+ x z))
+ (write (+ x y)))
+ (write (+ x y)))
View
@@ -0,0 +1,29 @@
+(define (list-length lst)
+ (if (null? lst)
+ 0
+ (+ 1 (list-length (cdr lst)))))
+
+(define (append lst1 lst2)
+ (if (null? lst1)
+ lst2
+ (cons (car lst1) (append (cdr lst1) lst2))))
+
+(define (list-reverse lst)
+ (if (null? lst)
+ '()
+ (append (list-reverse (cdr lst)) (list (car lst)) )))
+
+; Takes a list and returns a list of (cons elem elem) for each elem in the
+; given list.
+;
+(define (pairify lst)
+ (if (null? lst)
+ '()
+ (cons
+ (cons (car lst) (car lst))
+ (pairify (cdr lst)))))
+
+(write (list-length (list 1 2 3 4 5)))
+(write (append '(1 2 3 4) (list 9)))
+(write (list-reverse (list 1 2 3 4 5)))
+(write (pairify (list 1 2 3 4)))
View
@@ -0,0 +1,47 @@
+; queue data structure example from SICP 3.3.2
+;
+(define (front-ptr queue) (car queue))
+(define (rear-ptr queue) (cdr queue))
+(define (set-front-ptr! queue item) (set-car! queue item))
+(define (set-rear-ptr! queue item) (set-cdr! queue item))
+
+(define (empty-queue? queue) (null? (front-ptr queue)))
+
+
+(define (make-queue) (cons '() '()))
+
+(define (front-queue queue)
+ (if (empty-queue? queue)
+ (write 'ERROR)
+ (car (front-ptr queue))))
+
+(define (insert-queue! queue item)
+ (let ((new-pair (cons item '())))
+ (cond ((empty-queue? queue)
+ (set-front-ptr! queue new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue)
+ (else
+ (set-cdr! (rear-ptr queue) new-pair)
+ (set-rear-ptr! queue new-pair)
+ queue))))
+
+(define (delete-queue! queue)
+ (cond ((empty-queue? queue)
+ (write 'ERROR))
+ (else
+ (set-front-ptr! queue (cdr (front-ptr queue)))
+ queue)))
+
+; Note: the output here will expose the internal representation of the queue
+; as a cons of the front pointer and rear pointer. The contents of the queue
+; are visible in the front pointer.
+;
+(define q (make-queue))
+(write (insert-queue! q 'a))
+(write (insert-queue! q 'b))
+(write (delete-queue! q))
+(write (insert-queue! q 'c))
+(write (insert-queue! q 'd))
+(write (delete-queue! q))
+

0 comments on commit c0b4bb4

Please sign in to comment.