Task

Find solutions to the    sum to one hundred    puzzle.



Add (insert) the mathematical
operators      +    or    -      (plus
or minus)   before any of the digits in the

decimal numeric string    123456789    such that the
resulting mathematical expression adds up to a

particular sum   (in this iconic case,   100).



Example:

             123 + 4 - 5 + 67 - 89   =   100     

Show all output here.



   Show all solutions that sum to    100 
   Show the sum that has the maximum   number   of solutions   (from zero to infinity‡)
   Show the lowest positive sum that   can't   be expressed   (has no solutions),   using the rules for this task
   Show the ten highest numbers that can be expressed using the rules for this task   (extra credit)


‡   (where   infinity   would be a relatively small   123,456,789)



An example of a sum that can't be expressed   (within the rules of this task)   is:   5074

(which,   of course,   isn't the lowest positive sum that can't be expressed).




use framework "Foundation" -- for basic NSArray sort
 
property pSigns : {1, 0, -1} --> ( + | unsigned | - )
property plst100 : {"Sums to 100:", ""}
property plstSums : {}
property plstSumsSorted : missing value
property plstSumGroups : missing value
 
-- data Sign :: [ 1 | 0 | -1 ] = ( Plus | Unsigned | Minus )
-- asSum :: [Sign] -> Int
on asSum(xs)
    script
        on |λ|(a, sign, i)
            if sign ≠ 0 then
                {digits:{}, n:(n of a) + (sign * ((i & digits of a) as string as integer))}
            else
                {digits:{i} & (digits of a), n:n of a}
            end if
        end |λ|
    end script
 
    set rec to foldr(result, {digits:{}, n:0}, xs)
    set ds to digits of rec
    if length of ds > 0 then
        (n of rec) + (ds as string as integer)
    else
        n of rec
    end if
end asSum
 
-- data Sign :: [ 1 | 0 | -1 ] = ( Plus | Unisigned | Minus )
-- asString :: [Sign] -> String
on asString(xs)
    script
        on |λ|(a, sign, i)
            set d to i as string
            if sign ≠ 0 then
                if sign > 0 then
                    a & " +" & d
                else
                    a & " -" & d
                end if
            else
                a & d
            end if
        end |λ|
    end script
 
    foldl(result, "", xs)
end asString
 
-- sumsTo100 :: () -> String
on sumsTo100()
    -- From first permutation without leading '+' (3 ^ 8) to end of universe (3 ^ 9)
    repeat with i from 6561 to 19683
        set xs to nthPermutationWithRepn(pSigns, 9, i)
        if asSum(xs) = 100 then set end of plst100 to asString(xs)
    end repeat
    intercalate(linefeed, plst100)
end sumsTo100
 
 
-- mostCommonSum :: () -> String
on mostCommonSum()
    -- From first permutation without leading '+' (3 ^ 8) to end of universe (3 ^ 9)
    repeat with i from 6561 to 19683
        set intSum to asSum(nthPermutationWithRepn(pSigns, 9, i))
        if intSum ≥ 0 then set end of plstSums to intSum
    end repeat
 
    set plstSumsSorted to sort(plstSums)
    set plstSumGroups to group(plstSumsSorted)
 
    script groupLength
        on |λ|(a, b)
            set intA to length of a
            set intB to length of b
            if intA < intB then
                -1
            else if intA > intB then
                1
            else
                0
            end if
        end |λ|
    end script
 
    set lstMaxSum to maximumBy(groupLength, plstSumGroups)
    intercalate(linefeed, ¬
        {"Most common sum: " & item 1 of lstMaxSum, ¬
            "Number of instances: " & length of lstMaxSum})
end mostCommonSum
 
 
-- TEST ----------------------------------------------------------------------
on run
    return sumsTo100()
 
    -- Also returns a value, but slow:
    -- mostCommonSum()
end run
 
 
-- GENERIC FUNCTIONS ---------------------------------------------------------
 
