ghc/tests/programs/galois_raytrace/Pixmap.hs

   1 -- Copyright (c) 2000 Galois Connections, Inc.
   2 -- All rights reserved.  This software is distributed as
   3 -- free software under the license in the file "LICENSE",
   4 -- which is included in the distribution.
   5
   6 module Pixmap where
   7
   8 import Char
   9 import IO hiding (try)
  10 import Parsec
  11
  12 readPPM f
  13   = do  h <- openFile f ReadMode
  14         s <- hGetContents h
  15         case (parse parsePPM f s) of
  16           Left err -> error (show err)
  17           Right x  -> return x
  18
  19 writePPM f ppm
  20   = do  h <- openFile f WriteMode
  21         let s = showPPM (length (head ppm)) (length ppm) ppm
  22         hPutStr h s
  23
  24 -- parsing
  25
  26 parsePPM
  27   = do  string "P6"
  28         whiteSpace
  29         width <- number
  30         whiteSpace
  31         height <- number
  32         whiteSpace
  33         colormax <- number
  34         whiteSpace
  35         cs <- getInput
  36         return (chop width (chopColors cs))
  37
  38 chopColors [] = []
  39 chopColors (a:b:c:ds) = (ord a, ord b, ord c) : chopColors ds
  40
  41 chop n [] = []
  42 chop n xs = h : chop n t
  43     where (h, t) = splitAt n xs
  44
  45 number
  46   = do  ds <- many1 digit
  47         return (read ds :: Int)
  48
  49 whiteSpace
  50   = skipMany (simpleSpace <|> oneLineComment <?> "")
  51     where simpleSpace = skipMany1 (oneOf " \t\n\r\v")
  52           oneLineComment =
  53               do  char '#'
  54                   skipMany (noneOf "\n\r\v")
  55                   return ()
  56
  57 -- printing
  58
  59 showPPM :: Int -> Int -> [[(Int,Int,Int)]] -> String
  60 showPPM wid ht pss
  61   = header ++ concat [[chr r, chr g, chr b] | ps <- pss, (r, g, b) <-ps]
  62   where
  63     header = "P6\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n"
  64 showPPM _ _ _ = error "incorrect length of bitmap string"