diff --git a/piclib/srfi/1.scm b/piclib/srfi/1.scm index 3601beb2..13ada184 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,17 +9,89 @@ (define (xcons a b) (cons b a)) - (export cons list xcons) + ;; means for inter-referential definition + (define append-reverse #f) + + (define (cons* x . args) + (let rec ((acc '()) (x x) (lst args)) + (if (null? lst) + (append-reverse acc x) + (rec (cons x acc) (car lst) (cdr lst))))) + + (define (list-tabulate n init-proc) + (let rec ((acc '()) (n (- n 1))) + (if (zero? n) + (cons n acc) + (rec (cons n acc) (- 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)) (acc '())) + (if (zero? count) + (cons start acc) + (rec (- count 1) + (cons (+ start (* count step)) acc)))))) + + (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))))))) + + ;; if list? is support circular list, (define proper-list? list?) + (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 @@ -43,11 +116,66 @@ 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) (lis2 (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 4)) + (define (sixth pair) + (list-ref pair 5)) + (define (seventh pair) + (list-ref pair 6)) + (define (eighth pair) + (list-ref pair 7)) + (define (ninth pair) + (list-ref pair 8)) + (define (tenth pair) + (list-ref pair 9)) + + + (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+ @@ -56,13 +184,84 @@ ;; 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) (acc '())) + (if (null? lst) + acc + (let ((rst (cdr lst))) + (set-cdr! lst acc) + (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)) - (export length append concatenate reverse zip) + (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 (unzip5 list) + (values (map first list) + (map second list) + (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! + reverse reverse! append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count) ;; # Fold, unfold & map ;; map for-each @@ -70,7 +269,144 @@ ;; 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) + + ;; 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))) + + ;; means for inter-referential definition + (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) rest))))) + list) + + (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 @@ -83,14 +419,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) (not (pred x))) list)) + + (export filter partition remove + filter! partition! remove!) ;; # Searching ;; member memq memv @@ -99,12 +458,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))) @@ -112,17 +468,152 @@ (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))) + + (define (any pred clist . clists) + (if (null? clists) + (let rec ((clist clist)) + (if (pair? clist) + (or (pred (car clist)) + (rec (cdr clist))))) + (let rec ((clists (cons clist clists))) + (if (every pair? clists) + (or (apply pred (map car clists)) + (rec (map cdr clists))))))) + + (define (every pred clist . clists) + (if (null? clists) + (let rec ((clist clist)) + (or (null? clist) + (if (pred (car clist)) + (rec (cdr clist))))) + (let rec ((clists (cons clist clists))) + (or (any null? clists) + (if (apply pred (map car clists)) + (rec (map cdr clists))))))) + + (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 ;; 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! - (export assoc assq assv) + (define (alist-cons key datum alist) + (cons (cons key datum) alist)) + + (define (alist-copy alist) + (map (lambda (elt) (cons (car elt) (cdr elt))) alist)) + + (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 @@ -131,6 +622,158 @@ ;; 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)))) + + (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!