wl

commit 4daa94954d15e88d1dc9db0a639cca1b47676cd0
parent 2ca9f6ae98d8895cebd078f4440078dd434d6a33
Author: tomas <tomas@logand.com>
Date:   Sun, 18 Oct 2009 12:11:23 +0200

cons2 instead of cons., misc fold fns

Diffstat:
M
java.wl
 | 
101
+++++++++++++++++++++++++++++++++++++++++--------------------------------------
M
wl.java
 | 
2
+-

2 files changed, 53 insertions(+), 50 deletions(-)
diff --git a/java.wl b/java.wl
@@ -9,25 +9,11 @@
 (de cdar (L) (cdr (car L)))
 (de cddr (L) (cdr (cdr L)))
 
-(de caaar (L) (car (car (car L))))
-(de caadr (L) (car (car (cdr L))))
-(de cadar (L) (car (cdr (car L))))
-(de caddr (L) (car (cdr (cdr L))))
-(de cdaar (L) (cdr (car (car L))))
-(de cdadr (L) (cdr (car (cdr L))))
-(de cddar (L) (cdr (cdr (car L))))
-(de cdddr (L) (cdr (cdr (cdr L))))
-
-(de cadddr (L) (car (cdr (cdr (cdr L)))))
-(de cddddr (L) (cdr (cdr (cdr (cdr L)))))
-
 (de not (X) (== NIL X))
 (de bool (X) (not (not X)))
 (de =T (X) (== T X))
 (de nT (X) (not (== T X)))
 
-(de atom (X) (not (pair X)))
-
 (de rest () (cdr *Args))
 (de args () (bool (cdr *Args)))
 (de next ()
@@ -162,41 +148,40 @@
             (up. X Y) ) ) ) )
 
 (de identity (X) X)
