plist.body.scm 2.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102
  1. ;;;
  2. ;;; Property Lists implemented for Scheme
  3. ;;;
  4. ;;; Copyright 2016,2017 Jason K. MacDuffie
  5. ;;; License: GPLv3+
  6. ;;;
  7. ;; Example: '(pine cons numbers (1 2 3) color "blue")
  8. (define (search-property-list equivalence)
  9. (lambda (key plist)
  10. (cond
  11. ((null? plist) #f)
  12. ((equivalence key (car plist))
  13. plist)
  14. ((null? (cdr plist))
  15. #f)
  16. (else
  17. ((search-property-list equivalence) key (cddr plist))))))
  18. (define propq (search-property-list eq?))
  19. (define propv (search-property-list eqv?))
  20. (define property (search-property-list equal?))
  21. (define (option key props default)
  22. (let ((result (propq key props)))
  23. (if result (cadr result) default)))
  24. (define (plist-ref l prop)
  25. (define x (property prop l))
  26. (if x
  27. (cadr x)
  28. (error "plist-ref" "Property not found" l prop)))
  29. (define (plist-get l prop default)
  30. ;; This is useful for getting keyword arguments
  31. (define x (property prop l))
  32. (if x (cadr x) default))
  33. (define (plist-set-recurse l prop val)
  34. (if (null? l)
  35. (error "plist-set-recurse" "Property not found" l prop)
  36. (if (eq? (car l) prop)
  37. (cons prop (cons val (cddr l)))
  38. (cons (car l)
  39. (cons (cadr l)
  40. (plist-set-recurse (cddr l) prop val))))))
  41. (define (plist-set l prop val)
  42. ;; This procedure can add values if they do not exist
  43. (if (property prop l)
  44. (plist-set-recurse l prop val)
  45. (cons prop (cons val l))))
  46. (define (plist-set! l prop val)
  47. ;; This procedure will raise an error if prop does not exist
  48. (define x (property prop l))
  49. (if x
  50. (set-car! (cdr x) val)
  51. (error "plist-set!" "Property not found" l prop)))
  52. (define (plist-delete-recurse l prop)
  53. (if (null? l)
  54. (error "plist-delete-recurse" "Property not found" l prop)
  55. (if (eq? (car l) prop)
  56. (cddr l)
  57. (cons (car l)
  58. (cons (cadr l)
  59. (plist-delete-recurse (cddr l) prop))))))
  60. (define (plist-delete l prop)
  61. (if (property prop l)
  62. (plist-delete-recurse l prop)
  63. (error "plist-delete" "Property not found" l prop)))
  64. (define (plist-properties l)
  65. (if (null? l)
  66. '()
  67. (cons (car l) (plist-properties (cddr l)))))
  68. (define (plist-send l message . values)
  69. ;; This procedure exists for the possibility of object-like
  70. ;; use of plists
  71. (apply (plist-ref l message) l values))
  72. ;; It may be convenient to convert to and from alist
  73. (define (plist->alist l)
  74. (if (null? l)
  75. l
  76. (cons (cons (car l)
  77. (cadr l))
  78. (plist->alist (cddr l)))))
  79. (define (alist->plist l)
  80. (if (null? l)
  81. l
  82. (cons (caar l)
  83. (cons (cdar l)
  84. (alist->plist (cdr l))))))