Funktionale Programmierung: Bilder als Funktionen
| Funktionale Programmierung: Bilder als Funktionen |
|
|
|
module ImageTypes
where
-- ----------------------------------------
type Lightness = Double
type Channel = Int -> Int -> Lightness
data Geo
= Geo { width :: ! Int
, height :: ! Int
}
deriving (Eq)
data Image
= Image { geo :: ! Geo
, img :: Channel
}
-- ----------------------------------------
-- mothers little helper
on2 :: (a -> b) ->
(c -> d -> a) -> (c -> d -> b)
f `on2` c = \ x y -> f (c x y)
merge :: (a -> b -> c) ->
(x -> y -> a) ->
(x -> y -> b) ->
(x -> y -> c)
merge op f1 f2 = \ x y -> f1 x y `op` f2 x y
-- ----------------------------------------
-- predefined Lightness values
dark :: Lightness
dark = 0.0
light :: Lightness
light = 1.0
grey :: Lightness
grey = 0.5
lightOrDark :: Lightness -> Lightness
lightOrDark c
| c <= 0.5 = 0.0
| otherwise = 1.0
gammaLight :: Lightness -> Lightness -> Lightness
gammaLight g x = x ** (1/g)
invertLight :: Lightness -> Lightness
invertLight = (1.0 -)
reduceLight :: Int -> Lightness -> Lightness
reduceLight n c = fromIntegral c' / fromIntegral (n - 1)
where
c' :: Int
c' = floor (fromIntegral n * c)
-- ----------------------------------------
-- predefined channel values and combinators
uniChan :: Lightness -> Channel
uniChan = const . const
darkChan :: Channel
darkChan = uniChan dark
lightChan :: Channel
lightChan = uniChan light
mergeChan :: Lightness -> Channel -> Channel -> Channel
mergeChan a c1 c2
= \ x y -> a * c1 x y + (1 - a) * c2 x y
addChan :: Channel -> Channel -> Channel
addChan = mergeChan grey
addChans :: [Channel] -> Channel
addChans cs = \ x y ->
sum (map (\ c -> c x y) cs)
/ fromIntegral (length cs)
rectangleChan :: Geo -> Channel
rectangleChan (Geo w h)
= \ x y ->
if 0 <= x && x < w && 0 <= y && y < h
then light
else dark
-- ----------------------------------------
--
-- predefined geometry values anf functions
instance Show Geo where
show (Geo w h) = show w ++ "x" ++ show h
mkGeo :: Int -> Int -> Geo
mkGeo w h
| w > 0 && h > 0 = Geo w h
| otherwise = error $ "illegal geometry " ++ show (Geo w h)
maxGeo :: Geo -> Geo -> Geo
(Geo w1 h1) `maxGeo` (Geo w2 h2) = Geo (w1 `max` w2) (h1 `max` h2)
minGeo :: Geo -> Geo -> Geo
(Geo w1 h1) `minGeo` (Geo w2 h2) = Geo (w1 `min` w2) (h1 `min` h2)
flipGeo :: Geo -> Geo
flipGeo (Geo w h) = Geo h w
scaleGeo :: Int -> Int -> Geo -> Geo
scaleGeo n m (Geo w h) = mkGeo (n * w) (m * h)
shiftGeo :: Int -> Int -> Geo -> Geo
shiftGeo n m (Geo w h) = mkGeo (w + n) (h + m)
-- ----------------------------------------
mkBitmap :: Geo -> (Int -> Int -> Bool) -> Image
mkBitmap g f = Image g ((fromIntegral . fromEnum) `on2` f)
-- ----------------------------------------
invert :: Image -> Image
invert (Image g c)
= Image g $ \ x y -> 1 - c x y
gamma :: Lightness -> Image -> Image
gamma = undefined
bitmap :: Image -> Image
bitmap = undefined
reduceColors :: Int -> Image -> Image
reduceColors n = transLight (reduceLight n)
transLight :: (Lightness -> Lightness) ->
Image -> Image
transLight tf (Image g c)
= Image g $ tf `on2` c
-- ----------------------------------------
flipV :: Image -> Image
flipV (Image g@(Geo w _h) c)
= Image g $ \ x y -> c (w - x - 1) y
flipH :: Image -> Image
flipH (Image g i)
= undefined
rot90 :: Image -> Image
rot90 (Image g i)
= undefined
rot180 :: Image -> Image
rot180 = undefined
rot270 :: Image -> Image
rot270 = undefined
-- das Bild um n Spalten nach rechts rotieren und
-- um m Zeilen nach unten
shiftRot :: Int -> Int -> Image -> Image
shiftRot n m (Image g i)
= undefined
-- das Bild n mal in der Wagerechten und
-- m mal in der Senkrechten wiederhohlen
-- (kacheln)
tile :: Int -> Int -> Image -> Image
tile n m (Image g i)
= undefined
-- das gleiche wie tile, nur mit abwechselnd gespiegelten
-- Bildern, so dass keine sichtbaren Kanten an den Bildgrenzen
-- entstehen
tileMirr :: Int -> Int -> Image -> Image
tileMirr n m (Image g i)
= undefined
-- Groesse halbieren
halfSize :: Image -> Image
halfSize (Image (Geo w h) i)
= undefined
-- vergroessern um die Faktoren n un m
scale :: Int -> Int -> Image -> Image
scale n m (Image g i)
= undefined
-- Zwei Bilder kombinieren, z.B. addieren
merge2 :: (Lightness -> Lightness -> Lightness) ->
Image -> Image -> Image
merge2 op (Image g1 i1) (Image g2 i2)
= undefined
-- ----------------------------------------
|
|
module Main where
import Data.Maybe
import ImageTypes
import ReadImage
import ShowImage
import System.Environment
import System.IO
-- --------------------------------------
processImage :: FilePath -> FilePath
-> (Image -> Image)
-> IO ()
processImage src dst f
= do ih <- openBinaryFile src ReadMode
c <- hGetContents ih
let res = showImage True . f . readImage $ c
oh <- openBinaryFile dst WriteMode
hPutStr oh res
hClose ih
hClose oh
-- --------------------------------------
main :: IO()
main
= getArgs >>= main1
main1 :: [String] -> IO()
main1 [opr, inp, outp]
= do
processImage inp outp (lookupOp opr)
where
lookupOp op
= (fromMaybe id . lookup op) fctTab
fctTab :: [(String, Image -> Image)]
fctTab
= [ ("id" , id )
, ("bitmap" , bitmap )
, ("fliph" , flipH )
, ("flipv" , flipV )
, ("gamma.5" , gamma 0.5 )
, ("gamma2" , gamma 2.0 )
, ("halfsize" , halfSize )
, ("invert" , invert )
, ("reduce3" , reduceColors 3 )
, ("rot90" , rot90 )
, ("rot180" , rot180 )
, ("rot270" , rot270 )
, ("double" , scale 2 3 )
, ("tile4" , tile 2 2 )
, ("tilemir4" , tileMirr 2 2 )
, ("shiftrot" , shiftRot 20 20)
, ("mult" , \ i -> merge2 (*) i (flipV i))
]
main1 args
= hPutStrLn stderr $ "usage: Uebung7 <fct> <input> <output> (got: " ++ show args ++ ")"
-- --------------------------------------
|
|
module ReadImage
(readImage)
where
import Data.Array.Unboxed
import Data.Word
import ImageTypes
readImage :: String -> Image
readImage = readPNM . item
readPNM :: (String, String) -> Image
readPNM ("P1", str)
= mkBitmap (mkGeo w h) at
where
(ns, rest)= readRow 2 str
[w, h] = map read ns
pixels = fst . readRow len $ rest
len = w * h
bits :: [Int]
bits = map read pixels
bitMx :: UArray Int Bool
bitMx = listArray (0, len - 1) . map (== 0) $ bits
at x y
| 0 <= x && x < w &&
0 <= y && y < h
= bitMx ! (x + w * y)
| otherwise
= False
readPNM ("P2", str)
= Image (mkGeo w h) at
where
([w', h', m'], rest) = readRow 3 str
w = (read w')::Int
h = (read h')::Int
m = (read m')::Lightness
l = w * h
pixels = fst . readRow l $ rest
bytes :: [Word8]
bytes = map read pixels
byteMx :: UArray Int Word8
byteMx = listArray (0, l - 1) bytes
at x y
| 0 <= x && x < w &&
0 <= y && y < h
= fromIntegral (byteMx ! (x + w * y)) / m
| otherwise
= dark
readPNM ("P3", str)
= Image (mkGeo w h) at
where
([w', h', m'], rest) = readRow 3 str
w = (read w')::Int
h = (read h')::Int
m = (read m')::Lightness
len = w * h
len3 = len * 3
pixels = fst . readRow len3 $ rest
bytes :: [Word8]
bytes = merge3 (map read pixels)
where
merge3 (r:g:b:xs) = (r + g + b) `div` 3 : merge3 xs
merge3 _ = []
byteMx :: UArray Int Word8
byteMx = listArray (0, len - 1) bytes
at x y
| 0 <= x && x < w &&
0 <= y && y < h
= fromIntegral (byteMx ! (x + w * y)) / m
| otherwise
= dark
readPNM ("P5", str)
= Image (mkGeo w h) at
where
([w', h', m'], rest) = readRow 3 str
w = (read w')::Int
h = (read h')::Int
m = (read m')::Lightness
l = w * h
bytes :: [Word8]
bytes = map (toEnum . fromEnum) .tail $ rest
byteMx :: UArray Int Word8
byteMx = listArray (0, l - 1) bytes
at x y
| 0 <= x && x < w &&
0 <= y && y < h
= fromIntegral (byteMx ! (x + w * y)) / m
| otherwise
= dark
readPNM ("P6", str)
= Image (mkGeo w h) at
where
([w', h', m'], rest) = readRow 3 str
w = (read w')::Int
h = (read h')::Int
m = (read m')::Lightness
len = w * h
bytes :: [Word8]
bytes = merge3 . map (toEnum . fromEnum) . tail $ rest
where
merge3 (r:g:b:xs) = (r + g + b) `div` 3 : merge3 xs
merge3 _ = []
byteMx :: UArray Int Word8
byteMx = listArray (0, len - 1) bytes
at x y
| 0 <= x && x < w &&
0 <= y && y < h
= fromIntegral (byteMx ! (x + w * y)) / m
| otherwise
= dark
readPNM (fmt, _)
= error $ "unsupported PNM format " ++ show fmt
-- ----------------------------------------
item :: String -> (String, String)
item str
= i1
where
i@(w,r) = head (lex str)
i1 | head w == '#'
= item r1
| otherwise
= i
where
r1 = ( drop 1 . snd . break (== '\n') . drop 1) r
readFct :: (String -> (a, String)) ->
Int ->
String -> ([a], String)
readFct _f 0 str
= ([],str)
readFct f n str
= (i:r, str2)
where
(i, str1) = f str
(r, str2) = readFct f (n-1) str1
readRow :: Int -> String -> ([String], String)
readRow = readFct item
-- ----------------------------------------
|
|
module ShowImage
(showImage)
where
import ImageTypes
-- ----------------------------------------
showImage :: Bool -> Image -> String
showImage bin (Image (Geo w h) at)
= imgType ++ imgGeo ++ "255\n" ++ imgData
where
imgGeo = show w ++ " " ++ show h ++ "\n# Haskell PPM Tools\n"
imgType
| bin = "P5\n"
| otherwise = "P2\n"
imgData
= pixToChar . pixToList $ at
pixToChar
| bin = map toEnum
| otherwise = concatMap ((++ "\n") . show)
pixToList f
= [ toPix (f x y) | y <- [0..h-1], x <- [0..w-1] ]
where
toPix :: Lightness -> Int
toPix c = floor (c * 256.0) `min` 255 `max` 0
-- ----------------------------------------
|
|
-- Initial Uebung7.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: Uebung7
version: 0.1.0.0
synopsis: Simple Image Manipulation
build-type: Simple
cabal-version: >=1.10
executable Uebung7
main-is: Main.hs
other-modules: ImageTypes
ReadImage
ShowImage
other-extensions: OverloadedStrings
build-depends: base >=4
, array >=0.4
, bytestring >=0.10
default-language: Haskell2010
ghc-options: -Wall -funbox-strict-fields -fwarn-tabs
|
|
| Letzte Änderung: 27.03.2015 | © Prof. Dr. Uwe Schmidt |
