HaskellでAOJのIntroduction to Programmingを解いてみた。

Introduction to Programming

AIZU ONLINE JUDGE (AOJ) の Introduction to Programming をHaskellで解いたのでここに書いておくことにする。

ITP1 - Getting Started -

Introduction to Programming I - Getting Started -

Hello World

Hello Worldを出力。
大概の言語では入門本の最初に、Haskell本では真ん中くらいに書いてある内容。

1
main = putStrLn "Hello World"

X Cubic

ITP1_1_B: X Cubic

1
2
3
import Control.Applicative
main =
    print =<< (^ 3) . read <$> getLine 

Rectangle

ITP1_1_C: Rectangle

1
2
3
4
5
import Control.Applicative
readDigits = map read <$> words <$> getLine :: IO [Int]
main =
    putStrLn . unwords . map show
    =<< ([a,b] -> [a*b, (a+b)*2]) <$> readDigits 

Watch

ITP1_1_D: Watch

1
2
3
4
5
6
7
8
9
import Control.Applicative
import Data.List
main =
    zipWith id [h,m,s] . repeat <$> readLn
    >>= putStrLn . (intercalate ":") . map show
    where
    h x = x `div` 3600
    m x = x `mod` 3600 `div` 60
    s x = x `mod` 3600 `mod` 60 

ITP1 - Branch on Condition -

Introduction to Programming I - Branch on Condition -

Small, Large, or Equal

ITP1_2_A: Small, Large, or Equal

1
2
3
4
5
6
7
8
9
import Control.Applicative
main =
    interact (fn . map read . words)
    where
    fn :: [Int] -> String
    fn [a,b]
        | a < b = "a < b¥n"
        | a > b = "a > b¥n"
        | a == b = "a == b¥n"

Range

ITP1_2_B: Range

1
2
3
4
5
6
7
8
import Control.Applicative
main =
    interact (fn . map read . words)
    where
    fn :: [Int] -> String
    fn [a,b,c]
        | a < b && b < c = "Yes¥n"
        | otherwise = "No¥n"

Sorting Three Numbers

ITP1_2_C: Sorting Three Numbers

1
2
3
4
5
6
import Data.List
main =
    interact (toStr . sort . map read . words)
    where
    toStr :: [Int] -> String
    toStr xs = (unwords $ map show xs) ++ "¥n"

Circle in a Rectangle

ITP1_2_D: Circle in a Rectangle

1
2
3
4
5
6
7
main =
    interact (inBounds . map read . words)
    where
    inBounds :: [Int] -> String
    inBounds [w,h,x,y,r]
        | 0 <= (x-r) && (x+r) <= w && 0 <= (y-r) && (y+r) <= h = "Yes¥n"
        | otherwise = "No¥n"

ITP1_3 - Repetitive Processing -

Introduction to Programming I - Repetitive Processing -

Print Many Hello World

ITP1_3_A: Print Many Hello World

1
2
3
import Control.Monad
main =
    replicateM_ 1000 (putStrLn "Hello World")

Print Test Cases

ITP1_3_B: Print Test Cases

x が 0 のとき入力の終わり。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
import Control.Monad
import Control.Applicative

solve :: Int -> Int -> String
solve n x =
    "Case " ++ show n ++ ": " ++ show x

main =
    mapM_ putStrLn =<< (zipWith solve [1..]) . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [Int]
    takeInputs = takeWhile (/= 0) . map read 

Swapping Two Numbers

ITP1_3_C: Swapping Two Numbers

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
import Control.Monad
import Control.Applicative
import Data.List

solve :: [Int] -> String
solve ns =
    unwords . map show $ sort ns

main =      
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== 0)) . map (map read . words) 

How Many Divisors?

ITP1_3_D: How Many Divisors?

1
2
3
4
5
main = 
    interact ((++ "¥n") . fn . map read . words)
    where
    fn [a,b,c] =
        show $ length [x | x<-[a..b], (c `mod` x == 0)]

ITP1_4 - Computation -

Introduction to Programming I - Computation -

A / B Problem

ITP1_4_A: A / B Problem

フォーマット出力

1
2
3
4
5
6
7
8
9
import Control.Applicative
import Text.Printf
readDigits = map read <$> words <$> getLine :: IO [Int]
main = do
    ab@[a,b] <- readDigits
    let d = a `div` b
    let r = a `mod` b
    let f = ([a,b] -> a / b) $ map realToFrac ab
    printf "%d %d %.5fn" d r (f :: Double) 

