path: root/alistab.scm

;;; "alistab.scm" database tables using association lists (assoc)
; Copyright 1994, 1997 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;; LLDB	is (filename . alist-table)
;;; HANDLE	is (#(table-name key-dim) . TABLE)
;;; TABLE	is an alist of (Primary-key . ROW)
;;; ROW		is a list of non-primary VALUEs

(require 'common-list-functions)
(require 'relational-database)		;for make-relational-system
(require-if 'compiling 'sort)
;@
(define alist-table
  (let ((catalog-id 0)
	(resources '*base-resources*)
	(make-list-keyifier (lambda (prinum types) identity))
	(make-keyifier-1 (lambda (type) list))
	(make-key->list (lambda (prinum types) identity))
	(make-key-extractor (lambda (primary-limit column-type-list index)
			      (let ((i (+ -1 index)))
				(lambda (lst) (list-ref lst i))))))

(define keyify-1 (make-keyifier-1 'atom))

(define (make-base filename dim types)
  (list filename
	(list catalog-id)
	(list resources (list 'free-id 1))))

(define (open-base infile writable)
  (define (reader port)
    (cond ((eof-object? port) #f)
	  ((not (eqv? #\; (read-char port))) #f)
	  ((not (eqv? #\; (read-char port))) #f)
	  (else (cons (and (not (input-port? infile)) infile)
		      (read port)))))
  (cond ((input-port? infile) (reader infile))
	((file-exists? infile) (call-with-input-file infile reader))
	(else #f)))

(define (write-base lldb outfile)
  ((lambda (fun)
     (cond ((output-port? outfile) (fun outfile))
	   ((string? outfile) (call-with-output-file outfile fun))
	   (else #f)))
   (lambda (port)
     (display (string-append
	       ";;; \"" outfile "\" SLIB " *SLIB-VERSION*
	       " alist-table database	 -*-scheme-*-")
	      port)
     (newline port) (newline port)
     (display "(" port) (newline port)
     (for-each
      (lambda (table)
	(display " (" port)
	(write (car table) port) (newline port)
	(for-each
	 (lambda (row)
	   (display "  " port) (write row port) (newline port))
	 (cdr table))
	(display " )" port) (newline port))
      (cdr lldb))
     (display ")" port) (newline port)
;     (require 'pretty-print)
;     (pretty-print (cdr lldb) port)
     (set-car! lldb (if (string? outfile) outfile #f))
     #t)))

(define (sync-base lldb)
  (cond ((car lldb) (write-base lldb (car lldb)) #t)
	(else
;;;	 (display "sync-base: database filename not known")
	 #f)))

(define (close-base lldb)
  (cond ((car lldb) (write-base lldb (car lldb))
		    (set-cdr! lldb #f)
		    (set-car! lldb #f) #t)
	((cdr lldb) (set-cdr! lldb #f)
		    (set-car! lldb #f) #t)
	(else
;;;	 (display "close-base: database not open")
	 #f)))

(define (make-table lldb dim types)
  (let ((free-hand (open-table lldb resources 1 '(atom integer))))
    (and free-hand
	 (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand)))
		(table-id #f))
	   (cond (row
		  (set! table-id (cadr row))
		  (set-car! (cdr row) (+ 1 table-id))
		  (set-cdr! lldb (cons (list table-id) (cdr lldb)))
		  table-id)
		 (else #f))))))

(define (open-table lldb base-id dim types)
  (assoc base-id (cdr lldb)))

(define (kill-table lldb base-id dim types)
  (define ckey (list base-id))
  (let ((pair (assoc* ckey (cdr lldb))))
    (and pair (set-cdr! lldb (delete-assoc ckey (cdr lldb))))
    (and pair (not (assoc* ckey (cdr lldb))))))

(define handle->alist cdr)
(define set-handle-alist! set-cdr!)

(define (assoc* keys alist)
  (let ((pair (assoc (car keys) alist)))
    (cond ((not pair) #f)
	  ((null? (cdr keys)) pair)
	  (else (assoc* (cdr keys) (cdr pair))))))

(define (make-assoc* keys alist vals)
  (let ((pair (assoc (car keys) alist)))
    (cond ((not pair) (cons (cons (car keys)
				  (if (null? (cdr keys))
				      vals
				      (make-assoc* (cdr keys) '() vals)))
			    alist))
	  (else (set-cdr! pair (if (null? (cdr keys))
				   vals
				   (make-assoc* (cdr keys) (cdr pair) vals)))
		alist))))

(define (delete-assoc ckey alist)
  (cond
   ((null? ckey) '())
   ((assoc (car ckey) alist)
    => (lambda (match)
	 (let ((adl (delete-assoc (cdr ckey) (cdr match))))
	   (cond ((null? adl) (delete match alist))
		 (else (set-cdr! match adl) alist)))))
   (else alist)))

(define (delete-assoc* ckey alist)
  (cond
   ((every not ckey) '())		;includes the null case.
   ((not (car ckey))
    (delete '()
	    (map (lambda (fodder)
		   (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
		     (if (null? adl) '() (cons (car fodder) adl))))
		 alist)))
   ((procedure? (car ckey))
    (delete '()
	    (map (lambda (fodder)
		   (if ((car ckey) (car fodder))
		       (let ((adl (delete-assoc* (cdr ckey) (cdr fodder))))
			 (if (null? adl) '() (cons (car fodder) adl)))
		       fodder))
		 alist)))
   ((assoc (car ckey) alist)
    => (lambda (match)
	 (let ((adl (delete-assoc* (cdr ckey) (cdr match))))
	   (cond ((null? adl) (delete match alist))
		 (else (set-cdr! match adl) alist)))))
   (else alist)))

(define (assoc*-for-each proc bkey ckey alist)
  (cond ((null? ckey) (proc (reverse bkey)))
	((not (car ckey))
	 (for-each (lambda (alist)
		     (assoc*-for-each proc
				      (cons (car alist) bkey)
				      (cdr ckey)
				      (cdr alist)))
		   alist))
	((procedure? (car ckey))
	 (for-each (lambda (alist)
		     (if ((car ckey) (car alist))
			 (assoc*-for-each proc
					  (cons (car alist) bkey)
					  (cdr ckey)
					  (cdr alist))))
		   alist))
	((assoc (car ckey) alist)
	 => (lambda (match)
	      (assoc*-for-each proc
			       (cons (car match) bkey)
			       (cdr ckey)
			       (cdr match))))))

(define (assoc*-map proc bkey ckey alist)
  (cond ((null? ckey) (list (proc (reverse bkey))))
	((not (car ckey))
	 (apply append
		(map (lambda (alist)
		       (assoc*-map proc
				   (cons (car alist) bkey)
				   (cdr ckey)
				   (cdr alist)))
		     alist)))
	((procedure? (car ckey))
	 (apply append
		(map (lambda (alist)
		       (if ((car ckey) (car alist))
			   (assoc*-map proc
				       (cons (car alist) bkey)
				       (cdr ckey)
				       (cdr alist))
			   '()))
		     alist)))
	((assoc (car ckey) alist)
	 => (lambda (match)
	      (assoc*-map proc
			  (cons (car match) bkey)
			  (cdr ckey)
			  (cdr match))))
	(else '())))

(define (sorted-assoc*-for-each proc bkey ckey alist)
  (cond ((null? ckey) (proc (reverse bkey)))
	((not (car ckey))
	 (for-each (lambda (alist)
		     (sorted-assoc*-for-each proc
					     (cons (car alist) bkey)
					     (cdr ckey)
					     (cdr alist)))
		   (alist-sort! alist)))
	((procedure? (car ckey))
	 (sorted-assoc*-for-each proc
				 bkey
				 (cons #f (cdr ckey))
				 (remove-if-not (lambda (pair)
						  ((car ckey) (car pair)))
						alist)))
	((assoc (car ckey) alist)
	 => (lambda (match)
	      (sorted-assoc*-for-each proc
				      (cons (car match) bkey)
				      (cdr ckey)
				      (cdr match))))))

(define (alist-sort! alist)
  (define (key->sortable k)
    (cond ((number? k) k)
	  ((string? k) k)
	  ((symbol? k) (symbol->string k))
	  ((vector? k) (map key->sortable (vector->list k)))
	  (else (slib:error "unsortable key" k))))
  ;; This routine assumes that the car of its operands are either
  ;; numbers or strings (or lists of those).
  (define (car-key-< x y)
    (key-< (car x) (car y)))
  (define (key-< x y)
    (cond ((and (number? x) (number? y)) (< x y))
	  ((number? x) #t)
	  ((number? y) #f)
	  ((string? x) (string<? x y))
	  ((key-< (car x) (car y)) #t)
	  ((key-< (car y) (car x)) #f)
	  (else (key-< (cdr x) (cdr y)))))
  (require 'sort)
  (map cdr (sort! (map (lambda (p)
			 (cons (key->sortable (car p)) p))
		       alist)
		  car-key-<)))

(define (present? handle ckey)
  (assoc* ckey (handle->alist handle)))

(define (make-putter prinum types)
  (lambda (handle ckey restcols)
    (set-handle-alist! handle
		       (make-assoc* ckey (handle->alist handle) restcols))))

(define (make-getter prinum types)
  (lambda (handle ckey)
    (let ((row (assoc* ckey (handle->alist handle))))
      (and row (cdr row)))))

(define (for-each-key handle operation primary-limit column-type-list match-keys)
  (assoc*-for-each operation
		   '()
		   match-keys
		   (handle->alist handle)))

(define (map-key handle operation primary-limit column-type-list match-keys)
  (assoc*-map operation
	      '()
	      match-keys
	      (handle->alist handle)))

(define (ordered-for-each-key handle operation
			      primary-limit column-type-list match-keys)
  (sorted-assoc*-for-each operation
			  '()
			  match-keys
			  (handle->alist handle)))

(define (supported-type? type)
  (case type
    ((atom ordinal integer boolean string symbol expression number) #t)
    (else #f)))

(define (supported-key-type? type)
  (case type
    ((atom ordinal integer number symbol string) #t)
    (else #f)))

;;make-table open-table remover assoc* make-assoc*
;;(trace assoc*-for-each assoc*-map sorted-assoc*-for-each)

    (lambda (operation-name)
      (case operation-name
	((make-base) make-base)
	((open-base) open-base)
	((write-base) write-base)
	((sync-base) sync-base)
	((close-base) close-base)
	((catalog-id) catalog-id)
	((make-table) make-table)
	((open-table) open-table)
	((kill-table) kill-table)
	((make-keyifier-1) make-keyifier-1)
	((make-list-keyifier) make-list-keyifier)
	((make-key->list) make-key->list)
	((make-key-extractor) make-key-extractor)
	((supported-type?) supported-type?)
	((supported-key-type?) supported-key-type?)
	((present?) present?)
	((make-putter) make-putter)
	((make-getter) make-getter)
	((delete)
	 (lambda (handle ckey)
	   (set-handle-alist! handle
			      (delete-assoc ckey (handle->alist handle)))))
	((delete*)
	 (lambda (handle primary-limit column-type-list match-keys)
	   (set-handle-alist! handle
			      (delete-assoc* match-keys
					     (handle->alist handle)))))
	((for-each-key) for-each-key)
	((map-key) map-key)
	((ordered-for-each-key) ordered-for-each-key)
	(else #f)))
    ))

(set! *base-table-implementations*
      (cons (list 'alist-table (make-relational-system alist-table))
	    *base-table-implementations*))

;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333)