Library for Project Euler

gistfile1.txt

module Main
import StdEnv, StdDebug, StdLib, BigInt, Rational//, StdOverloadedList, Parsers

//---------------------------------------------------------------------------------

S :: (a -> b -> c) (a -> b) a -> c
S f g x = f x (g x)

//---------------------------------------------------------------------------------

tail :: Int -> [a] -> [a]
tail n = S f (drop n) where
    f xs [] = xs
    f [_:xs] [_:ys] = f xs ys

//---------------------------------------------------------------------------------

fib :: [BigInt]
fib =: [one:one:S (zipWith (+)) tl fib]

//---------------------------------------------------------------------------------

isPalindrome :: ([a] -> Bool) | Eq a
isPalindrome = S (==) reverse

//---------------------------------------------------------------------------------

class factorize a :: a -> [a]

instance factorize Int where
    factorize n = factorizeAt n [2:[3,5..]]

instance factorize BigInt where
    factorize n = (factorizeAt n o map toBigInt) [2:[3,5..]]

factorizeAt :: a [a] -> [a] | Enum, Eq, *, /, rem a
factorizeAt n [x:xs]
    | n == one = []
    | x * x > n = [n]
    | n rem x == zero = [x:factorizeAt (n / x) [x:xs]]
    | otherwise = factorizeAt n xs

fact :: (Int -> [Int])
fact = f [2:[3,5..]] where
    f [x:xs] n
        | n == 1 = []
        | x * x > n = [n]
        | n rem x == 0 = [x:f [x:xs] (n/x)]
        | otherwise = f xs n

class countFact a :: a -> Int

instance countFact Int where
    countFact 0 = 0
    countFact n = (prod o map ((+) 1 o length) o group o factorize) n

instance countFact BigInt where
    countFact n
        | n == zero = 0
        | otherwise = (prod o map ((+) 1 o length) o group o factorize) n

sumFact :: Int -> Int
sumFact 0 = 0
sumFact n = (prod o map f o group o factorize) n - n where
    f xs = sum [1:[x^y \\ x <- xs & y <- [1..]]]

