halftone

import Data.Array.IArray
import Control.Monad (liftM,replicateM)
import System (getArgs)
import System.Random (getStdGen,randomRs)
type Picture = Array (Int,Int) Int
step x | x <  = 
| otherwise = 1
inv  = 1
inv _ = 
threshold :: Picture -> Int -> Picture
threshold a t= a//[((i',j'),inv.step$a!(i,j)-t)
|i' <- range(i,k),j'<-range(j,l)]
where ((i,j),(k,l)) = bounds a
mask4 = listArray ((1,1),(4,4))
[6,12,7,9,
15,1,14,4,
10,8,11,5,
3,13,2,16]::Array(Int,Int) Int
mask3 = listArray((1,1),(3,3))
[8,1,6,
3,5,7,
4,9,2]::Array(Int,Int) Int
dither ::Array(Int,Int) Int -> Picture ->Int-> Picture
dither m a n= a//[((i',j'),inv.step$ (m1*m2+1)*a!(i',j') - n*m!((mod i' m1)+1,(mod j' m2)+1))
|i' <- range(i,k),j'<-range(j,l)]
where ((i,j),(k,l)) = bounds a
((_,_),(m1,m2)) = bounds m
rand ::Picture -> Int -> IO Picture
rand a m = do
r <- getStdGen
return$listArray ((1,1),(h,w))$zipWith f (elems a)$ take (h*w) $randomRs(,m)r
where f x y = inv.step $ x- y
((_,_),(h,w)) = bounds a
er ::Picture -> Int -> Picture
er a m = listArray (bounds a) $ map (inv.fst) $elems a'
where a' = listArray (bounds a) $ map b $indices a::Array(Int,Int)(Int,Double)
e (1,1) = 
e (1,j+1) = snd $ a'!(1,j)
e (i+1,1) =sum$ zipWith (*) [2*x,2*y] $map(snd.(a'!))[(i,1),(i,2)]
e (i+1,w) =sum$ zipWith (*) [z,z*sqrt 2,z*sqrt 2] $map(snd.(a'!))[(i,w-1),(i,w),(i+1,w-1)]
e (i+1,j+1) =sum$ zipWith (*) [y,x,y,x] $map(snd.(a'!))[(i,j),(i,j+1),(i,j+2),(i+1,j)]
b (i,j) = (step$ e(i,j)+(fromIntegral$a!(i,j))-m'/2,e(i,j)+(fromIntegral$a!(i,j)-m*fst(b(i,j))))
m' = fromIntegral m
x = 1/(2+sqrt 2)
y = 1/(2+2*sqrt 2)
z = 1/(1+2*sqrt 2)
((_,_),(_,w)) = bounds a
splitW::Picture -> (Picture,Picture)
splitW a =(listArray((1,1),(h,w'))a1,listArray((1,1),(h,w-w'))a2)
where ((_,_),(h,w)) = bounds a
w' = ceiling $ (/2).fromIntegral $ w
a1 = [a!(i,j)|i<-range(1,h),j<-range(1,w')]
a2 = [a!(i,j)|i<-range(1,h),j<-range(w'+1,w)]
splitH::Picture -> (Picture,Picture)
splitH a =(listArray((1,1),(h',w))a1,listArray((1,1),(h-h',w))a2)
where ((_,_),(h,w)) = bounds a
h' = ceiling $ (/2).fromIntegral $ h
a1 = [a!(i,j)|i<-range(1,h'),j<-range(1,w)]
a2 = [a!(i,j)|i<-range(h'+1,h),j<-range(1,w)]
combW::(Picture,Picture)->Picture
combW (a,b) = listArray ((1,1),(h,wa+wb)) 
where ((_,_),(h,wa)) = bounds a
((_,_),(_,wb)) = bounds b
c (i,j) | j <= wa = a!(i,j)
| otherwise =b!(i,j-wa)
combH::(Picture,Picture)->Picture
combH (a,b) = listArray ((1,1),(ha+hb,w)) 
where ((_,_),(ha,w)) = bounds a
((_,_),(hb,_)) = bounds b
c(i,j) | i <= ha = a!(i,j)
| otherwise = b!(i-ha,j)
divide::Picture -> Int -> Int -> Picture
divide a s m
| h == 1 && w==1 = listArray ((1,1),(1,1)) [s]
| h > w = combH(divide h1 (signum$rh+s)m,divide h2 ((rh+s)`div`2)m)
| otherwise = combW(divide w1 (signum$rw+s)m,divide w2 ((rw+s)`div`2)m)
where ((_,_),(h,w)) = bounds a
(h1,h2) = splitH a
(w1,w2) = splitW a
r a1 a2 = step.(flip(-)m).sum.map ((flip mod m).sum.elems) $ [a1,a2]
(rh,rw)= (r h1 h2,r w1 w2)
getPic :: IO (String,Int,Picture)
getPic = do
t <- getLine
(w:h:hs) <- toNums getLine :: IO [Int]
(m:ms) <- toNums getLine :: IO [Int]
a <- toNums getContents ::IO[Int]
case t of
"P3" -> return (t,m,listArray((1,1),(h,3*w)) a)
"P2" -> return (t,m,listArray((1,1),(h,w)) a)
where toNums = liftM(map read.words)
outP1 p = do
putStrLn "P1"
putStrLn $ show w ++" " ++ show h
putStrLn.concat.map((" "++).show).elems $ p
where ((_,_),(h,w)) = bounds p
outP3 p = do
putStrLn "P3"
putStrLn $ show (div w 3) ++" " ++ show h
putStrLn "1"
putStrLn.concat.map((" "++).show.((flip mod 2).(+1))).elems $ p
where ((_,_),(h,w)) = bounds p
main :: IO ()
main = do
a <- getArgs
(t,m,p) <- getPic
case (head a)++t of
"tP2" -> outP1 $ threshold p (div m 2)
"tP3" -> outP3 $ threshold p (div m 2)
"dP2" -> outP1 $ dither mask3 p m
"dP3" -> outP3 $ dither mask3 p m
"d3P2" -> outP1 $ dither mask3 p m
"d3P3" -> outP3 $ dither mask3 p m
"d4P2" -> outP1 $ dither mask4 p m
"d4P3" -> outP3 $ dither mask4 p m
"rP2" -> rand p m >>= outP1
"rP3" -> rand p m >>= outP3
"eP2" -> outP1 $ er p m
"eP3" -> outP3 $ er p m
"vP2" -> outP1 $ divide (listArray(bounds p)(map ((-)m) (elems p)))  m
"vP3" -> outP3 $ divide p  m
"gP2" -> outP1.pg.modGen$read(a!!1)
pic = listArray ((1,1),(10,10)) [..99]::Picture
pg a = listArray ((1,1),(256,256))[a(i,j)|i<-[1..256],j<-[1..256]]::Picture
modGen  m (i,j) =inv $  (i+j)`mod` m
More Reading
Newer// マラソン
Older// haskell memo