Circle

ITP1_4_B: Circle

1
2
3
4
import Text.Printf
main = do
    r <- readLn :: IO Double
    printf "%.6f %.6fn" (pi * r^2) (2 * pi * r)

Simple Calculator

ITP1_4_C: Simple Calculator

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
import Control.Monad
import Control.Applicative

solve :: [String] -> [String]
solve [] = []
solve (line:lines) =
    let [a,op,b] = words line in
    case (go (read a) op (read b)) of
    Just x -> show x : solve lines
    Nothing -> []
    where
    go :: Int -> String -> Int -> Maybe Int
    go a "+" b = Just $ a + b
    go a "-" b = Just $ a - b
    go a "*" b = Just $ a * b
    go a "/" b = Just $ a `div` b
    go _ _ _ = Nothing

main = 
    mapM_ putStrLn =<< solve . lines <$> getContents 

Min, Max and Sum

ITP1_4_D: Min, Max and Sum

1
2
3
4
5
6
7
8
9
import Control.Applicative
readDigits = map read <$> words <$> getLine :: IO [Int]

solve :: [Int] -> [Int]
solve ns = [minimum ns, maximum ns, sum ns]

main = do
    _ <- getLine
    putStrLn . unwords . map show . solve =<< readDigits 

ITP1_5 - Structured Program I -

Introduction to Programming I - Structured Program I -

Print a Rectangle

ITP1_5_A: Print a Rectangle

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
import Control.Monad
import Control.Applicative

solve :: [Int] -> String
solve [h,w] = 
    unlines . replicate h $ replicate w '#'

main =
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== 0)) . map (map read . words) 

Print a Frame

ITP1_5_B: Print a Frame

配列の登場。(1,1)から１周回る。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
import Data.Array.ST (STUArray, runSTUArray, newArray, writeArray, getBounds)
import Data.Array.Unboxed
import Data.Ix (range)
import Control.Monad.ST (ST,runST)
import Control.Monad
import Control.Applicative

type PosXY = (Int,Int)
type Box = UArray PosXY Char
type STBox s = ST s (STUArray s PosXY Char)

mkBox :: Int -> Int -> Box
mkBox w h =
    let dirs = [(1,0), (0,1), (-1,0), (0,-1)] in
    runSTUArray $ do
        box <- newArray ((1,1),(w,h)) '.' :: STBox s
        go box (1,1) dirs
    where
    go :: (STUArray s PosXY Char) -> PosXY -> [PosXY] -> STBox s
    go box _ [] =
        return box
    go box xy dxdys@(dxy:nextdxys) = do
        rng <- getBounds box
        writeArray box xy '#'
        let nxy = ((x1,y1) (x2,y2) -> (x1+x2, y1+y2)) xy dxy
        if (inRange rng nxy) then
            go box nxy dxdys
        else
            go box xy nextdxys

solve :: [Int] -> String
solve [h,w] =
    let box = mkBox w h in
    let ((sx,sy), (ex,ey)) = bounds box in
    unlines [[box!(x,y) | x<-[sx..ex]] | y<-[sy..ey]]

main =
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== 0)) . map (map read . words) 

Print a Chessboard

ITP1_5_C: Print a Chessboard

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
import Data.Array.ST (STUArray, runSTUArray, newArray, writeArray, getBounds)
import Data.Array.Unboxed
import Data.Ix (range)
import Control.Monad.ST (ST,runST)
import Control.Monad
import Control.Applicative

type PosXY = (Int,Int)
type Board = UArray PosXY Char
type STBoard s = ST s (STUArray s PosXY Char)

mkChessBoard :: Int -> Int -> Board
mkChessBoard h w =
    runSTUArray $ do
        box <- newArray ((1,1),(w,h)) '.' :: STBoard s
        rng <- range <$> getBounds box
        forM_ rng $ idx@(y,x) -> do
          let c = if even (y+x) then '#' else '.'
          writeArray box idx c
        return box

solve :: [Int] -> String
solve [h,w] =
    let box = mkChessBoard h w in
    let ((sx,sy), (ex,ey)) = bounds box in
    unlines [[box!(x,y) | x<-[sx..ex]] | y<-[sy..ey]]

main =
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== 0)) . map (map read . words) 

Structured Programming

