the impossible happened: splitTyConApp

[Frederik Eaton]

Attaching the file, sorry.

When I comment out line 32:

myXlogyx :: Dom a => FVector a -> FVector a -> FVector a

then the error goes away.

On Sun, Jun 11, 2006 at 05:32:49PM +0100, Frederik Eaton wrote:
> Hi,
> 
> $ ghc -O3 --make LearnBinFactors.hs -package GSL -o lbf
> Chasing modules from: LearnBinFactors.hs
> Compiling Main             ( LearnBinFactors.hs, LearnBinFactors.o )
> ghc-6.4.2: panic! (the `impossible' happened, GHC version 6.4.2):
>         splitTyConApp a{tv a8EX}
> 
> I've attached the program LearnBinFactors.hs.
> 
> The version of the GSL package which it uses can be downloaded from:
> 
> http://ofb.net/~frederik/GSLHaskell2.tar.gz
> 
> Frederik
> 
> -- 
> http://ofb.net/~frederik/
> 

-- 
http://ofb.net/~frederik/
-------------- next part --------------
{-# OPTIONS -fglasgow-exts #-}
module Main where

import Control.Exception
import Debug.Trace
import Random

import Vector

defaults = P {pY=undefined, pNumFactors=8, pMaxSteps=30, pIters=20}

data Params v n d = P {
    pY :: v (n, d),
    pMaxSteps :: Int,
    pIters :: Int,
    pNumFactors :: Int
  }
showParams p = show (pY p, pMaxSteps p, pIters p, pNumFactors p)

data State v d k = S {
    sMu :: v (d, k),
    sSigma2 :: R,
    sPie :: v k
  }
showState s = show (sMu s, sSigma2 s, sPie s)

seqState s = vseq (sMu s) . vseq (sPie s) . seq (sSigma2 s)

but = flip assert

myXlogyx :: Dom a => FVector a -> FVector a -> FVector a
myXlogyx x y = x * log (y/(x +. 1.0e-20))

--mstep :: (Dom n, Dom d, Dom k) => Params FVector n d -> FVector (n,k) -> FVector (k,k) -> State FVector d k
--mstep :: (Dom n, Dom d, Dom k, Vector v R, Num (v (n,k)), Num (v (d,k)), Num (v (n,d)), FracVector v R) => Params v n d -> v (n,k) -> v (k,k) -> State v d k
mstep (p::Params v n d) (es::v(n,k)) (ess::v(k,k)) = (s::State v d k)
    `but` (sigma2 > 0.0)
  where
    s = S {sMu = (mu::v(d,k)), sSigma2 = sigma2, sPie = pie}
    (y::v(n,d)) = pY p
    (mu::v(d,k)) = trans (pinv ess *> (trans es *> y))
--    (mu::v(d,k)) = trans (pinv ess * (trans es *> y))
    sigma2 = (vsumSq y + vsum (mu * (mu *> ess)) - 2 * vsum (es * (y *> mu))) /
        (fromIntegral $ vlen y)
    pie = fromRow $ unif *> es

--meanFieldStep :: (Dom n, Dom d, Dom k) => Params FVector n d -> State FVector d k -> FVector (n,k) -> (FVector (n,k), R, R)
meanFieldStep (p::Params v n d) (s::State v d k) (lambda0::(v (n,k))) =
--    trace ("(d,pieExpr,yExpr,lambda,f)"++show (d,pieExpr,yExpr,lambda,f)) $
    (lambda::v(n,k), f::R, dist::R)
  where
    (mu,sigma2,pie) = (sMu s, sSigma2 s, sPie s)
    y = pY p
    d = fromIntegral $ cols y

    pieExpr = log (pie / (1-pie))
    lambda = byRow $ \ (p::n) ->
        let y_p = getRow y p in
        vectorUpdate (fromRow $ getRow lambda0 p) domain $ \lambda_p' (i::k) ->
          sigm $ (pieExpr ! i) + (1/sigma2) *
          let mu_i = getCol mu i
              mu_ss = vsumSq mu_i / 2
              lambda_p = toRow lambda_p' in
          fromS ((y_p - lambda_p *> trans mu +
              (lambda_p ! (0,i)) .* (trans mu_i)) *> mu_i) - mu_ss
    f = sum $ foreach $ \p ->
        let lp = getRow lambda p
            yp = getRow y p
            f_ = vsum (myXlogyx lp (toRow pie) + myXlogyx (1-lp) (toRow $ 1-pie))
                    - d * log sigma2 / 2
                    - (1/(2*sigma2)) * vsumSq (yp - lp*>(trans mu))
                    - (1/(2*sigma2))*(vsum ((lp-lp**2)*(sumCols (mu*mu))))
                    - (d/2)*log(2*pi)
        in f_
    dist = sqrt $ vsumSq (lambda-lambda0)

--initState :: (Dom k, Dom d) => IO (State FVector d k)
initState () = do -- :: IO (State v d k) = do
    (mu0::v(d,k)) <- randIO
    putStrLn $ "size of mu0: "++(show (rows mu0, cols mu0))
    (sigma2_0::R) <- randomIO >>= (return.(+0.1))
    (pie0::v k) <- randIO
    return $ S {sMu = mu0, sSigma2 = sigma2_0, sPie = pie0}

--learnBinFactors :: (Dom k, Dom d, Dom n) => Params FVector n d -> IO (State FVector d k)
learnBinFactors (p::Params v n d) = do
    s <- initState ()
    doIters p 1 s

--doIters :: (Dom n, Dom d, Dom k) => Params FVector n d -> Int -> State FVector d k -> IO (State FVector d k)
doIters p n s | n >= (pIters p) = return s
doIters (p::Params v n d) (n::Int) (s::State v d k) =
    seqState s $ trace ("EM iteration: "++show n) $ 
--    trace ("s="++showState s) $
    do
    let (mu,sigma2,pie) = (sMu s, sSigma2 s, sPie s)
    (lambda0::v(n,k)) <- randIO
    let (lambda::v(n,k), f) = meanField p s lambda0
    let es = lambda
    let ess = (trans lambda) *> lambda +
                diag (fromRow $ sumCols lambda - sumCols (lambda * lambda))
    let s' = mstep p es ess
    doIters p (n+1) s'

--meanField :: (Dom n, Dom d, Dom k) => Params FVector n d -> State FVector d k -> FVector (n,k) -> (FVector (n,k), R)
meanField (p::Params v n d) (s::State v d k) (lambda0::v(n,k)) =
    let {(lambda, f, n) =
          loopUntil (lambda0, minBound, 0) (\ (lambda, f, n) ->
        let (lambda', f', dist) = meanFieldStep p s lambda
        in
        (if f' < f then
            trace ("F decreased in MeanField step "++show n++" from "++show f++" to "++show f')
         else id) $
        trace ("f="++show f) $
        trace ("dist="++show dist) $
        ((lambda', f', n+1), n+1 < (pMaxSteps p) {- && dist > 1.0e-4 -}))}
    in trace ("meanField took "++show n++" steps") $
    (lambda, f)
  
loopUntil :: a -> (a -> (a,Bool)) -> a
loopUntil x0 f = let (x,cont) = f x0 in
    if cont then loopUntil x f else x

main = do
    readMatrixFile "data.txt" doLearn

doLearn :: forall d n . (Dom n, Dom d) => FVector (n,d) -> IO ()
doLearn y = do
    let p = defaults {pY = y}
    putStrLn $ "(n,d)="++show (rows y, cols y)
    reifyIntegral (pNumFactors p) (\ (_::k_) -> do
        (s :: State v d (L k_)) <-
            learnBinFactors p
        putStrLn $ "mu="++show (sMu s)
        putStrLn $ "pi="++show (sPie s)
        putStrLn $ "sigma2="++show (sSigma2 s)
      )