From 668a9cf87856fe8cc97eee677ea794ac2a40af29 Mon Sep 17 00:00:00 2001 From: "chris.double" Date: Wed, 13 Sep 2006 07:49:18 +0000 Subject: [PATCH] lazy-lists: complete remaining lazy list operations --- contrib/lazy-lists/lists.factor | 189 ++++++++++++++------------------ contrib/lazy-lists/lists.facts | 120 +++++++++++++++----- 2 files changed, 176 insertions(+), 133 deletions(-) diff --git a/contrib/lazy-lists/lists.factor b/contrib/lazy-lists/lists.factor index 0dd4c4c601..3351347743 100644 --- a/contrib/lazy-lists/lists.factor +++ b/contrib/lazy-lists/lists.factor @@ -2,37 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Updated by Matthew Willis, July 2006 +! Updated by Chris Double, September 2006 USING: kernel sequences math vectors arrays namespaces generic ; IN: lazy-lists -TUPLE: cons car cdr ; -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- bool ) - -C: cons ( car cdr -- list ) - [ set-cons-cdr ] keep - [ set-cons-car ] keep ; - -M: cons car ( cons -- car ) - cons-car ; - -: nil ( -- cons ) - T{ cons f f f } ; - -M: cons nil? ( cons -- bool ) - nil eq? ; - -: cons ( car cdr -- list ) - ; - -: 1list ( obj -- cons ) - nil ; - -: 2list ( obj obj -- cons ) - nil ; - TUPLE: promise quot forced? value ; C: promise ( quot -- promise ) [ set-promise-quot ] keep ; @@ -47,6 +21,36 @@ C: promise ( quot -- promise ) [ set-promise-quot ] keep ; ] unless promise-value ; +TUPLE: cons car cdr ; +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( cons -- bool ) + +C: cons ( car cdr -- list ) + [ set-cons-cdr ] keep + [ set-cons-car ] keep ; + +M: cons car ( cons -- car ) + cons-car ; + +M: cons cdr ( cons -- cdr ) + cons-cdr ; + +: nil ( -- cons ) + T{ cons f f f } ; + +M: cons nil? ( cons -- bool ) + nil eq? ; + +: cons ( car cdr -- list ) + ; + +: 1list ( obj -- cons ) + nil ; + +: 2list ( a b -- cons ) + nil ; + ! Both 'car' and 'cdr' are promises : lazy-cons ( car cdr -- promise ) >r r> @@ -80,15 +84,20 @@ TUPLE: list ; : uncons ( cons -- car cdr ) #! Return the car and cdr of the lazy list dup car swap cdr ; - + +: leach ( list quot -- ) + swap dup nil? [ + 2drop + ] [ + uncons swap pick call swap leach + ] if ; + : 2curry ( a b quot -- quot ) curry curry ; TUPLE: lazy-map cons quot ; -: lmap ( list quot -- list ) - #! Return a lazy list containing the collected result of calling - #! quot on the original lazy list. +: lmap ( list quot -- result ) over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) @@ -99,11 +108,12 @@ M: lazy-map cdr ( lazy-map -- cdr ) [ lazy-map-cons cdr ] keep lazy-map-quot lmap ; +M: lazy-map nil? ( lazy-map -- bool ) + lazy-map-cons nil? ; + TUPLE: lazy-take n cons ; -: ltake ( n list -- list ) - #! Return a lazy list containing the first n items from - #! the original lazy list. +: ltake ( n list -- result ) over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) @@ -113,6 +123,9 @@ M: lazy-take cdr ( lazy-take -- cdr ) [ lazy-take-n 1- ] keep lazy-take-cons cdr ltake ; +M: lazy-take nil? ( lazy-take -- bool ) + lazy-take-n zero? ; + TUPLE: lazy-subset cons quot ; : lsubset ( list quot -- list ) @@ -152,90 +165,50 @@ M: lazy-subset nil? ( lazy-subset -- bool ) ] if ] 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 ; + [ [ , ] leach ] V{ } make ; : list>array ( list -- array ) - list>vector >array ; + [ [ , ] leach ] { } make ; -DEFER: backwards-vector>list -: (backwards-vector>list) ( vector -- list ) - dup empty? [ drop nil ] - [ dup pop swap backwards-vector>list cons ] if ; +TUPLE: lazy-append list1 list2 ; -DEFER: force-promise +: lappend ( list1 list2 -- result ) + { + { [ over nil? over nil? and ] [ 2drop nil ] } + { [ over nil? ] [ nip ] } + { [ dup nil? ] [ drop ] } + { [ t ] [ ] } + } cond ; -: 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 ; +M: lazy-append car ( lazy-append -- car ) + lazy-append-list1 car ; -DEFER: lappend* -: (lappend*) ( lists -- list ) - dup nil? [ - uncons >r dup nil? [ drop r> (lappend*) ] - [ uncons r> cons lappend* cons ] if - ] unless ; +M: lazy-append cdr ( lazy-append -- cdr ) + [ lazy-append-list1 cdr ] keep + lazy-append-list2 lappend ; -: 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 ; +M: lazy-append nil? ( lazy-append -- bool ) + dup lazy-append-list1 nil? [ + drop t + ] [ + lazy-append-list2 nil? + ] if ; -: lappend ( list1 list2 -- llist ) - #! Concatenate two lazy lists such that they appear to be one big - #! lazy list. - lunit cons lappend* ; +TUPLE: lazy-from-by n quot ; -: 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 ; \ No newline at end of file + [ 1 + ] lfrom-by ; + +M: lazy-from-by car ( lazy-from-by -- car ) + lazy-from-by-n ; + +M: lazy-from-by cdr ( lazy-from-by -- cdr ) + [ lazy-from-by-n ] keep + lazy-from-by-quot dup >r call r> lfrom-by ; + +M: lazy-from-by nil? ( lazy-from-by -- bool ) + drop f ; diff --git a/contrib/lazy-lists/lists.facts b/contrib/lazy-lists/lists.facts index 86126f4a2c..efed0d5a5d 100644 --- a/contrib/lazy-lists/lists.facts +++ b/contrib/lazy-lists/lists.facts @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help lazy-lists ; +USING: help lazy-lists sequences ; HELP: { $values { "quot" "a quotation with stack effect ( -- X )" } { "promise" "a promise object" } } @@ -14,46 +14,116 @@ HELP: force { $see-also } ; HELP: -{ $values { "car" "A promise for the head of the lazy list" } { "cdr" "A promise for the tail of the lazy list" } { "cons" "a cons object" } } -{ $description "Constructs a lazy cons cell. The car and cdr are promises that, when forced, provide the non-lazy values." } -{ $see-also car cdr nil } ; +{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } +{ $see-also cons car cdr nil nil? } ; HELP: car { $values { "cons" "a cons object" } { "car" "the first item in the list" } } -{ $description "Returns the first item in the list. This causes the item to be evaluated." } -{ $see-also car cdr } ; +{ $description "Returns the first item in the list." } +{ $see-also cons cdr nil nil? } ; HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } -{ $see-also car cdr } ; - -HELP: cons -{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "cons" "the resulting cons object" } } -{ $description "Constructs a cons object for a lazy list from two quotations. The 'car' quotation should return the head of the list, and the 'cons' quotation the tail when called." } -{ $see-also car cdr } ; +{ $see-also cons car nil nil? } ; HELP: nil -{ $values { "array" "An empty array" } } -{ $description "Returns a representation of an empty lazy list" } -{ $see-also car cdr nil? } ; +{ $values { "cons" "An empty cons" } } +{ $description "Returns a representation of an empty list" } +{ $see-also cons car cdr nil? } ; HELP: nil? { $values { "cons" "a cons object" } } -{ $description "Return true if the cons object is the nil list." } -{ $see-also nil } ; +{ $description "Return true if the cons object is the nil cons." } +{ $see-also cons car cdr nil } ; -HELP: -{ $values { "car" "the car of the list" } { "cdr" "a object for the cdr of the list" } { "list" "a lazy list" } } -{ $description "Constructs a lazy list where the car is already forced and the cdr is an already forced list." } -{ $see-also car cdr } ; +HELP: cons +{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } +{ $see-also car cdr nil nil? } ; HELP: 1list -{ $values { "obj" "an object" } { "list" "a list" } } +{ $values { "obj" "an object" } { "cons" "a cons object" } } { $description "Create a list with 1 element." } -{ $see-also 2list } ; +{ $see-also 2list } ; HELP: 2list -{ $values { "a" "an object" } { "b" "an object" } { "list" "a list" } } +{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } { $description "Create a list with 2 elements." } -{ $see-also 1list } ; +{ $see-also 1list } ; + +HELP: lazy-cons +{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "cons" "the resulting cons object" } } +{ $description "Constructs a cons object for a lazy list from two quotations. The 'car' quotation should return the head of the list, and the 'cons' quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } +{ $see-also cons car cdr nil nil? } ; + +HELP: 1lazy-list +{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } +{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } +{ $see-also 2lazy-list 3lazy-list } ; + +HELP: 2lazy-list +{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } +{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } +{ $see-also 1lazy-list 3lazy-list } ; + +HELP: 3lazy-list +{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } } +{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } +{ $see-also 1lazy-list 2lazy-list } ; + +HELP: lnth +{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } +{ $description "Outputs the nth element of the list." } +{ $see-also cons car cdr } ; + +HELP: uncons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } +{ $see-also cons car cdr } ; + +HELP: leach +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- )" } } +{ $description "Call the quotation for each item in the list." } +{ $see-also lmap ltake lsubset lappend lfrom lfrom-by } ; + +HELP: lmap +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } } +{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also leach ltake lsubset lappend lfrom lfrom-by } ; + +HELP: ltake +{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } +{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also leach lmap lsubset lappend lfrom lfrom-by } ; + +HELP: lsubset +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } } +{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } +{ $see-also leach lmap ltake lappend lfrom lfrom-by } ; + +HELP: list>vector +{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } } +{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." } +{ $see-also list>array } ; + +HELP: list>array +{ $values { "list" "a cons object" } { "array" "the list converted to an array" } } +{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." } +{ $see-also list>vector } ; + +HELP: lappend +{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } } +{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } +{ $see-also leach lmap ltake lsubset lfrom lfrom-by } ; + +HELP: lfrom-by +{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "result" "a lazy list of integers" } } +{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } +{ $see-also leach lmap ltake lsubset lfrom } ; + +HELP: lfrom +{ $values { "n" "an integer" } { "result" "a lazy list of integers" } } +{ $description "Return an infinite lazy list of incrementing integers starting from n." } +{ $see-also leach lmap ltake lsubset lfrom-by } ;