ITP1_5_D: Structured Programming

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
import Control.Monad
import Data.IORef
main = do
    n <- readLn :: IO Int
    x <- newIORef 0;
    forM_ [1..n] $ i -> do
        writeIORef x i
        if (i `mod` 3 == 0) then
            putStr $ " " ++ show i
        else
            include3 i x
    putStrLn ""
    where
    include3 :: Int -> IORef Int -> IO ()
    include3 i x = do
        x' <- readIORef x
        if (x' `mod` 10 == 3) then
            putStr $ " " ++ show i
        else do
            x' <- readIORef x
            writeIORef x (x' `div` 10)
            readIORef x
            >>= a -> when (a /= 0) $
                include3 i x

ITP1_6 - Array -

Introduction to Programming I - Array -

Reversing Numbers

ITP1_6_A: Reversing Numbers

1
2
3
4
5
6
7
import Data.List
import Control.Monad
import Control.Applicative
readDigits = map read <$> words <$> getLine :: IO [Int]
main = do
    _ <- getLine
    putStrLn =<< unwords . map show . reverse <$> readDigits 

Finding Missing Cards

ITP1_6_B: Finding Missing Cards

全てのカード集合（ジョーカー含まず）13×4=52枚から、持っているカードの集合との差（集合）が足りないカード。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
import Data.List
import Control.Monad
import Control.Applicative

data Card = S Int | H Int | C Int | D Int deriving (Show, Eq, Ord)

readCards :: IO [Card]
readCards =
    map rd . lines <$> getContents
    where
    rd :: String -> Card
    rd l =
        case (words l) of
          ["S", n] -> S (read n)
          ["H", n] -> H (read n)
          ["C", n] -> C (read n)
          ["D", n] -> D (read n)
          _ -> undefined

main = do
    _ <- getLine
    cards <- readCards
    let suit = concat [map f [1..13] | f<-[S,H,C,D]]
    mapM_ print (suit \\ cards) 

Official House

ITP1_6_C: Official House

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Data.List
import Data.Array.ST (STUArray, runSTUArray, newArray, readArray, writeArray)
import Data.Array.Unboxed
import Control.Monad.ST (ST,runST)
import Control.Monad
import Control.Applicative

type HouseFloorRoom = (Int,Int,Int)
type Apartment = UArray HouseFloorRoom Int
type STApartment s = ST s (STUArray s HouseFloorRoom Int)

solve :: [String] -> Apartment
solve lines =
    runSTUArray $ do
        arr <- newArray ((1,1,1),(4,3,10)) 0 :: STApartment s
        forM_ lines $ line -> do
            let [b,f,r,v] = map read $ words line
            writeArray arr (b,f,r) =<< (+ v) <$> readArray arr (b,f,r)
        return arr
        
main :: IO ()
main = do
    let sep = replicate 20 '#' ++ "n"
    n <- readLn :: IO Int
    ap <- solve <$> replicateM n getLine
    let ((sh,sf,sr), (eh,ef,er)) = bounds ap
    putStr . intercalate sep $
        [unlines [concat [cell2str ap (h,f,r) | r<-[sr..er]] | f<-[sf..ef]] | h<-[sh..eh]]
    where
    cell2str arr idx = " " ++ (show $ arr!idx) 

Matrix Vector Multiplication

ITP1_6_D: Matrix Vector Multiplication

1
2
3
4
5
6
7
8
import Control.Monad
import Control.Applicative
readDigits = map read <$> words <$> getLine :: IO [Int]
main = do
    [n,m] <- readDigits
    matrix <- replicateM n $ readDigits
    vector <- replicateM m $ readLn :: IO [Int]
    putStr $ unlines [show . sum $ zipWith (*) m vector | m<-matrix] 

ITP1_7 - Structured Program II -

Introduction to Programming I - Structured Program II -

Grading

ITP1_7_A: Grading

問題文そのままの定義。書いた順番で選ばれるから成績のよい条件から並べて書く。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
import Control.Monad
import Control.Applicative

solve :: [Int] -> String
solve [-1, _, _] = "F"
solve [_, -1, _] = "F"
solve [a, b, c]
    | 80 <= (a+b) = "A"
    | 65 <= (a+b) = "B"
    | 50 <= (a+b) = "C"
    | 30 <= (a+b) && 50 <= c = "C"
    | 30 <= (a+b) = "D"
    | otherwise = "F"

main =
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== -1)) . map (map read . words) 

How many ways?

ITP1_7_B: How many ways?

これは99 questions/Solutions/26を参考にした。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
import Control.Monad
import Control.Applicative

combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations _ [] = []
combinations n (x:xs) = (map (x:) (combinations (n-1) xs)) ++ (combinations n xs)

solve :: [Int] -> String
solve [n, x] =
   show $ length [nc3 | nc3<-combinations 3 [1..n], sum nc3==x]

main =
    mapM_ putStrLn =<< map solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = takeWhile (not . all (== 0)) . map (map read . words) 

Spreadsheet

ITP1_7_C: Spreadsheet

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
import Control.Monad
import Control.Applicative
import Data.List

solve :: [[Int]] -> String
solve (rc:cs) =
    let matrix = transpose $ map attachSumCell $ transpose $ map attachSumCell cs in
    unlines [unwords [show c | c<-y] | y<-matrix]
    where
    attachSumCell :: [Int] -> [Int]
    attachSumCell c = c ++ [sum c]

main =
    putStr =<< solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = map (map read . words) 

Matrix Multiplication

ITP1_7_D: Matrix Multiplication

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
import Control.Applicative
import Control.Monad
import Data.List

solve :: [[Int]] -> [String]
solve ([n,m,l]:matxs) =
    let (matA,matB) = splitAt n $ matxs in
    let mAB = [[sum $ zipWith (*) a b | b<-transpose matB] | a<-matA] in
    map (unwords . map show) mAB

main =
    mapM_ putStrLn =<< solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Int]]
    takeInputs = map (map read . words) 

ITP1_8 - Character -

Introduction to Programming I - Character -

Toggling Cases

ITP1_8_A: Toggling Cases

1
2
3
4
5
6
7
import Data.Char
toggle c
    | isLower c = toUpper c
    | isUpper c = toLower c
    | otherwise = c
main =
    interact (map toggle)

Sum of Numbers

ITP1_8_B: Sum of Numbers

1
2
3
4
5
6
7
8
9
import Control.Monad
import Control.Applicative

solve :: String -> String
solve s =
    show $ sum [read [c] | c<-s]

main =
    mapM_ putStrLn =<< map solve . takeWhile (/= "0") . lines <$> getContents 

Counting Characters

ITP1_8_C: Counting Characters

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
import Control.Monad
import Control.Applicative
import Data.Char
import Data.List

solve :: String -> String
solve s =
    let chunk = group $ sort [toLower c | c<-s, isAlpha c] in
    let sets = [(c,length s) | s@(c:_)<-chunk] in
    unlines $ map (showchr sets) ['a'..'z']
    where
    showchr :: [(Char,Int)] -> Char -> String
    showchr sets c =
        let n = maybe 0 id (lookup c sets) :: Int in
        [c] ++ " : " ++ (show n)

main =
    putStr =<< solve <$> getContents 

Ring

ITP1_8_D: Ring

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
import Control.Monad
import Control.Applicative
import Data.List
solve :: [String] -> String
solve [s,p] =
    if (isInfixOf p $ s ++ s) then
        "Yes"
    else
        "No"
main =
    putStrLn =<< solve . lines <$> getContents 

ITP1_9 - String -

Introduction to Programming I - String -

Finding a Word

ITP1_9_A: Finding a Word

“END_OF_TEXT”？それは無視。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
import Control.Monad
import Control.Applicative
import Data.Char
solve :: String -> String
solve str =
    let w:ws = words $ map toLower str in
    show $ length [a | a<-ws, a==w]

main =
    putStrLn =<< solve <$> getContents 

Shuffle

ITP1_9_B: Shuffle

リストを割って、前を後ろにつなぐ。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
import Control.Monad
import Control.Applicative
import Data.List

