;Phillip Bryce Varney W00835612 ;CS 211 Scheme assignment 4 (define debugdb '(Rooms(Place Seats Boardtype Computer) ((CH171 80 Chalk No) (HH101 250 no yes)(SC211 35 white yes) (CH301 90 Chalk Yes) (CF105 65 White Yes)))) ;Get_cell returns a single cell from the db (define get_cell (lambda (DBname Row Col) (cond ((zero? row) ;Are we looking for an attribute name? (let attrib_loop ((attribs (cadr dbname)) (col_count 1)) (cond ((eq? col_count col) (car attribs)) (else (attrib_loop (cdr attribs) (+ col_count 1)))))) ;Find the row first (else (let find_col ((col_current 1) (row_out ;This named let returns the row that we're looking for (let find_row ((row_current 1) (DB (caddr DBname))) (cond ((eq? row_current row) (car db)) (else (find_row (+ row_current 1) (cdr db))))))) ;This named let finds the correct column to print (cond ((eq? col_current col) (car row_out)) (else (find_col (+ col_current 1) (cdr row_out))))))))) (define db_stat (lambda (dbname cmd . args) (case cmd ;This returns the number or rows in the db (not including the attribute name row) ((rows) (let count_rows ((count 0) (db (caddr DBname))) (cond ((null? db) count) (else (count_rows (+ count 1) (cdr db)))))) ;This returns the number of columns in the db ((columns) (let count_cols ((count 0) (db (cadr DBname))) ;We count the attribute row (cond ((null? db) count) (else (count_cols (+ count 1) (cdr db)))))) ;This returns the column number that refers to the attribute, IE Seats = 2 Boardtype = 3... ((attrib_col) (let find_attrib ((count 1) (db (cadr DBname))) (cond ((> count (db_stat dbname 'columns)) #f) ((eq? (car db) (car args)) count) (else (find_attrib (+ count 1) (cdr db)))))) ;The returns the row that refers to the name given. This assumes the name is the first object in the row. ((name_row) (let find_name ((count 1) (db (caddr dbname))) (cond ((eq? (car args) (caar db)) count) (else (find_name (+ count 1) (cdr db))))))))) ;db_namer takes a db and binds the table name to the table in scheme. (define db_namer (lambda (db) (eval (list 'define (car db) `(quote,db))))) ;This took much, /much/ longer than it should have. It's a basiclly a hack to dynamiclly name varibles, which I'm sure is ;a native function, but I can't find it. (list 'define (car db) `(quote,db)) returns (define dbname '(dbcontents)), then ;that's evaluated. ;Display_DB prints out the database in a readable format (define display_db (lambda (db) ; Print the relation title row (let print_relation ((row (cadr db))) (cond ((null? row) (newline)) ;Are we done with the title row (else (display (car row)) (display (make-string ;Print spaces to make everything orderly (- 25 (cond ;There isn't a generic length function, so find the type and convert. ((symbol? (car row)) (string-length (symbol->string (car row)))) ((number? (car row)) (string-length (number->string (car row)))) (else (string-length (car row))))) #\space)) (print_relation (cdr row))))) ; Start printing cells (let print_loop ((rowcount 1) (colcount 1)) (cond ;If we've run out of rows to display, stop. ((> rowcount (db_stat db 'rows)) (newline) (display "End of output...")) ;If we've run out of cells in this row to display (no more columns), loop with the next row and a new line. ((> colcount (db_stat db 'columns)) (newline) (print_loop (+ rowcount 1) 1)) ;We have something to display. (else (display (get_cell db rowcount colcount)) ;Compute the size of the thing we just put out, and fill in spaces until we hit 25, so it looks even. (display (make-string (- 25 (cond ;There isn't a generic length function, so find the type and convert. ((symbol? (get_cell db rowcount colcount)) (string-length (symbol->string (get_cell db rowcount colcount)))) ((number? (get_cell db rowcount colcount)) (string-length (number->string (get_cell db rowcount colcount)))) (else (string-length (get_cell db rowcount colcount))))) ;This whole ugly block returns 25 minus the length of our cell output. #\space)) (print_loop rowcount (+ colcount 1))))))) (define inject_cell (lambda (dbname row value) (cond ((zero? row) ;if row is 0 we're adding a attrib to the title row (append (append (list (car dbname)) (list (append (cadr dbname) (list value)))) (list (caddr dbname)))) (else (append (append (list (car dbname)) (list (cadr dbname))) (list (let build_rows ((newrows '()) (dbrows (caddr dbname)) (rowcount 1)) (cond ((> rowcount (db_stat dbname 'rows)) newrows) ;Are we finished? ((eq? row rowcount) ;Is this the row we need to add a value to? If so add the modded row (build_rows (append newrows (list (append (car dbrows) (list value)))) (cdr dbrows) (+ rowcount 1))) (else ;Not the row we need to change, just move on. (build_rows (append newrows (list(car dbrows))) (cdr dbrows) (+ rowcount 1))))))))))) (define prompt_loop (lambda () (newline) (display "Database Query $ ") ;The prompt (let ((cmd (read))) (cond ((not(list? cmd)) ;Make sure the input is in list form, or (car cmd) throws an error. (display "Command was not a list") (prompt_loop)) (else (case (car cmd) ;Find what command it was and run it. ;Each of the following pipes the output of the command into display_db as a complete database to be displayed. ((select) (display_db (select (eval (caadr cmd)) (cadadr cmd) (car (cddadr cmd)))) (prompt_loop)) ((join) (display_db (join (eval(cadr cmd))(eval(caddr cmd)))) (prompt_loop)) ((project) (display_db (cond ((list? (cadr cmd)) (project (eval (caadr cmd)) (cadadr cmd ))) (else (project (eval (cadr cmd)) (caddr cmd))))) (prompt_loop)) ((exit) (newline) (display "Database shutting down.") (newline) (display "Please report bugs to /dev/null")) (else (Display "Unknown command") (prompt_loop)))))))) (define database-start (lambda (file) (cond ((not(symbol? file)) (Display "Input was not a symbol")) ;Making sure the input is correct (else (let ((port (open-input-file (symbol->string file)))) (let read_loop ((db (read port))) ;Open and read the port (cond ((eof-object? db) ;Are we are the end of the file? If so exit and move to prompt (newline) (Display "End of file found, database startup complete.") (prompt_loop)) (else (Display "Database Found: ") (Display (car db)) (newline) (Display "Importing database...") (newline) (db_namer db) (cond ((not(null? (eval (car db)))) ;Check if there is now a variable of the db name (Display (car db)) (Display " was imported succesfully!")) (else (Display "Error importing database."))) (newline) (read_loop (read port)))))))))) ;Grab the next list and loop (define select (lambda (dbname attrib value) (append (append (list (car dbname)) (list (cadr dbname))) (list ;This appends the db name and attrib titles to the new rows (let select_loop ((newdb '()) (db (caddr dbname)) (rowcount 1) (attribcol (db_stat dbname 'attrib_col attrib))) (cond ((null? db) newdb);Are we out of rows to check? ((eq? (get_cell dbname rowcount attribcol) value) ;Does this row have the right value for attrib? If so keep it. (select_loop (append newdb (list (car db))) (cdr db) (+ rowcount 1) attribcol)) (else ;Attrib had the wrong value, ignore the row and move on. (select_loop newdb (cdr db) (+ rowcount 1) attribcol)))))))) (define join (lambda (dbone dbtwo) ;See what columns we need to add (let join_loop ((newdb dbone) (rowcount 0) (newcols (let cols_loop ((newcols '()) (attribone (cdadr dbone)) (attribtwo (cdadr dbtwo))) (cond ((null? attribtwo) newcols) ((member (car attribtwo) attribone) ;If this column is in db one, ignore (cols_loop newcols attribone (cdr attribtwo))) (else ;Add that attribute to the list, and loop. (cols_loop (append newcols (list(car attribtwo))) attribone (cdr attribtwo))))))) (cond ((> rowcount (db_stat dbone 'rows)) (join_loop newdb 0 (cdr newcols)) ) ((null? newcols) newdb) (else (cond ((zero? rowcount) (join_loop (inject_cell newdb 0 (car newcols)) (+ rowcount 1) newcols)) (else (join_loop (inject_cell newdb rowcount (get_cell dbtwo rowcount (db_stat dbtwo 'attrib_col (car newcols)))) (+ rowcount 1) newcols)))))))) (define project (lambda (dbname . args) (let ((cols (let col_loop ( (newlist '()) (attrib_list (cond ((list? (car args)) (car args)) (else args)))) (cond ((null? attrib_list) newlist) (else (col_loop (append newlist (list (db_stat dbname 'attrib_col (car attrib_list)))) (cdr attrib_list))))))) (append '(fooname) (append (list ;New attrib title bar ;Just put in a space so it doesn't actually display anything, but fullfils display_db's format (let title_loop ((row '())(count 1)) (cond ((> count (length cols)) row) (else (title_loop (append row (list " ")) (+ count 1)))))) ;New rows (list (let build_list ((rowlist '()) (row_count 1)) (cond ((> row_count (db_stat dbname 'rows)) rowlist) (else (build_list (append rowlist (list (let build_row ((row '()) (attrib_list cols)) (cond ((null? attrib_list) row) (else (build_row (append row (list (get_cell dbname row_count (car attrib_list)))) (cdr attrib_list))))))) (+ row_count 1)) )))))))))