Haskell - ビット演算(ビットマップグラフィックス(対角線))

すごいHaskellたのしく学ぼう!
(オーム社)
Miran Lipovača (著)
田中 英行 村主 崇行 (翻訳)
[Kindle版]

開発環境

• OS X Mavericks - Apple(OS)
• BBEdit - Bare Bones Software, Inc., Emacs (Text Editor)
• Haskell (純粋関数型プログラミング言語)
• GHC (The Glasgow Haskell Compiler) (処理系)
• The Haskell Platform (インストール方法、モジュール等)

C実践プログラミング 第3版 (Steve Oualline (著)、 望月 康司 (監訳) (翻訳)、谷口 功 (翻訳)、オライリー・ジャパン)のⅡ部(単純なプログラミング)の11章(ビット演算)、11.8(ビットマップグラフィックス)、11.10(プログラミング実習)、実習11-3をHaskellで解いてみる。

その他参考書籍

• プログラミングHaskell (オーム社) Graham Hutton(著) 山本 和彦(翻訳)
• Real World Haskell―実戦で学ぶ関数型言語プログラミング (オライリージャパン) Bryan O'Sullivan John Goerzen Don Stewart(著) 山下 伸夫 伊東 勝利 株式会社タイムインターメディア(翻訳)

実習11-3.

コード(BBEdit)

Sample.hs

{-# OPTIONS -Wall -Werror #-}
import Data.Bits
import Data.Word

main :: IO ()
main = putStr $ makeGraphics whiteCross

canvas :: [[Word8]]
canvas = replicate (div xSize 8) $ replicate ySize 0

blackCanvas :: [[Word8]]
blackCanvas = foldr mySetBit
                    canvas
                    [(x, y) | x <- [0..xSize - 1], y <- [0..ySize - 1]]

whiteCross :: [[Word8]]
whiteCross = foldr myClearBit blackCanvas [(x, x) | x <- [0..xSize - 1]]

xSize :: Int
xSize = 40

ySize :: Int
ySize = 60

mySetBit :: (Int, Int) -> [[Word8]] -> [[Word8]]
mySetBit (x, y) graphics =
    let a = div x 8
        b = graphics !! a
        c = take y b ++ ((b !! y) .|. (shiftR 0x80 (mod x 8))):drop (y + 1) b
    in take a graphics ++ c:drop (a + 1) graphics

myClearBit :: (Int, Int) -> [[Word8]] -> [[Word8]]
myClearBit (x, y) graphics =
    let a = div x 8
        b = graphics !! a
        c = take y b ++
            b !! y .&.
            complement ((shiftR 0x80 (mod x 8)) :: Word8):drop (y + 1) b
    in take a graphics ++ c:drop (a + 1) graphics

myTestBit :: (Int, Int) -> [[Word8]] -> Bool
myTestBit (x, y) graphics =
    graphics !! (div x 8) !! y .&. shiftR 0x80 (mod x 8) > 0

makeGraphics :: [[Word8]] -> String
makeGraphics graphics = unlines $ concatStrings (div xSize 8) $
    map (\(y, x) -> (map (\b -> if graphics !! x !! y .&. b /= 0 then
                                    'X'
                                else
                                    '.')    
                         (takeWhile (>0) $ geometricShift 0x80 1)))
        [(y, x) | y <- [0..ySize - 1], x <- [0..(div xSize 8) - 1]]

geometricShift :: (Bits b) => b -> Int -> [b]
geometricShift a r = a:(map (`shiftR`r) $ geometricShift a r)

concatStrings :: Int -> [String] -> [String]
concatStrings _ [] = []
concatStrings n x = concat (take n x):concatStrings n (drop n x)

入出力結果(Terminal, runghc)

$ runghc Sample.hs
.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
X.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.XX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.X
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX.
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
$

{-# OPTIONS -Wall -Werror #-}を記述してるから、細かく型を指定(:: Double)しないと警告がいっぱい出た。慣れるまでは{-# OPTIONS -Wall -Werror #-}の記述を消さずに細かく型を指定していくことに。