diff options
Diffstat (limited to 'alistab.scm')
| -rw-r--r-- | alistab.scm | 317 |
1 files changed, 220 insertions, 97 deletions
diff --git a/alistab.scm b/alistab.scm index c8149bf..f0e8d59 100644 --- a/alistab.scm +++ b/alistab.scm @@ -1,5 +1,5 @@ ;;; "alistab.scm" database tables using association lists (assoc) -; Copyright 1994 Aubrey Jaffer +; Copyright 1994, 1997 Aubrey Jaffer ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and @@ -18,13 +18,23 @@ ;each case. ;;; LLDB is (filename . alist-table) -;;; HANDLE is (table-name . 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) + (define alist-table -(let ((catalog-id 0) - (resources '*base-resources*)) + (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 @@ -85,84 +95,155 @@ (define (make-table lldb dim types) (let ((free-hand (open-table lldb resources 1 '(atom integer)))) (and free-hand - (let* ((row (remover free-hand 'free-id)) - (id #f)) + (let* ((row (assoc* (keyify-1 'free-id) (handle->alist free-hand))) + (table-id #f)) (cond (row - (set! id (car row)) - ((make-putter 1 '(atom integer)) free-hand 'free-id - (list (+ 1 id))) - (set-cdr! lldb (cons (list id) (cdr lldb))) - id) + (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 (remover nalist key) - (let ((alist (cdr nalist))) - (cond ((null? alist) #f) - ((equal? key (caar alist)) - (set-cdr! nalist (cdr alist)) - (cdar alist)) - ((null? (cdr alist)) #f) - ((equal? key (caadr alist)) - (set! nalist (cdadr alist)) - (set-cdr! alist (cddr alist)) - nalist) - (else - (let l ((al (cdr alist))) - (cond ((null? (cdr al)) #f) - ((equal? key (caadr al)) - (set! nalist (caadr al)) - (set-cdr! al (cddr al)) - nalist) - (else (l (cdr al))))))))) - (define (kill-table lldb base-id dim types) - (and (remover lldb base-id) #t)) + (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->base-id car) (define handle->alist cdr) (define set-handle-alist! set-cdr!) -(define (present? handle key) - (assoc key (handle->alist handle))) - -(define (make-putter prinum types) - (lambda (handle ckey restcols) - (let ((row (assoc ckey (handle->alist handle)))) - (cond (row (set-cdr! row restcols)) - (else (set-handle-alist! - handle (cons (cons ckey restcols) - (handle->alist handle)))))))) - -(define (make-getter prinum types) - (lambda (handle ckey) - (let ((row (assoc ckey (handle->alist handle)))) - (and row (cdr row))))) +(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-list-keyifier prinum types) - (if (= 1 prinum) car list->vector)) +(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 (make-keyifier-1 type) - identity) +(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 (make-key->list prinum types) - (cond ((= 1 prinum) list) - (else vector->list))) +(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 (make-key-extractor primary-limit column-type-list index) - (if (= 1 primary-limit) identity - (let ((i (+ -1 index))) - (lambda (v) (vector-ref v i))))) +(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 (for-each-key handle operation) - (for-each (lambda (x) (operation (car x))) (handle->alist handle))) +(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 (map-key handle operation) - (map (lambda (x) (operation (car x))) (handle->alist handle))) +(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 (ordered-for-each-key handle operation) +(define (alist-sort! alist) (define (key->sortable k) (cond ((number? k) k) ((string? k) k) @@ -182,15 +263,45 @@ ((key-< (car y) (car x)) #f) (else (key-< (cdr x) (cdr y))))) (require 'sort) - (for-each operation - (map cdr (sort! (map (lambda (p) (cons (key->sortable (car p)) - (car p))) - (handle->alist handle)) - car-key-<)))) + (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 match-key) + (assoc*-for-each operation + '() + match-key + (handle->alist handle))) + +(define (map-key handle operation match-key) + (assoc*-map operation + '() + match-key + (handle->alist handle))) + +(define (ordered-for-each-key handle operation match-key) + (sorted-assoc*-for-each operation + '() + match-key + (handle->alist handle))) (define (supported-type? type) (case type - ((base-id atom integer boolean string symbol expression) #t) + ((base-id atom integer boolean string symbol expression number) #t) (else #f))) (define (supported-key-type? type) @@ -198,30 +309,42 @@ ((atom integer symbol string) #t) (else #f))) - (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) - ((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) remover) - ((for-each-key) for-each-key) - ((map-key) map-key) - ((ordered-for-each-key) ordered-for-each-key) - ((catalog-id) catalog-id) - (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 match-key) + (set-handle-alist! handle + (delete-assoc* match-key + (handle->alist handle))))) + ((for-each-key) for-each-key) + ((map-key) map-key) + ((ordered-for-each-key) ordered-for-each-key) + (else #f))) + )) + +;; #f (trace-all "/home/jaffer/slib/alistab.scm") (untrace alist-table) (set! *qp-width* 333) |