Disambiguation works completely in regexp

db4
Daniel Ehrenberg 2009-02-23 13:10:38 -06:00
parent 88f9b3ea92
commit ba1ac44176
6 changed files with 51 additions and 17 deletions

View File

@ -0,0 +1,25 @@
! 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

View File

@ -20,8 +20,7 @@ C: <range> range
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 -- ? ) = ;
@ -120,7 +119,10 @@ TUPLE: and-class seq ;
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 ;
@ -131,12 +133,15 @@ m:METHOD: combine-and { t object }
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 ;
@ -147,6 +152,9 @@ m:METHOD: combine-or { t object }
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 ;
@ -174,7 +182,7 @@ M: and-class class-member?
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? ;
@ -183,7 +191,7 @@ M: or-class class-member?
{
{ t [ f ] }
{ f [ t ] }
[ not-class boa ]
[ dup not-class? [ class>> ] [ not-class boa ] if ]
} case ;
M: not-class class-member?

View File

@ -12,11 +12,12 @@ TUPLE: parts in out ;
: 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 ;

View File

@ -7,9 +7,9 @@ IN: regexp.negation.tests
! 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 } } }

View File

@ -12,11 +12,11 @@ CONSTANT: fail-state -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
@ -48,8 +48,8 @@ CONSTANT: fail-state -1
: 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

View File

@ -120,7 +120,7 @@ M: not-class modify-class
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 ;