factor/contrib/lazy-lists/lists.factor

! 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 <promise> r> <promise> <cons> ;

: 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 ;