Changeset 18918 in project
- Timestamp:
- 07/22/10 00:03:13 (11 years ago)
- Location:
- release/4/combinators/trunk
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/combinators/trunk/combinators.setup
r18914 r18918 6 6 7 7 (setup-shared-extension-module 'section-combinators (extension-version "1.1.0") 8 #:compile-options '(- optimize-level 3 -fixnum-arithmetic -no-procedure-checks))8 #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks)) 9 9 (setup-shared-extension-module 'logical-combinators (extension-version "1.1.0") 10 #:compile-options '(- optimize-level 3 -fixnum-arithmetic -no-procedure-checks))10 #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks)) 11 11 (setup-shared-extension-module 'sort-combinators (extension-version "1.1.0") 12 #:compile-options '(- optimize-level 3 -fixnum-arithmetic -no-procedure-checks))12 #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks)) 13 13 (setup-shared-extension-module 'stack-combinators (extension-version "1.1.0") 14 #:compile-options '(- optimize-level 3 -fixnum-arithmetic -no-procedure-checks))14 #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks)) 15 15 16 16 (install-extension 'combinators '() `((version ,(extension-version "1.1.0")))) -
release/4/combinators/trunk/logical-combinators.scm
r18914 r18918 2 2 ;;;; Kon Lovett, Mar '09 3 3 4 (declare 5 (usual-integrations) 6 (generic) 7 (inline) 8 (local) 9 (no-procedure-checks) 10 (bound-to-procedure 11 ##sys#check-closure) ) 4 (module logical-combinators 12 5 13 (module logical-combinators (;export 14 andf orf) 6 (;export 7 andf 8 orf) 15 9 16 (import scheme chicken data-structures srfi-1) 10 (import scheme chicken data-structures srfi-1) 11 12 (declare 13 (type 14 (andf (procedure (#!rest) *)) 15 (orf (procedure (#!rest) *)) ) ) 17 16 18 17 ;; Eager 'or' & 'and' … … 27 26 (define (orf . args) 28 27 (let loop ((args args)) 29 (cond ((null? args) #f) 30 ((car args) => identity) 31 (else 32 (loop (cdr args)) ) ) ) ) 28 (and (not (null? args)) 29 (or (car args) 30 (loop (cdr args)) ) ) ) ) 33 31 34 32 ) ;module logical-combinators -
release/4/combinators/trunk/sort-combinators.scm
r18914 r18918 2 2 ;;;; Kon Lovett, Mar '09 3 3 4 (declare 5 (usual-integrations) 6 (generic) 7 (inline) 8 (local) 9 (no-procedure-checks) 10 (bound-to-procedure 11 ##sys#check-closure) ) 4 ;; Issues 5 ;; 6 ;; - group/key is not a combinator 12 7 13 8 (module sort-combinators (;export … … 15 10 make-equal/key make-less-than/key) 16 11 17 (import scheme chicken srfi-1)12 (import scheme chicken srfi-1) 18 13 19 (require-library srfi-1) 14 (require-library srfi-1) 15 16 (declare 17 (type 18 (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list)) 19 (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) 20 (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) ) 21 22 ;; 23 24 ;kinda violates the argument list orientation of comibinators 25 (define (group-by proc #!optional (equality equal?)) 26 (lambda (ls) 27 (let loop ((ls ls) (acc '())) 28 (if (null? ls) acc #;(reverse! acc) 29 (let ((key (proc (car ls)))) 30 (receive (grouped rest) (span (lambda (item) (equality key (proc item))) ls) 31 (loop rest (cons grouped acc)) ) ) ) ) ) ) 20 32 21 33 ;; Group a list of elements by some key attribute. … … 28 40 29 41 (define (group/key keyproc ls #!optional (equality equal?)) 30 (let loop ((ls ls) (acc '())) 31 (if (null? ls) acc #;(reverse! acc) 32 (let ((key (keyproc (car ls)))) 33 (receive (grouped rest) (span (lambda (item) (equality key (keyproc item))) ls) 34 (loop rest (cons grouped acc)) ) ) ) ) ) 42 ((group-by keyproc equality) ls) ) 35 43 36 44 ;; Define a less-than function for a sort of a structured sequence. … … 47 55 ;; E.g. to sort a list of lists by their first items, using 48 56 ;; string-case-insensitive comparison: 49 ;; (make-hash-table ( uni first string-ci-hash) (make-equal/key first string-ci=?))57 ;; (make-hash-table (o string-ci-hash first) (make-equal/key first string-ci=?)) 50 58 51 59 (define (make-equal/key keyproc #!optional (equal =)) -
release/4/combinators/trunk/stack-combinators.scm
r18914 r18918 2 2 ;;;; Kon Lovett, Mar '09 3 3 ;;;; Portions from a 'comp.lang.scheme' posting by "wayo.cavazos@gmail.com" 4 5 ;These are useless & sigle valued! 4 6 5 7 (module stack-combinators … … 103 105 (define tri@ 104 106 (case-lambda 105 ((x y z f g h c) (c (f x) (g y) (hz)))106 ((f g h c) (lambda (x y z) (tri@ x y z f g hc)))))107 ((x y z f c) (c (f x) (f y) (f z))) 108 ((f c) (lambda (x y z) (tri@ x y z f c))))) 107 109 108 110 ;;
Note: See TracChangeset
for help on using the changeset viewer.