solve :: [String] -> [String]
solve [] = []
solve (ini:m:ls) =
    let (ns, ns') = splitAt (read m) ls in
    (foldl' shuffle ini $ map read ns) : solve ns'
    where
    shuffle :: String -> Int -> String
    shuffle s n =
        let (a,b) = splitAt n s in
        b ++ a

main =
    mapM_ putStrLn =<< solve . takeWhile (/= "-") . lines <$> getContents 

Card Game

ITP1_9_C: Card Game

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
import Control.Monad
import Control.Applicative
import Data.List
solve :: [String] -> String
solve (n:ls) =
    let (l,r) = foldl' duel (0,0) $ map words ls in
    show l ++ " " ++ show r
    where
    duel :: (Int,Int) -> [String] -> (Int,Int)
    duel (pl,pr) [cl,cr]
        | cl < cr = (pl, pr+3)
        | cl > cr = (pl+3, pr)
        | otherwise = (pl+1, pr+1)

main =
    putStrLn =<< solve . lines <$> getContents 

Transformation

ITP1_9_D: Transformation

Haskellであっても無理せずに副作用は副作用で書こうか。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Control.Monad
import Control.Applicative
import Data.List
solve :: [String] -> IO ()
solve (str:q:cs) =
    foldM_ ope str $ map words cs
    where
    slice :: String -> Int -> Int -> (String,String,String)
    slice str bgn end =
        let (a,b) = splitAt bgn str in
        let (c,d) = splitAt (1+end-bgn) b in
        (a,c,d)
    ope :: String -> [String] -> IO String
    ope str ["print",a,b] = do
        let [a',b'] = map read [a,b]
        let (_,c,_) = slice str a' b'
        putStrLn c
        return str
    ope str ["reverse",a,b] = do
        let [a',b'] = map read [a,b]
        let (l,c,r) = slice str a' b'
        return $ l ++ reverse c ++ r
    ope str ["replace",a,b,p] = do
        let [a',b'] = map read [a,b]
        let (l,c,r) = slice str a' b'
        return $ l ++ zipWith (a b->b) c p ++ r
    ope _ _ = undefined

main =
    solve . lines =<< getContents

ITP1_10 - Math Functions -

Introduction to Programming I - Math Functions -

Distance

ITP1_10_A: Distance

1
2
3
4
5
6
main =
    interact (show . distance . map read . words)
    where
    distance :: [Double] -> Double
    distance [x1,y1,x2,y2] =
        sqrt ((x2-x1)^2 + (y2-y1)^2)

Triangle

ITP1_10_B: Triangle

1
2
3
4
5
6
7
8
solve :: [Double] -> [Double]
solve [a,b,c] =
    let s = (1/2) * a * b * sin (c*pi/180.0) in
    let l = a + b + sqrt (a^2 + b^2 - 2*a*b*cos(c*pi/180)) in
    let h = b * sin (c*pi/180.0) in
    [s,l,h]

main = interact (unlines . map show . solve . map read . words)

Standard Deviation

ITP1_10_C: Standard Deviation

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
import Control.Monad
import Control.Applicative
solve :: [String] -> [String]
solve ("0":_) = []
solve (n:ss:lines) =
    let n' = read n :: Double in
    let ss' = [read s | s<-words ss] :: [Double] in
    let m = sum ss' / n' in
    let alpha = sqrt (sum [(s - m)^2 | s<-ss'] / n') in
    (show alpha) : solve lines

main = mapM_ putStrLn =<< solve . lines <$> getContents 

Distance II

ITP1_10_D: Distance II

問題文によるとnは整数だった。Doubleで定義してもうた。。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
import Control.Monad
import Control.Monad
import Control.Applicative
solve :: [[Double]] -> [Double]
solve [_,vecX,vecY] =
    [
        chebyshev 1.0 vecX vecY,
        chebyshev 2.0 vecX vecY,
        chebyshev 3.0 vecX vecY,
        maximum $ zipWith (x y -> abs(x-y)) vecX vecY
    ] 
    where
    chebyshev :: Double -> [Double] -> [Double] -> Double
    chebyshev n vx vy =
        (sum $ zipWith (x y -> abs(x-y)**n) vx vy) ** (1.0/n)

main =
    mapM_ (putStrLn . show) =<< solve . takeInputs . lines <$> getContents
    where
    takeInputs :: [String] -> [[Double]]
    takeInputs = take 3 . map (map read . words) 

ITP1_11 - Structure and Class -

Introduction to Programming I - Structure and Class -

Dice I

ITP1_11_A: Dice I

リストを配列のようにアクセスして6面を張り替える。
思いついたままのコードでHaskellらしくないかもしれないが、ACを取れたからこれでいいことにする。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
import Control.Applicative
import Data.List

type Dice = [Int]

rot :: Dice -> Char -> Dice
rot d 'E' = [d!!3, d!!1, d!!0, d!!5, d!!4, d!!2]
rot d 'W' = [d!!2, d!!1, d!!5, d!!0, d!!4, d!!3]
rot d 'N' = [d!!1, d!!5, d!!2, d!!3, d!!0, d!!4]
rot d 'S' = [d!!4, d!!0, d!!2, d!!3, d!!5, d!!1]
rot _ _ = undefined

solve :: [String] -> String
solve [labels,cmds] =
    let dice = [read s | s<-words labels] :: Dice in
    show . head $ foldl' rot dice cmds

main =
    putStrLn =<< solve . take 2 . lines <$> getContents 

問題文に

サイコロをクラスや構造体で作成しておきましょう。

と書いてあるので、

1
type Dice = [Int]

サイコロはこのように宣言しておいた。

Dice II

ITP1_11_B: Dice II

上の続き、サイコロをどう動かせばいいかをリストで与える。
lookupで取り出した方向へ動かせばいい。””は動かす必要なしという意味。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe (fromJust)

type Dice = [Int]

rot :: Dice -> Char -> Dice
rot d 'E' = [d!!3, d!!1, d!!0, d!!5, d!!4, d!!2]
rot d 'W' = [d!!2, d!!1, d!!5, d!!0, d!!4, d!!3]
rot d 'N' = [d!!1, d!!5, d!!2, d!!3, d!!0, d!!4]
rot d 'S' = [d!!4, d!!0, d!!2, d!!3, d!!5, d!!1]
rot _ _ = undefined

solve :: [[Int]] -> [String]
solve (dice:qCnt:qs) =
    map solve' $ take (head qCnt) qs
    where
    solve' [upSide,foreSide] =
        let cmdSet = [(upSide, ["", "N", "W", "E", "S", "NN"]),
                        (foreSide, ["S", "", "NWS", "NES", "NEES", "N"])] in
        let d = foldl' f dice cmdSet in
        show $ d!!2
    f :: Dice -> (Int,[String]) -> Dice
    f dice (side,cmds) =
        let cmd = fromJust . lookup side $ zip dice cmds in
        foldl' rot dice cmd 

main =
    mapM_ putStrLn =<< solve . map (map read . words) . lines <$> getContents 

Dice III

ITP1_11_C: Dice III

ろくなアルゴリズムが思いつかないので、E方向、N方向で4×4×4×4=256通り動かせば一致するかな。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe (fromJust)

type Dice = [Int]

rot :: Dice -> Char -> Dice
rot d 'E' = [d!!3, d!!1, d!!0, d!!5, d!!4, d!!2]
rot d 'W' = [d!!2, d!!1, d!!5, d!!0, d!!4, d!!3]
rot d 'N' = [d!!1, d!!5, d!!2, d!!3, d!!0, d!!4]
rot d 'S' = [d!!4, d!!0, d!!2, d!!3, d!!5, d!!1]
rot _ _ = undefined

solve :: [[Int]] -> String
solve (diceA:diceB:_) =
    let es = cycle "E" in
    let ns = cycle "N" in
    let cmdSets =   [ take a es ++ take b ns ++ take c es ++ take d ns
                    | a<-[1..4], b<-[1..4], c<-[1..4], d<-[1..4]]
    in  
    solve' cmdSets
    where
    solve' [] = "No"
    solve' (cmd:cmds) =
        if (foldl' rot diceB cmd == diceA) then
            "Yes"
        else
            solve' cmds

main =
    putStrLn =<< solve . map (map read . words) . lines <$> getContents 

Dice IV

ITP1_11_D: Dice IV

やっぱりアルゴリズムが思いつかないので、力尽くで始末する

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe (fromJust)

type Dice = [Int]

rot :: Dice -> Char -> Dice
rot d 'E' = [d!!3, d!!1, d!!0, d!!5, d!!4, d!!2]
rot d 'W' = [d!!2, d!!1, d!!5, d!!0, d!!4, d!!3]
rot d 'N' = [d!!1, d!!5, d!!2, d!!3, d!!0, d!!4]
rot d 'S' = [d!!4, d!!0, d!!2, d!!3, d!!5, d!!1]
rot _ _ = undefined

solve :: [[Int]] -> String
solve ([n]:dices) =
    let ls = [(a,b) | a<-dices,b<-dices, a/=b] in
    if (any id $ map equal ls) then
        "No"
    else
        "Yes"
    where
    equal (diceA,diceB) =
        let es = cycle "E" in
        let ns = cycle "N" in
        let cmdSets =   [ take a es ++ take b ns ++ take c es ++ take d ns
                        | a<-[1..4], b<-[1..4], c<-[1..4], d<-[1..4]]
        in
        eq cmdSets
        where
        eq [] = False
        eq (cmd:cmds) =
            if (foldl' rot diceB cmd == diceA) then
                True
            else
                eq cmds

main =
    putStrLn =<< solve . map (map read . words) . lines <$> getContents 