eval_thunk_selector: strange selectee 29

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
Glasgow-haskell-bugs@xxxxxxxxxxx
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs