In number theory, a weird number is a natural number that is abundant but not semiperfect (and therefore not perfect either).

In other words, the sum of the proper divisors of the number (divisors including 1 but not itself) is greater than the number itself (the number is abundant), but no subset of those divisors sums to the number itself (the number is not semiperfect).

For example:

 12 is not a weird number.
 It is abundant; its proper divisors 1, 2, 3, 4, 6 sum to 16 (which is > 12),
 but it is semiperfect, e.g.:     6 + 4 + 2 == 12.
 70 is a weird number.
 It is abundant; its proper divisors 1, 2, 5, 7, 10, 14, 35 sum to 74 (which is > 70),
 and there is no subset of proper divisors that sum to 70.


Task

Find and display, here on this page, the first 25 weird numbers.



Related tasks

 Abundant, deficient and perfect number classifications
 Proper divisors


See also

 OEIS: A006037 weird numbers
 Wikipedia: weird number
 MathWorld: weird number


on run
    take(25, weirds())
    -- Gets there, but takes about 6 seconds on this system,
    -- (logging intermediates through the Messages channel, for the impatient :-)
end run
 
 
-- weirds :: Gen [Int]
on weirds()
    script
        property x : 1
        property v : 0
        on |λ|()
            repeat until isWeird(x)
                set x to 1 + x
            end repeat
            set v to x
            log v
            set x to 1 + x
            return v
        end |λ|
    end script
end weirds
 
-- isWeird :: Int -> Bool
on isWeird(n)
    set ds to descProperDivisors(n)
    set d to sum(ds) - n
    0 < d and not hasSum(d, ds)
end isWeird
 
-- hasSum :: Int -> [Int] -> Bool
on hasSum(n, xs)
    if {} ≠ xs then
        set h to item 1 of xs
        set t to rest of xs
        if n < h then
            hasSum(n, t)
        else
            n = h or hasSum(n - h, t) or hasSum(n, t)
        end if
    else
        false
    end if
end hasSum
 
-- GENERIC ------------------------------------------------
 
-- descProperDivisors :: Int -> [Int]
on descProperDivisors(n)
    if n = 1 then
        {1}
    else
        set realRoot to n ^ (1 / 2)
        set intRoot to realRoot as integer
        set blnPerfect to intRoot = realRoot
 
        -- isFactor :: Int -> Bool 
        script isFactor
            on |λ|(x)
                n mod x = 0
            end |λ|
        end script
 
        -- Factors up to square root of n,
        set lows to filter(isFactor, enumFromTo(1, intRoot))
 
        -- and cofactors of these beyond the square root,
 
        -- integerQuotient :: Int -> Int
        script integerQuotient
            on |λ|(x)
                (n / x) as integer
            end |λ|
        end script
 
        set t to rest of lows
        if blnPerfect then
            set xs to t
        else
            set xs to lows
        end if
        map(integerQuotient, t) & (reverse of xs)
    end if
end descProperDivisors
 
-- enumFromTo :: (Int, Int) -> [Int]
on enumFromTo(m, n)
    if m ≤ n then
        set lst to {}
        repeat with i from m to n
            set end of lst to i
        end repeat
        return lst
    else
        return {}
    end if
end enumFromTo
 
-- filter :: (a -> Bool) -> [a] -> [a]
on filter(f, xs)
    tell mReturn(f)
        set lst to {}
        set lng to length of xs
        repeat with i from 1 to lng
            set v to item i of xs
            if |λ|(v, i, xs) then set end of lst to v
        end repeat
        return lst
    end tell
end filter
 
-- 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
 
-- 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
 
-- sum :: [Num] -> Num
on sum(xs)
    script add
        on |λ|(a, b)
            a + b
        end |λ|
    end script
 
    foldl(add, 0, xs)
end sum
 
-- take :: Int -> Gen [a] -> [a]
on take(n, xs)
    set ys to {}
    repeat with i from 1 to n
        set v to xs's |λ|()
        if missing value is v then
            return ys
        else
            set end of ys to v
        end if
    end repeat
    return ys
end take
 
-- Lift 2nd class handler function into 1st class script wrapper 
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn