eharetea

A record system using get and put within scheme.

A record system using get and put within scheme.

Date Created:Sunday October 05th, 2008 01:41 AM
Date Modified:Sunday October 05th, 2008 02:04 AM

(define (attach-tag type-tag contents)
   (cons type-tag contents)
)

(define (type-tag datum)
   (if (pair? datum)
       (car datum)
       (error "Bad datum -- TYPE-TAG" datum)
   )
)

(define (contents datum)
   (if (pair? datum)
       (cdr datum)
       (error "Bad datum -- CONTENTS" datum)
   )
)


;; different data abstractions are allowed

(define (make-record1 id name address salary)
   (attach-tag 'make-record1 (cons id (list name address salary))))

(define (make-record2 id name address salary)
   (attach-tag 'make-record2 (cons id (cons name (cons address salary)))))


;; the get functions check the typ-tags on the data

(define (get-id record)
   ((get (type-tag record) 'get-id) (contents record)))

(define (get-name record)
   ((get (type-tag record) 'get-name) (contents record)))

(define (get-salary record)
  ((get (type-tag record) 'get-salary) (contents record)))

(define (get-address record)
  ((get (type-tag record) 'get-address) (contents record)))


;; CREATE COLUMNS ABSTRACTION
(put 'id 'get-get get-id)
(put 'name 'get-get get-name)
(put 'address 'get-get get-address)
(put 'salary 'get-get get-salary)
(define (get-column column) (get column 'get-get))

;; ADD A FEW RECORDS
(define recs
 (list 
 (make-record1 1 "Dan Lynch" "Berkeley" 1000)
 (make-record1 2 "John Doe" "Hawaii" 100)
 (make-record2 3 "Jane Smith" "Los Angeles" 200)
 (make-record2 4 "Charles Wright" "Ann Arbor" 130)
 (make-record1 5 "Walter Smith" "Berkeley" 1000)
 (make-record1 6 "Kelly Jackson" "Hawaii" 100)
 (make-record1 7 "Dan Smith" "Berkeley" 1000)
 (make-record1 8 "Peter Pauly" "Hawaii" 100)
 (make-record1 9 "Mike Snow" "Berkeley" 1000)
 (make-record1 0 "Jason Berg" "Hawaii" 100)
 (make-record1 11 "David Holmes" "Berkeley" 1000)
 (make-record1 12 "Jessica Polk" "Hawaii" 100)
 (make-record1 13 "Jeramiah Page" "Berkeley" 1000)
 (make-record1 14 "Brant Hall" "Hawaii" 100)
 (make-record1 15 "Greg Hurd" "Berkeley" 1000)
 (make-record1 16 "Elliot Wilson" "Hawaii" 100)
 )
)


(define (add-record rec recs)
   (cons rec recs)
)


;; ADD RECORD FUNCTIONS

(put 'make-record1 'get-id (lambda (record) (car record)))
(put 'make-record2 'get-id (lambda (record) (car record)))
(put 'make-record1 'get-name (lambda (record) (cadr record)))
(put 'make-record2 'get-name (lambda (record) (cadr record)))
(put 'make-record1 'get-address (lambda (record) (caddr record)))
(put 'make-record2 'get-address (lambda (record) (caddr record)))
(put 'make-record1 'get-salary (lambda (record) (cadddr record)))
(put 'make-record2 'get-salary (lambda (record) (cdddr record)))

; instance is the item you are looking for in the column
                        
(define (search col val recs action)
 (let ((lst ((if (eq? action map) map filter) (lambda (x) (equal? val ((get-column col) x))) recs)))
      (cond ((null? lst) '())
            (else 
              (cond ((eq? action filter) (map display (list " ---- Number of matches: " (length lst) " ---- ")) (print lst))
                    (else lst)
              )
            )
      )
 )                          
)

;; SEARCH THE TABLE FOR A GIVEN COLUMN AND MAKE A LIST BASED ON A PREDICATE
(define (search-pred col pred recs action)
 (let ((lst ((if (eq? action map) map filter) (lambda (x) (pred ((get-column col) x))) recs)))
      (cond ((null? lst) '())   
            (else lst)
      )
 )                          
)

(define (find-employee-by-salary fn amount recs)
   (search-pred 'salary (lambda (x) (fn amount x)) recs filter)
)

(define (find-by column fn val recs)
   (search-pred column (lambda (x) (fn val x)) recs filter)
)

(define (group-by column recs)
   (if (null? recs) '()
       (cons ((get column 'get-get) (car recs)) (group-by column (cdr recs)))))

(define (print-lst lst)
   (cond ((null? lst) '()) (else (print (car lst)) (print-lst (cdr lst)))))

;; DISPLAY ALL NAMES OF INDIVIDUALS THAT LIVE IN BERKELEY
(define (live-in-berk? recs) 
   (print-lst (group-by 'name (find-by 'address equal? "berkeley" recs))))

;; LISTS NAMES OF PEOPLE WHO MAKE MORE THAN A GIVEN AMOUNT
(define (make-more-than? amount)
   (print-lst (group-by 'name (find-by 'salary > amount recs))))

;; GIVES THE SUM OF ALL EMPLOYEES THAT LIVE IN A PARTICULAR PLACE
(define (sum-of-all-employees-salary-that-live-in? place)
   (accumulate + 0 (group-by 'salary (find-by 'address equal? place recs))))

Records by Dan Lynch
is licensed under a Creative Commons Attribution-Noncommercial-Share Alike 3.0 United States License
Based on a work at www.3daet.com
Permissions beyond the scope of this license may be available at http://www.3daet.com