123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102 |
- ;;;
- ;;; Property Lists implemented for Scheme
- ;;;
- ;;; Copyright 2016,2017 Jason K. MacDuffie
- ;;; License: GPLv3+
- ;;;
- ;; Example: '(pine cons numbers (1 2 3) color "blue")
- (define (search-property-list equivalence)
- (lambda (key plist)
- (cond
- ((null? plist) #f)
- ((equivalence key (car plist))
- plist)
- ((null? (cdr plist))
- #f)
- (else
- ((search-property-list equivalence) key (cddr plist))))))
- (define propq (search-property-list eq?))
- (define propv (search-property-list eqv?))
- (define property (search-property-list equal?))
- (define (option key props default)
- (let ((result (propq key props)))
- (if result (cadr result) default)))
- (define (plist-ref l prop)
- (define x (property prop l))
- (if x
- (cadr x)
- (error "plist-ref" "Property not found" l prop)))
- (define (plist-get l prop default)
- ;; This is useful for getting keyword arguments
- (define x (property prop l))
- (if x (cadr x) default))
- (define (plist-set-recurse l prop val)
- (if (null? l)
- (error "plist-set-recurse" "Property not found" l prop)
- (if (eq? (car l) prop)
- (cons prop (cons val (cddr l)))
- (cons (car l)
- (cons (cadr l)
- (plist-set-recurse (cddr l) prop val))))))
- (define (plist-set l prop val)
- ;; This procedure can add values if they do not exist
- (if (property prop l)
- (plist-set-recurse l prop val)
- (cons prop (cons val l))))
- (define (plist-set! l prop val)
- ;; This procedure will raise an error if prop does not exist
- (define x (property prop l))
- (if x
- (set-car! (cdr x) val)
- (error "plist-set!" "Property not found" l prop)))
- (define (plist-delete-recurse l prop)
- (if (null? l)
- (error "plist-delete-recurse" "Property not found" l prop)
- (if (eq? (car l) prop)
- (cddr l)
- (cons (car l)
- (cons (cadr l)
- (plist-delete-recurse (cddr l) prop))))))
- (define (plist-delete l prop)
- (if (property prop l)
- (plist-delete-recurse l prop)
- (error "plist-delete" "Property not found" l prop)))
- (define (plist-properties l)
- (if (null? l)
- '()
- (cons (car l) (plist-properties (cddr l)))))
- (define (plist-send l message . values)
- ;; This procedure exists for the possibility of object-like
- ;; use of plists
- (apply (plist-ref l message) l values))
- ;; It may be convenient to convert to and from alist
- (define (plist->alist l)
- (if (null? l)
- l
- (cons (cons (car l)
- (cadr l))
- (plist->alist (cddr l)))))
- (define (alist->plist l)
- (if (null? l)
- l
- (cons (caar l)
- (cons (cdar l)
- (alist->plist (cdr l))))))
|