*

1 files changed, 84 insertions, 0 deletions

diff --git a/js/games/nluqo.github.io/~bh/downloads/simply/database.scm b/js/games/nluqo.github.io/~bh/downloads/simply/database.scm
new file mode 100644
index 0000000..5f9c17f
--- /dev/null
+++ b/js/games/nluqo.github.io/~bh/downloads/simply/database.scm
@@ -0,0 +1,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)))))