steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/jamesnvc

db4
Slava Pestov 2008-06-04 21:54:10 -05:00
parent 9861146d8d bb050c9f4c
commit 8ef7f4d904
42 changed files with 779 additions and 619 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/globs/globs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; promises strings unicode.case ;
IN: globs IN: globs

2
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order assocs math math.parser math.vectors math.functions math.order
lazy-lists hashtables ascii ; lists hashtables ascii ;
IN: json.reader IN: json.reader
! Grammar for JSON from RFC 4627 ! Grammar for JSON from RFC 4627

445
extra/lazy-lists/lazy-lists.factor
View File

@ -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

27
extra/lisp/lisp-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: lisp.test
@ -10,8 +10,10 @@ IN: lisp.test
"#f" [ f ] lisp-define "#f" [ f ] lisp-define
"#t" [ t ] lisp-define "#t" [ t ] lisp-define
"+" "math" "+" define-primitve "+" "math" "+" define-primitive
"-" "math" "-" define-primitve "-" "math" "-" define-primitive
! "list" [ >array ] lisp-define
{ 5 } [ { 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall [ 2 3 ] "+" <lisp-symbol> funcall
@ -22,26 +24,31 @@ IN: lisp.test
] unit-test ] unit-test
{ 3 } [ { 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call "((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test ] unit-test
{ 42 } [ { 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 ] unit-test
{ 1 } [ { 1 } [
"(if #t 1 2)" lisp-string>factor call "(if #t 1 2)" lisp-eval
] unit-test ] unit-test
{ "b" } [ { "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call "(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test ] unit-test
{ 5 } [ { 5 } [
"(begin (+ 1 4))" lisp-string>factor call "(begin (+ 1 4))" lisp-eval
] unit-test ] unit-test
{ 3 } [ { 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 ] unit-test
] with-interactive-vocabs
! { { 1 2 3 4 5 } } [
! "(list 1 2 3 4 5)" lisp-eval
! ] unit-test
] with-interactive-vocabs

108
extra/lisp/lisp.factor
View File

@ -1,48 +1,51 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib 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 vectors syntax lisp.parser assocs parser sequences.lib words quotations
fry ; fry lists inspector ;
IN: lisp IN: lisp
DEFER: convert-form DEFER: convert-form
DEFER: funcall DEFER: funcall
DEFER: lookup-var DEFER: lookup-var
DEFER: lisp-macro?
DEFER: lookup-macro
DEFER: macro-call
! Functions to convert s-exps to quotations ! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot ) : convert-body ( cons -- quot )
[ ] [ convert-form compose ] reduce ; inline [ ] [ convert-form compose ] lreduce ; inline
: convert-if ( s-exp -- quot ) : convert-if ( cons -- quot )
rest first3 [ convert-form ] tri@ '[ @ , , if ] ; cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
: convert-begin ( s-exp -- quot ) : convert-begin ( cons -- quot )
rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
: convert-cond ( s-exp -- quot ) : convert-cond ( cons -- quot )
rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
{ } map-as '[ , cond ] ; { } lmap-as '[ , cond ] ;
: convert-general-form ( s-exp -- quot ) : convert-general-form ( cons -- quot )
unclip convert-form swap convert-body swap '[ , @ funcall ] ; uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
! words for convert-lambda ! words for convert-lambda
<PRIVATE <PRIVATE
: localize-body ( assoc body -- assoc newbody ) : localize-body ( assoc body -- assoc newbody )
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if [ dup cons? [ localize-body ] when nip ] if
] map ; ] with lmap>array ;
: localize-lambda ( body vars -- newbody newvars ) : localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap 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 ) : split-lambda ( cons -- body-cons vars-seq )
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline 3car -rot nip [ name>> ] lmap>array ; inline
: rest-lambda ( body vars -- quot ) : rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi "&rest" swap [ index ] [ remove ] 2bi
localize-lambda <lambda> localize-lambda <lambda>
'[ , cut '[ @ , ] , compose ] ; '[ , cut '[ @ , ] , compose ] ;
@ -51,46 +54,63 @@ DEFER: lookup-var
localize-lambda <lambda> '[ , compose ] ; localize-lambda <lambda> '[ , compose ] ;
PRIVATE> PRIVATE>
: convert-lambda ( s-exp -- quot ) : convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
: convert-quoted ( s-exp -- quot ) : convert-quoted ( cons -- quot )
second 1quotation ; cdr 1quotation ;
: convert-list-form ( s-exp -- quot ) : form-dispatch ( lisp-symbol -- quot )
dup first dup lisp-symbol? name>>
[ name>> { { "lambda" [ convert-lambda ] }
{ { "lambda" [ convert-lambda ] } { "quote" [ convert-quoted ] }
{ "quote" [ convert-quoted ] } { "if" [ convert-if ] }
{ "if" [ convert-if ] } { "begin" [ convert-begin ] }
{ "begin" [ convert-begin ] } { "cond" [ convert-cond ] }
{ "cond" [ convert-cond ] } [ drop convert-general-form ]
[ drop convert-general-form ] } case ;
} case ]
[ drop convert-general-form ] if ; : 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 ) : convert-form ( lisp-form -- quot )
{ { [ dup s-exp? ] [ body>> convert-list-form ] } {
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } { [ dup cons? ] [ convert-list-form ] }
[ 1quotation ] { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ]
} cond ; } cond ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ; lisp-expr parse-result-ast convert-form lambda-rewrite call ;
: lisp-eval ( str -- * )
lisp-string>factor call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env SYMBOL: lisp-env
ERROR: no-such-var var ; ERROR: no-such-var var ;
SYMBOL: macro-env
M: no-such-var summary drop "No such variable" ;
: init-env ( -- ) : init-env ( -- )
H{ } clone lisp-env set ; H{ } clone lisp-env set
H{ } clone macro-env set ;
: lisp-define ( name quot -- ) : lisp-define ( name quot -- )
swap lisp-env get set-at ; swap lisp-env get set-at ;
: lisp-get ( name -- word ) : 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 ) : lookup-var ( lisp-symbol -- quot )
name>> lisp-get ; name>> lisp-get ;
@ -98,5 +118,11 @@ ERROR: no-such-var var ;
: funcall ( quot sym -- * ) : funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline dup lisp-symbol? [ lookup-var ] when call ; inline
: define-primitve ( name vocab word -- ) : define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] lisp-define ; 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 ;

