! Updated by Matthew Willis, July 2006 ! ! Copyright (C) 2004 Chris Double. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: ! ! 1. Redistributions of source code must retain the above copyright notice, ! this list of conditions and the following disclaimer. ! ! 2. Redistributions in binary form must reproduce the above copyright notice, ! this list of conditions and the following disclaimer in the documentation ! and/or other materials provided with the distribution. ! ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. USING: kernel sequences math vectors arrays namespaces ; IN: lazy-lists TUPLE: promise quot forced? value ; C: promise ( quot -- promise ) [ set-promise-quot ] keep ; : force ( promise -- value ) #! Force the given promise leaving the value of calling the #! promises quotation on the stack. Re-forcing the promise #! will return the same value and not recall the quotation. dup promise-forced? [ dup promise-quot call over set-promise-value t over set-promise-forced? ] unless promise-value ; ! Both 'car' and 'cdr' are promises TUPLE: cons car cdr ; : nil ( -- list ) #! The nil lazy list. { } ; : nil? ( list -- bool ) #! Is the given lazy cons the nil value { } = ; : car ( list -- car ) #! Return the value of the head of the lazy list. cons-car force ; : cdr ( list -- cdr ) #! Return the rest of the lazy list. #! This is itself a lazy list. cons-cdr force ; : cons ( car cdr -- list ) #! Given a car and cdr, both quotations, return a cons. >r r> ; : lunit ( obj -- list ) #! Given a value produce a lazy list containing that value. unit [ nil ] cons ; : lnth ( n list -- value ) #! Return the nth item in a lazy list swap [ cdr ] times car ; : uncons ( cons -- car cdr ) #! Return the car and cdr of the lazy list dup car swap cdr ; : 2curry ( a b quot -- quot ) curry curry ; : lmap ( list quot -- list ) #! Return a lazy list containing the collected result of calling #! quot on the original lazy list. over nil? [ drop ] [ 2dup [ >r cdr r> lmap ] 2curry >r [ >r car r> call ] 2curry r> cons ] if ; : ltake ( n list -- list ) #! Return a lazy list containing the first n items from #! the original lazy list. over zero? [ 2drop nil ] [ 2dup [ >r 1- r> cdr ltake ] 2curry >r [ nip car ] 2curry r> cons ] if ; DEFER: lsubset : (lsubset) ( list pred -- list ) >r dup nil? [ r> drop ] [ uncons swap dup r> dup >r call [ swap r> lsubset cons ] [ drop r> (lsubset) ] if ] if ; : lsubset-car ( array pred -- value ) 2dup >r first car dup r> call [ 2nip ] [ drop >r dup first cdr 0 pick set-nth r> lsubset-car ] if ; ! cons needs to be lazy so lsubset can lazilly detect nil! ! It needs to skip all 'f' entries on initial call. : lsubset ( list pred -- list ) #! Return a lazy list containing the elements in llist #! satisfying pred over nil? [ drop ] [ >r 1array r> 2dup [ >r first cdr r> lsubset ] 2curry >r [ lsubset-car ] 2curry r> cons ] if ; : t1 [ 1 ] [ [ 2 ] [ [ 3 ] [ nil ] cons ] cons ] cons ; : t2 [ 2 ] [ [ 3 ] [ [ 4 ] [ nil ] cons ] cons ] cons ; : (list>backwards-vector) ( list -- vector ) dup nil? [ drop V{ } clone ] [ uncons (list>backwards-vector) swap over push ] if ; : list>vector ( list -- vector ) #! Convert a lazy list to a vector. This will cause #! an infinite loop if the lazy list is an infinite list. (list>backwards-vector) reverse ; : list>array ( list -- array ) list>vector >array ; DEFER: backwards-vector>list : (backwards-vector>list) ( vector -- list ) dup empty? [ drop nil ] [ dup pop swap backwards-vector>list cons ] if ; : backwards-vector>list ( vector -- list ) [ , \ (backwards-vector>list) , ] force-promise ; : array>list ( array -- list ) #! Convert a list to a lazy list. reverse >vector backwards-vector>list ; DEFER: lappend* : (lappend*) ( lists -- list ) dup nil? [ uncons >r dup nil? [ drop r> (lappend*) ] [ uncons r> cons lappend* cons ] if ] unless ; : lappend* ( llists -- list ) #! Given a lazy list of lazy lists, concatenate them #! together in a lazy fashion. The actual appending is #! done lazily on iteration rather than immediately #! so it works very fast no matter how large the lists. [ , \ (lappend*) , ] force-promise ; : lappend ( list1 list2 -- llist ) #! Concatenate two lazy lists such that they appear to be one big #! lazy list. lunit cons lappend* ; : leach ( list quot -- ) #! Call the quotation on each item in the lazy list. #! Warning: If the list is infinite then this will #! never return. swap dup nil? [ 2drop ] [ uncons swap pick call swap leach ] if ; DEFER: lapply : (lapply) ( list quot -- list ) over nil? [ drop ] [ swap dup car >r uncons pick call swap lapply r> swap cons ] if ; : lapply ( list quot -- list ) #! Returns a lazy list which is #! (cons (car list) #! (lapply (quot (car list) (cdr list)) quot)) #! This allows for complicated list functions [ swap , , \ (lapply) , ] force-promise ; DEFER: lfrom-by : (lfrom-by) ( n quot -- list ) 2dup call swap lfrom-by cons ; : lfrom-by ( n quot -- list ) #! Return a lazy list of values starting from n, with #! each successive value being the result of applying quot to #! n. [ swap , , \ (lfrom-by) , ] force-promise ; : lfrom ( n -- list ) #! Return a lazy list of increasing numbers starting #! from the initial value 'n'. [ 1 + ] lfrom-by ;