{-
This solution has flickering effect;
maybe later modify to use Double buffering mode
or xor drawing mode to draw list of regions.
-}
import Picture
import Draw
import Region
import SOEGraphics hiding (Region)
pictToList :: Picture -> RegionList
pictToList EmptyPic = []
pictToList (Region c r) = [(c, r)]
pictToList (p1 `Over` p2) = pictToList p1 ++ pictToList p2
type RegionList = [(Color, Region)]
redraw :: Window -> RegionList -> IO ()
redraw w regs = do
clearWindow w
sequence_ (map (uncurry (drawRegionInWindow w)) (reverse regs))
mousePress :: Window -> Point -> RegionList -> IO (Maybe RegionList)
mousePress w (x, y) regs = do
let aux (_, r) = r `containsR` (pixelToInch (x-xWin2), pixelToInch (yWin2-y))
case (break aux regs) of
(_, []) -> return Nothing
(top, hit:bot) -> do
let regs' = hit:(top++bot)
redraw w regs'
return (Just regs')
mouseRelease :: Window -> Point -> Point -> RegionList -> IO RegionList
mouseRelease w p0 p1 [] = return []
mouseRelease w p0 p1 ((c, r):rs) = do
let v = getTranslate p0 p1
let regs' = (c, Translate v r):rs
redraw w regs'
return regs'
type Vector = (Float, Float)
getTranslate :: Point -> Point -> Vector
getTranslate (x0, y0) (x1, y1)
= (pixelToInch (x1-x0), pixelToInch (y0-y1)) -- Y axis opposite direction
dragAndDrog :: Window -> Point -> Point -> RegionList -> IO ()
dragAndDrog w p0 p1 [] = return ()
dragAndDrog w p0 p1 ((c, r):rs) = do
let v = getTranslate p0 p1
redraw w ((c, Translate v r):rs)
loop :: Window -> Maybe Point -> RegionList -> IO ()
loop w p regs = do
e <- getWindowEvent w
case p of
Nothing -> ----- not in DnD mode -----
case e of
Key { char = c, isDown = isDown } | isDown && c == ' '
-> return ()
Button { pt = pt, isLeft = isLeft, isDown = isDown }
| isLeft && isDown -> do
regs' <- mousePress w pt regs
case regs' of
Nothing -> loop w p regs
Just (regs'') -> loop w (Just pt) regs''
_ -> loop w p regs
Just p0 -> ----- in DnD mode -----
case e of
Key { char = c, isDown = isDown } | isDown && c == ' '
-> return ()
Button { pt = pt, isLeft = isLeft, isDown = isDown }
| isLeft && not isDown -> do
regs' <- mouseRelease w p0 pt regs
loop w Nothing regs'
MouseMove { pt = pt } -> do
dragAndDrog w p0 pt regs
loop w p regs
_ -> loop w p regs
draw3 :: String -> Picture -> IO ()
draw3 s p = runGraphics $ do
w <- openWindow s (xWin, yWin)
let regs = pictToList p
redraw w regs
loop w Nothing regs
----- test -----
r1, r2, r3, r4 :: Region
r1 = Shape (Rectangle 3 2)
r2 = Shape (Ellipse 1 1.5)
r3 = Shape (RtTriangle 3 2)
r4 = Shape (Polygon [(-2.5, 2.5), (-3, 0), (-1.7, -1), (-1.1, 0.2), (-1.5, 2)])
p1, p2, p3, p4 :: Picture
p1 = Region Red r1
p2 = Region Blue r2
p3 = Region Green r3
p4 = Region Yellow r4
pic :: Picture
pic = foldl Over EmptyPic [p1, p2, p3, p4]
main :: IO ()
main = draw3 "Picture DnD Test" pic
This entry was posted
on Sunday, June 10th, 2007 at 3:28 pm and is filed under Haskell - SOE.
You can follow any responses to this entry through the RSS 2.0 feed.
You can leave a response, or trackback from your own site.