Mathematica, 373 bytes
If[l=Length;a=Accumulate[l/@#]&;u=Unequal;e=Select;{}==(m=(g=#;Tr[#2Flatten[ConstantArray[#,LCM@@l/@g/l@#]&/@g]~Count~#&@@@Tally@c])&/@e[p=e[c~Internal`PartitionRagged~#&/@Join@@Permutations/@IntegerPartitions[l[c=Characters[s=StringReplace[#,c:"A"~CharacterRange~"Z":>(d=ToLowerCase@c)<>d]]]],u@@l/@#&&And@@u@@@#&],FreeQ[p,l_List/;#!=l&&SubsetQ[a@l,a@#]]&]),"evil",Min@m]&
This is quite long... and also rather naive. It defines an unnamed function that takes the string and returns score. It takes about 1 second to handle "Establishments"
, so it's well within the time limit. I've got a slightly shorter version that uses Combinatorica`SetPartitions
, but it already takes a minute for "Establishme"
.
Here is a version with whitespace:
If[
l = Length;
a = Accumulate[l /@ #] &;
u = Unequal;
e = Select;
{} == (
m = (
g = #;
Tr[
#2 Flatten[
ConstantArray[
#,
LCM @@ l /@ g/l@#
] & /@ g
]~Count~# & @@@ Tally@c
]
) & /@ e[
p = e[
c~Internal`PartitionRagged~# & /@ Join @@ Permutations /@ IntegerPartitions[
l[
c = Characters[
s = StringReplace[
#,
c : "A"~CharacterRange~"Z" :> (d = ToLowerCase@c) <> d
]
]
]
],
u @@ l /@ # && And @@ u @@@ # &
],
FreeQ[p, l_List /; # != l && SubsetQ[a@l, a@#]] &
]
),
"evil",
Min@m
] &
I might add a more detailed explanation later. This code uses the second solution from this answerfrom this answer to get all the partitions and this solutionthis solution to make sure they are all maximally segmented.