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/draw/draw.hs | 41 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 41 insertions(+)
 create mode 100644 progs/demo/X11/draw/draw.hs

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

diff --git a/progs/demo/X11/draw/draw.hs b/progs/demo/X11/draw/draw.hs
new file mode 100644
index 0000000..1ba68ce
--- /dev/null
+++ b/progs/demo/X11/draw/draw.hs
@@ -0,0 +1,41 @@
+module Draw where
+
+import Xlib 
+
+main = getEnv "DISPLAY" exit (\ host -> draw host)
+
+draw :: String -> IO ()
+draw host =
+  xOpenDisplay host `thenIO` \ display ->
+  let (screen:_) = xDisplayRoots display
+      fg_color = xScreenBlackPixel screen
+      bg_color = xScreenWhitePixel screen
+      root = xScreenRoot screen
+  in
+  xCreateWindow root
+                (XRect 100 100 400 400)
+                [XWinBackground bg_color,
+                 XWinEventMask (XEventMask [XButtonMotion, 
+		                            XButtonPress,
+                                            XKeyPress])] 
+  `thenIO` \window ->
+  xMapWindow window `thenIO` \() ->
+  xCreateGcontext (XDrawWindow root)
+                  [XGCBackground bg_color,
+                   XGCForeground fg_color] `thenIO` \ gcontext ->
+  let
+    handleEvent :: XPoint -> IO ()
+    handleEvent last =
+      xGetEvent display `thenIO` \event ->
+        let pos = xEventPos event
+	in        
+	case (xEventType event) of
+          XButtonPressEvent  -> handleEvent pos
+          XMotionNotifyEvent -> 
+            xDrawLine (XDrawWindow window) gcontext last pos `thenIO` \() ->
+	    handleEvent pos
+          XKeyPressEvent     -> xCloseDisplay display
+          _                  -> handleEvent last
+  in
+  appendChan stdout "Press any key to quit.\n" exit done `thenIO` \ _ ->
+  handleEvent (XPoint 0 0)
-- 
cgit v1.2.3