countFactArray :: Int -> {#Int}
countFactArray n
    # arr = {createArray (n+1) 2 & [0] = 0, [1] = 1}
    = f xs arr
where
    xs = [2..n/2]
    f [] arr = arr
    f [p:ps] arr = f ps (g xs arr) where
        xs = takeWhile ((>=) n) [p*x \\ x <- [2..]]
        g [] arr = arr
        g [x:xs] arr = g xs (incr x arr) where
            incr i arr =: {[i] = ai} = {arr & [i] = ai+1}

//---------------------------------------------------------------------------------

C :: Int Int -> BigInt
C x y
    | m == zero = one
    | otherwise = (prod [(m-n+one)..m]) / (prod [one..n])
where
    m = toBigInt x
    n = toBigInt y

factorial :: Int -> Int
factorial 0 = 1
factorial n = prod [1..n]

//---------------------------------------------------------------------------------

isqrt :: (Int -> Int)
isqrt = (entier o sqrt o toReal)

//---------------------------------------------------------------------------------

permutation :: [a] -> [[a]] | Eq a
permutation [] = [[]]
permutation xs = [[x:rest] \\ x <- xs, rest <- permutation (removeMember x xs)]

perm :: [[a]] -> [[a]] | Eq a
perm [] = [[]]
perm [xs:yss] = [[x:rest] \\ x <- xs, rest <- perm (map (filter ((<>) x)) yss)]

powerSet :: [a] -> [[a]]
powerSet [] = [[]]
powerSet [x:xs] = flatten [[[x:ys],ys] \\ ys <- powerSet xs]

matrix :: Int [Int] -> [[Int]]
matrix n xs = f [] (repeatn n xs) where
    f xss []       = xss
    f [] [ys:yss]  = f [[y] \\ y <- ys] yss
    f xss [ys:yss] = f [xs ++ [y] \\ xs <- xss, y <- ys] yss

//---------------------------------------------------------------------------------

integerPartitions :: Int -> [[Int]]
integerPartitions m = foldl (++) [] [iPartitions m n \\ n <- [1..m]]

iPartitions :: Int Int -> [[Int]]
iPartitions m n
    | m < n     = [[]]
    | m == n    = [repeatn m 1]
    | n == 1    = [[m]]
    | otherwise = map (add1 n) (flatten [iPartitions (m-n) x \\ x <- [1..min (m-n) n]])
where 
    add1 len xs = take len [x+1 \\ x <- xs ++ (repeat 0)]

countPartitions :: Int -> BigInt
countPartitions m = sum (xs !! m) where
    xs = [[f m n \\ n <- [1..m]] \\ m <- [0..]]
    f m n
        | m < n = zero
        | m == n || n == 1 = one
        | otherwise = (sum o take n) (xs !! (m-n))

//---------------------------------------------------------------------------------

i2d :: (Int -> [Int])
i2d = f [] where
    f xs 0 = xs
    f xs n = f [n rem 10:xs] (n/10)

d2i :: ([Int] -> Int)
d2i = foldl ((+) o (*) 10) 0

//---------------------------------------------------------------------------------

:: Day = Sun | Mon | Tue | Wed | Thu | Fri | Sat

zeller y m d = [Sun, Mon, Tue, Wed, Thu, Fri, Sat] !! i where
    xs = [0, 3, 2, 5, 0, 3, 5, 1, 4, 6, 2, 4]
    Y | m < 3 = y - 1 | otherwise = y
    i = (Y + Y/4 - Y/100 + Y/400 + (xs !! (m-1)) + d) rem 7

//---------------------------------------------------------------------------------

pythagorean :: Int -> [[Int]]
pythagorean limit = [[m^2-n^2, 2*m*n, m^2+n^2] \\ m <- [1..limit], n <- [1..m] | isOdd (m+n) && gcd m n == 1]

genPythagorean :: [Int] -> [[Int]]
genPythagorean [x0,x1,x2] = res where // [3,4,5] から [[5,12,13],[15,8,17],[21,20,29]] を生成
    P = [[-1,-2,2],[-2,-1,2],[-2,-2,3]] // 生成行列
    a = [~x0 ,x1,x2]
    b = [ x0,~x1,x2]
    c = [~x0,~x1,x2]
    res = map (\x = map (sumProd x) P) [a,b,c]
    sumProd xs ys = sum [x*y \\ x <- xs & y <- ys]

primitivePythagoreans :: ([Int] -> Bool) -> [[Int]]
primitivePythagoreans cond = f [] [[3,4,5]] where
    f res [] = res
    f res [xs:xss] = f [xs:res] ((filter cond o genPythagorean) xs ++ xss)

pythagoreans :: ([Int] -> Bool) -> [[Int]]
pythagoreans cond = (flatten o map f o primitivePythagoreans) cond where
    f ps = takeWhile cond [map ((*) x) ps \\ x <- [1..]]

//---------------------------------------------------------------------------------

polygonalNumbers :: Int -> [Int]
polygonalNumbers p = [n*(n*(p-2)-p+4)/2 \\ n <- [1..]]

triangleNumbers :: [Int]
triangleNumbers = polygonalNumbers 3

squareNumbers :: [Int]
squareNumbers = polygonalNumbers 4

pentagonalNumbers :: [Int]
pentagonalNumbers = polygonalNumbers 5

hexagonalNumbers :: [Int]
hexagonalNumbers = polygonalNumbers 6

heptagonalNumbers :: [Int]
heptagonalNumbers = polygonalNumbers 7

octagonalNumbers :: [Int]
octagonalNumbers = polygonalNumbers 8

isPentagonal :: Int -> Bool
isPentagonal n = x == y * y && (y + 1) rem 6 == 0 where
    x = 1 + 24 * n
    y = (entier o sqrt o toReal) x

generalisedPentagonalNumbers :: [BigInt]
generalisedPentagonalNumbers = [f n \\ n <- [zero:flatten [[x,~x] \\ x <- [toBigInt 1..]]]] where
    f n = n * (n *% 3 - one) / toBigInt 2


//---------------------------------------------------------------------------------

foldCF :: [Int] -> Rational
foldCF xs = f one (last ys) (last zs) zs where
    ys = map toBigInt xs
    zs = init ys
    f a b c [] = b /: a
    f a b c xs = f b (a + b * c) (last ys) ys where ys = init xs 

sqrtCF :: Int -> [Int]
sqrtCF n
    | root^2 == n = [root]
    | otherwise = f 0 1 0 []
where
    root = (entier o sqrt o toReal) n
    f x y z res
        | z == 1 = res ++ [hd res * 2]
        | otherwise = f a b b (res ++ [next])
    where
        next = (root + x) / y
        a = 0 - (x - y * next)
        b = (n - (x - y * next) ^ 2) / y

//---------------------------------------------------------------------------------