For the Haskell program from hell (it kills ghc-6.01 on OpenBSD 3.4, hugs on MacOS X and hugs on EPOC)....
It's a translation of the (in)famous jpeg.gs script - but I'm yet to see whether it works or not, and how fast. But it does compile cleanly.
I can send you a sample JPEG that causes the crash, but I think any image will do.
Good luck, and thanks for making Haskell happen in the real world.
> module Jpeg where > import Char > type Table a = Int -> a
Auxiliary functions: > infixr 9 `o` > o :: (c->d) -> (a->b->c) -> (a->b->d) > (g `o` f) x y = g (f x y) > > ap :: (a->b) -> a -> b > ap f x = f x > > ap' :: a -> (a->b) -> b > ap' x f = f x > > > subst :: Eq a => a -> b -> (a->b) -> (a->b) > subst i e t j | i==j = e > | otherwise = t j > > multi :: Int -> [a] -> [a] > multi n = concat . map (replicate n) > > ceilDiv :: Int -> Int -> Int > --ceilDiv n d = (n+d-1)/d > ceilDiv n d = (n+d-1) `div` d -- I think Matrix manipulation > type Dim = (Int,Int) > type Mat a = [[a]] > > matapply :: Num a => Mat a -> [a] -> [a] > matapply m v = map (inprod v) m > > inprod :: Num a => [a] -> [a] -> a > inprod = sum `o` zipWith (*) > > matmap :: (a->b) -> Mat a -> Mat b > matmap = map . map > > matconcat :: Mat (Mat a) -> Mat a > matconcat = concat . map (map concat . transpose) > > matzip :: [Mat a] -> Mat [a] > matzip = map transpose . transpose > > transpose :: [[a]] -> [[a]] -- transpose list of lists > transpose = foldr > (\xs xss -> zipWith (:) xs (xss ++ repeat [])) > [] Bit Streams > type Bits = [Bool] > > byte2bits :: Int -> Bits > byte2bits x = zipWith (>=) (map (rem x) powers) (tail powers) > where powers = [256,128,64,32,16,8,4,2,1] > > string2bits :: String -> Bits > string2bits = concat . map (byte2bits.ord) > > byte2nibs :: Int -> (Int,Int) > --byte2nibs x = (x/16, x`rem`16) > byte2nibs x = (x `div` 16, x `rem` 16) -- I think; maybe should be divMod? Binary Trees > data Tree a = Nil > | Tip a > | Bin (Tree a) (Tree a) > instance Functor Tree where > fmap f Nil = Nil > fmap f (Tip a) = Tip (f a) > fmap f (Bin x y) = Bin (fmap f x) (fmap f y) State Function (StFun) Monad > data StFun s r = SF (s -> (r,s)) > > instance Functor (StFun s) where > fmap h (SF f) = SF g > where g s = (h x,s') > where (x,s') = f s > > instance Monad (StFun s) where > return x = SF g > where g s = (x,s) > SF f >>= sfh = SF g > where g s = h s' > where (x,s') = f s > SF h = sfh x > > st'apply :: StFun a b -> a -> b > st'apply (SF f) s = x > where (x,_) = f s ---------------------------------------------- -- Primitive State Functions ---------------------------------------------- > empty :: StFun [a] Bool > empty = SF f > where f [] = (True, []) > f xs = (False, xs) > > item :: StFun [a] a > item = SF f > where f (x:xs) = (x,xs) > > peekitem :: StFun [a] a > peekitem = SF f > where f ys@(x:xs) = (x, ys) > > entropy :: StFun String String > entropy = SF f > where f ys@('\xFF':'\x00':xs) = let (as,bs) = f xs in ('\xFF':as,bs) > f ys@('\xFF': _ ) = ([],ys) > f ( x :xs) = let (as,bs) = f xs in (x:as,bs) > ---------------------------------------------- -- Auxiliary State Functions ---------------------------------------------- The Gofer version here used monad comprehensions, which I think aren't legitimate Haskell. I think the result still looks OK. > byte :: StFun String Int > byte = do > c <- item > return (ord c) > > word :: StFun String Int > word = do > a <- byte > b <- byte > return (a*256+b) > > nibbles :: StFun String (Int,Int) > nibbles = do > a <- byte > return (byte2nibs a) > ---------------------------------------------- -- State Function Combinators ---------------------------------------------- > -- list :: [StFun s r] -> StFun s [r] > list :: Monad m => [m a] -> m [a] > list [] = return [] > list (f:fs) = do > x<-f > xs<-list fs > return (x:xs) > > exactly :: Monad m => Int -> m a -> m [a] > exactly 0 f = return [] > exactly (n+1) f = do > x<-f > xs<-exactly n f > return (x:xs) > > matrix :: Monad m => Dim -> m a -> m (Mat a) > matrix (y,x) = exactly y . exactly x > > -- many :: Monad (StFun [a]) => StFun [a] b -> StFun [a] [b] > many f = do b <- empty > y <- f > ys <- many f > return (if b then [] else y:ys) > > sf'uncur :: (b -> StFun a (b,c)) -> StFun (a,b) c > sf'uncur f = SF h > where h (a,b) = (c, (a',b')) > where SF g = f b > ((b',c),a') = g a > > sf'curry :: StFun (a,b) c -> b -> StFun a (b,c) > sf'curry (SF h) = f > where f b = SF g > where g a = ((b',c),a') > where (c,(a',b')) = h (a,b) ---------------------------------------------- -- Huffman Trees ---------------------------------------------- > -- build :: Monad (StFun [(a,Int)]) => Int -> StFun [(a,Int)] (Tree a) > build n = do > b <- empty > (_,s) <- peekitem > t <- if n==s > then > do > (v,_) <- item > return (Tip v) > else > do > x <- build (n+1) > y <- build (n+1) > return (Bin x y) > return (if b then Nil else t) {- build :: Monad (StFun [(a,Int)]) => Int -> StFun [(a,Int)] (Tree a) build n = [ res | b <- empty , res <- if b then return Nil else [ t | (_,s) <- peekitem , t <- if n==s then [Tip v | (v,_) <- item] else [Bin x y | x <- build (n+1), y <- build (n+1)] ] ] -} > -- huffmanTree :: Monad (StFun [(a,Int)]) => [[a]] -> Tree a > huffmanTree = st'apply (build 0) . concat . zipWith f [1..16] > where f s = fmap (\v->(v,s)) > tree_lookup :: Tree a -> StFun Bits a > tree_lookup (Tip x) = return x > tree_lookup (Bin lef rit) = do > b <- item > x <- tree_lookup (if b then rit else lef) > return x > > receive :: Int -> StFun Bits Int > receive 0 = return 0 > receive (k+1) = do > n <- receive k > b <- item > return (2*n + (if b then 1 else 0)) > > dcdecode :: Tree Int -> StFun Bits Int > dcdecode t = do > s <- tree_lookup t > v <- receive s > return (extend v s) > > > extend v t | t==0 = 0 > | v>=vt = v > | otherwise = v + 1 - 2*vt > where vt = 2^(t-1) > > acdecode :: Tree (Int,Int) -> Int -> StFun Bits [Int] > acdecode t k > = > do > (r,s) <- tree_lookup t > x <- let k' = k + r + 1 > in if r==0&&s==0 > then > do return (replicate (64-k) 0) > else > do > x <- receive s > xs <- if k'>=64 then > do return [] > else acdecode t k' > return (replicate r 0 ++ (extend x s:xs)) > > return x ---------------------------------------------- -- Discrete Cosine Transform ---------------------------------------------- > idct1 :: [Float] -> [Float] > idct1 = matapply cosinuses > > idct2 :: Mat Float -> Mat Float > idct2 = transpose . fmap idct1 . transpose . fmap idct1 > > cosinuses :: Mat Float > cosinuses = fmap f [1,3..15] > where f x = fmap g [0..7] > where g 0 = 0.5 / sqrt 2.0 > g u = 0.5 * cos(fromIntegral(x*u)*(pi/16.0)) ---------------------------------------------- -- Dequantization and Upsampling ---------------------------------------------- > type QuaTab = [Int] > > dequant :: QuaTab -> [Int] -> Mat Int > dequant = matmap truncate `o` idct2 `o` zigzag `o` > fmap fromIntegral `o` zipWith (*) > > upsamp :: Dim -> Mat a -> Mat a > upsamp (1,1) = id > upsamp (x,y) = multi y . fmap (multi x) > > zigzag xs = matmap (xs!!) [[ 0, 1, 5, 6,14,15,27,28] > ,[ 2, 4, 7,13,16,26,29,42] > ,[ 3, 8,12,17,25,30,41,43] > ,[ 9,11,18,24,31,40,44,53] > ,[10,19,23,32,39,45,52,54] > ,[20,22,33,38,46,51,55,60] > ,[21,34,37,47,50,56,59,61] > ,[35,36,48,49,57,58,62,63] > ] > > -- alternative, cheaper in time but more expensive in memory: > zigzag' xs = (transpose . fmap concat . transpose . fst . foldr f e) [1..15] > where e = ([],reverse xs) > f n (rss,xs) = (bs:rss, ys) > where (as,ys) = splitAt (min n (16-n)) xs > rev = if even n then id else reverse > bs = replicate (max (n-8) 0) [] > ++ fmap (:[]) (rev as) > ++ replicate (max (8-n) 0) [] ---------------------------------------------- -- Data decoding ---------------------------------------------- > type DataUnit = Mat Int > type Picture = Mat [Int] > > type DataSpec = (Dim, QuaTab, Tree Int, Tree (Int,Int)) > type MCUSpec = [(Dim, DataSpec)] > > dataunit :: DataSpec -> Int -> StFun Bits (Int,DataUnit) > dataunit (u,q,dc,ac) x = > do > dx <- dcdecode dc > xs <- acdecode ac 1 > return (let y=x+dx in (y,upsamp u (dequant q (y:xs)))) > > units :: Dim -> DataSpec -> StFun (Bits,Int) DataUnit > units dim = fmap matconcat . matrix dim . sf'uncur . dataunit > > units' :: (Dim,DataSpec) -> Int -> StFun Bits (Int,DataUnit) > units' = sf'curry . uncurry units > > mcu :: MCUSpec -> [ Int -> StFun Bits (Int,DataUnit) ] > mcu = fmap units' > > mcu' :: MCUSpec -> [Int] -> [ StFun Bits (Int,DataUnit) ] > mcu' = zipWith ap . mcu > > mcu'' :: MCUSpec -> [Int] -> StFun Bits ([Int],[DataUnit]) > mcu'' = fmap unzip `o` list `o` mcu' > > mcu''' :: MCUSpec -> StFun (Bits,[Int]) Picture > mcu''' = fmap matzip . sf'uncur . mcu'' > > picture :: Dim -> MCUSpec -> StFun (Bits,[Int]) Picture > picture dim = fmap matconcat . matrix dim . mcu''' -- if you prefer one-liners over auxiliary definitions: > pict dim = fmap matconcat > . matrix dim > . fmap matzip > . sf'uncur > . fmap unzip > `o` list > `o` zipWith ap > . fmap (sf'curry . uncurry units) ---------------------------------------------- -- JPEG Header structure ---------------------------------------------- > type FrameCompo = (Int,Dim,Int) > type ScanCompo = (Int,Int,Int) > type QtabCompo = (Int,[Int]) > > type SOF = (Dim,[FrameCompo]) > type DHT = (Int,Int,Tree Int) > type SOS = ([ScanCompo],Bits) > type DQT = [QtabCompo] > type XXX = (Char,String) > > frameCompo = > do > c <- byte > dim <- nibbles > tq <- byte > return (c,dim,tq) > > > scanCompo = > do > cs <- byte > (td,ta) <- nibbles > return (cs,td,ta) > > qtabCompo = > do > (p,id) <- nibbles > qt <- exactly 64 (if p==0 then byte else word) > return (id,qt) > > > sofSeg = do > _ <- word > _ <- byte > y <- word > x <- word > n <- byte > fcs <- exactly n frameCompo > return ((y,x), fcs) > dhtSeg = do > _ <- word > (tc,th) <- nibbles > ns <- exactly 16 byte > v <- list (fmap (flip exactly byte) ns) > return (tc, th, huffmanTree v) > dqtSeg = do > len <- word > qts <- exactly ((len-2)`rem`64) qtabCompo > return qts > > sosSeg = do > _ <- word > n <- byte > scs <- exactly n scanCompo > _ <- byte > _ <- byte > _ <- nibbles > ent <- entropy > return (scs, string2bits ent) > > > segment :: (SOF->a, DHT->a, DQT->a, SOS->a, XXX->a) -> StFun String a > segment (sof,dht,dqt,sos,xxx) = > do > _ <- item > c <- item > s <- case c of > '\xC0' -> fmap sof sofSeg > '\xC4' -> fmap dht dhtSeg > '\xDB' -> fmap dqt dqtSeg > '\xDA' -> fmap sos sosSeg > '\xD8' -> do return (xxx (c,[])) > '\xD9' -> do return (xxx (c,[])) > _ -> do > n <- word > xs <- exactly (n-2) item > return ( xxx (c,xs) ) > return s ---------------------------------------------- -- JPEG Decoder ---------------------------------------------- > type Huf = (Table(Tree Int), Table(Tree (Int,Int))) > type Sof = (Dim, Table(Dim,QuaTab)) > type Qua = Table QuaTab > type State = (Sof,Huf,Qua,Picture) > > segments :: StFun String [State->State] > segments = many (segment (sof,dht,dqt,sos,xxx)) > where sof x s@(a,b,c,d) = (evalSOF x s, b, c, d) > dht x s@(a,b,c,d) = (a, evalDHT x s, c, d) > dqt x s@(a,b,c,d) = (a, b, evalDQT x s, d) > sos x s@(a,b,c,d) = (a, b, c, evalSOS x s) > xxx _ s = s > > errRes :: State > errRes = (error"SOF", error"DHT", error"DQT", error"SOS") > > evalSOF :: SOF -> State -> Sof > evalSOF (dim,xs) (~(_,sof),_,qua,_) = (dim, foldr f sof xs) > where f (i,d,q) = subst i (d,qua q) > > evalDHT :: DHT -> State -> Huf > evalDHT (0,i,tree) (_,~(hdc,hac),_,_) = (subst i tree hdc, hac) > evalDHT (1,i,tree) (_,~(hdc,hac),_,_) = (hdc, subst i (fmap byte2nibs tree) hac) > > evalDQT :: DQT -> State -> Qua > evalDQT xs (_,_,qua,_) = foldr f qua xs > where f (i,q) = subst i q > > evalSOS :: SOS -> State -> Picture > evalSOS (cs,xs) (((y,x),sof),(h0,h1),_,_) > = st'apply thePicture (xs,[0,0,0]) > where thePicture = picture repCount mcuSpec > mcuSpec = fmap f cs > f (id,dc,ac) = (d, (upsCount d, qt, h0 dc, h1 ac)) > where (d,qt) = sof id > repCount = ( ceilDiv y (8*maxy), ceilDiv x (8*maxx) ) > -- upsCount (h,w) = ( maxy/h, maxx/w ) > upsCount (h,w) = ( maxy `div` h, maxx `div` w ) > maxy = maximum ( fmap (fst.fst) mcuSpec ) > maxx = maximum ( fmap (snd.fst) mcuSpec ) > > jpegDecode :: String -> Picture > jpegDecode = pi4 . foldl ap' errRes . st'apply segments > where pi4 (_,_,_,x) = x > ---------------------------------------------- -- Main driver ---------------------------------------------- > yCbCr2rgb :: Mat [Int] -> Mat [Int] > yCbCr2rgb = matmap f > where f = fmap ((+128).( `div` 15)) . matapply [ [15, 0, 24] > , [15, -5,-12] > , [15, 30, 0] > ] > > dst << src = > do > input <- readFile src > writeFile dst ((ppm . yCbCr2rgb . jpegDecode) input) > > main = "example.ppm" << "example.jpg" ---------------------------------------------- -- PPM Creation ---------------------------------------------- > ppm xss = "P6\n# Creator: Haskell JPEG decoder\n" > ++ w ++ " " ++ h ++ "\n255\n" > ++ (fmap (chr.sane) . concat . concat) xss > where -- w = "384" > -- h = "256" > w = show (length (head xss)) > h = show (length xss) > > sane x = (0 `max` x) `min` 255 ---------------------------------------------- -- XPM Creation ---------------------------------------------- > xpm xss = xpmhead xss > ++ concat (fmap xpmpal [0..255]) > ++ concat (fmap xpmline xss) > ++ xpmtail > > xpmhead xss = "/* XPM */\nstatic char *a[] = { \"" ++ w ++ " " ++ h ++ " 256 2\"\n" > where --w = "160" > w = show (length (head xss)) > h = show (length xss) > --h = "80" > > xpmtail = "};\n" > > xpmpal x = ",\"" ++ s ++ " c #" ++ s ++ s ++ s ++ "\"\n" > where s = byte2hex x > > xpmline xs = ",\"" ++ concat(fmap byte2hex xs) ++ "\"\n" > > > nib2hex x | x<10 = chr (x+48) > | otherwise = chr (x+55) > > byte2hex x = [ nib2hex h, nib2hex l ] > where (h,l) = byte2nibs x ---------------------------------------------- -- BMP Creation ---------------------------------------------- > bmp xss = bmphead xss > ++ concat (fmap bmpline xss) > > bmphead :: [[a]] -> String > bmphead xss = (concat . fmap wor ) > ([ 16793, len, 0, 0, 0 ,54, 0, 40 > , 0 , w , 0, h, 0 , 1, 24, 0 ] ++ replicate 11 0) > where w = length (head xss) > h = length xss > len = w*h*3 + 54 > > bmpline :: [[Int]] -> String > bmpline = concat . fmap (fmap chr) > > wor x = [chr (x `div` 256), chr (x`rem`256) ]
_______________________________________________ Glasgow-haskell-bugs mailing list [EMAIL PROTECTED] http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs