java.wl (13775B)
1 # -*- picolisp -*- 2 3 # *In *Out *Args 4 5 (def 'de. '(L (def (pop 'L) L))) 6 7 (de caar (L) (car (car L))) 8 (de cadr (L) (car (cdr L))) 9 (de cdar (L) (cdr (car L))) 10 (de cddr (L) (cdr (cdr L))) 11 12 (de not (X) (== NIL X)) 13 (de bool (X) (not (not X))) 14 (de =T (X) (== T X)) 15 (de nT (X) (not (== T X))) 16 17 (de rest () (cdr *Args)) 18 (de args () (bool (cdr *Args))) 19 (de next () 20 (set *Args (cadr *Args)) 21 (con *Args (cddr *Args)) 22 (car *Args) ) 23 24 (de list @ (rest)) 25 26 (de nil P (run P 1) NIL) 27 (de t P (run P 1) T) 28 29 (de if. (C . L) 30 (loop 31 (T C (up. '@ @) (eval (car L) 1)) 32 (T T (run (cdr L) 1)) ) ) 33 34 # (de up L 35 # (let C (pop 'L) 36 # (print C L *Stk *Env) 37 # (if (sym? C) 38 # (up. 2 C (eval (car L) 1)) 39 # (up. (+ 1 (eval C 1)) (pop 'L) (eval (car L) 1)) ) 40 # (print C L *Stk *Env) 41 # ) ) 42 43 (de ifn (C . L) 44 (loop 45 (NIL C (eval (pop 'L) 1)) 46 (T T (up @ C) (run (cdr L) 1)) ) ) 47 48 (de if2 (C D . L) 49 (loop 50 (T (and C D) (up @ @) (eval (pop 'L) 1)) 51 (pop 'L) 52 (T C (up @ @) (eval (pop 'L) 1)) 53 (pop 'L) 54 (T D (up @ @) (eval (pop 'L) 1)) 55 (pop 'L) 56 (T T (run L 1)) ) ) 57 58 (de cond L 59 (use X 60 (loop 61 (NIL L) 62 (setq X (pop 'L)) 63 (T (eval (car X) 1) (up @ @) (run (cdr X) 1)) ) ) ) 64 65 (de nond L 66 (use X 67 (loop 68 (NIL L) 69 (setq X (pop 'L)) 70 (NIL (eval (car X) 1) (run (cdr X) 1)) 71 (up @ @) ) ) ) 72 73 (de case (C . L) 74 (up @ C) 75 (use X 76 (loop 77 (NIL L) 78 (setq X (pop 'L)) 79 (T (if (atom (car X)) 80 (or (=T (car X)) (= C (car X))) 81 (member C (car X)) ) 82 (run (cdr X) 1)) ) ) ) 83 84 (de prog P (run P 1)) 85 (de prog1 (E . P) (up @ E) (run P 1) E) 86 (de prog2 (E F . P) (up @ F) (run P 1) F) 87 88 (de when (C . P) 89 (loop 90 (T C (up @ @) (run P 1)) 91 (T T) ) ) 92 93 (de unless (C . P) 94 (loop 95 (NIL C (run P 1)) 96 (T T) ) ) 97 98 (de as (C . L) (when C L)) 99 100 (de while L 101 (let (C (pop 'L) Z) 102 (loop 103 (NIL (eval C 1) Z) 104 (up @ @) 105 (def 'Z (run L 1)) ) ) ) 106 107 (de until L 108 (let (C (pop 'L) Z) 109 (loop 110 (T (eval C 1) Z) 111 (def 'Z (run L 1)) ) ) ) 112 113 (de setq L 114 (let (V NIL K) 115 (while L 116 (def 'K (pop 'L)) 117 (def 'V (eval (pop 'L) 1)) 118 (up. K V) ) 119 V ) ) 120 121 (de on L 122 (while L 123 (up. (pop 'L) T) ) ) 124 125 (de off L 126 (while L 127 (up. (pop 'L) NIL) ) ) 128 129 (de onOff L 130 (use X 131 (while L 132 (setq X (pop 'L)) 133 (up. X (not (val X))) ) ) ) 134 135 (de zero L 136 (while L 137 (up. (pop 'L) 0) ) ) 138 139 (de one L 140 (while L 141 (up. (pop 'L) 1) ) ) 142 143 (de default L # L collide 144 (use (X Y) 145 (while L 146 (setq X (pop 'L) Y (eval (pop 'L) 1)) 147 (unless (val X) 148 (up. X Y) ) ) ) ) 149 150 (de identity (X) X) 151 #(de foldl (F A L) (ifn (pair L) A (foldl F (F A (car L)) (cdr L)))) 152 (de foldl (F A L) 153 (loop 154 (NIL (pair L) A) 155 (setq A (F A (car L)) L (cdr L)) ) ) 156 (de foldlx (F A L) 157 (let (M (cons2 NIL A) N M) 158 (loop 159 (NIL (pair L) (cdr M)) 160 (con N (F N L)) 161 (when (pair (cdr N)) 162 (setq N (cdr N)) ) # TODO @ 163 (setq L (cdr L)) ) ) ) 164 (de foldr (F E L) (ifn (pair L) E (F (car L) (foldr F E (cdr L))))) # TODO loop 165 (de foldl1 (F L) (foldl F (pop 'L) L)) 166 (de foldr1 (F L) (foldr F (pop 'L) L)) 167 (de unfoldl (P F G X A) (if (P X) A (unfoldl P F G (G X) (cons2 (F X) A)))) # TODO loop 168 (de unfoldr (P F G X E) (if (P X) E (cons2 (F X) (unfoldr P F G (G X))))) # TODO loop 169 (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 170 (de constantly (X) (list NIL (cons2 'quote X))) 171 (de fmap (F L) (foldlx '((X Y) (cons2 ((up F 2) (car Y)))) NIL L)) # TODO use up 172 (de o @ (list (list 'X) (foldr '((F X) (list F X)) 'X (rest)))) 173 (de oq L (list (list 'X) (foldr '((F X) (list F X)) 'X L))) 174 175 (def 'atom (oq not pair)) 176 177 #(de filter (P L) (foldr '((X Y) (if (P X) (cons2 X Y) Y)) NIL L)) 178 (de filter (P L) (foldlx '((X Y) (when (P (car Y)) (cons2 (car Y)))) NIL L)) 179 180 (de need (N L S) (unfoldl =0 (constantly S) 1- N)) # TODO L, -N 181 182 (de cons @ 183 (cons2 (next) 184 (foldlx '((X Y) (if (pair (cdr Y)) (cons2 (car Y) (cdr Y)) (car Y))) 185 NIL (rest) ) ) ) 186 187 (de and L 188 (loop 189 (NIL (eval (pop 'L) 1)) 190 (up @ @) 191 (NIL (pair L) @) ) ) 192 193 (de or L 194 (loop 195 (T (eval (pop 'L) 1) @) 196 (up @ @) 197 (NIL (pair L)) ) ) 198 199 (de nand L 200 (loop 201 (NIL (eval (pop 'L) 1) T) 202 (up @ @) 203 (NIL (pair L)) ) ) 204 205 (de nor L 206 (loop 207 (T (eval (pop 'L) 1)) 208 (up @ @) 209 (NIL (pair L) T) ) ) 210 211 (de xor (X Y) 212 (if X 213 (and (not Y) T) 214 (and Y T) ) ) 215 216 # (de let? L 217 # (let (K (pop 'L) V (eval (pop 'L) 1)) 218 # (when V 219 # (def 'K V) 220 # (run L 1 '(K)) ) ) ) # TODO 221 222 (de 1+ (X) (+ 1 X)) 223 (de 1- (X) (- X 1)) 224 225 (de length (L) (foldl 1+ 0 L)) # TODO other cases 226 227 (de reverse (L) (foldl '((X Y) (cons2 Y X)) NIL L)) 228 229 (de member (I L) 230 (let X L 231 (loop 232 (T (atom L) (and (= I L) L)) 233 (T (= I (car L)) L) 234 (T (== X (setq L (cdr L)))) ) ) ) 235 236 (de memq (I L) 237 (let X L 238 (loop 239 (T (atom L) (and (== I L) L)) 240 (T (== I (car L)) L) 241 (T (== X (setq L (cdr L)))) ) ) ) 242 243 (de full (L) 244 (not (memq NIL L)) ) 245 246 (de assoc (I L) 247 (loop 248 (NIL L) 249 (T (= I (caar L)) (car L)) 250 (pop 'L) ) ) 251 252 (de asoq (I L) 253 (loop 254 (NIL L) 255 (T (== I (caar L)) (car L)) 256 (pop 'L) ) ) 257 258 (de fin (X) 259 (loop 260 (NIL (pair X) X) 261 (pop 'X) ) ) 262 263 (de last (L) (foldl1 '((X Y) Y) L)) 264 265 (de println @ 266 (prog1 (pass print) 267 (prin "^J") ) ) 268 269 (de prinl @ 270 (prog1 (pass prin) 271 (prin "^J") ) ) 272 273 (de * @ (when (args) (foldl1 '((X Y) (X 'multiply Y)) (rest)))) 274 (de / @ (when (args) (foldl1 '((X Y) (X 'divide Y)) (rest)))) 275 (de % @ (when (args) (foldl1 '((X Y) (X 'remainder Y)) (rest)))) 276 (de -. @ 277 (when (args) 278 (let A (rest) 279 (if (pair (cdr A)) 280 (foldl1 '((X Y) (X 'subtract Y)) (rest)) 281 (0 'subtract (car A)) ) ) ) ) 282 (de +. @ (when (args) (- (pass - 0)))) 283 284 (de & @ (when (args) (foldl1 '((X Y) (X 'and Y)) (rest)))) 285 (de | @ (when (args) (foldl1 '((X Y) (X 'or Y)) (rest)))) 286 (de x| @ (when (args) (foldl1 '((X Y) (X 'xor Y)) (rest)))) 287 288 (de >> (N X) 289 (if (gt0 N) 290 (X 'shiftRight N) 291 (X 'shiftLeft (abs N)) ) ) 292 293 (de max @ (foldl1 '((X Y) (if (> X Y) X Y)) (rest))) # TODO > 294 (de min @ (foldl1 '((X Y) (if (< X Y) X Y)) (rest))) # TODO < 295 296 (de =0 (N) (when (= 0 N) N)) 297 (de n0 (N) (not (=0 N))) 298 299 (de jclass (N) (java.lang.Class 'forName N)) 300 301 (de gc () (`((jclass 'java.lang.Runtime) 'getRuntime) 'gc)) 302 303 (de import L 304 (let (P (pop 'L) C) 305 (while L 306 (setq C (pop 'L)) 307 (def C (jclass (pack P "." C))) ) ) ) 308 309 (de jnum (X) 310 (jnew `(jclass 'java.math.BigInteger) (X 'toString)) ) 311 312 (de heap @ 313 (let R `((jclass 'java.lang.Runtime) 'getRuntime) 314 (/ (if (args) 315 (if (=T (next)) 316 (jnum (R 'freeMemory)) 317 (jnum (R 'maxMemory)) ) 318 (- (jnum (R 'totalMemory)) (jnum (R 'freeMemory))) ) 319 `(* 1024 1024) ) ) ) 320 321 (let C (jclass 'java.lang.Boolean) 322 (def 'true (jfield C 'TRUE)) 323 (def 'false (jfield C 'FALSE)) ) 324 (def 'null (gc)) 325 326 # mapping 327 # 328 # | | last | link | chain | 329 # |----------+------+---------+--------| 330 # | car | mapc | mapcar | mapcan | 331 # | cdr | map | maplist | mapcon | 332 # | car prop | maps | - | - | 333 334 (de needLength (L) (foldl '((X Y) (cons NIL X)) NIL L)) 335 336 (de map (F . @) 337 (let (L (rest) M NIL A (needLength L) B NIL E) 338 (loop 339 (setq M L B A E T) 340 (while M 341 (setq E (and E (atom (car M)))) 342 (set B (car M)) 343 (pop M) 344 (pop 'M) 345 (pop 'B) ) 346 (T E) 347 (apply F A) ) ) ) 348 349 (de mapc (F . @) 350 (let (L (rest) M NIL A (needLength L) B NIL E) 351 (loop 352 (setq M L B A E T) 353 (while M 354 (setq E (and E (atom (car M)))) 355 (set B (pop M)) 356 (pop 'M) 357 (pop 'B) ) 358 (T E) 359 (apply F A) ) ) ) 360 361 (de mapcan (F . @) 362 (let (L (rest) M NIL A (needLength L) B NIL E) 363 (make 364 (loop 365 (setq M L B A E T) 366 (while M 367 (setq E (and E (atom (car M)))) 368 (set B (pop M)) 369 (pop 'M) 370 (pop 'B) ) 371 (T E) 372 (chain (apply F A)) ) ) ) ) 373 374 (de mapcar (F . @) 375 (let (L (rest) M NIL A (needLength L) B NIL E) 376 (make 377 (loop 378 (setq M L B A E T) 379 (while M 380 (setq E (and E (atom (car M)))) 381 (set B (pop M)) 382 (pop 'M) 383 (pop 'B) ) 384 (T E) 385 (link (apply F A)) ) ) ) ) 386 387 (de mapcon (F . @) 388 (let (L (rest) M NIL A (needLength L) B NIL E) 389 (make 390 (loop 391 (setq M L B A E T) 392 (while M 393 (setq E (and E (atom (car M)))) 394 (set B (car M)) 395 (pop M) 396 (pop 'M) 397 (pop 'B) ) 398 (T E) 399 (chain (apply F A)) ) ) ) ) 400 401 (de maplist (F . @) 402 (let (L (rest) M NIL A (needLength L) B NIL E) 403 (make 404 (loop 405 (setq M L B A E T) 406 (while M 407 (setq E (and E (atom (car M)))) 408 (set B (car M)) 409 (pop M) 410 (pop 'M) 411 (pop 'B) ) 412 (T E) 413 (link (apply F A)) ) ) ) ) 414 415 (de maps (F S . @) 416 (apply mapc (cons2 (getl S) (rest)) F) ) 417 418 (de in (F . P) 419 (let *In (jnew `(jclass 'wl$In) (jnew `(jclass 'java.io.FileInputStream) F)) 420 (finally (*In 'close) 421 (run P 1 '(*In)) ) ) ) # TODO 422 423 (de out (F . P) 424 (let *Out (jnew `(jclass 'java.io.PrintStream) 425 (jnew `(jclass 'java.io.FileOutputStream) F) ) 426 (finally (*Out 'close) 427 (run P 1 '(*Out)) ) ) ) # TODO 428 429 (de load @ # finally? 430 (while (args) 431 (in (next) 432 (until (eof) 433 (eval (eval (read) 1) 1) ) ) ) ) 434 435 (de recur recurse (run (cdr recurse))) 436 437 (def 'caaar (oq car car car)) 438 (def 'caadr (oq car car cdr)) 439 (def 'cadar (oq car cdr car)) 440 (def 'caddr (oq car cdr cdr)) 441 (def 'cdaar (oq cdr car car)) 442 (def 'cdadr (oq cdr car cdr)) 443 (def 'cddar (oq cdr cdr car)) 444 (def 'cdddr (oq cdr cdr cdr)) 445 446 (def 'cadddr (oq car cdr cdr cdr)) 447 (def 'cddddr (oq cdr cdr cdr cdr)) 448 449 (de even (N) (= (% N 2) 0)) 450 (def 'odd (oq not even)) 451 452 (de lt0 (X) (and (num? X) (< X 0))) 453 (de gt0 (X) (and (num? X) (< 0 X))) 454 (de le0 (X) (and (num? X) (or (< X 0) (= 0 X)))) 455 (de ge0 (X) (and (num? X) (or (< 0 X) (= 0 X)))) 456 457 (de foldln (F A L) 458 (let Z T 459 (loop 460 (NIL (and (pair L) (setq Z (F A (car L)))) Z) 461 (setq A (pop 'L)) ) ) ) 462 (de foldln1 (F L) (foldln F (pop 'L) L)) 463 464 (de > @ (foldln1 '((X Y) (< Y X)) (rest))) 465 (de <= @ (foldln1 '((X Y) (or (< X Y) (= X Y))) (rest))) 466 (de >= @ (foldln1 '((X Y) (or (< Y X) (= X Y))) (rest))) 467 (de <> @ (not (pass =))) 468 469 (de abs (N) (if (lt0 N) (- N) N)) 470 471 (de test (X . P) (println X (run P 1))) 472 473 (de inc (X . @) 474 (if (num? X) 475 (1+ X) 476 (set X (+ (val X) (or (next) 1))) ) ) 477 478 (de dec. (X . @) 479 (if (num? X) 480 (1- X) 481 (set X (- (val X) (or (next) 1))) ) ) 482 483 (de sys (K . @) (`(jclass 'java.lang.System) 'getenv K)) 484 485 #(de exec () (`((jclass 'java.lang.Runtime) 'getRuntime) 'gc)) 486 487 (de jvector @ 488 (let X (jnew `(jclass 'java.util.Vector)) 489 (while (args) 490 (X 'add (next)) ) 491 X ) ) 492 493 (de lit (X) (if (atom X) X (cons 'quote X))) 494 495 (de pwd () (`(jclass 'java.lang.System) 'getProperty "user.dir")) 496 497 #(de jv2l (X) 498 # (let (A (`(jclass 'java.util.Arrays) 'asList X) L (cons) M L) 499 # (unless (jeq true (A 'isEmpty)) 500 # (println A (A 'isEmpty)) 501 # (setq M (con M (cons (A 'remove 0) NIL))) ) 502 # (cdr L) ) ) 503 504 (de dir (X) 505 (filter '((X) (unless (= "." (car (chop X))) X)) 506 (jv2l ((jnew `(jclass 'java.io.File) (or X ".")) 'list)) ) ) 507 508 (de info (X) # TODO proper date & time 509 (let F (jnew `(jclass 'java.io.File) (or X ".")) 510 (and (jeq true (F 'exists)) 511 (cons (or (jeq true (F 'isDirectory)) (jnum (F 'length))) 512 (jnum (F 'lastModified)) 513 (jnum (F 'lastModified)) ) ) ) ) 514 515 (de object (S C . @) 516 (set S C) 517 (while (args) 518 (put S (next) (next)) ) ) 519 520 (de get (S . @) 521 (while (args) 522 (let (K (next) L (getl S) C) 523 (loop 524 (NIL L (unless (args) (or (atom C) (car C)))) 525 (T (and (atom (setq C (pop 'L))) (== K C)) (setq S T)) 526 (T (and (pair C) (== K (cdr C))) (setq S (car C))) ) ) ) ) 527 528 (de prop (S K) # TODO argv 529 (let (L (getl S) C) 530 (loop 531 (NIL L) 532 (T (and (atom (setq C (pop 'L))) (== K C)) C) 533 (T (and (pair C) (== K (cdr C))) C) ) ) ) 534 535 (de put (S K V) # TODO argv 536 (if V 537 (let (L (getl S) C) 538 (loop 539 (NIL L (putl S (cons (cons V K) (getl S)))) 540 (T (and (atom (setq C (car L))) (== K C)) (or (=T V) (set L (cons V K)))) 541 (T (and (pair C) (== K (cdr C))) (if (=T V) (set L K) (set C V))) 542 (setq L (cdr L)) ) ) 543 (putl S (filter '((C) (not (if (atom C) (== K C) (== K (cdr C))))) (getl S))) ) 544 V ) 545 546 (de ; (S . P) 547 (while P 548 (let (K (pop 'P) L (getl S) C) 549 (loop 550 (NIL L (unless P (or (atom C) (car C)))) 551 (T (and (atom (setq C (pop 'L))) (== K C)) (setq S T)) 552 (T (and (pair C) (== K (cdr C))) (setq S (car C))) ) ) ) ) 553 554 (de fibo (N) 555 (if (< N 2) 556 1 557 (+ (fibo (dec N)) (fibo (- N 2))) ) ) 558 #(de ; (S . L) (apply get L S)) 559 #(de : L (apply get L This)) 560 #(de :: (S . L) (apply prop L S)) # ??? 561 562 (de fibo.. (N) 563 (if. (< N 2) 564 1 565 (+. (fibo.. (dec. N)) (fibo.. (-. N 2))) ) ) 566 (de with (This . P) (run P 1 '(This)))