home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / X11 / animation / r_display.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  3.1 KB  |  113 lines  |  [TEXT/YHS2]
  1. module R_Display (displaym) where
  2.  
  3. import R_Ptypes
  4. import R_Utility
  5. import Xlib
  6. import R_Constants
  7.  
  8. displaym :: String -> Int -> Movie -> IO ()
  9.  
  10. displaym host n movie =
  11.   let
  12.     movie' = cycle (take n (map (map translatePoly) movie))
  13.   in
  14.   xOpenDisplay host 
  15.   >>= \ display ->
  16.   let (screen:_) = xDisplayRoots display
  17.       fg_color = xScreenBlackPixel screen
  18.       bg_color = xScreenWhitePixel screen
  19.       color_map = xScreenDefaultColormap screen
  20.       getPixels [] = return []
  21.       getPixels (c:cs) = 
  22.         xLookupColor color_map c >>= \ (xc, _) ->
  23.          xAllocColor color_map xc >>= \ (p,_,_) ->
  24.         getPixels cs >>= \ ps ->
  25.         return (p:ps) 
  26.   in
  27.   getPixels (map colorName allColors) 
  28.   >>= \ pixels ->
  29.   let
  30.     lookupPixel c = lookupPixel1 c allColors pixels
  31.  
  32.     lookupPixel1 x []     _      = head pixels
  33.     lookupPixel1 x (c:cs) (p:ps) = 
  34.       if x == c then p
  35.                 else lookupPixel1  x cs ps
  36.     parent = xScreenRoot screen
  37.   in
  38.   xMArrayCreate [lookupPixel i | i <- [0..15]] 
  39.   >>= \ pixelArray ->
  40.   xCreateGcontext (XDrawWindow parent)
  41.                   [XGCBackground bg_color,
  42.                    XGCForeground fg_color]
  43.   >>= \ gcontext ->
  44.   xCreateGcontext (XDrawWindow parent)
  45.                   [XGCBackground bg_color,
  46.                    XGCForeground bg_color] 
  47.   >>= \ blank_gcontext ->
  48.   xCreateWindow parent
  49.                 (XRect 100 100 500 500)
  50.                 [XWinBackground bg_color,
  51.                  XWinEventMask (XEventMask [XButtonPress])] 
  52.   >>= \window ->
  53.   let depth = xDrawableDepth (XDrawWindow window) 
  54.   in
  55.   xCreatePixmap (XSize 500 500) depth (XDrawWindow parent)
  56.   >>= \ pixmap ->
  57.   xMapWindow window 
  58.   >>= \() ->
  59.   let
  60.     dispFrame m = 
  61.       xDrawRectangle (XDrawPixmap pixmap) 
  62.                      blank_gcontext 
  63.              (XRect 0 0 500 500) 
  64.              True 
  65.       >>
  66.       dispPic m 
  67.       >>
  68.       xCopyArea (XDrawPixmap pixmap) gcontext (XRect 0 0 500 500) 
  69.                 (XDrawWindow window) (XPoint 0 0) 
  70.       >>
  71.       xDisplayForceOutput display
  72.  
  73.     dispPic [] = return ()
  74.     dispPic (p:ps) = dispPoly p >> dispPic ps
  75.  
  76.     dispPoly (c, vec) =
  77. --      xLookupColor color_map (colorName c) >>= \ ec ->
  78. --      xAllocColor color_map ec >>= \ p -> 
  79.       xMArrayLookup pixelArray c >>= \p ->
  80.       xUpdateGcontext gcontext [XGCForeground p] >>= \ () ->
  81. --      xSetGcontextForeground gcontext (lookupPixel c) >>= \ () ->
  82.       xDrawLines (XDrawPixmap pixmap) gcontext vec True
  83.  
  84.     untilButton3 (frame:frames) = 
  85.       let 
  86.         action = dispFrame frame >> untilButton3 frames
  87.       in
  88.       xEventListen display >>= \count ->
  89.       if count == 0 then action else
  90.       xGetEvent display >>= \event ->
  91.         case (xEventType event) of
  92.      XButtonPressEvent -> 
  93.        case (xEventCode event) of
  94.          3 -> return ()
  95.          _ -> action
  96.          _                       -> action
  97.   in
  98.   putStr ("Click right button to end.\n") >>
  99.   untilButton3 movie' >>
  100.   xFreePixmap pixmap >>
  101.   xCloseDisplay display
  102.  
  103. type Movie' = [Pic']
  104. type Pic' = [Poly']
  105. type Poly' = (Int, [XPoint])
  106.  
  107. translatePoly :: Poly -> Poly'
  108. translatePoly (c, vs) = (c, flatten_2 vs)
  109.  
  110. flatten_2 []        = []
  111. flatten_2 ((a,b):r) = (XPoint (a `div` 2) (b `div` 2)):(flatten_2 r)
  112.  
  113.