From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 progs/demo/X11/mdraw/mdraw.hs | 83 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)
 create mode 100644 progs/demo/X11/mdraw/mdraw.hs

(limited to 'progs/demo/X11/mdraw/mdraw.hs')

diff --git a/progs/demo/X11/mdraw/mdraw.hs b/progs/demo/X11/mdraw/mdraw.hs
new file mode 100644
index 0000000..c4bb508
--- /dev/null
+++ b/progs/demo/X11/mdraw/mdraw.hs
@@ -0,0 +1,83 @@
+module MDraw where
+
+import Xlib 
+
+mapIO :: (a -> IO b) -> [a] -> IO [b]
+
+mapIO f []     = returnIO []
+mapIO f (x:xs) = f x `thenIO` \ y -> 
+                 mapIO f xs `thenIO` \ ys -> 
+		 returnIO (y:ys)
+
+map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c]
+
+map2IO f [] []         = returnIO []
+map2IO f (x:xs) (z:zs) = f x z `thenIO` \ y -> 
+		         map2IO f xs zs `thenIO` \ ys -> 
+		         returnIO (y:ys)
+
+xGetEventMul              :: XMArray XDisplay -> IO (Int, XEvent)
+xGetEventMul displays = 
+  let n_displays = xMArrayLength displays
+      loop :: Int -> IO (Int, XEvent)
+      loop i = if i == n_displays then loop 0
+               else xMArrayLookup displays i `thenIO` \ display ->
+                    xDisplayForceOutput display `thenIO` \ _ ->
+                    xEventListen display `thenIO` \ n_events ->
+                    if n_events == 0 then loop (i + 1)
+                    else xGetEvent display `thenIO` \ event ->
+                         returnIO (i, event)
+  in loop 0
+
+-- takes a list of host names
+
+mdraw :: [String] -> IO ()
+mdraw hosts =
+  xHandleError (\ (XError msg) -> appendChan stdout msg exit done) $
+  mapIO xOpenDisplay hosts `thenIO` \ displays ->
+  let screens = map (head . xDisplayRoots) displays
+      fg_colors = map xScreenBlackPixel screens
+      bg_colors = map xScreenWhitePixel screens
+      roots = map xScreenRoot screens
+  in
+  map2IO (\ root color -> 
+              xCreateWindow root 
+                            (XRect 100 100 400 400)
+                            [XWinBackground color,
+		             XWinEventMask (XEventMask [XButtonMotion, 
+                                                        XButtonPress])])
+         roots
+         bg_colors 
+  `thenIO` \windows ->
+  mapIO xMapWindow windows `thenIO` \ _ ->
+  map2IO xCreateGcontext 
+        (map XDrawWindow roots) 
+        (map (\ color -> [XGCForeground color]) fg_colors)
+  `thenIO` \ gcontexts ->
+  xMArrayCreate displays `thenIO` \ displayArr ->
+  let
+    handleEvent lasts =
+      xGetEventMul displayArr `thenIO` \ (idx, event) ->
+        let pos = xEventPos event
+	in
+	case (xEventType event) of
+          XButtonPressEvent  -> 
+            xMArrayUpdate lasts idx pos `thenIO` \ () ->
+            handleEvent lasts
+          XMotionNotifyEvent ->
+            xMArrayLookup lasts idx `thenIO` \ last -> 
+            map2IO (\ window gcontext -> xDrawLine (XDrawWindow window) 
+                                                    gcontext 
+                                                    last 
+                                                    pos)
+                   windows
+                   gcontexts
+            `thenIO` \ _ ->
+            xMArrayUpdate lasts idx pos `thenIO` \ () ->
+            handleEvent lasts
+          _                  -> handleEvent lasts
+  in
+  xMArrayCreate (map (\ _ -> XPoint 0 0) hosts) `thenIO` \ lasts ->
+  handleEvent lasts `thenIO` \ _ ->
+  returnIO ()
+
-- 
cgit v1.2.3