-! 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 ;
] [
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) ;
: 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
[ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi
[ drop ] [ dup ] [ ] tri* nth ; inline
-: (search) ( quot seq -- i elt )
+: (search) ( quot: ( elt -- <=> ) seq -- i elt )
dup length 1 <= [
finish
] [
{ +lt+ [ dup midpoint@ head-slice (search) ] }
{ +gt+ [ dup midpoint@ tail-slice (search) ] }
} case
- ] if ; inline
+ ] if ; inline recursive
PRIVATE>
array? hashtable? vector?
tuple? sbuf? node? tombstone?
- array-capacity array-nth set-array-nth
+ array-nth set-array-nth
wrap probe
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
{ "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 }
{ "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
} 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 ] tri
+} cleave
(( obj quot -- curry )) define-declared
"compose" "kernel" create
} 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 ] tri
+} cleave
(( quot1 quot2 -- compose )) define-declared
! Sub-primitive words
"libc" require
"io.streams.c" require
- "io.thread" require
"vocabs.loader" require
"syntax" require
"-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
"flushable"
"foldable"
"inline"
+ "recursive"
"parsing"
"t"
"{"
! 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
#! 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
: <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
[ 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
: 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
! 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? ;
[ 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 % "-- " % ]
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* ;
! 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 ;
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 ;
[ 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 ;
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 [
<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
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 )
] [
probe (new-key@)
] if
- ] if ; inline
+ ] if ; inline recursive
: new-key@ ( key hash -- array n empty? )
array>> 2dup hash@ (new-key@) ; inline
: 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
[ 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
[ { ascii } declare decode-char ] \ decode-char inlined?
] unit-test
+[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
+
! Later
! [ t ] [
: #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 ;
: #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
] if
] [
2drop f
- ] if ; inline
+ ] if ; inline recursive
GENERIC: calls-label* ( label node -- ? )
: 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
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 [
! 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 ;
\ 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 ;
{ 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
: 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 )
] 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 ;
[ 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
! 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 )
: 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
: (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) ;
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
: 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
] [
] [
>r 1- r> find-last-integer
] if
- ] if ; inline
+ ] if ; inline recursive
[ "-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
[ "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
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 -- ? )
{
} 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> ;
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
[ 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
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 ;
<PRIVATE
-: array-capacity ( array -- n )
- 1 slot { array-capacity } declare ; inline
-
: array-nth ( n array -- elt )
swap 2 fixnum+fast slot ; inline
] 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
: 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? [
>r >r halves r> r>
[ [ binary-reduce ] 2curry bi@ ] keep
call
- ] if ; inline
+ ] if ; inline recursive
: cut ( seq n -- before after )
[ head ] [ tail ] 2bi ;
: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
-: (merge) ( merge quot -- )
+: (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
+ ] if ; inline recursive
: flip-accum ( merge -- )
dup [ accum>> ] [ accum1>> ] bi eq? [
[ merge ] 2curry each-chunk ; inline
: sort-loop ( merge quot -- )
- 2 swap
- [ pick seq>> length pick > ]
- [ [ dup ] [ 1 shift ] [ ] tri* [ sort-pass ] 2keep ]
- [ ] while 3drop ; inline
+ [ 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
: (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) ;
"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
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
- >r [ [ ] [ ] while ] curry r> spawn ;
+ >r [ loop ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack r>
: make-inline ( word -- )
t "inline" set-word-prop ;
+: make-recursive ( word -- )
+ t "recursive" set-word-prop ;
+
: make-flushable ( word -- )
t "flushable" set-word-prop ;
M: word reset-word
{
"unannotated-def"
- "parsing" "inline" "foldable" "flushable"
+ "parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
"constructing"
: 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 -- ? )
! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: kernel continuations sequences namespaces fry ;\r
+USING: kernel continuations combinators sequences quotations arrays namespaces\r
+ fry summary assocs math math.order macros ;\r
\r
IN: backtrack\r
\r
SYMBOL: failure\r
\r
-: amb ( seq -- elt )\r
- failure get\r
- '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
- , continue ] callcc1 ;\r
+ERROR: amb-failure ;\r
+\r
+M: amb-failure summary drop "Backtracking failure" ;\r
\r
: fail ( -- )\r
- f amb drop ;\r
+ failure get [ continue ]\r
+ [ amb-failure ] if* ;\r
\r
: require ( ? -- )\r
[ fail ] unless ;\r
\r
+MACRO: checkpoint ( quot -- quot' )\r
+ '[ failure get ,\r
+ '[ '[ failure set , continue ] callcc0\r
+ , failure set @ ] callcc0 ] ;\r
+\r
+: number-from ( from -- from+n )\r
+ [ 1 + number-from ] checkpoint ;\r
+\r
+<PRIVATE\r
+\r
+: unsafe-number-from-to ( to from -- to from+n )\r
+ 2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
+\r
+: number-from-to ( to from -- to from+n )\r
+ 2dup < [ fail ] when unsafe-number-from-to ;\r
+\r
+: amb-integer ( seq -- int )\r
+ length 1 - 0 number-from-to nip ;\r
+\r
+MACRO: unsafe-amb ( seq -- quot )\r
+ dup length 1 =\r
+ [ first 1quotation ]\r
+ [ [ first ] [ rest ] bi\r
+ '[ , [ drop , unsafe-amb ] checkpoint ] ] if ;\r
+\r
+PRIVATE> \r
+\r
+: amb-lazy ( seq -- elt )\r
+ [ amb-integer ] [ nth ] bi ;\r
+\r
+: amb ( seq -- elt )\r
+ dup empty?\r
+ [ drop fail f ]\r
+ [ unsafe-amb ] if ; inline\r
+\r
+MACRO: amb-execute ( seq -- quot )\r
+ [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
+ '[ , 0 unsafe-number-from-to nip , case ] ;\r
+\r
+: if-amb ( true false -- )\r
+ [\r
+ [ { t f } amb ]\r
+ [ '[ @ require t ] ]\r
+ [ '[ @ f ] ]\r
+ tri* if\r
+ ] with-scope ; inline\r
+\r
: nop ;
-MACRO: amb-execute ( seq -- quot )
- [ length ] [ <enum> [ 1quotation ] assoc-map ] bi
- '[ , amb , case ] ;
-
-: if-amb ( true false -- )
- [
- [ { t f } amb ]
- [ '[ @ require t ] ]
- [ '[ @ f ] ]
- tri* if
- ] with-scope ; inline
-
: do-something ( a b -- c )
{ + - * } amb-execute ;
] 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
: wait-for-mailbox ( mailbox timeout -- )\r
>r threads>> r> "mailbox" wait ;\r
\r
-: block-unless-pred ( mailbox timeout pred -- )\r
+: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
pick check-disposed\r
pick data>> over dlist-contains? [\r
3drop\r
] [\r
>r 2dup wait-for-mailbox r> block-unless-pred\r
- ] if ; inline\r
+ ] if ; inline recursive\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
over check-disposed\r
f mailbox-get-all-timeout ;\r
\r
: while-mailbox-empty ( mailbox quot -- )\r
- over mailbox-empty? [\r
- dup >r dip r> while-mailbox-empty\r
- ] [\r
- 2drop\r
- ] if ; inline\r
+ [ [ mailbox-empty? ] curry ] dip [ ] while ; inline\r
\r
: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
3dup block-unless-pred\r
} 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
+++ /dev/null
-Eric Mertens
+++ /dev/null
-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 ;
+++ /dev/null
-An efficient implementation of the disjoint-set data structure
+++ /dev/null
-collections
--- /dev/null
+Eric Mertens
--- /dev/null
+! 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 ;
--- /dev/null
+An efficient implementation of the disjoint-set data structure
--- /dev/null
+collections
\r
HELP: '[\r
{ $syntax "code... ]" }\r
-{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;\r
+{ $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 @ } "." }\r
+{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
ARTICLE: "fry.examples" "Examples of fried quotations"\r
-"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."\r
+"The easiest way to understand fried quotations is to look at some examples."\r
$nl\r
"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"\r
{ $code "{ 10 20 30 } '[ . ] each" }\r
"{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"\r
"{ 10 20 30 } [ 3 5 / ] map"\r
}\r
-"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"\r
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:"\r
{ $code \r
"{ 10 20 30 } [ sq ] '[ @ . ] each"\r
+ "{ 10 20 30 } [ sq ] [ call . ] curry each"\r
"{ 10 20 30 } [ sq ] [ . ] compose each"\r
"{ 10 20 30 } [ sq . ] each"\r
}\r
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"\r
"{ 8 13 14 27 } [ even? dup 5 ? ] map"\r
}\r
-"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"\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:"\r
{ $code \r
"{ 10 20 30 } 1 '[ , _ / ] map"\r
+ "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map"\r
"{ 10 20 30 } 1 [ swap / ] curry map"\r
"{ 10 20 30 } [ 1 swap / ] map"\r
}\r
"For any quotation body " { $snippet "X" } ", the following two are equivalent:"\r
{ $code\r
- "[ >r X r> ]"\r
- "[ X _ ]"\r
+ "[ [ X ] dip ]"\r
+ "'[ X _ ]"\r
}\r
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
-"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."\r
-$nl\r
+"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:"\r
+{ $code\r
+ "'[ [ , key? ] all? ] filter"\r
+ "[ [ key? ] curry all? ] curry filter"\r
+}\r
"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:"\r
{ $code\r
"'[ 3 , + 4 , / ]"\r
} ;\r
\r
ARTICLE: "fry.limitations" "Fried quotation limitations"\r
-"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;\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." ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
"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."\r
{ $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 ;
: 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 -- ? )
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
- ] [ ] [ ] while
+ ] loop
"c1" get count-down
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
- ] [ ] [ ] while
+ ] loop
"c2" get count-down
] "Monitor test thread" spawn drop
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
: 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
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
- profile>> nickname>> ] unit-test
+ profile>> nickname>> ] unit-test
{ join_ "#factortest" } [
- { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+ { ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net MODE #factortest +ns"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":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"
\ No newline at end of file
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 )
! 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
: 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 -- )
- irc> listeners>>
- [ irc-channel-listener? [ swap remove-participant ] [ 2drop ] if ] with
- assoc-each ;
+ dup listeners-with-participant [ delete-at ] with each ;
-: add-participant ( nick mode channel -- )
+: add-participant ( mode nick channel -- )
listener> [ participants>> set-at ] [ 2drop ] if* ;
DEFER: me?
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) ;
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
- [ maybe-forward-join ]
- [ dup trailing>> to-listener ]
- [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
- tri ;
+ { [ maybe-forward-join ] ! keep
+ [ dup trailing>> to-listener ]
+ [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+ [ handle-participant-change ]
+ } cleave ;
M: part handle-incoming-irc ( part -- )
- [ dup channel>> to-listener ] keep
- [ prefix>> parse-name ] [ channel>> ] bi remove-participant ;
+ [ dup channel>> to-listener ]
+ [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
+ [ handle-participant-change ]
+ tri ;
M: kick handle-incoming-irc ( kick -- )
- [ dup channel>> to-listener ]
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
- tri ;
+ { [ 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 -- )
- [ prefix>> parse-name remove-participant-from-all ] keep
- call-next-method ;
+ { [ 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 ] [ f ] if ;
+ 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) ;
+ [ names-reply>participants ] [ channel>> listener> ] bi
+ [ (>>participants) ] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;
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 ;
! Reader/Writer
! ======================================
-: irc-mailbox-get ( mailbox quot -- )
- [ 5 seconds ] dip
- '[ , , , [ mailbox-get-timeout ] dip call ]
- [ drop ] recover ; inline
-
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
irc>
- [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
+ [ [ irc-disconnected ] dip to-listener ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ profile>> nickname>> /LOGIN ]
tri ;
[ (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 ;
} 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
--- /dev/null
+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
+
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 )
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" ;
: split-trailing ( string -- string string/f )
":" split1 ;
+PRIVATE>
+
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
[ [ tuple-slots ] [ parameters>> ] bi append ] dip
[ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
-PRIVATE>
\r
IN: irc.ui.load\r
\r
-: file-or ( path path -- path ) over exists? ? ;\r
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
\r
: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
\r
sequences strings hashtables splitting fry assocs hashtables\r
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids\r
- io io.styles namespaces calendar calendar.format\r
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.lists ui.gadgets.labels\r
+ io io.styles namespaces calendar calendar.format models\r
irc.client irc.client.private irc.messages irc.messages.private\r
irc.ui.commandparser irc.ui.load ;\r
\r
\r
TUPLE: ui-window client tabs ;\r
\r
+TUPLE: irc-tab < frame listener client listmodel ;\r
+\r
: write-color ( str color -- )\r
foreground associate format ;\r
: red { 0.5 0 0 1 } ;\r
: green { 0 0.5 0 1 } ;\r
: blue { 0 0 1 1 } ;\r
+: black { 0 0 0 1 } ;\r
+\r
+: colors H{ { +operator+ { 0 0.5 0 1 } }\r
+ { +voice+ { 0 0 1 1 } }\r
+ { +normal+ { 0 0 0 1 } } } ;\r
\r
: dot-or-parens ( string -- string )\r
dup empty? [ drop "." ]\r
" has left IRC" red write-color\r
trailing>> dot-or-parens red write-color ;\r
\r
+M: mode write-irc\r
+ "* " blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " blue write-color\r
+ [ mode>> write ] keep\r
+ " to " blue write-color\r
+ channel>> write ;\r
+\r
M: irc-end write-irc\r
drop "* You have left IRC" red write-color ;\r
\r
[ print-irc ]\r
[ listener get write-message ] bi ;\r
\r
-: display ( stream listener -- )\r
+GENERIC: handle-inbox ( tab message -- )\r
+\r
+: filter-participants ( assoc val -- alist )\r
+ [ >alist ] dip\r
+ '[ second , = ] filter ;\r
+\r
+: update-participants ( tab -- )\r
+ [ listmodel>> ] [ listener>> participants>> ] bi\r
+ [ +operator+ filter-participants ]\r
+ [ +voice+ filter-participants ]\r
+ [ +normal+ filter-participants ] tri\r
+ append append swap set-model ;\r
+\r
+M: participant-changed handle-inbox\r
+ drop update-participants ;\r
+\r
+M: object handle-inbox\r
+ nip print-irc ;\r
+\r
+: display ( stream tab -- )\r
'[ , [ [ t ]\r
- [ , read-message print-irc ]\r
+ [ , dup listener>> read-message handle-inbox ]\r
[ ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
-: <irc-pane> ( listener -- pane )\r
+: <irc-pane> ( tab -- tab pane )\r
<scrolling-pane>\r
- [ <pane-stream> swap display ] keep ;\r
+ [ <pane-stream> swap display ] 2keep ;\r
\r
TUPLE: irc-editor < editor outstream listener client ;\r
\r
-: <irc-editor> ( page pane listener -- client editor )\r
- irc-editor new-editor\r
- swap >>listener swap <pane-stream> >>outstream\r
+: <irc-editor> ( tab pane -- tab editor )\r
+ over irc-editor new-editor\r
+ swap
listener>> >>listener swap <pane-stream> >>outstream
\r over client>> >>client ;\r
\r
: editor-send ( irc-editor -- )\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-TUPLE: irc-page < frame listener client ;\r
+: <irc-list> ( -- gadget model )\r
+ [ drop ]\r
+ [ first2 [ <label> ] dip >>color ]\r
+ { } <model> [ <list> ] keep ;\r
+\r
+: <irc-tab> ( listener client -- irc-tab )\r
+ irc-tab new-frame\r
+ swap client>> >>client swap >>listener\r
+ <irc-pane> [ <scroller> @center grid-add* ] keep\r
+ <irc-editor> <scroller> @bottom grid-add* ;\r
+\r
+: <irc-channel-tab> ( listener client -- irc-tab )\r
+ <irc-tab>\r
+ <irc-list> [ <scroller> @right grid-add* ] dip >>listmodel\r
+ [ update-participants ] keep ;\r
\r
-: <irc-page> ( listener client -- irc-page )\r
- irc-page new-frame\r
- swap client>> >>client swap [ >>listener ] keep\r
- [ <irc-pane> [ <scroller> @center grid-add* ] keep ]\r
- [ <irc-editor> <scroller> @bottom grid-add* ] bi ;\r
+: <irc-server-tab> ( listener client -- irc-tab )\r
+ <irc-tab> ;\r
\r
-M: irc-page graft*\r
+M: irc-tab graft*\r
[ listener>> ] [ client>> ] bi\r
add-listener ;\r
\r
-M: irc-page ungraft*\r
+M: irc-tab ungraft*\r
[ listener>> ] [ client>> ] bi\r
remove-listener ;\r
\r
: join-channel ( name ui-window -- )\r
[ dup <irc-channel-listener> ] dip\r
- [ <irc-page> swap ] keep\r
+ [ <irc-channel-tab> swap ] keep\r
tabs>> add-page ;\r
\r
: irc-window ( ui-window -- )\r
: ui-connect ( profile -- ui-window )\r
<irc-client> ui-window new over >>client swap\r
[ connect-irc ]\r
- [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ [ listeners>> +server-listener+ swap at over <irc-tab>\r
"Server" associate <tabbed> >>tabs ] bi ;\r
\r
: server-open ( server port nick password channels -- )\r
[ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each ;\r
+ [ over join-channel ] each drop ;\r
\r
: main-run ( -- ) run-ircui ;\r
\r
[ 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 )
local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
- >r "local-reader" word-prop r>
- read-local-quot [ set-local-value ] append ;
+ >r "local-reader" word-prop r>
+ read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
: 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>
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
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
: 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
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 .
] bind ;
: optimizer-report. ( word -- )
- word-optimize-report report. ;
+ make-report report. ;
] { } make ;
: find-source ( seq -- elt )
- [ keys ] [ values ] bi diff prune
+ unzip diff prune
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
-USING: circular disjoint-set kernel math math.ranges
+USING: circular disjoint-sets kernel math math.ranges
sequences sequences.lib ;
IN: project-euler.186
drop nip
] if ;
+: <relation> ( n -- unionfind )
+ <disjoint-set> [ [ add-atom ] curry each ] keep ;
+
: euler186 ( -- n )
- <generator> 0 1000000 <disjoint-set> (p186) ;
+ <generator> 0 1000000 <relation> (p186) ;
MAIN: euler186
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs words sequences arrays compiler\r
tools.time io.styles io prettyprint vocabs kernel sorting\r
-generator optimizer math math.order math.statistics combinators ;\r
+generator optimizer math math.order math.statistics combinators\r
+optimizer.debugger ;\r
IN: report.optimizer\r
\r
-: count-optimization-passes ( nodes n -- n )\r
- >r optimize-1\r
- [ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
-\r
: table. ( alist -- )\r
20 short tail*\r
standard-table-style\r
tri\r
] 2bi ; inline\r
\r
+: optimization-passes ( word -- n )\r
+ word-dataflow nip 1 count-optimization-passes nip ;\r
+\r
: optimizer-measurements ( -- alist )\r
all-words [ compiled>> ] filter\r
- [\r
- dup [\r
- word-dataflow nip 1 count-optimization-passes\r
- ] benchmark 2array\r
- ] { } map>assoc ;\r
+ [ dup [ optimization-passes ] benchmark 2array ] { } map>assoc ;\r
\r
: optimizer-measurements. ( alist -- )\r
{\r
dup string? swap number? or not
] [ drop f ] if ;
-: deep-each ( obj quot -- )
+: deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch?
- [ [ deep-each ] curry each ] [ 2drop ] if ; inline
+ [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
-: deep-map ( obj quot -- newobj )
+: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
[ call ] keep over branch?
- [ [ deep-map ] curry map ] [ drop ] if ; inline
+ [ [ deep-map ] curry map ] [ drop ] if ; inline recursive
-: deep-filter ( obj quot -- seq )
+: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over >r
pusher >r deep-each r>
- r> dup branch? [ like ] [ drop ] if ; inline
+ r> dup branch? [ like ] [ drop ] if ; inline recursive
-: deep-find-from ( obj quot -- elt ? )
+: deep-find-from ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ >r nip r> deep-find-from ] curry find drop >boolean
] [ 2drop f f ] if
- ] if ; inline
+ ] if ; inline recursive
: deep-find ( obj quot -- elt ) deep-find-from drop ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
-: deep-change-each ( obj quot -- )
+: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
- ] curry change-each ] [ 2drop ] if ; inline
+ ] curry change-each ] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;
IN: sorting.insertion
<PRIVATE
-:: insert ( seq quot n -- )
+:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
n n 1- [ seq nth quot call ] bi@ >= [
n n 1- seq exchange
seq quot n 1- insert
] unless
- ] unless ; inline
+ ] unless ; inline recursive
PRIVATE>
: insertion-sort ( seq quot -- )
M: cocoa-ui-backend do-events ( -- )
[
- [
- NSApp [ dup do-event ] [ ] [ ] while drop
- ui-wait
- ] ui-try
+ [ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
TUPLE: pasteboard handle ;
i end < [
i j bitmap texture copy-pixel
bitmap texture end (copy-row)
- ] when ; inline
+ ] when ; inline recursive
:: copy-row ( i j bitmap texture width width2 -- i j )
i j bitmap texture i width + (copy-row)
projects / factor.git / commitdiff