blob: 5f9c17f40191b52b06144648c0348040356cf9a2 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
;;; Database.scm: This file contains the code we show in the database
;;; chapter of _Simply_Scheme_. You should add your new work to this file.
;;; The database ADT: a filename, list of fields and list of records
(define (make-db filename fields records)
(vector filename fields records))
(define (db-filename db)
(vector-ref db 0))
(define (db-set-filename! db filename)
(vector-set! db 0 filename))
(define (db-fields db)
(vector-ref db 1))
(define (db-set-fields! db fields)
(vector-set! db 1 fields))
(define (db-records db)
(vector-ref db 2))
(define (db-set-records! db records)
(vector-set! db 2 records))
;;; Stuff about the current state
(define current-state (vector #f))
(define (no-db?)
(not (vector-ref current-state 0)))
(define (current-db)
(if (no-db?)
(error "No current database!")
(vector-ref current-state 0)))
(define (set-current-db! db)
(vector-set! current-state 0 db))
(define (current-fields)
(db-fields (current-db)))
;; User commands
(define (new-db filename fields)
(set-current-db! (make-db filename fields '()))
'created)
(define (insert)
(let ((new-record (get-record)))
(db-insert new-record (current-db)))
(if (ask "Insert another? ")
(insert)
'inserted))
(define (db-insert record db)
(db-set-records! db (cons record (db-records db))))
(define (get-record)
(get-record-loop 0
(make-vector (length (current-fields)))
(current-fields)))
(define (get-record-loop which-field record fields)
(if (null? fields)
record
(begin (display "Value for ")
(display (car fields))
(display "--> ")
(vector-set! record which-field (read))
(get-record-loop (+ which-field 1) record (cdr fields)))))
;;; Utilities
(define (ask question)
(display question)
(let ((answer (read)))
(cond ((equal? (first answer) 'y) #t)
((equal? (first answer) 'n) #f)
(else (show "Please type Y or N.")
(ask question)))))
|