-(de foldl (F A L) (ifn (pair L) A (foldl F (F A (car L)) (cdr L))))
+#(de foldl (F A L) (ifn (pair L) A (foldl F (F A (car L)) (cdr L))))
+(de foldl (F A L)
+   (loop
+      (NIL (pair L) A)
+      (setq A (F A (car L)) L (cdr L)) ) )
+(de foldlx (F A L)
+   (let (M (cons2 NIL A) N M)
+      (loop
+         (NIL (pair L) (cdr M))
+         (con N (F N L))
+         (when (pair (cdr N))
+            (setq N (cdr N)) ) # TODO @
+         (setq L (cdr L)) ) ) )
 (de foldr (F E L) (ifn (pair L) E (F (car L) (foldr F E (cdr L)))))
 (de foldl1 (F L) (foldl F (pop 'L) L))
 (de foldr1 (F L) (foldr F (pop 'L) L))
-#(de unfold (P F G X) (if (P X) NIL (cons. (F X) (unfold P F G (G X)))))
-(de unfold (P F G X A) (if (P X) A (unfold P F G (G X) (cons. (F X) A))))
-(de hylo (P F G E H X) (if (P X) E (hylo P F G (H (F X) E) H (G X))))
-(de constantly (X) (list NIL (cons. 'quote X)))
+(de unfoldl (P F G X A) (if (P X) A (unfoldl P F G (G X) (cons2 (F X) A)))) # TODO loop
+(de unfoldr (P F G X E) (if (P X) E (cons2 (F X) (unfoldr P F G (G X)))))
+(de hylo (P F G E H X) (if (P X) E (hylo P F G (H (F X) E) H (G X)))) # TODO loop
+(de constantly (X) (list NIL (cons2 'quote X)))
+#(de fmap (FF L) (foldr '((X Y) (cons2 (FF X) Y)) NIL L))
+(de fmap (FF L) (foldlx '((X Y) (cons2 (FF (car Y)))) NIL L))
+(de o @ (list (list 'X) (foldr '((FFF X) (list FFF X)) 'X (rest))))
+(de oq L (list (list 'X) (foldr '((FFF X) (list FFF X)) 'X L)))
+
+(def 'atom (oq not pair))
 
-(de filter (P L) (foldr '((X Y) (if (P X) (cons. X Y) Y)) NIL L)) # TODO use foldl
+#(de filter (P L) (foldr '((X Y) (if (P X) (cons2 X Y) Y)) NIL L))
+(de filter (P L) (foldlx '((X Y) (when (P (car Y)) (cons2 (car Y)))) NIL L))
 
-(de need (N L S) (unfold =0 (constantly S) 1- N)) # TODO L, -N
+(de need (N L S) (unfoldl =0 (constantly S) 1- N)) # TODO L, -N
 
-# TODO fix cons (cons '(1 2) 3 '(4 5 6))
 (de cons @
-   (cdr
-      (foldl '((X Y)
-               (ifn X
-                  (let Z (cons. NIL Y) (set Z Z))
-                  (con (car X) (cons. (cdar X) Y))
-                  (set X (cdar X))
-                  X ) )
-         NIL (rest) ) ) )
-
-# (de foldlx (FF L)
-#    (cdr
-#       (foldl '((X Y)
-#                (ifn X
-#                   (let Z (cons. NIL Y) (set Z Z))
-#                   (con (car X) (FF (cdar X) Y))
-#                   (set X (cdar X))
-#                   X ) )
-#          NIL (rest) ) ) )
-
-# (de cons @ (foldlx '((X Y) (if (atom Y) (cons. X Y) (cons. X (cons. Y)))) (rest)))
+   (foldlx '((X Y) (if (pair (cdr Y)) (cons2 (car Y) (cdr Y)) (car Y))) NIL (rest)) )
 
 (de and L
    (loop
@@ -238,7 +223,7 @@
 
 (de length (L) (foldl 1+ 0 L)) # TODO other cases
 
-(de reverse (L) (foldl '((X Y) (cons Y X)) NIL L))
+(de reverse (L) (foldl '((X Y) (cons2 Y X)) NIL L))
 
 (de member (I L)
    (let X L
@@ -284,9 +269,9 @@
    (pass prin)
    (prin "^J") )
 
-(de * @ (when (args) (foldl '((X Y) (X 'multiply Y)) 1 (rest))))
-(de / @ (when (args) (foldl '((X Y) (X 'divide Y)) 1 (rest))))
-(de % @ (when (args) (foldl '((X Y) (X 'remainder Y)) 1 (rest))))
+(de * @ (when (args) (foldl1 '((X Y) (X 'multiply Y)) (rest))))
+(de / @ (when (args) (foldl1 '((X Y) (X 'divide Y)) (rest))))
+(de % @ (when (args) (foldl1 '((X Y) (X 'remainder Y)) (rest))))
 (de - @
    (when (args)
       (let A (rest)
@@ -323,8 +308,9 @@
             (- (jnum (R 'totalMemory)) (jnum (R 'freeMemory))) )
          `(* 1024 1024) ) ) )
 
-(def 'true (jfield (jclass 'java.lang.Boolean) 'TRUE))
-(def 'false (jfield (jclass 'java.lang.Boolean) 'FALSE))
+(let C (jclass 'java.lang.Boolean)
+   (def 'true (jfield C 'TRUE))
+   (def 'false (jfield C 'FALSE)) )
 (def 'null (gc))
 
 # mapping
@@ -415,7 +401,7 @@
             (link (apply F A)) ) ) ) )
 
 (de maps (F S . @)
-   (apply mapc (cons (getl S) (rest)) F) )
+   (apply mapc (cons2 (getl S) (rest)) F) )
 
 (de in (F . P)
    (let *In (jnew `(jclass 'wl$In) (jnew `(jclass 'java.io.FileInputStream) F))
@@ -434,3 +420,20 @@
          (finally ()
             (while (read)
                (eval @ 1) ) ) ) ) )
+
+(de recur recurse (run (cdr recurse)))
+
+(def 'caaar (oq car car car))
+(def 'caadr (oq car car cdr))
+(def 'cadar (oq car cdr car))
+(def 'caddr (oq car cdr cdr))
+(def 'cdaar (oq cdr car car))
+(def 'cdadr (oq cdr car cdr))
+(def 'cddar (oq cdr cdr car))
+(def 'cdddr (oq cdr cdr cdr))
+
+(def 'cadddr (oq car cdr cdr cdr))
+(def 'cddddr (oq cdr cdr cdr cdr))
+
+(de even (N) (= (% N 2) 0))
+(def 'odd (oq not even))
diff --git a/wl.java b/wl.java
@@ -712,7 +712,7 @@ class wl implements Runnable {
             else err(E, "Don't know how to val");
             return Z;
         }});
-        fn("cons.", new Fn() {public Any fn(Any E) {
+        fn("cons2", new Fn() {public Any fn(Any E) {
             Any X = E.cdr();
             return mkCons(eval(X.car()), eval(X.cdr().car()));
         }});