Various changes to the APS code

9 files changed, 114 insertions, 101 deletions

diff --git a/scheme/Makefile b/scheme/Makefile
index 9e383cf..8f1ea10 100644
--- a/scheme/Makefile
+++ b/scheme/Makefile
@@ -4,5 +4,5 @@ upload:
 	scp aps.zip micheles@merlin.phyast.pitt.edu:public_html/scheme
 experimental.zip:
 	zip -r experimental experimental/mod?.sls experimental/use-mod?.ss \
-        experimental/static-map.sls
+        experimental/static-map.sls experimental/static-map/dummy-ctxt.slsx
 	scp experimental.zip micheles@merlin.phyast.pitt.edu:public_html/scheme
diff --git a/scheme/aps/lang.sls b/scheme/aps/lang.sls
index 6b41198..369ba61 100644
--- a/scheme/aps/lang.sls
+++ b/scheme/aps/lang.sls
@@ -1,10 +1,12 @@
 #!r6rs
 (library (aps lang)
-(export literal-replace : unbound? raw-identifier=? raw-id=?
-        identifier-append identifier-prepend
-        get-name-from-define let1)
+(export literal-replace : empty-ctxt unbound? symbol-identifier=? inject
+        identifier-append identifier-prepend ct-eval get-name-from-define let1)
 (import (rnrs) (sweet-macros))
 
+(def-syntax (inject ctxt (pat val) ... templ)
+  #'(with-syntax ((pat (datum->syntax ctxt val)) ...) templ))
+
 ;;LET1
 (def-syntax let1
   (syntax-match ()
@@ -24,20 +26,18 @@
     ))
 ;;END
 
-;;RAW-IDENTIFIER=?
-(define (raw-identifier=? raw id)
-  (symbol=? raw (syntax->datum id)))
-;;END
-
-;;RAW-ID=?
-(define (raw-id=? raw-id x)
-    (and (identifier? x) (raw-identifier=? raw-id x)))
+;;SYMBOL-IDENTIFIER=?
+(define (symbol-identifier=? id1 id2)
+  (symbol=? (syntax->datum id1) (syntax->datum id2)))
 ;;END
 
 ;;UNBOUND?
+(define empty-ctxt
+  (generate-temporaries '(empty-ctxt)))
+
 (define (unbound? id)
-  (define unbound-id (datum->syntax #'dummy-ctxt (syntax->datum id)))
-  (free-identifier=? id  unbound-id))
+  (define stripped-id (datum->syntax #'empty-ctxt (syntax->datum id)))
+  (free-identifier=? id  stripped-id))
 ;;END
 
 ;;LITERAL-REPLACE
@@ -65,6 +65,10 @@
     ))
 ;;END
 
+;;CT-EVAL;; probably useless having inject
+(define (ct-eval form ctxt)
+  (lambda (x) (datum->syntax ctxt (syntax->datum form))))
+;;END
 
 ;;GET-NAME-FROM-DEFINE
 (define get-name-from-define
diff --git a/scheme/aps/list-match.sls b/scheme/aps/list-match.sls
index 94ba577..6d7f366 100644
--- a/scheme/aps/list-match.sls
+++ b/scheme/aps/list-match.sls
@@ -9,7 +9,7 @@
       (cond
        ((_match obj pattern (list template) guard ...) => car) ...
        (else (error 'list-match "pattern failure" obj))))
-  (for-all (cut raw-id=? 'sub <>) #'(sub ...)))
+  (for-all (cut symbol-identifier=? #'sub <>) #'(sub ...)))
 
 (def-syntax _match
   (syntax-match (quote quasiquote)
@@ -19,7 +19,7 @@
        #'(and (null? obj) guard? template))
       (sub (_match obj underscore template guard?)
         #'(and guard? template)
-        (raw-id=? #'_ #'underscore))
+        (symbol-identifier=? #'_ #'underscore))
       (sub (_match obj var template guard?)
         #'(let ((var obj)) (and guard? template))
         (identifier? #'var))
diff --git a/scheme/aps/list-utils.sls b/scheme/aps/list-utils.sls
index 95b351f..b6b5714 100644
--- a/scheme/aps/list-utils.sls
+++ b/scheme/aps/list-utils.sls
@@ -1,7 +1,8 @@
 #!r6rs
 (library (aps list-utils)
 (export range enumerate zip transpose distinct? let+ perm list-of-aux list-for
-        remove-dupl append-unique fold flatten list-of normalize symbol-table)
+        remove-dupl append-unique deep-map deep-fold fold
+        flatten list-of normalize symbol-table)
 (import (rnrs) (sweet-macros) (aps cut) (for (aps lang) expand))
 
 ;;; macros
@@ -29,6 +30,22 @@
     ))
 ;;END
 
+;;DEEP-MAP
+(define (deep-map f lst)
+  (map (lambda (x)
+         (if (and (list? x) (not (eq? 'quote (car x))))
+             (deep-map f x)
+             (f x))) lst))
+;;END
+
+;;DEEP-FOLD
+(define (deep-fold f seed lst);; this is flattening the structure
+  (fold-right
+   (lambda (x a)
+     (if (and (list? x) (not (eq? 'quote (car x))))
+         (deep-fold f a x) (f x a))) seed lst))
+;;END
+
 ;;LIST-OF
 
 (def-syntax list-of-aux
diff --git a/scheme/aps/loop.sls b/scheme/aps/loop.sls
new file mode 100644
index 0000000..beea182
--- /dev/null
+++ b/scheme/aps/loop.sls
@@ -0,0 +1,47 @@
+(library (aps loop)
+(export let/cc loop for)
+(import (rnrs) (sweet-macros))
+
+(def-syntax (let/cc name body body* ...)
+  #'(call-with-current-continuation (lambda (name) body body* ...)))
+
+(def-syntax loop
+  (syntax-match (start end do next)
+    (sub (loop (start (i i0) ...) (end cond? result)
+               expr (next incr-i ...))
+         #`(let/cc #,(datum->syntax #'loop 'break)
+             (let loop* ((i i0) ...)
+               (let/cc #,(datum->syntax #'loop 'continue)
+                  (cond (cond? result) (else expr (loop* incr-i ...))))))
+         (= (length #'(i ...)) (length #'(incr-i ...)))
+         (syntax-violation 'loop "Mismatch loop variables/next variables"
+                           #'((i ...) (incr-i ...))))
+    (sub (loop (start (i i0) ...) expr (next incr-i ...))
+         #'(loop (start (i i0) ...) (end #f (void))
+                 expr (next incr-i ...)))
+    (sub (loop expr)
+         #'(loop (start) expr (next)))))
+
+(def-syntax (for (i ...) (i0 ...) body body* ...)
+  (let ((len1 (length #'(i ...))) (len2 (length #'(i0 ...))))
+  (if (not (= len1 len2))
+      (syntax-violation 'loop "Mismatch loop variables/init values"
+                        #'((i ...) (i0 ...)) (list len1 len2))
+  #`(let/cc #,(datum->syntax #'for 'break)
+      (let #,(datum->syntax #'for 'loop) ((i i0) ...)
+           body body* ...)))))
+
+;; ; include yield
+;; (def-syntax (generator body body* ...)
+;;   (let yield
+;;       body body* ...))
+
+;; (define (generator-zip . generators)
+;;   (generator ;; while not stop-iteration
+;;    (yield (list-of (g) (g in generators)))))
+
+;; (define (for action . generators)
+;;   (define generator (apply generator-zip generators))
+;;   (loop (from (value (generator))) (eqn? value stop-iteration)
+;;    (do (apply action value)) ((generator))))
+)
diff --git a/scheme/aps/string-utils.sls b/scheme/aps/string-utils.sls
index 0d6b8c0..4b6febb 100644
--- a/scheme/aps/string-utils.sls
+++ b/scheme/aps/string-utils.sls
@@ -1,6 +1,27 @@
+#!r6rs
 (library (aps string-utils)
-(export string-split)
-(import (rnrs) (aps compat))
+(export string-split drop1 collect-symbols-starting-with
+        replace-with-commas)
+(import (rnrs) (aps compat) (aps list-utils))
+
+(define (string-cdr s)
+  (list->string (cdr (string->list s))))
+
+(define (drop1 s);; drop the first character from a symbol
+  (string->symbol (list->string (cdr (string->list (symbol->string s))))))
+
+(define (collect-symbols-starting-with char lst)
+  (remove-dupl symbol=?
+   (deep-fold
+    (lambda (x a)
+      (if (and (symbol? x) (char=? char (string-ref (symbol->string x) 0)))
+          (cons x a) a)) '() lst)))
+
+(define (replace-with-commas char lst)
+  (deep-map
+   (lambda (x)
+     (if (and (symbol? x) (char=? char (string-ref (symbol->string x) 0)))
+         (list 'unquote x) x)) lst))
 
 ;;STRING-SPLIT
 ;; adapted from http://schemecookbook.org/Cookbook/StringSplit
diff --git a/scheme/easy-test.sls b/scheme/easy-test.sls
deleted file mode 100644
index 8364909..0000000
--- a/scheme/easy-test.sls
+++ /dev/null
@@ -1,46 +0,0 @@
-(library (easy-test)
-(export test run-tests runner run print-nothing print-dot print-msg)
-(import (rnrs) (only (ikarus) printf) (sweet-macros))
-
-;; test macro
-(def-syntax (test description expr expected)
-  #'(lambda (cmd)
-      (case cmd
-        ((descr) description)
-        ((values) '(expr  expected))
-        ((run) (equal? expr expected))
-        (else (error 'test "Invalid command" cmd)))))
-
-;; three helper functions
-(define (print-nothing descr expr expected)
-  (display ""))
-
-(define (print-dot descr expr expected)
-  (display "."))
-
-(define (print-msg descr expr expected)
-  (printf "\n'~a' failed. Expected ~a, got ~a\n" descr expected expr))
-
-;; full runner
-(define (run-tests print-success print-failure . tests)
-  (let loop ((tests tests) (success 0) (failure 0))
-    (if (null? tests)
-        (list success failure)
-        (let* ((test1 (car tests))
-               (descr (test1 'descr)) (vals (test1 'values)))
-          (if (test1 'run)
-              (begin; the test succeeded
-                (apply print-success descr vals)
-                (loop (cdr tests) (+ 1 success) failure))
-              (begin; the test failed
-                (apply print-failure descr vals)
-                (loop (cdr tests) success (+ 1 failure))))))))
-
-;; runner factory
-(define (runner print-success print-failure)
-  (lambda tests (apply run-tests print-success print-failure tests)))
-
-;; default runner
-(define run (runner print-dot print-msg))
-
-)
diff --git a/scheme/experimental/dummy-ctxt.sls b/scheme/experimental/dummy-ctxt.sls
new file mode 100644
index 0000000..05c2302
--- /dev/null
+++ b/scheme/experimental/dummy-ctxt.sls
@@ -0,0 +1,6 @@
+#!r6rs
+(library (experimental dummy-ctxt)
+ (export dummy-ctxt)
+ (import (only (rnrs) define syntax))
+ (define dummy-ctxt #'here)
+ )
diff --git a/scheme/loop.sls b/scheme/loop.sls
deleted file mode 100644
index 7ff06f0..0000000
--- a/scheme/loop.sls
+++ /dev/null
@@ -1,36 +0,0 @@
-(import (rnrs) (sweet-macros))
-
-(def-syntax (let/cc name body body* ...)
-  #'(call-with-current-continuation (lambda (name) body body* ...)))
-
-(def-syntax loop
-  (syntax-match (start end do next)
-    (sub (loop (start (i i0) ...) (end cond? result)
-               (do body body* ...) (next incr-i ...))
-         #`(let/cc #,(datum->syntax #'loop 'break)
-             (let loop* ((i i0) ...)
-               (let/cc #,(datum->syntax #'loop 'continue)
-                  body body* ...
-                  (if cond? result (loop* incr-i ...)))))
-         (= (length #'(i ...)) (length #'(incr-i ...)))
-         (syntax-violation 'loop "Mismatch loop variables/next variables"
-                           #'((i ...) (incr-i ...))))
-    (sub (loop (start (i i0) ...) (do body body* ...) (next incr-i ...))
-         #'(loop (start (i i0) ...) (end #f (void))
-                 (do body body* ...) (next incr-i ...)))
-    (sub (loop (do body body* ...))
-         #'(loop (start) (do body body* ...) (next)))))
-
-; include yield
-;(def-syntax (generator body body* ...)
-;  (let yield
-;      body body* ...))
-
-(define (generator-zip . generators)
-  (generator ;; while not stop-iteration
-   (yield (list-of (g) (g in generators)))))
-
-(define (for action . generators)
-  (define generator (apply generator-zip generators))
-  (loop (from (value (generator))) (eqn? value stop-iteration)
-   (do (apply action value)) ((generator))))