http://t3x.org/s9fes/get-prop.scm.html

get-prop, etc

Location: lib, 47 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; Placed in the Public Domain
;
; (get-prop plist symbol)               ==>  object
; (put-prop plist symbol object)        ==>  plist
; (rem-prop plist symbol)               ==>  plist
; (put-prop! <variable> symbol object)  ==>  plist
; (rem-prop! <variable> symbol)         ==>  plist
;
; A property list (plist) is a list of the form
;
;       (symbol1 object1 symbol2 object2 ...)
;
; GET-PROP returns the object (property) following the given
; SYMBOL or #F if SYMBOL does not exist in an odd position
; in the PLIST.
; PUT-PROP returns a new plist in which the given OBJECT is
; the property associated with SYMBOL. When SYMBOL is already
; in the PLIST, the existing association will be removed.
; REM-PROP returns a new plist with the given SYMBOL and the
; associated property removed.
;
; PUT-PROP! adds a new property to the plist bound to the
; given <variable>. The variable will be bound to the new
; list. REM-PROP! removes a property from a plist that is
; bound to the <variable>.
;
; Example:   (get-prop '() 'foo)        ==>  #f
;            (put-prop '() 'foo 42)     ==>  (foo 42)
;            (get-prop '(foo 42) 'foo)  ==>  42
;            (rem-prop '(foo 42) 'foo)  ==>  ()

(define (get-prop a x)
  (cond ((null? a)
          #f)
        ((and (eq? x (car a))
              (pair? (cdr a)))
          (cadr a))
        ((pair? (cdr a))
          (get-prop (cddr a) x))
        (else
          #f)))

(define (put-prop a k v)
  (let loop ((in  a)
             (out '()))
    (cond ((null? in)
            (cons k (cons v a)))
          ((and (eq? k (car in))
                (pair? (cdr in)))
            (append (reverse! (cons v (cons k out)))
                    (cddr in)))
          ((pair? (cdr in))
            (loop (cddr in)
                  (cons (cadr in)
                        (cons (car in) out))))
          (else
            (cons k (cons v a))))))

(define (rem-prop a x)
  (let loop ((in  a)
             (out '()))
    (cond ((null? in)
            (reverse! out))
          ((and (eq? x (car in))
                (pair? (cdr in)))
            (append (reverse! out) (cddr in)))
          ((pair? (cdr in))
            (loop (cddr in)
                  (cons (cadr in)
                        (cons (car in) out))))
          (else
            a))))

(define-syntax (put-prop! n k v)
  `(set! ,n (put-prop ,n ,k ,v)))

(define-syntax (rem-prop! n k)
  `(set! ,n (rem-prop ,n ,k)))

contact  |  privacy