--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: regexp.classes tools.test arrays kernel ;
+IN: regexp.classes.tests
+
+[ f ] [ { 1 2 } <and-class> ] unit-test
+[ T{ or-class f { 2 1 } } ] [ { 1 2 } <or-class> ] unit-test
+[ 3 ] [ { 1 2 } <and-class> 3 2array <or-class> ] unit-test
+[ CHAR: A ] [ CHAR: A LETTER-class <primitive-class> 2array <and-class> ] unit-test
+[ CHAR: A ] [ LETTER-class <primitive-class> CHAR: A 2array <and-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ CHAR: A LETTER-class <primitive-class> 2array <or-class> ] unit-test
+[ T{ primitive-class { class LETTER-class } } ] [ LETTER-class <primitive-class> CHAR: A 2array <or-class> ] unit-test
+[ t ] [ { t 1 } <or-class> ] unit-test
+[ t ] [ { 1 t } <or-class> ] unit-test
+[ f ] [ { f 1 } <and-class> ] unit-test
+[ f ] [ { 1 f } <and-class> ] unit-test
+[ 1 ] [ { f 1 } <or-class> ] unit-test
+[ 1 ] [ { 1 f } <or-class> ] unit-test
+[ 1 ] [ { t 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 t } <and-class> ] unit-test
+[ 1 ] [ 1 <not-class> <not-class> ] unit-test
+[ 1 ] [ { 1 1 } <and-class> ] unit-test
+[ 1 ] [ { 1 1 } <or-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <and-class> ] unit-test
+[ T{ primitive-class { class letter-class } } ] [ letter-class <primitive-class> dup 2array <or-class> ] unit-test
GENERIC: class-member? ( obj class -- ? )
-! When does t get put in?
-M: t class-member? ( obj class -- ? ) 2drop f ;
+M: t class-member? ( obj class -- ? ) 2drop t ;
M: integer class-member? ( obj class -- ? ) = ;
m:GENERIC: combine-and ( class1 class2 -- combined ? )
-m:METHOD: combine-and { object object } 2drop f f ;
+: replace-if-= ( object object -- object ? )
+ over = ;
+
+m:METHOD: combine-and { object object } replace-if-= ;
m:METHOD: combine-and { integer integer }
2dup = [ drop t ] [ 2drop f t ] if ;
m:METHOD: combine-and { f object }
drop t ;
+m:METHOD: combine-and { not-class object }
+ [ class>> ] dip = [ f t ] [ f f ] if ;
+
m:METHOD: combine-and { integer object }
2dup class-member? [ drop t ] [ 2drop f t ] if ;
m:GENERIC: combine-or ( class1 class2 -- combined ? )
-m:METHOD: combine-or { object object } 2drop f f ;
+m:METHOD: combine-or { object object } replace-if-= ;
m:METHOD: combine-or { integer integer }
2dup = [ drop t ] [ 2drop f f ] if ;
m:METHOD: combine-or { f object }
nip t ;
+m:METHOD: combine-or { not-class object }
+ [ class>> ] dip = [ t t ] [ f f ] if ;
+
m:METHOD: combine-or { integer object }
2dup class-member? [ nip t ] [ 2drop f f ] if ;
seq>> [ class-member? ] with all? ;
: <or-class> ( seq -- class )
- [ combine-or ] t or-class combine ;
+ [ combine-or ] f or-class combine ;
M: or-class class-member?
seq>> [ class-member? ] with any? ;
{
{ t [ f ] }
{ f [ t ] }
- [ not-class boa ]
+ [ dup not-class? [ class>> ] [ not-class boa ] if ]
} case ;
M: not-class class-member?
: powerset-partition ( classes -- partitions )
[ length [ 2^ ] keep ] keep '[
_ <bits> _ make-partition
- ] map ;
+ ] map rest ;
: partition>class ( parts -- class )
- [ in>> ] [ out>> ] bi
- [ <or-class> ] bi@ <not-class> 2array <and-class> ;
+ [ out>> [ <not-class> ] map ]
+ [ in>> <and-class> ] bi
+ prefix <and-class> ;
: get-transitions ( partition state-transitions -- next-states )
[ in>> ] dip '[ _ at ] map prune ;
! R/ |[^a]|.+/
T{ transition-table
{ transitions H{
- { 0 H{ { CHAR: a 1 } { T{ not-class f T{ or-class f { CHAR: a } } } -1 } } }
- { 1 H{ { T{ not-class f T{ or-class f { } } } -1 } } }
- { -1 H{ { any-char -1 } } }
+ { 0 H{ { CHAR: a 1 } { T{ not-class f CHAR: a } -1 } } }
+ { 1 H{ { t -1 } } }
+ { -1 H{ { t -1 } } }
} }
{ start-state 0 }
{ final-states H{ { 0 0 } { -1 -1 } } }
: add-default-transition ( state's-transitions -- new-state's-transitions )
clone dup
- [ [ fail-state ] dip keys <or-class> <not-class> ] keep set-at ;
+ [ [ fail-state ] dip keys [ <not-class> ] map <and-class> ] keep set-at ;
: fail-state-recurses ( transitions -- new-transitions )
clone dup
- [ fail-state any-char associate fail-state ] dip set-at ;
+ [ fail-state t associate fail-state ] dip set-at ;
: add-fail-state ( transitions -- new-transitions )
[ add-default-transition ] assoc-map
: unify-final-state ( transition-table -- transition-table )
dup [ final-states>> keys ] keep
- '[ -1 eps <literal-transition> _ add-transition ] each
- H{ { -1 -1 } } >>final-states ;
+ '[ -2 eps <literal-transition> _ add-transition ] each
+ H{ { -2 -2 } } >>final-states ;
: adjoin-dfa ( transition-table -- start end )
box-transitions unify-final-state renumber-states
class>> modify-class <not-class> ;
M: any-char modify-class
- [ dotall option? ] dip any-char-no-nl ? ;
+ drop dotall option? t any-char-no-nl ? ;
: modify-letter-class ( class -- newclass )
case-insensitive option? [ drop Letter-class ] when ;