1 | ;;;; uni-combinators.scm |
---|

2 | ;;;; Kon Lovett, Jul '10 |
---|

3 | |
---|

4 | (module uni-combinators |
---|

5 | |
---|

6 | (;export |
---|

7 | uni uni2 uni3 uni-each uni-all) |
---|

8 | |
---|

9 | (import |
---|

10 | scheme |
---|

11 | chicken) |
---|

12 | |
---|

13 | #| |
---|

14 | ;;; Hook |
---|

15 | |
---|

16 | ;; Unary |
---|

17 | |
---|

18 | (define uni-left |
---|

19 | (case-lambda |
---|

20 | ((c f) (lambda (x) (c (f x) x))) |
---|

21 | ((c) (lambda (f) (uni-left c f))) |
---|

22 | (() (lambda (c) (uni-left c))))) |
---|

23 | |
---|

24 | (define uni-right |
---|

25 | (case-lambda |
---|

26 | ((c f) (lambda (x) (c x (f x)))) |
---|

27 | ((c) (lambda (f) (uni-right c f))) |
---|

28 | (() (lambda (c) (uni-right c))))) |
---|

29 | |
---|

30 | (define uni2-left |
---|

31 | (case-lambda |
---|

32 | ((c f) (lambda (x y) (c (f x y) x y))) |
---|

33 | ((c) (lambda (f) (uni2-left c f))) |
---|

34 | (() (lambda (c) (uni2-left c))))) |
---|

35 | |
---|

36 | (define uni2-right |
---|

37 | (case-lambda |
---|

38 | ((c f) (lambda (x y) (c x y (f x y)))) |
---|

39 | ((c) (lambda (f) (uni2-right c f))) |
---|

40 | (() (lambda (c) (uni2-right c))))) |
---|

41 | |
---|

42 | (define uni3-left |
---|

43 | (case-lambda |
---|

44 | ((c f) (lambda (x y z) (c (f x y z) x y z))) |
---|

45 | ((c) (lambda (f) (uni3-left c f))) |
---|

46 | (() (lambda (c) (uni3-left c))))) |
---|

47 | |
---|

48 | (define uni3-right |
---|

49 | (case-lambda |
---|

50 | ((c f) (lambda (x y z) (c x y z (f x y z)))) |
---|

51 | ((c) (lambda (f) (uni3-right c f))) |
---|

52 | (() (lambda (c) (uni3-right c))))) |
---|

53 | |
---|

54 | (define (uni-each-left c f) |
---|

55 | (lambda (x) (c (f x) x)) ) |
---|

56 | |
---|

57 | (define (uni-each-right c f) |
---|

58 | (lambda (x) (c x (f x))) ) |
---|

59 | |
---|

60 | (define (uni-all-left c f) |
---|

61 | (lambda xs (apply c (apply f xs) xs)) ) |
---|

62 | |
---|

63 | (define (uni-all-right c f) |
---|

64 | (lambda xs (apply c (append xs (list (apply f xs))))) ) |
---|

65 | |# |
---|

66 | |
---|

67 | ;;; Fork |
---|

68 | |
---|

69 | ;; Unary |
---|

70 | |
---|

71 | (define uni |
---|

72 | (case-lambda |
---|

73 | ((c f) (lambda (x) (c (f x)))) |
---|

74 | ((c) (lambda (f) (uni c f))) |
---|

75 | (() (lambda (c) (uni c))))) |
---|

76 | |
---|

77 | (define uni2 |
---|

78 | (case-lambda |
---|

79 | ((c f) (lambda (x y) (c (f x y)))) |
---|

80 | ((c) (lambda (f) (uni2 c f))) |
---|

81 | (() (lambda (c) (uni2 c))))) |
---|

82 | |
---|

83 | (define uni3 |
---|

84 | (case-lambda |
---|

85 | ((c f) (lambda (x y z) (c (f x y z)))) |
---|

86 | ((c) (lambda (f) (uni3 c f))) |
---|

87 | (() (lambda (c) (uni3 c))))) |
---|

88 | |
---|

89 | (define (uni-each c f) |
---|

90 | (lambda (x) (c (f x))) ) |
---|

91 | |
---|

92 | (define (uni-all c f) |
---|

93 | (lambda xs (c (apply f xs))) ) |
---|

94 | |
---|

95 | ) ;module uni-combinators |
---|