-- nthPermutationWithRepn :: [a] -> Int -> Int -> [a]
on nthPermutationWithRepn(xs, groupSize, iIndex)
    set intBase to length of xs
    set intSetSize to intBase ^ groupSize
 
    if intBase < 1 or iIndex > intSetSize then
        {}
    else
        set baseElems to inBaseElements(xs, iIndex)
        set intZeros to groupSize - (length of baseElems)
 
        if intZeros > 0 then
            replicate(intZeros, item 1 of xs) & baseElems
        else
            baseElems
        end if
    end if
end nthPermutationWithRepn
 
-- inBaseElements :: [a] -> Int -> [String]
on inBaseElements(xs, n)
    set intBase to length of xs
 
    script nextDigit
        on |λ|(residue)
            set {divided, remainder} to quotRem(residue, intBase)
 
            {valid:divided > 0, value:(item (remainder + 1) of xs), new:divided}
        end |λ|
    end script
 
    reverse of unfoldr(nextDigit, n)
end inBaseElements
 
-- sort :: [a] -> [a]
on sort(lst)
    ((current application's NSArray's arrayWithArray:lst)'s ¬
        sortedArrayUsingSelector:"compare:") as list
end sort
 
-- maximumBy :: (a -> a -> Ordering) -> [a] -> a 
on maximumBy(f, xs)
    set cmp to mReturn(f)
    script max
        on |λ|(a, b)
            if a is missing value or cmp's |λ|(a, b) < 0 then
                b
            else
                a
            end if
        end |λ|
    end script
 
    foldl(max, missing value, xs)
end maximumBy
 
-- group :: Eq a => [a] -> [[a]]
on group(xs)
    script eq
        on |λ|(a, b)
            a = b
        end |λ|
    end script
 
    groupBy(eq, xs)
end group
 
-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
on groupBy(f, xs)
    set mf to mReturn(f)
 
    script enGroup
        on |λ|(a, x)
            if length of (active of a) > 0 then
                set h to item 1 of active of a
            else
                set h to missing value
            end if
 
            if h is not missing value and mf's |λ|(h, x) then
                {active:(active of a) & x, sofar:sofar of a}
            else
                {active:{x}, sofar:(sofar of a) & {active of a}}
            end if
        end |λ|
    end script
 
    if length of xs > 0 then
        set dct to foldl(enGroup, {active:{item 1 of xs}, sofar:{}}, tail(xs))
        if length of (active of dct) > 0 then
            sofar of dct & {active of dct}
        else
            sofar of dct
        end if
    else
        {}
    end if
end groupBy
 
-- tail :: [a] -> [a]
on tail(xs)
    if length of xs > 1 then
        items 2 thru -1 of xs
    else
        {}
    end if
end tail
 
 
-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
    set {dlm, my text item delimiters} to {my text item delimiters, strText}
    set strJoined to lstText as text
    set my text item delimiters to dlm
    return strJoined
end intercalate
 
--  quotRem :: Integral a => a -> a -> (a, a)
on quotRem(m, n)
    {m div n, m mod n}
end quotRem
 
-- replicate :: Int -> a -> [a]
on replicate(n, a)
    set out to {}
    if n < 1 then return out
    set dbl to {a}
 
    repeat while (n > 1)
        if (n mod 2) > 0 then set out to out & dbl
        set n to (n div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate
 
-- foldr :: (a -> b -> a) -> a -> [b] -> a
on foldr(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from lng to 1 by -1
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldr
 
-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl
 
-- unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
on unfoldr(f, v)
    set mf to mReturn(f)
    set lst to {}
    set recM to mf's |λ|(v)
    repeat while (valid of recM) is true
        set end of lst to value of recM
        set recM to mf's |λ|(new of recM)
    end repeat
    lst & value of recM
end unfoldr
 
-- until :: (a -> Bool) -> (a -> a) -> a -> a
on |until|(p, f, x)
    set mp to mReturn(p)
    set v to x
 
    tell mReturn(f)
        repeat until mp's |λ|(v)
            set v to |λ|(v)
        end repeat
    end tell
    return v
end |until|
 
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map
 
 
-- Lift 2nd class handler function into 1st class script wrapper 
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn