Merge branch 'master' of git://factorcode.org/git/jamesnvc
Slava Pestov
commit
8ef7f4d904
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser-combinators regexp lazy-lists sequences kernel
|
||||
USING: parser-combinators regexp lists sequences kernel
|
||||
promises strings unicode.case ;
|
||||
IN: globs
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser-combinators namespaces sequences promises strings
|
||||
assocs math math.parser math.vectors math.functions math.order
|
||||
lazy-lists hashtables ascii ;
|
||||
lists hashtables ascii ;
|
||||
IN: json.reader
|
||||
|
||||
! Grammar for JSON from RFC 4627
|
||||
|
|
|
|||
|
|
@ -1,445 +0,0 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! 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
|
||||
quotations promises combinators io ;
|
||||
IN: lazy-lists
|
||||
|
||||
! Lazy List Protocol
|
||||
MIXIN: list
|
||||
GENERIC: car ( cons -- car )
|
||||
GENERIC: cdr ( cons -- cdr )
|
||||
GENERIC: nil? ( cons -- ? )
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
force car ;
|
||||
|
||||
M: promise cdr ( promise -- cdr )
|
||||
force cdr ;
|
||||
|
||||
M: promise nil? ( cons -- bool )
|
||||
force nil? ;
|
||||
|
||||
TUPLE: cons car cdr ;
|
||||
|
||||
C: cons cons
|
||||
|
||||
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? ;
|
||||
|
||||
: 1list ( obj -- cons )
|
||||
nil cons ;
|
||||
|
||||
: 2list ( a b -- cons )
|
||||
nil cons cons ;
|
||||
|
||||
: 3list ( a b c -- cons )
|
||||
nil cons cons cons ;
|
||||
|
||||
! Both 'car' and 'cdr' are promises
|
||||
TUPLE: lazy-cons car cdr ;
|
||||
|
||||
: lazy-cons ( car cdr -- promise )
|
||||
[ promise ] bi@ \ lazy-cons boa
|
||||
T{ promise f f t f } clone
|
||||
[ set-promise-value ] keep ;
|
||||
|
||||
M: lazy-cons car ( lazy-cons -- car )
|
||||
lazy-cons-car force ;
|
||||
|
||||
M: lazy-cons cdr ( lazy-cons -- cdr )
|
||||
lazy-cons-cdr force ;
|
||||
|
||||
M: lazy-cons nil? ( lazy-cons -- bool )
|
||||
nil eq? ;
|
||||
|
||||
: 1lazy-list ( a -- lazy-cons )
|
||||
[ nil ] lazy-cons ;
|
||||
|
||||
: 2lazy-list ( a b -- lazy-cons )
|
||||
1lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: 3lazy-list ( a b c -- lazy-cons )
|
||||
2lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
swap [ cdr ] times car ;
|
||||
|
||||
: (llength) ( list acc -- n )
|
||||
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
|
||||
|
||||
: llength ( list -- n )
|
||||
0 (llength) ;
|
||||
|
||||
: 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 swapd over 2slip leach ] if ; inline
|
||||
|
||||
: lreduce ( list identity quot -- result )
|
||||
swapd leach ; inline
|
||||
|
||||
TUPLE: memoized-cons original car cdr nil? ;
|
||||
|
||||
: not-memoized ( -- obj )
|
||||
{ } ;
|
||||
|
||||
: not-memoized? ( obj -- bool )
|
||||
not-memoized eq? ;
|
||||
|
||||
: <memoized-cons> ( cons -- memoized-cons )
|
||||
not-memoized not-memoized not-memoized
|
||||
memoized-cons boa ;
|
||||
|
||||
M: memoized-cons car ( memoized-cons -- car )
|
||||
dup memoized-cons-car not-memoized? [
|
||||
dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
|
||||
] [
|
||||
memoized-cons-car
|
||||
] if ;
|
||||
|
||||
M: memoized-cons cdr ( memoized-cons -- cdr )
|
||||
dup memoized-cons-cdr not-memoized? [
|
||||
dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
|
||||
] [
|
||||
memoized-cons-cdr
|
||||
] if ;
|
||||
|
||||
M: memoized-cons nil? ( memoized-cons -- bool )
|
||||
dup memoized-cons-nil? not-memoized? [
|
||||
dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
|
||||
] [
|
||||
memoized-cons-nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-map cons quot ;
|
||||
|
||||
C: <lazy-map> lazy-map
|
||||
|
||||
: lmap ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
|
||||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ lazy-map-cons car ] keep
|
||||
lazy-map-quot call ;
|
||||
|
||||
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? ;
|
||||
|
||||
: lmap-with ( value list quot -- result )
|
||||
with lmap ;
|
||||
|
||||
TUPLE: lazy-take n cons ;
|
||||
|
||||
C: <lazy-take> lazy-take
|
||||
|
||||
: ltake ( n list -- result )
|
||||
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
|
||||
|
||||
M: lazy-take car ( lazy-take -- car )
|
||||
lazy-take-cons car ;
|
||||
|
||||
M: lazy-take cdr ( lazy-take -- cdr )
|
||||
[ lazy-take-n 1- ] keep
|
||||
lazy-take-cons cdr ltake ;
|
||||
|
||||
M: lazy-take nil? ( lazy-take -- bool )
|
||||
dup lazy-take-n zero? [
|
||||
drop t
|
||||
] [
|
||||
lazy-take-cons nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-until cons quot ;
|
||||
|
||||
C: <lazy-until> lazy-until
|
||||
|
||||
: luntil ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-until> ] if ;
|
||||
|
||||
M: lazy-until car ( lazy-until -- car )
|
||||
lazy-until-cons car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-while cons quot ;
|
||||
|
||||
C: <lazy-while> lazy-while
|
||||
|
||||
: lwhile ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-while> ] if ;
|
||||
|
||||
M: lazy-while car ( lazy-while -- car )
|
||||
lazy-while-cons car ;
|
||||
|
||||
M: lazy-while cdr ( lazy-while -- cdr )
|
||||
[ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep lazy-while-quot call not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
C: <lazy-filter> lazy-filter
|
||||
|
||||
: lfilter ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ lazy-filter-cons car ] keep
|
||||
lazy-filter-quot call ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
[ lazy-filter-cons cdr ] keep
|
||||
set-lazy-filter-cons ;
|
||||
|
||||
M: lazy-filter car ( lazy-filter -- car )
|
||||
dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
|
||||
|
||||
M: lazy-filter cdr ( lazy-filter -- cdr )
|
||||
dup car-filter? [
|
||||
[ lazy-filter-cons cdr ] keep
|
||||
lazy-filter-quot lfilter
|
||||
] [
|
||||
dup skip cdr
|
||||
] if ;
|
||||
|
||||
M: lazy-filter nil? ( lazy-filter -- bool )
|
||||
dup lazy-filter-cons nil? [
|
||||
drop t
|
||||
] [
|
||||
dup car-filter? [
|
||||
drop f
|
||||
] [
|
||||
dup skip nil?
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: list>vector ( list -- vector )
|
||||
[ [ , ] leach ] V{ } make ;
|
||||
|
||||
: list>array ( list -- array )
|
||||
[ [ , ] leach ] { } make ;
|
||||
|
||||
TUPLE: lazy-append list1 list2 ;
|
||||
|
||||
C: <lazy-append> lazy-append
|
||||
|
||||
: lappend ( list1 list2 -- result )
|
||||
over nil? [ nip ] [ <lazy-append> ] if ;
|
||||
|
||||
M: lazy-append car ( lazy-append -- car )
|
||||
lazy-append-list1 car ;
|
||||
|
||||
M: lazy-append cdr ( lazy-append -- cdr )
|
||||
[ lazy-append-list1 cdr ] keep
|
||||
lazy-append-list2 lappend ;
|
||||
|
||||
M: lazy-append nil? ( lazy-append -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-from-by n quot ;
|
||||
|
||||
C: lfrom-by lazy-from-by ( n quot -- list )
|
||||
|
||||
: lfrom ( n -- list )
|
||||
[ 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 slip lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-zip list1 list2 ;
|
||||
|
||||
C: <lazy-zip> lazy-zip
|
||||
|
||||
: lzip ( list1 list2 -- lazy-zip )
|
||||
over nil? over nil? or
|
||||
[ 2drop nil ] [ <lazy-zip> ] if ;
|
||||
|
||||
M: lazy-zip car ( lazy-zip -- car )
|
||||
[ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
|
||||
|
||||
M: lazy-zip cdr ( lazy-zip -- cdr )
|
||||
[ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
|
||||
|
||||
M: lazy-zip nil? ( lazy-zip -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: sequence-cons index seq ;
|
||||
|
||||
C: <sequence-cons> sequence-cons
|
||||
|
||||
: seq>list ( index seq -- list )
|
||||
2dup length >= [
|
||||
2drop nil
|
||||
] [
|
||||
<sequence-cons>
|
||||
] if ;
|
||||
|
||||
M: sequence-cons car ( sequence-cons -- car )
|
||||
[ sequence-cons-index ] keep
|
||||
sequence-cons-seq nth ;
|
||||
|
||||
M: sequence-cons cdr ( sequence-cons -- cdr )
|
||||
[ sequence-cons-index 1+ ] keep
|
||||
sequence-cons-seq seq>list ;
|
||||
|
||||
M: sequence-cons nil? ( sequence-cons -- bool )
|
||||
drop f ;
|
||||
|
||||
: >list ( object -- list )
|
||||
{
|
||||
{ [ dup sequence? ] [ 0 swap seq>list ] }
|
||||
{ [ dup list? ] [ ] }
|
||||
[ "Could not convert object to a list" throw ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-concat car cdr ;
|
||||
|
||||
C: <lazy-concat> lazy-concat
|
||||
|
||||
DEFER: lconcat
|
||||
|
||||
: (lconcat) ( car cdr -- list )
|
||||
over nil? [
|
||||
nip lconcat
|
||||
] [
|
||||
<lazy-concat>
|
||||
] if ;
|
||||
|
||||
: lconcat ( list -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
uncons (lconcat)
|
||||
] if ;
|
||||
|
||||
M: lazy-concat car ( lazy-concat -- car )
|
||||
lazy-concat-car car ;
|
||||
|
||||
M: lazy-concat cdr ( lazy-concat -- cdr )
|
||||
[ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
|
||||
|
||||
M: lazy-concat nil? ( lazy-concat -- bool )
|
||||
dup lazy-concat-car nil? [
|
||||
lazy-concat-cdr nil?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: lcartesian-product ( list1 list2 -- result )
|
||||
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
|
||||
|
||||
: lcartesian-product* ( lists -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
|
||||
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
|
||||
] reduce
|
||||
] if ;
|
||||
|
||||
: lcomp ( list quot -- result )
|
||||
[ lcartesian-product* ] dip lmap ;
|
||||
|
||||
: lcomp* ( list guards quot -- result )
|
||||
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
|
||||
|
||||
DEFER: lmerge
|
||||
|
||||
: (lmerge) ( list1 list2 -- result )
|
||||
over [ car ] curry -rot
|
||||
[
|
||||
dup [ car ] curry -rot
|
||||
[
|
||||
[ cdr ] bi@ lmerge
|
||||
] 2curry lazy-cons
|
||||
] 2curry lazy-cons ;
|
||||
|
||||
: lmerge ( list1 list2 -- result )
|
||||
{
|
||||
{ [ over nil? ] [ nip ] }
|
||||
{ [ dup nil? ] [ drop ] }
|
||||
{ [ t ] [ (lmerge) ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-io stream car cdr quot ;
|
||||
|
||||
C: <lazy-io> lazy-io
|
||||
|
||||
: lcontents ( stream -- result )
|
||||
f f [ stream-read1 ] <lazy-io> ;
|
||||
|
||||
: llines ( stream -- result )
|
||||
f f [ stream-readln ] <lazy-io> ;
|
||||
|
||||
M: lazy-io car ( lazy-io -- car )
|
||||
dup lazy-io-car dup [
|
||||
nip
|
||||
] [
|
||||
drop dup lazy-io-stream over lazy-io-quot call
|
||||
swap dupd set-lazy-io-car
|
||||
] if ;
|
||||
|
||||
M: lazy-io cdr ( lazy-io -- cdr )
|
||||
dup lazy-io-cdr dup [
|
||||
nip
|
||||
] [
|
||||
drop dup
|
||||
[ lazy-io-stream ] keep
|
||||
[ lazy-io-quot ] keep
|
||||
car [
|
||||
[ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
|
||||
] [
|
||||
3drop nil
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: lazy-io nil? ( lazy-io -- bool )
|
||||
car not ;
|
||||
|
||||
INSTANCE: cons list
|
||||
INSTANCE: sequence-cons list
|
||||
INSTANCE: memoized-cons list
|
||||
INSTANCE: promise list
|
||||
INSTANCE: lazy-io list
|
||||
INSTANCE: lazy-concat list
|
||||
INSTANCE: lazy-cons list
|
||||
INSTANCE: lazy-map list
|
||||
INSTANCE: lazy-take list
|
||||
INSTANCE: lazy-append list
|
||||
INSTANCE: lazy-from-by list
|
||||
INSTANCE: lazy-zip list
|
||||
INSTANCE: lazy-while list
|
||||
INSTANCE: lazy-until list
|
||||
INSTANCE: lazy-filter list
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lisp lisp.parser tools.test sequences math kernel parser ;
|
||||
USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
|
||||
|
||||
IN: lisp.test
|
||||
|
||||
|
|
@ -10,8 +10,10 @@ IN: lisp.test
|
|||
"#f" [ f ] lisp-define
|
||||
"#t" [ t ] lisp-define
|
||||
|
||||
"+" "math" "+" define-primitve
|
||||
"-" "math" "-" define-primitve
|
||||
"+" "math" "+" define-primitive
|
||||
"-" "math" "-" define-primitive
|
||||
|
||||
! "list" [ >array ] lisp-define
|
||||
|
||||
{ 5 } [
|
||||
[ 2 3 ] "+" <lisp-symbol> funcall
|
||||
|
|
@ -22,26 +24,31 @@ IN: lisp.test
|
|||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 42 } [
|
||||
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
|
||||
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 1 } [
|
||||
"(if #t 1 2)" lisp-string>factor call
|
||||
"(if #t 1 2)" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ "b" } [
|
||||
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
|
||||
"(cond (#f \"a\") (#t \"b\"))" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
"(begin (+ 1 4))" lisp-string>factor call
|
||||
"(begin (+ 1 4))" lisp-eval
|
||||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
|
||||
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
|
||||
] unit-test
|
||||
] with-interactive-vocabs
|
||||
|
||||
! { { 1 2 3 4 5 } } [
|
||||
! "(list 1 2 3 4 5)" lisp-eval
|
||||
! ] unit-test
|
||||
|
||||
] with-interactive-vocabs
|
||||
|
|
|
|||
|
|
@ -1,48 +1,51 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg sequences arrays strings combinators.lib
|
||||
namespaces combinators math bake locals locals.private accessors
|
||||
namespaces combinators math locals locals.private accessors
|
||||
vectors syntax lisp.parser assocs parser sequences.lib words quotations
|
||||
fry ;
|
||||
fry lists inspector ;
|
||||
IN: lisp
|
||||
|
||||
DEFER: convert-form
|
||||
DEFER: funcall
|
||||
DEFER: lookup-var
|
||||
DEFER: lisp-macro?
|
||||
DEFER: lookup-macro
|
||||
DEFER: macro-call
|
||||
|
||||
! Functions to convert s-exps to quotations
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: convert-body ( s-exp -- quot )
|
||||
[ ] [ convert-form compose ] reduce ; inline
|
||||
: convert-body ( cons -- quot )
|
||||
[ ] [ convert-form compose ] lreduce ; inline
|
||||
|
||||
: convert-if ( s-exp -- quot )
|
||||
rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
|
||||
: convert-if ( cons -- quot )
|
||||
cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
|
||||
|
||||
: convert-begin ( s-exp -- quot )
|
||||
rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
|
||||
: convert-begin ( cons -- quot )
|
||||
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
|
||||
|
||||
: convert-cond ( s-exp -- quot )
|
||||
rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
|
||||
{ } map-as '[ , cond ] ;
|
||||
: convert-cond ( cons -- quot )
|
||||
cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
|
||||
{ } lmap-as '[ , cond ] ;
|
||||
|
||||
: convert-general-form ( s-exp -- quot )
|
||||
unclip convert-form swap convert-body swap '[ , @ funcall ] ;
|
||||
: convert-general-form ( cons -- quot )
|
||||
uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
|
||||
|
||||
! words for convert-lambda
|
||||
<PRIVATE
|
||||
: localize-body ( assoc body -- assoc newbody )
|
||||
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
|
||||
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
|
||||
] map ;
|
||||
dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ]
|
||||
[ dup cons? [ localize-body ] when nip ] if
|
||||
] with lmap>array ;
|
||||
|
||||
: localize-lambda ( body vars -- newbody newvars )
|
||||
make-locals dup push-locals swap
|
||||
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
|
||||
[ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ;
|
||||
|
||||
: split-lambda ( s-exp -- body vars )
|
||||
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
|
||||
: split-lambda ( cons -- body-cons vars-seq )
|
||||
3car -rot nip [ name>> ] lmap>array ; inline
|
||||
|
||||
: rest-lambda ( body vars -- quot )
|
||||
: rest-lambda ( body vars -- quot )
|
||||
"&rest" swap [ index ] [ remove ] 2bi
|
||||
localize-lambda <lambda>
|
||||
'[ , cut '[ @ , ] , compose ] ;
|
||||
|
|
@ -51,46 +54,63 @@ DEFER: lookup-var
|
|||
localize-lambda <lambda> '[ , compose ] ;
|
||||
PRIVATE>
|
||||
|
||||
: convert-lambda ( s-exp -- quot )
|
||||
: convert-lambda ( cons -- quot )
|
||||
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
|
||||
|
||||
: convert-quoted ( s-exp -- quot )
|
||||
second 1quotation ;
|
||||
: convert-quoted ( cons -- quot )
|
||||
cdr 1quotation ;
|
||||
|
||||
: convert-list-form ( s-exp -- quot )
|
||||
dup first dup lisp-symbol?
|
||||
[ name>>
|
||||
{ { "lambda" [ convert-lambda ] }
|
||||
{ "quote" [ convert-quoted ] }
|
||||
{ "if" [ convert-if ] }
|
||||
{ "begin" [ convert-begin ] }
|
||||
{ "cond" [ convert-cond ] }
|
||||
[ drop convert-general-form ]
|
||||
} case ]
|
||||
[ drop convert-general-form ] if ;
|
||||
: form-dispatch ( lisp-symbol -- quot )
|
||||
name>>
|
||||
{ { "lambda" [ convert-lambda ] }
|
||||
{ "quote" [ convert-quoted ] }
|
||||
{ "if" [ convert-if ] }
|
||||
{ "begin" [ convert-begin ] }
|
||||
{ "cond" [ convert-cond ] }
|
||||
[ drop convert-general-form ]
|
||||
} case ;
|
||||
|
||||
: macro-expand ( cons -- quot )
|
||||
uncons lookup-macro macro-call convert-form ;
|
||||
|
||||
: convert-list-form ( cons -- quot )
|
||||
dup car
|
||||
{ { [ dup lisp-macro? ] [ macro-expand ] }
|
||||
{ [ dup lisp-symbol? ] [ form-dispatch ] }
|
||||
[ drop convert-general-form ]
|
||||
} cond ;
|
||||
|
||||
: convert-form ( lisp-form -- quot )
|
||||
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
|
||||
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
|
||||
[ 1quotation ]
|
||||
{
|
||||
{ [ dup cons? ] [ convert-list-form ] }
|
||||
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
|
||||
[ 1quotation ]
|
||||
} cond ;
|
||||
|
||||
: lisp-string>factor ( str -- quot )
|
||||
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
|
||||
|
||||
: lisp-eval ( str -- * )
|
||||
lisp-string>factor call ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: lisp-env
|
||||
ERROR: no-such-var var ;
|
||||
|
||||
SYMBOL: macro-env
|
||||
|
||||
M: no-such-var summary drop "No such variable" ;
|
||||
|
||||
: init-env ( -- )
|
||||
H{ } clone lisp-env set ;
|
||||
H{ } clone lisp-env set
|
||||
H{ } clone macro-env set ;
|
||||
|
||||
: lisp-define ( name quot -- )
|
||||
swap lisp-env get set-at ;
|
||||
|
||||
: lisp-get ( name -- word )
|
||||
dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
|
||||
dup lisp-env get at [ ] [ no-such-var ] ?if ;
|
||||
|
||||
: lookup-var ( lisp-symbol -- quot )
|
||||
name>> lisp-get ;
|
||||
|
|
@ -98,5 +118,11 @@ ERROR: no-such-var var ;
|
|||
: funcall ( quot sym -- * )
|
||||
dup lisp-symbol? [ lookup-var ] when call ; inline
|
||||
|
||||
: define-primitve ( name vocab word -- )
|
||||
swap lookup 1quotation '[ , compose call ] lisp-define ;
|
||||
: define-primitive ( name vocab word -- )
|
||||
swap lookup 1quotation '[ , compose call ] lisp-define ;
|
||||
|
||||
: lookup-macro ( lisp-symbol -- macro )
|
||||
name>> macro-env get at ;
|
||||
|
||||
: lisp-macro? ( car -- ? )
|
||||
dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lisp.parser tools.test peg peg.ebnf ;
|
||||
USING: lisp.parser tools.test peg peg.ebnf lists ;
|
||||
|
||||
IN: lisp.parser.tests
|
||||
|
||||
|
|
@ -9,38 +9,60 @@ IN: lisp.parser.tests
|
|||
] unit-test
|
||||
|
||||
{ -42 } [
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 37/52 } [
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 123.98 } [
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "" } [
|
||||
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "aoeu" } [
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ "aoeu\"de" } [
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "foobar" } } [
|
||||
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ lisp-symbol f "+" } } [
|
||||
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
"+" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ s-exp f
|
||||
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
|
||||
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
|
||||
{ +nil+ } [
|
||||
"()" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{
|
||||
cons
|
||||
f
|
||||
T{ lisp-symbol f "foo" }
|
||||
T{
|
||||
cons
|
||||
f
|
||||
1
|
||||
T{ cons f 2 T{ cons f "aoeu" +nil+ } }
|
||||
} } } [
|
||||
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f
|
||||
1
|
||||
T{ cons f
|
||||
T{ cons f 3 T{ cons f 4 +nil+ } }
|
||||
T{ cons f 2 +nil+ } }
|
||||
}
|
||||
} [
|
||||
"(1 (3 4) 2)" lisp-expr parse-result-ast
|
||||
] unit-test
|
||||
|
|
@ -1,16 +1,13 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
|
||||
combinators.lib math ;
|
||||
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
|
||||
combinators.lib math fry accessors lists ;
|
||||
|
||||
IN: lisp.parser
|
||||
|
||||
TUPLE: lisp-symbol name ;
|
||||
C: <lisp-symbol> lisp-symbol
|
||||
|
||||
TUPLE: s-exp body ;
|
||||
C: <s-exp> s-exp
|
||||
|
||||
EBNF: lisp-expr
|
||||
_ = (" " | "\t" | "\n")*
|
||||
LPAREN = "("
|
||||
|
|
@ -24,8 +21,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string
|
|||
number = float
|
||||
| rational
|
||||
| integer
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
|
||||
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
|
||||
| "<" | "#" | " =" | ">" | "?" | "^" | "_"
|
||||
| "~" | "+" | "-" | "." | "@"
|
||||
letters = [a-zA-Z] => [[ 1array >string ]]
|
||||
initials = letters | id-specials
|
||||
numbers = [0-9] => [[ 1array >string ]]
|
||||
|
|
@ -36,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
|
|||
atom = number
|
||||
| identifier
|
||||
| string
|
||||
list-item = _ (atom|s-expression) _ => [[ second ]]
|
||||
s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
|
||||
list-item = _ ( atom | s-expression ) _ => [[ second ]]
|
||||
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
|
||||
;EBNF
|
||||
|
|
@ -0,0 +1 @@
|
|||
James Cash
|
||||
|
|
@ -11,5 +11,5 @@ IN: lazy-lists.examples
|
|||
: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
|
||||
: powers-of-2 1 [ 2 * ] lfrom-by ;
|
||||
: ones 1 [ ] lfrom-by ;
|
||||
: squares naturals [ dup * ] lmap ;
|
||||
: squares naturals [ dup * ] lazy-map ;
|
||||
: first-five-squares 5 squares ltake list>array ;
|
||||
|
|
@ -1,48 +1,8 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: help.markup help.syntax sequences strings ;
|
||||
IN: lazy-lists
|
||||
|
||||
{ car cons cdr nil nil? list? uncons } related-words
|
||||
|
||||
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." } ;
|
||||
|
||||
HELP: car
|
||||
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
|
||||
{ $description "Returns the first item in the list." } ;
|
||||
|
||||
HELP: cdr
|
||||
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
|
||||
{ $description "Returns the tail of the list." } ;
|
||||
|
||||
HELP: nil
|
||||
{ $values { "cons" "An empty cons" } }
|
||||
{ $description "Returns a representation of an empty list" } ;
|
||||
|
||||
HELP: nil?
|
||||
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
|
||||
{ $description "Return true if the cons object is the nil cons." } ;
|
||||
|
||||
HELP: list? ( object -- ? )
|
||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the object conforms to the list protocol." } ;
|
||||
|
||||
{ 1list 2list 3list } related-words
|
||||
|
||||
HELP: 1list
|
||||
{ $values { "obj" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 1 element." } ;
|
||||
|
||||
HELP: 2list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 2 elements." } ;
|
||||
|
||||
HELP: 3list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 3 elements." } ;
|
||||
USING: help.markup help.syntax sequences strings lists ;
|
||||
IN: lists.lazy
|
||||
|
||||
HELP: lazy-cons
|
||||
{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
|
||||
|
|
@ -68,37 +28,15 @@ HELP: <memoized-cons>
|
|||
{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
|
||||
{ $see-also cons car cdr nil nil? } ;
|
||||
|
||||
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 llength cons car cdr } ;
|
||||
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
|
||||
|
||||
HELP: llength
|
||||
{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
|
||||
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
|
||||
{ $see-also lnth 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." } ;
|
||||
|
||||
{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
|
||||
|
||||
HELP: leach
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
|
||||
{ $description "Call the quotation for each item in the list." } ;
|
||||
|
||||
HELP: lreduce
|
||||
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
|
||||
{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
|
||||
|
||||
HELP: lmap
|
||||
HELP: lazy-map
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- 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 <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
|
||||
|
||||
HELP: lmap-with
|
||||
HELP: lazy-map-with
|
||||
{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
|
||||
{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
|
||||
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
|
||||
|
||||
HELP: ltake
|
||||
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
|
||||
|
|
@ -147,6 +85,8 @@ HELP: >list
|
|||
{ $values { "object" "an object" } { "list" "a list" } }
|
||||
{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
|
||||
{ $see-also seq>list } ;
|
||||
|
||||
{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
|
||||
|
||||
HELP: lconcat
|
||||
{ $values { "list" "a list of lists" } { "result" "a list" } }
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006 Matthew Willis and Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: lazy-lists tools.test kernel math io sequences ;
|
||||
IN: lazy-lists.tests
|
||||
USING: lists lists.lazy tools.test kernel math io sequences ;
|
||||
IN: lists.lazy.tests
|
||||
|
||||
[ { 1 2 3 4 } ] [
|
||||
{ 1 2 3 4 } >list list>array
|
||||
|
|
@ -25,5 +25,5 @@ IN: lazy-lists.tests
|
|||
] unit-test
|
||||
|
||||
[ { 4 5 6 } ] [
|
||||
3 { 1 2 3 } >list [ + ] lmap-with list>array
|
||||
3 { 1 2 3 } >list [ + ] lazy-map-with list>array
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,394 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
! Updated by James Cash, June 2008
|
||||
!
|
||||
USING: kernel sequences math vectors arrays namespaces
|
||||
quotations promises combinators io lists accessors ;
|
||||
IN: lists.lazy
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
force car ;
|
||||
|
||||
M: promise cdr ( promise -- cdr )
|
||||
force cdr ;
|
||||
|
||||
M: promise nil? ( cons -- bool )
|
||||
force nil? ;
|
||||
|
||||
! Both 'car' and 'cdr' are promises
|
||||
TUPLE: lazy-cons car cdr ;
|
||||
|
||||
: lazy-cons ( car cdr -- promise )
|
||||
[ promise ] bi@ \ lazy-cons boa
|
||||
T{ promise f f t f } clone
|
||||
[ set-promise-value ] keep ;
|
||||
|
||||
M: lazy-cons car ( lazy-cons -- car )
|
||||
car>> force ;
|
||||
|
||||
M: lazy-cons cdr ( lazy-cons -- cdr )
|
||||
cdr>> force ;
|
||||
|
||||
M: lazy-cons nil? ( lazy-cons -- bool )
|
||||
nil eq? ;
|
||||
|
||||
: 1lazy-list ( a -- lazy-cons )
|
||||
[ nil ] lazy-cons ;
|
||||
|
||||
: 2lazy-list ( a b -- lazy-cons )
|
||||
1lazy-list 1quotation lazy-cons ;
|
||||
|
||||
: 3lazy-list ( a b c -- lazy-cons )
|
||||
2lazy-list 1quotation lazy-cons ;
|
||||
|
||||
TUPLE: memoized-cons original car cdr nil? ;
|
||||
|
||||
: not-memoized ( -- obj )
|
||||
{ } ;
|
||||
|
||||
: not-memoized? ( obj -- bool )
|
||||
not-memoized eq? ;
|
||||
|
||||
: <memoized-cons> ( cons -- memoized-cons )
|
||||
not-memoized not-memoized not-memoized
|
||||
memoized-cons boa ;
|
||||
|
||||
M: memoized-cons car ( memoized-cons -- car )
|
||||
dup car>> not-memoized? [
|
||||
dup original>> car [ >>car drop ] keep
|
||||
] [
|
||||
car>>
|
||||
] if ;
|
||||
|
||||
M: memoized-cons cdr ( memoized-cons -- cdr )
|
||||
dup cdr>> not-memoized? [
|
||||
dup original>> cdr [ >>cdr drop ] keep
|
||||
] [
|
||||
cdr>>
|
||||
] if ;
|
||||
|
||||
M: memoized-cons nil? ( memoized-cons -- bool )
|
||||
dup nil?>> not-memoized? [
|
||||
dup original>> nil? [ >>nil? drop ] keep
|
||||
] [
|
||||
nil?>>
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-map cons quot ;
|
||||
|
||||
C: <lazy-map> lazy-map
|
||||
|
||||
: lazy-map ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
|
||||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ cons>> car ] keep
|
||||
quot>> call ;
|
||||
|
||||
M: lazy-map cdr ( lazy-map -- cdr )
|
||||
[ cons>> cdr ] keep
|
||||
quot>> lazy-map ;
|
||||
|
||||
M: lazy-map nil? ( lazy-map -- bool )
|
||||
cons>> nil? ;
|
||||
|
||||
: lazy-map-with ( value list quot -- result )
|
||||
with lazy-map ;
|
||||
|
||||
TUPLE: lazy-take n cons ;
|
||||
|
||||
C: <lazy-take> lazy-take
|
||||
|
||||
: ltake ( n list -- result )
|
||||
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
|
||||
|
||||
M: lazy-take car ( lazy-take -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-take cdr ( lazy-take -- cdr )
|
||||
[ n>> 1- ] keep
|
||||
cons>> cdr ltake ;
|
||||
|
||||
M: lazy-take nil? ( lazy-take -- bool )
|
||||
dup n>> zero? [
|
||||
drop t
|
||||
] [
|
||||
cons>> nil?
|
||||
] if ;
|
||||
|
||||
TUPLE: lazy-until cons quot ;
|
||||
|
||||
C: <lazy-until> lazy-until
|
||||
|
||||
: luntil ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-until> ] if ;
|
||||
|
||||
M: lazy-until car ( lazy-until -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ cons>> uncons ] keep quot>> tuck call
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-while cons quot ;
|
||||
|
||||
C: <lazy-while> lazy-while
|
||||
|
||||
: lwhile ( list quot -- result )
|
||||
over nil? [ drop ] [ <lazy-while> ] if ;
|
||||
|
||||
M: lazy-while car ( lazy-while -- car )
|
||||
cons>> car ;
|
||||
|
||||
M: lazy-while cdr ( lazy-while -- cdr )
|
||||
[ cons>> cdr ] keep quot>> lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep quot>> call not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
C: <lazy-filter> lazy-filter
|
||||
|
||||
: lfilter ( list quot -- result )
|
||||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ cons>> car ] keep
|
||||
quot>> call ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
dup cons>> cdr >>cons ;
|
||||
|
||||
M: lazy-filter car ( lazy-filter -- car )
|
||||
dup car-filter? [ cons>> ] [ dup skip ] if car ;
|
||||
|
||||
M: lazy-filter cdr ( lazy-filter -- cdr )
|
||||
dup car-filter? [
|
||||
[ cons>> cdr ] keep
|
||||
quot>> lfilter
|
||||
] [
|
||||
dup skip cdr
|
||||
] if ;
|
||||
|
||||
M: lazy-filter nil? ( lazy-filter -- bool )
|
||||
dup cons>> nil? [
|
||||
drop t
|
||||
] [
|
||||
dup car-filter? [
|
||||
drop f
|
||||
] [
|
||||
dup skip nil?
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: list>vector ( list -- vector )
|
||||
[ [ , ] leach ] V{ } make ;
|
||||
|
||||
: list>array ( list -- array )
|
||||
[ [ , ] leach ] { } make ;
|
||||
|
||||
TUPLE: lazy-append list1 list2 ;
|
||||
|
||||
C: <lazy-append> lazy-append
|
||||
|
||||
: lappend ( list1 list2 -- result )
|
||||
over nil? [ nip ] [ <lazy-append> ] if ;
|
||||
|
||||
M: lazy-append car ( lazy-append -- car )
|
||||
list1>> car ;
|
||||
|
||||
M: lazy-append cdr ( lazy-append -- cdr )
|
||||
[ list1>> cdr ] keep
|
||||
list2>> lappend ;
|
||||
|
||||
M: lazy-append nil? ( lazy-append -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-from-by n quot ;
|
||||
|
||||
C: lfrom-by lazy-from-by ( n quot -- list )
|
||||
|
||||
: lfrom ( n -- list )
|
||||
[ 1+ ] lfrom-by ;
|
||||
|
||||
M: lazy-from-by car ( lazy-from-by -- car )
|
||||
n>> ;
|
||||
|
||||
M: lazy-from-by cdr ( lazy-from-by -- cdr )
|
||||
[ n>> ] keep
|
||||
quot>> dup slip lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: lazy-zip list1 list2 ;
|
||||
|
||||
C: <lazy-zip> lazy-zip
|
||||
|
||||
: lzip ( list1 list2 -- lazy-zip )
|
||||
over nil? over nil? or
|
||||
[ 2drop nil ] [ <lazy-zip> ] if ;
|
||||
|
||||
M: lazy-zip car ( lazy-zip -- car )
|
||||
[ list1>> car ] keep list2>> car 2array ;
|
||||
|
||||
M: lazy-zip cdr ( lazy-zip -- cdr )
|
||||
[ list1>> cdr ] keep list2>> cdr lzip ;
|
||||
|
||||
M: lazy-zip nil? ( lazy-zip -- bool )
|
||||
drop f ;
|
||||
|
||||
TUPLE: sequence-cons index seq ;
|
||||
|
||||
C: <sequence-cons> sequence-cons
|
||||
|
||||
: seq>list ( index seq -- list )
|
||||
2dup length >= [
|
||||
2drop nil
|
||||
] [
|
||||
<sequence-cons>
|
||||
] if ;
|
||||
|
||||
M: sequence-cons car ( sequence-cons -- car )
|
||||
[ index>> ] keep
|
||||
seq>> nth ;
|
||||
|
||||
M: sequence-cons cdr ( sequence-cons -- cdr )
|
||||
[ index>> 1+ ] keep
|
||||
seq>> seq>list ;
|
||||
|
||||
M: sequence-cons nil? ( sequence-cons -- bool )
|
||||
drop f ;
|
||||
|
||||
: >list ( object -- list )
|
||||
{
|
||||
{ [ dup sequence? ] [ 0 swap seq>list ] }
|
||||
{ [ dup list? ] [ ] }
|
||||
[ "Could not convert object to a list" throw ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-concat car cdr ;
|
||||
|
||||
C: <lazy-concat> lazy-concat
|
||||
|
||||
DEFER: lconcat
|
||||
|
||||
: (lconcat) ( car cdr -- list )
|
||||
over nil? [
|
||||
nip lconcat
|
||||
] [
|
||||
<lazy-concat>
|
||||
] if ;
|
||||
|
||||
: lconcat ( list -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
uncons swap (lconcat)
|
||||
] if ;
|
||||
|
||||
M: lazy-concat car ( lazy-concat -- car )
|
||||
car>> car ;
|
||||
|
||||
M: lazy-concat cdr ( lazy-concat -- cdr )
|
||||
[ car>> cdr ] keep cdr>> (lconcat) ;
|
||||
|
||||
M: lazy-concat nil? ( lazy-concat -- bool )
|
||||
dup car>> nil? [
|
||||
cdr>> nil?
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
|
||||
: lcartesian-product ( list1 list2 -- result )
|
||||
swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ;
|
||||
|
||||
: lcartesian-product* ( lists -- result )
|
||||
dup nil? [
|
||||
drop nil
|
||||
] [
|
||||
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
|
||||
swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat
|
||||
] reduce
|
||||
] if ;
|
||||
|
||||
: lcomp ( list quot -- result )
|
||||
[ lcartesian-product* ] dip lazy-map ;
|
||||
|
||||
: lcomp* ( list guards quot -- result )
|
||||
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
|
||||
|
||||
DEFER: lmerge
|
||||
|
||||
: (lmerge) ( list1 list2 -- result )
|
||||
over [ car ] curry -rot
|
||||
[
|
||||
dup [ car ] curry -rot
|
||||
[
|
||||
[ cdr ] bi@ lmerge
|
||||
] 2curry lazy-cons
|
||||
] 2curry lazy-cons ;
|
||||
|
||||
: lmerge ( list1 list2 -- result )
|
||||
{
|
||||
{ [ over nil? ] [ nip ] }
|
||||
{ [ dup nil? ] [ drop ] }
|
||||
{ [ t ] [ (lmerge) ] }
|
||||
} cond ;
|
||||
|
||||
TUPLE: lazy-io stream car cdr quot ;
|
||||
|
||||
C: <lazy-io> lazy-io
|
||||
|
||||
: lcontents ( stream -- result )
|
||||
f f [ stream-read1 ] <lazy-io> ;
|
||||
|
||||
: llines ( stream -- result )
|
||||
f f [ stream-readln ] <lazy-io> ;
|
||||
|
||||
M: lazy-io car ( lazy-io -- car )
|
||||
dup car>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup stream>> over quot>> call
|
||||
swap dupd set-lazy-io-car
|
||||
] if ;
|
||||
|
||||
M: lazy-io cdr ( lazy-io -- cdr )
|
||||
dup cdr>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup
|
||||
[ stream>> ] keep
|
||||
[ quot>> ] keep
|
||||
car [
|
||||
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
|
||||
] [
|
||||
3drop nil
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: lazy-io nil? ( lazy-io -- bool )
|
||||
car not ;
|
||||
|
||||
INSTANCE: sequence-cons list
|
||||
INSTANCE: memoized-cons list
|
||||
INSTANCE: promise list
|
||||
INSTANCE: lazy-io list
|
||||
INSTANCE: lazy-concat list
|
||||
INSTANCE: lazy-cons list
|
||||
INSTANCE: lazy-map list
|
||||
INSTANCE: lazy-take list
|
||||
INSTANCE: lazy-append list
|
||||
INSTANCE: lazy-from-by list
|
||||
INSTANCE: lazy-zip list
|
||||
INSTANCE: lazy-while list
|
||||
INSTANCE: lazy-until list
|
||||
INSTANCE: lazy-filter list
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: lists
|
||||
|
||||
{ car cons cdr nil nil? list? uncons } related-words
|
||||
|
||||
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." } ;
|
||||
|
||||
HELP: car
|
||||
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
|
||||
{ $description "Returns the first item in the list." } ;
|
||||
|
||||
HELP: cdr
|
||||
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
|
||||
{ $description "Returns the tail of the list." } ;
|
||||
|
||||
HELP: nil
|
||||
{ $values { "cons" "An empty cons" } }
|
||||
{ $description "Returns a representation of an empty list" } ;
|
||||
|
||||
HELP: nil?
|
||||
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
|
||||
{ $description "Return true if the cons object is the nil cons." } ;
|
||||
|
||||
HELP: list? ( object -- ? )
|
||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the object conforms to the list protocol." } ;
|
||||
|
||||
{ 1list 2list 3list } related-words
|
||||
|
||||
HELP: 1list
|
||||
{ $values { "obj" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 1 element." } ;
|
||||
|
||||
HELP: 2list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 2 elements." } ;
|
||||
|
||||
HELP: 3list
|
||||
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
|
||||
{ $description "Create a list with 3 elements." } ;
|
||||
|
||||
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 llength cons car cdr } ;
|
||||
|
||||
HELP: llength
|
||||
{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
|
||||
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
|
||||
{ $see-also lnth 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." } ;
|
||||
|
||||
{ leach lreduce lmap>array } related-words
|
||||
|
||||
HELP: leach
|
||||
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
|
||||
{ $description "Call the quotation for each item in the list." } ;
|
||||
|
||||
HELP: lreduce
|
||||
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
|
||||
{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
|
||||
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test lists math ;
|
||||
|
||||
IN: lists.tests
|
||||
|
||||
{ { 3 4 5 6 } } [
|
||||
T{ cons f 1
|
||||
T{ cons f 2
|
||||
T{ cons f 3
|
||||
T{ cons f 4
|
||||
+nil+ } } } } [ 2 + ] lmap>array
|
||||
] unit-test
|
||||
|
||||
{ 10 } [
|
||||
T{ cons f 1
|
||||
T{ cons f 2
|
||||
T{ cons f 3
|
||||
T{ cons f 4
|
||||
+nil+ } } } } 0 [ + ] lreduce
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f
|
||||
1
|
||||
T{ cons f
|
||||
2
|
||||
T{ cons f
|
||||
T{ cons f
|
||||
3
|
||||
T{ cons f
|
||||
4
|
||||
T{ cons f
|
||||
T{ cons f 5 +nil+ }
|
||||
+nil+ } } }
|
||||
+nil+ } } }
|
||||
} [
|
||||
{ 1 2 { 3 4 { 5 } } } seq>cons
|
||||
] unit-test
|
||||
|
||||
{ { 1 2 { 3 4 { 5 } } } } [
|
||||
{ 1 2 { 3 4 { 5 } } } seq>cons cons>seq
|
||||
] unit-test
|
||||
|
||||
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
|
||||
{ 1 2 3 4 } seq>cons [ 1+ ] lmap
|
||||
] unit-test
|
||||
|
||||
! { { 3 4 { 5 6 { 7 } } } } [
|
||||
! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq
|
||||
! ] unit-test
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
! Copyright (C) 2008 Chris Double & James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors math arrays vectors classes words ;
|
||||
|
||||
IN: lists
|
||||
|
||||
! List Protocol
|
||||
MIXIN: list
|
||||
GENERIC: car ( cons -- car )
|
||||
GENERIC: cdr ( cons -- cdr )
|
||||
GENERIC: nil? ( cons -- ? )
|
||||
|
||||
TUPLE: cons car cdr ;
|
||||
|
||||
C: cons cons
|
||||
|
||||
M: cons car ( cons -- car )
|
||||
car>> ;
|
||||
|
||||
M: cons cdr ( cons -- cdr )
|
||||
cdr>> ;
|
||||
|
||||
SYMBOL: +nil+
|
||||
M: word nil? +nil+ eq? ;
|
||||
M: object nil? drop f ;
|
||||
|
||||
: nil ( -- +nil+ ) +nil+ ;
|
||||
|
||||
: uncons ( cons -- cdr car )
|
||||
[ cdr ] [ car ] bi ;
|
||||
|
||||
: 1list ( obj -- cons )
|
||||
nil cons ;
|
||||
|
||||
: 2list ( a b -- cons )
|
||||
nil cons cons ;
|
||||
|
||||
: 3list ( a b c -- cons )
|
||||
nil cons cons cons ;
|
||||
|
||||
: 2car ( cons -- car caar )
|
||||
[ car ] [ cdr car ] bi ;
|
||||
|
||||
: 3car ( cons -- car caar caaar )
|
||||
[ car ] [ cdr car ] [ cdr cdr car ] tri ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
swap [ cdr ] times car ;
|
||||
|
||||
: (llength) ( list acc -- n )
|
||||
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
|
||||
|
||||
: llength ( list -- n )
|
||||
0 (llength) ;
|
||||
|
||||
: leach ( list quot -- )
|
||||
over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline
|
||||
|
||||
: lreduce ( list identity quot -- result )
|
||||
swapd leach ; inline
|
||||
|
||||
: (lmap>array) ( acc cons quot -- newcons )
|
||||
over nil? [ 2drop ]
|
||||
[ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
|
||||
|
||||
: lmap>array ( cons quot -- newcons )
|
||||
{ } -rot (lmap>array) ; inline
|
||||
|
||||
: lmap-as ( cons quot exemplar -- seq )
|
||||
[ lmap>array ] dip like ;
|
||||
|
||||
: lmap ( list quot -- newlist )
|
||||
lmap>array <reversed> nil [ swap cons ] reduce ;
|
||||
|
||||
: same? ( obj1 obj2 -- ? )
|
||||
[ class ] bi@ = ;
|
||||
|
||||
: seq>cons ( seq -- cons )
|
||||
[ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
|
||||
|
||||
: cons>seq ( cons -- array )
|
||||
[ dup cons? [ cons>seq ] when ] lmap>array ;
|
||||
|
||||
: traverse ( list quot -- newlist )
|
||||
[ over list? [ traverse ] [ call ] if ] curry lmap ;
|
||||
|
||||
INSTANCE: cons list
|
||||
|
|
@ -0,0 +1 @@
|
|||
Implementation of lisp-style linked lists
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
cons
|
||||
lists
|
||||
sequences
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists math.erato tools.test ;
|
||||
USING: lists.lazy math.erato tools.test ;
|
||||
IN: math.erato.tests
|
||||
|
||||
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
|
||||
USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
|
||||
math.ranges sequences ;
|
||||
IN: math.erato
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
|
||||
USING: arrays kernel lists math math.primes namespaces sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -17,7 +17,7 @@ IN: math.primes.factors
|
|||
dup empty? [ drop ] [ first , ] if ;
|
||||
|
||||
: (factors) ( quot list n -- )
|
||||
dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
|
||||
dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
|
||||
|
||||
: (decompose) ( n quot -- seq )
|
||||
[ lprimes rot (factors) ] { } make ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: arrays math.primes tools.test lazy-lists ;
|
||||
USING: arrays math.primes tools.test lists.lazy ;
|
||||
|
||||
{ 1237 } [ 1234 next-prime ] unit-test
|
||||
{ f t } [ 1234 prime? 1237 prime? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel lazy-lists math math.functions math.miller-rabin
|
||||
USING: combinators kernel lists.lazy math math.functions math.miller-rabin
|
||||
math.order math.primes.list math.ranges sequences sorting ;
|
||||
IN: math.primes
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test monads math kernel sequences lazy-lists promises ;
|
||||
USING: tools.test monads math kernel sequences lists promises ;
|
||||
IN: monads.tests
|
||||
|
||||
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel sequences sequences.deep splitting
|
||||
accessors fry locals combinators namespaces lazy-lists
|
||||
accessors fry locals combinators namespaces lists lists.lazy
|
||||
shuffle ;
|
||||
IN: monads
|
||||
|
||||
|
|
@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ;
|
|||
|
||||
M: list monad-of drop list-monad ;
|
||||
|
||||
M: list >>= '[ , _ lmap lconcat ] ;
|
||||
M: list >>= '[ , _ lazy-map lconcat ] ;
|
||||
|
||||
! State
|
||||
SINGLETON: state-monad
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
|
||||
USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
|
||||
IN: morse
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -23,4 +23,4 @@ HELP: any-char-parser
|
|||
"from the input string. The value consumed is the "
|
||||
"result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel lazy-lists tools.test strings math
|
||||
USING: kernel lists.lazy tools.test strings math
|
||||
sequences parser-combinators arrays math.parser unicode.categories ;
|
||||
IN: parser-combinators.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists promises kernel sequences strings math
|
||||
USING: lists lists.lazy promises kernel sequences strings math
|
||||
arrays splitting quotations combinators namespaces
|
||||
unicode.case unicode.categories sequences.deep ;
|
||||
IN: parser-combinators
|
||||
|
|
@ -147,8 +147,8 @@ TUPLE: and-parser parsers ;
|
|||
>r parse-result-parsed r>
|
||||
[ parse-result-parsed 2array ] keep
|
||||
parse-result-unparsed <parse-result>
|
||||
] lmap-with
|
||||
] lmap-with lconcat ;
|
||||
] lazy-map-with
|
||||
] lazy-map-with lconcat ;
|
||||
|
||||
M: and-parser parse ( input parser -- list )
|
||||
#! Parse 'input' by sequentially combining the
|
||||
|
|
@ -171,7 +171,7 @@ M: or-parser parse ( input parser1 -- list )
|
|||
#! of parser1 and parser2 being applied to the same
|
||||
#! input. This implements the choice parsing operator.
|
||||
or-parser-parsers 0 swap seq>list
|
||||
[ parse ] lmap-with lconcat ;
|
||||
[ parse ] lazy-map-with lconcat ;
|
||||
|
||||
: left-trim-slice ( string -- string )
|
||||
#! Return a new string without any leading whitespace
|
||||
|
|
@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result )
|
|||
-rot parse [
|
||||
[ parse-result-parsed swap call ] keep
|
||||
parse-result-unparsed <parse-result>
|
||||
] lmap-with ;
|
||||
] lazy-map-with ;
|
||||
|
||||
TUPLE: some-parser p1 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ HELP: 'digit'
|
|||
"the input string. The numeric value of the digit "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
|
||||
|
||||
HELP: 'integer'
|
||||
{ $values
|
||||
|
|
@ -21,7 +21,7 @@ HELP: 'integer'
|
|||
"the input string. The numeric value of the integer "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
|
||||
HELP: 'string'
|
||||
{ $values
|
||||
{ "parser" "a parser object" } }
|
||||
|
|
@ -30,7 +30,7 @@ HELP: 'string'
|
|||
"quotations from the input string. The string value "
|
||||
" consumed is the result of the parse." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
|
||||
|
||||
HELP: 'bold'
|
||||
{ $values
|
||||
|
|
@ -62,6 +62,6 @@ HELP: comma-list
|
|||
"'element' should be a parser that can parse the elements. The "
|
||||
"result of the parser is a sequence of the parsed elements." }
|
||||
{ $examples
|
||||
{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
|
||||
{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
|
||||
|
||||
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings math sequences lazy-lists words
|
||||
USING: kernel strings math sequences lists.lazy words
|
||||
math.parser promises parser-combinators unicode.categories ;
|
||||
IN: parser-combinators.simple
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lazy-lists math math.primes ;
|
||||
USING: lists math math.primes ;
|
||||
IN: project-euler.007
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=7
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lazy-lists math.algebra math math.functions
|
||||
USING: arrays kernel lists lists.lazy math.algebra math math.functions
|
||||
math.order math.primes math.ranges project-euler.common sequences ;
|
||||
IN: project-euler.134
|
||||
|
||||
|
|
@ -39,7 +39,7 @@ IN: project-euler.134
|
|||
PRIVATE>
|
||||
|
||||
: euler134 ( -- answer )
|
||||
0 5 lprimes-from uncons [ 1000000 > ] luntil
|
||||
0 5 lprimes-from uncons swap [ 1000000 > ] luntil
|
||||
[ [ s + ] keep ] leach drop ;
|
||||
|
||||
! [ euler134 ] 10 ave-time
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: arrays combinators kernel lazy-lists math math.parser
|
||||
USING: arrays combinators kernel lists math math.parser
|
||||
namespaces parser parser-combinators parser-combinators.simple
|
||||
promises quotations sequences combinators.lib strings math.order
|
||||
assocs prettyprint.backend memoize unicode.case unicode.categories ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences math math.functions tetris.board
|
||||
tetris.piece tetris.tetromino lazy-lists combinators system ;
|
||||
tetris.piece tetris.tetromino lists combinators system ;
|
||||
IN: tetris.game
|
||||
|
||||
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays tetris.tetromino math math.vectors
|
||||
sequences quotations lazy-lists ;
|
||||
sequences quotations lists.lazy ;
|
||||
IN: tetris.piece
|
||||
|
||||
#! A piece adds state to the tetromino that is the piece's delegate. The
|
||||
|
|
|
|||
|
|
@ -94,6 +94,10 @@
|
|||
"SYMBOLS:"
|
||||
))
|
||||
|
||||
(defun factor-indent-line ()
|
||||
"Indent current line as Factor code"
|
||||
(indent-line-to (+ (current-indentation) 4)))
|
||||
|
||||
(defun factor-mode ()
|
||||
"A mode for editing programs written in the Factor programming language."
|
||||
(interactive)
|
||||
|
|
@ -107,6 +111,8 @@
|
|||
(setq font-lock-defaults
|
||||
'(factor-font-lock-keywords nil nil nil nil))
|
||||
(set-syntax-table factor-mode-syntax-table)
|
||||
(make-local-variable 'indent-line-function)
|
||||
(setq indent-line-function 'factor-indent-line)
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
|
|
|
|||
Loading…
Reference in New Issue