[ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
[ f ] [ t <not-class> ] unit-test
[ t ] [ f <not-class> ] unit-test
-[ f ] [ 1 <not-class> 1 t replace-question ] unit-test
+[ f ] [ 1 <not-class> 1 t answer ] unit-test
! Making classes into nested conditionals
[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
-[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t answer ] unit-test
-[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f answer ] unit-test
+[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
+[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test
[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
SYMBOL: foo
[ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test
-[ t ] [ foo <primitive-class> dup t replace-question ] unit-test
-[ f ] [ foo <primitive-class> dup f replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t replace-question ] unit-test
-[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f replace-question ] unit-test
-[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f replace-question ] unit-test
-[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t replace-question ] unit-test
-[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f replace-question ] unit-test
+[ t ] [ foo <primitive-class> dup t answer ] unit-test
+[ f ] [ foo <primitive-class> dup f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f answer ] unit-test
+[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f answer ] unit-test
+[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t answer ] unit-test
+[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f answer ] unit-test
: try-combine ( elt1 elt2 quot -- combined/f ? )
3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
+DEFER: answer
+
+:: try-cancel ( elt1 elt2 empty -- combined/f ? )
+ [ elt1 elt2 empty answer dup elt1 = not ] try-combine ;
+
:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
f :> combined!
- seq [ elt quot try-combine swap combined! ] find drop
+ seq [ elt quot call swap combined! ] find drop
[ seq remove-nth combined prefix ]
[ seq elt prefix ] if* ; inline
+: combine-by ( seq quot -- new-seq )
+ { } swap '[ _ prefix-combining ] reduce ; inline
+
+:: seq>instance ( seq empty class -- instance )
+ seq length {
+ { 0 [ empty ] }
+ { 1 [ seq first ] }
+ [ drop class new seq >>seq ]
+ } case ; inline
+
:: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq )
seq class flatten
- { } [ quot prefix-combining ] reduce
- dup length {
- { 0 [ drop empty ] }
- { 1 [ first ] }
- [ drop class new swap >>seq ]
- } case ; inline
+ [ quot try-combine ] combine-by
+ ! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4)
+ empty class seq>instance ; inline
: <and-class> ( seq -- class )
[ combine-and ] t and-class combine ;
TUPLE: condition question yes no ;
C: <condition> condition
-GENERIC# replace-question 2 ( class from to -- new-class )
+GENERIC# answer 2 ( class from to -- new-class )
-M:: object replace-question ( class from to -- new-class )
+M:: object answer ( class from to -- new-class )
class from = to class ? ;
: replace-compound ( class from to -- seq )
- [ seq>> ] 2dip '[ _ _ replace-question ] map ;
+ [ seq>> ] 2dip '[ _ _ answer ] map ;
-M: and-class replace-question
+M: and-class answer
replace-compound <and-class> ;
-M: or-class replace-question
+M: or-class answer
replace-compound <or-class> ;
-M: not-class replace-question
- [ class>> ] 2dip replace-question <not-class> ;
+M: not-class answer
+ [ class>> ] 2dip answer <not-class> ;
-: answer ( table question answer -- new-table )
- '[ _ _ replace-question ] assoc-map
+: assoc-answer ( table question answer -- new-table )
+ '[ _ _ answer ] assoc-map
[ nip ] assoc-filter ;
-: answers ( table questions answer -- new-table )
- '[ _ answer ] each ;
+: assoc-answers ( table questions answer -- new-table )
+ '[ _ assoc-answer ] each ;
DEFER: make-condition
: (make-condition) ( table questions question -- condition )
[ 2nip ]
- [ swap [ t answer ] dip make-condition ]
- [ swap [ f answer ] dip make-condition ] 3tri
+ [ swap [ t assoc-answer ] dip make-condition ]
+ [ swap [ f assoc-answer ] dip make-condition ] 3tri
2dup = [ 2nip ] [ <condition> ] if ;
: make-condition ( table questions -- condition )
{ R' .*a' R' b.*' } <and> ;
[ t ] [ "bljhasflsda" conj matches? ] unit-test
-[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail?
+[ f ] [ "bsdfdfs" conj matches? ] unit-test
[ f ] [ "fsfa" conj matches? ] unit-test
[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test
: non-literals>dispatch ( literals non-literals -- quot )
[ swap ] assoc-map ! we want state => predicate, and get the opposite as input
- swap keys f answers
+ swap keys f assoc-answers
table>condition [ <box> ] condition-map condition>quot ;
: literals>cases ( literal-transitions -- case-body )
projects / factor.git / commitdiff