[Haskell-cafe] HGL concurrency problems

[Carsten Schultz]

[Cc to the HGL maintainer, I hope that is ok.]

Hallo,

I am trying to use HGL.  My configuration is

Mac OS X 10.6.2 (using X11)
ghc 6.12.1
HGL 3.2.0.2 (via cabal-install)

My program opens a window, draws points and lines, with a considerable
amount of calculation between the lines, and then waits for a key stroke
before exiting.

What happens depends on whether I compile with -threaded or without.

With -threaded:
The programs runs ok, but after a short time stops updating the window,
so that I never see when it has finished.  Moving the mouse over the
window can trigger updates.

Without -threaded:
Similar as in the other, but the program nor only stops updating the
window, it also stops the calculation and sits idle.  Playing with the
mouse can again make it run for a short time.

I attach the program in case that this might help.  I did not try to
extract a minimal example, but the program is short.

Thanks for any help.  I would also like to know if it works on other
platforms/versions.

Carsten


module Main where

{- Calculates the convex hull of a set of points in an inefficient way.
   O(n^3)

  For each `o' on stdout a red line segment should be drawn
 -}

import qualified Graphics.HGL as HGL
import System.Random
import System.IO

nrOfPoints = 10000  -- CONFIGURE HERE

data Point = Point {xc, yc :: Float}

randomPoints :: Int -> IO [Point]

randomPoints n =
    sequence $ replicate n randomPoint
    where randomPoint =
              do phi <- randomRIO (0, 2*pi)
                 r0 <- randomRIO (0,0.48 ** 2)
                 let r = sqrt r0
                 return $ Point (r * cos phi + 0.5) (r * sin phi + 0.5)

boundarySegments :: [Point] -> [(Point, Point)]
boundarySegments ps
    = filter isBoundary (pairs' ps)
      where
      pairs' l = concat [[(a,b), (b,a)] | (a,b) <- pairs l]
      isBoundary s = all (`leftOf` s) ps

leftOf :: Point -> (Point, Point) -> Bool

q `leftOf` (p1,p2)
    = (xc p2-xc p1)*(yc q-yc p1) - (yc p2-yc p1)*(xc q-xc p1) >= 0


pairs :: [a] -> [(a,a)]
pairs [] = []
pairs [x] = []
pairs (x:xs) = [(x,x') | x' <- xs] ++ pairs xs



main :: IO ()
main =
    do
    HGL.runGraphics $
       do
       points <- randomPoints nrOfPoints
       redPen <- HGL.createPen HGL.Solid 1 (HGL.RGB 255 0 0)
       w <- HGL.openWindowEx "hull" Nothing (ww,wh) HGL.Unbuffered Nothing
       drawInWindow w $ sequence_ $ map pt points
       drawInWindow w $ (HGL.selectPen redPen  >> return ())
       sequence_ $ map ((drawInWindow w) . seg)
                     $ boundarySegments points
       drawInWindow w $ HGL.text (0,0) "done"
       putStr "\ndone\n"
       HGL.getKey w
       HGL.closeWindow w
    where
    drawInWindow w a =
        do putStr "o" >> hFlush stdout
           HGL.drawInWindow w a
    ww, wh :: Int
    ww = 400 * 2
    wh = 300 * 2
    wwf = fromIntegral ww
    whf = fromIntegral wh
    xf, yf :: Point -> Float
    xf p = xc p * wwf
    yf p = yc p * whf
    x, y :: Point -> Int
    x = round . xf
    y = round . yf
    pt :: Point -> HGL.Graphic
    pt (Point x y) = HGL.ellipse
                     (round (x*wwf-2),(round(y*whf-2)))
                     (round (x*wwf+2),(round(y*whf+2)))
    seg :: (Point, Point) -> HGL.Graphic
    seg (u,v) = HGL.line (x u, y u)  (x v, y v)