factor/contrib/parser-combinators/lazy.factor

! 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.
IN: lazy
USE: lists
USE: stack
USE: math
USE: stdio
USE: prettyprint
USE: kernel
USE: combinators
USE: logic

: curry1 ( n quot -- quot )
  #! Return a quotation that when called will initially
  #! have 'n' pushed on the stack.
  cons ;

: curry2 ( n1 n2 quot -- quot )
  #! Return a quotation that when called will initially
  #! have 'n1' and 'n2' pushed on the stack.
  cons cons ;

: delay ( value -- promise )
  #! Return a promise that when 'forced' returns the original value.
  unit ;

: force ( promise -- value )
  #! Return the value associated with the promise.
  call ;

: lcons ( car promise -- lcons )
  #! Return a lazy pair, where the cdr is a promise and must
  #! be forced to return the value.
  cons ;

: lunit ( a -- llist )
  #! Construct a lazy list of one element.
  [ ] delay lcons ;

: lcar ( lcons -- car )
  #! Return the car of a lazy pair.
  car ;

: lcdr ( lcons -- cdr )
  #! Return the cdr of a lazy pair, implicitly forcing it.
  cdr force ;

: lnth ( n llist -- value )
  #! Return the nth item in a lazy list
  swap [ lcdr ] times lcar ;

: luncons ( lcons -- car cdr )
  #! Return the car and forced cdr of the lazy cons.
  uncons force ;

: (ltake) ( n llist accum -- list )
  >r >r pred dup 0 < [ 
    drop r> drop r> reverse  
  ] [ 
    r> luncons swap r> cons (ltake) 
  ] ifte ;

: ltake ( n llist -- list )
  #! Return a list containing the first n items from
  #! the lazy list.
  [ ] (ltake) ;

: lmap ( llist quot -- llist )
  #! Return a lazy list containing the collected result of calling
  #! quot on the original lazy list.
  over [ ] = [
    2drop [ ]
  ] [
    >r luncons r>     
    dup swapd           
    [ lmap ] curry2  
    >r call r>
    lcons 
  ] ifte ;

: lsubset ( llist pred -- llist )
  #! Return a lazy list containing only the items from the original
  #! lazy list for which the predicate returns a value other than f.
  over [ ] = [
    2drop [ ] 
  ] [
    >r luncons r>
    dup swapd
    [ lsubset ] curry2
    -rot dupd call [ 
      swap lcons
    ] [
      drop call 
    ] ifte 
  ] ifte ;

: lappend* ;
: (lappend*) ;
: lappend-list* ;

: lappend-item* ( llists list item -- llist )
  -rot [ lappend-list* ] curry2 lcons ;

: lappend-list* ( llists list -- llist )
  dup [ 
    #! non-empty list
    luncons swap lappend-item*
  ] [
    #! empty list
    drop lappend*
  ] ifte ;
  
  
: (lappend*) ( llists -- llist )
  dup lcar [  ( llists  ) 
    #! Yes, the first item in the list is a valid llist
    luncons swap lappend-list*
  ] [
    #! The first item in the list is an empty list.
    #! Resume passing the next list.
    lcdr lappend*
  ] ifte ;

: lappend* ( llists -- llist )
  #! Given a lazy list of lazy lists, return a lazy list that
  #! works through all of the sub-lists in sequence.
  dup [
    (lappend*)
  ] [
    #! Leave empty list on the stack
  ] ifte ;

: list>llist ( list -- llist )
  #! Convert a list to a lazy list.
  dup [
    uncons [ list>llist ] curry1 lcons 
  ] when ;

: lappend ( llist1 llist2 -- llist )
  #! Concatenate two lazy lists such that they appear to be one big lazy list.
  2list list>llist lappend* ;

: leach ( llist quot -- )
  #! Call the quotation on each item in the lazy list. 
  #! Warning: If the list is infinite then this will
  #! never return.  
  over [
      >r luncons r> tuck >r >r call r> r> leach
  ] [
      2drop
  ] ifte ;