From bdfaef44670031cac8674f26d7fb633512943498 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 16:50:08 +0900 Subject: [PATCH] implemented Association lists --- piclib/srfi/1.scm | 187 +++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 170 insertions(+), 17 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index addd8ac1..51430e73 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -1,5 +1,6 @@ (define-library (srfi 1) - (import (scheme base)) + (import (scheme base) + (scheme cxr)) ;; # Constructors ;; cons list @@ -8,6 +9,9 @@ (define (xcons a b) (cons b a)) + ;; means for inter-referential definition + (define append-reverse #f) + (define (cons* x . args) (let rec ((acc '()) (x x) (lst args)) (if (null? lst) @@ -56,6 +60,7 @@ ((eq? x lst) #t) (else (rec (cdr lst))))))) + ;; if list? is support circular list, (define proper-list? list?) (define (proper-list? x) (if (not (circular-list? x)) (list? x))) @@ -125,7 +130,6 @@ (begin (set-cdr! lis '()) x) (rec (cdr lis) (- n 1))))) - ;; (define (drop-right! flist i) (let ((lead (drop flist i))) (if (not-pair? lead) @@ -510,34 +514,27 @@ (values (take-while! (lambda (x) (not (pred x))) clist) (drop-while! (lambda (x) (not (pred x))) clist))) - ;; means for inter-referential definition - (define any #f) - (define (any pred clist . clists) (if (null? clists) (let rec ((clist clist)) (if (pair? clist) - (if (pred (car clist)) - #t + (or (pred (car clist)) (rec (cdr clist))))) (let rec ((clists (cons clist clists))) (if (every pair? clists) - (if (apply pred (map car clists)) - #t + (or (apply pred (map car clists)) (rec (map cdr clists))))))) (define (every pred clist . clists) (if (null? clists) (let rec ((clist clist)) - (if (pair? clist) + (or (null? clist) (if (pred (car clist)) - (rec (cdr clist))) - #t)) + (rec (cdr clist))))) (let rec ((clists (cons clist clists))) - (if (every pair? clists) + (or (any null? clists) (if (apply pred (map car clists)) - (rec (map cdr clists))) - #t)))) + (rec (map cdr clists))))))) (define (list-index pred clist . clists) (if (null? clists) @@ -600,9 +597,20 @@ (define (alist-cons key datum alist) (cons (cons key datum) alist)) - (define ) + (define (alist-copy alist) + (map (lambda (elt) (cons (car elt) (cdr elt))) alist)) - (export assoc assq assv) + (define (alist-delete key alist . =) + (let ((= (if (null? =) equal? (car =)))) + (remove (lambda (x) (= key (car x))) alist))) + + (define (alist-delete! key alist . =) + (let ((= (if (null? =) equal? (car =)))) + (remove! (lambda (x) (= key (car x))) alist))) + + (export assoc assq assv + alist-cons alist-copy + alist-delete alist-delete!) ;; # Set operations on lists ;; lset<= lset= lset-adjoin @@ -611,6 +619,151 @@ ;; lset-difference lset-difference! ;; lset-xor lset-xor! ;; lset-diff+intersenction lset-diff+intersection! + (define (lset<= = . lists) + (or (null? lists) + (let rec ((head (car lists)) (rest (cdr lists))) + (or (null? rest) + (let ((next (car rest)) (rest (cdr rest))) + (and (or (eq? head next) + (every (lambda (x) (member x next =)) head)) + (rec next rest))))))) + + (define (lset= = . lists) + (or (null? lists) + (let rec ((head (car lists)) (rest (cdr lists))) + (or (null? rest) + (let ((next (car rest)) (rest (cdr rest))) + (and (or (eq? head next) + (and (every (lambda (x) (member x next =)) head) + (every (lambda (x) (member x head =)) next)) + (rec next rest)))))))) + + (define (lset-adjoin = list . elts) + (let rec ((list list) (elts elts)) + (if (null? elts) + list + (if (member (car elts) list) + (rec list (cdr elts)) + (rec (cons (car elts) list) (cdr elts)))))) + + (define (lset-union = . lists) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + (rec head rest) + (rec (apply lset-adjoin = head next) rest))))))) + + (define (lset-intersection = . lists) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + (rec head rest) + (rec (filter (lambda (x) (member x next =)) head) + rest))))))) + + (define (lset-difference = list . lists) + (let rec ((head list) (rest lists)) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + '() + (rec (remove (lambda (x) (member x next =)) head) + rest)))))) + + (define (lset-xor = . lists) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + '() + (rec (append (remove (lambda (x) (member x next =)) head) + (remove (lambda (x) (member x head =)) next)) + rest))))))) + + (define (lset-diff+intersection = list . lists) + (values (apply lset-difference = list lists) + (lset-intersection = list (apply lset-union lists)))) + + (define (lset-adjoin! = list . elts) + (let rec ((list list) (elts elts)) + (if (null? elts) + list + (if (member (car elts) list) + (rec list (cdr elts)) + (let ((tail (cdr elts))) + (set-cdr! elts list) + (rec elts tail)))))) + + (define (lset-union! = . lists) + (letrec ((adjoin + (lambda (lst1 lst2) + (if (null? lst2) + lst1 + (if (member (car lst2) lst1 =) + (adjoin lst1 (cdr lst2)) + (let ((tail (cdr lst2))) + (set-cdr! lst2 lst1) + (adjoin lst2 tail))))))) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + (rec head rest) + (rec (adjoin head next) rest)))))))) + + (define (lset-intersection! = . lists) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + (rec head rest) + (rec (filter! (lambda (x) (member x next =)) head) + rest))))))) + + (define (lset-difference! = list . lists) + (let rec ((head list) (rest lists)) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + '() + (rec (remove! (lambda (x) (member x next =)) head) + rest)))))) + + (define (lset-xor! = . lists) + (if (null? lists) + lists + (let rec ((head (car lists)) (rest (cdr lists))) + (if (null? rest) + head + (let ((next (car rest)) (rest (cdr rest))) + (if (eq? head next) + '() + (rec (append! (remove! (lambda (x) (member x next =)) head) + (remove! (lambda (x) (member x head =)) next)) + rest))))))) + + (define (lset-diff+intersection! = list . lists) + (values (apply lset-difference! = list lists) + (lset-intersection! = list (apply lset-union! lists)))) ;; # Primitive side-effects ;; set-car! set-cdr!