;;;; -*- mode: scheme -*- ;;;;

; This is a relational data base "stub"
; That is, the functions provide some of the functionality of a real
; relational database

; The data is not stored out on a disk, however.  Instead, the data
; is captured in a list of lists assigned to a symbol, such as BLOCKS.  
; Thus BLOCKS is the name of a relation.  The first list in the list of 
; lists is a list of field names; the remaining lists are records.  The
; following is an example:
;
; (define blocks <-- relation name
;  '((class 	color	size	weight) <-- field names
;    (box	black	medium	heavy)  <-- first record
;    (ball	blue	large	heavy)  <-- second record
;    .
;    .
;    .

;;;; COMMONLISP IMITATORS

(define (remove-duplicates l)
  "
  Purpose:	Remove duplicate elements from a list
  "
  (cond ((null? l) '())
	((member (first l) (cdr l)) (remove-duplicates (cdr l)))
	(else (cons (first l) (remove-duplicates (cdr l))))))

(define (position x l)
  "
  Purpose:	Identify place of an element X in list L
  Remark:	First position is position 0
  "
  (define (position-aux x l count)
    (cond ((null? l) #f)
	  ((eq? x (first l)) count)
	  (else (position-aux x (cdr l) (+ 1 count)))))
  (position-aux x l 0))

(define (remove target elements)
  "
  Purpose:	Remove all list elements that are eq? to target
  "
  (cond ((null? elements) '())
	((eq? target (first elements))
	 (remove target (rest elements)))
	(else
	 (cons (first elements)
	       (remove target (rest elements))))))

;;;; BASIC PROCEDURES

(define (db-add record relation)
  "
  Purpose:	Add a record to a relation
  "
  (if (member record (cdr relation))
      relation
    (cons (first relation) (cons record (cdr relation)))))

(define (db-delete record relation)
  "
  Purpose:	Delete a record from a relation
  "
  (cons (first relation) (remove record (cdr relation))))

(define (db-combine . relations)
  "
  Purpose:	Combines compatible relations into one relation
  Remark: 	Relations are compatible only if their fiels are identical;
		Duplicates removed
  "
  (if (not (= 1 (length (remove-duplicates (map first relations)))))
      (error "You are trying to combine incompatible data with db-combine"))
  (cons (first (first relations))
	(remove-duplicates
	  (apply append (map cdr relations)))))

(define (db-combine-distinct . relations)
  "
  Purpose:	Combines compatible relations into one relation
  Remark: 	Relations are compatible only if their fiels are identical;
		Duplicates retained
  "
  (if
   (not (= 1 (length (remove-duplicates (map first relations)))))
   (error
    "You are trying to combine incompatible relations"))
  (cons (first (first relations))
	(apply append (map cdr relations))))

(define (db-project relation field-list)
  "
  Purpose:	Project a relation over given fields
  Remark: 	Produces new relation with only the specified fields;
		Duplicates removed
  "
  (set! relation (db-project-distinct relation field-list))
  (cons (first relation) (remove-duplicates (cdr relation))))

(define (db-project-distinct relation field-list)
  "
  Purpose:	Project a relation over given fields
  Remark: 	Produces new relation with only the specified fields;
		Duplicates retained
  "
  (set! field-list (remove 'over (remove 'and field-list)))
  (db-project-aux relation field-list))

(define (db-project-aux relation projections)
  "
  Purpose:	Does the work involved in projection
  "
  (let* ((fields (first relation))
         ;; Identify positions of named fields:
	 (positions (map (lambda (p) (position p fields)) projections)))
    (if (member #f positions)
	(error "You cannot project over a field that does not exist"))
    ;; Select items by position from records:
    (map (lambda (record)
	   (map (lambda (index) (list-ref record index))
		positions))
	 relation)))

(define (db-select relation triple-list)
  "
  Purpose:	Select records from relation according to field specifications
  Remark: 	Produces new relation with only the specified records
		Duplicates retained
  "
  (db-select-aux relation (remove 'with (remove 'and triple-list))))
  
(define (db-select-aux relation triple-list)
  "
  Purpose:	Does the work involved in selection
  "
  (let ((fields (first relation))
	(records (cdr relation)))
    (cond ((null? triple-list) relation)
          ;; If the element compared to is *, ignore constraint
	  ((eq? '* (third triple-list))
	   (db-select-aux relation (cdddr triple-list)))
	  (else
           ;; Find position of named field;
	   ;; Identify comparison function;
	   ;; Identify expression to compare field entry with:
	   (let ((index (position (first triple-list) fields))
		 (function (eval (second triple-list) (the-environment)))
		 (reference (third triple-list)))
 	     ;; Construct new relation with only surviving records
	     (cons fields
		   ;; Purge empty lists with append; squash nonempty lists:
		   (apply append 
			  (map
			   (lambda (record)
			     ;; Check field entry against given expression
			     (if (function (list-ref record index) reference)
			         ;; Keep if comparision function yields #t 
				 (list record)
				 ;; Otherwise; eliminate
				 '()))
		  	   ;; Work on all records that survive recursive call:
			   (cdr (db-select-aux relation (cdddr triple-list)))))))))))

;;;; COUNTING AND SORTING PROCEDURES

(define (db-report-count n)
  "
  Purpose:	Return string describing number
  "
  (cond ((= n 0) (format #t "~%There are none"))
	((= n 1) (format #t "~%There is 1"))
	(else (format #t "~%There are ~a" n))))

(define (db-count-items relation)
  "
  Purpose:	Identify the number of records in a relation
  Remark:	Number of records is one less than the number of elements
  "
  (- (length relation) 1))

(define (db-sort relation keys)
  "
  Purpose:	Sort the records using the keys (which are field names)
  "
  (db-sort-aux relation (remove 'by (remove 'and keys))))

(define (db-sort-aux relation keys)
  "
  Purpose:	Does the work involved in sorting
  "
  (let ((fields (first relation))
	(records (cdr relation)))
    (cond ((null? keys) relation)
	  (else
	   ;; Get the position of the first key;
           (let ((index (position (first keys) fields)))
 	     ;; Sort recursively after sorting on first key:
	     (db-sort-aux
	      ;; Reassemble the relation:
	      (cons fields
		    ;; Sort records using the first key:
		    (sort records
			  (lambda (x y)
			    (less? (list-ref x index)
				   (list-ref y index)))))
	      (cdr keys)))))))

(define (less? x y)
  "
  Purpose:	Determin if the first element is 'less than' second
  Remark:	Works on both numbers and strings
  "
  (cond ((and (number? x) (number? y)) (< x y))
	(else (string<? (format #f "~a" x) (format #f "~a" y)))))

;;;; RELATION DISPLAY

(define (db-show arg)
  "
  Purpose:	Boring code that pretty prints records
  "
  (db-show-relation arg))

(define (db-show-relation arg)
  "
  Purpose:	Supports DB-SHOW
  "
  (let ((widths (db-field-widths arg)))
    (format #t "~%")
    (db-show-record widths (first arg))
    (db-show-record
     widths
     (map (lambda (width) (make-string width #\-)) widths))
    (for-each (lambda (record) (db-show-record widths record))
	      (cdr arg))))

(define (db-show-record widths fields)
  "
  Purpose:	Supports DB-SHOW
  "
  (format #t "~%|")
      (do ((widths widths (cdr widths))
           (fields fields (cdr fields)))
	  ((null? widths))
	(format #t " ~a~a |"
		(first fields)
		(make-string
		  (- (first widths)
		     (string-length (format #f "~a" (first fields))))
		  #\space))))

(define (db-field-widths relation)
  "
  Purpose:	Supports DB-SHOW
  "
  (cond ((null? (cdr relation))
	 (map string-length
	      (map (lambda (x) (format #f "~a" x))
		   (first relation))))
	(else (map max
		   (db-field-widths (list (first relation)))
		   (db-field-widths (cdr relation))))))


;;;; INTERFACE EVALUATION PROCEDURE


(define (db-call X) 
  "
  Purpose:	Syntactic sugar for EVAL
  "
  (eval x (the-environment)))