Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
c9a1c0a02f
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private math math.private sequences
|
||||
sequences.private ;
|
||||
USING: accessors kernel kernel.private math math.private
|
||||
sequences sequences.private ;
|
||||
IN: arrays
|
||||
|
||||
M: array clone (clone) ;
|
||||
M: array length array-capacity ;
|
||||
M: array length length>> ;
|
||||
M: array nth-unsafe >r >fixnum r> array-nth ;
|
||||
M: array set-nth-unsafe >r >fixnum r> set-array-nth ;
|
||||
M: array resize resize-array ;
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
] [
|
||||
3dup nth-unsafe at*
|
||||
[ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: assoc-stack ( key seq -- value )
|
||||
dup length 1- swap (assoc-stack) ;
|
||||
|
|
@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
|
|||
: zip ( keys values -- alist )
|
||||
2array flip ; inline
|
||||
|
||||
: unzip ( assoc -- keys values )
|
||||
dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ;
|
||||
|
||||
: search-alist ( key alist -- pair i )
|
||||
[ first = ] with find swap ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,43 @@
|
|||
IN: binary-search
|
||||
USING: help.markup help.syntax sequences kernel math.order ;
|
||||
|
||||
ARTICLE: "binary-search" "Binary search"
|
||||
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
|
||||
{ $subsection search }
|
||||
"Variants of sequence words optimized for sorted sequences:"
|
||||
{ $subsection sorted-index }
|
||||
{ $subsection sorted-member? }
|
||||
{ $subsection sorted-memq? }
|
||||
{ $see-also "order-specifiers" "sequences-sorting" } ;
|
||||
|
||||
ABOUT: "binary-search"
|
||||
|
||||
HELP: search
|
||||
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
|
||||
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
|
||||
$nl
|
||||
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
|
||||
$nl
|
||||
"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
|
||||
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
|
||||
|
||||
{ find find-from find-last find-last find-last-from search } related-words
|
||||
|
||||
HELP: sorted-index
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
|
||||
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
|
||||
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
|
||||
|
||||
{ index index-from last-index last-index-from sorted-index } related-words
|
||||
|
||||
HELP: sorted-member?
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
|
||||
|
||||
{ member? sorted-member? } related-words
|
||||
|
||||
HELP: sorted-memq?
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
|
||||
|
||||
{ memq? sorted-memq? } related-words
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
IN: binary-search.tests
|
||||
USING: binary-search math.order vectors kernel tools.test ;
|
||||
|
||||
\ sorted-member? must-infer
|
||||
|
||||
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
|
||||
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
|
||||
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
|
||||
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
|
||||
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
|
||||
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
|
||||
|
||||
[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
|
||||
[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private accessors math
|
||||
math.order combinators ;
|
||||
IN: binary-search
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: midpoint ( seq -- elt )
|
||||
[ midpoint@ ] keep nth-unsafe ; inline
|
||||
|
||||
: decide ( quot seq -- quot seq <=> )
|
||||
[ midpoint swap call ] 2keep rot ; inline
|
||||
|
||||
: finish ( quot slice -- i elt )
|
||||
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
|
||||
[ drop ] [ dup ] [ ] tri* nth ; inline
|
||||
|
||||
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
|
||||
dup length 1 <= [
|
||||
finish
|
||||
] [
|
||||
decide {
|
||||
{ +eq+ [ finish ] }
|
||||
{ +lt+ [ dup midpoint@ head-slice (search) ] }
|
||||
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
|
||||
} case
|
||||
] if ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: search ( seq quot -- i elt )
|
||||
over empty? [ 2drop f f ] [ swap <flat-slice> (search) ] if ;
|
||||
inline
|
||||
|
||||
: natural-search ( obj seq -- i elt )
|
||||
[ <=> ] with search ;
|
||||
|
||||
: sorted-index ( obj seq -- i )
|
||||
natural-search drop ;
|
||||
|
||||
: sorted-member? ( obj seq -- ? )
|
||||
dupd natural-search nip = ;
|
||||
|
||||
: sorted-memq? ( obj seq -- ? )
|
||||
dupd natural-search nip eq? ;
|
||||
|
|
@ -37,7 +37,7 @@ nl
|
|||
array? hashtable? vector?
|
||||
tuple? sbuf? node? tombstone?
|
||||
|
||||
array-capacity array-nth set-array-nth
|
||||
array-nth set-array-nth
|
||||
|
||||
wrap probe
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts
|
|||
classes classes.builtin classes.tuple classes.tuple.private
|
||||
kernel.private vocabs vocabs.loader source-files definitions
|
||||
slots classes.union classes.intersection classes.predicate
|
||||
compiler.units bootstrap.image.private io.files accessors combinators ;
|
||||
compiler.units bootstrap.image.private io.files accessors
|
||||
combinators ;
|
||||
IN: bootstrap.primitives
|
||||
|
||||
"Creating primitives and basic runtime structures..." print flush
|
||||
|
|
@ -225,7 +226,9 @@ bi
|
|||
{ "imaginary" { "real" "math" } read-only }
|
||||
} define-builtin
|
||||
|
||||
"array" "arrays" create { } define-builtin
|
||||
"array" "arrays" create {
|
||||
{ "length" { "array-capacity" "sequences.private" } read-only }
|
||||
} define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
{ "wrapped" read-only }
|
||||
|
|
@ -261,7 +264,9 @@ bi
|
|||
{ "sub-primitive" read-only }
|
||||
} define-builtin
|
||||
|
||||
"byte-array" "byte-arrays" create { } define-builtin
|
||||
"byte-array" "byte-arrays" create {
|
||||
{ "length" { "array-capacity" "sequences.private" } read-only }
|
||||
} define-builtin
|
||||
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
|
|
@ -306,9 +311,12 @@ tuple
|
|||
} prepare-slots define-tuple-class
|
||||
|
||||
"curry" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
||||
{
|
||||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||
} cleave
|
||||
(( obj quot -- curry )) define-declared
|
||||
|
||||
"compose" "kernel" create
|
||||
|
|
@ -319,9 +327,12 @@ tuple
|
|||
} prepare-slots define-tuple-class
|
||||
|
||||
"compose" "kernel" lookup
|
||||
[ f "inline" set-word-prop ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ] tri
|
||||
{
|
||||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||
} cleave
|
||||
(( quot1 quot2 -- compose )) define-declared
|
||||
|
||||
! Sub-primitive words
|
||||
|
|
|
|||
|
|
@ -32,7 +32,6 @@ load-help? off
|
|||
"libc" require
|
||||
|
||||
"io.streams.c" require
|
||||
"io.thread" require
|
||||
"vocabs.loader" require
|
||||
|
||||
"syntax" require
|
||||
|
|
|
|||
|
|
@ -56,6 +56,8 @@ parse-command-line
|
|||
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
|
||||
"io.thread" require
|
||||
|
||||
! Set dll paths
|
||||
os wince? [ "windows.ce" require ] when
|
||||
os winnt? [ "windows.nt" require ] when
|
||||
|
|
|
|||
|
|
@ -59,6 +59,7 @@ IN: bootstrap.syntax
|
|||
"flushable"
|
||||
"foldable"
|
||||
"inline"
|
||||
"recursive"
|
||||
"parsing"
|
||||
"t"
|
||||
"{"
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private alien.accessors sequences
|
||||
USING: accessors kernel kernel.private alien.accessors sequences
|
||||
sequences.private math ;
|
||||
IN: byte-arrays
|
||||
|
||||
M: byte-array clone (clone) ;
|
||||
M: byte-array length array-capacity ;
|
||||
M: byte-array length length>> ;
|
||||
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
|
||||
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
|
||||
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ ERROR: bad-superclass class ;
|
|||
#! 4 slot == superclasses>>
|
||||
rot dup tuple? [
|
||||
layout-of 4 slot
|
||||
2dup array-capacity fixnum<
|
||||
2dup 1 slot fixnum<
|
||||
[ array-nth eq? ] [ 3drop f ] if
|
||||
] [ 3drop f ] if ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -90,10 +90,10 @@ ERROR: no-case ;
|
|||
: <buckets> ( initial length -- array )
|
||||
next-power-of-2 swap [ nip clone ] curry map ;
|
||||
|
||||
: distribute-buckets ( assoc initial quot -- buckets )
|
||||
spin [ length <buckets> ] keep
|
||||
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
|
||||
nip ; inline
|
||||
: distribute-buckets ( alist initial quot -- buckets )
|
||||
swapd [ >r dup first r> call 2array ] curry map
|
||||
[ length <buckets> dup ] keep
|
||||
[ first2 (distribute-buckets) ] with each ; inline
|
||||
|
||||
: hash-case-table ( default assoc -- array )
|
||||
V{ } [ 1array ] distribute-buckets
|
||||
|
|
|
|||
|
|
@ -30,10 +30,3 @@ words splitting grouping sorting ;
|
|||
\ + stack-trace-contains?
|
||||
\ > stack-trace-contains?
|
||||
] unit-test
|
||||
|
||||
: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
|
||||
|
||||
[ t ] [
|
||||
[ 10 quux ] ignore-errors
|
||||
\ sort stack-trace-contains?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value )
|
|||
[ peek-back ] [ pop-back* ] bi ;
|
||||
|
||||
: slurp-dequeue ( dequeue quot -- )
|
||||
over dequeue-empty? [ 2drop ] [
|
||||
[ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi
|
||||
] if ; inline
|
||||
[ drop [ dequeue-empty? not ] curry ]
|
||||
[ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
|
||||
|
||||
MIXIN: dequeue
|
||||
|
|
|
|||
|
|
@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ;
|
|||
: set-front-to-back ( dlist -- )
|
||||
dup front>> [ dup back>> >>front ] unless drop ;
|
||||
|
||||
: (dlist-find-node) ( dlist-node quot -- node/f ? )
|
||||
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
|
||||
over [
|
||||
[ call ] 2keep rot
|
||||
[ drop t ] [ >r next>> r> (dlist-find-node) ] if
|
||||
] [ 2drop f f ] if ; inline
|
||||
] [ 2drop f f ] if ; inline recursive
|
||||
|
||||
: dlist-find-node ( dlist quot -- node/f ? )
|
||||
>r front>> r> (dlist-find-node) ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces sequences strings words assocs
|
||||
combinators accessors ;
|
||||
combinators accessors arrays ;
|
||||
IN: effects
|
||||
|
||||
TUPLE: effect in out terminated? ;
|
||||
|
|
@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ;
|
|||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
GENERIC: (stack-picture) ( obj -- str )
|
||||
M: string (stack-picture) ;
|
||||
M: word (stack-picture) name>> ;
|
||||
M: integer (stack-picture) drop "object" ;
|
||||
GENERIC: effect>string ( obj -- str )
|
||||
M: string effect>string ;
|
||||
M: word effect>string name>> ;
|
||||
M: integer effect>string drop "object" ;
|
||||
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
|
||||
|
||||
: stack-picture ( seq -- string )
|
||||
[ [ (stack-picture) % CHAR: \s , ] each ] "" make ;
|
||||
[ [ effect>string % CHAR: \s , ] each ] "" make ;
|
||||
|
||||
: effect>string ( effect -- string )
|
||||
M: effect effect>string ( effect -- string )
|
||||
[
|
||||
"( " %
|
||||
[ in>> stack-picture % "-- " % ]
|
||||
|
|
@ -51,6 +52,9 @@ M: word stack-effect
|
|||
M: effect clone
|
||||
[ in>> clone ] [ out>> clone ] bi <effect> ;
|
||||
|
||||
: stack-height ( word -- n )
|
||||
stack-effect effect-height ;
|
||||
|
||||
: split-shuffle ( stack shuffle -- stack1 stack2 )
|
||||
in>> length cut* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lexer sets sequences kernel splitting effects ;
|
||||
USING: lexer sets sequences kernel splitting effects summary
|
||||
combinators debugger arrays parser ;
|
||||
IN: effects.parser
|
||||
|
||||
: parse-effect ( end -- effect )
|
||||
parse-tokens dup { "(" "((" } intersect empty? [
|
||||
{ "--" } split1 dup [
|
||||
<effect>
|
||||
] [
|
||||
"Stack effect declaration must contain --" throw
|
||||
DEFER: parse-effect
|
||||
|
||||
ERROR: bad-effect ;
|
||||
|
||||
M: bad-effect summary
|
||||
drop "Bad stack effect declaration" ;
|
||||
|
||||
: parse-effect-token ( end -- token/f )
|
||||
scan tuck = [ drop f ] [
|
||||
dup { f "(" "((" } member? [ bad-effect ] [
|
||||
":" ?tail [
|
||||
scan-word {
|
||||
{ \ ( [ ")" parse-effect ] }
|
||||
[ ]
|
||||
} case 2array
|
||||
] when
|
||||
] if
|
||||
] [
|
||||
"Stack effect declaration must not contain ( or ((" throw
|
||||
] if ;
|
||||
|
||||
: parse-effect-tokens ( end -- tokens )
|
||||
[ parse-effect-token dup ] curry [ ] [ drop ] produce ;
|
||||
|
||||
: parse-effect ( end -- effect )
|
||||
parse-effect-tokens { "--" } split1 dup
|
||||
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
|
||||
|
|
|
|||
|
|
@ -77,6 +77,9 @@ TUPLE: check-method class generic ;
|
|||
PREDICATE: method-body < word
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
||||
M: method-body inline?
|
||||
"method-generic" word-prop inline? ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
|
|
|
|||
|
|
@ -64,6 +64,9 @@ M: engine-word stack-effect
|
|||
[ extra-values ] [ stack-effect ] bi
|
||||
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
|
||||
|
||||
M: engine-word inline?
|
||||
"tuple-dispatch-generic" word-prop inline? ;
|
||||
|
||||
M: engine-word crossref? "forgotten" word-prop not ;
|
||||
|
||||
M: engine-word irrelevant? drop t ;
|
||||
|
|
|
|||
|
|
@ -37,14 +37,14 @@ SYMBOL: graph
|
|||
|
||||
SYMBOL: previous
|
||||
|
||||
: (closure) ( obj quot -- )
|
||||
: (closure) ( obj quot: ( elt -- assoc ) -- )
|
||||
over previous get key? [
|
||||
2drop
|
||||
] [
|
||||
over previous get conjoin
|
||||
dup slip
|
||||
[ nip (closure) ] curry assoc-each
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: closure ( obj quot -- assoc )
|
||||
H{ } clone [
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ TUPLE: hashtable
|
|||
<PRIVATE
|
||||
|
||||
: wrap ( i array -- n )
|
||||
array-capacity 1 fixnum-fast fixnum-bitand ; inline
|
||||
length>> 1 fixnum-fast fixnum-bitand ; inline
|
||||
|
||||
: hash@ ( key array -- i )
|
||||
>r hashcode >fixnum dup fixnum+fast r> wrap ; inline
|
||||
|
|
@ -27,10 +27,10 @@ TUPLE: hashtable
|
|||
dup ((empty)) eq?
|
||||
[ 3drop no-key ] [
|
||||
= [ rot drop t ] [ probe (key@) ] if
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: key@ ( key hash -- array n ? )
|
||||
array>> dup array-capacity 0 eq?
|
||||
array>> dup length>> 0 eq?
|
||||
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
|
||||
|
||||
: <hash-array> ( n -- array )
|
||||
|
|
@ -51,7 +51,7 @@ TUPLE: hashtable
|
|||
] [
|
||||
probe (new-key@)
|
||||
] if
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: new-key@ ( key hash -- array n empty? )
|
||||
array>> 2dup hash@ (new-key@) ; inline
|
||||
|
|
@ -71,7 +71,7 @@ TUPLE: hashtable
|
|||
|
||||
: hash-large? ( hash -- ? )
|
||||
[ count>> 3 fixnum*fast 1 fixnum+fast ]
|
||||
[ array>> array-capacity ] bi fixnum> ; inline
|
||||
[ array>> length>> ] bi fixnum> ; inline
|
||||
|
||||
: hash-stale? ( hash -- ? )
|
||||
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
|
||||
|
|
|
|||
|
|
@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ;
|
|||
[ unify-effects ] [ unify-dataflow ] bi ; inline
|
||||
|
||||
: infer-branches ( last branches node -- )
|
||||
#! last is a quotation which provides a #return or a #values
|
||||
#! last -> #return or #values
|
||||
#! node -> #if or #dispatch
|
||||
1 reify-curries
|
||||
call dup node,
|
||||
pop-d drop
|
||||
|
|
|
|||
|
|
@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
[ { ascii } declare decode-char ] \ decode-char inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
|
||||
|
||||
! Later
|
||||
|
||||
! [ t ] [
|
||||
|
|
|
|||
|
|
@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ;
|
|||
|
||||
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
|
||||
|
||||
TUPLE: #merge < node ;
|
||||
! Phi node: merging is a sequence of sequences of values
|
||||
TUPLE: #merge < node merging ;
|
||||
|
||||
: #merge ( -- node ) \ #merge all-out-node ;
|
||||
|
||||
|
|
@ -191,7 +192,7 @@ TUPLE: #declare < node ;
|
|||
: #drop ( n -- #shuffle )
|
||||
d-tail flatten-curries \ #shuffle in-node ;
|
||||
|
||||
: node-exists? ( node quot -- ? )
|
||||
: node-exists? ( node quot: ( node -- ? ) -- ? )
|
||||
over [
|
||||
2dup 2slip rot [
|
||||
2drop t
|
||||
|
|
@ -201,7 +202,7 @@ TUPLE: #declare < node ;
|
|||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
GENERIC: calls-label* ( label node -- ? )
|
||||
|
||||
|
|
@ -223,21 +224,21 @@ SYMBOL: node-stack
|
|||
|
||||
: iterate-next ( -- node ) node@ successor>> ;
|
||||
|
||||
: iterate-nodes ( node quot -- )
|
||||
: iterate-nodes ( node quot: ( -- ) -- )
|
||||
over [
|
||||
[ swap >node call node> drop ] keep iterate-nodes
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: (each-node) ( quot -- next )
|
||||
: (each-node) ( quot: ( node -- ) -- next )
|
||||
node@ [ swap call ] 2keep
|
||||
node-children [
|
||||
[
|
||||
[ (each-node) ] keep swap
|
||||
] iterate-nodes
|
||||
] each drop
|
||||
iterate-next ; inline
|
||||
iterate-next ; inline recursive
|
||||
|
||||
: with-node-iterator ( quot -- )
|
||||
>r V{ } clone node-stack r> with-variable ; inline
|
||||
|
|
@ -260,14 +261,14 @@ SYMBOL: node-stack
|
|||
2drop
|
||||
] if ; inline
|
||||
|
||||
: (transform-nodes) ( prev node quot -- )
|
||||
: (transform-nodes) ( prev node quot: ( node -- newnode ) -- )
|
||||
dup >r call dup [
|
||||
>>successor
|
||||
successor>> dup successor>>
|
||||
r> (transform-nodes)
|
||||
] [
|
||||
r> 2drop f >>successor drop
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: transform-nodes ( node quot -- new-node )
|
||||
over [
|
||||
|
|
|
|||
|
|
@ -10,16 +10,6 @@ classes classes.tuple ;
|
|||
|
||||
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
|
||||
|
||||
[ 0 ] [ { } bitfield-quot call ] unit-test
|
||||
|
||||
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
|
||||
|
||||
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
|
||||
|
||||
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
|
||||
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||
|
||||
TUPLE: color r g b ;
|
||||
|
||||
C: <color> color
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel words sequences generic math
|
||||
namespaces quotations assocs combinators math.bitfields
|
||||
namespaces quotations assocs combinators
|
||||
inference.backend inference.dataflow inference.state
|
||||
classes.tuple classes.tuple.private effects summary hashtables
|
||||
classes generic sets definitions generic.standard slots.private ;
|
||||
|
|
@ -48,25 +48,6 @@ IN: inference.transforms
|
|||
|
||||
\ spread [ spread>quot ] 1 define-transform
|
||||
|
||||
! Bitfields
|
||||
GENERIC: (bitfield-quot) ( spec -- quot )
|
||||
|
||||
M: integer (bitfield-quot) ( spec -- quot )
|
||||
[ swapd shift bitor ] curry ;
|
||||
|
||||
M: pair (bitfield-quot) ( spec -- quot )
|
||||
first2 over word? [ >r swapd execute r> ] [ ] ?
|
||||
[ shift bitor ] append 2curry ;
|
||||
|
||||
: bitfield-quot ( spec -- quot )
|
||||
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
|
||||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
\ flags [
|
||||
[ 0 , [ , \ bitor , ] each ] [ ] make
|
||||
] 1 define-transform
|
||||
|
||||
! Tuple operations
|
||||
: [get-slots] ( slots -- quot )
|
||||
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
|
||||
|
|
|
|||
|
|
@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ;
|
|||
{ CHAR: \n [ line-ends\n ] }
|
||||
} case ; inline
|
||||
|
||||
: ((read-until)) ( buf quot -- string/f sep/f )
|
||||
! quot: -- char stop?
|
||||
: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
|
||||
dup call
|
||||
[ >r drop "" like r> ]
|
||||
[ pick push ((read-until)) ] if ; inline
|
||||
[ pick push ((read-until)) ] if ; inline recursive
|
||||
|
||||
: (read-until) ( quot -- string/f sep/f )
|
||||
100 <sbuf> swap ((read-until)) ; inline
|
||||
|
|
|
|||
|
|
@ -109,10 +109,13 @@ DEFER: if
|
|||
: 2bi@ ( w x y z quot -- )
|
||||
dup 2bi* ; inline
|
||||
|
||||
: while ( pred body tail -- )
|
||||
: loop ( pred: ( -- ? ) -- )
|
||||
dup slip swap [ loop ] [ drop ] if ; inline recursive
|
||||
|
||||
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
|
||||
>r >r dup slip r> r> roll
|
||||
[ >r tuck 2slip r> while ]
|
||||
[ 2nip call ] if ; inline
|
||||
[ 2nip call ] if ; inline recursive
|
||||
|
||||
! Object protocol
|
||||
GENERIC: hashcode* ( depth obj -- code )
|
||||
|
|
|
|||
|
|
@ -59,9 +59,7 @@ SYMBOL: error-hook
|
|||
] recover ;
|
||||
|
||||
: until-quit ( -- )
|
||||
quit-flag get
|
||||
[ quit-flag off ]
|
||||
[ listen until-quit ] if ; inline
|
||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
||||
|
||||
: listener ( -- )
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
|
|
|
|||
|
|
@ -15,3 +15,13 @@ IN: math.bitfields.tests
|
|||
[ 3 ] [ foo ] unit-test
|
||||
[ 3 ] [ { a b } flags ] unit-test
|
||||
\ foo must-infer
|
||||
|
||||
[ 0 ] [ { } bitfield-quot call ] unit-test
|
||||
|
||||
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
|
||||
|
||||
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
|
||||
|
||||
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
|
||||
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math sequences words ;
|
||||
USING: arrays kernel math sequences words
|
||||
namespaces inference.transforms ;
|
||||
IN: math.bitfields
|
||||
|
||||
GENERIC: (bitfield) ( value accum shift -- newaccum )
|
||||
|
|
@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum )
|
|||
|
||||
: flags ( values -- n )
|
||||
0 [ dup word? [ execute ] when bitor ] reduce ;
|
||||
|
||||
GENERIC: (bitfield-quot) ( spec -- quot )
|
||||
|
||||
M: integer (bitfield-quot) ( spec -- quot )
|
||||
[ swapd shift bitor ] curry ;
|
||||
|
||||
M: pair (bitfield-quot) ( spec -- quot )
|
||||
first2 over word? [ >r swapd execute r> ] [ ] ?
|
||||
[ shift bitor ] append 2curry ;
|
||||
|
||||
: bitfield-quot ( spec -- quot )
|
||||
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
|
||||
|
||||
\ bitfield [ bitfield-quot ] 1 define-transform
|
||||
|
||||
\ flags [
|
||||
[ 0 , [ , \ bitor , ] each ] [ ] make
|
||||
] 1 define-transform
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ;
|
|||
|
||||
: (fixnum-log2) ( accum n -- accum )
|
||||
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
|
||||
inline
|
||||
inline recursive
|
||||
|
||||
M: fixnum (log2) 0 swap (fixnum-log2) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -124,21 +124,21 @@ M: float fp-nan?
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: (each-integer) ( i n quot -- )
|
||||
: (each-integer) ( i n quot: ( i -- ) -- )
|
||||
[ iterate-step iterate-next (each-integer) ]
|
||||
[ 3drop ] if-iterate? ; inline
|
||||
[ 3drop ] if-iterate? ; inline recursive
|
||||
|
||||
: (find-integer) ( i n quot -- i )
|
||||
: (find-integer) ( i n quot: ( i -- ? ) -- i )
|
||||
[
|
||||
iterate-step roll
|
||||
[ 2drop ] [ iterate-next (find-integer) ] if
|
||||
] [ 3drop f ] if-iterate? ; inline
|
||||
] [ 3drop f ] if-iterate? ; inline recursive
|
||||
|
||||
: (all-integers?) ( i n quot -- ? )
|
||||
: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
|
||||
[
|
||||
iterate-step roll
|
||||
[ iterate-next (all-integers?) ] [ 3drop f ] if
|
||||
] [ 3drop t ] if-iterate? ; inline
|
||||
] [ 3drop t ] if-iterate? ; inline recursive
|
||||
|
||||
: each-integer ( n quot -- )
|
||||
iterate-prep (each-integer) ; inline
|
||||
|
|
@ -152,7 +152,7 @@ PRIVATE>
|
|||
: all-integers? ( n quot -- ? )
|
||||
iterate-prep (all-integers?) ; inline
|
||||
|
||||
: find-last-integer ( n quot -- i )
|
||||
: find-last-integer ( n quot: ( i -- ? ) -- i )
|
||||
over 0 < [
|
||||
2drop f
|
||||
] [
|
||||
|
|
@ -161,4 +161,4 @@ PRIVATE>
|
|||
] [
|
||||
>r 1- r> find-last-integer
|
||||
] if
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -77,10 +77,6 @@ unit-test
|
|||
[ "-101.0e-2" string>number number>string ]
|
||||
unit-test
|
||||
|
||||
[ 5.0 ]
|
||||
[ "10.0/2" string>number ]
|
||||
unit-test
|
||||
|
||||
[ f ]
|
||||
[ "1e1/2" string>number ]
|
||||
unit-test
|
||||
|
|
@ -104,3 +100,11 @@ unit-test
|
|||
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
|
||||
|
||||
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
|
||||
|
||||
[ 0.0/0.0 ] [ "0/0." string>number ] unit-test
|
||||
|
||||
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
|
||||
|
||||
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
|
||||
|
||||
[ "-0.0" ] [ -0.0 number>string ] unit-test
|
||||
|
|
|
|||
|
|
@ -55,8 +55,9 @@ SYMBOL: negative?
|
|||
dup [ (base>) ] [ drop 0 swap ] if ;
|
||||
|
||||
: string>ratio ( str -- a/b )
|
||||
"-" ?head dup negative? set swap
|
||||
"/" split1 (base>) >r whole-part r>
|
||||
3dup and and [ / + ] [ 3drop f ] if ;
|
||||
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
|
||||
|
||||
: valid-digits? ( seq -- ? )
|
||||
{
|
||||
|
|
@ -66,20 +67,23 @@ SYMBOL: negative?
|
|||
} cond ;
|
||||
|
||||
: string>integer ( str -- n/f )
|
||||
"-" ?head swap
|
||||
string>digits dup valid-digits?
|
||||
[ radix get digits>integer ] [ drop f ] if ;
|
||||
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: base> ( str radix -- n/f )
|
||||
[
|
||||
"-" ?head dup negative? set >r
|
||||
{
|
||||
{ [ CHAR: / over member? ] [ string>ratio ] }
|
||||
{ [ CHAR: . over member? ] [ string>float ] }
|
||||
[ string>integer ]
|
||||
} cond
|
||||
r> [ dup [ neg ] when ] when
|
||||
CHAR: / over member? [
|
||||
string>ratio
|
||||
] [
|
||||
CHAR: . over member? [
|
||||
string>float
|
||||
] [
|
||||
string>integer
|
||||
] if
|
||||
] if
|
||||
] with-radix ;
|
||||
|
||||
: string>number ( str -- n/f ) 10 base> ;
|
||||
|
|
|
|||
|
|
@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables
|
|||
kernel.private sbufs growable assocs namespaces quotations
|
||||
math strings combinators ;
|
||||
|
||||
: (each-object) ( quot -- )
|
||||
next-object dup
|
||||
[ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline
|
||||
: (each-object) ( quot: ( obj -- ) -- )
|
||||
[ next-object dup ] swap [ drop ] while ; inline
|
||||
|
||||
: each-object ( quot -- )
|
||||
begin-scan (each-object) end-scan ; inline
|
||||
|
|
|
|||
|
|
@ -70,8 +70,6 @@ M: #label collect-label-info*
|
|||
[ V{ } clone node-stack get length 3array ] keep
|
||||
node-param label-info get set-at ;
|
||||
|
||||
USE: prettyprint
|
||||
|
||||
M: #call-label collect-label-info*
|
||||
node-param label-info get at
|
||||
node-stack get over third tail
|
||||
|
|
|
|||
|
|
@ -143,6 +143,14 @@ IN: optimizer.known-words
|
|||
{ [ dup optimize-instance? ] [ optimize-instance ] }
|
||||
} define-optimizers
|
||||
|
||||
! This is a special-case hack
|
||||
: redundant-array-capacity-check? ( #call -- ? )
|
||||
dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ;
|
||||
|
||||
\ array-capacity? {
|
||||
{ [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] }
|
||||
} define-optimizers
|
||||
|
||||
! eq? on the same object is always t
|
||||
{ eq? = } {
|
||||
{ { @ @ } [ 2drop t ] }
|
||||
|
|
|
|||
|
|
@ -219,7 +219,7 @@ M: number detect-number ;
|
|||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
USE: binary-search.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
|
|
@ -227,7 +227,7 @@ USE: sorting.private
|
|||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
[ dup midpoint@ cut-slice old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
|
|
|
|||
|
|
@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private
|
|||
slots.private ;
|
||||
IN: quotations
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: uncurry dup 3 slot swap 4 slot ; inline
|
||||
|
||||
: uncompose dup 3 slot swap 4 slot ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: quotation call (call) ;
|
||||
|
||||
M: curry call dup 3 slot swap 4 slot call ;
|
||||
M: curry call uncurry call ;
|
||||
|
||||
M: compose call dup 3 slot swap 4 slot slip call ;
|
||||
M: compose call uncompose slip call ;
|
||||
|
||||
M: wrapper equal?
|
||||
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -243,6 +243,7 @@ $nl
|
|||
{ $subsection "sequences-destructive" }
|
||||
{ $subsection "sequences-stacks" }
|
||||
{ $subsection "sequences-sorting" }
|
||||
{ $subsection "binary-search" }
|
||||
{ $subsection "sets" }
|
||||
"For inner loops:"
|
||||
{ $subsection "sequences-unsafe" } ;
|
||||
|
|
@ -585,8 +586,6 @@ HELP: index
|
|||
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
|
||||
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
|
||||
|
||||
{ index index-from last-index last-index-from member? memq? } related-words
|
||||
|
||||
HELP: index-from
|
||||
{ $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } }
|
||||
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ;
|
||||
|
|
|
|||
|
|
@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: array-capacity ( array -- n )
|
||||
1 slot { array-capacity } declare ; inline
|
||||
|
||||
: array-nth ( n array -- elt )
|
||||
swap 2 fixnum+fast slot ; inline
|
||||
|
||||
|
|
@ -241,7 +238,8 @@ INSTANCE: repetition immutable-sequence
|
|||
] 3keep ; inline
|
||||
|
||||
: (copy) ( dst i src j n -- dst )
|
||||
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
|
||||
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
|
||||
inline recursive
|
||||
|
||||
: prepare-subseq ( from to seq -- dst i src j n )
|
||||
[ >r swap - r> new-sequence dup 0 ] 3keep
|
||||
|
|
@ -653,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
: halves ( seq -- first second )
|
||||
dup midpoint@ cut-slice ;
|
||||
|
||||
: binary-reduce ( seq start quot -- value )
|
||||
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
|
||||
#! We can't use case here since combinators depends on
|
||||
#! sequences
|
||||
pick length dup 0 3 between? [
|
||||
|
|
@ -668,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
>r >r halves r> r>
|
||||
[ [ binary-reduce ] 2curry bi@ ] keep
|
||||
call
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: cut ( seq n -- before after )
|
||||
[ head ] [ tail ] 2bi ;
|
||||
|
|
|
|||
|
|
@ -2,18 +2,19 @@ USING: help.markup help.syntax kernel words math
|
|||
sequences math.order ;
|
||||
IN: sorting
|
||||
|
||||
ARTICLE: "sequences-sorting" "Sorting and binary search"
|
||||
"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
|
||||
ARTICLE: "sequences-sorting" "Sorting sequences"
|
||||
"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved."
|
||||
$nl
|
||||
"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences."
|
||||
$nl
|
||||
"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "."
|
||||
$nl
|
||||
"Sorting a sequence with a custom comparator:"
|
||||
{ $subsection sort }
|
||||
"Sorting a sequence with common comparators:"
|
||||
{ $subsection natural-sort }
|
||||
{ $subsection sort-keys }
|
||||
{ $subsection sort-values }
|
||||
"Binary search:"
|
||||
{ $subsection binsearch }
|
||||
{ $subsection binsearch* } ;
|
||||
{ $subsection sort-values } ;
|
||||
|
||||
ABOUT: "sequences-sorting"
|
||||
|
||||
|
|
@ -41,24 +42,4 @@ HELP: midpoint@
|
|||
{ $values { "seq" "a sequence" } { "n" integer } }
|
||||
{ $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ;
|
||||
|
||||
HELP: midpoint
|
||||
{ $values { "seq" "a sequence" } { "elt" object } }
|
||||
{ $description "Outputs the element at the midpoint of a sequence." } ;
|
||||
|
||||
HELP: partition
|
||||
{ $values { "seq" "a sequence" } { "n" integer } { "slice" slice } }
|
||||
{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ;
|
||||
|
||||
HELP: binsearch
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } }
|
||||
{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
|
||||
$nl
|
||||
"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
|
||||
|
||||
HELP: binsearch*
|
||||
{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } }
|
||||
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
|
||||
$nl
|
||||
"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ;
|
||||
|
||||
{ <=> compare natural-sort sort-keys sort-values } related-words
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: sorting sequences kernel math math.order random
|
||||
tools.test vectors ;
|
||||
tools.test vectors sets ;
|
||||
IN: sorting.tests
|
||||
|
||||
[ [ ] ] [ [ ] natural-sort ] unit-test
|
||||
[ { } ] [ { } natural-sort ] unit-test
|
||||
|
||||
[ { 270000000 270000001 } ]
|
||||
[ T{ slice f 270000000 270000002 270000002 } natural-sort ]
|
||||
|
|
@ -11,18 +11,16 @@ unit-test
|
|||
[ t ] [
|
||||
100 [
|
||||
drop
|
||||
100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
|
||||
100 [ 20 random [ 1000 random ] replicate ] replicate
|
||||
dup natural-sort
|
||||
[ set= ] [ nip [ before=? ] monotonic? ] 2bi and
|
||||
] all?
|
||||
] unit-test
|
||||
|
||||
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
|
||||
|
||||
[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
|
||||
! Is it a stable sort?
|
||||
[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test
|
||||
|
||||
[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
|
||||
[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
|
||||
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
|
||||
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
|
||||
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
|
||||
[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
|
||||
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,49 +1,141 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math sequences vectors math.order
|
||||
sequences sequences.private math.order ;
|
||||
IN: sorting
|
||||
|
||||
DEFER: sort
|
||||
! Optimized merge-sort:
|
||||
!
|
||||
! 1) only allocates 2 temporary arrays
|
||||
|
||||
! 2) first phase (interchanging pairs x[i], x[i+1] where
|
||||
! x[i] > x[i+1]) is handled specially
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <iterator> 0 tail-slice ; inline
|
||||
TUPLE: merge
|
||||
{ seq array }
|
||||
{ accum vector }
|
||||
{ accum1 vector }
|
||||
{ accum2 vector }
|
||||
{ from1 array-capacity }
|
||||
{ to1 array-capacity }
|
||||
{ from2 array-capacity }
|
||||
{ to2 array-capacity } ;
|
||||
|
||||
: this ( slice -- obj )
|
||||
dup slice-from swap slice-seq nth-unsafe ; inline
|
||||
|
||||
: next ( iterator -- )
|
||||
dup slice-from 1+ swap set-slice-from ; inline
|
||||
|
||||
: smallest ( iter1 iter2 quot -- elt )
|
||||
>r over this over this r> call +lt+ eq?
|
||||
-rot ? [ this ] keep next ; inline
|
||||
|
||||
: (merge) ( iter1 iter2 quot accum -- )
|
||||
>r pick empty? [
|
||||
drop nip r> push-all
|
||||
: dump ( from to seq accum -- )
|
||||
#! Optimize common case where to - from = 1, 2, or 3.
|
||||
>r >r 2dup swap - dup 1 =
|
||||
[ 2drop r> nth-unsafe r> push ] [
|
||||
dup 2 = [
|
||||
2drop dup 1+
|
||||
r> [ nth-unsafe ] curry bi@
|
||||
r> [ push ] curry bi@
|
||||
] [
|
||||
over empty? [
|
||||
2drop r> push-all
|
||||
dup 3 = [
|
||||
2drop dup 1+ dup 1+
|
||||
r> [ nth-unsafe ] curry tri@
|
||||
r> [ push ] curry tri@
|
||||
] [
|
||||
3dup smallest r> [ push ] keep (merge)
|
||||
drop r> subseq r> push-all
|
||||
] if
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: merge ( sorted1 sorted2 quot -- result )
|
||||
>r [ [ <iterator> ] bi@ ] 2keep r>
|
||||
rot length rot length + <vector>
|
||||
[ (merge) ] [ underlying>> ] bi ; inline
|
||||
: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
|
||||
: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
|
||||
: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
|
||||
: dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
|
||||
: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
|
||||
: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
|
||||
|
||||
: conquer ( first second quot -- result )
|
||||
[ tuck >r >r sort r> r> sort ] keep merge ; inline
|
||||
: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
|
||||
over r-done? [ drop dump-l ] [
|
||||
over l-done? [ drop dump-r ] [
|
||||
2dup decide
|
||||
[ over r-next ] [ over l-next ] if
|
||||
(merge)
|
||||
] if
|
||||
] if ; inline recursive
|
||||
|
||||
: flip-accum ( merge -- )
|
||||
dup [ accum>> ] [ accum1>> ] bi eq? [
|
||||
dup accum1>> underlying>> >>seq
|
||||
dup accum2>> >>accum
|
||||
] [
|
||||
dup accum1>> >>accum
|
||||
dup accum2>> underlying>> >>seq
|
||||
] if
|
||||
dup accum>> 0 >>length 2drop ; inline
|
||||
|
||||
: <merge> ( seq -- merge )
|
||||
\ merge new
|
||||
over >vector >>accum1
|
||||
swap length <vector> >>accum2
|
||||
dup accum1>> underlying>> >>seq
|
||||
dup accum2>> >>accum
|
||||
dup accum>> 0 >>length drop ; inline
|
||||
|
||||
: compute-midpoint ( merge -- merge )
|
||||
dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline
|
||||
|
||||
: merging ( from to merge -- )
|
||||
swap >>to2
|
||||
swap >>from1
|
||||
compute-midpoint
|
||||
dup [ to1>> ] [ seq>> length ] bi min >>to1
|
||||
dup [ to2>> ] [ seq>> length ] bi min >>to2
|
||||
dup to1>> >>from2
|
||||
drop ; inline
|
||||
|
||||
: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline
|
||||
|
||||
: chunks ( length size -- n ) [ align ] keep /i ; inline
|
||||
|
||||
: each-chunk ( length size quot -- )
|
||||
[ [ chunks ] keep ] dip
|
||||
[ nth-chunk ] prepose curry
|
||||
each-integer ; inline
|
||||
|
||||
: merge ( from to merge quot -- )
|
||||
[ [ merging ] keep ] dip (merge) ; inline
|
||||
|
||||
: sort-pass ( merge size quot -- )
|
||||
[
|
||||
over flip-accum
|
||||
over [ seq>> length ] 2dip
|
||||
] dip
|
||||
[ merge ] 2curry each-chunk ; inline
|
||||
|
||||
: sort-loop ( merge quot -- )
|
||||
[ 2 [ over seq>> length over > ] ] dip
|
||||
[ [ 1 shift 2dup ] dip sort-pass ] curry
|
||||
[ ] while 2drop ; inline
|
||||
|
||||
: each-pair ( seq quot -- )
|
||||
[ [ length 1+ 2/ ] keep ] dip
|
||||
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
|
||||
|
||||
: (sort-pairs) ( i1 i2 seq quot accum -- )
|
||||
>r >r 2dup length = [
|
||||
nip nth r> drop r> push
|
||||
] [
|
||||
tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq?
|
||||
[ swap ] when r> tuck [ push ] 2bi@
|
||||
] if ; inline
|
||||
|
||||
: sort-pairs ( merge quot -- )
|
||||
[ [ seq>> ] [ accum>> ] bi ] dip swap
|
||||
[ (sort-pairs) ] 2curry each-pair ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: sort ( seq quot -- sortedseq )
|
||||
over length 1 <=
|
||||
[ drop ] [ over >r >r halves r> conquer r> like ] if ;
|
||||
: sort ( seq quot -- seq' )
|
||||
[ <merge> ] dip
|
||||
[ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
|
||||
inline
|
||||
|
||||
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
|
||||
|
|
@ -53,25 +145,3 @@ PRIVATE>
|
|||
: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
|
||||
|
||||
: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
|
||||
|
||||
: midpoint ( seq -- elt )
|
||||
[ midpoint@ ] keep nth-unsafe ; inline
|
||||
|
||||
: partition ( seq n -- slice )
|
||||
+gt+ eq? not swap halves ? ; inline
|
||||
|
||||
: (binsearch) ( elt quot seq -- i )
|
||||
dup length 1 <= [
|
||||
slice-from 2nip
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup +eq+ eq?
|
||||
[ drop dup slice-from swap midpoint@ + 2nip ]
|
||||
[ partition (binsearch) ] if
|
||||
] if ; inline
|
||||
|
||||
: binsearch ( elt seq quot -- i )
|
||||
swap dup empty?
|
||||
[ 3drop f ] [ <flat-slice> (binsearch) ] if ; inline
|
||||
|
||||
: binsearch* ( elt seq quot -- result )
|
||||
over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ IN: splitting
|
|||
: (split) ( separators n seq -- )
|
||||
3dup rot [ member? ] curry find-from drop
|
||||
[ [ swap subseq , ] 2keep 1+ swap (split) ]
|
||||
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline
|
||||
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
|
||||
|
||||
: split, ( seq separators -- ) 0 rot (split) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -89,6 +89,7 @@ IN: bootstrap.syntax
|
|||
"POSTPONE:" [ scan-word parsed ] define-syntax
|
||||
"\\" [ scan-word literalize parsed ] define-syntax
|
||||
"inline" [ word make-inline ] define-syntax
|
||||
"recursive" [ word make-recursive ] define-syntax
|
||||
"foldable" [ word make-foldable ] define-syntax
|
||||
"flushable" [ word make-flushable ] define-syntax
|
||||
"delimiter" [ word t "delimiter" set-word-prop ] define-syntax
|
||||
|
|
|
|||
|
|
@ -195,7 +195,7 @@ M: real sleep
|
|||
<thread> [ (spawn) ] keep ;
|
||||
|
||||
: spawn-server ( quot name -- thread )
|
||||
>r [ [ ] [ ] while ] curry r> spawn ;
|
||||
>r [ loop ] curry r> spawn ;
|
||||
|
||||
: in-thread ( quot -- )
|
||||
>r datastack r>
|
||||
|
|
|
|||
|
|
@ -164,6 +164,9 @@ M: object redefined drop ;
|
|||
: make-inline ( word -- )
|
||||
t "inline" set-word-prop ;
|
||||
|
||||
: make-recursive ( word -- )
|
||||
t "recursive" set-word-prop ;
|
||||
|
||||
: make-flushable ( word -- )
|
||||
t "flushable" set-word-prop ;
|
||||
|
||||
|
|
@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- )
|
|||
M: word reset-word
|
||||
{
|
||||
"unannotated-def"
|
||||
"parsing" "inline" "foldable" "flushable"
|
||||
"parsing" "inline" "recursive" "foldable" "flushable"
|
||||
"predicating"
|
||||
"reading" "writing"
|
||||
"constructing"
|
||||
|
|
@ -222,6 +225,10 @@ ERROR: bad-create name vocab ;
|
|||
: constructor-word ( name vocab -- word )
|
||||
>r "<" swap ">" 3append r> create ;
|
||||
|
||||
GENERIC: inline? ( word -- ? )
|
||||
|
||||
M: word inline? "inline" word-prop ;
|
||||
|
||||
PREDICATE: parsing-word < word "parsing" word-prop ;
|
||||
|
||||
: delimiter? ( obj -- ? )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
ui.gadgets.handler
|
||||
ui.gadgets.slate
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.buttons
|
||||
|
|
@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
|
|||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gadgets.theme
|
||||
ui.gadgets.handler
|
||||
accessors
|
||||
qualified
|
||||
namespaces.lib assocs.lib vars
|
||||
rewrite-closures automata math.geometry.rect newfx ;
|
||||
|
||||
|
|
@ -23,13 +22,6 @@ IN: automata.ui
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
QUALIFIED: ui.gadgets.grids
|
||||
|
||||
: grid-add ( grid child i j -- grid )
|
||||
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
|
||||
|
||||
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
|
||||
|
|
@ -80,13 +72,15 @@ DEFER: automata-window
|
|||
"5 - Random Rule" [ random-rule ] view-button add-gadget
|
||||
"n - New" [ automata-window ] view-button add-gadget
|
||||
|
||||
@top grid-add
|
||||
@top grid-add*
|
||||
|
||||
C[ display ] <slate>
|
||||
{ 400 400 } >>dim
|
||||
{ 400 400 } >>pdim
|
||||
dup >slate
|
||||
|
||||
@center grid-add
|
||||
@center grid-add*
|
||||
|
||||
<handler>
|
||||
|
||||
H{ }
|
||||
T{ key-down f f "1" } [ start-center ] view-action is
|
||||
|
|
@ -95,9 +89,7 @@ DEFER: automata-window
|
|||
T{ key-down f f "5" } [ random-rule ] view-action is
|
||||
T{ key-down f f "n" } [ automata-window ] view-action is
|
||||
|
||||
<handler>
|
||||
|
||||
tuck set-gadget-delegate
|
||||
>>table
|
||||
|
||||
"Automata" open-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,20 +1,68 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel continuations sequences namespaces fry ;
|
||||
USING: kernel continuations combinators sequences quotations arrays namespaces
|
||||
fry summary assocs math math.order macros ;
|
||||
|
||||
IN: backtrack
|
||||
|
||||
SYMBOL: failure
|
||||
|
||||
: amb ( seq -- elt )
|
||||
failure get
|
||||
'[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each
|
||||
, continue ] callcc1 ;
|
||||
ERROR: amb-failure ;
|
||||
|
||||
M: amb-failure summary drop "Backtracking failure" ;
|
||||
|
||||
: fail ( -- )
|
||||
f amb drop ;
|
||||
failure get [ continue ]
|
||||
[ amb-failure ] if* ;
|
||||
|
||||
: require ( ? -- )
|
||||
[ fail ] unless ;
|
||||
|
||||
MACRO: checkpoint ( quot -- quot' )
|
||||
'[ failure get ,
|
||||
'[ '[ failure set , continue ] callcc0
|
||||
, failure set @ ] callcc0 ] ;
|
||||
|
||||
: number-from ( from -- from+n )
|
||||
[ 1 + number-from ] checkpoint ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: unsafe-number-from-to ( to from -- to from+n )
|
||||
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
|
||||
|
||||
: number-from-to ( to from -- to from+n )
|
||||
2dup < [ fail ] when unsafe-number-from-to ;
|
||||
|
||||
: amb-integer ( seq -- int )
|
||||
length 1 - 0 number-from-to nip ;
|
||||
|
||||
MACRO: unsafe-amb ( seq -- quot )
|
||||
dup length 1 =
|
||||
[ first 1quotation ]
|
||||
[ [ first ] [ rest ] bi
|
||||
'[ , [ drop , unsafe-amb ] checkpoint ] ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: amb-lazy ( seq -- elt )
|
||||
[ amb-integer ] [ nth ] bi ;
|
||||
|
||||
: amb ( seq -- elt )
|
||||
dup empty?
|
||||
[ drop fail f ]
|
||||
[ unsafe-amb ] if ; inline
|
||||
|
||||
MACRO: amb-execute ( seq -- quot )
|
||||
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
|
||||
'[ , 0 unsafe-number-from-to nip , case ] ;
|
||||
|
||||
: if-amb ( true false -- )
|
||||
[
|
||||
[ { t f } amb ]
|
||||
[ '[ @ require t ] ]
|
||||
[ '[ @ f ] ]
|
||||
tri* if
|
||||
] with-scope ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,55 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: backtrack shuffle math math.ranges quotations locals fry
|
||||
kernel words io memoize macros io prettyprint sequences assocs
|
||||
combinators namespaces ;
|
||||
IN: benchmark.backtrack
|
||||
|
||||
! This was suggested by Dr_Ford. Compute the number of quadruples
|
||||
! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by
|
||||
! placing them on the stack, and applying the operations
|
||||
! +, -, * and rot as many times as we wish.
|
||||
|
||||
: nop ;
|
||||
|
||||
: do-something ( a b -- c )
|
||||
{ + - * } amb-execute ;
|
||||
|
||||
: some-rots ( a b c -- a b c )
|
||||
#! Try to rot 0, 1 or 2 times.
|
||||
{ nop rot -rot } amb-execute ;
|
||||
|
||||
MEMO: 24-from-1 ( a -- ? )
|
||||
24 = ;
|
||||
|
||||
MEMO: 24-from-2 ( a b -- ? )
|
||||
[ do-something 24-from-1 ] [ 2drop ] if-amb ;
|
||||
|
||||
MEMO: 24-from-3 ( a b c -- ? )
|
||||
[ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ;
|
||||
|
||||
MEMO: 24-from-4 ( a b c d -- ? )
|
||||
[ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ;
|
||||
|
||||
: find-impossible-24 ( -- n )
|
||||
1 10 [a,b] [| a |
|
||||
1 10 [a,b] [| b |
|
||||
1 10 [a,b] [| c |
|
||||
1 10 [a,b] [| d |
|
||||
a b c d 24-from-4
|
||||
] count
|
||||
] sigma
|
||||
] sigma
|
||||
] sigma ;
|
||||
|
||||
: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ;
|
||||
|
||||
: backtrack-benchmark ( -- )
|
||||
words [ reset-memoized ] each
|
||||
find-impossible-24 pprint "/10000 quadruples can make 24." print
|
||||
words [
|
||||
dup pprint " tested " write "memoize" word-prop assoc-size pprint
|
||||
" possibilities" print
|
||||
] each ;
|
||||
|
||||
MAIN: backtrack-benchmark
|
||||
|
|
@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
C[ display ] <slate> >slate
|
||||
t slate> set-gadget-clipped?
|
||||
{ 600 400 } slate> set-slate-dim
|
||||
{ 600 400 } slate> set-slate-pdim
|
||||
C[ [ run ] in-thread ] slate> set-slate-graft
|
||||
C[ loop off ] slate> set-slate-ungraft
|
||||
|
||||
|
|
@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
|
||||
} [ call ] map [ add-gadget ] each
|
||||
1 over set-pack-fill
|
||||
over @top grid-add
|
||||
@top grid-add*
|
||||
|
||||
slate> over @center grid-add
|
||||
slate> @center grid-add*
|
||||
|
||||
<handler>
|
||||
|
||||
H{ } clone
|
||||
T{ key-down f f "1" } C[ drop randomize ] is
|
||||
|
|
@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ;
|
|||
T{ key-down f f "d" } C[ drop dec-separation-weight ] is
|
||||
|
||||
T{ key-down f f "ESC" } C[ drop toggle-loop ] is
|
||||
<handler> tuck set-gadget-delegate "Boids" open-window ;
|
||||
|
||||
>>table
|
||||
|
||||
"Boids" open-window ;
|
||||
|
||||
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
|
||||
|
||||
|
|
|
|||
|
|
@ -204,7 +204,7 @@ VAR: start-shape
|
|||
|
||||
: cfdg-window* ( -- )
|
||||
[ display ] closed-quot <slate>
|
||||
{ 500 500 } over set-slate-dim
|
||||
{ 500 500 } over set-slate-pdim
|
||||
dup "CFDG" open-window ;
|
||||
|
||||
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
|
||||
|
|
@ -17,7 +17,7 @@ IN: channels.tests
|
|||
from
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 3 4 } } [
|
||||
{ { 1 2 3 4 } } [
|
||||
V{ } clone <channel>
|
||||
[ from swap push ] in-thread
|
||||
[ from swap push ] in-thread
|
||||
|
|
@ -30,7 +30,7 @@ IN: channels.tests
|
|||
natural-sort
|
||||
] unit-test
|
||||
|
||||
{ V{ 1 2 4 9 } } [
|
||||
{ { 1 2 4 9 } } [
|
||||
V{ } clone <channel>
|
||||
[ 4 swap to ] in-thread
|
||||
[ 2 swap to ] in-thread
|
||||
|
|
|
|||
|
|
@ -11,13 +11,13 @@ IN: cocoa.enumeration
|
|||
] with-malloc
|
||||
] with-malloc ; inline
|
||||
|
||||
:: (NSFastEnumeration-each) ( object quot state stackbuf count -- )
|
||||
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
|
||||
object state stackbuf count -> countByEnumeratingWithState:objects:count:
|
||||
dup zero? [ drop ] [
|
||||
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
|
||||
'[ , void*-nth quot call ] each
|
||||
object quot state stackbuf count (NSFastEnumeration-each)
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: NSFastEnumeration-each ( object quot -- )
|
||||
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline
|
||||
|
|
|
|||
|
|
@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ;
|
|||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
>r threads>> r> "mailbox" wait ;
|
||||
|
||||
: block-unless-pred ( mailbox timeout pred -- )
|
||||
: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
||||
pick check-disposed
|
||||
pick data>> over dlist-contains? [
|
||||
3drop
|
||||
] [
|
||||
>r 2dup wait-for-mailbox r> block-unless-pred
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over check-disposed
|
||||
|
|
@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
|
|||
f mailbox-get-all-timeout ;
|
||||
|
||||
: while-mailbox-empty ( mailbox quot -- )
|
||||
over mailbox-empty? [
|
||||
dup >r dip r> while-mailbox-empty
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
[ [ mailbox-empty? ] curry ] dip [ ] while ; inline
|
||||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
3dup block-unless-pred
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ SYMBOL: exit
|
|||
} match-cond ;
|
||||
|
||||
[ -5 ] [
|
||||
[ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
|
||||
[ 0 [ counter ] loop ] "Counter" spawn "counter" set
|
||||
{ increment 10 } "counter" get send
|
||||
{ decrement 15 } "counter" get send
|
||||
[ value , self , ] { } make "counter" get send
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences sorting math math.order
|
||||
arrays combinators kernel ;
|
||||
USING: accessors assocs sequences sorting binary-search math
|
||||
math.order arrays combinators kernel ;
|
||||
IN: cords
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -23,7 +23,7 @@ M: multi-cord length count>> ;
|
|||
|
||||
M: multi-cord virtual@
|
||||
dupd
|
||||
seqs>> [ first <=> ] binsearch*
|
||||
seqs>> [ first <=> ] with search nip
|
||||
[ first - ] [ second ] bi ;
|
||||
|
||||
M: multi-cord virtual-seq
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien strings arrays help.markup help.syntax ;
|
||||
USING: alien strings arrays help.markup help.syntax destructors ;
|
||||
IN: core-foundation
|
||||
|
||||
HELP: CF>array
|
||||
|
|
@ -37,6 +37,16 @@ HELP: load-framework
|
|||
{ $values { "name" "a pathname string" } }
|
||||
{ $description "Loads a Core Foundation framework." } ;
|
||||
|
||||
HELP: &CFRelease
|
||||
{ $values { "alien" "Pointer to a Core Foundation object" } }
|
||||
{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
HELP: |CFRelease
|
||||
{ $values { "interface" "Pointer to a Core Foundation object" } }
|
||||
{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
|
||||
|
||||
{ CFRelease |CFRelease &CFRelease } related-words
|
||||
|
||||
ARTICLE: "core-foundation" "Core foundation utilities"
|
||||
"The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words."
|
||||
$nl
|
||||
|
|
@ -51,7 +61,9 @@ $nl
|
|||
{ $subsection <CFFileSystemURL> }
|
||||
{ $subsection <CFURL> }
|
||||
"Frameworks:"
|
||||
{ $subsection load-framework } ;
|
||||
{ $subsection load-framework }
|
||||
"Memory management:"
|
||||
{ $subsection &CFRelease }
|
||||
{ $subsection |CFRelease } ;
|
||||
|
||||
IN: core-foundation
|
||||
ABOUT: "core-foundation"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||
math sequences io.encodings.utf16 ;
|
||||
math sequences io.encodings.utf16 destructors accessors ;
|
||||
IN: core-foundation
|
||||
|
||||
TYPEDEF: void* CFAllocatorRef
|
||||
|
|
@ -135,3 +135,9 @@ M: f <CFNumber>
|
|||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
M: CFRelease-destructor dispose* alien>> CFRelease ;
|
||||
: &CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa &dispose drop ; inline
|
||||
: |CFRelease ( alien -- alien )
|
||||
dup f CFRelease-destructor boa |dispose drop ; inline
|
||||
|
|
|
|||
|
|
@ -1,72 +0,0 @@
|
|||
USING: accessors arrays hints kernel locals math sequences ;
|
||||
|
||||
IN: disjoint-set
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: disjoint-set parents ranks counts ;
|
||||
|
||||
: count ( a disjoint-set -- n )
|
||||
counts>> nth ; inline
|
||||
|
||||
: add-count ( p a disjoint-set -- )
|
||||
[ count [ + ] curry ] keep counts>> swap change-nth ; inline
|
||||
|
||||
: parent ( a disjoint-set -- p )
|
||||
parents>> nth ; inline
|
||||
|
||||
: set-parent ( p a disjoint-set -- )
|
||||
parents>> set-nth ; inline
|
||||
|
||||
: link-sets ( p a disjoint-set -- )
|
||||
[ set-parent ]
|
||||
[ add-count ] 3bi ; inline
|
||||
|
||||
: rank ( a disjoint-set -- r )
|
||||
ranks>> nth ; inline
|
||||
|
||||
: inc-rank ( a disjoint-set -- )
|
||||
ranks>> [ 1+ ] change-nth ; inline
|
||||
|
||||
: representative? ( a disjoint-set -- ? )
|
||||
dupd parent = ; inline
|
||||
|
||||
: representative ( a disjoint-set -- p )
|
||||
2dup representative? [ drop ] [
|
||||
[ [ parent ] keep representative dup ] 2keep set-parent
|
||||
] if ;
|
||||
|
||||
: representatives ( a b disjoint-set -- r r )
|
||||
[ representative ] curry bi@ ; inline
|
||||
|
||||
: ranks ( a b disjoint-set -- r r )
|
||||
[ rank ] curry bi@ ; inline
|
||||
|
||||
:: branch ( a b neg zero pos -- )
|
||||
a b = zero [ a b < neg pos if ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <disjoint-set> ( n -- disjoint-set )
|
||||
[ >array ]
|
||||
[ 0 <array> ]
|
||||
[ 1 <array> ] tri
|
||||
disjoint-set boa ;
|
||||
|
||||
: equiv-set-size ( a disjoint-set -- n )
|
||||
[ representative ] keep count ;
|
||||
|
||||
: equiv? ( a b disjoint-set -- ? )
|
||||
representatives = ; inline
|
||||
|
||||
:: equate ( a b disjoint-set -- )
|
||||
a b disjoint-set representatives
|
||||
2dup = [ 2drop ] [
|
||||
2dup disjoint-set ranks
|
||||
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
|
||||
disjoint-set link-sets
|
||||
] if ;
|
||||
|
||||
HINTS: equate disjoint-set ;
|
||||
HINTS: representative disjoint-set ;
|
||||
HINTS: equiv-set-size disjoint-set ;
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2008 Eric Mertens.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hints kernel locals math hashtables
|
||||
assocs ;
|
||||
|
||||
IN: disjoint-sets
|
||||
|
||||
TUPLE: disjoint-set
|
||||
{ parents hashtable read-only }
|
||||
{ ranks hashtable read-only }
|
||||
{ counts hashtable read-only } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: count ( a disjoint-set -- n )
|
||||
counts>> at ; inline
|
||||
|
||||
: add-count ( p a disjoint-set -- )
|
||||
[ count [ + ] curry ] keep counts>> swap change-at ; inline
|
||||
|
||||
: parent ( a disjoint-set -- p )
|
||||
parents>> at ; inline
|
||||
|
||||
: set-parent ( p a disjoint-set -- )
|
||||
parents>> set-at ; inline
|
||||
|
||||
: link-sets ( p a disjoint-set -- )
|
||||
[ set-parent ] [ add-count ] 3bi ; inline
|
||||
|
||||
: rank ( a disjoint-set -- r )
|
||||
ranks>> at ; inline
|
||||
|
||||
: inc-rank ( a disjoint-set -- )
|
||||
ranks>> [ 1+ ] change-at ; inline
|
||||
|
||||
: representative? ( a disjoint-set -- ? )
|
||||
dupd parent = ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: representative ( a disjoint-set -- p )
|
||||
|
||||
M: disjoint-set representative
|
||||
2dup representative? [ drop ] [
|
||||
[ [ parent ] keep representative dup ] 2keep set-parent
|
||||
] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: representatives ( a b disjoint-set -- r r )
|
||||
[ representative ] curry bi@ ; inline
|
||||
|
||||
: ranks ( a b disjoint-set -- r r )
|
||||
[ rank ] curry bi@ ; inline
|
||||
|
||||
:: branch ( a b neg zero pos -- )
|
||||
a b = zero [ a b < neg pos if ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <disjoint-set> ( -- disjoint-set )
|
||||
H{ } clone H{ } clone H{ } clone disjoint-set boa ;
|
||||
|
||||
GENERIC: add-atom ( a disjoint-set -- )
|
||||
|
||||
M: disjoint-set add-atom
|
||||
[ dupd parents>> set-at ]
|
||||
[ 0 -rot ranks>> set-at ]
|
||||
[ 1 -rot counts>> set-at ]
|
||||
2tri ;
|
||||
|
||||
GENERIC: equiv-set-size ( a disjoint-set -- n )
|
||||
|
||||
M: disjoint-set equiv-set-size [ representative ] keep count ;
|
||||
|
||||
GENERIC: equiv? ( a b disjoint-set -- ? )
|
||||
|
||||
M: disjoint-set equiv? representatives = ;
|
||||
|
||||
GENERIC: equate ( a b disjoint-set -- )
|
||||
|
||||
M:: disjoint-set equate ( a b disjoint-set -- )
|
||||
a b disjoint-set representatives
|
||||
2dup = [ 2drop ] [
|
||||
2dup disjoint-set ranks
|
||||
[ swap ] [ over disjoint-set inc-rank ] [ ] branch
|
||||
disjoint-set link-sets
|
||||
] if ;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
|
||||
USING: kernel namespaces sequences math
|
||||
listener io prettyprint sequences.lib fry ;
|
||||
|
||||
IN: display-stack
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: watched-variables
|
||||
|
||||
: watch-var ( sym -- ) watched-variables get push ;
|
||||
|
||||
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
|
||||
|
||||
: unwatch-var ( sym -- ) watched-variables get delete ;
|
||||
|
||||
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
|
||||
|
||||
: print-watched-variables ( -- )
|
||||
watched-variables get length 0 >
|
||||
[
|
||||
"----------" print
|
||||
watched-variables get
|
||||
watched-variables get [ unparse ] map longest length 2 +
|
||||
'[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
|
||||
each
|
||||
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: display-stack ( -- )
|
||||
V{ } clone watched-variables set
|
||||
[
|
||||
print-watched-variables
|
||||
"----------" print
|
||||
datastack [ . ] each
|
||||
"----------" print
|
||||
retainstack reverse [ . ] each
|
||||
]
|
||||
listener-hook set ;
|
||||
|
||||
|
|
@ -1 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -1,12 +1,19 @@
|
|||
USING: farkup kernel tools.test ;
|
||||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test ;
|
||||
IN: farkup.tests
|
||||
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
] unit-test
|
||||
|
||||
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
[ ] [
|
||||
"abcd-*strong*\nasdifj\nweouh23ouh23\n"
|
||||
"paragraph" \ farkup rule parse drop
|
||||
] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
|
||||
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
|
||||
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
|
||||
|
|
@ -15,11 +22,20 @@ IN: farkup.tests
|
|||
[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
|
||||
[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n</ul>" ] [ "-foo\n" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
|
||||
[ "<ul><li>foo</li>\n<li>bar</li>\n</ul>" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
|
||||
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test
|
||||
[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
|
||||
|
|
@ -29,7 +45,7 @@ IN: farkup.tests
|
|||
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "" convert-farkup ] unit-test
|
||||
|
||||
|
|
@ -77,8 +93,5 @@ IN: farkup.tests
|
|||
] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[
|
||||
"<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
|
||||
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
|
||||
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,72 +1,111 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.styles kernel memoize namespaces peg math
|
||||
combinators sequences strings html.elements xml.entities
|
||||
xmode.code2html splitting io.streams.string peg.parsers
|
||||
sequences.deep unicode.categories ;
|
||||
USING: accessors arrays combinators html.elements io io.streams.string
|
||||
kernel math memoize namespaces peg peg.ebnf prettyprint
|
||||
sequences sequences.deep strings xml.entities vectors splitting
|
||||
xmode.code2html ;
|
||||
IN: farkup
|
||||
|
||||
SYMBOL: relative-link-prefix
|
||||
SYMBOL: disable-images?
|
||||
SYMBOL: link-no-follow?
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heading1 obj ;
|
||||
TUPLE: heading2 obj ;
|
||||
TUPLE: heading3 obj ;
|
||||
TUPLE: heading4 obj ;
|
||||
TUPLE: strong obj ;
|
||||
TUPLE: emphasis obj ;
|
||||
TUPLE: superscript obj ;
|
||||
TUPLE: subscript obj ;
|
||||
TUPLE: inline-code obj ;
|
||||
TUPLE: paragraph obj ;
|
||||
TUPLE: list-item obj ;
|
||||
TUPLE: list obj ;
|
||||
TUPLE: table obj ;
|
||||
TUPLE: table-row obj ;
|
||||
TUPLE: link href text ;
|
||||
TUPLE: image href text ;
|
||||
TUPLE: code mode string ;
|
||||
|
||||
: delimiters ( -- string )
|
||||
"*_^~%[-=|\\\r\n" ; inline
|
||||
EBNF: farkup
|
||||
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
|
||||
2nl = nl nl
|
||||
|
||||
MEMO: text ( -- parser )
|
||||
[ delimiters member? not ] satisfy repeat1
|
||||
[ >string escape-string ] action ;
|
||||
heading1 = "=" (!("=" | nl).)+ "="
|
||||
=> [[ second >string heading1 boa ]]
|
||||
|
||||
MEMO: delimiter ( -- parser )
|
||||
[ dup delimiters member? swap "\r\n=" member? not and ] satisfy
|
||||
[ 1string ] action ;
|
||||
heading2 = "==" (!("=" | nl).)+ "=="
|
||||
=> [[ second >string heading2 boa ]]
|
||||
|
||||
: surround-with-foo ( string tag -- seq )
|
||||
dup <foo> swap </foo> swapd 3array ;
|
||||
heading3 = "===" (!("=" | nl).)+ "==="
|
||||
=> [[ second >string heading3 boa ]]
|
||||
|
||||
: delimited ( str html -- parser )
|
||||
[
|
||||
over token hide ,
|
||||
text [ surround-with-foo ] swapd curry action ,
|
||||
token hide ,
|
||||
] seq* ;
|
||||
heading4 = "====" (!("=" | nl).)+ "===="
|
||||
=> [[ second >string heading4 boa ]]
|
||||
|
||||
MEMO: escaped-char ( -- parser )
|
||||
[ "\\" token hide , any-char , ] seq* [ >string ] action ;
|
||||
strong = "*" (!("*" | nl).)+ "*"
|
||||
=> [[ second >string strong boa ]]
|
||||
|
||||
MEMO: strong ( -- parser ) "*" "strong" delimited ;
|
||||
MEMO: emphasis ( -- parser ) "_" "em" delimited ;
|
||||
MEMO: superscript ( -- parser ) "^" "sup" delimited ;
|
||||
MEMO: subscript ( -- parser ) "~" "sub" delimited ;
|
||||
MEMO: inline-code ( -- parser ) "%" "code" delimited ;
|
||||
MEMO: nl ( -- parser )
|
||||
"\r\n" token [ drop "\n" ] action
|
||||
"\r" token [ drop "\n" ] action
|
||||
"\n" token 3choice ;
|
||||
MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
|
||||
MEMO: h1 ( -- parser ) "=" "h1" delimited ;
|
||||
MEMO: h2 ( -- parser ) "==" "h2" delimited ;
|
||||
MEMO: h3 ( -- parser ) "===" "h3" delimited ;
|
||||
MEMO: h4 ( -- parser ) "====" "h4" delimited ;
|
||||
emphasis = "_" (!("_" | nl).)+ "_"
|
||||
=> [[ second >string emphasis boa ]]
|
||||
|
||||
superscript = "^" (!("^" | nl).)+ "^"
|
||||
=> [[ second >string superscript boa ]]
|
||||
|
||||
subscript = "~" (!("~" | nl).)+ "~"
|
||||
=> [[ second >string subscript boa ]]
|
||||
|
||||
inline-code = "%" (!("%" | nl).)+ "%"
|
||||
=> [[ second >string inline-code boa ]]
|
||||
|
||||
escaped-char = "\" . => [[ second ]]
|
||||
|
||||
image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
|
||||
| "[[image:" (!("]").)+ "]]"
|
||||
=> [[ second >string f image boa ]]
|
||||
|
||||
simple-link = "[[" (!("|]" | "]]") .)+ "]]"
|
||||
=> [[ second >string dup link boa ]]
|
||||
|
||||
labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
|
||||
|
||||
link = image-link | labelled-link | simple-link
|
||||
|
||||
heading = heading4 | heading3 | heading2 | heading1
|
||||
|
||||
inline-tag = strong | emphasis | superscript | subscript | inline-code
|
||||
| link | escaped-char
|
||||
|
||||
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
|
||||
|
||||
table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
|
||||
=> [[ first ]]
|
||||
table-row = "|" (table-column)+
|
||||
=> [[ second table-row boa ]]
|
||||
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
|
||||
=> [[ table boa ]]
|
||||
|
||||
paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
|
||||
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
|
||||
| (paragraph-item nl)+ paragraph-item?
|
||||
| paragraph-item)
|
||||
=> [[ paragraph boa ]]
|
||||
|
||||
list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
|
||||
=> [[ second list-item boa ]]
|
||||
list = ((list-item nl)+ list-item? | list-item)
|
||||
=> [[ list boa ]]
|
||||
|
||||
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
|
||||
|
||||
stand-alone = (code | heading | list | table | paragraph | nl)*
|
||||
;EBNF
|
||||
|
||||
MEMO: eq ( -- parser )
|
||||
[
|
||||
h1 ensure-not ,
|
||||
h2 ensure-not ,
|
||||
h3 ensure-not ,
|
||||
h4 ensure-not ,
|
||||
"=" token ,
|
||||
] seq* ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] with-string-writer ;
|
||||
|
||||
: invalid-url "javascript:alert('Invalid URL in farkup');" ;
|
||||
|
||||
|
|
@ -85,116 +124,57 @@ MEMO: eq ( -- parser )
|
|||
: escape-link ( href text -- href-esc text-esc )
|
||||
>r check-url escape-quoted-string r> escape-string ;
|
||||
|
||||
: make-link ( href text -- seq )
|
||||
: write-link ( text href -- )
|
||||
escape-link
|
||||
[
|
||||
"<a" ,
|
||||
" href=\"" , >r , r> "\"" ,
|
||||
link-no-follow? get [ " nofollow=\"true\"" , ] when
|
||||
">" , , "</a>" ,
|
||||
] { } make ;
|
||||
"<a" write
|
||||
" href=\"" write write "\"" write
|
||||
link-no-follow? get [ " nofollow=\"true\"" write ] when
|
||||
">" write write "</a>" write ;
|
||||
|
||||
: make-image-link ( href alt -- seq )
|
||||
: write-image-link ( href text -- )
|
||||
disable-images? get [
|
||||
2drop "<strong>Images are not allowed</strong>"
|
||||
2drop "<strong>Images are not allowed</strong>" write
|
||||
] [
|
||||
escape-link
|
||||
[
|
||||
"<img src=\"" , swap , "\"" ,
|
||||
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
|
||||
"/>" ,
|
||||
] { } make
|
||||
>r "<img src=\"" write write "\"" write r>
|
||||
dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if
|
||||
"/>" write
|
||||
] if ;
|
||||
|
||||
MEMO: image-link ( -- parser )
|
||||
: render-code ( string mode -- string' )
|
||||
>r string-lines r>
|
||||
[
|
||||
"[[image:" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
|
||||
"|" token hide
|
||||
[ CHAR: ] = not ] satisfy repeat0 2seq
|
||||
[ first >string ] action optional ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first2 make-image-link ] action ;
|
||||
<pre>
|
||||
htmlize-lines
|
||||
</pre>
|
||||
] with-string-writer write ;
|
||||
|
||||
MEMO: simple-link ( -- parser )
|
||||
[
|
||||
"[[" token hide ,
|
||||
[ "|]" member? not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first dup make-link ] action ;
|
||||
|
||||
MEMO: labelled-link ( -- parser )
|
||||
[
|
||||
"[[" token hide ,
|
||||
[ CHAR: | = not ] satisfy repeat1 ,
|
||||
"|" token hide ,
|
||||
[ CHAR: ] = not ] satisfy repeat1 ,
|
||||
"]]" token hide ,
|
||||
] seq* [ first2 make-link ] action ;
|
||||
|
||||
MEMO: link ( -- parser )
|
||||
[ image-link , simple-link , labelled-link , ] choice* ;
|
||||
|
||||
DEFER: line
|
||||
MEMO: list-item ( -- parser )
|
||||
[
|
||||
"-" token hide , ! text ,
|
||||
[ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
|
||||
] seq* [ "li" surround-with-foo ] action ;
|
||||
|
||||
MEMO: list ( -- parser )
|
||||
list-item nl hide list-of
|
||||
[ "ul" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-column ( -- parser )
|
||||
text [ "td" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table-row ( -- parser )
|
||||
"|" token hide
|
||||
table-column "|" token hide list-of
|
||||
"|" token hide nl hide optional 4seq
|
||||
[ "tr" surround-with-foo ] action ;
|
||||
|
||||
MEMO: table ( -- parser )
|
||||
table-row repeat1
|
||||
[ "table" surround-with-foo ] action ;
|
||||
|
||||
MEMO: code ( -- parser )
|
||||
[
|
||||
"[" token hide ,
|
||||
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
|
||||
"{" token hide ,
|
||||
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
|
||||
"}]" token hide ,
|
||||
] seq* [ first2 swap render-code ] action ;
|
||||
|
||||
MEMO: line ( -- parser )
|
||||
[
|
||||
nl table 2seq ,
|
||||
nl list 2seq ,
|
||||
text , strong , emphasis , link ,
|
||||
superscript , subscript , inline-code ,
|
||||
escaped-char , delimiter , eq ,
|
||||
] choice* repeat1 ;
|
||||
|
||||
MEMO: paragraph ( -- parser )
|
||||
line
|
||||
nl over 2seq repeat0
|
||||
nl nl ensure-not 2seq optional 3seq
|
||||
[
|
||||
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
|
||||
[ "<p>" swap "</p>" 3array ] unless
|
||||
] action ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
PEG: parse-farkup ( -- parser )
|
||||
[
|
||||
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
|
||||
] choice* repeat0 nl optional 2seq ;
|
||||
|
||||
: write-farkup ( parse-result -- )
|
||||
[ dup string? [ write ] [ drop ] if ] deep-each ;
|
||||
GENERIC: write-farkup ( obj -- )
|
||||
: <foo.> ( string -- ) <foo> write ;
|
||||
: </foo.> ( string -- ) </foo> write ;
|
||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
|
||||
M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ;
|
||||
M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ;
|
||||
M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ;
|
||||
M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ;
|
||||
M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ;
|
||||
M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ;
|
||||
M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ;
|
||||
M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ;
|
||||
M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ;
|
||||
M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ;
|
||||
M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ;
|
||||
M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ;
|
||||
M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ;
|
||||
M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
|
||||
M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
|
||||
M: table-row write-farkup ( obj -- )
|
||||
obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ;
|
||||
M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ;
|
||||
M: fixnum write-farkup ( obj -- ) write1 ;
|
||||
M: string write-farkup ( obj -- ) write ;
|
||||
M: vector write-farkup ( obj -- ) [ write-farkup ] each ;
|
||||
M: f write-farkup ( obj -- ) drop ;
|
||||
|
||||
: convert-farkup ( string -- string' )
|
||||
parse-farkup [ write-farkup ] with-string-writer ;
|
||||
farkup [ write-farkup ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -19,10 +19,11 @@ HELP: fry
|
|||
|
||||
HELP: '[
|
||||
{ $syntax "code... ]" }
|
||||
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;
|
||||
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." }
|
||||
{ $examples "See " { $link "fry.examples" } "." } ;
|
||||
|
||||
ARTICLE: "fry.examples" "Examples of fried quotations"
|
||||
"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."
|
||||
"The easiest way to understand fried quotations is to look at some examples."
|
||||
$nl
|
||||
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
|
||||
{ $code "{ 10 20 30 } '[ . ] each" }
|
||||
|
|
@ -38,9 +39,10 @@ $nl
|
|||
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
|
||||
"{ 10 20 30 } [ 3 5 / ] map"
|
||||
}
|
||||
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
|
||||
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"
|
||||
{ $code
|
||||
"{ 10 20 30 } [ sq ] '[ @ . ] each"
|
||||
"{ 10 20 30 } [ sq ] [ call . ] curry each"
|
||||
"{ 10 20 30 } [ sq ] [ . ] compose each"
|
||||
"{ 10 20 30 } [ sq . ] each"
|
||||
}
|
||||
|
|
@ -50,16 +52,17 @@ $nl
|
|||
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
|
||||
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
|
||||
}
|
||||
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"
|
||||
"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:"
|
||||
{ $code
|
||||
"{ 10 20 30 } 1 '[ , _ / ] map"
|
||||
"{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"
|
||||
"{ 10 20 30 } 1 [ swap / ] curry map"
|
||||
"{ 10 20 30 } [ 1 swap / ] map"
|
||||
}
|
||||
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"
|
||||
{ $code
|
||||
"[ >r X r> ]"
|
||||
"[ X _ ]"
|
||||
"[ [ X ] dip ]"
|
||||
"'[ X _ ]"
|
||||
}
|
||||
"Here are some built-in combinators rewritten in terms of fried quotations:"
|
||||
{ $table
|
||||
|
|
@ -73,8 +76,11 @@ $nl
|
|||
} ;
|
||||
|
||||
ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
||||
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."
|
||||
$nl
|
||||
"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
|
||||
{ $code
|
||||
"'[ [ , key? ] all? ] filter"
|
||||
"[ [ key? ] curry all? ] curry filter"
|
||||
}
|
||||
"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
|
||||
{ $code
|
||||
"'[ 3 , + 4 , / ]"
|
||||
|
|
@ -87,7 +93,7 @@ $nl
|
|||
} ;
|
||||
|
||||
ARTICLE: "fry.limitations" "Fried quotation limitations"
|
||||
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;
|
||||
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
|
||||
|
||||
ARTICLE: "fry" "Fried quotations"
|
||||
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
|
||||
|
|
|
|||
|
|
@ -1,64 +1,64 @@
|
|||
|
||||
USING: kernel namespaces math math.constants math.functions arrays sequences
|
||||
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
|
||||
ui.gadgets.slate colors ;
|
||||
ui.gadgets.slate colors accessors combinators.cleave ;
|
||||
|
||||
IN: golden-section
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! To run:
|
||||
! "golden-section" run
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: disk ( quadric radius center -- )
|
||||
: disk ( radius center -- )
|
||||
glPushMatrix
|
||||
gl-translate
|
||||
dup 0 glScalef
|
||||
0 1 10 10 gluDisk
|
||||
gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
|
||||
glPopMatrix ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! omega(i) = 2*pi*i*(phi-1)
|
||||
|
||||
! x(i) = 0.5*i*cos(omega(i))
|
||||
! y(i) = 0.5*i*sin(omega(i))
|
||||
|
||||
! radius(i) = 10*sin((pi*i)/720)
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: omega ( i -- omega ) phi 1- * 2 * pi * ;
|
||||
|
||||
: x ( i -- x ) dup omega cos * 0.5 * ;
|
||||
: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
|
||||
: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ;
|
||||
|
||||
: y ( i -- y ) dup omega sin * 0.5 * ;
|
||||
|
||||
: center ( i -- point ) dup x swap y 2array ;
|
||||
: center ( i -- point ) { x y } 1arr ;
|
||||
|
||||
: radius ( i -- radius ) pi * 720 / sin 10 * ;
|
||||
|
||||
: color ( i -- color ) 360.0 / dup 0.25 1 4array ;
|
||||
|
||||
: rim ( quadric i -- )
|
||||
black gl-color dup radius 1.5 * swap center disk ;
|
||||
: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ;
|
||||
: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
|
||||
|
||||
: inner ( quadric i -- )
|
||||
dup color gl-color dup radius swap center disk ;
|
||||
: dot ( i -- ) [ rim ] [ inner ] bi ;
|
||||
|
||||
: dot ( quadric i -- ) 2dup rim inner ;
|
||||
|
||||
: golden-section ( quadric -- ) 720 [ dot ] with each ;
|
||||
: golden-section ( -- ) 720 [ dot ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: with-quadric ( quot -- )
|
||||
gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline
|
||||
|
||||
: display ( -- )
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-400 400 -400 400 -1 1 glOrtho
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ golden-section ] with-quadric ;
|
||||
golden-section ;
|
||||
|
||||
: golden-section-window ( -- )
|
||||
[
|
||||
[ display ] <slate>
|
||||
{ 600 600 } over set-slate-dim
|
||||
{ 600 600 } >>pdim
|
||||
"Golden Section" open-window
|
||||
] with-ui ;
|
||||
]
|
||||
with-ui ;
|
||||
|
||||
MAIN: golden-section-window
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections"
|
|||
{ $subsection "heaps" }
|
||||
{ $subsection "graphs" }
|
||||
{ $subsection "buffers" }
|
||||
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
|
||||
"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ;
|
||||
|
||||
USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ IN: help.lint
|
|||
: effect-values ( word -- seq )
|
||||
stack-effect
|
||||
[ in>> ] [ out>> ] bi append
|
||||
[ (stack-picture) ] map
|
||||
[ dup pair? [ first ] when effect>string ] map
|
||||
prune natural-sort ;
|
||||
|
||||
: contains-funky-elements? ( element -- ? )
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
|
|||
|
||||
[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
|
||||
|
||||
[ "<ul><li>foo</li><li>bar</li></ul>" ] [
|
||||
[ "<ul><li>foo</li>\n<li>bar</li></ul>" ] [
|
||||
[ "farkup" T{ farkup } render ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
USING: kernel sequences arrays accessors grouping
|
||||
math.order sorting math assocs locals namespaces ;
|
||||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays accessors grouping math.order
|
||||
sorting binary-search math assocs locals namespaces ;
|
||||
IN: interval-maps
|
||||
|
||||
TUPLE: interval-map array ;
|
||||
|
|
@ -7,7 +9,7 @@ TUPLE: interval-map array ;
|
|||
<PRIVATE
|
||||
|
||||
: find-interval ( key interval-map -- interval-node )
|
||||
[ first <=> ] binsearch* ;
|
||||
[ first <=> ] with search nip ;
|
||||
|
||||
: interval-contains? ( key interval-node -- ? )
|
||||
first2 between? ;
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ os { winnt linux macosx } member? [
|
|||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "xyz" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
] loop
|
||||
|
||||
"c1" get count-down
|
||||
|
||||
|
|
@ -64,7 +64,7 @@ os { winnt linux macosx } member? [
|
|||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "yxy" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
] loop
|
||||
|
||||
"c2" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
|
|
|
|||
|
|
@ -2,10 +2,11 @@ USING: alien.syntax alien.c-types core-foundation system
|
|||
combinators kernel sequences debugger io accessors ;
|
||||
IN: iokit
|
||||
|
||||
<< {
|
||||
{ [ os macosx? ] [ "/System/Library/Frameworks/IOKit.framework" load-framework ] }
|
||||
[ "IOKit only supported on Mac OS X" ]
|
||||
} cond >>
|
||||
<<
|
||||
os macosx?
|
||||
[ "/System/Library/Frameworks/IOKit.framework" load-framework ]
|
||||
when
|
||||
>>
|
||||
|
||||
: kIOKitBuildVersionKey "IOKitBuildVersion" ; inline
|
||||
: kIOKitDiagnosticsKey "IOKitDiagnostics" ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel tools.test accessors arrays sequences qualified
|
||||
io.streams.string io.streams.duplex namespaces threads
|
||||
calendar irc.client.private irc.client irc.messages.private
|
||||
concurrency.mailboxes classes ;
|
||||
concurrency.mailboxes classes assocs ;
|
||||
EXCLUDE: irc.messages => join ;
|
||||
RENAME: join irc.messages => join_
|
||||
IN: irc.client.tests
|
||||
|
|
@ -20,28 +20,6 @@ IN: irc.client.tests
|
|||
: with-dummy-client ( quot -- )
|
||||
rot with-variable ; inline
|
||||
|
||||
! Parsing tests
|
||||
irc-message new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
1array
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
privmsg new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
"#factortest" >>name
|
||||
1array
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
{ "" } make-client dup "factorbot" set-nick current-irc-client [
|
||||
{ t } [ irc> profile>> nickname>> me? ] unit-test
|
||||
|
||||
|
|
@ -74,11 +52,19 @@ privmsg new
|
|||
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
|
||||
} make-client dup "factorbot" set-nick
|
||||
[ connect-irc ] keep 1 seconds sleep
|
||||
join-messages>> 5 seconds mailbox-get-timeout
|
||||
join-messages>> 1 seconds mailbox-get-timeout
|
||||
[ class ] [ trailing>> ] bi ] unit-test
|
||||
! TODO: user join
|
||||
! ":somedude!n=user@isp.net JOIN :#factortest"
|
||||
|
||||
{ +join+ "somebody" } [
|
||||
{ ":somebody!n=somebody@some.where JOIN :#factortest"
|
||||
} make-client dup "factorbot" set-nick
|
||||
[ listeners>> [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
|
||||
[ connect-irc ]
|
||||
[ listeners>> [ "#factortest" ] dip at
|
||||
[ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri
|
||||
[ action>> ] [ nick>> ] bi
|
||||
] unit-test
|
||||
! TODO: channel message
|
||||
! ":somedude!n=user@isp.net PRIVMSG #factortest :hello"
|
||||
! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello"
|
||||
! TODO: direct private message
|
||||
! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello"
|
||||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
|
||||
accessors destructors namespaces io assocs arrays qualified fry
|
||||
continuations threads strings classes combinators
|
||||
irc.messages irc.messages.private ;
|
||||
continuations threads strings classes combinators splitting hashtables
|
||||
ascii irc.messages irc.messages.private ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.client
|
||||
|
|
@ -27,33 +27,50 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages
|
|||
|
||||
TUPLE: irc-listener in-messages out-messages ;
|
||||
TUPLE: irc-server-listener < irc-listener ;
|
||||
TUPLE: irc-channel-listener < irc-listener name password timeout ;
|
||||
TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
|
||||
TUPLE: irc-nick-listener < irc-listener name ;
|
||||
SYMBOL: +server-listener+
|
||||
|
||||
! participant modes
|
||||
SYMBOL: +operator+
|
||||
SYMBOL: +voice+
|
||||
SYMBOL: +normal+
|
||||
|
||||
: participant-mode ( n -- mode )
|
||||
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
|
||||
|
||||
! participant changed actions
|
||||
SYMBOL: +join+
|
||||
SYMBOL: +part+
|
||||
SYMBOL: +mode+
|
||||
|
||||
! listener objects
|
||||
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
|
||||
|
||||
: <irc-server-listener> ( -- irc-server-listener )
|
||||
<mailbox> <mailbox> irc-server-listener boa ;
|
||||
|
||||
: <irc-channel-listener> ( name -- irc-channel-listener )
|
||||
<mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
|
||||
[ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone irc-channel-listener boa ;
|
||||
|
||||
: <irc-nick-listener> ( name -- irc-nick-listener )
|
||||
<mailbox> <mailbox> rot irc-nick-listener boa ;
|
||||
[ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
|
||||
|
||||
! ======================================
|
||||
! Message objects
|
||||
! ======================================
|
||||
|
||||
TUPLE: participant-changed nick action ;
|
||||
C: <participant-changed> participant-changed
|
||||
|
||||
SINGLETON: irc-end ! sent when the client isn't running anymore
|
||||
SINGLETON: irc-disconnected ! sent when connection is lost
|
||||
SINGLETON: irc-connected ! sent when connection is established
|
||||
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
||||
|
||||
: terminate-irc ( irc-client -- )
|
||||
[ in-messages>> irc-end swap mailbox-put ]
|
||||
[ f >>is-running drop ]
|
||||
[ [ irc-end ] dip in-messages>> mailbox-put ]
|
||||
[ [ f ] dip (>>is-running) ]
|
||||
[ stream>> dispose ]
|
||||
tri ;
|
||||
|
||||
|
|
@ -70,22 +87,39 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
|
|||
: listener> ( name -- listener/f ) irc> listeners>> at ;
|
||||
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
|
||||
|
||||
: to-listener ( message name -- )
|
||||
GENERIC: to-listener ( message obj -- )
|
||||
|
||||
M: string to-listener ( message string -- )
|
||||
listener> [ +server-listener+ listener> ] unless*
|
||||
[ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
[ to-listener ] [ drop ] if* ;
|
||||
|
||||
M: irc-listener to-listener ( message irc-listener -- )
|
||||
in-messages>> mailbox-put ;
|
||||
|
||||
: remove-participant ( nick channel -- )
|
||||
listener> [ participants>> delete-at ] [ drop ] if* ;
|
||||
|
||||
: listeners-with-participant ( nick -- seq )
|
||||
irc> listeners>> values
|
||||
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
|
||||
with filter ;
|
||||
|
||||
: remove-participant-from-all ( nick -- )
|
||||
dup listeners-with-participant [ delete-at ] with each ;
|
||||
|
||||
: add-participant ( mode nick channel -- )
|
||||
listener> [ participants>> set-at ] [ 2drop ] if* ;
|
||||
|
||||
DEFER: me?
|
||||
|
||||
: maybe-forward-join ( join -- )
|
||||
[ prefix>> parse-name me? ] keep and
|
||||
[ irc> join-messages>> mailbox-put ] when* ;
|
||||
|
||||
! ======================================
|
||||
! IRC client messages
|
||||
! ======================================
|
||||
|
||||
GENERIC: irc-message>string ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>string ( irc-message -- string )
|
||||
[ command>> ]
|
||||
[ parameters>> " " sjoin ]
|
||||
[ trailing>> dup [ CHAR: : prefix ] when ]
|
||||
tri 3array " " sjoin ;
|
||||
|
||||
: /NICK ( nick -- )
|
||||
"NICK " irc-write irc-print ;
|
||||
|
||||
|
|
@ -99,7 +133,7 @@ M: irc-message irc-message>string ( irc-message -- string )
|
|||
|
||||
: /JOIN ( channel password -- )
|
||||
"JOIN " irc-write
|
||||
[ " :" swap 3append ] when* irc-print ;
|
||||
[ [ " :" ] dip 3append ] when* irc-print ;
|
||||
|
||||
: /PART ( channel text -- )
|
||||
[ "PART " irc-write irc-write ] dip
|
||||
|
|
@ -133,12 +167,31 @@ M: irc-message irc-message>string ( irc-message -- string )
|
|||
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
|
||||
|
||||
: broadcast-message-to-listeners ( message -- )
|
||||
irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
|
||||
irc> listeners>> values [ to-listener ] with each ;
|
||||
|
||||
GENERIC: handle-participant-change ( irc-message -- )
|
||||
|
||||
M: join handle-participant-change ( join -- )
|
||||
[ prefix>> parse-name +join+ <participant-changed> ]
|
||||
[ trailing>> ] bi to-listener ;
|
||||
|
||||
M: part handle-participant-change ( part -- )
|
||||
[ prefix>> parse-name +part+ <participant-changed> ]
|
||||
[ channel>> ] bi to-listener ;
|
||||
|
||||
M: kick handle-participant-change ( kick -- )
|
||||
[ who>> +part+ <participant-changed> ]
|
||||
[ channel>> ] bi to-listener ;
|
||||
|
||||
M: quit handle-participant-change ( quit -- )
|
||||
prefix>> parse-name
|
||||
[ +part+ <participant-changed> ] [ listeners-with-participant ] bi
|
||||
[ to-listener ] with each ;
|
||||
|
||||
GENERIC: handle-incoming-irc ( irc-message -- )
|
||||
|
||||
M: irc-message handle-incoming-irc ( irc-message -- )
|
||||
+server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
|
||||
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
|
||||
|
||||
M: logged-in handle-incoming-irc ( logged-in -- )
|
||||
name>> irc> profile>> (>>nickname) ;
|
||||
|
|
@ -153,17 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- )
|
|||
dup irc-message-origin to-listener ;
|
||||
|
||||
M: join handle-incoming-irc ( join -- )
|
||||
[ [ prefix>> parse-name me? ] keep and
|
||||
[ irc> join-messages>> mailbox-put ] when* ]
|
||||
{ [ maybe-forward-join ] ! keep
|
||||
[ dup trailing>> to-listener ]
|
||||
bi ;
|
||||
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
|
||||
[ handle-participant-change ]
|
||||
} cleave ;
|
||||
|
||||
M: part handle-incoming-irc ( part -- )
|
||||
dup channel>> to-listener ;
|
||||
[ dup channel>> to-listener ]
|
||||
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
|
||||
[ handle-participant-change ]
|
||||
tri ;
|
||||
|
||||
M: kick handle-incoming-irc ( kick -- )
|
||||
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
|
||||
to-listener ;
|
||||
{ [ dup channel>> to-listener ]
|
||||
[ [ who>> ] [ channel>> ] bi remove-participant ]
|
||||
[ handle-participant-change ]
|
||||
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
|
||||
} cleave ;
|
||||
|
||||
M: quit handle-incoming-irc ( quit -- )
|
||||
{ [ dup prefix>> parse-name listeners-with-participant
|
||||
[ to-listener ] with each ]
|
||||
[ handle-participant-change ]
|
||||
[ prefix>> parse-name remove-participant-from-all ]
|
||||
[ ]
|
||||
} cleave call-next-method ;
|
||||
|
||||
: >nick/mode ( string -- nick mode )
|
||||
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
|
||||
|
||||
: names-reply>participants ( names-reply -- participants )
|
||||
trailing>> [ blank? ] trim " " split
|
||||
[ >nick/mode 2array ] map >hashtable ;
|
||||
|
||||
M: names-reply handle-incoming-irc ( names-reply -- )
|
||||
[ names-reply>participants ] [ channel>> listener> ] bi
|
||||
[ (>>participants) ] [ drop ] if* ;
|
||||
|
||||
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
||||
broadcast-message-to-listeners ;
|
||||
|
|
@ -174,24 +253,19 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
|
|||
|
||||
GENERIC: handle-outgoing-irc ( obj -- )
|
||||
|
||||
! M: irc-message handle-outgoing-irc ( irc-message -- )
|
||||
! irc-message>string irc-print ;
|
||||
M: irc-message handle-outgoing-irc ( irc-message -- )
|
||||
irc-message>client-line irc-print ;
|
||||
|
||||
M: privmsg handle-outgoing-irc ( privmsg -- )
|
||||
[ name>> ] [ trailing>> ] bi /PRIVMSG ;
|
||||
|
||||
M: part handle-outgoing-irc ( privmsg -- )
|
||||
M: part handle-outgoing-irc ( part -- )
|
||||
[ channel>> ] [ trailing>> "" or ] bi /PART ;
|
||||
|
||||
! ======================================
|
||||
! Reader/Writer
|
||||
! ======================================
|
||||
|
||||
: irc-mailbox-get ( mailbox quot -- )
|
||||
swap 5 seconds
|
||||
'[ , , , mailbox-get-timeout swap call ]
|
||||
[ drop ] recover ; inline
|
||||
|
||||
: handle-reader-message ( irc-message -- )
|
||||
irc> in-messages>> mailbox-put ;
|
||||
|
||||
|
|
@ -199,11 +273,12 @@ DEFER: (connect-irc)
|
|||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc>
|
||||
[ in-messages>> irc-disconnected swap mailbox-put ]
|
||||
[ [ irc-disconnected ] dip to-listener ]
|
||||
[ dup reconnect-time>> sleep (connect-irc) ]
|
||||
[ profile>> nickname>> /LOGIN ]
|
||||
tri ;
|
||||
|
||||
! FIXME: do something with the exception, store somewhere to help debugging
|
||||
: handle-disconnect ( error -- )
|
||||
drop irc> is-running>> [ (handle-disconnect) ] when ;
|
||||
|
||||
|
|
@ -220,14 +295,14 @@ DEFER: (connect-irc)
|
|||
[ (reader-loop) ] [ handle-disconnect ] recover ;
|
||||
|
||||
: writer-loop ( -- )
|
||||
irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
|
||||
irc> out-messages>> mailbox-get handle-outgoing-irc ;
|
||||
|
||||
! ======================================
|
||||
! Processing loops
|
||||
! ======================================
|
||||
|
||||
: in-multiplexer-loop ( -- )
|
||||
irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
|
||||
irc> in-messages>> mailbox-get handle-incoming-irc ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
|
||||
|
|
@ -236,12 +311,12 @@ DEFER: (connect-irc)
|
|||
{
|
||||
{ [ dup string? ] [ strings>privmsg ] }
|
||||
{ [ dup privmsg instance? ] [ swap >>name ] }
|
||||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
: listener-loop ( name listener -- )
|
||||
out-messages>> swap
|
||||
'[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ]
|
||||
irc-mailbox-get ;
|
||||
out-messages>> mailbox-get maybe-annotate-with-name
|
||||
irc> out-messages>> mailbox-put ;
|
||||
|
||||
: spawn-irc-loop ( quot name -- )
|
||||
[ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip
|
||||
|
|
@ -275,7 +350,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
|
|||
[ name>> ] keep set+run-listener ;
|
||||
|
||||
M: irc-server-listener (add-listener) ( irc-server-listener -- )
|
||||
+server-listener+ swap set+run-listener ;
|
||||
[ +server-listener+ ] dip set+run-listener ;
|
||||
|
||||
GENERIC: (remove-listener) ( irc-listener -- )
|
||||
|
||||
|
|
@ -283,8 +358,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
|
|||
name>> unregister-listener ;
|
||||
|
||||
M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
|
||||
[ [ out-messages>> ] [ name>> ] bi
|
||||
\ part new swap >>channel mailbox-put ] keep
|
||||
[ [ name>> ] [ out-messages>> ] bi
|
||||
[ [ part new ] dip >>channel ] dip mailbox-put ] keep
|
||||
name>> unregister-listener ;
|
||||
|
||||
M: irc-server-listener (remove-listener) ( irc-server-listener -- )
|
||||
|
|
@ -294,10 +369,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
|
|||
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
|
||||
swap >>stream
|
||||
t >>is-running
|
||||
in-messages>> irc-connected swap mailbox-put ;
|
||||
in-messages>> [ irc-connected ] dip mailbox-put ;
|
||||
|
||||
: with-irc-client ( irc-client quot -- )
|
||||
>r current-irc-client r> with-variable ; inline
|
||||
[ current-irc-client ] dip with-variable ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
USING: kernel tools.test accessors arrays qualified
|
||||
irc.messages irc.messages.private ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages.tests
|
||||
|
||||
! Parsing tests
|
||||
irc-message new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
1array
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
privmsg new
|
||||
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"PRIVMSG" >>command
|
||||
{ "#factortest" } >>parameters
|
||||
"hi" >>trailing
|
||||
"#factortest" >>name
|
||||
1array
|
||||
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
join new
|
||||
":someuser!n=user@some.where JOIN :#factortest" >>line
|
||||
"someuser!n=user@some.where" >>prefix
|
||||
"JOIN" >>command
|
||||
{ } >>parameters
|
||||
"#factortest" >>trailing
|
||||
1array
|
||||
[ ":someuser!n=user@some.where JOIN :#factortest"
|
||||
parse-irc-line f >>timestamp ] unit-test
|
||||
|
||||
|
|
@ -1,13 +1,15 @@
|
|||
! Copyright (C) 2008 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry sequences splitting ascii calendar accessors combinators
|
||||
classes.tuple math.order ;
|
||||
USING: kernel fry splitting ascii calendar accessors combinators qualified
|
||||
arrays classes.tuple math.order ;
|
||||
RENAME: join sequences => sjoin
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.messages
|
||||
|
||||
TUPLE: irc-message line prefix command parameters trailing timestamp ;
|
||||
TUPLE: logged-in < irc-message name ;
|
||||
TUPLE: ping < irc-message ;
|
||||
TUPLE: join < irc-message channel ;
|
||||
TUPLE: join < irc-message ;
|
||||
TUPLE: part < irc-message channel ;
|
||||
TUPLE: quit < irc-message ;
|
||||
TUPLE: privmsg < irc-message name ;
|
||||
|
|
@ -16,8 +18,26 @@ TUPLE: roomlist < irc-message channel names ;
|
|||
TUPLE: nick-in-use < irc-message asterisk name ;
|
||||
TUPLE: notice < irc-message type ;
|
||||
TUPLE: mode < irc-message name channel mode ;
|
||||
TUPLE: names-reply < irc-message who = channel ;
|
||||
TUPLE: unhandled < irc-message ;
|
||||
|
||||
: <irc-client-message> ( command parameters trailing -- irc-message )
|
||||
irc-message new now >>timestamp
|
||||
[ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
|
||||
|
||||
GENERIC: irc-message>client-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>client-line ( irc-message -- string )
|
||||
[ command>> ]
|
||||
[ parameters>> " " sjoin ]
|
||||
[ trailing>> dup [ CHAR: : prefix ] when ]
|
||||
tri 3array " " sjoin ;
|
||||
|
||||
GENERIC: irc-message>server-line ( irc-message -- string )
|
||||
|
||||
M: irc-message irc-message>server-line ( irc-message -- string )
|
||||
drop "not implemented yet" ;
|
||||
|
||||
<PRIVATE
|
||||
! ======================================
|
||||
! Message parsing
|
||||
|
|
@ -43,6 +63,8 @@ TUPLE: unhandled < irc-message ;
|
|||
: split-trailing ( string -- string string/f )
|
||||
":" split1 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: string>irc-message ( string -- object )
|
||||
dup split-prefix split-trailing
|
||||
[ [ blank? ] trim " " split unclip swap ] dip
|
||||
|
|
@ -55,6 +77,7 @@ TUPLE: unhandled < irc-message ;
|
|||
{ "NOTICE" [ \ notice ] }
|
||||
{ "001" [ \ logged-in ] }
|
||||
{ "433" [ \ nick-in-use ] }
|
||||
{ "353" [ \ names-reply ] }
|
||||
{ "JOIN" [ \ join ] }
|
||||
{ "PART" [ \ part ] }
|
||||
{ "PRIVMSG" [ \ privmsg ] }
|
||||
|
|
@ -66,4 +89,3 @@ TUPLE: unhandled < irc-message ;
|
|||
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
|
||||
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
|
||||
|
||||
IN: irc.ui.commandparser
|
||||
|
||||
"irc.ui.commands" require
|
||||
|
||||
: command ( string string -- string command )
|
||||
dup empty? [ drop "say" ] when
|
||||
dup "irc.ui.commands" lookup
|
||||
[ nip ]
|
||||
[ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
|
||||
|
||||
: parse-message ( string -- )
|
||||
"/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
|
||||
|
||||
IN: irc.ui.commands
|
||||
|
||||
: say ( string -- )
|
||||
[ client get profile>> nickname>> <own-message> print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: quote ( string -- )
|
||||
drop ; ! THIS WILL CHANGE
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Default system ircui-rc file
|
||||
! Copy into .ircui-rc in your home directory and then change username and such
|
||||
! To find your home directory, type "home ." into a Factor listener
|
||||
|
||||
USING: irc.client irc.ui ;
|
||||
|
||||
"irc.freenode.org" 8001 "factor-irc" f ! server port nick password
|
||||
{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin
|
||||
server-open
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel io.files parser editors sequences ;
|
||||
|
||||
IN: irc.ui.load
|
||||
|
||||
: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
|
||||
|
||||
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
|
||||
|
||||
: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
|
||||
|
||||
: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
|
||||
|
||||
: run-ircui ( -- ) ircui-rc run-file ;
|
||||
|
|
@ -3,52 +3,81 @@
|
|||
|
||||
USING: accessors kernel threads combinators concurrency.mailboxes
|
||||
sequences strings hashtables splitting fry assocs hashtables
|
||||
ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers
|
||||
ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs
|
||||
io io.styles namespaces irc.client irc.messages ;
|
||||
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
|
||||
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
|
||||
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels
|
||||
io io.styles namespaces calendar calendar.format models
|
||||
irc.client irc.client.private irc.messages irc.messages.private
|
||||
irc.ui.commandparser irc.ui.load ;
|
||||
|
||||
IN: irc.ui
|
||||
|
||||
SYMBOL: listener
|
||||
|
||||
SYMBOL: client
|
||||
|
||||
TUPLE: ui-window client tabs ;
|
||||
|
||||
TUPLE: irc-tab < frame listener client listmodel ;
|
||||
|
||||
: write-color ( str color -- )
|
||||
foreground associate format ;
|
||||
: red { 0.5 0 0 1 } ;
|
||||
: green { 0 0.5 0 1 } ;
|
||||
: blue { 0 0 1 1 } ;
|
||||
: black { 0 0 0 1 } ;
|
||||
|
||||
: prefix>nick ( prefix -- nick )
|
||||
"!" split first ;
|
||||
: colors H{ { +operator+ { 0 0.5 0 1 } }
|
||||
{ +voice+ { 0 0 1 1 } }
|
||||
{ +normal+ { 0 0 0 1 } } } ;
|
||||
|
||||
: dot-or-parens ( string -- string )
|
||||
dup empty? [ drop "." ]
|
||||
[ "(" prepend ")" append ] if ;
|
||||
|
||||
GENERIC: write-irc ( irc-message -- )
|
||||
|
||||
M: privmsg write-irc
|
||||
"<" blue write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
">" blue write-color
|
||||
" " write
|
||||
[ prefix>> parse-name write ] keep
|
||||
"> " blue write-color
|
||||
trailing>> write ;
|
||||
|
||||
TUPLE: own-message message nick timestamp ;
|
||||
|
||||
: <own-message> ( message nick -- own-message )
|
||||
now own-message boa ;
|
||||
|
||||
M: own-message write-irc
|
||||
"<" blue write-color
|
||||
[ nick>> bold font-style associate format ] keep
|
||||
"> " blue write-color
|
||||
message>> write ;
|
||||
|
||||
M: join write-irc
|
||||
"* " green write-color
|
||||
prefix>> prefix>nick write
|
||||
prefix>> parse-name write
|
||||
" has entered the channel." green write-color ;
|
||||
|
||||
M: part write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left the channel(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left the channel" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: quit write-irc
|
||||
"* " red write-color
|
||||
[ prefix>> prefix>nick write ] keep
|
||||
" has left IRC(" red write-color
|
||||
trailing>> write
|
||||
")" red write-color ;
|
||||
[ prefix>> parse-name write ] keep
|
||||
" has left IRC" red write-color
|
||||
trailing>> dot-or-parens red write-color ;
|
||||
|
||||
M: mode write-irc
|
||||
"* " blue write-color
|
||||
[ name>> write ] keep
|
||||
" has applied mode " blue write-color
|
||||
[ mode>> write ] keep
|
||||
" to " blue write-color
|
||||
channel>> write ;
|
||||
|
||||
M: irc-end write-irc
|
||||
drop "* You have left IRC" red write-color ;
|
||||
|
|
@ -63,56 +92,92 @@ M: irc-message write-irc
|
|||
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
|
||||
|
||||
: print-irc ( irc-message -- )
|
||||
write-irc nl ;
|
||||
[ timestamp>> timestamp>hms write " " write ]
|
||||
[ write-irc nl ] bi ;
|
||||
|
||||
: send-message ( message listener client -- )
|
||||
"<" blue write-color
|
||||
profile>> nickname>> bold font-style associate format
|
||||
">" blue write-color
|
||||
" " write
|
||||
over write nl
|
||||
out-messages>> mailbox-put ;
|
||||
: send-message ( message -- )
|
||||
[ print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
|
||||
: display ( stream listener -- )
|
||||
GENERIC: handle-inbox ( tab message -- )
|
||||
|
||||
: filter-participants ( assoc val -- alist )
|
||||
[ >alist ] dip
|
||||
'[ second , = ] filter ;
|
||||
|
||||
: update-participants ( tab -- )
|
||||
[ listmodel>> ] [ listener>> participants>> ] bi
|
||||
[ +operator+ filter-participants ]
|
||||
[ +voice+ filter-participants ]
|
||||
[ +normal+ filter-participants ] tri
|
||||
append append swap set-model ;
|
||||
|
||||
M: participant-changed handle-inbox
|
||||
drop update-participants ;
|
||||
|
||||
M: object handle-inbox
|
||||
nip print-irc ;
|
||||
|
||||
: display ( stream tab -- )
|
||||
'[ , [ [ t ]
|
||||
[ , read-message print-irc ]
|
||||
[ , dup listener>> read-message handle-inbox ]
|
||||
[ ] while ] with-output-stream ] "ircv" spawn drop ;
|
||||
|
||||
: <irc-pane> ( listener -- pane )
|
||||
: <irc-pane> ( tab -- tab pane )
|
||||
<scrolling-pane>
|
||||
[ <pane-stream> swap display ] keep ;
|
||||
[ <pane-stream> swap display ] 2keep ;
|
||||
|
||||
TUPLE: irc-editor < editor outstream listener client ;
|
||||
|
||||
: <irc-editor> ( pane listener client -- editor )
|
||||
[ irc-editor new-editor
|
||||
swap >>listener swap <pane-stream> >>outstream
|
||||
] dip client>> >>client ;
|
||||
: <irc-editor> ( tab pane -- tab editor )
|
||||
over irc-editor new-editor
|
||||
swap listener>> >>listener swap <pane-stream> >>outstream
|
||||
over client>> >>client ;
|
||||
|
||||
: editor-send ( irc-editor -- )
|
||||
{ [ outstream>> ]
|
||||
[ editor-string ]
|
||||
[ listener>> ]
|
||||
[ client>> ]
|
||||
[ editor-string ]
|
||||
[ "" swap set-editor-string ] } cleave
|
||||
'[ , , , send-message ] with-output-stream ;
|
||||
'[ , listener set , client set , parse-message ] with-output-stream ;
|
||||
|
||||
irc-editor "general" f {
|
||||
{ T{ key-down f f "RET" } editor-send }
|
||||
{ T{ key-down f f "ENTER" } editor-send }
|
||||
} define-command-map
|
||||
|
||||
: irc-page ( name pane editor tabbed -- )
|
||||
[ [ <scroller> @bottom frame, ! editor
|
||||
<scroller> @center frame, ! pane
|
||||
] make-frame swap ] dip add-page ;
|
||||
: <irc-list> ( -- gadget model )
|
||||
[ drop ]
|
||||
[ first2 [ <label> ] dip >>color ]
|
||||
{ } <model> [ <list> ] keep ;
|
||||
|
||||
: <irc-tab> ( listener client -- irc-tab )
|
||||
irc-tab new-frame
|
||||
swap client>> >>client swap >>listener
|
||||
<irc-pane> [ <scroller> @center grid-add* ] keep
|
||||
<irc-editor> <scroller> @bottom grid-add* ;
|
||||
|
||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||
<irc-tab>
|
||||
<irc-list> [ <scroller> @right grid-add* ] dip >>listmodel
|
||||
[ update-participants ] keep ;
|
||||
|
||||
: <irc-server-tab> ( listener client -- irc-tab )
|
||||
<irc-tab> ;
|
||||
|
||||
M: irc-tab graft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
add-listener ;
|
||||
|
||||
M: irc-tab ungraft*
|
||||
[ listener>> ] [ client>> ] bi
|
||||
remove-listener ;
|
||||
|
||||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ client>> add-listener ]
|
||||
[ drop <irc-pane> dup ]
|
||||
[ [ <irc-editor> ] keep ] 2tri
|
||||
tabs>> irc-page ;
|
||||
[ <irc-channel-tab> swap ] keep
|
||||
tabs>> add-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
[ tabs>> ]
|
||||
|
|
@ -122,9 +187,13 @@ irc-editor "general" f {
|
|||
: ui-connect ( profile -- ui-window )
|
||||
<irc-client> ui-window new over >>client swap
|
||||
[ connect-irc ]
|
||||
[ listeners>> +server-listener+ swap at <irc-pane> <scroller>
|
||||
[ listeners>> +server-listener+ swap at over <irc-tab>
|
||||
"Server" associate <tabbed> >>tabs ] bi ;
|
||||
|
||||
: freenode-connect ( -- ui-window )
|
||||
"irc.freenode.org" 8001 "factor-irc" f
|
||||
<irc-profile> ui-connect [ irc-window ] keep ;
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
[ over join-channel ] each drop ;
|
||||
|
||||
: main-run ( -- ) run-ircui ;
|
||||
|
||||
MAIN: main-run
|
||||
|
|
|
|||
|
|
@ -184,7 +184,7 @@ DEFER: (d)
|
|||
[ length ] keep [ (graded-ker/im-d) ] curry map ;
|
||||
|
||||
: graded-betti ( generators -- seq )
|
||||
basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
|
||||
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
|
||||
|
||||
! Bi-graded for two-step complexes
|
||||
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
|
||||
|
|
|
|||
|
|
@ -275,7 +275,7 @@ M: wlet local-rewrite*
|
|||
: parse-locals ( -- vars assoc )
|
||||
")" parse-effect
|
||||
word [ over "declared-effect" set-word-prop ] when*
|
||||
effect-in make-locals dup push-locals ;
|
||||
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
|
||||
|
|
|
|||
|
|
@ -158,7 +158,9 @@ DEFER: empty-model
|
|||
: lsys-viewer ( -- )
|
||||
|
||||
[ ] <slate> >slate
|
||||
{ 400 400 } clone slate> set-slate-dim
|
||||
{ 400 400 } clone slate> set-slate-pdim
|
||||
|
||||
slate> <handler>
|
||||
|
||||
{
|
||||
|
||||
|
|
@ -194,13 +196,9 @@ DEFER: empty-model
|
|||
[ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
|
||||
camera-action ] }
|
||||
|
||||
! } [ make* ] map alist>hash <handler> >handler
|
||||
} [ make* ] map >hashtable >>table
|
||||
|
||||
} [ make* ] map >hashtable <handler> >handler
|
||||
|
||||
slate> handler> set-gadget-delegate
|
||||
|
||||
handler> "L-system view" open-window
|
||||
"L-system view" open-window
|
||||
|
||||
500 sleep
|
||||
|
||||
|
|
|
|||
|
|
@ -23,12 +23,12 @@ GENERIC: sqrt ( x -- y ) foldable
|
|||
M: real sqrt
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
|
||||
|
||||
: each-bit ( n quot -- )
|
||||
: each-bit ( n quot: ( ? -- ) -- )
|
||||
over 0 number= pick -1 number= or [
|
||||
2drop
|
||||
] [
|
||||
2dup >r >r >r odd? r> call r> 2/ r> each-bit
|
||||
] if ; inline
|
||||
] if ; inline recursive
|
||||
|
||||
GENERIC: (^) ( x y -- z ) foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
IN: math.geometry
|
||||
|
||||
GENERIC: width ( object -- width )
|
||||
GENERIC: height ( object -- width )
|
||||
|
||||
GENERIC# set-x! 1 ( object x -- object )
|
||||
GENERIC# set-y! 1 ( object y -- object )
|
||||
|
|
@ -1,13 +1,15 @@
|
|||
|
||||
USING: kernel arrays math.vectors ;
|
||||
USING: kernel arrays sequences math.vectors math.geometry accessors ;
|
||||
|
||||
IN: math.geometry.rect
|
||||
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
TUPLE: rect loc dim ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ;
|
||||
: init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
|
||||
|
||||
C: <rect> rect
|
||||
: <rect> ( loc dim -- rect ) rect boa ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new init-rect ;
|
||||
|
||||
M: array rect-loc ;
|
||||
|
||||
|
|
@ -40,3 +42,8 @@ M: array rect-dim drop { 0 0 } ;
|
|||
: rect-union ( rect1 rect2 -- newrect )
|
||||
(rect-union) <extent-rect> ;
|
||||
|
||||
M: rect width ( rect -- width ) dim>> first ;
|
||||
M: rect height ( rect -- height ) dim>> second ;
|
||||
|
||||
M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
|
||||
M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ SYMBOL: matrix
|
|||
|
||||
: nth-row ( row# -- seq ) matrix get nth ;
|
||||
|
||||
: change-row ( row# quot -- | quot: seq -- seq )
|
||||
: change-row ( row# quot: ( seq -- seq ) -- )
|
||||
matrix get swap change-nth ; inline
|
||||
|
||||
: exchange-rows ( row# row# -- ) matrix get exchange ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel lists.lazy math math.functions math.miller-rabin
|
||||
math.order math.primes.list math.ranges sequences sorting ;
|
||||
math.order math.primes.list math.ranges sequences sorting
|
||||
binary-search ;
|
||||
IN: math.primes
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -13,14 +14,14 @@ PRIVATE>
|
|||
|
||||
: next-prime ( n -- p )
|
||||
dup 999983 < [
|
||||
primes-under-million [ [ <=> ] binsearch 1+ ] keep nth
|
||||
primes-under-million [ natural-search drop 1+ ] keep nth
|
||||
] [
|
||||
next-odd find-prime-miller-rabin
|
||||
] if ; foldable
|
||||
|
||||
: prime? ( n -- ? )
|
||||
dup 1000000 < [
|
||||
dup primes-under-million [ <=> ] binsearch* =
|
||||
dup primes-under-million natural-search nip =
|
||||
] [
|
||||
miller-rabin
|
||||
] if ; foldable
|
||||
|
|
@ -37,7 +38,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ dup 2 < ] [ drop { } ] }
|
||||
{ [ dup 1000003 < ]
|
||||
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
|
||||
[ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
|
||||
[ primes-under-million 1000003 lprimes-from
|
||||
rot [ <= ] curry lwhile list>array append ]
|
||||
} cond ; foldable
|
||||
|
|
@ -45,6 +46,6 @@ PRIVATE>
|
|||
: primes-between ( low high -- seq )
|
||||
primes-upto
|
||||
[ 1- next-prime ] dip
|
||||
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
|
||||
[ natural-search drop ] keep [ length ] keep <slice> ; foldable
|
||||
|
||||
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ kernel strings ;
|
|||
{ { object ppc object } "b" }
|
||||
{ { string object windows } "c" }
|
||||
}
|
||||
V{ cpu os }
|
||||
{ cpu os }
|
||||
] [
|
||||
example-1 canonicalize-specializers
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: classes io kernel kernel.private math.parser namespaces
|
||||
optimizer prettyprint prettyprint.backend sequences words arrays
|
||||
match macros assocs sequences.private generic combinators
|
||||
sorting math quotations accessors inference inference.dataflow
|
||||
optimizer.specializers ;
|
||||
sorting math quotations accessors inference inference.backend
|
||||
inference.dataflow optimizer.specializers generator ;
|
||||
IN: optimizer.debugger
|
||||
|
||||
! A simple tool for turning dataflow IR into quotations, for
|
||||
|
|
@ -135,14 +135,21 @@ M: object node>quot
|
|||
|
||||
: optimized-word. ( word ? -- ) >r specialized-def r> optimized-quot. ;
|
||||
|
||||
SYMBOL: pass-count
|
||||
SYMBOL: words-called
|
||||
SYMBOL: generics-called
|
||||
SYMBOL: methods-called
|
||||
SYMBOL: intrinsics-called
|
||||
SYMBOL: node-count
|
||||
|
||||
: dataflow>report ( node -- alist )
|
||||
: count-optimization-passes ( node n -- node n )
|
||||
>r optimize-1
|
||||
[ r> 1+ count-optimization-passes ] [ r> ] if ;
|
||||
|
||||
: make-report ( word -- assoc )
|
||||
[
|
||||
word-dataflow nip 1 count-optimization-passes pass-count set
|
||||
|
||||
H{ } clone words-called set
|
||||
H{ } clone generics-called set
|
||||
H{ } clone methods-called set
|
||||
|
|
@ -164,14 +171,12 @@ SYMBOL: node-count
|
|||
node-count set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: quot-optimize-report ( quot -- report )
|
||||
dataflow optimize dataflow>report ;
|
||||
|
||||
: word-optimize-report ( word -- report )
|
||||
def>> quot-optimize-report ;
|
||||
|
||||
: report. ( report -- )
|
||||
[
|
||||
"==== Optimization passes:" print
|
||||
pass-count get .
|
||||
nl
|
||||
|
||||
"==== Total number of dataflow nodes:" print
|
||||
node-count get .
|
||||
|
||||
|
|
@ -186,4 +191,4 @@ SYMBOL: node-count
|
|||
] bind ;
|
||||
|
||||
: optimizer-report. ( word -- )
|
||||
word-optimize-report report. ;
|
||||
make-report report. ;
|
||||
|
|
|
|||
|
|
@ -449,7 +449,7 @@ foo=<foreign any-char> 'd'
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"USING: peg.ebnf ; \"ab\" [EBNF foo='a' foo='b' EBNF]" eval drop
|
||||
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
|
||||
] must-fail
|
||||
|
||||
{ t } [
|
||||
|
|
|
|||
|
|
@ -371,7 +371,7 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
|
|||
M: ebnf-rule (transform) ( ast -- parser )
|
||||
dup elements>>
|
||||
(transform) [
|
||||
swap symbol>> dup get { [ tuple? ] [ delegate parser? ] } 1&& [
|
||||
swap symbol>> dup get parser? [
|
||||
"Rule '" over append "' defined more than once" append throw
|
||||
] [
|
||||
set
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue