From bc51836440e599d819649cd152137010671d8851 Mon Sep 17 00:00:00 2001 From: stibear Date: Sat, 8 Feb 2014 23:11:17 +0900 Subject: [PATCH 01/12] implemented Constructors and Predicates --- piclib/srfi/1.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 76 insertions(+), 3 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 3601beb2..832b10af 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -8,17 +8,85 @@ (define (xcons a b) (cons b a)) - (export cons list xcons) + (define (cons* x . args) + (let rec ((acm '()) (x x) (lst args)) + (if (null? lst) + (append-reverse acm x) + (rec (cons x acm) (car lst) (cdr lst))))) + + (define (list-tabulate n init-proc) + (let rec ((acm '()) (n (- n 1))) + (if (zero? n) + (cons n acm) + (rec (cons n acm) (- n 1))))) + + (define (circular-list elt . args) + (let ((lst (cons elt args))) + (let rec ((l lst)) + (if (null? (cdr l)) + (set-cdr! l lst) + (rec (cdr l)))) + lst)) + + (define (iota count . lst) + (let ((start (if (pair? lst) (car lst) 0)) + (step (if (and (pair? lst) (pair? (cdr lst))) + (cadr lst) 1))) + (let rec ((count (- count 1)) (acm '())) + (if (zero? count) + (cons start acm) + (rec (- count 1) + (cons (+ start (* count step)) acm)))))) + + (export cons list xcons make-list list-tabulate list-copy circular-list iota) ;; # Predicates ;; pair? null? - ;; proper-list? cirtular-list? dotted-list? + ;; proper-list? circular-list? dotted-list? ;; not-pair? null-list? ;; list= (define (not-pair? x) (not (pair? x))) - (export pair? null? not-pair?) + (define (circular-list? x) + (and (pair? x) + (let rec ((lst (cdr x))) + (cond ((not-pair?) #f) + ((null? lst) #f) + ((eq? x lst) #t) + (else (rec (cdr lst))))))) + + (define (proper-list? x) + (if (not (circular-list? x)) + (list? x))) + + (define (dotted-list? x) + (and (pair? x) + (not (proper-list? x)) + (not (circular-list? x)))) + + (define (null-list? x) + (cond ((pair? x) #f) + ((null? x) #t) + (else (error "null-list?: argument out of domain" x)))) + + (define (list= elt= . lists) + (or (null? lists) + (let rec1 ((list1 (car lists)) (others (cdr lists))) + (or (null? others) + (let ((list2 (car others)) + (others (cdr others))) + (if (eq? list1 list2) + (rec1 list2 others) + (let rec2 ((l1 list1) (l2 list2)) + (if (null-list? l1) + (and (null-list? l2) + (rec1 list2 others)) + (and (not (null-list? l2)) + (elt= (car l1) (car l2)) + (rec2 (cdr l1) (cdr l2))))))))))) + + (export pair? null? not-pair? proper-list? circular-list? null-list? list=) ;; # Selectors ;; car cdr ... cddadr cddddr list-ref @@ -62,6 +130,9 @@ (define (zip . lists) (apply map list lists)) + (define (append-reverse rev-head tail) + (append (reverse rev-head) tail)) + (export length append concatenate reverse zip) ;; # Fold, unfold & map @@ -70,6 +141,7 @@ ;; fold-right unfold-right pair-fold right reduce-right ;; append-map append-map! ;; map! pair-for-each filter-map map-in-order + (export map for-each) ;; # Filtering & partitioning @@ -135,3 +207,4 @@ ;; # Primitive side-effects ;; set-car! set-cdr! (export set-car! set-cdr!)) + From a89d88d276e367cdbcf95428eb880908ab7a3e69 Mon Sep 17 00:00:00 2001 From: stibear Date: Sun, 9 Feb 2014 02:20:48 +0900 Subject: [PATCH 02/12] implemented Selectors --- piclib/srfi/1.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 59 insertions(+), 3 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 832b10af..7f1028c2 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -111,11 +111,65 @@ x (drop (cdr x) (- i 1)))) + (define (take-right flist i) + (let ((len (length flist))) + (drop flist (- len i)))) + + (define (drop-right flist i) + (let ((len (length flist))) + (take flist (- len i)))) + + (define (take! x i) + (let rec ((lis x) (n (- i 1))) + (if (zero? n) + (begin (set-cdr! lis '()) x) + (rec (cdr lis) (- n 1))))) + + (define (drop-right! flist i) + (let ((lead (drop flist i))) + (if (not-pair? lead) + '() + (let rec ((lis1 flist) (lead (cdr lead))) + (if (pair? lis2) + (rec (cdr lis1) (cdr lis2)) + (begin (set-cdr! lis1 '()) flist)))))) + (define (split-at x i) (values (take x i) (drop x i))) - (export car cdr car+cdr - take drop) + (define (split-at! x i) + (values (take! x i) (drop x i))) + + (define (last pair) + (car (take-right pair 1))) + + (define (last-pair pair) + (take-right pair 1)) + + (define first car) + (define second cadr) + (define third caddr) + (define fourth cadddr) + (define (fifth pair) + (list-ref pair 5)) + (define (sixth pair) + (list-ref pair 6)) + (define (seventh pair) + (list-ref pair 7)) + (define (eighth pair) + (list-ref pair 8)) + (define (ninth pair) + (list-ref pair 9)) + (define (tenth pair) + (list-ref pair 10)) + + (export car cdr car+cdr list-ref + caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr + cdadar cdaddr cddaar cddadr cdddar cddddr + first second third fourth fifth sixth seventh eighth ninth tenth + take drop take-right drop-right take! drop-right! + split-at split-at! last last-pair) ;; # Miscellaneous ;; length length+ @@ -133,7 +187,9 @@ (define (append-reverse rev-head tail) (append (reverse rev-head) tail)) - (export length append concatenate reverse zip) + + + (export length append concatenate reverse zip append-reverse) ;; # Fold, unfold & map ;; map for-each From 2c491001a5ae8830d0cc6dbb590bdcd30347ad55 Mon Sep 17 00:00:00 2001 From: stibear Date: Mon, 10 Feb 2014 23:01:17 +0900 Subject: [PATCH 03/12] implemented Miscellaneous --- piclib/srfi/1.scm | 70 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 65 insertions(+), 5 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 7f1028c2..23456e00 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -124,7 +124,8 @@ (if (zero? n) (begin (set-cdr! lis '()) x) (rec (cdr lis) (- n 1))))) - + + ;; (define (drop-right! flist i) (let ((lead (drop flist i))) (if (not-pair? lead) @@ -178,18 +179,77 @@ ;; append-reverse append-reverse! ;; zip unzip1 unzip2 unzip3 unzip4 unzip5 ;; count + (define (length+ lst) + (if (not (circular-list? lst)) + (length lst))) + (define (concatenate lists) (apply append lists)) + (define (append! . lists) + (if (null? lists) + '() + (let rec ((lst lists)) + (if (not-pair? (cdr lst)) + (car lst) + (begin (set-cdr! (last-pair (car lst)) (cdr lst)) + (rec (cdr lst))))))) + + (define (concatenate! lists) + (apply append! lists)) + + (define (reverse! list) + (let rec ((lst list) (acm '())) + (if (null? lst) + acm + (let ((rst (cdr lst))) + (set-cdr! lst acm) + (rec rst lst))))) + + (define (append-reverse rev-head tail) + (if (null? rev-head) + tail + (append-reverse (cdr rev-head) (cons (car rev-head) tail)))) + + (define (append-reverse! rev-head tail) + (let ((rst (cdr rev-head))) + (if (null? rev-head) + tail + (begin (set-cdr! rev-head tail) + (append-reverse! rst rev-head))))) + (define (zip . lists) (apply map list lists)) - (define (append-reverse rev-head tail) - (append (reverse rev-head) tail)) + (define (unzip1 list) + (map first list)) + (define (unzip2 list) + (values (map first list) + (map second list))) + + (define (unzip3 list) + (values (map first list) + (map second list) + (map third list))) + + (define (unzip4 list) + (values (map first list) + (map second list) + (map third list) + (map fourth list))) + + (define (unzip3 list) + (values (map first list) + (map second list) + (map third list) + (map fourth list) + (map fifth list))) - - (export length append concatenate reverse zip append-reverse) + (export length length+ + append append! concatenate concatenate! + reverse reverse! append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5) ;; # Fold, unfold & map ;; map for-each From 4e2becb6426579b988e34cb78ed526f1a4b1400c Mon Sep 17 00:00:00 2001 From: stibear Date: Mon, 10 Feb 2014 23:20:20 +0900 Subject: [PATCH 04/12] implemented Miscellaneous completely --- piclib/srfi/1.scm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 23456e00..bc257e9f 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -245,6 +245,12 @@ (map third list) (map fourth list) (map fifth list))) + + (define (count pred . clists) + (let rec ((tflst (apply map pred clists)) (n 0)) + (if (null? tflst) + n + (rec (cdr tflst) (if (car tflst) (+ n 1) n))))) (export length length+ append append! concatenate concatenate! From 4e00cfc86a591f79eab4ee450e2ab0f632c2f30b Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 05:06:05 +0900 Subject: [PATCH 05/12] implemented Fold, unfold & map --- piclib/srfi/1.scm | 162 ++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 148 insertions(+), 14 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index bc257e9f..85970eff 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -9,16 +9,16 @@ (cons b a)) (define (cons* x . args) - (let rec ((acm '()) (x x) (lst args)) + (let rec ((acc '()) (x x) (lst args)) (if (null? lst) - (append-reverse acm x) - (rec (cons x acm) (car lst) (cdr lst))))) + (append-reverse acc x) + (rec (cons x acc) (car lst) (cdr lst))))) (define (list-tabulate n init-proc) - (let rec ((acm '()) (n (- n 1))) + (let rec ((acc '()) (n (- n 1))) (if (zero? n) - (cons n acm) - (rec (cons n acm) (- n 1))))) + (cons n acc) + (rec (cons n acc) (- n 1))))) (define (circular-list elt . args) (let ((lst (cons elt args))) @@ -32,11 +32,11 @@ (let ((start (if (pair? lst) (car lst) 0)) (step (if (and (pair? lst) (pair? (cdr lst))) (cadr lst) 1))) - (let rec ((count (- count 1)) (acm '())) + (let rec ((count (- count 1)) (acc '())) (if (zero? count) - (cons start acm) + (cons start acc) (rec (- count 1) - (cons (+ start (* count step)) acm)))))) + (cons (+ start (* count step)) acc)))))) (export cons list xcons make-list list-tabulate list-copy circular-list iota) @@ -199,11 +199,11 @@ (apply append! lists)) (define (reverse! list) - (let rec ((lst list) (acm '())) + (let rec ((lst list) (acc '())) (if (null? lst) - acm + acc (let ((rst (cdr lst))) - (set-cdr! lst acm) + (set-cdr! lst acc) (rec rst lst))))) (define (append-reverse rev-head tail) @@ -264,7 +264,142 @@ ;; append-map append-map! ;; map! pair-for-each filter-map map-in-order - (export map for-each) + ;; means for inter-referential definition + (define every #f) + + (define (fold kons knil clist . clists) + (if (null? clists) + (let rec ((acc knil) (clist clist)) + (if (null? clist) + acc + (rec (kons (car clist) acc) (cdr clist)))) + (let rec ((acc knil) (clists (cons clist clists))) + (if (every pair? clists) + (rec (apply kons (append (map car clists) (list acc))) + (map cdr clists)) + acc)))) + + (define (fold-right kons knil clist . clists) + (if (null? clists) + (let rec ((clist clist) (cont values)) + (if (null? clist) + (cont knil) + (rec (cdr clist) (lambda (x) (cont (kons (car clist) x)))))) + (let rec ((clists (cons clist clists)) (cont values)) + (if (every pair? clists) + (rec (map cdr clists) + (lambda (x) + (cont (apply kons (append (map car clists) (list x)))))) + (cont knil))))) + + (define (pair-fold kons knil clist . clists) + (if (null? clists) + (let rec ((acc knil) (clist clist)) + (if (null? clist) + acc + (let ((tail (cdr clist))) + (rec (kons clist acc) tail)))) + (let rec ((acc knil) (clists (cons clist clists))) + (if (every pair? clists) + (let ((tail (map cdr clists))) + (rec (apply kons (append clists (list acc))) + tail)) + acc)))) + + (define (pair-fold-right kons knil clist . clists) + (if (null? clists) + (let rec ((clist clist) (cont values)) + (if (null? clist) + (cont knil) + (let ((tail (map cdr clists))) + (rec tail (lambda (x) (cont (kons clist x))))))) + (let rec ((clists (cons clist clists)) (cont values)) + (if (every pair? clists) + (let ((tail (map cdr clists))) + (rec tail + (lambda (x) + (cont (apply kons (append clists (list x))))))) + (cont knil))))) + + (define (reduce f ridentity list) + (if (null? list) + ridentity + (fold f (car list) (cdr list)))) + + (define (reduce-right f ridentity list) + (fold-right f ridentity list)) + + (define (unfold p f g seed . tail-gen) + (let ((tail-gen (if (null? tail-gen) + (lambda (x) '()) + (car tail-gen)))) + (let rec ((seed seed) (cont values)) + (if (p seed) + (cont (tail-gen seed)) + (rec (g seed) (lambda (x) (cont (cons (f seed) x)))))))) + + (define (unfold-right p f g seed . tail) + (let rec ((seed seed) (lst tail)) + (if (p seed) + lst + (rec (g seed) (cons (f seed) lst))))) + + (define (append-map f . clists) + (apply append (apply map f clists))) + + (define (append-map! f . clists) + (apply append! (apply map f clists))) + + (define pair-for-each #f) + + (define (map! f list . lists) + (if (null? lists) + (pair-for-each (lambda (x) (set-car! x (f (car x)))) list) + (let rec ((list list) (lists lists)) + (if (pair? list) + (let ((head (map car lists)) + (rest (map cdr lists))) + (set-car! list (apply f (car list) head)) + (rec (cdr list) tail))))) + list1) + + (define (map-in-order f clist . clists) + (if (null? clists) + (let rec ((clist clist) (acc '())) + (if (null? clist) + (reverse acc) + (rec (cdr clist) (cons (f (car clist)) acc)))) + (let rec ((clists (cons clist clists)) (acc '())) + (if (every pair? clists) + (rec (map cdr clists) + (cons* (apply f (map car clists)) acc)) + (reverse acc))))) + + (define (pair-for-each f clist . clists) + (if (null? clist) + (let rec ((clist clist)) + (if (pair? clist) + (begin (f (car clist)) (rec (cdr clist))))) + (let rec ((clists (cons clist clists))) + (if (every pair? clists) + (begin (apply f (map car clists)) (rec (map cdr clists))))))) + + (define (filter-map f clist . clists) + (if (null? clists) + (let rec ((clist clist) (cont values)) + (if (null? clist) + (cont '()) + (rec (cdr clist) + (let ((it (f (car clist)))) + (if it + (lambda (x) (cont (cons it x))) + (lambda (x) (cont x))))))))) + + (export map for-each + fold unfold pair-fold reduce + fold-right unfold-right pair-fold-right reduce-right + append-map append-map! + map! pair-for-each filter-map map-in-order) ;; # Filtering & partitioning ;; filter partition remove @@ -329,4 +464,3 @@ ;; # Primitive side-effects ;; set-car! set-cdr! (export set-car! set-cdr!)) - From 2f550aee4921a315aa9c9504cffdde017b879d6c Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 05:34:32 +0900 Subject: [PATCH 06/12] implemented Filtering & partitioning --- piclib/srfi/1.scm | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 85970eff..850f1695 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -412,14 +412,37 @@ (filter pred (cdr list))) (filter pred (cdr list))))) + ;; means for inter-referential definition + (define remove #f) + (define (partition pred list) (values (filter pred list) - (filter (lambda (x) (not (pred x))) list))) + (remove pred list))) (define (remove pred list) (filter (lambda (x) (not (pred x))) list)) - (export filter partition remove) + (define (filter! pred list) + (let rec ((lst list)) + (if (null? lst) + lst + (if (pred (car lst)) + (begin (set-cdr! lst (rec (cdr lst))) + lst) + (rec (cdr lst)))))) + + ;; means for inter-referential definition + (define remove! #f) + + (define (partition! pred list) + (values (filter! pred list) + (remove! pred list))) + + (define (remove! pred list) + (filter! (lambda (x) (net (pred x))) list)) + + (export filter partition remove + filter! partition! remove!) ;; # Searching ;; member memq memv From 978e8001040d71f89f77cd04dff152812348a8d7 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 06:28:36 +0900 Subject: [PATCH 07/12] implemented Searching --- piclib/srfi/1.scm | 107 +++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 100 insertions(+), 7 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 850f1695..a3f7f587 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -451,12 +451,9 @@ ;; list-index ;; take-while drop-while take-while! ;; span break span! break! - (define (find-tail pred list) - (if (null? list) - #f - (if (pred (car list)) - list - (find-tail pred (cdr list))))) + + ;; means for inter-referential definition + (define find-tail #f) (define (find pred list) (let ((tail (find-tail pred list))) @@ -464,7 +461,103 @@ (car tail) #f))) - (export member memq memv find-tail find) + (define (find-tail pred list) + (if (null? list) + #f + (if (pred (car list)) + list + (find-tail pred (cdr list))))) + + (define (take-while pred clist) + (let rec ((clist clist) (cont values)) + (if (null? clist) + (cont '()) + (if (pred (car clist)) + (rec (cdr clist) + (lambda (x) (cont (cons (car clist) x)))) + (cont '()))))) + + (define (take-while! pred clist) + (let rec ((clist clist)) + (if (null? clist) + '() + (if (pred (car clist)) + (begin (set-cdr! clist (rec (cdr clist))) + clist) + '())))) + + (define (drop-while pred clist) + (let rec ((clist clist)) + (if (null? clist) + '() + (if (pred (car clist)) + (rec (cdr clist)) + clist)))) + + (define (span pred clist) + (values (take-while pred clist) + (drop-while pred clist))) + + (define (span! pred clist) + (values (take-while! pred clist) + (drop-while! pred clist))) + + (define (break pred clist) + (values (take-while (lambda (x) (not (pred x))) clist) + (drop-while (lambda (x) (not (pred x))) clist))) + + (define (break! pred clist) + (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 + (rec (cdr clist))))) + (let rec ((clists (cons clist clists))) + (if (every pair? clists) + (if (apply pred (map car clists)) + #t + (rec (map cdr clists))))))) + + (define (every pred clist . clists) + (if (null? clists) + (let rec ((clist clist)) + (if (pair? clist) + (if (pred (car clist)) + (rec (cdr clist))) + #t)) + (let rec ((clists (cons clist clists))) + (if (every pair? clists) + (if (apply pred (map car clists)) + (rec (map cdr clists))) + #t)))) + + (define (list-index pred clist . clists) + (if (null? clists) + (let rec ((clist clist) (n 0)) + (if (pair? clist) + (if (pred (car clist)) + n + (rec (cdr clist) (+ n 1))))) + (let rec ((clists (cons clist clists)) (n 0)) + (if (every pair? clists) + (if (apply pred (map car clists)) + n + (rec (map cdr clists) (+ n 1))))))) + + (export member memq memv + find find-tail + any every + list-index + take-while drop-while take-while! + span break span! break!) ;; # Deleting ;; delete delete-duplicates From 00c8351d5f968b1f0dd5d2c5be387b8b6bd89137 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 16:40:59 +0900 Subject: [PATCH 08/12] implemented Deleting --- piclib/srfi/1.scm | 39 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index a3f7f587..addd8ac1 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -367,13 +367,13 @@ (if (null? clists) (let rec ((clist clist) (acc '())) (if (null? clist) - (reverse acc) + (reverse! acc) (rec (cdr clist) (cons (f (car clist)) acc)))) (let rec ((clists (cons clist clists)) (acc '())) (if (every pair? clists) (rec (map cdr clists) (cons* (apply f (map car clists)) acc)) - (reverse acc))))) + (reverse! acc))))) (define (pair-for-each f clist . clists) (if (null? clist) @@ -562,11 +562,46 @@ ;; # Deleting ;; delete delete-duplicates ;; delete! delete-duplicates! + (define (delete x list . =) + (let ((= (if (null? =) equal? (car =)))) + (remove (lambda (a) (= x a)) list))) + + (define (delete! x list . =) + (let ((= (if (null? =) equal? (car =)))) + (remove! (lambda (a) (= x a)) list))) + + (define (delete-duplicates list . =) + (let ((= (if (null? =) equal? (car =)))) + (let rec ((list list)) + (if (null? list) + list + (let* ((x (car list)) + (rest (cdr list)) + (deleted (rec (delete x list =)))) + (if (eq? rest deleted) list (cons x deleted))))))) + + (define (delete-duplicates! list . =) + (let ((= (if (null? =) equal? (car =)))) + (let rec ((list list)) + (if (null? list) + list + (let* ((x (car list)) + (rest (cdr list)) + (deleted (rec (delete! x list =)))) + (if (eq? rest deleted) list (cons x deleted))))))) + + (export delete delete-duplicates + delete! delete-duplicates!) ;; # Association lists ;; assoc assq assv ;; alist-cons alist-copy ;; alist-delete alist-delete! + (define (alist-cons key datum alist) + (cons (cons key datum) alist)) + + (define ) + (export assoc assq assv) ;; # Set operations on lists From bdfaef44670031cac8674f26d7fb633512943498 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 16:50:08 +0900 Subject: [PATCH 09/12] 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! From 47594a07e2d973a95567d1611ffd805d4ba43d7b Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 21:52:36 +0900 Subject: [PATCH 10/12] implemented Set operations on lists --- piclib/srfi/1.scm | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 51430e73..2badd58d 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -765,6 +765,13 @@ (values (apply lset-difference! = list lists) (lset-intersection! = list (apply lset-union! lists)))) + (export lset<= lset= lset-adjoin + lset-union lset-union! + lset-intersection lset-intersection! + lset-difference lset-difference! + lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection!) + ;; # Primitive side-effects ;; set-car! set-cdr! (export set-car! set-cdr!)) From 88706bddad984a1d656ff1742fd0080104105840 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 22:29:25 +0900 Subject: [PATCH 11/12] fixed trivial bug --- piclib/srfi/1.scm | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 2badd58d..2f46284c 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -134,7 +134,7 @@ (let ((lead (drop flist i))) (if (not-pair? lead) '() - (let rec ((lis1 flist) (lead (cdr lead))) + (let rec ((lis1 flist) (lis2 (cdr lead))) (if (pair? lis2) (rec (cdr lis1) (cdr lis2)) (begin (set-cdr! lis1 '()) flist)))))) @@ -156,17 +156,18 @@ (define third caddr) (define fourth cadddr) (define (fifth pair) - (list-ref pair 5)) + (list-ref pair 4)) (define (sixth pair) - (list-ref pair 6)) + (list-ref pair 5)) (define (seventh pair) - (list-ref pair 7)) + (list-ref pair 6)) (define (eighth pair) - (list-ref pair 8)) + (list-ref pair 7)) (define (ninth pair) - (list-ref pair 9)) + (list-ref pair 8)) (define (tenth pair) - (list-ref pair 10)) + (list-ref pair 9)) + (export car cdr car+cdr list-ref caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr @@ -758,7 +759,7 @@ (if (eq? head next) '() (rec (append! (remove! (lambda (x) (member x next =)) head) - (remove! (lambda (x) (member x head =)) next)) + (remove! (lambda (x) (member x head =)) next)) rest))))))) (define (lset-diff+intersection! = list . lists) From 95561ba3e81f6dd8180af449e68d3030d46c1a97 Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 22:53:51 +0900 Subject: [PATCH 12/12] fixed trivial bugs --- piclib/srfi/1.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 2f46284c..13ada184 100644 --- a/piclib/srfi/1.scm +++ b/piclib/srfi/1.scm @@ -244,7 +244,7 @@ (map third list) (map fourth list))) - (define (unzip3 list) + (define (unzip5 list) (values (map first list) (map second list) (map third list) @@ -260,7 +260,8 @@ (export length length+ append append! concatenate concatenate! reverse reverse! append-reverse append-reverse! - zip unzip1 unzip2 unzip3 unzip4 unzip5) + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count) ;; # Fold, unfold & map ;; map for-each @@ -355,6 +356,7 @@ (define (append-map! f . clists) (apply append! (apply map f clists))) + ;; means for inter-referential definition (define pair-for-each #f) (define (map! f list . lists) @@ -365,8 +367,8 @@ (let ((head (map car lists)) (rest (map cdr lists))) (set-car! list (apply f (car list) head)) - (rec (cdr list) tail))))) - list1) + (rec (cdr list) rest))))) + list) (define (map-in-order f clist . clists) (if (null? clists) @@ -444,7 +446,7 @@ (remove! pred list))) (define (remove! pred list) - (filter! (lambda (x) (net (pred x))) list)) + (filter! (lambda (x) (not (pred x))) list)) (export filter partition remove filter! partition! remove!) @@ -505,7 +507,7 @@ (define (span! pred clist) (values (take-while! pred clist) - (drop-while! pred clist))) + (drop-while pred clist))) (define (break pred clist) (values (take-while (lambda (x) (not (pred x))) clist) @@ -513,7 +515,7 @@ (define (break! pred clist) (values (take-while! (lambda (x) (not (pred x))) clist) - (drop-while! (lambda (x) (not (pred x))) clist))) + (drop-while (lambda (x) (not (pred x))) clist))) (define (any pred clist . clists) (if (null? clists)