rw.lisp (22186B)
1 ;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw 24 (:use :cl) 25 (:export :*endian* 26 :append-reader 27 :bit-reader 28 :byte-reader 29 :byte-writer 30 :char-reader 31 :char-writer 32 :copy 33 :count-reader 34 :fibonacci-reader 35 :filter-reader 36 :flat-reader 37 :head-reader 38 :line-reader 39 :map-reader 40 :n-reader 41 :next 42 :next-octets 43 :next-u16 44 :next-u16be 45 :next-u16le 46 :next-u24 47 :next-u24be 48 :next-u24le 49 :next-u32 50 :next-u32be 51 :next-u32le 52 :next-u8 53 :next-utf8 54 :next-z0 55 :peek 56 :peek-reader 57 :reader 58 :reduce-reader 59 :search-reader 60 :skip 61 :slurp 62 :tail-reader 63 :till 64 :u16 65 :u16be 66 :u16le 67 :u24 68 :u24be 69 :u24le 70 :u32 71 :u32be 72 :u32le 73 :u8 74 :utf8-reader 75 :wrap-writer 76 :write-octets 77 :write-u16 78 :write-u16be 79 :write-u16le 80 :write-u24 81 :write-u24be 82 :write-u24le 83 :write-u32 84 :write-u32be 85 :write-u32le 86 :write-u8 87 :write-utf8-char 88 :write-utf8-codepoint 89 :write-utf8-string 90 :writer 91 :z0 92 :zip-reader 93 )) 94 95 (in-package :rw) 96 97 (defun next (reader) 98 (funcall reader)) 99 100 (defun peek (reader) 101 (funcall reader 'peek)) 102 103 (defmacro let? (k v &body body) 104 `(let ((,k ,v)) 105 (when ,k ,@body))) 106 107 (defun reader (x) 108 (etypecase x 109 (list (lambda () (pop x))) 110 (vector (let ((i 0) 111 (n (length x))) 112 (lambda () 113 (when (< i n) 114 (prog1 (aref x i) 115 (incf i)))))))) 116 117 (defun char-reader (stream) 118 (lambda () 119 (read-char stream nil nil))) 120 121 (defun byte-reader (stream) 122 (lambda () 123 (read-byte stream nil nil))) 124 125 (defun peek-reader (reader) 126 (let (x) 127 (lambda (&optional msg) 128 (ecase msg 129 (peek (or x (setq x (next reader)))) 130 ((nil) (prog1 (if x x (next reader)) 131 (setq x nil))))))) 132 133 (defun skip (reader &optional n/items) 134 (etypecase n/items 135 (integer 136 (dotimes (i n/items reader) 137 (next reader))) 138 (list 139 (let ((x (or n/items '(#\space #\tab #\return #\newline)))) 140 (loop 141 while (member (peek reader) x) 142 do (next reader))) 143 reader))) 144 145 (defun slurp (reader) ;; TODO use wherever possible 146 (let (x) 147 (loop 148 while (setq x (next reader)) 149 collect x))) 150 151 (defun till-reader (reader test) 152 (lambda () 153 (when (funcall test (peek reader)) 154 (next reader)))) 155 156 (defun till (reader &optional items good) ;; TODO till vs until? 157 (slurp 158 (till-reader reader 159 (if good 160 (lambda (x) (member x items :test #'equal)) 161 (lambda (x) (not (member x items :test #'equal))))))) 162 163 ;;(till (peek-reader (reader '(0 1 2 3 4))) '(3)) 164 ;;(till (peek-reader (reader '(0 1 2 3 4))) '(0 1) t) 165 ;;(till (skip (peek-reader (reader '(0 1 2 3 4))) 1) '(3)) 166 ;;(till (skip (peek-reader (reader #(0 1 2 3 4))) 1) '(3)) 167 ;;(with-open-file (s "/etc/passwd") (till (peek-reader (char-reader s)) '(#\:))) 168 169 (defun make-circular-list (n) 170 (check-type n (and fixnum (satisfies plusp))) 171 (let* ((b (cons nil nil)) 172 (e b)) 173 (dotimes (i (1- n)) 174 (push nil b)) 175 (setf (cdr e) b) 176 b)) 177 178 (defun delayed-reader (reader n) 179 (let ((b (make-circular-list n))) 180 (flet ((next () 181 (prog1 (car b) 182 (setf (car b) (next reader) 183 b (cdr b))))) 184 (dotimes (i n) 185 (next)) 186 #'next))) 187 188 ;;(slurp (delayed-reader (reader '(0 1 2 1 2 3 4 5 6 7 8 9)) 4)) 189 190 (defun %search-reader (reader needle) 191 (let* ((n (length needle)) 192 z 193 found) 194 (lambda () 195 (unless found 196 (let ((c (next reader))) 197 (when c 198 (block here 199 (setq z (loop 200 for i in (cons 0 z) 201 when (eql c (elt needle i)) 202 collect (if (= n (1+ i)) 203 (return-from here (setq found t)) 204 (1+ i)))))) 205 c))))) 206 207 ;;(slurp (%search-reader (reader '(0 1 2 3 4 5 6 7 8 9)) '(a))) 208 ;;(slurp (%search-reader (reader '(0 1 2 3 4 5 6 7 8 9)) '(3 2 5))) 209 ;;(slurp (%search-reader (reader '(0 1 2 1 2 3 4 5 6 7 8 9)) '(1 2 3 4 5))) 210 211 (defun search-reader (reader needle) 212 (let* ((n (length needle)) 213 (b (make-circular-list n)) 214 z 215 found) 216 (flet ((next () 217 (unless found 218 (let ((c (next reader))) 219 (when c 220 (block here 221 (setq z (loop 222 for i in (cons 0 z) 223 when (eql c (elt needle i)) 224 collect (if (= n (1+ i)) 225 (return-from here (setq found t)) 226 (1+ i)))))) 227 (prog1 (car b) 228 (setf (car b) c 229 b (cdr b))))))) 230 (dotimes (i n) 231 (next)) 232 #'next))) 233 234 ;;(slurp (search-reader (reader '(0 1 2 3 4 5 6 7 8 9)) '(a))) 235 ;;(slurp (search-reader (reader '(0 1 2 3 4 5 6 7 8 9)) '(3 2 5))) 236 ;;(slurp (search-reader (reader '(0 1 2 1 2 3 4 5 6 7 8 9)) '(1 2 3 4 5))) 237 238 ;;(with-open-file (s "/etc/passwd") (slurp (search-reader (char-reader s) "user"))) 239 240 #+nil 241 (with-open-file (s "/etc/passwd") 242 (let* ((sentinel "user") 243 (r (search-reader (char-reader s) sentinel))) 244 (list (coerce (till r (list sentinel) nil t) 'string) 245 (coerce (till r '(#\:)) 'string) 246 (coerce (till r (list sentinel) nil t) 'string) 247 (coerce (till r '(#\:)) 'string) 248 (coerce (till r (list sentinel) nil t) 'string) 249 (coerce (till r '(#\:)) 'string) 250 (coerce (till r (list sentinel) nil t) 'string)))) 251 252 (defun next-u8 (reader) 253 (let? x (next reader) 254 (assert (<= 0 x 255)) 255 x)) 256 257 (defparameter *endian* (or (find :little-endian *features*) 258 (find :big-endian *features*))) 259 260 (defun next-u16be (reader) 261 (let? x (next-u8 reader) 262 (let? y (next-u8 reader) 263 (logior (ash x 8) y)))) 264 265 (defun next-u16le (reader) 266 (let? x (next-u8 reader) 267 (let? y (next-u8 reader) 268 (logior (ash y 8) x)))) 269 270 (defun next-u16 (reader) 271 (ecase *endian* 272 (:big-endian (next-u16be reader)) 273 (:little-endian (next-u16le reader)))) 274 275 (defun next-u24be (reader) 276 (let? x (next-u8 reader) 277 (let? y (next-u8 reader) 278 (let? z (next-u8 reader) 279 (logior (ash x 16) (ash y 8) z))))) 280 281 (defun next-u24le (reader) 282 (let? x (next-u8 reader) 283 (let? y (next-u8 reader) 284 (let? z (next-u8 reader) 285 (logior (ash z 16) (ash y 8) x))))) 286 287 (defun next-u24 (reader) 288 (ecase *endian* 289 (:big-endian (next-u24be reader)) 290 (:little-endian (next-u24le reader)))) 291 292 (defun next-u32be (reader) 293 (let? x (next-u16be reader) 294 (let? y (next-u16be reader) 295 (logior (ash x 16) y)))) 296 297 (defun next-u32le (reader) 298 (let? x (next-u16le reader) 299 (let? y (next-u16le reader) 300 (logior (ash y 16) x)))) 301 302 (defun next-u32 (reader) 303 (ecase *endian* 304 (:big-endian (next-u32be reader)) 305 (:little-endian (next-u32le reader)))) 306 307 (defun next-octets (reader n) 308 (let ((z (make-array n 309 :element-type '(unsigned-byte 8) 310 :initial-element 0))) 311 (dotimes (i n z) 312 (let ((x (next-u8 reader))) 313 (if (zerop i) 314 (unless x (return-from next-octets nil)) 315 (assert x)) 316 (setf (aref z i) x))))) 317 318 (defun next-z0 (reader &optional (radix 10)) 319 (let ((x (till reader 320 (ecase radix 321 (2 '(#\0 #\1)) 322 (8 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) 323 (10 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) 324 (16 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 325 #\a #\b #\c #\d #\e #\f 326 #\A #\B #\C #\D #\E #\F))) 327 t))) 328 (when x 329 (parse-integer (coerce x 'string) :radix radix)))) 330 331 (defun next-utf8 (reader) 332 (let ((i1 (next reader)) i2 i3 i4 o2 o3 o4) 333 (macrolet ((wrong () 334 `(error "wrong UTF-8 sequence ~x ~x ~x ~x" i1 i2 i3 i4)) 335 (tail (i o) 336 `(progn 337 (setq ,i (next reader)) 338 (unless (and (typep ,i '(unsigned-byte 8)) 339 (= #x80 (logand #b11000000 ,i))) 340 (wrong)) 341 (setq ,o (logand #b00111111 ,i))))) 342 (cond 343 ((not i1) nil) 344 ((not (typep i1 '(unsigned-byte 8))) 345 (wrong)) 346 ((<= #b00000000 i1 #b01111111) ;; one 347 i1) 348 ((<= #b11000000 i1 #b11011111) ;; two 349 (tail i2 o2) 350 (let ((z (logior (ash (logand #x1f i1) 6) o2))) 351 (unless (<= #x000080 z #x0007ff) 352 (wrong)) 353 z)) 354 ((<= #b11100000 i1 #b11101111) ;; three 355 (tail i2 o2) 356 (tail i3 o3) 357 (let ((z (logior (ash (logand #x0f i1) 12) (ash o2 6) o3))) 358 (unless (or (<= #x000800 z #x00d7ff) 359 (<= #x00e000 z #x00ffff)) 360 (wrong)) 361 z)) 362 ((<= #b11110000 i1 #b11110111) ;; four 363 (tail i2 o2) 364 (tail i3 o3) 365 (tail i4 o4) 366 (let ((z (logior (ash (logand #x07 i1) 18) (ash o2 12) (ash o3 6) o4))) 367 (unless (<= #x010000 z #x10ffff) 368 (wrong)) 369 z)) 370 (t (wrong)))))) 371 372 (defun utf8-reader (octet-reader &key charp) 373 (if charp 374 (lambda () 375 (let ((x (next-utf8 octet-reader))) 376 (when x 377 (code-char x)))) 378 (lambda () 379 (next-utf8 octet-reader)))) 380 381 ;;(till (peek-reader (utf8-reader (reader #(#x24))))) 382 ;;(till (peek-reader (utf8-reader (reader #(#xc2 #xa2))))) 383 ;;(till (peek-reader (utf8-reader (reader #(#xe2 #x82 #xac))))) 384 ;;(till (peek-reader (utf8-reader (reader #(#xf0 #x90 #x8d #x88))))) 385 ;;(till (peek-reader (utf8-reader (reader #(#xc0 #x80))))) ;; overlong 386 387 (defun bit-reader (octet-reader) 388 (let (octet bit) 389 (lambda () 390 (unless octet 391 (setq octet (next octet-reader) 392 bit 7)) 393 (when octet 394 (prog1 (if (logbitp bit octet) 1 0) 395 (if (plusp bit) 396 (decf bit) 397 (setq octet nil))))))) 398 399 ;;(till (peek-reader (bit-reader (reader '(#b10110111 #b01111011))))) 400 401 ;; TODO next-u64|128 402 ;; TODO next-s8|16|32|64|128 403 404 (defun writer (x) 405 (etypecase x 406 ;;(list (lambda () (pop x))) 407 (vector 408 (if (adjustable-array-p x) 409 (lambda (v) (vector-push-extend v x)) 410 (let ((i -1)) 411 (lambda (v) (setf (aref x (incf i)) v))))))) 412 413 (defun char-writer (stream) 414 (lambda (x) 415 (write-char x stream))) 416 417 (defun byte-writer (stream) 418 (lambda (x) 419 (write-byte x stream))) 420 421 (defun write-u8 (writer x) 422 (assert (<= 0 x 255)) 423 (funcall writer x)) 424 425 (defun write-u16be (writer x) 426 (assert (<= 0 x 65535)) 427 (write-u8 writer (ash x -8)) 428 (write-u8 writer (logand #xff x))) 429 430 (defun write-u16le (writer x) 431 (assert (<= 0 x 65535)) 432 (write-u8 writer (logand #xff x)) 433 (write-u8 writer (ash x -8))) 434 435 (defun write-u16 (writer x) 436 (ecase *endian* 437 (:big-endian (write-u16be writer x)) 438 (:little-endian (write-u16le writer x)))) 439 440 (defun write-u24be (writer x) 441 (assert (<= 0 x #.(1- (expt 2 24)))) 442 (write-u8 writer (ash x -16)) 443 (write-u8 writer (logand #xff (ash x -8))) 444 (write-u8 writer (logand #xff x))) 445 446 (defun write-u24le (writer x) 447 (assert (<= 0 x #.(1- (expt 2 24)))) 448 (write-u8 writer (logand #xff x)) 449 (write-u8 writer (logand #xff (ash x -8))) 450 (write-u8 writer (ash x -16))) 451 452 (defun write-u24 (writer x) 453 (ecase *endian* 454 (:big-endian (write-u24be writer x)) 455 (:little-endian (write-u24le writer x)))) 456 457 (defun write-u32be (writer x) 458 (assert (<= 0 x #.(1- (expt 2 32)))) 459 (write-u16be writer (ash x -16)) 460 (write-u16be writer (logand #xffff x))) 461 462 (defun write-u32le (writer x) 463 (assert (<= 0 x #.(1- (expt 2 32)))) 464 (write-u16le writer (logand #xffff x)) 465 (write-u16le writer (ash x -16))) 466 467 (defun write-u32 (writer x) 468 (ecase *endian* 469 (:big-endian (write-u32be writer x)) 470 (:little-endian (write-u32le writer x)))) 471 472 (defun copy (reader writer) 473 (do (x) 474 ((not (setq x (funcall reader)))) 475 (funcall writer x))) 476 477 (defun write-octets (writer x) 478 (etypecase x 479 (stream (copy (byte-reader x) writer)) 480 (list (dolist (i x) (write-u8 writer i))) 481 (vector (dotimes (i (length x)) (write-u8 writer (aref x i)))))) 482 483 ;; TODO write-u64|128 484 ;; TODO write-s8|16|32|64|128 485 486 (defun write-utf8-codepoint (writer x) ;; TODO 487 (cond 488 ((<= 0 x #x7f) 489 (write-u8 writer x)) 490 ((<= #x000080 x #x0007ff) ;; 110xxxxx 10xxxxxx 491 (write-u8 writer (logior #b11000000 (ash x -6))) 492 (write-u8 writer (logior #b10000000 (logand x #b00111111)))) 493 ((or (<= #x000800 x #x00d7ff) ;; 1110xxxx 10xxxxxx 10xxxxxx 494 (<= #x00e000 x #x00ffff)) 495 (write-u8 writer (logior #b11100000 (ash x -12))) 496 (write-u8 writer (logior #b10000000 (logand (ash x -6) #b00111111))) 497 (write-u8 writer (logior #b10000000 (logand x #b00111111)))) 498 ((<= #x010000 x #x10ffff) ;; 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx 499 (write-u8 writer (logior #b11110000 (ash x -18))) 500 (write-u8 writer (logior #b10000000 (logand (ash x -12) #b00111111))) 501 (write-u8 writer (logior #b10000000 (logand (ash x -6) #b00111111))) 502 (write-u8 writer (logior #b10000000 (logand x #b00111111)))) 503 (t (error "wrong utf8 codepoint ~s" x)))) 504 505 ;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x24) (princ-to-string b)) => 24 506 ;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #xa2) (princ-to-string b)) => C2 A2 507 ;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x20ac) (princ-to-string b)) => E2 82 AC 508 ;;(let ((*print-base* 16) (b (make-array 0 :adjustable t :fill-pointer 0))) (write-utf8-codepoint (writer b) #x10348) (princ-to-string b)) => F0 90 8D 88 509 510 (defun write-utf8-char (writer x) 511 (write-utf8-codepoint writer (char-code x))) 512 513 (defun write-utf8-string (writer x) 514 (loop 515 for e across x 516 do (write-utf8-char writer e))) 517 518 (defun line-reader (reader) 519 (let ((r (peek-reader reader))) 520 (lambda () 521 (let ((x (till r '(#\newline)))) 522 (when (next r) 523 (or x :empty-line)))))) 524 525 (defun filter-reader (reader predicate) 526 (labels ((rec () 527 (let ((x (next reader))) 528 (when x 529 (if (funcall predicate x) 530 x 531 (rec)))))) 532 #'rec)) 533 534 (defun fibonacci-reader (n) 535 (let ((i -1) 536 (z1 0) 537 (z2 1)) 538 (lambda () 539 (incf i) 540 (cond 541 ((<= n i) nil) 542 ((< i 2) i) 543 (t (let ((z (+ z1 z2))) 544 (setq z1 z2 545 z2 z))))))) 546 547 ;;(slurp (fibonacci-reader 10)) => 0 1 1 2 3 5 8 13 21 34 548 549 (defun head-reader (reader n) 550 (let ((i 0)) 551 (lambda () 552 (when (< i n) 553 (incf i) 554 (funcall reader))))) 555 556 ;;(slurp (head-reader (reader '(1 2 3 4 5)) 3)) 557 ;;(slurp (head-reader (reader '(1 2 3 4 5)) 7)) 558 559 (defun tail-reader (reader n) 560 (labels ((rec () 561 (cond 562 ((plusp n) 563 (decf n) 564 (funcall reader) 565 (rec)) 566 (t 567 (funcall reader))))) 568 #'rec)) 569 570 ;;(slurp (tail-reader (reader '(1 2 3 4 5)) 3)) 571 ;;(slurp (tail-reader (reader '(1 2 3 4 5)) 7)) 572 573 ;;(next (head-reader (tail-reader (reader '(1 2 3 4 5)) 2) 1)) 574 575 (defun n-reader (reader n) 576 (let ((i 0)) 577 (lambda () 578 (when (< i n) 579 (incf i) 580 (or (funcall reader) 581 (error "only ~s out of ~s items read" (1- i) n)))))) 582 583 ;;(slurp (n-reader (reader '(1 2 3 4 5)) 3)) 584 ;;(slurp (n-reader (reader '(1 2 3 4 5)) 7)) 585 586 (defun map-reader (reader fn) 587 (lambda () 588 (let ((z (next reader))) 589 (when z 590 (funcall fn z))))) 591 592 (defun wrap-writer (writer fn) 593 (lambda (x) 594 (funcall writer (funcall fn x)))) 595 596 (defun flat-reader (reader) 597 (let ((r (list reader))) 598 (labels ((rec () 599 (when r 600 (let ((z (next (car r)))) 601 (cond 602 ((functionp z) 603 (push z r) 604 (rec)) 605 (z) 606 (t 607 (pop r) 608 (rec))))))) 609 #'rec))) 610 611 ;;(disassemble (flat-reader (reader '(1 2 3)))) 612 613 ;;(slurp (flat-reader (reader (list (reader (list 1 2)) (reader (list (reader (list 3 4)) 5)))))) 614 ;;(slurp (flat-reader (reader '(1 2 3)))) 615 616 ;; ? no writers, only readers -> pull bytes in write loop 617 618 ;; flat input octets -> cons tree -> [writer] flat output octets 619 ;; flat input octets -> cons tree -> octet-reader tree -> [writer] flat output octets 620 621 ;; https://rosettacode.org/wiki/Flatten_a_list 622 623 (defun append-reader (readers) 624 (labels ((rec () 625 (when readers 626 (let ((z (next (car readers)))) 627 (cond 628 (z) 629 (t 630 (pop readers) 631 (rec))))))) 632 #'rec)) 633 634 ;;(slurp (append-reader (list (reader "hi") (rw:reader "hello")))) 635 636 (defun ref (reader n) ;; is it useful? 637 (dotimes (i n (next reader)) 638 (next reader))) 639 640 ;;(ref (append-reader (list (reader "hi") (rw:reader "hello"))) 3) 641 642 (defun reduce-reader (reader fn i) 643 (lambda () 644 (let ((z (next reader))) 645 (when z 646 (setq i (funcall fn z i)))))) 647 648 ;;(slurp (reduce-reader (reader '(1 2 3)) #'+ 0)) 649 650 (defun final (reader) 651 (labels ((rec (z) 652 (let ((x (next reader))) 653 (if x 654 (rec x) 655 z)))) 656 (rec nil)) 657 #+nil 658 (do (x 659 (z nil x)) 660 ((not (setq x (next reader))) 661 z)) 662 #+nil 663 (let (z) 664 (loop 665 with x 666 while (setq x (next reader)) 667 do (setq z x)) 668 z)) 669 670 ;;(final (reduce-reader (reader '(1 2 3)) #'+ 0)) 671 672 (defun count-reader (reader) 673 (let ((i 0)) 674 (lambda () 675 (let ((z (next reader))) 676 (when z 677 (incf i)))))) 678 679 ;;(slurp (count-reader (reader '(1 2 3)))) 680 681 (defun zip-reader (readers) 682 (lambda () 683 (loop 684 for r in readers 685 for v = (next r) 686 unless v do (return) 687 collect v))) 688 689 ;;(slurp (zip-reader (list (reader '(1 2 3 4 5)) (reader '(a b c d))))) 690 ;;(slurp (zip-reader (list (reader '(1 2 3 4 5)) (reader '(a b c d e f))))) 691 692 (defun zip2-reader (readers) 693 (lambda () 694 (let ((z (mapcar 'next readers))) 695 (when (some #'identity z) 696 z)))) 697 698 ;;(slurp (zip2-reader (list (reader '(1 2 3 4 5)) (reader '(a b c d))))) 699 ;;(slurp (zip2-reader (list (reader '(1 2 3 4 5)) (reader '(a b c d e f))))) 700 701 ;; ? readers -> choose one based on some criterion? flat-reader + sort? 702 ;; mux-reader 703 704 ;; same fringe 705 ;; tree not in memory but computed lazily/on the fly, possibly huge 706 ;; try find / -type f 707 ;; what if e.g. same=hash but diff timestamp => collect differences => pull vs cb? 708 (labels ((down (x) 709 (if (atom x) 710 x 711 (map-reader (reader x) #'down)))) 712 (ecase (final 713 (reduce-reader 714 (zip2-reader ;; stops on first eof, need to stop when all eof 715 (list 716 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)) 717 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)))) 718 (lambda (x i) 719 (or (and i (eql (car x) (cadr x))) :no)) 720 t)) 721 ((t) t) 722 (:no nil))) 723 724 (defun same-elements-p (list) 725 (let ((h (car list))) 726 (dolist (i (cdr list) t) 727 (unless (eql h i) 728 (return))))) 729 730 (defun same-fringe (readers) 731 (final (reduce-reader (zip2-reader readers) 732 (lambda (x i) 733 (or (and i (same-elements-p x)) 734 (return-from same-fringe))) 735 t))) 736 737 (defun same-fringe (readers) 738 (final (map-reader (zip2-reader readers) 739 (lambda (x) 740 (or (same-elements-p x) 741 (return-from same-fringe)))))) 742 743 #+nil 744 (labels ((down (x) 745 (if (atom x) 746 x 747 (map-reader (reader x) #'down)))) 748 (same-fringe 749 (list 750 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)) 751 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)) 752 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)) 753 (flat-reader (map-reader (reader '(1 (2 (3 4) 5 6) 7)) #'down)))))