Changeset 18918 in project for release/4/combinators


Ignore:
Timestamp:
07/22/10 00:03:13 (9 years ago)
Author:
Kon Lovett
Message:

More sections

Location:
release/4/combinators/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/combinators/trunk/combinators.setup

    r18914 r18918  
    66
    77(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))
    99(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))
    1111(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))
    1313(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))
    1515
    1616(install-extension 'combinators '() `((version ,(extension-version "1.1.0"))))
  • release/4/combinators/trunk/logical-combinators.scm

    r18914 r18918  
    22;;;; Kon Lovett, Mar '09
    33
    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
    125
    13 (module logical-combinators (;export
    14   andf orf)
     6  (;export
     7    andf
     8    orf)
    159
    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) *)) ) )
    1716
    1817;; Eager 'or' & 'and'
     
    2726(define (orf . args)
    2827  (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)) ) ) ) )
    3331
    3432) ;module logical-combinators
  • release/4/combinators/trunk/sort-combinators.scm

    r18914 r18918  
    22;;;; Kon Lovett, Mar '09
    33
    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
    127
    138(module sort-combinators (;export
     
    1510  make-equal/key make-less-than/key)
    1611
    17 (import scheme chicken srfi-1)
     12  (import scheme chicken srfi-1)
    1813
    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)) ) ) ) ) ) )
    2032
    2133;; Group a list of elements by some key attribute.
     
    2840
    2941(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) )
    3543
    3644;; Define a less-than function for a sort of a structured sequence.
     
    4755;; E.g. to sort a list of lists by their first items, using
    4856;; 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=?))
    5058
    5159(define (make-equal/key keyproc #!optional (equal =))
  • release/4/combinators/trunk/stack-combinators.scm

    r18914 r18918  
    22;;;; Kon Lovett, Mar '09
    33;;;; Portions from a 'comp.lang.scheme' posting by "wayo.cavazos@gmail.com"
     4
     5;These are useless & sigle valued!
    46
    57(module stack-combinators
     
    103105(define tri@
    104106  (case-lambda
    105     ((x y z f g h c)  (c (f x) (g y) (h z)))
    106     ((f g h c)        (lambda (x y z) (tri@ x y z f g h c)))))
     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)))))
    107109
    108110;;
Note: See TracChangeset for help on using the changeset viewer.