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
作成者 Toru Mano
最終更新時刻 2023-01-01 (c70d5a1)