Merge branch 'master' of factorcode.org:/git/factor
Conflicts: extra/bake/bake.factordb4
Eduardo Cavazos
commit
515dfd3ef2
2
Makefile
2
Makefile
|
|
@ -3,7 +3,7 @@ AR = ar
|
|||
LD = ld
|
||||
|
||||
EXECUTABLE = factor
|
||||
VERSION = 0.91
|
||||
VERSION = 0.92
|
||||
|
||||
IMAGE = factor.image
|
||||
BUNDLE = Factor.app
|
||||
|
|
|
|||
|
|
@ -198,9 +198,9 @@ M: long-long-type box-return ( type -- )
|
|||
: c-bool> ( int -- ? )
|
||||
zero? not ;
|
||||
|
||||
: >c-array ( seq type word -- )
|
||||
>r >r dup length dup r> <c-array> dup -roll r>
|
||||
[ execute ] 2curry 2each ; inline
|
||||
: >c-array ( seq type word -- byte-array )
|
||||
[ [ dup length ] dip <c-array> ] dip
|
||||
[ [ execute ] 2curry each-index ] 2keep drop ; inline
|
||||
|
||||
: >c-array-quot ( type vocab -- quot )
|
||||
dupd set-nth-word [ >c-array ] 2curry ;
|
||||
|
|
|
|||
|
|
@ -505,6 +505,8 @@ M: quotation '
|
|||
jit-r>-word
|
||||
jit-swap
|
||||
jit-swap-word
|
||||
jit-over
|
||||
jit-over-word
|
||||
jit-fixnum-fast
|
||||
jit-fixnum-fast-word
|
||||
jit-fixnum>=
|
||||
|
|
|
|||
|
|
@ -512,7 +512,7 @@ tuple
|
|||
{ "unimplemented" "kernel.private" }
|
||||
{ "gc-reset" "memory" }
|
||||
}
|
||||
dup length [ >r first2 r> make-primitive ] 2each
|
||||
[ >r first2 r> make-primitive ] each-index
|
||||
|
||||
! Bump build number
|
||||
"build" "kernel" create build 1+ 1quotation define
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ M: string error. print ;
|
|||
nl
|
||||
"The following restarts are available:" print
|
||||
nl
|
||||
dup length [ restart. ] 2each
|
||||
[ restart. ] each-index
|
||||
] if ;
|
||||
|
||||
: print-error ( error -- )
|
||||
|
|
|
|||
|
|
@ -64,8 +64,7 @@ DEFER: if
|
|||
|
||||
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
|
||||
|
||||
: 3keep ( x y z quot -- x y z )
|
||||
>r 3dup r> -roll 3slip ; inline
|
||||
: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline
|
||||
|
||||
! Cleavers
|
||||
: bi ( x p q -- )
|
||||
|
|
|
|||
|
|
@ -43,8 +43,8 @@ ARTICLE: "sequences-integers" "Integer sequences and counted loops"
|
|||
$nl
|
||||
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
|
||||
{ $example "3 [ . ] each" "0\n1\n2" }
|
||||
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link 2each } ":"
|
||||
{ $example "{ \"a\" \"b\" \"c\" } dup length [\n \"Index: \" write . \"Element: \" write .\n] 2each" "Index: 0\nElement: \"a\"\nIndex: 1\nElement: \"b\"\nIndex: 2\nElement: \"c\"" }
|
||||
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
|
||||
$nl
|
||||
"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
|
||||
|
||||
ARTICLE: "sequences-access" "Accessing sequence elements"
|
||||
|
|
|
|||
|
|
@ -426,6 +426,18 @@ PRIVATE>
|
|||
: follow ( obj quot -- seq )
|
||||
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
|
||||
|
||||
: prepare-index ( seq quot -- seq n quot )
|
||||
>r dup length r> ; inline
|
||||
|
||||
: each-index ( seq quot -- )
|
||||
prepare-index 2each ; inline
|
||||
|
||||
: map-index ( seq quot -- )
|
||||
prepare-index 2map ; inline
|
||||
|
||||
: reduce-index ( seq identity quot -- )
|
||||
swapd each-index ; inline
|
||||
|
||||
: index ( obj seq -- n )
|
||||
[ = ] with find drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ HELP: add-alarm
|
|||
|
||||
HELP: later
|
||||
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
|
||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
|
||||
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
|
||||
|
||||
HELP: cancel-alarm
|
||||
{ $values { "alarm" alarm } }
|
||||
|
|
|
|||
|
|
@ -82,10 +82,10 @@ PRIVATE>
|
|||
<alarm> [ register-alarm ] keep ;
|
||||
|
||||
: later ( quot dt -- alarm )
|
||||
from-now f add-alarm ;
|
||||
hence f add-alarm ;
|
||||
|
||||
: every ( quot dt -- alarm )
|
||||
[ from-now ] keep add-alarm ;
|
||||
[ hence ] keep add-alarm ;
|
||||
|
||||
: cancel-alarm ( alarm -- )
|
||||
alarm-entry [ alarms get-global heap-delete ] if-box? ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
|
||||
USING: kernel arrays sequences sequences.private macros ;
|
||||
|
||||
IN: arrays.lib
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
dup [ f <array> ] curry
|
||||
swap <reversed> [
|
||||
[ swap [ set-nth-unsafe ] keep ] curry
|
||||
] map concat append ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Non-core array words
|
||||
|
|
@ -1 +0,0 @@
|
|||
collections
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
USING: kernel parser namespaces sequences quotations arrays vectors splitting
|
||||
strings words math
|
||||
macros arrays.lib combinators.lib combinators.conditional newfx ;
|
||||
strings words math generalizations
|
||||
macros combinators.lib combinators.conditional newfx ;
|
||||
|
||||
IN: bake
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: tools.test math prettyprint kernel io arrays vectors sequences
|
||||
arrays.lib bake bake.fry ;
|
||||
generalizations bake bake.fry ;
|
||||
|
||||
IN: bake.fry.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: parser lexer kernel math sequences namespaces assocs summary
|
||||
words splitting math.parser arrays sequences.next mirrors
|
||||
shuffle compiler.units ;
|
||||
generalizations compiler.units ;
|
||||
IN: bitfields
|
||||
|
||||
! Example:
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ MEMO: unix-1970 ( -- timestamp )
|
|||
|
||||
: now ( -- timestamp ) gmt >local-time ;
|
||||
|
||||
: from-now ( dt -- timestamp ) now swap time+ ;
|
||||
: hence ( dt -- timestamp ) now swap time+ ;
|
||||
: ago ( dt -- timestamp ) now swap time- ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
|
||||
|
|
@ -303,41 +303,25 @@ GENERIC: days-in-year ( obj -- n )
|
|||
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
||||
|
||||
GENERIC: days-in-month ( obj -- n )
|
||||
: (days-in-month) ( year month -- n )
|
||||
dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
|
||||
|
||||
M: array days-in-month ( obj -- n )
|
||||
first2 dup 2 = [
|
||||
drop leap-year? 29 28 ?
|
||||
] [
|
||||
nip day-counts nth
|
||||
] if ;
|
||||
: days-in-month ( timestamp -- n )
|
||||
>date< drop (days-in-month) ;
|
||||
|
||||
M: timestamp days-in-month ( timestamp -- n )
|
||||
>date< drop 2array days-in-month ;
|
||||
|
||||
GENERIC: day-of-week ( obj -- n )
|
||||
|
||||
M: timestamp day-of-week ( timestamp -- n )
|
||||
: day-of-week ( timestamp -- n )
|
||||
>date< zeller-congruence ;
|
||||
|
||||
M: array day-of-week ( array -- n )
|
||||
first3 zeller-congruence ;
|
||||
|
||||
GENERIC: day-of-year ( obj -- n )
|
||||
|
||||
M: array day-of-year ( array -- n )
|
||||
first3
|
||||
3dup day-counts rot head-slice sum +
|
||||
swap leap-year? [
|
||||
-roll
|
||||
pick 3 1 <date> >r <date> r>
|
||||
:: (day-of-year) ( year month day -- n )
|
||||
day-counts month head-slice sum day +
|
||||
year leap-year? [
|
||||
year month day <date>
|
||||
year 3 1 <date>
|
||||
after=? [ 1+ ] when
|
||||
] [
|
||||
>r 3drop r>
|
||||
] if ;
|
||||
] when ;
|
||||
|
||||
M: timestamp day-of-year ( timestamp -- n )
|
||||
>date< 3array day-of-year ;
|
||||
: day-of-year ( timestamp -- n )
|
||||
>date< (day-of-year) ;
|
||||
|
||||
: day-offset ( timestamp m -- timestamp n )
|
||||
over day-of-week - ; inline
|
||||
|
|
@ -373,7 +357,7 @@ M: timestamp day-of-year ( timestamp -- n )
|
|||
|
||||
M: timestamp sleep-until timestamp>millis sleep-until ;
|
||||
|
||||
M: duration sleep from-now sleep-until ;
|
||||
M: duration sleep hence sleep-until ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "calendar.unix" ] }
|
||||
|
|
|
|||
|
|
@ -57,9 +57,9 @@ GENERIC: month. ( obj -- )
|
|||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ] 2keep
|
||||
[ 1 zeller-congruence ] 2keep
|
||||
2array days-in-month day-abbreviations2 " " join print
|
||||
[ month-names nth write bl number>string print ]
|
||||
[ 1 zeller-congruence ]
|
||||
[ (days-in-month) day-abbreviations2 " " join print ] 2tri
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ day. ] keep
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ HELP: column
|
|||
|
||||
HELP: <column> ( seq n -- column )
|
||||
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
|
||||
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
|
||||
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays prettyprint columns ;"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel combinators words quotations arrays sequences locals macros
|
||||
shuffle combinators.lib arrays.lib fry ;
|
||||
shuffle combinators.lib generalizations fry ;
|
||||
|
||||
IN: combinators.cleave
|
||||
|
||||
|
|
|
|||
|
|
@ -11,46 +11,3 @@ HELP: generate
|
|||
"[ 20 random-prime ] [ 4 mod 3 = ] generate ."
|
||||
"526367"
|
||||
} ;
|
||||
|
||||
HELP: ndip
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $description "A generalisation of " { $link dip } " that can work "
|
||||
"for any stack depth. The quotation will be called with a stack that "
|
||||
"has 'n' items removed first. The 'n' items are then put back on the "
|
||||
"stack. The quotation can consume and produce any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
}
|
||||
{ $see-also dip 2dip } ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" number } }
|
||||
{ $description "A generalisation of " { $link slip } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also slip nkeep } ;
|
||||
|
||||
HELP: nkeep
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $description "A generalisation of " { $link keep } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also keep nslip } ;
|
||||
|
||||
! HELP: &&
|
||||
! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
|
||||
! { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
|
||||
|
||||
! HELP: ||
|
||||
! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
|
||||
! { $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;
|
||||
|
|
|
|||
|
|
@ -5,16 +5,6 @@ IN: combinators.lib.tests
|
|||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
|
||||
[ [ dup 2^ 2array ] 5 napply ] must-infer
|
||||
|
||||
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
|
||||
|
||||
[ { "foo" "xbarx" } ]
|
||||
[
|
||||
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel combinators fry namespaces quotations hashtables
|
||||
sequences assocs arrays inference effects math math.ranges
|
||||
arrays.lib shuffle macros continuations locals ;
|
||||
generalizations macros continuations locals ;
|
||||
|
||||
IN: combinators.lib
|
||||
|
||||
|
|
@ -12,30 +12,10 @@ IN: combinators.lib
|
|||
! Generalized versions of core combinators
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
MACRO: ndip ( quot n -- ) dup saver -rot restorer 3append ;
|
||||
|
||||
MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ;
|
||||
|
||||
: 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
|
||||
|
||||
MACRO: nkeep ( n -- )
|
||||
[ ] [ 1+ ] [ ] tri
|
||||
'[ [ , ndup ] dip , -nrot , nslip ] ;
|
||||
|
||||
: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
|
||||
|
||||
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
|
||||
|
||||
MACRO:: nwith ( quot n -- )
|
||||
[let | n' [ n 1+ ] |
|
||||
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
|
||||
|
||||
MACRO: napply ( n -- )
|
||||
2 [a,b]
|
||||
[ [ 1- ] [ ] bi
|
||||
'[ , ntuck , nslip ] ]
|
||||
map concat >quotation [ call ] append ;
|
||||
|
||||
: 2with ( param1 param2 obj quot -- obj curry )
|
||||
with with ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel combinators quotations arrays sequences assocs
|
||||
locals shuffle macros fry ;
|
||||
locals generalizations macros fry ;
|
||||
|
||||
IN: combinators.short-circuit
|
||||
|
||||
|
|
|
|||
|
|
@ -5,25 +5,26 @@ ARTICLE: "ctags" "Ctags file"
|
|||
{ $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "."
|
||||
{ $subsection ctags }
|
||||
{ $subsection ctags-write }
|
||||
{ $subsection ctag-strings }
|
||||
{ $subsection ctag } ;
|
||||
|
||||
HELP: ctags ( path -- )
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
{ $unchecked-example
|
||||
"USING: ctags ;"
|
||||
"\"tags\" ctags-write"
|
||||
"\"tags\" ctags"
|
||||
""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ctags-write ( seq path -- )
|
||||
{ $values { "seq" sequence }
|
||||
{ $values { "alist" "an association list" }
|
||||
{ "path" "a pathname string" } }
|
||||
{ $description "Stores a " { $snippet "seq" } " in " { $snippet "path" } ". " { $snippet "seq" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
|
||||
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
|
||||
{ $examples
|
||||
{ $example
|
||||
{ $unchecked-example
|
||||
"USING: kernel ctags ;"
|
||||
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write"
|
||||
""
|
||||
|
|
@ -32,13 +33,25 @@ HELP: ctags-write ( seq path -- )
|
|||
{ $notes
|
||||
{ $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ;
|
||||
|
||||
HELP: ctag-strings ( alist -- seq )
|
||||
{ $values { "alist" "an association list" }
|
||||
{ "seq" sequence } }
|
||||
{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: kernel ctags prettyprint ;"
|
||||
"{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings ."
|
||||
"{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ctag ( seq -- str )
|
||||
{ $values { "seq" sequence }
|
||||
{ "str" string } }
|
||||
{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel ctags ;"
|
||||
{ $unchecked-example
|
||||
"USING: kernel ctags prettyprint ;"
|
||||
"{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
|
||||
"\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +1,12 @@
|
|||
USING: kernel ctags tools.test io.backend sequences ;
|
||||
IN: columns.tests
|
||||
USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
|
||||
IN: ctags.tests
|
||||
|
||||
[ t ] [
|
||||
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
|
||||
{ if { "resource:extra/unix/unix.factor" 91 } } ctag =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
|
||||
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
|
||||
] unit-test
|
||||
|
|
@ -18,8 +18,11 @@ IN: ctags
|
|||
second number>string %
|
||||
] "" make ;
|
||||
|
||||
: ctag-strings ( seq1 -- seq2 )
|
||||
{ } swap [ ctag suffix ] each ;
|
||||
|
||||
: ctags-write ( seq path -- )
|
||||
ascii [ [ ctag print ] each ] with-file-writer ;
|
||||
[ ctag-strings ] dip ascii set-file-lines ;
|
||||
|
||||
: (ctags) ( -- seq )
|
||||
{ } all-words [
|
||||
|
|
|
|||
|
|
@ -1,8 +1,22 @@
|
|||
IN: db.pools.tests
|
||||
USING: db.pools tools.test ;
|
||||
USING: db.pools tools.test continuations io.files namespaces
|
||||
accessors kernel math destructors ;
|
||||
|
||||
\ <db-pool> must-infer
|
||||
|
||||
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
||||
|
||||
! Test behavior after image save/load
|
||||
USE: db.sqlite
|
||||
|
||||
[ "pool-test.db" temp-file delete-file ] ignore-errors
|
||||
|
||||
[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
|
||||
|
||||
[ ] [ "pool" get expired>> t >>expired drop ] unit-test
|
||||
|
||||
[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
|
||||
|
||||
[ ] [ "pool" get dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: io.files kernel tools.test db db.tuples classes
|
|||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitfields.lib
|
||||
math.ranges strings sequences.lib urls ;
|
||||
math.ranges strings sequences.lib urls fry ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
|
|
@ -201,10 +201,10 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
! ] with-db
|
||||
|
||||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||
[ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ;
|
||||
|
||||
: test-postgresql ( quot -- )
|
||||
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
|
||||
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ;
|
||||
|
||||
: test-repeated-insert
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
|
|
@ -463,6 +463,31 @@ fubbclass "FUBCLASS" { } define-persistent
|
|||
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
|
||||
|
||||
[ test-db-inheritance ] test-sqlite
|
||||
[ test-db-inheritance ] test-postgresql
|
||||
|
||||
|
||||
TUPLE: string-encoding-test id string ;
|
||||
|
||||
string-encoding-test "STRING_ENCODING_TEST" {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
{ "string" "STRING" TEXT }
|
||||
} define-persistent
|
||||
|
||||
: test-string-encoding ( -- )
|
||||
[ ] [ string-encoding-test ensure-table ] unit-test
|
||||
|
||||
[ ] [
|
||||
string-encoding-test new
|
||||
"\u{copyright-sign}\u{bengali-letter-cha}" >>string
|
||||
[ insert-tuple ] [ id>> "id" set ] bi
|
||||
] unit-test
|
||||
|
||||
[ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
|
||||
string-encoding-test new "id" get >>id select-tuple string>>
|
||||
] unit-test ;
|
||||
|
||||
[ test-string-encoding ] test-sqlite
|
||||
[ test-string-encoding ] test-postgresql
|
||||
|
||||
! Don't comment these out. These words must infer
|
||||
\ bind-tuple must-infer
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: words kernel sequences combinators.lib locals
|
||||
locals.private accessors parser namespaces continuations
|
||||
summary definitions arrays.lib arrays ;
|
||||
summary definitions generalizations arrays ;
|
||||
IN: descriptive
|
||||
|
||||
ERROR: descriptive-error args underlying word ;
|
||||
|
|
|
|||
|
|
@ -40,10 +40,9 @@ M: login-realm modify-form ( responder -- )
|
|||
permit-id get realm get name>> permit-id-key <cookie>
|
||||
"$login-realm" resolve-base-path >>path
|
||||
realm get
|
||||
[ timeout>> from-now >>expires ]
|
||||
[ domain>> >>domain ]
|
||||
[ secure>> >>secure ]
|
||||
tri ;
|
||||
bi ;
|
||||
|
||||
: put-permit-cookie ( response -- response' )
|
||||
<permit-cookie> put-cookie ;
|
||||
|
|
|
|||
|
|
@ -31,6 +31,6 @@ TUPLE: server-state-manager < filter-responder timeout ;
|
|||
new
|
||||
swap >>responder
|
||||
20 minutes >>timeout ; inline
|
||||
|
||||
|
||||
: touch-state ( state manager -- )
|
||||
timeout>> from-now >>expires drop ;
|
||||
timeout>> hence >>expires drop ;
|
||||
|
|
|
|||
|
|
@ -116,7 +116,6 @@ M: session-saver dispose
|
|||
: <session-cookie> ( -- cookie )
|
||||
session get id>> session-id-key <cookie>
|
||||
"$sessions" resolve-base-path >>path
|
||||
sessions get timeout>> from-now >>expires
|
||||
sessions get domain>> >>domain ;
|
||||
|
||||
: put-session-cookie ( response -- response' )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,136 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup kernel sequences quotations
|
||||
math ;
|
||||
IN: generalizations
|
||||
|
||||
HELP: npick
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link dup } ", "
|
||||
{ $link over } " and " { $link pick } " that can work "
|
||||
"for any stack depth. The nth item down the stack will be copied and "
|
||||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also dup over pick } ;
|
||||
|
||||
HELP: ndup
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link dup } ", "
|
||||
{ $link 2dup } " and " { $link 3dup } " that can work "
|
||||
"for any number of items. The n topmost items on the stack will be copied and "
|
||||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
}
|
||||
{ $see-also dup 2dup 3dup } ;
|
||||
|
||||
HELP: nnip
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link nip } " and " { $link 2nip }
|
||||
" that can work "
|
||||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
|
||||
}
|
||||
{ $see-also nip 2nip } ;
|
||||
|
||||
HELP: ndrop
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link drop }
|
||||
" that can work "
|
||||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
|
||||
}
|
||||
{ $see-also drop 2drop 3drop } ;
|
||||
|
||||
HELP: nrot
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link rot } " that works for any "
|
||||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also rot -nrot } ;
|
||||
|
||||
HELP: -nrot
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link -rot } " that works for any "
|
||||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
|
||||
}
|
||||
{ $see-also rot nrot } ;
|
||||
|
||||
HELP: nrev
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
|
||||
}
|
||||
{ $see-also rot nrot } ;
|
||||
|
||||
HELP: ndip
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $description "A generalization of " { $link dip } " that can work "
|
||||
"for any stack depth. The quotation will be called with a stack that "
|
||||
"has 'n' items removed first. The 'n' items are then put back on the "
|
||||
"stack. The quotation can consume and produce any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
}
|
||||
{ $see-also dip 2dip } ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" number } }
|
||||
{ $description "A generalization of " { $link slip } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also slip nkeep } ;
|
||||
|
||||
HELP: nkeep
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $description "A generalization of " { $link keep } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also keep nslip } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"A number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
{ $subsection narray }
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
{ $subsection -nrot }
|
||||
{ $subsection nnip }
|
||||
{ $subsection ndrop }
|
||||
{ $subsection nrev }
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection ncurry }
|
||||
{ $subsection nwith }
|
||||
{ $subsection napply } ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
USING: tools.test generalizations kernel math arrays sequences ;
|
||||
IN: generalizations.tests
|
||||
|
||||
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
|
||||
{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test
|
||||
{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test
|
||||
{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test
|
||||
[ 1 1 ndup ] must-infer
|
||||
{ 1 1 } [ 1 1 ndup ] unit-test
|
||||
{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
|
||||
{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test
|
||||
{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test
|
||||
[ 1 2 2 nrot ] must-infer
|
||||
{ 2 1 } [ 1 2 2 nrot ] unit-test
|
||||
{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test
|
||||
{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test
|
||||
[ 1 2 2 -nrot ] must-infer
|
||||
{ 2 1 } [ 1 2 2 -nrot ] unit-test
|
||||
{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test
|
||||
{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test
|
||||
[ 1 2 3 4 3 nnip ] must-infer
|
||||
{ 4 } [ 1 2 3 4 3 nnip ] unit-test
|
||||
[ 1 2 3 4 4 ndrop ] must-infer
|
||||
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
|
||||
|
||||
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
|
||||
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
|
||||
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
|
||||
[ [ dup 2^ 2array ] 5 napply ] must-infer
|
||||
|
||||
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private namespaces math math.ranges
|
||||
combinators macros quotations fry locals arrays ;
|
||||
IN: generalizations
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
dup [ f <array> ] curry
|
||||
swap <reversed> [
|
||||
[ swap [ set-nth-unsafe ] keep ] curry
|
||||
] map concat append ;
|
||||
|
||||
MACRO: npick ( n -- )
|
||||
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
|
||||
|
||||
MACRO: ndup ( n -- )
|
||||
dup '[ , npick ] n*quot ;
|
||||
|
||||
MACRO: nrot ( n -- )
|
||||
1- dup saver swap [ r> swap ] n*quot append ;
|
||||
|
||||
MACRO: -nrot ( n -- )
|
||||
1- dup [ swap >r ] n*quot swap restorer append ;
|
||||
|
||||
MACRO: ndrop ( n -- )
|
||||
[ drop ] n*quot ;
|
||||
|
||||
: nnip ( n -- )
|
||||
swap >r ndrop r> ; inline
|
||||
|
||||
MACRO: ntuck ( n -- )
|
||||
2 + [ dupd -nrot ] curry ;
|
||||
|
||||
MACRO: nrev ( n -- quot )
|
||||
1 [a,b] [ '[ , -nrot ] ] map concat ;
|
||||
|
||||
MACRO: ndip ( quot n -- )
|
||||
dup saver -rot restorer 3append ;
|
||||
|
||||
MACRO: nslip ( n -- )
|
||||
dup saver [ call ] rot restorer 3append ;
|
||||
|
||||
MACRO: nkeep ( n -- )
|
||||
[ ] [ 1+ ] [ ] tri
|
||||
'[ [ , ndup ] dip , -nrot , nslip ] ;
|
||||
|
||||
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
|
||||
|
||||
MACRO:: nwith ( quot n -- )
|
||||
[let | n' [ n 1+ ] |
|
||||
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
|
||||
|
||||
MACRO: napply ( n -- )
|
||||
2 [a,b]
|
||||
[ [ 1- ] keep '[ , ntuck , nslip ] ]
|
||||
map concat >quotation [ call ] append ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs html.parser kernel math sequences strings ascii
|
||||
arrays shuffle unicode.case namespaces splitting http
|
||||
sequences.lib accessors io combinators http.client urls ;
|
||||
arrays generalizations shuffle unicode.case namespaces splitting
|
||||
http sequences.lib accessors io combinators http.client urls ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
TUPLE: link attributes clickable ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel words summary slots quotations
|
||||
sequences assocs math arrays inference effects shuffle
|
||||
sequences assocs math arrays inference effects generalizations
|
||||
continuations debugger classes.tuple namespaces vectors
|
||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||
sequences.private combinators mirrors combinators.lib
|
||||
sequences.private combinators mirrors
|
||||
combinators.short-circuit ;
|
||||
IN: inverse
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TUPLE: pool connections disposed expired ;
|
|||
: check-pool ( pool -- )
|
||||
dup check-disposed
|
||||
dup expired>> expired? [
|
||||
ALIEN: 31337 >>expired
|
||||
31337 <alien> >>expired
|
||||
connections>> delete-all
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -125,7 +125,8 @@ M: fd refill
|
|||
} cond ;
|
||||
|
||||
M: unix (wait-to-read) ( port -- )
|
||||
dup dup handle>> refill dup
|
||||
dup
|
||||
dup handle>> dup check-disposed refill dup
|
||||
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
|
||||
|
||||
! Writers
|
||||
|
|
@ -144,7 +145,9 @@ M: fd drain
|
|||
} cond ;
|
||||
|
||||
M: unix (wait-to-write) ( port -- )
|
||||
dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
|
||||
dup
|
||||
dup handle>> dup check-disposed drain
|
||||
dup [ wait-for-port ] [ 2drop ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
|
|
|||
|
|
@ -61,6 +61,7 @@ C: <FileArgs> FileArgs
|
|||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
{
|
||||
[ handle>> check-disposed ]
|
||||
[ handle>> handle>> ]
|
||||
[ buffer>> ]
|
||||
[ buffer>> buffer-length ]
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ M: winnt add-completion ( win32-handle -- )
|
|||
] if ;
|
||||
|
||||
M: win32-handle cancel-operation
|
||||
handle>> CancelIo drop ;
|
||||
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
|
||||
|
||||
M: winnt io-multiplex ( ms -- )
|
||||
handle-overlapped [ 0 io-multiplex ] when ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: io.backend kernel continuations sequences ;
|
||||
USING: io.backend kernel continuations sequences
|
||||
system vocabs.loader combinators ;
|
||||
IN: io.windows.privileges
|
||||
|
||||
HOOK: set-privilege io-backend ( name ? -- ) inline
|
||||
|
|
@ -6,3 +7,8 @@ HOOK: set-privilege io-backend ( name ? -- ) inline
|
|||
: with-privileges ( seq quot -- )
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "io.windows.nt.privileges" require ] }
|
||||
{ [ os wince? ] [ "io.windows.ce.privileges" require ] }
|
||||
} cond
|
||||
|
|
|
|||
|
|
@ -257,11 +257,11 @@ DEFER: (d)
|
|||
[ laplacian-kernel ] graded-laplacian ;
|
||||
|
||||
: graded-basis. ( seq -- )
|
||||
dup length [
|
||||
[
|
||||
"=== Degree " write pprint
|
||||
": dimension " write dup length .
|
||||
[ alt. ] each
|
||||
] 2each ;
|
||||
] each-index ;
|
||||
|
||||
: bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
|
||||
#! d: C(u,z) ---> C(u+2,z-1)
|
||||
|
|
@ -289,11 +289,11 @@ DEFER: (d)
|
|||
[ laplacian-kernel ] bigraded-laplacian ;
|
||||
|
||||
: bigraded-basis. ( seq -- )
|
||||
dup length [
|
||||
[
|
||||
"=== U-degree " write .
|
||||
dup length [
|
||||
[
|
||||
" === Z-degree " write pprint
|
||||
": dimension " write dup length .
|
||||
[ " " write alt. ] each
|
||||
] 2each
|
||||
] 2each ;
|
||||
] each-index
|
||||
] each-index ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: logging.server sequences namespaces concurrency.messaging
|
||||
words kernel arrays shuffle tools.annotations
|
||||
prettyprint.config prettyprint debugger io.streams.string
|
||||
splitting continuations effects arrays.lib parser strings
|
||||
splitting continuations effects generalizations parser strings
|
||||
quotations fry symbols accessors ;
|
||||
IN: logging
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators
|
|||
combinators.lib combinators.short-circuit fry kernel locals macros
|
||||
math math.blas.cblas math.blas.vectors math.blas.vectors.private
|
||||
math.complex math.functions math.order multi-methods qualified
|
||||
sequences sequences.merged sequences.private shuffle symbols ;
|
||||
sequences sequences.merged sequences.private generalizations
|
||||
shuffle symbols ;
|
||||
QUALIFIED: syntax
|
||||
IN: math.blas.matrices
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors alien alien.c-types arrays byte-arrays combinators
|
||||
combinators.short-circuit fry kernel macros math math.blas.cblas
|
||||
math.complex math.functions math.order multi-methods qualified
|
||||
sequences sequences.private shuffle ;
|
||||
sequences sequences.private generalizations ;
|
||||
QUALIFIED: syntax
|
||||
IN: math.blas.vectors
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ IN: math.vectors
|
|||
: normalize ( u -- v ) dup norm v/n ;
|
||||
|
||||
: set-axis ( u v axis -- w )
|
||||
dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ;
|
||||
[ >r zero? 2over ? r> swap nth ] map-index 2nip ;
|
||||
|
||||
HINTS: vneg { array } ;
|
||||
HINTS: norm-sq { array } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel io parser lexer words namespaces quotations arrays assocs sequences
|
||||
splitting grouping math shuffle ;
|
||||
splitting grouping math generalizations ;
|
||||
|
||||
IN: mortar
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences vectors classes classes.algebra
|
||||
combinators arrays words assocs parser namespaces definitions
|
||||
prettyprint prettyprint.backend quotations arrays.lib
|
||||
prettyprint prettyprint.backend quotations generalizations
|
||||
debugger io compiler.units kernel.private effects accessors
|
||||
hashtables sorting shuffle math.order sets ;
|
||||
IN: multi-methods
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
USING: kernel namespaces threads combinators sequences arrays
|
||||
math math.functions math.ranges random
|
||||
opengl.gl opengl.glu vars multi-methods shuffle
|
||||
opengl.gl opengl.glu vars multi-methods generalizations shuffle
|
||||
ui
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors assocs math kernel shuffle combinators.lib
|
||||
USING: accessors assocs math kernel shuffle generalizations
|
||||
words quotations arrays combinators sequences math.vectors
|
||||
io.styles prettyprint vocabs sorting io generic locals.private
|
||||
math.statistics math.order ;
|
||||
math.statistics math.order combinators.lib ;
|
||||
IN: reports.noise
|
||||
|
||||
: badness ( word -- n )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
USING: combinators.lib kernel sequences math namespaces assocs
|
||||
random sequences.private shuffle math.functions
|
||||
arrays math.parser math.private sorting strings ascii macros
|
||||
assocs.lib quotations hashtables math.order locals ;
|
||||
assocs.lib quotations hashtables math.order locals
|
||||
generalizations ;
|
||||
IN: sequences.lib
|
||||
|
||||
: each-withn ( seq quot n -- ) nwith each ; inline
|
||||
|
|
@ -24,21 +25,6 @@ MACRO: firstn ( n -- )
|
|||
concat >quotation
|
||||
[ drop ] compose ;
|
||||
|
||||
: prepare-index ( seq quot -- seq n quot )
|
||||
>r dup length r> ; inline
|
||||
|
||||
: each-index ( seq quot -- )
|
||||
#! quot: ( elt index -- )
|
||||
prepare-index 2each ; inline
|
||||
|
||||
: map-index ( seq quot -- )
|
||||
#! quot: ( elt index -- obj )
|
||||
prepare-index 2map ; inline
|
||||
|
||||
: reduce-index ( seq identity quot -- )
|
||||
#! quot: ( prev elt index -- next )
|
||||
swapd each-index ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: each-percent ( seq quot -- )
|
||||
|
|
|
|||
|
|
@ -1,84 +0,0 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup kernel sequences ;
|
||||
IN: shuffle
|
||||
|
||||
HELP: npick
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link dup } ", "
|
||||
{ $link over } " and " { $link pick } " that can work "
|
||||
"for any stack depth. The nth item down the stack will be copied and "
|
||||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also dup over pick } ;
|
||||
|
||||
HELP: ndup
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link dup } ", "
|
||||
{ $link 2dup } " and " { $link 3dup } " that can work "
|
||||
"for any number of items. The n topmost items on the stack will be copied and "
|
||||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
}
|
||||
{ $see-also dup 2dup 3dup } ;
|
||||
|
||||
HELP: nnip
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link nip } " and " { $link 2nip }
|
||||
" that can work "
|
||||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" }
|
||||
}
|
||||
{ $see-also nip 2nip } ;
|
||||
|
||||
HELP: ndrop
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link drop }
|
||||
" that can work "
|
||||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" }
|
||||
}
|
||||
{ $see-also drop 2drop 3drop } ;
|
||||
|
||||
HELP: nrot
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link rot } " that works for any "
|
||||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also rot -nrot } ;
|
||||
|
||||
HELP: -nrot
|
||||
{ $values { "n" "a number" } }
|
||||
{ $description "A generalisation of " { $link -rot } " that works for any "
|
||||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
|
||||
}
|
||||
{ $see-also rot nrot } ;
|
||||
|
||||
ARTICLE: { "shuffle" "overview" } "Extra shuffle words"
|
||||
"A number of stack shuffling words for those rare times when you "
|
||||
"need to deal with tricky stack situations and can't refactor the "
|
||||
"code to work around it."
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
{ $subsection -nrot }
|
||||
{ $subsection nnip }
|
||||
{ $subsection ndrop } ;
|
||||
|
||||
IN: shuffle
|
||||
ABOUT: { "shuffle" "overview" }
|
||||
|
|
@ -1,25 +1,4 @@
|
|||
USING: arrays shuffle kernel math tools.test inference words ;
|
||||
USING: shuffle tools.test ;
|
||||
|
||||
[ 8 ] [ 5 6 7 8 3nip ] unit-test
|
||||
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
|
||||
{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test
|
||||
{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test
|
||||
{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test
|
||||
{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test
|
||||
{ 1 1 } [ 1 1 ndup ] unit-test
|
||||
{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
|
||||
{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test
|
||||
{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test
|
||||
{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test
|
||||
{ 2 1 } [ 1 2 2 nrot ] unit-test
|
||||
{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test
|
||||
{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test
|
||||
{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test
|
||||
{ 2 1 } [ 1 2 2 -nrot ] unit-test
|
||||
{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test
|
||||
{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test
|
||||
{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test
|
||||
{ 4 } [ 1 2 3 4 3 nnip ] unit-test
|
||||
{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test
|
||||
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
|
||||
[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,24 +1,9 @@
|
|||
! Copyright (C) 2007 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces math inference.transforms
|
||||
combinators macros quotations math.ranges fry ;
|
||||
USING: kernel generalizations ;
|
||||
|
||||
IN: shuffle
|
||||
|
||||
MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
|
||||
|
||||
MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;
|
||||
|
||||
MACRO: nrot ( n -- ) 1- dup saver swap [ r> swap ] n*quot append ;
|
||||
|
||||
MACRO: -nrot ( n -- ) 1- dup [ swap >r ] n*quot swap restorer append ;
|
||||
|
||||
MACRO: ndrop ( n -- ) [ drop ] n*quot ;
|
||||
|
||||
: nnip ( n -- ) swap >r ndrop r> ; inline
|
||||
|
||||
MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ;
|
||||
|
||||
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
|
||||
|
||||
: nipd ( a b c -- b c ) rot drop ; inline
|
||||
|
|
@ -32,8 +17,3 @@ MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ;
|
|||
: 4drop ( a b c d -- ) 3drop drop ; inline
|
||||
|
||||
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
|
||||
|
||||
MACRO: nrev ( n -- quot )
|
||||
[ 1+ ] map
|
||||
reverse
|
||||
[ [ -nrot ] curry ] map concat ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
|
||||
opengl multiline ui.gadgets accessors sequences ui.render ui math
|
||||
arrays arrays.lib combinators ;
|
||||
arrays generalizations combinators ;
|
||||
IN: spheres
|
||||
|
||||
STRING: plane-vertex-shader
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel combinators sequences arrays math math.vectors
|
||||
shuffle vars ;
|
||||
generalizations vars ;
|
||||
|
||||
IN: springies
|
||||
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ tetris-gadget H{
|
|||
dup tetris-gadget-tetris maybe-update relayout-1 ;
|
||||
|
||||
M: tetris-gadget graft* ( gadget -- )
|
||||
dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
|
||||
dup [ tick ] curry 100 milliseconds every
|
||||
swap set-tetris-gadget-alarm ;
|
||||
|
||||
M: tetris-gadget ungraft* ( gadget -- )
|
||||
|
|
|
|||
|
|
@ -33,10 +33,10 @@ IN: tools.memory
|
|||
[ [ write-cell ] each ] with-row ;
|
||||
|
||||
: (data-room.) ( -- )
|
||||
data-room 2 <groups> dup length [
|
||||
data-room 2 <groups> [
|
||||
[ first2 ] [ number>string "Generation " prepend ] bi*
|
||||
write-total/used/free
|
||||
] 2each
|
||||
] each-index
|
||||
"Decks" write-total
|
||||
"Cards" write-total ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: tools.walker io io.streams.string kernel math
|
||||
math.private namespaces prettyprint sequences tools.test
|
||||
continuations math.parser threads arrays tools.walker.debug
|
||||
generic.standard ;
|
||||
generic.standard sequences.private kernel.private ;
|
||||
IN: tools.walker.tests
|
||||
|
||||
[ { } ] [
|
||||
|
|
@ -50,6 +50,10 @@ IN: tools.walker.tests
|
|||
[ 5 6 number= ] test-walker
|
||||
] unit-test
|
||||
|
||||
[ { 0 } ] [
|
||||
[ 0 { array-capacity } declare ] test-walker
|
||||
] unit-test
|
||||
|
||||
[ { f } ] [
|
||||
[ "XYZ" "XYZ" mismatch ] test-walker
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ SYMBOL: drag-timer
|
|||
: start-drag-timer ( -- )
|
||||
hand-buttons get-global empty? [
|
||||
[ drag-gesture ]
|
||||
300 milliseconds from-now
|
||||
300 milliseconds hence
|
||||
100 milliseconds
|
||||
add-alarm drag-timer get-global >box
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,8 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
|
|||
>r [ first ] [ ] bi r> exec-with-env ;
|
||||
|
||||
: with-fork ( child parent -- )
|
||||
fork-process dup zero? -roll swap curry if ; inline
|
||||
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
|
||||
if ; inline
|
||||
|
||||
: SIGKILL 9 ; inline
|
||||
: SIGTERM 15 ; inline
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: alien alien.c-types alien.syntax kernel libc structs sequences
|
||||
continuations byte-arrays strings
|
||||
math namespaces system combinators vocabs.loader qualified
|
||||
accessors inference macros locals shuffle arrays.lib
|
||||
accessors inference macros locals generalizations
|
||||
unix.types debugger io prettyprint ;
|
||||
|
||||
IN: unix
|
||||
|
|
|
|||
|
|
@ -2,12 +2,12 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Planet Factor Administration</t:title>
|
||||
<t:title>Concatenative Planet: Administration</t:title>
|
||||
|
||||
<ul>
|
||||
<t:bind-each t:name="blogroll">
|
||||
<li>
|
||||
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
|
||||
<t:a t:href="$planet/admin/edit-blog" t:query="id">
|
||||
<t:label t:name="name" />
|
||||
</t:a>
|
||||
</li>
|
||||
|
|
@ -15,8 +15,8 @@
|
|||
</ul>
|
||||
|
||||
<div>
|
||||
<t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
|
||||
| <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
|
||||
<t:a t:href="$planet/admin/new-blog">Add Blog</t:a>
|
||||
| <t:button t:action="$planet/admin/update" class="link-button link">Update</t:button>
|
||||
</div>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Blog</t:title>
|
||||
|
||||
<t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
|
||||
<t:form t:action="$planet/admin/edit-blog" t:for="id">
|
||||
|
||||
<table>
|
||||
|
||||
|
|
@ -29,6 +29,6 @@
|
|||
|
||||
</t:form>
|
||||
|
||||
<t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
|
||||
<t:button t:action="$planet/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -1,14 +0,0 @@
|
|||
<?xml version='1.0' ?>
|
||||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:bind-each t:name="postings">
|
||||
|
||||
<p class="news">
|
||||
<strong><t:label t:name="title" /></strong> <br/>
|
||||
<t:a value="link" class="more">Read More...</t:a>
|
||||
</p>
|
||||
|
||||
</t:bind-each>
|
||||
|
||||
</t:chloe>
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Blog</t:title>
|
||||
|
||||
<t:form t:action="$planet-factor/admin/new-blog">
|
||||
<t:form t:action="$planet/admin/new-blog">
|
||||
|
||||
<table>
|
||||
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@
|
|||
<t:style t:include="resource:extra/webapps/planet/planet.css" />
|
||||
|
||||
<div class="navbar">
|
||||
<t:a t:href="$planet-factor/list">Front Page</t:a>
|
||||
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
|
||||
| <t:a t:href="$planet-factor/admin">Admin</t:a>
|
||||
<t:a t:href="$planet/list">Front Page</t:a>
|
||||
| <t:a t:href="$planet/feed.xml">Atom Feed</t:a>
|
||||
| <t:a t:href="$planet/admin">Admin</t:a>
|
||||
|
||||
<t:if t:code="furnace.auth:logged-in?">
|
||||
<t:if t:code="furnace.auth.features.edit-profile:allow-edit-profile?">
|
||||
|
|
|
|||
|
|
@ -17,13 +17,13 @@ furnace.auth
|
|||
furnace.syndication ;
|
||||
IN: webapps.planet
|
||||
|
||||
TUPLE: planet-factor < dispatcher ;
|
||||
TUPLE: planet < dispatcher ;
|
||||
|
||||
SYMBOL: can-administer-planet-factor?
|
||||
SYMBOL: can-administer-planet?
|
||||
|
||||
can-administer-planet-factor? define-capability
|
||||
can-administer-planet? define-capability
|
||||
|
||||
TUPLE: planet-factor-admin < dispatcher ;
|
||||
TUPLE: planet-admin < dispatcher ;
|
||||
|
||||
TUPLE: blog id name www-url feed-url ;
|
||||
|
||||
|
|
@ -65,7 +65,7 @@ posting "POSTINGS"
|
|||
: <edit-blogroll-action> ( -- action )
|
||||
<page-action>
|
||||
[ blogroll "blogroll" set-value ] >>init
|
||||
{ planet-factor "admin" } >>template ;
|
||||
{ planet "admin" } >>template ;
|
||||
|
||||
: <planet-action> ( -- action )
|
||||
<page-action>
|
||||
|
|
@ -74,12 +74,12 @@ posting "POSTINGS"
|
|||
postings "postings" set-value
|
||||
] >>init
|
||||
|
||||
{ planet-factor "planet" } >>template ;
|
||||
{ planet "planet" } >>template ;
|
||||
|
||||
: <planet-feed-action> ( -- action )
|
||||
<feed-action>
|
||||
[ "Planet Factor" ] >>title
|
||||
[ URL" $planet-factor" ] >>url
|
||||
[ URL" $planet" ] >>url
|
||||
[ postings ] >>entries ;
|
||||
|
||||
:: <posting> ( entry name -- entry' )
|
||||
|
|
@ -111,7 +111,7 @@ posting "POSTINGS"
|
|||
<action>
|
||||
[
|
||||
update-cached-postings
|
||||
URL" $planet-factor/admin" <redirect>
|
||||
URL" $planet/admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <delete-blog-action> ( -- action )
|
||||
|
|
@ -120,7 +120,7 @@ posting "POSTINGS"
|
|||
|
||||
[
|
||||
"id" value <blog> delete-tuples
|
||||
URL" $planet-factor/admin" <redirect>
|
||||
URL" $planet/admin" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: validate-blog ( -- )
|
||||
|
|
@ -136,7 +136,7 @@ posting "POSTINGS"
|
|||
: <new-blog-action> ( -- action )
|
||||
<page-action>
|
||||
|
||||
{ planet-factor "new-blog" } >>template
|
||||
{ planet "new-blog" } >>template
|
||||
|
||||
[ validate-blog ] >>validate
|
||||
|
||||
|
|
@ -146,7 +146,7 @@ posting "POSTINGS"
|
|||
[ insert-tuple ]
|
||||
[
|
||||
<url>
|
||||
"$planet-factor/admin/edit-blog" >>path
|
||||
"$planet/admin/edit-blog" >>path
|
||||
swap id>> "id" set-query-param
|
||||
<redirect>
|
||||
]
|
||||
|
|
@ -161,7 +161,7 @@ posting "POSTINGS"
|
|||
"id" value <blog> select-tuple from-object
|
||||
] >>init
|
||||
|
||||
{ planet-factor "edit-blog" } >>template
|
||||
{ planet "edit-blog" } >>template
|
||||
|
||||
[
|
||||
validate-integer-id
|
||||
|
|
@ -174,15 +174,15 @@ posting "POSTINGS"
|
|||
[ update-tuple ]
|
||||
[
|
||||
<url>
|
||||
"$planet-factor/admin" >>path
|
||||
"$planet/admin" >>path
|
||||
swap id>> "id" set-query-param
|
||||
<redirect>
|
||||
]
|
||||
tri
|
||||
] >>submit ;
|
||||
|
||||
: <planet-factor-admin> ( -- responder )
|
||||
planet-factor-admin new-dispatcher
|
||||
: <planet-admin> ( -- responder )
|
||||
planet-admin new-dispatcher
|
||||
<edit-blogroll-action> "blogroll" add-main-responder
|
||||
<update-action> "update" add-responder
|
||||
<new-blog-action> "new-blog" add-responder
|
||||
|
|
@ -190,15 +190,15 @@ posting "POSTINGS"
|
|||
<delete-blog-action> "delete-blog" add-responder
|
||||
<protected>
|
||||
"administer Planet Factor" >>description
|
||||
{ can-administer-planet-factor? } >>capabilities ;
|
||||
{ can-administer-planet? } >>capabilities ;
|
||||
|
||||
: <planet-factor> ( -- responder )
|
||||
planet-factor new-dispatcher
|
||||
: <planet> ( -- responder )
|
||||
planet new-dispatcher
|
||||
<planet-action> "list" add-main-responder
|
||||
<planet-feed-action> "feed.xml" add-responder
|
||||
<planet-factor-admin> "admin" add-responder
|
||||
<planet-admin> "admin" add-responder
|
||||
<boilerplate>
|
||||
{ planet-factor "planet-common" } >>template ;
|
||||
{ planet "planet-common" } >>template ;
|
||||
|
||||
: start-update-task ( db params -- )
|
||||
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
|
||||
<t:title>Planet Factor</t:title>
|
||||
<t:title>Concatenative Planet</t:title>
|
||||
|
||||
<table width="100%" cellpadding="10">
|
||||
<tr>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
Look at the source to this page by clicking *Edit* to compare the farkup language with resulting output.
|
||||
|
||||
= level 1 heading =
|
||||
|
||||
== level 2 heading ==
|
||||
|
||||
=== level 3 heading ===
|
||||
|
||||
==== level 4 heading ====
|
||||
|
||||
Here is a paragraph of text, with _emphasized_ and *strong* text, together with an inline %code snippet%. Did you know that E=mc^2^, and L~2~ spaces are cool? Of course, if you want to include \_ special \* characters \^ you \~ can \% do that, too.
|
||||
|
||||
You can make [[Wiki Links]] just like that, as well as links to external sites: [[http://sbcl.sourceforge.net]]. [[Factor|Custom link text]] can be used [[http://www.apple.com|with both types of links]].
|
||||
|
||||
Images can be embedded in the text:
|
||||
|
||||
[[image:http://factorcode.org/graphics/logo.png]]
|
||||
|
||||
- a list
|
||||
- with three
|
||||
- items
|
||||
|
||||
|a table|with|four|columns|
|
||||
|and|two|rows|...|
|
||||
|
||||
Here is some code:
|
||||
|
||||
[{HAI
|
||||
CAN HAS STDIO?
|
||||
VISIBLE "HAI WORLD!"
|
||||
KTHXBYE}]
|
||||
|
||||
There is syntax highlighting various languages, too:
|
||||
|
||||
[factor{PEG: parse-request-line ( string -- triple )
|
||||
#! Triple is { method url version }
|
||||
[
|
||||
'space' ,
|
||||
'http-method' ,
|
||||
'space' ,
|
||||
'url' ,
|
||||
'space' ,
|
||||
'http-version' ,
|
||||
'space' ,
|
||||
] seq* just ;}]
|
||||
|
||||
Some Java:
|
||||
|
||||
[java{/**
|
||||
* Returns the extension of the specified filename, or an empty
|
||||
* string if there is none.
|
||||
* @param path The path
|
||||
*/
|
||||
public static String getFileExtension(String path)
|
||||
{
|
||||
int fsIndex = getLastSeparatorIndex(path);
|
||||
int index = path.lastIndexOf('.');
|
||||
// there could be a dot in the path and no file extension
|
||||
if(index == -1 || index < fsIndex )
|
||||
return "";
|
||||
else
|
||||
return path.substring(index);
|
||||
}}]
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
Congratulations, you are now running your very own Wiki.
|
||||
|
||||
You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text.
|
||||
|
||||
Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page.
|
||||
|
|
@ -13,6 +13,7 @@
|
|||
<t:a t:href="$wiki">Front Page</t:a>
|
||||
| <t:a t:href="$wiki/articles">All Articles</t:a>
|
||||
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
|
||||
| <t:a t:href="$wiki/random">Random Article</t:a>
|
||||
|
||||
<t:if t:code="furnace.auth:logged-in?">
|
||||
|
||||
|
|
@ -45,6 +46,16 @@
|
|||
</td>
|
||||
</t:if>
|
||||
</tr>
|
||||
|
||||
<tr>
|
||||
<td>
|
||||
<t:bind t:name="footer">
|
||||
<small>
|
||||
<t:farkup t:name="content" />
|
||||
</small>
|
||||
</t:bind>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
</t:chloe>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel hashtables calendar
|
||||
USING: accessors kernel hashtables calendar random assocs
|
||||
namespaces splitting sequences sorting math.order present
|
||||
io.files io.encodings.ascii
|
||||
syndication
|
||||
html.components html.forms
|
||||
http.server
|
||||
|
|
@ -115,6 +116,14 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
|
||||
{ wiki "view" } >>template ;
|
||||
|
||||
: <random-article-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
article new select-tuples random
|
||||
[ title>> ] [ "Front Page" ] if*
|
||||
view-url <redirect>
|
||||
] >>display ;
|
||||
|
||||
: amend-article ( revision article -- )
|
||||
swap id>> >>revision update-tuple ;
|
||||
|
||||
|
|
@ -286,15 +295,15 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
{ wiki "page-common" } >>template ;
|
||||
|
||||
: init-sidebar ( -- )
|
||||
"Sidebar" latest-revision [
|
||||
"sidebar" [ from-object ] nest-form
|
||||
] when* ;
|
||||
"Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when*
|
||||
"Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ;
|
||||
|
||||
: <wiki> ( -- dispatcher )
|
||||
wiki new-dispatcher
|
||||
<main-article-action> <article-boilerplate> "" add-responder
|
||||
<view-article-action> <article-boilerplate> "view" add-responder
|
||||
<view-revision-action> <article-boilerplate> "revision" add-responder
|
||||
<random-article-action> "random" add-responder
|
||||
<list-revisions-action> <article-boilerplate> "revisions" add-responder
|
||||
<list-revisions-feed-action> "revisions.atom" add-responder
|
||||
<diff-action> <article-boilerplate> "diff" add-responder
|
||||
|
|
@ -309,3 +318,15 @@ M: revision feed-entry-url id>> revision-url ;
|
|||
<boilerplate>
|
||||
[ init-sidebar ] >>init
|
||||
{ wiki "wiki-common" } >>template ;
|
||||
|
||||
: init-wiki ( -- )
|
||||
"resource:extra/webapps/wiki/initial-content" directory* keys
|
||||
[
|
||||
[ ascii file-contents ] [ file-name "." split1 drop ] bi
|
||||
f <revision>
|
||||
swap >>title
|
||||
swap >>content
|
||||
"slava" >>author
|
||||
now >>date
|
||||
add-revision
|
||||
] each ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ webapps.wee-url
|
|||
webapps.user-admin ;
|
||||
IN: websites.concatenative
|
||||
|
||||
: test-db ( -- db params ) "resource:test.db" sqlite-db ;
|
||||
: test-db ( -- params db ) "resource:test.db" sqlite-db ;
|
||||
|
||||
: init-factor-db ( -- )
|
||||
test-db [
|
||||
|
|
@ -48,7 +48,7 @@ TUPLE: factor-website < dispatcher ;
|
|||
<blogs> "blogs" add-responder
|
||||
<todo-list> "todo" add-responder
|
||||
<pastebin> "pastebin" add-responder
|
||||
<planet-factor> "planet" add-responder
|
||||
<planet> "planet" add-responder
|
||||
<wiki> "wiki" add-responder
|
||||
<wee-url> "wee-url" add-responder
|
||||
<user-admin> "user-admin" add-responder
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel windows.com windows.com.syntax windows.ole32
|
||||
alien alien.syntax tools.test libc alien.c-types arrays.lib
|
||||
alien alien.syntax tools.test libc alien.c-types
|
||||
namespaces arrays continuations accessors math windows.com.wrapper
|
||||
windows.com.wrapper.private destructors effects ;
|
||||
IN: windows.com.tests
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.c-types effects kernel windows.ole32
|
||||
parser lexer splitting grouping sequences.lib sequences namespaces
|
||||
assocs quotations shuffle accessors words macros alien.syntax
|
||||
parser lexer splitting grouping sequences namespaces
|
||||
assocs quotations generalizations accessors words macros alien.syntax
|
||||
fry arrays ;
|
||||
IN: windows.com.syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.c-types windows.com.syntax
|
||||
windows.com.syntax.private windows.com continuations kernel
|
||||
sequences.lib namespaces windows.ole32 libc vocabs
|
||||
assocs accessors arrays sequences quotations combinators
|
||||
math words compiler.units destructors fry
|
||||
math.parser combinators.lib ;
|
||||
namespaces windows.ole32 libc vocabs assocs accessors arrays
|
||||
sequences quotations combinators math words compiler.units
|
||||
destructors fry math.parser generalizations ;
|
||||
IN: windows.com.wrapper
|
||||
|
||||
TUPLE: com-wrapper vtbls disposed ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax parser namespaces kernel math
|
||||
windows.types shuffle math.bitfields alias ;
|
||||
windows.types generalizations math.bitfields alias ;
|
||||
IN: windows.user32
|
||||
|
||||
! HKL for ActivateKeyboardLayout
|
||||
|
|
@ -1285,10 +1285,10 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
|
|||
! FUNCTION: SetWindowPlacement
|
||||
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
|
||||
|
||||
: HWND_BOTTOM ALIEN: 1 ;
|
||||
: HWND_NOTOPMOST ALIEN: -2 ;
|
||||
: HWND_TOP ALIEN: 0 ;
|
||||
: HWND_TOPMOST ALIEN: -1 ;
|
||||
: HWND_BOTTOM ( -- alien ) 1 <alien> ;
|
||||
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
|
||||
: HWND_TOP ( -- alien ) 0 <alien> ;
|
||||
: HWND_TOPMOST ( -- alien ) -1 <alien> ;
|
||||
|
||||
! FUNCTION: SetWindowRgn
|
||||
! FUNCTION: SetWindowsHookA
|
||||
|
|
|
|||
|
|
@ -422,7 +422,10 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
|||
}
|
||||
if(jit_ignore_declare_p(untag_object(array),i))
|
||||
{
|
||||
if(offset == 0) return i;
|
||||
|
||||
i++;
|
||||
|
||||
break;
|
||||
}
|
||||
default:
|
||||
|
|
|
|||
Loading…
Reference in New Issue