source: project/release/4/combinators/tags/1.2.0/section-combinators.scm @ 19029

Last change on this file since 19029 was 19029, checked in by Kon Lovett, 10 years ago

Release w/ more stuff.

File size: 2.4 KB
Line 
1;;;; section-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4(module section-combinators
5
6  (;export
7    left-section right-section
8    crop-left crop-right
9    reversed
10    arguments-chain arguments-each arguments-all)
11
12  (import
13    scheme
14    chicken
15    (only srfi-1 drop drop-right circular-list)
16    (only data-structures identity))
17
18  (require-library srfi-1)
19
20  (declare
21    (type
22      (left-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
23      (right-section (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
24      (reversed (procedure ((procedure (#!rest) *)) (procedure (#!rest) *)))
25      (crop-left (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
26      (crop-right (procedure ((procedure (#!rest) *) fixnum) (procedure (#!rest) *)))
27      (arguments-chain (procedure (#!rest) (procedure (#!rest) *)))
28      (arguments-each (procedure (#!rest) (procedure (#!rest) list)))
29      (arguments-all (procedure (#!rest) (procedure (#!rest) list))) ) )
30
31;;; Section
32
33(define (left-section fn . args)
34  (lambda xs (apply fn (append args xs))) )
35
36; (reverse (append (reverse args) (reverse xs))) = (append xs args)
37(define (right-section fn . args)
38  (lambda xs (apply fn (append xs args))) )
39
40;;; Crop
41
42; (compose fn (right-section drop n) list)
43(define (crop-left fn n)
44  (lambda xs (apply fn (drop xs n))) )
45
46; (compose fn (right-section drop-right n) list)
47(define (crop-right fn n)
48  (lambda xs (apply fn (drop-right xs n))) )
49
50;;; Reverse
51
52; (compose fn reverse list)
53(define (reversed fn)
54  (lambda xs (apply fn (reverse xs))) )
55
56;;; Argument
57
58  (include "arguments-helpers.inc")
59
60;; arguments-chain
61
62; ((arguments-chain f g) arg...) -> (apply f (apply g arg...))
63; ((arguments-chain f) arg...) -> (apply f arg...)
64; ((arguments-chain) arg...) -> (list arg...)
65
66(define (arguments-chain . fns)
67  (let ((fn (chain-func fns)))
68    (lambda xs (fn xs)) ) )
69
70;; arguments-each
71
72; ((arguments-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
73; ((arguments-each) arg...) -> (list arg...)
74
75(define (arguments-each . fns)
76  (let ((fn (each-func fns)))
77    (lambda xs (fn xs)) ) )
78
79;; arguments-all
80
81; ((arguments-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
82; ((arguments-all) arg...) -> (list arg...)
83
84(define (arguments-all . fns)
85  (let ((fn (all-func fns)))
86    (lambda xs (fn xs)) ) )
87
88) ;module section-combinators
Note: See TracBrowser for help on using the repository browser.