46
extra/lisp/parser/parser-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: lisp.parser.tests
@ -9,38 +9,60 @@ IN: lisp.parser.tests
] unit-test ] unit-test
{ -42 } [ { -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast "-42" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ 37/52 } [ { 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast "37/52" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ 123.98 } [ { 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast "123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ "" } [ { "" } [
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast "\"\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ "aoeu" } [ { "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ "aoeu\"de" } [ { "aoeu\"de" } [
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ T{ lisp-symbol f "foobar" } } [ { 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 ] unit-test
{ T{ lisp-symbol f "+" } } [ { T{ lisp-symbol f "+" } } [
"+" "atom" \ lisp-expr rule parse parse-result-ast "+" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test
{ T{ s-exp f { +nil+ } [
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [ "()" lisp-expr parse-result-ast
"(foo 1 2 \"aoeu\")" 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 ] unit-test

16
extra/lisp/parser/parser.factor
View File

@ -1,16 +1,13 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib math ; combinators.lib math fry accessors lists ;
IN: lisp.parser IN: lisp.parser
TUPLE: lisp-symbol name ; TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol C: <lisp-symbol> lisp-symbol
TUPLE: s-exp body ;
C: <s-exp> s-exp
EBNF: lisp-expr EBNF: lisp-expr
_ = (" " | "\t" | "\n")* _ = (" " | "\t" | "\n")*
LPAREN = "(" LPAREN = "("
@ -24,8 +21,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string
number = float number = float
| rational | rational
| integer | integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#" id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" | "<" | "#" | " =" | ">" | "?" | "^" | "_"
| "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]] letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials initials = letters | id-specials
numbers = [0-9] => [[ 1array >string ]] numbers = [0-9] => [[ 1array >string ]]
@ -36,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
atom = number atom = number
| identifier | identifier
| string | string
list-item = _ (atom|s-expression) _ => [[ second ]] list-item = _ ( atom | s-expression ) _ => [[ second ]]
s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]] s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
;EBNF ;EBNF

1
extra/lists/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

0
extra/lazy-lists/authors.txt → extra/lists/lazy/authors.txt
View File

0
extra/lazy-lists/examples/authors.txt → extra/lists/lazy/examples/authors.txt
View File

0
extra/lazy-lists/examples/examples-tests.factor → extra/lists/lazy/examples/examples-tests.factor
View File

2
extra/lazy-lists/examples/examples.factor → extra/lists/lazy/examples/examples.factor
View File

@ -11,5 +11,5 @@ IN: lazy-lists.examples
: odds 1 lfrom [ 2 mod 1 = ] lfilter ; : odds 1 lfrom [ 2 mod 1 = ] lfilter ;
: powers-of-2 1 [ 2 * ] lfrom-by ; : powers-of-2 1 [ 2 * ] lfrom-by ;
: ones 1 [ ] lfrom-by ; : ones 1 [ ] lfrom-by ;
: squares naturals [ dup * ] lmap ; : squares naturals [ dup * ] lazy-map ;
: first-five-squares 5 squares ltake list>array ; : first-five-squares 5 squares ltake list>array ;

76
extra/lazy-lists/lazy-lists-docs.factor → extra/lists/lazy/lazy-docs.factor
View File

@ -1,48 +1,8 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences strings ; USING: help.markup help.syntax sequences strings lists ;
IN: lazy-lists IN: lists.lazy
{ 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: lazy-cons HELP: lazy-cons
{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } } { $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." } { $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? } ; { $see-also cons car cdr nil nil? } ;
HELP: lnth { lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
{ $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 HELP: lazy-map
{ $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
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $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." } ; { $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" } } { $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 HELP: ltake
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $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" } } { $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." } { $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 } ; { $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 HELP: lconcat
{ $values { "list" "a list of lists" } { "result" "a list" } } { $values { "list" "a list of lists" } { "result" "a list" } }

6
extra/lazy-lists/lazy-lists-tests.factor → extra/lists/lazy/lazy-tests.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Matthew Willis and Chris Double. ! Copyright (C) 2006 Matthew Willis and Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: lazy-lists tools.test kernel math io sequences ; USING: lists lists.lazy tools.test kernel math io sequences ;
IN: lazy-lists.tests IN: lists.lazy.tests
[ { 1 2 3 4 } ] [ [ { 1 2 3 4 } ] [
{ 1 2 3 4 } >list list>array { 1 2 3 4 } >list list>array
@ -25,5 +25,5 @@ IN: lazy-lists.tests
] unit-test ] unit-test
[ { 4 5 6 } ] [ [ { 4 5 6 } ] [
3 { 1 2 3 } >list [ + ] lmap-with list>array 3 { 1 2 3 } >list [ + ] lazy-map-with list>array
] unit-test ] unit-test

394
extra/lists/lazy/lazy.factor Normal file
View File

@ -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
extra/lazy-lists/old-doc.html → extra/lists/lazy/old-doc.html
View File

0
extra/lazy-lists/summary.txt → extra/lists/lazy/summary.txt
View File

0
extra/lazy-lists/tags.txt → extra/lists/lazy/tags.txt
View File

70
extra/lists/lists-docs.factor Normal file
View File

@ -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." } ;

50
extra/lists/lists-tests.factor Normal file
View File

@ -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

87
extra/lists/lists.factor Normal file
View File

@ -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

1
extra/lists/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation of lisp-style linked lists

3
extra/lists/tags.txt Normal file
View File

@ -0,0 +1,3 @@
cons
lists
sequences

2
extra/math/erato/erato-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu. ! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: math.erato.tests
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test

2
extra/math/erato/erato.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu. ! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; math.ranges sequences ;
IN: math.erato IN: math.erato

4
extra/math/primes/factors/factors.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Samuel Tardieu. ! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: math.primes.factors
<PRIVATE <PRIVATE
@ -17,7 +17,7 @@ IN: math.primes.factors
dup empty? [ drop ] [ first , ] if ; dup empty? [ drop ] [ first , ] if ;
: (factors) ( quot list n -- ) : (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 ) : (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ; [ lprimes rot (factors) ] { } make ;

2
extra/math/primes/primes-tests.factor
View File

@ -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 { 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test

2
extra/math/primes/primes.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Samuel Tardieu. ! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; math.order math.primes.list math.ranges sequences sorting ;
IN: math.primes IN: math.primes

2
extra/monads/monads-tests.factor
View File

@ -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 IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test

4
extra/monads/monads.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences sequences.deep splitting USING: arrays kernel sequences sequences.deep splitting
accessors fry locals combinators namespaces lazy-lists accessors fry locals combinators namespaces lists lists.lazy
shuffle ; shuffle ;
IN: monads IN: monads
@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ;
M: list monad-of drop list-monad ; M: list monad-of drop list-monad ;
M: list >>= '[ , _ lmap lconcat ] ; M: list >>= '[ , _ lazy-map lconcat ] ;
! State ! State
SINGLETON: state-monad SINGLETON: state-monad

2
extra/morse/morse.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Alex Chapman ! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: morse
<PRIVATE <PRIVATE

2
extra/parser-combinators/parser-combinators-docs.factor
View File

@ -23,4 +23,4 @@ HELP: any-char-parser
"from the input string. The value consumed is the " "from the input string. The value consumed is the "
"result of the parse." } "result of the parse." }
{ $examples { $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" } } ;

2
extra/parser-combinators/parser-combinators-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005 Chris Double. ! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; sequences parser-combinators arrays math.parser unicode.categories ;
IN: parser-combinators.tests IN: parser-combinators.tests

10
extra/parser-combinators/parser-combinators.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! 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 arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ; unicode.case unicode.categories sequences.deep ;
IN: parser-combinators IN: parser-combinators
@ -147,8 +147,8 @@ TUPLE: and-parser parsers ;
>r parse-result-parsed r> >r parse-result-parsed r>
[ parse-result-parsed 2array ] keep [ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ] lazy-map-with
] lmap-with lconcat ; ] lazy-map-with lconcat ;
M: and-parser parse ( input parser -- list ) M: and-parser parse ( input parser -- list )
#! Parse 'input' by sequentially combining the #! 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 #! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator. #! input. This implements the choice parsing operator.
or-parser-parsers 0 swap seq>list or-parser-parsers 0 swap seq>list
[ parse ] lmap-with lconcat ; [ parse ] lazy-map-with lconcat ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result )
-rot parse [ -rot parse [
[ parse-result-parsed swap call ] keep [ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result> parse-result-unparsed <parse-result>
] lmap-with ; ] lazy-map-with ;
TUPLE: some-parser p1 ; TUPLE: some-parser p1 ;

8
extra/parser-combinators/simple/simple-docs.factor
View File

@ -11,7 +11,7 @@ HELP: 'digit'
"the input string. The numeric value of the digit " "the input string. The numeric value of the digit "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $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' HELP: 'integer'
{ $values { $values
@ -21,7 +21,7 @@ HELP: 'integer'
"the input string. The numeric value of the integer " "the input string. The numeric value of the integer "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $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' HELP: 'string'
{ $values { $values
{ "parser" "a parser object" } } { "parser" "a parser object" } }
@ -30,7 +30,7 @@ HELP: 'string'
"quotations from the input string. The string value " "quotations from the input string. The string value "
" consumed is the result of the parse." } " consumed is the result of the parse." }
{ $examples { $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' HELP: 'bold'
{ $values { $values
@ -62,6 +62,6 @@ HELP: comma-list
"'element' should be a parser that can parse the elements. The " "'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." } "result of the parser is a sequence of the parsed elements." }
{ $examples { $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 { $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words

2
extra/parser-combinators/simple/simple.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple IN: parser-combinators.simple

2
extra/project-euler/007/007.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer. ! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists math math.primes ; USING: lists math math.primes ;
IN: project-euler.007 IN: project-euler.007
! http://projecteuler.net/index.php?section=problems&id=7 ! http://projecteuler.net/index.php?section=problems&id=7

4
extra/project-euler/134/134.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu. ! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; math.order math.primes math.ranges project-euler.common sequences ;
IN: project-euler.134 IN: project-euler.134
@ -39,7 +39,7 @@ IN: project-euler.134
PRIVATE> PRIVATE>
: euler134 ( -- answer ) : euler134 ( -- answer )
0 5 lprimes-from uncons [ 1000000 > ] luntil 0 5 lprimes-from uncons swap [ 1000000 > ] luntil
[ [ s + ] keep ] leach drop ; [ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time ! [ euler134 ] 10 ave-time

2
extra/regexp/regexp.factor
View File

@ -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 namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories ; assocs prettyprint.backend memoize unicode.case unicode.categories ;

2
extra/tetris/game/game.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Alex Chapman ! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math math.functions tetris.board 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 IN: tetris.game
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ; TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;

2
extra/tetris/piece/piece.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Alex Chapman ! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays tetris.tetromino math math.vectors USING: kernel arrays tetris.tetromino math math.vectors
sequences quotations lazy-lists ; sequences quotations lists.lazy ;
IN: tetris.piece IN: tetris.piece
#! A piece adds state to the tetromino that is the piece's delegate. The #! A piece adds state to the tetromino that is the piece's delegate. The

6
misc/factor.el
View File

@ -94,6 +94,10 @@
"SYMBOLS:" "SYMBOLS:"
)) ))
(defun factor-indent-line ()
"Indent current line as Factor code"
(indent-line-to (+ (current-indentation) 4)))
(defun factor-mode () (defun factor-mode ()
"A mode for editing programs written in the Factor programming language." "A mode for editing programs written in the Factor programming language."
(interactive) (interactive)
@ -107,6 +111,8 @@
(setq font-lock-defaults (setq font-lock-defaults
'(factor-font-lock-keywords nil nil nil nil)) '(factor-font-lock-keywords nil nil nil nil))
(set-syntax-table factor-mode-syntax-table) (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)) (run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))