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 |
---|