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

2
extra/globs/globs.factor
View File

@ -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
extra/json/reader/reader.factor
View File

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

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

108
extra/lisp/lisp.factor
View File

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

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

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

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

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

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

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.
! 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" } }

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.
! 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

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.
! 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

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

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

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

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

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
{ 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.
! 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

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
[ 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
! 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

2
extra/morse/morse.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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
promises quotations sequences combinators.lib strings math.order
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
! 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? ;

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

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

6
misc/factor.el
View File

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