From 4e00cfc86a591f79eab4ee450e2ab0f632c2f30b Mon Sep 17 00:00:00 2001 From: stibear Date: Tue, 11 Feb 2014 05:06:05 +0900 Subject: [PATCH] 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!)) -