Changeset 18918 in project

Timestamp:

07/22/10 00:03:13 (10 years ago)

Author:

Kon Lovett

Message:

More sections

Location:

release/4/combinators/trunk

Files:

• combinators.setup (modified) (1 diff)
• logical-combinators.scm (modified) (2 diffs)
• sort-combinators.scm (modified) (4 diffs)
• stack-combinators.scm (modified) (2 diffs)

release/4/combinators/trunk/combinators.setup

@@ -6 +6 @@
 
 (setup-shared-extension-module 'section-combinators (extension-version "1.1.0")
-  #:compile-options '(-optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
+  #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
 (setup-shared-extension-module 'logical-combinators (extension-version "1.1.0")
-  #:compile-options '(-optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
+  #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
 (setup-shared-extension-module 'sort-combinators (extension-version "1.1.0")
-  #:compile-options '(-optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
+  #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
 (setup-shared-extension-module 'stack-combinators (extension-version "1.1.0")
-  #:compile-options '(-optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
+  #:compile-options '(-scrutinize -optimize-level 3 -fixnum-arithmetic -no-procedure-checks))
 
 (install-extension 'combinators '() `((version ,(extension-version "1.1.0"))))

release/4/combinators/trunk/logical-combinators.scm

@@ -2 +2 @@
 ;;;; Kon Lovett, Mar '09
 
-(declare
-  (usual-integrations)
-  (generic)
-  (inline)
-  (local)
-  (no-procedure-checks)
-  (bound-to-procedure
-    ##sys#check-closure) )
+(module logical-combinators
 
-(module logical-combinators (;export
-  andf orf)
+  (;export
+    andf
+    orf)
 
-(import scheme chicken data-structures srfi-1)
+  (import scheme chicken data-structures srfi-1)
+
+  (declare
+    (type
+      (andf (procedure (#!rest) *))
+      (orf (procedure (#!rest) *)) ) )
 
 ;; Eager 'or' & 'and'
@@ -27 +26 @@
 (define (orf . args)
   (let loop ((args args))
-    (cond ((null? args) #f)
-          ((car args)   => identity)
-          (else
-            (loop (cdr args)) ) ) ) )
+    (and (not (null? args))
+         (or (car args)
+             (loop (cdr args)) ) ) ) )
 
 ) ;module logical-combinators

release/4/combinators/trunk/sort-combinators.scm

@@ -2 +2 @@
 ;;;; Kon Lovett, Mar '09
 
-(declare
-  (usual-integrations)
-  (generic)
-  (inline)
-  (local)
-  (no-procedure-checks)
-  (bound-to-procedure
-    ##sys#check-closure) )
+;; Issues
+;;
+;; - group/key is not a combinator
 
 (module sort-combinators (;export
@@ -15 +10 @@
   make-equal/key make-less-than/key)
 
-(import scheme chicken srfi-1)
+  (import scheme chicken srfi-1)
 
-(require-library srfi-1)
+  (require-library srfi-1)
+
+  (declare
+    (type
+      (group/key (procedure ((procedure (*) *) list #!optional (procedure (* *) boolean)) list))
+      (make-less-than/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean)))
+      (make-equal/key (procedure ((procedure (*) *) #!optional (procedure (* *) boolean)) (procedure (* *) boolean))) ) )
+
+;;
+
+;kinda violates the argument list orientation of comibinators
+(define (group-by proc #!optional (equality equal?))
+  (lambda (ls)
+    (let loop ((ls ls) (acc '()))
+      (if (null? ls) acc #;(reverse! acc)
+          (let ((key (proc (car ls))))
+            (receive (grouped rest) (span (lambda (item) (equality key (proc item))) ls)
+              (loop rest (cons grouped acc)) ) ) ) ) ) )
 
 ;; Group a list of elements by some key attribute.
@@ -28 +40 @@
 
 (define (group/key keyproc ls #!optional (equality equal?))
-  (let loop ((ls ls) (acc '()))
-    (if (null? ls) acc #;(reverse! acc)
-        (let ((key (keyproc (car ls))))
-          (receive (grouped rest) (span (lambda (item) (equality key (keyproc item))) ls)
-            (loop rest (cons grouped acc)) ) ) ) ) )
+  ((group-by keyproc equality) ls) )
 
 ;; 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
 ;; string-case-insensitive comparison:
-;; (make-hash-table (uni first string-ci-hash) (make-equal/key first string-ci=?))
+;; (make-hash-table (o string-ci-hash first) (make-equal/key first string-ci=?))
 
 (define (make-equal/key keyproc #!optional (equal =))

release/4/combinators/trunk/stack-combinators.scm

@@ -2 +2 @@
 ;;;; Kon Lovett, Mar '09
 ;;;; Portions from a 'comp.lang.scheme' posting by "wayo.cavazos@gmail.com"
+
+;These are useless & sigle valued!
 
 (module stack-combinators
@@ -103 +105 @@
 (define tri@
   (case-lambda
-    ((x y z f g h c)  (c (f x) (g y) (h z)))
-    ((f g h c)        (lambda (x y z) (tri@ x y z f g h c)))))
+    ((x y z f c)  (c (f x) (f y) (f z)))
+    ((f c)        (lambda (x y z) (tri@ x y z f c)))))
 
 ;;