{-# OPTIONS -Wall #-} module GIF where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import Data.Char (chr) -------------------------------------------- -- To make a still image or an animation: -- -------------------------------------------- ---------------------------------------------------------- -- Step 1: Choose or write a color table consisting of -- -- exactly 128 colors as your palette. -- -- These colors are numbered 0 through 127. -- -- The color table must contain exactly 128 colors, -- -- for a total of 384 Ints. -- -- You can use 'redBlueColorTable' if you don't want -- -- to write your own. -- ---------------------------------------------------------- -- 384 bytes long, red is 0..63, black is 64, blue is 65..127 redBlueColorTable :: [Int] redBlueColorTable = [255,0,0] ++ concat [[n,0,0] | n <- [252, 248 .. 4]] ++ concat [[0,0,n] | n <- [ 0, 4 .. 252]] redTealColorTable :: [Int] redTealColorTable = [255,0,0] ++ concat [[n,0,0] | n <- [252, 248 .. 4]] ++ concat [[0,n,n] | n <- [ 0, 4 .. 252]] -- Black is 0, yellow is 127 blackYellowColorTable :: [Int] blackYellowColorTable = concat [[n,n,0] | n <- [0, 2 .. 254]] --------------------------------------------------------------------------------- -- Step 2: Choose number of pixels for width and number of pixels for height. -- -- width has type Int -- -- height has type Int -- --------------------------------------------------------------------------------- ---------------------------- -- To make a still image: -- ---------------------------- data Image = Image { imageColorTable :: [Int] , imageWidth :: Int -- number of horizontal pixels , imageHeight :: Int -- number of vertical pixels , imageData :: [Int] } deriving (Eq,Show) ------------------------------------------------------------------ -- Step 3: Provide image data. -- -- Image data runs horizontally from left to right across the -- -- top of the image, then left to right across the second -- -- row, on down to the bottom. Each Int falls in the range -- -- 0 to 127 and represents the color of a pixel. -- -- Image data has type [Int]. -- -- The list must be exactly width x height in length. -- ------------------------------------------------------------------ makeImageGIF :: FilePath -> Image -> IO () makeImageGIF filename (Image colorTable width height image) = let gifString = makeImageGIFString colorTable width height image in writeGIFFile filename gifString exampleImage :: Image exampleImage = let f x y = cos (sqrt (x**2 + 2*y**2)/8) in Image { imageColorTable = redBlueColorTable , imageWidth = 200 -- pixels , imageHeight = 200 -- pixels , imageData = scale127list [f x y | y <- [0..199 :: Double] , x <- [0..199 :: Double]] } writeExampleImage :: IO () writeExampleImage = makeImageGIF "exampleImage.gif" exampleImage exampleRedSquare :: Image exampleRedSquare = Image { imageColorTable = redBlueColorTable , imageWidth = 400 -- pixels , imageHeight = 400 -- pixels , imageData = replicate 160000 0 } writeRedSquare :: IO () writeRedSquare = makeImageGIF "exampleRedSquare.gif" exampleRedSquare --------------------------- -- To make an animation: -- --------------------------- -- animTimeStep is the number of hundredths of a second between frames. -- It must satisfy 1 <= animTimeStep <= 255. data Animation = Animation { animColorTable :: [Int] , animWidth :: Int -- number of horizontal pixels , animHeight :: Int -- number of vertical pixels , animTimeStep :: Int -- hundredths of a second , animData :: [[Int]] } deriving (Eq,Show) ------------------------------------------------------------------ -- Step 3: Provide animation data. -- -- The animation data is list of image data. -- -- Since image data has type [Int], animation data has type -- -- [[Int]]. -- ------------------------------------------------------------------ makeAnimGIF :: FilePath -> Animation -> IO () makeAnimGIF filename anim = let gifString = makeAnimGIFString2 anim in writeGIFFile filename gifString exampleAnim :: Animation exampleAnim = let f x y t = cos (sqrt (x**2 + 2*y**2)/8 - 2*t) in Animation { animColorTable = redBlueColorTable , animWidth = 200 -- pixels , animHeight = 200 -- pixels , animTimeStep = 10 -- hundredths of a second , animData = scale127 [[f x y t | y <- [0..199 :: Double] , x <- [0..199 :: Double]] | t <- [0,0.1 .. 10]] } writeExampleAnim :: IO () writeExampleAnim = makeAnimGIF "exampleAnim.gif" exampleAnim --------------------- -- Supporting Code -- --------------------- type R = Double header :: String header = "GIF89a" trailer :: String trailer = [chr 0x3b] widthHeight :: Int -> Int -> String widthHeight width height = let wwH = div width 256 wwL = mod width 256 hhH = div height 256 hhL = mod height 256 in if wwH < 256 && hhH < 256 then map chr [wwL,wwH,hhL,hhH] else error $ "bad width or height: (wwH,hhH) = (" ++ show wwH ++ "," ++ show hhH ++ ")" -- repeat the animation 65535 times appExtension :: String appExtension = [chr 0x21, chr 0xff, chr 0x0b] ++ "NETSCAPE2.0" ++ [chr 0x03, chr 0x01, chr 0xff, chr 0xff, chr 0x00] -- graphic control extension -- Give the number of hundredths of a second between frames. gceTimeStep :: Int -> String gceTimeStep dt = map chr [0x21,0xf9,0x04,0x04,dt,0x00,0xff,0x00] makeFrameImage :: Int -> Int -> [Int] -> String makeFrameImage width height image = imageDescriptor width height ++ [chr 7] ++ subBlockify image ++ [chr 0] makeFrameAnim :: Int -> Int -> Int -> [Int] -> String makeFrameAnim width height dt image = gceTimeStep dt ++ makeFrameImage width height image -- logical screen descriptor lsd :: Int -> Int -> String lsd width height = widthHeight width height ++ map chr [0xf6,0,0] -- 10 bytes imageDescriptor :: Int -> Int -> String imageDescriptor width height = chr 0x2c : replicate 4 (chr 0) ++ widthHeight width height ++ [chr 0] subBlockify :: [Int] -> String subBlockify ns = let blk = take 120 ns rst = drop 120 ns cblk = 128 : blk in if length blk < 120 then let endblk = cblk ++ [129] in map chr (length endblk : endblk) else map chr (length cblk : cblk) ++ subBlockify rst writeGIFFile :: FilePath -> String -> IO () writeGIFFile filename gifData = B.writeFile filename $ C.pack gifData makeImageGIFString :: [Int] -> Int -> Int -> [Int] -> String makeImageGIFString colorTable width height image = header ++ lsd width height ++ map chr colorTable ++ makeFrameImage width height image ++ trailer makeAnimGIFString :: [Int] -> Int -> Int -> [[Int]] -> String makeAnimGIFString colorTable width height images = header ++ lsd width height ++ map chr colorTable ++ appExtension ++ concat [makeFrameImage width height image | image <- images] ++ trailer makeAnimGIFString2 :: Animation -> String makeAnimGIFString2 (Animation colorTable width height dt images) = header ++ lsd width height ++ map chr colorTable ++ appExtension ++ concat [makeFrameAnim width height dt image | image <- images] ++ trailer -- 0 maps to 64 scale127list :: [R] -> [Int] scale127list zs = let zMax = maximum $ map abs zs in map (round . (*127) . (/2) . (+1) . (/zMax)) zs -- 0 maps to 64 scale127 :: [[R]] -> [[Int]] scale127 zs = let zMax = maximum $ map abs $ concat zs in map (map (round . (*127) . (/2) . (+1) . (/zMax))) zs -- NN = non-negative scaleNN :: [[R]] -> [[Int]] scaleNN zs = let zMax = maximum $ concat zs in map (map (round . (*127) . (/zMax))) zs scaleNNpower :: R -> [[R]] -> [[Int]] scaleNNpower p zs = let zMax = maximum $ concat zs in map (map (round . (*127) . (**p) . (/zMax))) zs oddPow :: R -> R -> R oddPow x p = if x >= 0 then x ** p else -abs x ** p raise :: R -> R -> R raise p x = oddPow x p -- 0 maps to 64 scale127power :: R -> [[R]] -> [[Int]] scale127power p zs = let zMax = maximum $ map abs $ concat zs in map (map (round . (*127) . (/2) . (+1) . raise p . (/zMax))) zs