Import to github.

165 files changed, 17571 insertions, 0 deletions

diff --git a/progs/README b/progs/README
new file mode 100644
index 0000000..8b28d8f
--- /dev/null
+++ b/progs/README
@@ -0,0 +1,9 @@
+This directory contains Haskell source code.
+Subdirectories:
+prelude               The prelude used in this system
+tutorial              The online supplement to the Hudak & Fasel tutorial
+demo                  A set of random demo programs
+lib                   Various random extensions
+
+Other programs can be found in the Haskell program library on the
+official Haskell ftp sites.
diff --git a/progs/demo/Calendar.hs b/progs/demo/Calendar.hs
new file mode 100644
index 0000000..fa2e4a4
--- /dev/null
+++ b/progs/demo/Calendar.hs
@@ -0,0 +1,138 @@
+-- This is a modification of the calendar program described in section 4.5
+-- of Bird and Wadler's ``Introduction to functional programming'', with
+-- two ways of printing the calendar ... as in B+W, or like UNIX `cal':
+--
+-- Use from within Yale Haskell:
+--
+--   Main> :l Calendar
+--   Now in module Calendar.
+--   Calendar> @ do cal 1992
+--   Calendar> :e
+--
+--   ... Unix style calendar ...
+--
+--   Calendar> @ do calendar 1992
+--   Calendar> :e
+--
+--   ... Bird and Wadler style calendar ...
+--
+--   Calendar>
+
+module Calendar(cal,calendar) where
+
+infixr 5 `above`, `beside`
+
+do cal year    = appendChan stdout (cal year) exit done
+
+-- Picture handling:
+
+type Picture   =  [[Char]]
+
+height, width :: Picture -> Int
+height p       = length p
+width  p       = length (head p)
+
+above, beside :: Picture -> Picture -> Picture
+above          = (++)
+beside         = zipWith (++)
+
+stack, spread :: [Picture] -> Picture
+stack          = foldr1 above
+spread         = foldr1 beside
+
+empty         :: (Int,Int) -> Picture
+empty (h,w)    = copy h (copy w ' ')
+
+block, blockT :: Int -> [Picture] -> Picture
+block n        = stack . map spread . group n
+blockT n       = spread . map stack . group n
+
+group         :: Int -> [a] -> [[a]]
+group n []     = []
+group n xs     = take n xs : group n (drop n xs)
+
+lframe        :: (Int,Int) -> Picture -> Picture
+lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
+		 where h = height p
+                       w = width p
+
+-- Information about the months in a year:
+
+monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
+                    where feb | leap year = 29
+                              | otherwise = 28
+
+leap year         = if year`mod`100 == 0 then year`mod`400 == 0
+                                         else year`mod`4   == 0
+
+monthNames        = ["January","February","March","April",
+		     "May","June","July","August",
+		     "September","October","November","December"]
+
+jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
+                    where last = year - 1
+
+firstDays year    = take 12
+                         (map (`mod`7)
+                              (scanl (+) (jan1st year) (monthLengths year)))
+
+-- Producing the information necessary for one month:
+
+dates fd ml = map (date ml) [1-fd..42-fd]
+              where date ml d | d<1 || ml<d  = ["   "]
+                              | otherwise    = [rjustify 3 (show d)]
+
+-- The original B+W calendar:
+
+calendar :: Int -> String
+calendar  = unlines . block 3 . map picture . months
+            where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
+                  title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
+                  table fd ml    = lframe (8,25)
+                                          (daynames `beside` entries fd ml)
+                  daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
+                  entries fd ml  = blockT 7 (dates fd ml)
+                  months year    = zip4 monthNames
+                                        (copy 12 year)
+                                        (firstDays year)
+                                        (monthLengths year)
+
+-- In a format somewhat closer to UNIX cal:
+
+cal     :: Int -> String
+cal year = unlines (banner year `above` body year)
+           where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
+                 body           = block 3 . map (pad . pic) . months
+                 pic (mn,fd,ml) = title mn `above` table fd ml
+                 pad p          = (side`beside`p`beside`side)`above`end
+                 side           = empty (8,2)
+                 end            = empty (1,25)
+                 title mn       = [cjustify 21 mn]
+                 table fd ml    = daynames `above` entries fd ml
+                 daynames       = [" Su Mo Tu We Th Fr Sa"]
+                 entries fd ml  = block 7 (dates fd ml)
+                 months year    = zip3 monthNames
+                                       (firstDays year)
+                                       (monthLengths year)
+
+-- Additional (B+W)-isms: these really ought to go in a separate module,
+-- in a spearate file.  But for ease of packaging this simple application,
+-- it doesn't seem worth the trouble!
+
+copy    :: Int -> a -> [a]
+copy n x = take n (repeat x)
+
+space   :: Int -> String
+space n  = copy n ' '
+
+-- Simple string formatting:
+
+cjustify, ljustify, rjustify :: Int -> String -> String
+ 
+cjustify n s = space halfm ++ s ++ space (m - halfm)
+               where m     = n - length s
+                     halfm = m `div` 2
+ljustify n s = s ++ space (n - length s)
+rjustify n s = space (n - length s) ++ s
+ 
+-- End of calendar program
diff --git a/progs/demo/README b/progs/demo/README
new file mode 100644
index 0000000..4a683cd
--- /dev/null
+++ b/progs/demo/README
@@ -0,0 +1,15 @@
+
+This directory contains Haskell demo programs.  All of these programs
+compile and execute properly.
+
+This directory contains:
+
+
+fact.hs			factorial
+merge.hs		merge sort	
+pfac.hs			parallel factorial
+primes.hs		prime number generator
+qs.hs			quick sort
+queens.hs               N queens
+symalg/                 A symbolic algebra program
+prolog/                 A prolog interpreter
diff --git a/progs/demo/X11/animation/README b/progs/demo/X11/animation/README
new file mode 100644
index 0000000..c14b867
--- /dev/null
+++ b/progs/demo/X11/animation/README
@@ -0,0 +1,22 @@
+In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya 
+proposes an approach to animation that uses functional languages. As
+Arya describes, the cost of computing power is falling. This is making
+the use of computer animation much more prevalent. However, languages
+such as C make it difficult to program animations. What is needed is
+a simpler, faster and more accessible way to program graphics. Functional
+languages are a very effective means for this, due to their higher order
+functions.
+ 
+	Kevi Arya goes on to provide such a functional animation package in
+the language Miranda. Haskell in particular is good functional language for
+two reasons. It is a completely functional language, doing even I/O in a 
+functional manner. Variables are evaluated in a lazy manner allowing infinite 
+lists to be manipulated easily, which suits the infinite frames format
+of animation.
+
+The following animations are provided here:
+
+  seaside.hs  - a seaside scene
+  planets.hs  - planets in orbit
+  palm.hs     - another seaside scene
+  birds.hs    - flying birds
diff --git a/progs/demo/X11/animation/animation.hs b/progs/demo/X11/animation/animation.hs
new file mode 100644
index 0000000..3c0750c
--- /dev/null
+++ b/progs/demo/X11/animation/animation.hs
@@ -0,0 +1,16 @@
+-- This bundles all the animation stuff into a single module.
+
+module Animation(R_Ptypes..,R_Constants..,R_Utility..,R_Picture..,R_Behaviour..,
+                 R_Movie..,R_Shapes..,R_Defaults..,R_Inbetween..,
+                 R_Display..) where
+import R_Ptypes
+import R_Constants
+import R_Utility
+import R_Picture
+import R_Behaviour
+import R_Movie
+import R_Shapes
+import R_Defaults
+import R_Inbetween
+import R_Display
+
diff --git a/progs/demo/X11/animation/animation.hu b/progs/demo/X11/animation/animation.hu
new file mode 100644
index 0000000..0dd71ee
--- /dev/null
+++ b/progs/demo/X11/animation/animation.hu
@@ -0,0 +1,6 @@
+animation.hs
+r_movie.hu
+r_defaults.hu
+r_shapes.hu
+r_inbetween.hu
+r_display.hu
diff --git a/progs/demo/X11/animation/birds.hs b/progs/demo/X11/animation/birds.hs
new file mode 100644
index 0000000..daba730
--- /dev/null
+++ b/progs/demo/X11/animation/birds.hs
@@ -0,0 +1,28 @@
+module Birds where
+
+import Animation
+
+bird :: Movie
+--bird = osc [bird1,bird2]
+bird = rOVERLAY
+         [apply (bPar [right,right,right,right]) bm1,
+          apply (bPar [up,right,right,right]) bm2]
+         where bm1 = osc [bird1]
+               bm2 = osc [bird2]
+
+bird1 = [(black,b1)]
+        where b1 = [(0,90),(20,100),(30,110),(40,110),(50,100),(110,120),
+                    (130,100),(120,90),(80,90),(0,90),
+                    (80,90),(90,70),(140,50),(120,90),(80,90),
+                    (80,90),(70,70),(80,60),(90,70)]
+
+bird2 = [(red,b2)]
+        where b2 = [(0,60),(20,70),(30,80),(40,80),(50,70),(110,70),
+                    (140,30),(110,35),(100,35),(70,50),(50,60),(0,60),
+	            (70,50),(100,90),(150,100),(120,60),(110,35),
+                    (70,50),(65,100),(85,115),(97,86)]
+
+main = getEnv "DISPLAY" exit 
+       (\ host -> displaym host 30 bird)
+
+
diff --git a/progs/demo/X11/animation/birds.hu b/progs/demo/X11/animation/birds.hu
new file mode 100644
index 0000000..cd94b30
--- /dev/null
+++ b/progs/demo/X11/animation/birds.hu
@@ -0,0 +1,3 @@
+:o= all
+birds.hs
+animation.hu
diff --git a/progs/demo/X11/animation/doc.tex b/progs/demo/X11/animation/doc.tex
new file mode 100644
index 0000000..1b66751
--- /dev/null
+++ b/progs/demo/X11/animation/doc.tex
@@ -0,0 +1,578 @@
+
+%  This is obsolete regarding the X system  -- jcp
+
+% -*-latex-*-
+% Creator: John Tinmouth
+% Creation Date: Thu May 9 1991
+\documentstyle[11pt]{article}
+\newcommand{\X}[1]{{#1}\index{{#1}}}
+\begin{document}
+
+\title{A Functional Animation Package in Haskell}
+\author{
+        John Tinmouth\\
+        Computer Science Senior Project\\
+         Yale University\\
+         Professor Paul Hudak }
+\date{9 May 1991}
+\maketitle
+
+
+
+\section{Introduction}
+
+  	In his paper "A Functional Animation Starter Kit" [ARYA88], Kevi Arya 
+proposes an approach to animation that uses functional languages. As
+Arya describes, the cost of computing power is falling. This is making
+the use of computer animation much more prevalent. However, languages
+such as C make it difficult to program animations. What is needed is
+a simpler, faster and more accessible way to program graphics. Functional
+languages are a very effective means for this, due to their higher order
+functions.
+ 
+	Kevi Arya goes on to provide such a functional animation package in
+the language Miranda. Haskell in particular is good functional language for
+two reasons. It is a completely functional language, doing even I/O in a 
+functional manner. Variables are evaluated in a lazy manner allowing infinite 
+lists to be manipulated easily, which suits the infinite frames format
+of animation. As it is now possible to complete the implementation of
+this package is Haskell, my work has been converting these Miranda programs
+to Haskell version 1.0-0, Yale Haskell Group. 
+
+
+  
+\section{How to Use the Graphics:  Overview}
+
+  By using higher order functions, it becomes very easy to do rapid 
+prototyping of animations. You can quickly throw out an animation of
+simple images manipulated in simple ways. For example, if there was
+an image of a car, and you wanted it to move left, you could almost 
+just describe it in english, and that would be the animation.
+\begin{verbatim}
+     movie = apply left car
+\end{verbatim}
+
+	After the simple model is done, converting it to a more complex model
+is simple. Simply make the image, "car" in this case, more complex, and
+then modify the "left" function, and you are done.
+
+	There are three stages in making a movie. First of all, you must
+define your basic images. These will tend to be Pics put into lists, either
+finite or infinite, to be basic Movies. Second, you decide precisely
+what kind of motion you want in animation. These are behaviours. A behaviour
+modifies a movie over time, changing each successive frame. This includes
+motion, changing size, changing from one image to another and so forth. These 
+are applied to your basic Movies. Third, you must combine your basic Movies
+into your final Movie. If you want a scene of clouds and a man walking, you
+must overlay your basic Movie of clouds with your Movie of a walking man.
+
+\section {Original Images or Pics}
+
+	A Movie is a list of frames called Pics. Each of these Pics is a list 
+of colored polygons. The Pic is a Color followed by a list of Vectors, 
+representing the vertices of the Polygon. The original Pic usually must
+be entered by hand, although simple generation routines for boxes, 
+triangles and circles are available. You need to produce some of these
+basic images in one way or another, so that you have something to 
+manipulate.
+
+	To make a Movie, you need a list of these Pics. With a single Pic, you
+can generate a sequence of that Pic. With several Pics, you can oscillate
+through the Pics in an inifinite list. To generate an infinite list of
+Pics of p1, define a Movie, m1 = i p1. 
+  The following datatypes are used in this package:
+
+\begin{verbatim}
+type Vec	= (Int,Int)
+type Color	= Int
+type Poly	= (Color,[Vec])
+type Pic 	= [Poly]
+type Movie	= [Pic]
+type Behaviour	= [Pic -> Pic]
+\end{verbatim}
+
+
+\subsection {Modifying Pics}
+
+  Starting with a single Pic, it is possible to create a short list of
+Pics to oscillate on. You can flip it, scale it, or otherwise modify the
+original Pic (p1) in some way to create another Pic (p2). You can either
+keep doing this and produce N images for a Movie of [p1,p2,...,pN], or use
+the interpolation functions available to shift from p1 to p2 in N frames,
+resulting in a Movie [p1,interp1,interp2,...,interpN-2,p2].
+  The list of specific Pic-to-Pic functions is included in the next section,
+along with short explanations of what they do.
+
+\subsection {Pic-to-Pic Functions Available}
+
+\begin{verbatim}
+overlay_Pic     Args: Pic Pic 
+                This takes 2 Pics and just puts them together into one Pic.
+                module: R_Picture
+
+put_Pic	        Args: Vec Pic Pic
+                This overlays the two Pics, putting Pic-1's center the Vec 
+                distance away from Pic-2's center.
+                module: R_Picture
+
+over_Pic        Args: Pic Pic
+                This puts two images on top of one another, explicitly 
+                centering the first on top of the second and forms one Pic.
+                module: R_Picture
+                
+above_Pic       Args: Pic Pic
+                This puts the first Pic above the second Pic, at a distance
+                of half the combined heights of the Pics and overlays them
+                to form one Pic.
+                module: R_Picture
+
+beside_Pic      Args: Pic Pic
+                This puts the first Pic to the right of the second Pic, at
+                a distance of half the combined widths of the Pics and 
+                overlays them to form one Pic.
+                module: R_Picture
+
+beside2_Pic     Args: Pic Pic
+                Withouth analysing the widths of the Pics, it puts the
+                first Pic the width of the second Pic to the right and
+                overlays them to form one Pic.
+                module: R_Picture
+
+scale_Pic       Args: Int Pic 
+                This scales the picture in elevenths around its own origin
+                and returns that Pic. So if the Int is 22, the Pic will
+                scaled by a factor of 2 (22/11).
+                module: R_Picture
+
+scale_rel_Pic   Args: Vev Int Pic
+                This is another scaling function, but it scales the image
+                from the Vec, treating it as the origin. 
+                module: R_Picture
+
+mov_Pic         Args: Vec Pic
+                This moves the Pic by the amount of the vector.  
+                module: R_Picture
+
+movto_Pic       Args: Vec Pic
+                This moves the Pic's center to the Vec.
+                module: R_Picture
+
+to_orig         Args: Pic
+                This moves the Pic's center to the lower,left side of
+                the Pic. 
+                module: R_Picture
+
+rot_Pic         Args: Vec Float Pic
+                This rotates the Pic by the Float in radians, using the Vec
+                as the origin of rotation.
+                module: R_Picture
+
+twist_Pic       Args: Float Pic
+                This rotates the Pic by the Float amount of radians around
+                its own center. 
+                module: R_Picture
+
+rot_Pic'        Args: Vec Pic
+                This rotates the Pic by a certain amount (set in R_Constants)
+                using the Vec as the center of rotation. The set amount of
+                rotation makes it faster than rot_Pic.
+                module: R_Picture
+
+twist_Pic'      Args: Pic
+                This rotates the Pic by a certain amoutn (set in R_Constants)
+                around the Pic's origin. The set amount of rotation makes
+                it faster than twist_Pic.
+                module: R_Picture
+
+flipx_Pic       Args: Int Pic
+                This flips the Pic around the line x=Int, essentially giving
+                a mirror image of the Pic, reversing right and left.
+                module: R_Picture
+
+
+flipy_Pic       Args: Int Pic
+                This flips the Pic around the line y=Int, mirror-imaging the
+                Pic, reversing up and down.
+                module: R_Picture
+
+flip_Pic        Args: Pic
+                This flips the Pic around its own x-origin, reversing
+                left and right. 
+                module: R_Picture
+
+flock_Pic       Args: Int Pic
+                This takes the image Pic and copies it out Int*Int times in
+                a Int by Int grid pattern, and returns that as an Pic.
+                module: R_Picture
+
+set_Color       Args: Int Pic
+                This takes an Int standing for a color, and changes the
+                color of the Pic to that.
+                module: R_Picture 
+\end{verbatim}
+
+\subsection{Other Functions for Manipulating Pics}
+
+\begin{verbatim}
+i               Args: Any		
+                This will take anything and return an infinite stream of them.
+                module: R_Utility
+
+osc             Args: [Any]
+                This will take a Movie, which is a list of Pics and 
+                oscillate them. 
+                    [p1]           will give [p1,p1,p1,p1....]
+                    [p1,p2,p3,p4]  will give [p1,p2,p3,p4,p3,p2,p1,p2...]
+                module: R_Utility
+\end{verbatim}
+
+\section{Behaviours and their Application to Movies}
+
+	A Behaviour is a list of functions that will convert one Pic to
+another Pic. This list then can be applied to any Movie with one
+of the application functions (most often apply). The beauty of the Behaviour
+is that once you have a behaviour for moving left, you can move any
+Movie left without rewriting the routine every time.
+  
+	There are specific functions that take a Behaviour and a Movie and
+return a new Movie. These are apply and while. If you had a Movie of a
+man walking in place, and a Behaviour called left that moves Pics ever
+increasing distances left, then you could create a man walking left by:
+\begin{verbatim}
+        apply left man
+\end{verbatim}
+
+	If you want to apply more than one Behaviour to a Movie, you must first
+decide whether to do that in sequence or in parallel, and use bSeq and bPar
+to reduce the list of Behaviours to a single Behaviour, and then apply
+that to a movie. For example:
+\begin{verbatim}
+        apply (bPar left up) gull
+\end{verbatim}
+will take a Movie of a gull and move the Pics up and left.
+
+	Most of the basic Behaviours are defined in R\_Behaviour. 
+
+    
+\subsection{Defining Customized Packages of Behaviours}
+
+	Often you will have more specialized, or just simpler Behaviours you
+want to use. Using the Behaviours and Pic-to-Pic functions, it is very
+easy to create your own small library of Behaviours. R\_Defaults is a
+module of such Behaviours. For example, to create a Behaviour to move
+a Movie right, you  would create a list of mov\_Pic's, each taking a
+everincreasingly large x-coordinate.
+\begin{verbatim}
+        right = [ mov_Pic (x,y) | (x,y) <- zip [0,10,..] [0,..] ] 
+\end{verbatim}
+
+	Or if you wanted a behavour to place a Movie at (100,100) twice as
+large as before, you could create a new Behaviour from old ones as:
+    scaleat= bPar [movto (i (100,100)), scale (i 22)]
+
+\subsection{Behaviours Available}
+\begin{verbatim}
+flip            Args: none
+                This will flip every Pic around its x-origin, resulting in
+                mirror images reversing left and right.
+                module: R_Behaviour
+ 		
+twist'          Args: none
+                This will rotate each Pic by the amount rotunit (see 
+                R_Constants) around its origin.
+                module: R_Behaviour
+
+mov             Args: [Vec]
+                This will move each Pic by its corresponding vector.
+                module: R_Behaviour
+
+movto           Args: [Vec]
+                This will move each Pic's origin to its corresponding vector.
+                module: R_Behaviour
+
+circ_mov        Args: Float Float
+                This will move each Pic in a circle, of radius of the first
+                Float and by an increment of the second Float, using (0,0)
+                as the origin of rotation.
+                module: R_Behaviour
+
+scale           Args: [Int]
+                Scales every Pic on its origin by the the corresponding Int
+                in the list. These Ints represents elevenths, so that a 
+                [2,2,...] will scale every Pic by 2/11 .
+                module: R_Behaviour
+
+scale_rel       Args: Vec [Int]	
+                Same as scale, except that the Pics are all scaled using the
+                Vec as the point of origin.
+                module: R_Behaviour
+
+twist           Args: [Float]
+                This will rotate every Pic by its corresponding Float from
+                the list in radians.
+                module: R_Behaviour
+
+set_color       Args: [Int]
+                This sets each Pic to the color indicated by its 
+                corresponding int in the list.
+                module: R_Behaviour
+	
+rot             Args: [Vec] [Float]
+                This will rotate each Pic around its corresponding Vec by
+                its corresponding Float in radians.
+                module: R_Behaviour
+
+big             Args: none
+                Scales every Pic up by scaleunit
+                module: R_Defaults
+
+huge            Args: none
+                This scales every Pic up by 2*scaleunit
+                module: R_Defaults
+
+small           Args: none
+                This scales every Pic down by 10/11
+                module: R_Defaults
+
+tiny            Args: none
+                This scale every Pic down by 5/11
+                module: R_Defaults
+
+bigger          Args: none
+                This scales every Pic in the list by scaleunit more 
+                than the previous Pic, so that the n-th element is
+                scaled up by (n-1)*scaleunit 
+                module: R_Defaults
+
+smaller         Args: none
+                This scales every Pic down, so that the n-th element
+		is scaled down by (n-1)*(10/11)
+                module: R_Defaults
+
+ccw             Args: none
+                This rotates every Pic by one rotunit more than the
+                previous Pic, in a counterclockwise fashion.
+                module: R_Defaults
+
+cw              Args: none
+                This rotates every Pic by one rotunit more than the
+                previous Pic, in a clockwise fashion.
+                module: R_Defaults
+
+up              Args: none
+                This moves every Pic up by one unit more than the 
+                Previous Pic, so that the n-th element is moved up 
+                (n-1) units.
+                module: R_Defaults
+
+down            Args: none
+                This is same as up, but the Pics move down.
+                module: R_Defaults
+
+right           Args: none
+                This is same as up, but the Pics move right.
+                module: R_Defaults
+
+left            Args: none
+                This is same as up, but the Pics move left.
+                module: R_Defaults
+\end{verbatim}
+
+\subsection{Functions For Behaviours}
+
+\begin{verbatim}
+do              Args: Int Behaviour
+                This takes the first Int elements of the Behaviour and
+                return that.
+                module: R_Behaviour
+
+rpt             Args: Int Behaviour
+                This takes an Int and returns a Behaviour of length Int.
+                However, the n-th Pic-to-Pic in the Behaviour returned
+                is made up of the first through (n-1)the Pic-to-Pics of
+                the input list.
+                module: R_Behaviour
+
+forever         Args: Behaviour
+                This makes a finite Behaviour list an infinite one by
+                appending the list to itself endlessly.
+                module: R_Behaviour
+
+apply           Args: Behaviour Movie
+                This takes a Behaviour and applies it to a Movie
+                module: R_Behaviour
+
+while           Args: (Boolean function) Behaviour Movie
+                As long as the Boolean function evaluates true, this 
+                takes a Behaviour and applies it to a Movie. When it
+                evaluates to false, no more Pics are produced and
+                the Movie is cut short there.
+                module: R_Behaviour
+
+bseq            Args: Behaviour Behaviour
+                This takes two Behaviour and creates one Behaviour made
+                up of the two inputs applies in sequence.
+                module: R_Behaviour
+
+bSeq            Args: [Behaviour] Behaviour
+                This takes two Behaviour and creates one Behaviour made
+                up of the two inputs applies in sequence.
+                module: R_Behaviour
+
+bpar            Args: Behaviour Behaviour
+                This takes two Behaviour and creates one Behaviour made
+                up of the two inputs applies in parallel.
+                module: R_Behaviour
+
+bPar            Args: [Behaviour] Behaviour
+                This takes two Behaviour and creates one Behaviour made
+                up of the two inputs applies in parallel.
+                module: R_Behaviour
+\end{verbatim}
+
+\section{Creating the Final Movie}
+
+	Finally, you have your basic Movies made up of Pictures and Behaviours.
+Now you need to combine them into one Movie. The functions that do this
+are found in the module R\_Movie. These functions will take a list of
+Movies and return a single Movie combining all the Movies in the list.
+How they are combined can be controlled to some extent. Usually they are
+just overlayed, but they can be put beside one another, or on top of
+one another, or put a Vec distance apart.
+
+	It is also possible to use a combination of these forms. If you wanted
+to overaly M1 and M2, and then put that beside M3, you would do:
+\begin{verbatim}
+        rBESIDE [M3, rOVERLAY [M1,M2] ]
+\end{verbatim}
+This is acceptable as rOVERLAY will return a single Movie. 
+
+\subsection{Movie Combining Functions}
+
+\begin{verbatim}
+rABOVE          Args: [Movie]
+                Puts all the Movies into one movie, all above one another.
+                module: R_Movie
+
+rBESIDE         Args: [Movie]
+                Puts all the Movies into one movie, all beside one another.
+                module: R_Movie
+
+rBESIDE2        Args: [Movie]
+                Using their absolute coordinates, puts all the Movies
+                beside one another.
+                module: R_Movie
+
+rOVER           Args: [Movie]
+                This lays the Movies on top of one another, centering 
+                each Pic so that they share the same origin.
+                module: R_Movie
+
+rOVERLAY        Args: [Movie]
+                This lays the Movies on top of one another, centering
+                each Pic so that they share the smae origin.
+                module: R_Movie
+
+pUT             Args: [Vec] Movie Movie
+                This takes a list of Vec, and puts each Pic of the
+                first Movie in the location of the corresponding
+                Vec on top of the Pic of the second Movie and
+                returns that list as the new Movie.
+                module: R_Movie
+
+\end{verbatim}
+
+\section{Displaying Your Movie}
+
+	Once you have your function for the Movie defined, you need to output
+it in some way. Currently, this is done by outputting characters to a file and
+running a C Program in X-Windows that displays the contents of the file
+as a graphic in the X system. First of all, you must convert the
+Movie variable to a stream of characters. This is done by running 
+"showm" on the Movie. Be carefull you don't try to convert an infinite list
+into characters as the compiler will take awhile to do this. Instead, take
+a certain number of frames and convert them with "showm".
+\begin{verbatim}
+        man\_vm = rOVERLAY [man,vm]
+        man\_vmstring = showm (take 20 man&vm)
+\end{verbatim}
+  Now that you have this string, you need to write it to disk. The 
+"writetofile" function does this. It takes a characater string(ie [Char] )
+as an argument, and then prompts you for a filename. It then writes the
+string to the filename. So to put man\_vm string into a file:
+\begin{verbatim}
+        main = writetofile man_vmstring
+\end{verbatim}
+and run the program, where you will prompted for the filename. Or you could:
+\begin{verbatim}
+        main = writetofile (showm (take 20 man_vm))
+\end{verbatim}
+to make it more compact.
+
+
+\subsection{Miscellaneous Usefull Functions}
+
+\begin{verbatim}
+inbetween       Args: Int Pic Pic
+                This takes an Int and two Pics and returns a Movie 
+                with Int Pics interpolating between the two Pics.
+                module: R_Inbetween
+
+tween           Args: Int Movie Movie
+                This takes an Int and two Movies and returns one
+                Movie made up of the first Movie, Int number of
+                frames of Pics interpolating between the last
+                Pic of the first Movie and the first Pic of the
+                second Movie, followed by the second Movie
+                module: R_Inbetween
+
+box             Args: Int Int Int
+                This takes 3 Ints, the color, width and height of 
+                the box and returns a Pic of a box
+                module: R_Shapes
+
+tri             Args: Int Vec Vec Vec
+                This takes a color and three vectors and returns a
+                Pic of a triangle of that colour with those vertices.
+                module: R_Shapes
+
+circ            Args: Int Int Int
+                This takes a color, the radius and the number of points
+                around the circle, and returns a circle with origin at
+                (0,0).
+                module: R_Shapes
+\end{verbatim}
+
+\pagebreak
+\large {\bf Appendix:  C Programs to Display on X-Windows}
+\\
+\\
+	The program currently used to run these graphics is called "xcshow".
+This takes one argument, the name of the file to be run. When run
+in X-Windows, it will produce a window with the first Pic. To run it, click
+on the left mouse button inside the window. Clicking again will freeze it.
+This will keep cycling through the file, replaying again when it hits the
+end of the file, until the window is killed.
+
+	There is also "xshow" which is used to run the monochrome Movies, as
+"xcshow" is used to run the color Movies. As this animation package
+only produces color Movies, it isn't too usefull.
+
+
+\pagebreak
+\large {\bf References}
+\\
+\\
+\begin{verbatim}
+[ARYA88] "The Formal Analysis of a Functiona Animation System", Kevi Arya,
+          DPhil,Thesis,Oxford University, Programming Research Group,
+          April 1988
+
+[ARYA89] "Processes In A Functional Animation System", Kevi Arya,IBM
+          T.J. Research Center, 1989 
+
+[HASK90] "Report On The Programming Language Haskell, Version 1.0",
+          YALEU/DCS/RR-777,Yale University,1990
+\end{verbatim}
+
+\end{document}
diff --git a/progs/demo/X11/animation/palm.hs b/progs/demo/X11/animation/palm.hs
new file mode 100644
index 0000000..9deef12
--- /dev/null
+++ b/progs/demo/X11/animation/palm.hs
@@ -0,0 +1,47 @@
+module Palm (main) where
+
+import Animation
+import SeaFigs
+
+main = getEnv "DISPLAY" exit 
+       (\ host -> displaym host 30 trans)
+
+trans :: Movie
+trans = manright++change++gull2
+
+manright::Movie
+manright =  mirrorx (take 10 (apply left man))
+
+gull2::Movie
+gull2 = apply (bPar [right,up,huge,huge,huge,(mov (i (275,0)))])  gull
+
+change::Movie
+change = inbetween 5  manf1 gull1
+              where gull1 = head gull2
+	            manf1 = last manright
+
+
+
+mirrorx :: Movie -> Movie
+mirrorx m = map (flipx_Pic x) m 
+              where (x,_)=orig_Movie m
+               
+
+orig_Movie :: Movie -> Vec
+orig_Movie m = ((x2-x1) `div` 2,(y2-y1) `div` 2)
+                  where x2 = reduce max (map maxx m)
+                        x1 = reduce min (map minx m)
+			y2 = reduce max (map maxy m)
+			y1 = reduce min (map miny m)
+
+maxx :: Pic -> Int
+maxx p = reduce max [x | (c,q) <- p, (x,y) <- q]
+
+minx :: Pic -> Int
+minx p = reduce min [x | (c,q) <- p, (x,y) <- q]
+
+maxy :: Pic -> Int
+maxy p = reduce max [y | (c,q) <- p, (x,y) <- q]
+
+miny :: Pic -> Int
+miny p = reduce min [y | (c,q) <- p, (x,y) <- q]
diff --git a/progs/demo/X11/animation/palm.hu b/progs/demo/X11/animation/palm.hu
new file mode 100644
index 0000000..a86fcb9
--- /dev/null
+++ b/progs/demo/X11/animation/palm.hu
@@ -0,0 +1,3 @@
+:o= all
+palm.hs
+seafigs.hu
diff --git a/progs/demo/X11/animation/planets.hs b/progs/demo/X11/animation/planets.hs
new file mode 100644
index 0000000..38f278a
--- /dev/null
+++ b/progs/demo/X11/animation/planets.hs
@@ -0,0 +1,30 @@
+module Planets (main) where
+
+import Animation
+
+planets:: Float -> Float -> Int -> Int -> Int -> Int -> Movie
+planets i1 i2 r1 r2 c1 c2
+    = rOVERLAY
+       [ apply f1 earth,
+         apply (bpar f1 f2) moon
+       ]
+        where f1 = circ_mov (fromIntegral r1) i1
+              f2 = circ_mov (fromIntegral r2) i2
+              earth = osc [mov_Pic (vplus center (r1,0)) (box c1 30 30)]
+              moon = osc [mov_Pic (vplus center (r1+r2,0)) (box c2 15 15)]
+
+gen a b c d = c :(gen a b (c+b) d)
+
+
+planet_scene:: Movie
+planet_scene = rOVERLAY
+                 [apply (bpar (set_color (i yellow)) (movto (i center))) orb,
+                  planets (pi/40.0) (pi/10.0) 450 80 darkblue lightblue,
+                  planets (pi/20.0) (pi/8.0) 300 50 brown black,
+                  planets (pi/10.0) (pi/4.0) 150 40 green red
+                 ]
+
+orb = osc [circ red 50 10]
+
+main = getEnv "DISPLAY" exit 
+       (\ host -> displaym host 60 planet_scene)
diff --git a/progs/demo/X11/animation/planets.hu b/progs/demo/X11/animation/planets.hu
new file mode 100644
index 0000000..3473372
--- /dev/null
+++ b/progs/demo/X11/animation/planets.hu
@@ -0,0 +1,3 @@
+:o= all
+planets.hs
+animation.hu
diff --git a/progs/demo/X11/animation/r_behaviour.hs b/progs/demo/X11/animation/r_behaviour.hs
new file mode 100644
index 0000000..6f58e3b
--- /dev/null
+++ b/progs/demo/X11/animation/r_behaviour.hs
@@ -0,0 +1,158 @@
+{-**********************************************************************
+  MODULE R_BEHAVIOUR
+
+    This module defines the basic Behaviours available to manipulate
+  Movies. These functions can either be used directly, or used to
+  easily create personnalized Behaviours (see R_Defaults).
+    There are the Behaviours that affect one Movie, which are mov,movto
+  circ_mov,scale,scale_rel,rot,flip and set_color. These change some 
+  aspect of the movie over time.
+    There are functions that combine several movies into one, namely
+  bseq,bSeq,bpar and bPar.
+    Some functions modify the Behaviours. These are do, rpt and forever.
+  They put limits on how long the Behaviour is. 
+    Finally, there are the functions that apply the Behaviours to a Movie.
+  These are apply and while. Apply applies a Behaviour to a Movie until
+  it runs out of Movie or Behaviour. While takes a conditional and
+  applies the Behaviour to it until that condition is fullfilled.
+
+***********************************************************************-}
+
+module R_Behaviour (mov,movto,circ_mov,scale,scale_rel,rot,flipb,
+		    set_color,
+   		    bseq,bSeq,bpar,bPar,
+		    do,rpt,forever,
+		    apply,while )  where
+
+import R_Ptypes
+import R_Utility
+import R_Picture
+
+  -- takes a Pic to Pic and makes an infinite list Behaviour out of it	    
+makeb1 :: (Pic->Pic) -> Behaviour
+makeb1 f = f : makeb1 f
+
+  -- takes a movie and flips it around the x-origin using flip_Pic
+flipb :: Behaviour
+flipb = makeb1 flip_Pic
+
+  -- twist makes twist_Pic into a Behaviour, rotating the image by rotunit
+twist' :: Behaviour
+twist' = makeb1 twist_Pic'
+
+  -- makeb2 makes a Behaviour out of a function that takes a list and a 
+  -- function and outputs a Behaviour.
+makeb2 :: (a->Pic->Pic) -> [a] -> Behaviour
+makeb2 f [] = []
+makeb2 f (v:vs) = f v : makeb2 f vs
+
+  -- mov takes a list of Vec's and applies each Pic-to-Pic in the Behaviour
+  -- list to its corresponding Vec, and gives back a new Behaviour
+mov :: [Vec] ->Behaviour
+mov = makeb2 mov_Pic
+
+  -- movto creates a list of Pic-to-Pic Behaviours that move each Pic to its 
+  -- corresponding Vec
+movto :: [Vec] -> Behaviour
+movto = makeb2 movto_Pic
+
+  -- produces a Behaviour that produces movement in a circle, taking
+  -- the radius and the increment as arguments.
+circ_mov :: Float -> Float -> Behaviour
+circ_mov r inc = mov (map (vmin' (head vs')) vs')
+                    where vs = [ (r*(cos theta),r*(sin theta)) |
+                               theta <- gen inc 0.0  ]
+                          vmin' x y = vmin y x
+                          vs' = map vftov vs
+
+gen :: Float -> Float -> [Float]
+gen b c = c : (gen b (c+b) )
+
+
+  -- scale outputs a list of Pic-to-Pic's that scale according to its 
+  -- corresponding Int in the input list
+scale :: [Int] -> Behaviour
+scale = makeb2 scale_Pic
+
+  -- scale_rel does the same thing, but centers on the lower-left corner of
+  -- the image
+scale_rel :: Vec -> [Int] -> Behaviour
+scale_rel v = makeb2 (scale_rel_Pic v)
+
+  -- twist outputs a list of Behaviours that rotate each pick by its 
+  -- corresponding Float in the list
+twist :: [Float] -> Behaviour
+twist = makeb2 twist_Pic
+
+  -- set_color takes a list of Colors, and returns a list of Pic-to-Pic's
+  -- that change to the corresponding color in the list
+set_color :: [Color] -> Behaviour
+set_color = makeb2 set_Color_Pic
+
+  -- makeb3 takes a function with two inputs, and two input lists and
+  -- returns a behaviour made up of functions with inputs fromt the lists
+makeb3 :: (a->b->Pic->Pic) -> [a] -> [b] -> Behaviour
+makeb3 f [] (p:ps) = []
+makeb3 f (v:vs) [] = []
+makeb3 f (v:vs) (p:ps) = f v p : makeb3 f vs ps
+
+  -- rot produces behaviours rotating by the Float, around the point
+  -- of the Vec, both provided by lists.
+rot :: [Vec] -> [Float] -> Behaviour
+rot = makeb3 rot_Pic
+
+  -- bseq takes two Behaviours and combines them into one, in sequence. 
+  -- It first applies all of the first Behaviour, then all of the second
+bseq :: Behaviour -> Behaviour -> Behaviour
+bseq ps [] = []
+bseq [] qs = []
+bseq ps qs = ps ++ (mapc (last ps) qs)
+
+  -- bSeq takes a list of Behaviour and makes them into one Behaviour, in
+  -- sequence.
+bSeq :: [Behaviour] -> Behaviour
+bSeq = reduce bseq
+
+  -- bpar takes two behaviours and applies them both simultaneously,
+  -- producing a list of Pic-to-Pic's, each one made up of a function
+  -- from the first list combined with a function from the second list
+bpar :: Behaviour -> Behaviour -> Behaviour
+bpar [] (q:qs) = []
+bpar (p:ps) [] = []
+bpar (p:ps) (q:qs) = (p.q):(bpar ps qs)
+
+  -- bPar takes a list of Behaviours and makes them all into one Behaviour,
+  -- in paralell
+bPar :: [Behaviour] -> Behaviour
+bPar = reduce bpar
+
+  -- takes the first n POic-to-Pics in a Behaviour and returns that Behaviour 
+do :: Int -> Behaviour -> Behaviour
+do n f = take n f
+
+  -- applies bseq to the list of behaviours, so that the nth element of
+  -- the returned list has n-1 behaviours in it, applied in sequence
+rpt :: Int -> Behaviour -> Behaviour
+rpt n f = replicate n bseq [] f
+
+  -- takes the behaviour and applies all the behaviours up the nth element
+  -- to the nth element, in an infinite list
+forever :: Behaviour -> Behaviour
+forever f = bseq f (forever f)
+
+  -- takes a behaviour, applies each from to a Pic in a Movie and returns
+  -- the new Movie
+apply :: Behaviour -> Movie -> Movie
+apply [] ms = []
+apply fs [] = []
+apply (f:fs) (m:ms) = (f m):(apply fs ms)
+
+  -- applies the Behaviour to the Movie until the condition is fullfilled,
+  -- then returns the movie to that point
+while :: (Pic -> Bool) -> Behaviour -> Movie -> Movie
+while c [] ms = []
+while c fs [] = []
+while c (f:fs) (m:ms) = if (c m) then ( (f m):(while c fs ms))
+                        else []
+
+
diff --git a/progs/demo/X11/animation/r_behaviour.hu b/progs/demo/X11/animation/r_behaviour.hu
new file mode 100644
index 0000000..afa52bb
--- /dev/null
+++ b/progs/demo/X11/animation/r_behaviour.hu
@@ -0,0 +1,3 @@
+:o= all
+r_behaviour.hs
+r_picture.hu
diff --git a/progs/demo/X11/animation/r_constants.hs b/progs/demo/X11/animation/r_constants.hs
new file mode 100644
index 0000000..f36e3f2
--- /dev/null
+++ b/progs/demo/X11/animation/r_constants.hs
@@ -0,0 +1,129 @@
+{-****************************************************************
+   MODULE R_CONSTANTS
+
+     This module sets up all the constants used in this functional
+   animation package.
+     Defined here are the basic units of movement, scale and rotation.
+   The screen height and width are set, and the various parts of
+   the screen such as the top-middle, lower-left and center are
+   all set. Finally the color values used by xcshow, the c-program
+   that displays the movies in X, are set.
+
+******************************************************************-}
+
+module R_Constants (fps, unit, hf, qt, scaleunit, rotunit,
+                    nullpic, nullseq,
+                    sinunit,cosunit,
+                    screenwid, screenht, botl, leftm, topl, topm, topr,
+                    rightm, botr, botm, center,
+		    white,black,red,green,darkblue,lightblue,brown,yellow,
+		    colorName, allColors
+			) where
+
+import R_Ptypes
+
+  -- units are set. The scaleunit is in 11th, so that the 12 is
+  -- actually 12/11'ths
+fps :: Int
+unit :: Int
+hf :: Int
+qt :: Int
+scaleunit :: Int
+fps = 25
+unit = 15
+hf =  unit `div` 2
+qt =  unit `div`4
+scaleunit = 12
+  --scaleunit is div'ed by 12 later
+
+rotunit :: Float
+rotunit  = pi/18
+sinunit  = sin rotunit
+cosunit  = cos rotunit
+
+
+nullpic :: Pic
+nullpic = []
+nullseq :: Movie
+nullseq= nullpic : [ nullseq2 | nullseq2 <- nullseq]
+
+  -- Screen Parameters
+screenwid :: Int
+screenwid = 800
+screenht :: Int
+screenht  = 800
+
+botl :: Vec
+leftm :: Vec
+topl :: Vec
+topm :: Vec
+topr :: Vec
+rightm :: Vec
+botr :: Vec
+botm :: Vec
+center :: Vec
+
+leftmb :: Vec
+leftmt :: Vec
+topml :: Vec
+topmr :: Vec
+rightmt :: Vec
+rightmb :: Vec
+botml :: Vec
+botmr :: Vec
+
+botl   = ( 0, 0 )
+leftm  = ( 0, screenht `div` 2)
+topl   = ( 0, screenht )
+topm   = ( screenwid `div` 2, screenht )
+topr   = ( screenwid, screenht )
+rightm = ( screenwid, screenht `div` 2 )
+botr   = ( screenwid, 0 )
+botm   = ( screenwid `div` 2, 0 )
+center = ( screenwid `div` 2, screenht `div` 2 )
+
+leftmb  = ( 0, screenht `div` 4 )
+leftmt  = ( 0, (screenht*3) `div` 4 )
+topml   = ( screenwid `div` 4, screenht )
+topmr   = ( (screenwid*3) `div` 4, screenht )
+rightmt = ( screenwid, (screenht*3) `div` 4 )
+rightmb = ( screenwid, screenht `div` 4 )
+botml   = ( screenwid `div` 4, 0 )
+botmr   = ( (screenwid*3) `div` 4, 0 )
+
+  -- Colors values set to names
+
+white :: Color
+white = 1
+black :: Color
+black = 2
+red :: Color
+red = 4
+green :: Color
+green = 6
+darkblue :: Color
+darkblue = 8
+lightblue :: Color
+lightblue = 10
+yellow :: Color
+yellow = 12
+brown :: Color
+brown = 14
+
+colorName :: Color -> String
+colorName 1 = "white"
+colorName 2 = "black"
+colorName 4 = "red"
+colorName 6 = "green"
+colorName 8 = "blue"
+colorName 10 = "lightblue"
+colorName 12 = "yellow"
+colorName 14 = "brown"
+
+allColors :: [Color]
+allColors = [1,2,4,6,8,10,12,14]
+
+
+
+
+
diff --git a/progs/demo/X11/animation/r_constants.hu b/progs/demo/X11/animation/r_constants.hu
new file mode 100644
index 0000000..d61580f
--- /dev/null
+++ b/progs/demo/X11/animation/r_constants.hu
@@ -0,0 +1,3 @@
+:o= all
+r_constants.hs
+r_ptypes.hu
diff --git a/progs/demo/X11/animation/r_curve.hs b/progs/demo/X11/animation/r_curve.hs
new file mode 100644
index 0000000..14d288c
--- /dev/null
+++ b/progs/demo/X11/animation/r_curve.hs
@@ -0,0 +1,60 @@
+{-**************************************************************
+  MODULE R_CURVE
+
+    This module produces sequences of numbers to be used by
+  Behaviours. The sequences used for moving or scaling can
+  be produced here, in either linear sequences or accelerating
+  and decelerating sequences.
+    The acceleration functions produce floats, so the vftov function
+  would have to be used to convert floating point vectors to integer
+  vectors.
+
+***************************************************************-}
+
+module R_Curve(lnr,hold, acc, dec, accdec, decacc) where
+
+import R_Ptypes
+import R_Constants
+import R_Utility
+import R_Picture
+import R_Behaviour
+
+  -- lnr takes the start, finish and the number of intervals and
+  -- produces a linear list of ints going from the start to finish.
+lnr :: Int -> Int -> Int ->[Int]
+lnr start fin n = take n [start,(start+step)..]
+			where step = ((fin-start)`div`(n-1))
+
+  -- hold produces an infinite number of ints starting at v, modified
+  -- by step every time.
+hold :: Int -> Int -> [Int]  
+hold v step  = [v,v+step..]
+
+  -- acc accelerates from 0 to the max in n steps.
+acc :: Int -> Int -> Int -> [Int]
+acc min max n = min:acc' min (max-min) n 1 
+
+acc' ::  Int -> Int -> Int -> Int -> [Int]
+acc' min max n c | (c>n) = []
+acc' min max n c         = (min + (((max*c*c) `div` (n*n)))) 
+                           : (acc' min max n (c+1)) 
+
+
+  -- dec decelerates from the max to 0 in n steps.
+dec :: Int -> Int -> Int -> [Int]
+dec min max n = reverse (acc min max n)
+  
+  -- accdec accelerates from start up to max and back to fin, in an steps
+  -- accelerating and dn steps decelerating
+accdec :: Int -> Int -> Int -> Int -> Int -> [Int]
+accdec start max fin an dn = (acc start max an)++(tail (dec fin max dn))
+
+  -- decacc decelerates from start to min in dn steps and then accelerates
+  -- back up to fin in an more steps
+decacc :: Int -> Int -> Int -> Int -> Int -> [Int]
+decacc start min fin dn an = (dec min start dn)++(tail (acc min fin an))
+
+
+
+
+
diff --git a/progs/demo/X11/animation/r_curve.hu b/progs/demo/X11/animation/r_curve.hu
new file mode 100644
index 0000000..9aa9629
--- /dev/null
+++ b/progs/demo/X11/animation/r_curve.hu
@@ -0,0 +1,3 @@
+:o= all
+r_curve.hs
+r_behaviour.hu
diff --git a/progs/demo/X11/animation/r_defaults.hs b/progs/demo/X11/animation/r_defaults.hs
new file mode 100644
index 0000000..1b7070a
--- /dev/null
+++ b/progs/demo/X11/animation/r_defaults.hs
@@ -0,0 +1,76 @@
+{-****************************************************************
+  MODULE R_DEFAULTS
+
+    This module uses the R_Behaviour module to define convient and
+  easy to use behaviours. These aren't very sophistated, but they
+  can be used to quickly animate a movie. For more sophistated
+  animation, a similiar library of sophistocated personnalized 
+  functions can be created.
+
+******************************************************************-}
+
+module R_Defaults (big, huge, bigger, smaller, ccw, cw, 
+                   up, down, left, right,small,tiny)
+where
+
+import R_Ptypes
+import R_Constants
+import R_Utility
+import R_Picture
+import R_Behaviour
+
+
+  -- big scales everything up by the scaleunit (now 12/11ths)
+big :: Behaviour
+big = [scale_Pic x | x <- [scaleunit,scaleunit..]]
+
+  -- huge scales everything up by twice the scaleunit (24/11ths)
+huge :: Behaviour
+huge= [scale_Pic x | x <- [scaleunit*2,(scaleunit*2)..]]
+  
+  -- small scales everything down by 10/11ths
+small :: Behaviour
+small = [scale_Pic x | x <- [s,s..]]
+        where s = 10
+  
+  -- tiny scales everything down by 5/11ths
+tiny :: Behaviour
+tiny  = [scale_Pic x | x <- [s,s..]]
+        where s = 5
+  
+  -- bigger causes the Pics to be scaled up by 12/11ths,24/11ths,36/11ths
+  -- and so on, everincreasing.
+bigger :: Behaviour
+bigger = [scale_Pic x | x <- (rept (\x -> div (x*scaleunit) 11) 1)]
+  
+  -- smaller causes the Pics to be scaled downwards in ever decreasing 
+  -- amounts.
+smaller :: Behaviour
+smaller = [scale_Pic x | x <- (rept (\x -> div (x*10) 11) 1)]
+  
+  -- a hardwired version of ccw that rotates the Pics by one rotunit
+  -- more every Pic, counterclockwise.
+ccw :: Behaviour
+ccw = [twist_Pic x | x <- [0.0,rotunit..]]
+  
+  -- same as ccw, but rotates the Pics clockwise
+cw :: Behaviour
+cw = [twist_Pic x | x <- [0.0,-rotunit..]]
+  
+  -- moves the Pic up by one more unit every Pic.
+up :: Behaviour
+up    = [mov_Pic (x,y) | (x,y)<- zip2 [0,0..] [0,unit..]]
+
+  -- moves the Pic down by one more unit every Pic.  
+down :: Behaviour
+down  = [mov_Pic (x,y) | (x,y)<-zip2 [0,0..] [0,-unit]] 
+  
+  -- moves the Pic left by one more unit every Pic.
+left :: Behaviour
+left  = [mov_Pic (x,y) | (x,y)<- zip2 [0,-unit..] [0,0..]] 
+  
+  -- moves the Pic right by one more unit every Pic.
+right :: Behaviour
+right = [mov_Pic (x,y) | (x,y)<- zip2 [0,unit..] [0,0..]] 
+  
+
diff --git a/progs/demo/X11/animation/r_defaults.hu b/progs/demo/X11/animation/r_defaults.hu
new file mode 100644
index 0000000..f945bbc
--- /dev/null
+++ b/progs/demo/X11/animation/r_defaults.hu
@@ -0,0 +1,3 @@
+:o= all
+r_defaults.hs
+r_behaviour.hu
diff --git a/progs/demo/X11/animation/r_display.hs b/progs/demo/X11/animation/r_display.hs
new file mode 100644
index 0000000..19f1d4a
--- /dev/null
+++ b/progs/demo/X11/animation/r_display.hs
@@ -0,0 +1,114 @@
+module R_Display (displaym) where
+
+import R_Ptypes
+import R_Utility
+import Xlib
+import R_Constants
+
+displaym :: String -> Int -> Movie -> IO ()
+
+displaym host n movie =
+  let
+    movie' = cycle (take n (map (map translatePoly) movie))
+  in
+  xOpenDisplay host 
+  `thenIO` \ display ->
+  let (screen:_) = xDisplayRoots display
+      fg_color = xScreenBlackPixel screen
+      bg_color = xScreenWhitePixel screen
+      color_map = xScreenDefaultColormap screen
+      getPixels [] = returnIO []
+      getPixels (c:cs) = 
+        xLookupColor color_map c `thenIO` \ (xc, _) ->
+     	xAllocColor color_map xc `thenIO` \ (p,_,_) ->
+        getPixels cs `thenIO` \ ps ->
+        returnIO (p:ps) 
+  in
+  getPixels (map colorName allColors) 
+  `thenIO` \ pixels ->
+  let
+    lookupPixel c = lookupPixel1 c allColors pixels
+
+    lookupPixel1 x []     _      = head pixels
+    lookupPixel1 x (c:cs) (p:ps) = 
+      if x == c then p
+                else lookupPixel1  x cs ps
+    parent = xScreenRoot screen
+  in
+  xMArrayCreate [lookupPixel i | i <- [0..15]] 
+  `thenIO` \ pixelArray ->
+  xCreateGcontext (XDrawWindow parent)
+                  [XGCBackground bg_color,
+                   XGCForeground fg_color]
+  `thenIO` \ gcontext ->
+  xCreateGcontext (XDrawWindow parent)
+                  [XGCBackground bg_color,
+                   XGCForeground bg_color] 
+  `thenIO` \ blank_gcontext ->
+  xCreateWindow parent
+                (XRect 100 100 500 500)
+                [XWinBackground bg_color,
+                 XWinEventMask (XEventMask [XButtonPress])] 
+  `thenIO` \window ->
+  let depth = xDrawableDepth (XDrawWindow window) 
+  in
+  xCreatePixmap (XSize 500 500) depth (XDrawWindow parent)
+  `thenIO` \ pixmap ->
+  xMapWindow window 
+  `thenIO` \() ->
+  let
+    dispFrame m = 
+      xDrawRectangle (XDrawPixmap pixmap) 
+                     blank_gcontext 
+		     (XRect 0 0 500 500) 
+		     True 
+      `thenIO_`
+      dispPic m 
+      `thenIO_`
+      xCopyArea (XDrawPixmap pixmap) gcontext (XRect 0 0 500 500) 
+                (XDrawWindow window) (XPoint 0 0) 
+      `thenIO_`
+      xDisplayForceOutput display
+
+    dispPic [] = returnIO ()
+    dispPic (p:ps) = dispPoly p `thenIO_` dispPic ps
+
+    dispPoly (c, vec) =
+--      xLookupColor color_map (colorName c) `thenIO` \ ec ->
+--      xAllocColor color_map ec `thenIO` \ p -> 
+      xMArrayLookup pixelArray c `thenIO` \p ->
+      xUpdateGcontext gcontext [XGCForeground p] `thenIO` \ () ->
+--      xSetGcontextForeground gcontext (lookupPixel c) `thenIO` \ () ->
+      xDrawLines (XDrawPixmap pixmap) gcontext vec True
+
+    untilButton3 (frame:frames) = 
+      let 
+        action = dispFrame frame `thenIO_` untilButton3 frames
+      in
+      xEventListen display `thenIO` \count ->
+      if count == 0 then action else
+      xGetEvent display `thenIO` \event ->
+        case (xEventType event) of
+	 XButtonPressEvent -> 
+	   case (xEventCode event) of
+	     3 -> returnIO ()
+	     _ -> action
+         _                       -> action
+  in
+  printString ("Click right button to end.\n") `thenIO_`
+  untilButton3 movie' `thenIO_`
+  xFreePixmap pixmap `thenIO_`
+  xCloseDisplay display
+
+type Movie' = [Pic']
+type Pic' = [Poly']
+type Poly' = (Int, [XPoint])
+
+translatePoly :: Poly -> Poly'
+translatePoly (c, vs) = (c, flatten_2 vs)
+
+flatten_2 []        = []
+flatten_2 ((a,b):r) = (XPoint (a `div` 2) (b `div` 2)):(flatten_2 r)
+
+printString :: String -> IO ()
+printString s = appendChan "stdout" s abort (returnIO ())
diff --git a/progs/demo/X11/animation/r_display.hu b/progs/demo/X11/animation/r_display.hu
new file mode 100644
index 0000000..23f2c77
--- /dev/null
+++ b/progs/demo/X11/animation/r_display.hu
@@ -0,0 +1,6 @@
+:o= foldr inline constant
+r_constants.hu
+r_utility.hu
+r_ptypes.hu
+r_display.hs
+$HASKELL_LIBRARY/X11/xlib.hu
diff --git a/progs/demo/X11/animation/r_inbetween.hs b/progs/demo/X11/animation/r_inbetween.hs
new file mode 100644
index 0000000..a7fb7d3
--- /dev/null
+++ b/progs/demo/X11/animation/r_inbetween.hs
@@ -0,0 +1,82 @@
+{-******************************************************************
+  MODULE R_INBETWEEN
+
+    This module takes care of interpolation functions. Basically,
+  given two Pics, inbetween will give you a movie gradually 
+  converting from one Pic to the other Pic, using linear interpolation.
+    Tween will take two Movies, and append them, interpolating n
+  frames between the last Pic of the first Movie and the first Pic of
+  the last Movie.      
+
+******************************************************************-}
+
+module R_Inbetween (inbetween,tween) where
+
+import R_Ptypes
+import R_Utility
+import R_Picture
+import R_Behaviour
+
+  -- inbetween takes an int and two Pics, and interpolates n Pics
+  -- of interpolated Pics. 
+inbetween :: Int -> Pic -> Pic -> Movie
+inbetween n p1 p2 | (length p1 == length p2) = 
+                       ((zip1.(map (inbetweenp n))).zip1) [p1,p2]
+inbetween  n p1 p2       = inbetween n [(col,p1')] [(col,p2')]
+                          where p1' = concat [ vs | (c,vs) <- p1]
+                                p2' = concat [ vs | (c,vs) <- p2]
+                                col = head [ c | (c,vs) <- p1 ]
+                      
+  -- inbetweenp takes a list of 2 Polygons ([[Vec]]) and returns a 
+  -- sequence of interpolated Polygons. Should the Number of vertices 
+  -- of one Polygon be less than those in the other, it splits it so 
+  -- as to have two Polygons of the same length.
+inbetweenp :: Int -> Pic -> Pic
+inbetweenp n  [(c1,vs),(c2,ws)] = 
+   if ((length vs) < (length ws)) then  
+         inbetween1 (split (length ws) (c1,vs)) (c2,ws) 0 n
+   else if ((length vs) > (length ws)) then
+         inbetween1 (c1,vs) (split (length vs) (c2,ws)) 0 n
+   else inbetween1 (c1,vs) (c2,ws) 0 n
+                         
+
+  -- inbetween1 returns a sequence of interpolated Polygons.
+inbetween1 :: Poly -> Poly -> Int -> Int -> Pic
+inbetween1 p1 p2 m n | m>n || n<=0 = []
+inbetween1 p1 p2 m n               = inbetween2 p1 p2 m n 
+                                     :inbetween1 p1 p2 (m+1) n
+
+  -- inbetween2 returns ONE of the required sequence of 
+  -- interpolated Polygons.
+inbetween2 :: Poly -> Poly -> Int -> Int -> Poly
+inbetween2 (c1,vs) (c2,ws) p q = (c1, map (partway p q) (zip1 [vs,ws]))
+          
+  -- split splits up a Polygon so as to have the given #vertices.
+split :: Int -> Poly -> Poly
+split n (c,vs) = (c, split' n vs)
+
+split' :: Int -> [Vec] -> [Vec]
+split' n vs | n<= (length vs) = vs
+split' n vs = if (n>double) then
+                     split' n (split' double vs)
+              else 
+                     v1:(mid v1 v2):(split' (n-2) (v2:vss))
+              where double = 2*((length vs)) - 1
+                    (v1:v2:vss) = vs
+
+                           
+  -- tween will interpolate n Pics transforming the last Pic of
+  -- the first Movie into the first Pic of the second Movie, and
+  -- then run the second Movie    
+tween :: Int -> Movie -> Movie -> Movie         
+tween n m1 []   = m1
+tween n m1 m2  = m1 ++ (inbetween n (last m1) (head m2')) ++ (tail m2')       
+            where m2' = apply (mov (repeat v)) m2 
+                  v = vmin (orig_Pic (last m1)) (orig_Pic (head m2))
+
+  -- tweens will take a list of Movies and append them all, interpolating
+  -- n frames between every Movie.
+tweens :: Int -> [Movie] -> Movie
+tweens n = foldr (tween n) [] 
+
+
diff --git a/progs/demo/X11/animation/r_inbetween.hu b/progs/demo/X11/animation/r_inbetween.hu
new file mode 100644
index 0000000..52771d0
--- /dev/null
+++ b/progs/demo/X11/animation/r_inbetween.hu
@@ -0,0 +1,3 @@
+:o= all
+r_inbetween.hs
+r_behaviour.hu
diff --git a/progs/demo/X11/animation/r_movie.hs b/progs/demo/X11/animation/r_movie.hs
new file mode 100644
index 0000000..a97a452
--- /dev/null
+++ b/progs/demo/X11/animation/r_movie.hs
@@ -0,0 +1,114 @@
+{-*********************************************************************
+  MODULE R_MOVIE
+
+    This module contains necessary functions for editing Movies. There
+  are several that give information on a Movie, such as the heights or
+  wirdths of its Pics. The others all deal with the various ways of
+  combining various Movies into one Movie, a vital set of functions.
+
+*********************************************************************-}
+
+module R_Movie (ht, wid, orig,
+                above, rABOVE, beside, rBESIDE,rBESIDE2, over, rOVER,
+                overlay, rOVERLAY, pUT,
+                uncurry, curry
+                ) where
+
+import R_Ptypes
+import R_Constants
+import R_Utility
+import R_Picture
+
+  -- takes a function and a list and returns a new list of element operated
+  -- on by the function.
+promote:: (a->b)->[a]->[b]
+promote f []     = []
+promote f [p]    = f p:promote f [p]
+promote f (p:ps) = f p:promote f ps
+
+  -- promote1 takes a function that analyzes a Pic, and then applies it
+  -- to analyse a movie, returning a list.
+promote1:: (Pic->a) -> Movie -> [a]
+promote1 f ps = [f p | p <- ps]
+
+  -- ht takes a Movie and returns a list of the heights of the Pics
+ht :: Movie -> [Int]
+ht   = promote1 ht_Pic
+
+  -- wid takes a Movie and returns a list of the widths of the Pics
+wid :: Movie -> [Int]
+wid  = promote1 wid_Pic
+
+  -- orig takes a Movie and returns a list of vectors that are the
+  -- origins of the Pics
+orig:: Movie -> [Vec]
+orig = promote1 orig_Pic
+
+  -- promote2 takes a function accepting an element and a Pic, and
+  -- applies the function to the Movie and list, producing a new Movie
+promote2:: (a->Pic->Pic) -> [a] -> Movie -> Movie
+promote2 f ps qs = [f p q | (p,q) <- zip2 ps qs]
+
+  -- takes two Movies and puts them above one another
+above:: Movie -> Movie -> Movie
+above = promote2 above_Pic
+
+  -- takes a list of Movies and puts them all above one another
+rABOVE:: [Movie] -> Movie
+rABOVE = reduce above
+
+  -- takes two Movies and puts them beside one another
+beside:: Movie -> Movie -> Movie
+beside = promote2 beside_Pic
+
+  -- takes a list of Movies and puts them all beside one another
+rBESIDE:: [Movie] -> Movie
+rBESIDE = reduce beside
+
+  -- same as beside, but with absolute coordinates.
+beside2:: Movie -> Movie -> Movie
+beside2 = promote2 beside2_Pic
+
+  -- same as rBESIDE, but with absolute coordinates.
+rBESIDE2:: [Movie] -> Movie
+rBESIDE2 = reduce beside2
+
+  -- puts one Movie on top of the other Movie
+over:: Movie -> Movie -> Movie
+over = promote2 over_Pic
+
+  -- takes a list of Movies, and puts the n-th on top of the first
+  -- through 9n-1)th.
+rOVER:: [Movie] -> Movie
+rOVER = reduce over
+
+  -- just overlays the two Movies by appending the Pics.
+overlay:: Movie -> Movie -> Movie
+overlay = promote2 overlay_Pic
+
+  -- overlays a list of Movies by appending the Pics
+rOVERLAY:: [Movie] -> Movie
+rOVERLAY = reduce overlay
+
+  -- promote3 takes a function that takes two items and a Pic and 
+  -- returns a Pic, and then applies it to two input lists and a Movie,
+  -- producing a new Movie.
+promote3:: (a->b->Pic->Pic) -> [a] -> [b] -> Movie -> Movie
+promote3 f ps qs rs = [f p q r | (p,q,r) <- zip3 ps qs rs]
+
+  -- pUT takes a list of Vectors, and puts each Pic of the first Movie
+  -- in the location of the corresponding vector, on top  of the Pic of
+  -- the second Movie, and returns that list as a new Movie.
+pUT:: [Vec] -> Movie -> Movie -> Movie
+pUT = promote3 put_Pic
+
+  -- uncurry takes a function that takes two elements and a list of
+  -- two elements and applies the function to them.
+uncurry:: (a->a->b) -> [a] -> b
+uncurry f [a,b] = f a b
+
+  -- curry takes a function that takes a list, and two elements, and
+  -- then applies the function to the elements in a list.
+curry:: ([a]->b) -> a -> a -> b
+curry f a b = f [a,b]
+
diff --git a/progs/demo/X11/animation/r_movie.hu b/progs/demo/X11/animation/r_movie.hu
new file mode 100644
index 0000000..0023a04
--- /dev/null
+++ b/progs/demo/X11/animation/r_movie.hu
@@ -0,0 +1,3 @@
+:o= all
+r_movie.hs
+r_picture.hu
diff --git a/progs/demo/X11/animation/r_picture.hs b/progs/demo/X11/animation/r_picture.hs
new file mode 100644
index 0000000..ed3a50f
--- /dev/null
+++ b/progs/demo/X11/animation/r_picture.hs
@@ -0,0 +1,188 @@
+{-************************************************************
+   MODULE R_PICTURE
+ 
+     This module contains all the functions that can be used to manipulate
+   Pic's. The user will probably never use any of these functions. They
+   are used by Behaviours and such higher-order functions, which apply
+   these routines to all the Pic's in the list.
+     
+*************************************************************-}
+
+module R_Picture (close_Pic, ht_Pic, wid_Pic, orig_Pic,
+                  overlay_Pic, put_Pic, over_Pic, above_Pic, beside_Pic,
+                  map_Pic,beside2_Pic,
+                  scale_Pic, scale_rel_Pic, mov_Pic, rot_Pic, twist_Pic,
+                  twist_Pic', flipx_Pic, flipy_Pic, flip_Pic, {- flock_Pic, -}
+                  set_Color_Pic,
+                  to_orig_Pic,
+		  movto_Pic
+                  ) where
+
+import R_Ptypes
+import R_Constants
+import R_Utility
+
+  -- close_Pic makes sure that the polygon is closed
+close_Pic:: Pic -> Pic
+close_Pic p = map close_Poly p
+              where
+              close_Poly (c,ply) | (head ply) == (last ply) = (c,ply)
+              close_Poly (c,ply)       = (c,ply++(tail (reverse ply)))
+
+  --these functions find the max and min x and y coordinates of a Pic
+maxx :: Pic -> Int
+maxx p = reduce max [x | (c,q) <- p, (x,y) <- q]
+
+minx :: Pic -> Int
+minx p = reduce min [x | (c,q) <- p, (x,y) <- q]
+
+maxy :: Pic -> Int
+maxy p = reduce max [y | (c,q) <- p, (x,y) <- q]
+
+miny :: Pic -> Int
+miny p = reduce min [y | (c,q) <- p, (x,y) <- q]
+
+  -- these functions find the height, width and origin of a Pic
+ht_Pic :: Pic -> Int
+ht_Pic p = (maxy p) - (miny p)
+
+wid_Pic :: Pic -> Int
+wid_Pic p = (maxx p) - (minx p)
+
+orig_Pic:: Pic -> Vec
+orig_Pic p = ( (maxx p + minx p) `div` 2, (maxy p + miny p) `div` 2 )
+
+-- PICTURE COMBINING OPERATIONS:
+  
+  -- overlay_Pic just takes 2 Pics and puts them together into one
+overlay_Pic:: Pic -> Pic -> Pic
+overlay_Pic p q = p ++ q
+
+  -- put_Pic overlays the Pics, offsetting the first Pic by a vector
+  -- amount from the origin of the second
+put_Pic:: Vec -> Pic -> Pic -> Pic
+put_Pic v p q = overlay_Pic
+                     (movto_Pic (vplus (orig_Pic q) v) p )
+                     q
+
+  -- over_Pic puts one Pic directly on top of the other
+over_Pic:: Pic -> Pic -> Pic
+over_Pic p q = put_Pic (0,0) p q
+
+  -- above_Pic puts the first Pic on top of the second
+above_Pic:: Pic -> Pic -> Pic
+above_Pic p q = put_Pic (0,(((ht_Pic q) + (ht_Pic p)) `div` 2)) p q
+
+  -- beside_Pic puts the first Pic beside the second. The width of
+  -- the Pic is defined as the max x minus the min x, so a moving
+  -- figure will stand still in this implementation
+beside_Pic:: Pic -> Pic -> Pic
+beside_Pic p q = put_Pic (((wid_Pic q)+(wid_Pic p)) `div` 2, 0) p q
+
+  -- beside2_Pic puts the first Pic beside the second, without 
+  -- shifting to the width of the Pic. It uses the absolute coordinates.
+beside2_Pic:: Pic -> Pic -> Pic
+beside2_Pic p q = put ((wid_Pic q), 0) p q
+     where put v p q = overlay_Pic (mov_Pic v p) q
+
+
+  -- The following maps a given function over the Vector-list of each Polygon:
+map_Pic:: (Vec -> Vec) -> Pic -> Pic
+map_Pic f p = map f' p
+              where f' (c,vs) = (c, map f vs)
+
+-- THE GEOMETRIC TRANSFORMATIONS:
+
+  -- scales the Pic by r, where r is in units of 11th. ie r=1, the Pic is
+  -- scaled by 1/11 to its origin. 
+scale_Pic :: Int -> Pic -> Pic
+scale_Pic r p
+   = map_Pic (scalep r) p
+     where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
+           dx = fst (orig_Pic p)
+           dy = snd (orig_Pic p)
+
+  -- this is another scaling function, but it centers the image at the Vec
+scale_rel_Pic :: Vec -> Int -> Pic -> Pic
+scale_rel_Pic v r
+   = map_Pic (scalep r)
+     where scalep r (v1,v2) = (div ((r*(v1-dx))+dx) 11,div ((r*(v2-dy))+dy) 11)
+           dx = fst v
+           dy = snd v
+
+  -- moves a Pic by the vector amount
+mov_Pic:: Vec -> Pic -> Pic
+mov_Pic v = map_Pic (vplus v)
+
+  -- moves a Pic to the vector
+movto_Pic:: Vec -> Pic -> Pic
+movto_Pic v p = mov_Pic (vmin v (orig_Pic p)) p
+
+  -- moves the origin of the Pic to the lower left side of the Pic
+to_orig_Pic:: Pic -> Pic
+to_orig_Pic p = mov_Pic (-mx,-my) p
+                where mx = minx p
+                      my = miny p
+
+  -- rotates the Pic about the Vector by theta
+rot_Pic :: Vec -> Float -> Pic -> Pic
+rot_Pic (a,b) theta
+                   = map_Pic  (rotp (a,b) theta)
+                     where rotp (a,b) t (v1,v2)
+                             = vftov (a2+ (u * cos theta - v * sin theta),
+                                      b2+ (u * sin theta + v * cos theta))
+                                where u =  u1 -a2
+                                      v =  u2 -b2
+				      (u1,u2) = vtovf (v1,v2)
+ 				      (a2,b2) = vtovf (a,b)
+
+  -- rotates a Pic about its origin by theta
+twist_Pic :: Float -> Pic -> Pic
+twist_Pic theta p = rot_Pic (orig_Pic p) theta p
+
+
+  -- hardwired version of rot_Pic that runs faster by rotating a set
+  -- unit, the rotunit, every time
+rot_Pic':: Vec -> Pic -> Pic
+rot_Pic' (a,b) = map_Pic (rotp (a,b))
+                 where rotp (a,b) (v1,v2)
+                         = vftov (a2+ (u * cosunit - v * sinunit),
+                                  b2+ (u * sinunit + v * cosunit))
+                            where u = u1-a2
+                                  v = u2-b2
+				  (u1,u2) = vtovf (v1,v2)
+				  (a2,b2) = vtovf (a,b)
+
+  -- hardwired version of twist_Pic that runs faster using rot_Pic'
+twist_Pic':: Pic -> Pic
+twist_Pic' p = rot_Pic' (orig_Pic p) p
+
+  -- flips the Pic about the line x=n (x-coordinates change)
+flipx_Pic :: Int -> Pic -> Pic 
+flipx_Pic n  = map_Pic (flipvx n)
+               where
+               flipvx n (a,b) = (2*(n-a)+a,b)
+
+  -- flips the Pic about the line y=n (y-coordinates change)
+flipy_Pic :: Int -> Pic -> Pic 
+flipy_Pic n = map_Pic (flipvy n)
+              where
+              flipvy n (a,b) = (a, 2*(n-b)+b)
+
+  -- flips the Pic about its own x origin.
+flip_Pic:: Pic -> Pic
+flip_Pic p = map_Pic (flipvx x) p
+             where (x,y) = orig_Pic p
+                   flipvx n (a,b) = (2*(n-a)+a,b)
+
+  -- copies the Pic into another Pic n*n times in an n by n array pattern
+flock_Pic :: Int -> Pic -> Pic
+flock_Pic 1 p = p
+flock_Pic (n+2) p = beside_Pic (flock_Pic (n-1) p) (row n p)
+                    where row n p = replicate n above_Pic nullpic p
+
+  -- changes the color of the Pic
+set_Color_Pic:: Color -> Pic -> Pic
+set_Color_Pic c p = map f p
+                    where f (c',vs) = (c,vs)
+
diff --git a/progs/demo/X11/animation/r_picture.hu b/progs/demo/X11/animation/r_picture.hu
new file mode 100644
index 0000000..932d87c
--- /dev/null
+++ b/progs/demo/X11/animation/r_picture.hu
@@ -0,0 +1,4 @@
+:o= all
+r_picture.hs
+r_constants.hu
+r_utility.hu
diff --git a/progs/demo/X11/animation/r_ptypes.hs b/progs/demo/X11/animation/r_ptypes.hs
new file mode 100644
index 0000000..c020f82
--- /dev/null
+++ b/progs/demo/X11/animation/r_ptypes.hs
@@ -0,0 +1,67 @@
+{-***********************************************************************
+   MODULE PTYPES
+
+     This module contains the definitions for all the basic datatypes used to
+   create functional movies. 
+     The basis of all the images is the Poly, which is a tuple of a color
+   and a list of points. This is displayed as a polygon of that color. The 
+   form is a line drawn to each of the points, in order.
+     A list of these Poly's is a Pic, or picture. Each picture is a single
+   frame of the movie. A list of Pic's makes up a Movie, which is a series
+   of Pic's displayed in order.
+     Behaviours affect the movies, such as moving them left, or right.
+     PictoPic's affect a single picture.
+     The other functions simply convert regular values such as integers
+   and floats to the datatypes used by the functional programming.
+
+************************************************************************-}
+
+
+module R_Ptypes (Vec(..), Color(..), Pic(..), Poly(..), Movie(..), Behaviour(..), PictoPic(..), Process(..),
+		 Vecfloat(..),
+                 Msg(..), Chan(..),
+                 Val (..),
+                 ntov, vtov, nstov, vstov, pstov, bstov
+                )   where
+
+
+  --These are the basic data types for storing and manipulating the movies. 
+
+type Vec = (Int,Int)
+type Color = Int
+type Pic = [Poly]
+type Poly = (Color,[Vec])
+type Movie = [Pic]
+type Behaviour = [Pic -> Pic]
+type PictoPic  = Pic -> Pic
+
+type Process = [Msg] -> [Msg]
+type Msg     = [(Chan,Val)]
+type Chan    = [Char]
+
+data Val     = N Int | V (Int,Int) | P Pic | B PictoPic
+
+type Vecfloat = (Float,Float)
+
+
+
+--Those convert from the various regular values to Val's.
+
+ntov n   = N n
+
+vtov:: Vec -> Val
+vtov v   = V v
+
+ptov:: Pic -> Val
+ptov  p  = P p
+
+nstov ns = [N n|n<-ns]
+
+vstov:: [Vec] -> [Val]
+vstov vs = [V v|v<-vs]
+
+pstov:: [Pic] -> [Val]
+pstov ps = [P p|p<-ps]
+
+bstov:: [PictoPic] -> [Val]
+bstov bs = [B b|b<-bs]
diff --git a/progs/demo/X11/animation/r_ptypes.hu b/progs/demo/X11/animation/r_ptypes.hu
new file mode 100644
index 0000000..8a99f8f
--- /dev/null
+++ b/progs/demo/X11/animation/r_ptypes.hu
@@ -0,0 +1,2 @@
+:o= all
+r_ptypes.hs
diff --git a/progs/demo/X11/animation/r_shapes.hs b/progs/demo/X11/animation/r_shapes.hs
new file mode 100644
index 0000000..aef3362
--- /dev/null
+++ b/progs/demo/X11/animation/r_shapes.hs
@@ -0,0 +1,38 @@
+{-*****************************************************************
+  MODULE R_SHAPES
+  
+    This modules produces Pic's of boxes and triangles to help build
+  Pic's to animate.    
+    
+******************************************************************-}
+
+module R_Shapes (box, tri, circ_mov, circ) where
+
+import R_Ptypes
+import R_Utility
+import R_Picture
+import R_Behaviour
+
+  -- box takes four three ints, the color, width and height of the box and
+  -- returns a Pic of a box
+box :: Int -> Int -> Int -> Pic
+box c width height= [(c,[(0,0),(width,0),(width,height),(0,height),(0,0)])]
+
+  -- tri takes a color and three vectors, and returns a Pic of a triangle
+  -- with the vectors as vertices
+tri:: Color -> Vec -> Vec -> Vec -> Pic
+tri c (x1,y1) (x2,y2) (x3,y3) = [(c,[(x1,y1),(x2,y2),(x3,y3),(x1,y1)])]
+
+
+  -- circ takes a color, the radius
+circ :: Color -> Int -> Int -> Pic
+circ c r inc = [(c,(r+r,r):(circ' r' inc' 1.0))]
+               where r' = (fromIntegral r)
+                     inc' = (fromIntegral inc)
+
+circ' :: Float -> Float -> Float  -> [Vec]
+circ' r inc c | c>inc = []
+circ' r inc c         = vftov (x+r,y+r) : (circ' r inc (c+1.0))
+                	where x = r*(cos((2*c*pi)/inc))
+                      	      y = r*(sin((2*c*pi)/inc))
+                    
diff --git a/progs/demo/X11/animation/r_shapes.hu b/progs/demo/X11/animation/r_shapes.hu
new file mode 100644
index 0000000..ad0bf40
--- /dev/null
+++ b/progs/demo/X11/animation/r_shapes.hu
@@ -0,0 +1,3 @@
+:o= all
+r_shapes.hs
+r_behaviour.hu
diff --git a/progs/demo/X11/animation/r_utility.hs b/progs/demo/X11/animation/r_utility.hs
new file mode 100644
index 0000000..9dfcc65
--- /dev/null
+++ b/progs/demo/X11/animation/r_utility.hs
@@ -0,0 +1,150 @@
+{-*********************************************************************
+    MODULE R_UTILITY
+  
+      This module contains all the basic utility functions that the other
+    modules need to have to write their code. These are made generally
+    low level functions, manipulating vectors or defining very 
+    general functions  
+
+**********************************************************************-}
+
+
+module R_Utility (vtovf,vftov,
+		  vplus, vmin, mid, partway,
+                  mag,
+                  reduce, power, i,
+                  member, repeat, zip1, zip2, zip3, rept, replicate,
+                  mapc, 
+                  append, flatten, rptseq, osc
+                  ) where
+
+import R_Ptypes
+
+
+-- CONVERSION
+
+  -- vtovf takes a vector of integers, and converts it to a vector of floats
+vtovf :: Vec -> Vecfloat
+vtovf (x,y) = (fromIntegral x,fromIntegral y)
+
+  -- vftov takes a vector of floats and converts it to a vector of integers.
+  -- It rounds the floats off to do this.
+vftov :: Vecfloat -> Vec
+vftov (x,y) = (round x,round y)
+
+
+-- VECTOR OPERATIONS:
+
+  -- vector addition
+vplus:: Vec -> Vec -> Vec
+vplus (a,b) (c,d) = (a+c,b+d)
+
+  -- vector substraction
+vmin:: Vec -> Vec -> Vec
+vmin (a,b) (c,d) = (a-c,b-d)
+
+  -- finds the midpoint between two vectors
+mid:: Vec -> Vec -> Vec
+mid (x1,y1) (x2,y2) = (div (x1+x2) 2,div (y1+y2) 2 )
+
+  -- finds a point p/q along the way between two vectors
+partway :: Int -> Int -> [Vec] -> Vec
+partway p q [(x1,y1),(x2,y2)]
+        = vplus (x1,y1) ( div (p*(x2-x1)) q, div (p*(y2-y1)) q )
+
+  -- finds the magnitude of two vectors
+mag :: Vec -> Int
+mag p = round (magfloat (vtovf p))
+
+magfloat :: Vecfloat -> Float
+magfloat (x,y) = sqrt (x*x + y*y)
+
+  -- returns a vector at right angles to the input vector
+normal:: Vec -> Vec
+normal (x,y) = (-y,x)
+
+  -- returns the first vector projected onto the second
+project:: Vec -> Vec -> Vec
+project (vx,vy) (wx,wy) = partway (vx*wx+vy*wy) (mw*mw) [(0,0),(wx,wy)]
+			     where mw = mag (wx,wy)
+
+
+-- HIGHER-ORDER FUNCTIONS:
+
+  -- just foldr1. It applies a function of two inputs to an entire list 
+  -- recursively, and displays the single element result
+reduce :: (a->a->a) -> [a] -> a
+reduce = foldr1
+
+  -- power applies a single function n times to a seed
+power :: Int -> (a->a) -> a -> a
+power 0 f seed = seed
+power (n+1) f seed = f (power n f seed)
+
+  -- i takes an element and returns an infinite list of them
+i :: a -> [a]
+i x = x: (i x)
+
+  -- checks to see if x is in the list of xs
+member :: (Eq a) => [a] -> a -> Bool
+member [] x = False
+member (y:ys) x = x == y || member ys x
+
+  -- zip1 takes lists of lists, and rearranges them so that all the first
+  -- elements are in the first list, all the second in the second and so on.
+zip1 :: (Eq a) => [[a]] -> [[a]]
+zip1 xs | member xs [] = []
+zip1 xs = (map head xs):(zip1 (map tail xs))
+
+  -- takes two lists and makes a list of tuples.
+zip2 :: [a] -> [b] -> [(a,b)]
+zip2=zip
+
+  -- rept takes a function and a list of elements, and applies the function
+  -- n-1 times to the n-th element
+rept :: (a->a) -> a -> [a]
+rept f x =  x:(rept f (f x))
+
+  -- replicate creates an list n elements long of a, with the function
+  -- applies to the n-th element n-1 times.
+replicate :: Int -> (a->a->a) -> a -> a -> a
+replicate 0 f zero a = zero
+replicate 1 f zero a = a
+replicate (n+2) f zero a = f a (replicate (n+1) f zero a)
+
+  -- mapc is a map function for lists of functions (behaviours)
+mapc :: (a->b) -> [c->a] -> [c->b]
+mapc f as = [f.a | a <- as]
+
+
+-- FUNCTIONS OVER SEQUENCES:
+
+  -- append takes a list of lists, and makes them into one giant happy list.
+append :: [[a]] -> [a]
+append = foldr (++) []
+
+  -- flatten takes a list of lists of tuples and gives one giant happy list
+  -- of single elements back.
+flatten:: [[(a,a)]] -> [a]
+flatten s = foldr f []  (append s)
+            where f (x,y) [] = [x,y]
+                  f (x,y) (z:zs) = x:y:(z:zs)
+
+  -- rptseq takes a list of elements and applies a function to them,
+  -- n-1 times for the n-th element, but using map 
+rptseq :: (a->a) -> [a] -> [a]
+rptseq f [] = []
+rptseq f (x:xs) = x:rptseq f (map f xs)
+
+  -- osc takes a list, and makes sure it oscillates. If the head is 
+  -- equal to the tail, it simply repeats the sequence infinitely. If
+  -- the head is not equal to the tail, it adds the sequence then adds
+  -- the reversed sequence minus the first and last elements, and then repeats
+osc :: [a] -> [a]
+osc s  | (length s) == 0 = []
+osc s  | (length s) == 1 = head s: osc s
+osc s           = (s ++ (((tail.reverse).tail) s)) ++ (osc s)
+
+
+
+
diff --git a/progs/demo/X11/animation/r_utility.hu b/progs/demo/X11/animation/r_utility.hu
new file mode 100644
index 0000000..6fac189
--- /dev/null
+++ b/progs/demo/X11/animation/r_utility.hu
@@ -0,0 +1,3 @@
+:o= all
+r_utility.hs
+r_ptypes.hu
diff --git a/progs/demo/X11/animation/seafigs.hs b/progs/demo/X11/animation/seafigs.hs
new file mode 100644
index 0000000..c216a63
--- /dev/null
+++ b/progs/demo/X11/animation/seafigs.hs
@@ -0,0 +1,158 @@
+module Seafigs (sky,blue_sky,clouds,clouds2,gull,man,sun,vm,windmill,palm) where
+
+import Animation
+
+blue_sky:: Movie
+blue_sky = osc [box lightblue 1000 1000]
+
+sky:: Color -> Movie
+sky c = osc [box c 1000 1000]
+
+clouds2:: Movie
+clouds2 = apply (mov (i (cld_wid,0))) (rBESIDE[cld,cld])
+         where cld_wid = -(wid_Pic (cld!!0))
+               cld= apply (bPar [right,mov (repeat (250,-50))]) cldm1
+               cldm1=osc[cloud1]
+ 
+clouds:: Movie
+clouds
+  = rOVERLAY
+      [apply (bPar [right,mov (repeat (250,-50))]) cloudm1,
+       apply (bPar [right,mov (repeat (0,-50))]) cloudm2,
+       apply (bPar [right,mov (repeat (250,-75))]) cloudm2,
+       apply (bPar [right,flipb,smaller,mov(repeat (200,-100))]) cloudm2,
+       apply (bPar [right,flipb,smaller,mov(repeat (300,-125))]) cloudm1,
+       apply (bPar [right,right,mov (repeat (-50,50))]) cloudm1]
+       where cloudm1 = osc [cloud1]
+             cloudm2 = osc [cloud2]
+
+
+cloud1 = [(white,ply)]
+         where ply = [(142,301),(169,309),(180,315),(192,312),
+                      (196,308),(202,302),(216,300),(224,308),
+                      (238,312),(258,311),(274,301),(278,283),
+                      (265,279),(246,279),(230,281),(197,286),
+                      (185,288),(167,287),(148,287),(136,292),
+                      (136,292),(142,301)]
+
+
+cloud2 = [(white,ply)]
+         where ply = [(51,262), (56,266),
+                      (66,265), (90,264), (92,266), (98,270),
+                      (111,268),(137,268),(155,266),(174,266),
+                      (183,262),(183,253),(162,251),(136,254),
+                      (132,250),(126,248),(115,252),(109,253),
+                      (98,252), (90,253), (88,254), (67,254),
+                      (56,252), (49,254), (47,259), (51,262)]
+
+gull :: Movie
+gull = osc [gull1,gull2]
+
+gull1 = [(black,[(2,4),(6,4),(9,2),(10,0),(11,2),
+               (16,4),(20,4)])]
+
+gull2 = [(black,[(0,0),(2,2),(6,3),(9,2),(12,3),
+               (16,2),(18,0)])]
+
+man :: Movie
+man = osc [man1,man2,man3]
+
+
+man1 = [(black,[(0,0),(10,0),(20,40),(30,60),(40,20),
+                (60,0),(50,0)]),
+        (black,[(0,40),(20,60),(30,80),(50,70),(60,60)]),
+        (black,[(30,60),(30,100)]),
+        (black,[(30,100),(25,100),(20,105),(23,112),
+                (20,115),(30,120),(35,120),(40,115),
+                (40,110),(35,105),(30,100)])
+                 ]
+
+man2 = [(black,[(20,0),(30,0),(20,40),(30,60),(45,30),
+                (60,20),(50,0)]),
+        (black,[(0,60),(20,60),(20,80),(40,80),(50,60)]),
+        (black,[(30,60),(20,100)]),
+        (black,[(20,100),(15,100),(10,105),(13,112),
+                (10,115),(20,120),(30,120),(30,115),
+                (30,110),(25,105),(20,100)])
+                 ]
+
+man3 = [(black,[(0,15),(5,10),(15,45),(30,60),(35,25),
+            (44,10),(35,0)]),
+        (black,[(10,40),(22,60),(20,80),(40,75),(45,44)]),
+        (black,[(30,60),(20,100)]),
+        (black,[(20,100),(19,100),(14,105),(17,112),
+                (14,115),(24,120),(34,120),(34,115),
+                (34,110),(29,105),(200,100)])
+                 ]
+
+sun :: Movie
+sun = osc [sun']
+      where
+      sun' = reduce overlay_Pic [sun1,
+                                 twist_Pic (pi/24.0) sun1,
+                                 twist_Pic (pi/12.0) sun1]
+
+sun1 = [(yellow,[(43,16),(18,27),(9,51),(20,71),(42,81),
+                 (66,73),(76,47),(69,25),(43,15),(43,16)])]
+
+vm :: Movie
+vm =  osc[vm1,vm2]
+
+vm1 = beside_Pic (box brown 10 15)
+                 (above_Pic light1 (box brown 40 80))
+      where light1 = box yellow 10 10
+
+vm2 = beside_Pic (box brown 10 15)
+                 (reduce above_Pic [light,light2,box brown 40 80])
+      where light2 = over_Pic (box red 10 10) (box white 5 5)
+            light  = [ (red,[(5,5), (10,2), (0,30),(5,5)]),
+                       (red,[(20,2),(25,5),(30,30),(20,2)]),
+                       (red,[(15,15),(20,15),(15,50),(10,25)])]
+
+windmill :: Movie
+windmill
+   = apply
+       (bpar (mov (repeat (unit*3,0))) (scale_rel (0,0) (repeat 3)))
+       (overlay body (apply (movto (repeat (100,400))) prop))
+
+blade = osc [tri red (0,0) (100,0) (50,300)]
+prop  = apply cw fan
+
+fan  = rOVERLAY [fan1,fan2,fan3,fan4]
+fan1 = blade
+fan2 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan1
+fan3 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan2
+fan4 = apply (rot (osc[(50,300)]) (osc[pi/2.0])) fan3
+
+body = osc [ [(brown,[(0,0),(200,0),(170,300),
+                     (100,400),(30,300),(0,0)]) ] ]
+
+
+palm :: Movie
+palm
+  = osc palms
+    where palms = inbetween 3 palm1 (flipx_Pic 100 palm1)
+          palm1 = reduce overlay_Pic [trunk,frond1,frond2,frond3,frond4]
+              where frond1 = [ (green,[(50,60),(60,70),(80,60)]),
+                               (green,[(50,70),(60,80),(80,70)]),
+                               (green,[(50,80),(55,90),(70,80)]),
+                               (green,[(60,70),(55,90),(50,100)]) ]
+
+                    frond2 = flipx_Pic 50 frond1
+
+                    frond3 = [ (green,[(10,70),(5,80)]),
+                               (green,[(10,80),(10,90)]),
+                               (green,[(20,90),(20,100)]),
+                               (green,[(30,95),(40,104)]),
+                               (green,[(5,80),(20,100),(40,104),
+                                       (50,100)])]
+
+                    frond4 = [(green,[(0,100),(5,110)]),
+                              (green,[(15,105),(15,115)]),
+                              (green,[(25,105),(30,115)]),
+                              (green,[(35,105),(40,115)]),
+                              (green,[(5,110),(30,115),(50,110),
+                                      (50,100)])]
+
+                    trunk  = [(brown,[(100,0),(95,40),(80,80),
+                                      (70,90),(60,97),(50,100)])]
diff --git a/progs/demo/X11/animation/seafigs.hu b/progs/demo/X11/animation/seafigs.hu
new file mode 100644
index 0000000..83fcfcf
--- /dev/null
+++ b/progs/demo/X11/animation/seafigs.hu
@@ -0,0 +1,3 @@
+:o= all
+animation.hu
+seafigs.hs
diff --git a/progs/demo/X11/animation/seaside.hs b/progs/demo/X11/animation/seaside.hs
new file mode 100644
index 0000000..fe11e12
--- /dev/null
+++ b/progs/demo/X11/animation/seaside.hs
@@ -0,0 +1,25 @@
+module Seaside (main) where
+
+import Animation
+import Seafigs
+
+seaside :: Movie
+seaside = rOVERLAY [blue_sky,
+		    apply (bPar [up,cw,movto (repeat botm)]) sun,
+		    apply right clouds,
+		    apply (bPar [right,bigger]) gull,
+		    apply (bPar [right,right,bigger]) gull,
+		    apply (bPar [up,up,right,bigger]) gull,
+		    apply (bPar [up,right,right,right]) gull,
+		    windm,
+		    apply (mov (repeat botm)) palm,
+		    man_and_vm
+           	   ]
+	where man_and_vm = rBESIDE2 [manfig, vm]
+              manfig = apply left (apply (mov (i (700,0)))
+ 					         man)
+	      windm = apply (mov (i (500,0))) windmill        	 
+
+
+main = getEnv "DISPLAY" exit 
+       (\ host -> displaym host 30 (map (flipy_Pic 500) seaside))
diff --git a/progs/demo/X11/animation/seaside.hu b/progs/demo/X11/animation/seaside.hu
new file mode 100644
index 0000000..df2c4b9
--- /dev/null
+++ b/progs/demo/X11/animation/seaside.hu
@@ -0,0 +1,5 @@
+:o= all
+seaside.hs
+seafigs.hu
+
+
diff --git a/progs/demo/X11/draw/README b/progs/demo/X11/draw/README
new file mode 100644
index 0000000..b844d2b
--- /dev/null
+++ b/progs/demo/X11/draw/README
@@ -0,0 +1 @@
+This is the draw program used in the X window documentation
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)
diff --git a/progs/demo/X11/draw/draw.hu b/progs/demo/X11/draw/draw.hu
new file mode 100644
index 0000000..f09a72e
--- /dev/null
+++ b/progs/demo/X11/draw/draw.hu
@@ -0,0 +1,2 @@
+$HASKELL_LIBRARY/X11/xlib.hu
+draw.hs
diff --git a/progs/demo/X11/gobang/README b/progs/demo/X11/gobang/README
new file mode 100644
index 0000000..d5634a4
--- /dev/null
+++ b/progs/demo/X11/gobang/README
@@ -0,0 +1,66 @@
+gobang       Weiming Wu & Niping Wu
+
+
+Introduction
+
+Our final project is to design and implement a Gobang game under
+X-Window3.2 environment, using the Haskell programming language. Users
+can play the game human-vs-human.  The program also provides a robot
+player with whom the user can play the game with.  We wrote altogether
+ten modules which were saved in different files to control the whole
+game.
+
+
+About Gobang
+
+The checkerboard of Gobang consists of 19 vertical lines and 19
+horizontal lines.  Two players in turn place a unit on the
+checkerboard.  Each unit should be put on an unoccupied intersection
+of a vertical and a horizontal line.  The winner is the player who
+first makes five consecutive units on either vertical, horizontal or
+diagonal direction.
+
+The program is able to perform the following tasks: 1) Use a new
+window under X-Window interface to display the checkerboard.  Players
+will use a mouse to place units onto the chessboard, where a unit is a
+circle with the color black or white.  2) Prompt for the names of both
+players and display them.  3) Calculate the time both players have
+used up.  4) Supervise the progress of the game, declare winner and
+end the game once one player wins.  5) At each point of the game,
+store the progress of the game, so players can review each step during
+the game.  6) There are five buttons on the screen which would provide
+some special services such as starting a new game, quitting the game,
+saving the game, importing the saved game, or reviewing the game as
+soon as the user selects the corresponding buttons.  7) Provide a
+moderately well robot player for that game (using minimum-maximum
+algorithm).
+
+
+Running Gobang
+
+A window titled "gobang" will appear on the screen.  On it is a
+checkerboard, clocks and buttons.  There will be an instruction saying
+"Please enter the name of player-1".  The user can do two things:
+either enter the name of a player or choose the "import" button. Once
+the "import" button is selected, an unfinished game, which was saved
+in the file "###go.bhs###" will be imported.  Please notice that the
+character "@" is reserved for the robot player, so if the user types
+in @ as the name of the first player, it is assumed that player-1 is
+the robot player.  Then the name of player 2 is prompted.  The game
+starts and at each turn an instruction like "Please enter your play."
+would appear on the screen.  The user should put a unit onto the
+checkerboard.  If the button is clicked on a wrong place or a unit is
+put onto an occupied position, an error message saying "Wrong Point.
+Please reenter." will appear on the screen and the user should reenter
+his play.  The marker next to the name of a player indicates whose
+turn it is.  At any point of the game the user can choose the other
+four buttons.  If the "new" button is selected, the present game will
+be terminated and a new blank checkerboard will be displayed on the
+screen; if the "review" button is selected, one step of the previous
+plays will be displayed each time after the user hits any key; if the
+"save" button is selected, the steps so far will be saved into the
+file "###go.bhs###"; if the "quit" button is selected, the game will
+be terminated.
+
+
+
diff --git a/progs/demo/X11/gobang/gobang.hs b/progs/demo/X11/gobang/gobang.hs
new file mode 100644
index 0000000..f4844dc
--- /dev/null
+++ b/progs/demo/X11/gobang/gobang.hs
@@ -0,0 +1,364 @@
+module Gobang where
+
+import Xlib
+import Utilities
+import Redraw
+import Weights
+
+getXInfo :: String -> IO XInfo
+getXInfo host = 
+  xOpenDisplay host `thenIO` \ display ->
+  let (screen:_) = xDisplayRoots display 
+      fg_pixel = xScreenBlackPixel screen
+      bg_pixel = xScreenWhitePixel screen
+      root = xScreenRoot screen
+  in 
+  xCreateWindow root
+                (XRect 0 0 900 600)
+                [XWinBackground bg_pixel, 
+                 XWinEventMask (XEventMask [XButtonPress, 
+                                            XKeyPress, 
+                                            XExposure])]
+                 `thenIO` \ window ->
+  xSetWmName window "Gobang" `thenIO` \() ->
+  xMapWindow window `thenIO` \() ->
+  xOpenFont display "10x20" `thenIO`  \ playerfont ->
+  xOpenFont display "6x13" `thenIO` \ genericfont ->
+  xCreateGcontext (XDrawWindow window)
+                  [XGCBackground bg_pixel,      
+                   XGCForeground fg_pixel] `thenIO` \ gcontext  ->
+  xCreateGcontext (XDrawWindow window)
+                  [XGCBackground fg_pixel,
+                   XGCForeground bg_pixel,
+                   XGCFont       genericfont] `thenIO` \ gcontext2 ->
+  xCreateGcontext (XDrawWindow window)
+                  [XGCBackground bg_pixel,
+                   XGCForeground fg_pixel,
+                   XGCFont       playerfont] `thenIO` \ gcontextp ->
+  returnIO (XInfo display window gcontext gcontext2 gcontextp)
+
+demo = main
+
+main = getEnv "DISPLAY" exit $ \ host ->
+       xHandleError (\(XError msg) -> appendChan stdout msg exit done) $
+       gobang host
+
+gobang :: String -> IO ()
+gobang host =
+  getXInfo host `thenIO` \ xinfo ->
+  xMArrayCreate [1..361] `thenIO` \ board ->
+  xMArrayCreate [1..361] `thenIO` \ weight1 ->
+  xMArrayCreate [1..361] `thenIO` \ weight2 ->
+  xMArrayCreate [1..722] `thenIO` \ steps ->
+  xMArrayCreate [""] `thenIO` \ player1 ->
+  xMArrayCreate [""] `thenIO` \ player2 ->
+  xMArrayCreate [1..4] `thenIO`  \ time ->
+  xMArrayCreate [1] `thenIO` \ numbersteps ->
+  xMArrayCreate [""] `thenIO` \ promptString ->
+  xMArrayCreate [1] `thenIO` \ next_player ->
+  let state = GameState player1 player2 board steps weight1 weight2 time
+                        numbersteps promptString next_player
+  in
+  initGame xinfo state `thenIO` \ _ ->
+  promptPlayers xinfo state `thenIO` \ _ ->
+  playGame xinfo state
+
+promptPlayers xinfo state = 
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+      (GameState player1 player2 board steps weight1 weight2 time
+                 numbersteps promptString next_player) = state
+  in
+  promptFor "player 1:" xinfo state `thenIO` \ player1_name ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name
+  `thenIO` \ _ ->
+  xMArrayUpdate player1 0 player1_name `thenIO` \ _ ->
+  promptFor "player 2:" xinfo state `thenIO` \ player2_name ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name
+  `thenIO` \ _ ->
+  xMArrayUpdate player2 0 player2_name `thenIO` \ _ ->
+  clearCmd xinfo state
+
+initGame :: XInfo -> GameState -> IO ()
+initGame xinfo 
+         state@(GameState player1 player2 board steps weight1 weight2 time
+                          numbersteps promptString next_player) =
+          getTime `thenIO` \ curtime ->
+          initArray time 0 2 0 `thenIO` \() ->
+          initArray time 2 4 curtime `thenIO` \() ->
+          initArray numbersteps 0 1 0 `thenIO` \() ->
+          initArray board 0 361 0 `thenIO` \() ->
+          initArray weight1 0 361 0 `thenIO` \() ->
+          initArray weight2 0 361 0 `thenIO` \ () ->
+          initArray next_player 0 1 1 `thenIO` \ () ->
+          clearCmd xinfo state `thenIO` \ () ->
+          redraw xinfo state
+ 
+
+handleButton :: XPoint -> XInfo -> GameState -> GameCont -> IO ()
+handleButton (XPoint x y) 
+             xinfo
+             state@(GameState player1 player2 board steps weight1 weight2 time
+                              numbersteps promptString next_player)
+             cont 
+       | buttonPress 700 330 x y  = initArray player1 0 1 "" `thenIO` \ _ ->
+                                    initArray player2 0 1 "" `thenIO` \ _ ->
+                                    initGame xinfo state `thenIO` \ _ ->
+                                    promptPlayers xinfo state `thenIO` \ _ ->
+                                    playGame xinfo state
+       | buttonPress 700 360 x y  = initGame xinfo state `thenIO` \ _ ->
+                                    playGame xinfo state
+       | buttonPress 700 390 x y  = undoGame xinfo state cont
+       | buttonPress 700 420 x y  = loadGame xinfo state cont
+       | buttonPress 700 450 x y  = saveGame xinfo state `thenIO` \ () ->
+                                    cont xinfo state
+       | buttonPress 700 480 x y  = quitGame xinfo state cont
+       | ishelp x y          = helpGame xinfo state `thenIO` \ () ->
+                               cont xinfo state
+       | otherwise           = cont xinfo state
+
+when :: Bool -> IO () -> IO ()
+when cond action = if cond then action else returnIO ()
+
+undoGame xinfo@(XInfo display window gcontext gcontext2 gcontextp)
+         state@(GameState player1 player2 board steps weight1 weight2 time
+                          numbersteps promptString next_player)
+         cont =
+  xMArrayLookup next_player 0 `thenIO` \ next_p ->
+  xMArrayLookup player1 0 `thenIO` \ name1 ->
+  xMArrayLookup player2 0 `thenIO` \ name2 ->
+  let undoStep n =
+        xMArrayLookup steps (2*n) `thenIO` \ x ->
+        xMArrayLookup steps (2*n+1) `thenIO` \ y ->
+        xMArrayUpdate board ((x-1)*19 + y-1) 0 `thenIO` \ _ ->
+        (if (name1 == "computer" || name2 == "computer") 
+            then draw_unit board weight1 weight2 x y 
+            else returnIO ()) `thenIO` \ _ ->
+       xDrawRectangle (XDrawWindow window) gcontext2 
+                      (XRect (x*30-15) (y*30-15) 30 30) True 
+       `thenIO` \() ->
+--        drawBoard xinfo `thenIO` \ _ ->
+--        drawPieces 1 1 board xinfo `thenIO` \ _ ->
+        let x30 = x * 30
+            y30 = y * 30
+            c = XPoint x30 y30
+            w = XPoint (x30-15) y30
+            e = XPoint (x30+15) y30
+            no = XPoint x30 (y30-15)
+            s = XPoint x30 (y30+15)
+            m = XArc (x30-3) (y30-3) 6 6 (-1.0) 6.283
+        in
+        when (x > 1) (xDrawLine (XDrawWindow window) gcontext w c) 
+        `thenIO` \ _ ->
+        when (x < 19) (xDrawLine (XDrawWindow window) gcontext c e) 
+        `thenIO` \ _ ->
+        when (y > 1) (xDrawLine (XDrawWindow window) gcontext no c) 
+        `thenIO` \ _ ->
+        when (y < 19) (xDrawLine (XDrawWindow window) gcontext c s) 
+        `thenIO` \ _ ->
+        when ((x `elem` [4,10,16]) && (y `elem` [4,10,16]))
+             (xDrawArc (XDrawWindow window) gcontext m True) 
+        `thenIO` \ _ ->
+        xDisplayForceOutput display `thenIO` \ _ ->
+        xMArrayUpdate numbersteps 0 n `thenIO` \ _ ->
+        xMArrayLookup next_player 0 `thenIO` \ next_p ->
+        xMArrayUpdate next_player 0 (if next_p == 1 then 2 else 1) 
+
+      cur_name = if next_p == 1 then name1 else name2
+      last_name = if next_p == 1 then name2 else name1
+  in
+  xMArrayLookup numbersteps 0 `thenIO` \ n ->
+  if n==0 then drawCmd "No more steps to undo!" xinfo state `thenIO` \ _ ->
+               cont xinfo state
+  else 
+  if cur_name == "computer" then cont xinfo state
+  else
+  (undoStep (n-1) `thenIO` \_ ->
+   if (last_name == "computer" && n /= 1) then undoStep (n-2)
+   else
+   returnIO ()) `thenIO` \ _ ->
+  playGame xinfo state
+    
+
+
+
+promptFile xinfo state cont =
+  promptFor "File name:" xinfo state `thenIO` \ name ->
+  readFile name 
+           (\ _ -> drawCmd ("Can't read file:" ++ name) xinfo state 
+                   `thenIO` \ _ -> 
+		   cont XNull)
+           (\ content -> cont (XSome content))
+
+loadGame xinfo state cont =
+  promptFile xinfo state $ \ file ->
+  case file of
+    XNull -> cont xinfo state
+    XSome file_content ->
+     readGameState file_content `thenIO` \ new_state ->
+     let (GameState _ _ _ _ _ _ time _ _ _) = new_state
+     in
+     getTime `thenIO` \ curtime ->
+     initArray time 2 4 curtime `thenIO` \() ->
+     redraw xinfo new_state `thenIO` \ _ ->
+     playGame xinfo new_state
+
+saveGame :: XInfo -> GameState -> IO ()
+saveGame xinfo state =
+  promptFor "File name:" xinfo state `thenIO` \ name ->
+  showGameState state `thenIO` \ str ->
+  writeFile name str
+            (\ _ -> drawCmd ("Can't write file: " ++ name) xinfo state)
+	    done
+
+quitGame :: XInfo -> GameState -> GameCont -> IO ()
+quitGame xinfo state cont =
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+  in
+  promptFor "Are you sure? (y/n)" xinfo state `thenIO` \ reps ->
+  if (reps == "y" || reps == "Y") then xCloseDisplay display
+                                  else clearCmd xinfo state `thenIO` \ _ ->
+                                       cont xinfo state
+
+playGame :: XInfo -> GameState -> IO ()
+playGame xinfo state =
+     let             
+        (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+        (GameState player1 player2 board steps weight1 weight2 time
+                   numbersteps promptString next_player) = state
+     in
+     xMArrayLookup numbersteps 0 `thenIO` \ x ->
+     (\cont -> if x == 361 
+               then drawCmd "It's a tie!" xinfo state `thenIO` \ _ ->
+                    let loop xinfo state = waitButton xinfo state (\ _ -> loop)
+                    in loop xinfo state
+               else cont) $        
+     xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
+     getTime `thenIO` \ curtime ->
+     xMArrayLookup time 0 `thenIO` \ lstm0 ->
+     xMArrayLookup time 1 `thenIO` \ lstm1 ->
+     xMArrayLookup time 2 `thenIO` \ lstm2 ->
+     xMArrayLookup time 3 `thenIO` \ lstm3 ->
+     drawCmd ("Waiting for player # " ++ (show next_player_num)) xinfo state 
+     `thenIO` \() ->
+     if (next_player_num == 1)
+        then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70)
+                   '<' `thenIO` \(trash) ->
+             xDrawRectangle (XDrawWindow window) gcontext2 
+	                    (XRect 840 180 40 40) True `thenIO` \() ->
+             xMArrayUpdate time 2 curtime `thenIO` \() ->
+             xMArrayUpdate time 1 (lstm1+curtime-lstm3) `thenIO` \() ->
+             showtime 705 270 (lstm1+curtime-lstm3) xinfo `thenIO` \() ->
+             xMArrayLookup player1 0 `thenIO` \ x ->
+             if (x == "computer") 
+                   then computerplay xinfo state
+                   else humanplay xinfo state
+        else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210)
+                    '<' `thenIO` \(trash) ->
+             xDrawRectangle (XDrawWindow window) gcontext2 
+	                    (XRect 840 40 40 40)  True `thenIO` \() ->
+             xMArrayUpdate time 3 curtime `thenIO` \() ->
+             xMArrayUpdate time 0 (lstm0+curtime-lstm2) `thenIO` \() ->
+             showtime 705 130 (lstm0+curtime-lstm3) xinfo `thenIO` \() ->
+             xMArrayLookup player2 0 `thenIO` \ x ->
+             if (x == "computer") 
+                   then computerplay xinfo state
+                   else humanplay xinfo state
+
+waitButton xinfo@(XInfo display _ _ _ _) state cont = 
+  let
+    loop xinfo state = 
+      xGetEvent display `thenIO` \ event ->
+      case (xEventType event) of
+        XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state 
+                          `thenIO` \ _ ->
+                          loop xinfo state
+        XButtonPressEvent -> 
+                          let pos = xEventPos event
+                          in 
+                          handleButton pos xinfo state (cont pos)
+        _              -> xBell display 0 `thenIO` \ _ ->
+                          loop xinfo state
+  in
+  loop xinfo state
+
+updateboard :: XInfo -> GameState -> Int -> Int -> IO ()
+updateboard xinfo state x y = 
+            let (GameState player1 player2 board steps weight1 weight2 time
+                           numbersteps promptString next_player) = state
+                (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+            in
+            xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
+            xMArrayUpdate next_player 0 (if next_player_num == 1 then 2 else 1)
+            `thenIO` \ _ -> 
+            xMArrayLookup numbersteps 0 `thenIO` \ z ->
+            xMArrayUpdate numbersteps 0 (z+1) `thenIO` \() ->
+            xMArrayUpdate steps (2*z) x `thenIO` \() ->
+            xMArrayUpdate steps (2*z+1) y `thenIO` \() ->
+            xMArrayLookup player1 0 `thenIO` \ name1 ->
+            xMArrayLookup player2 0 `thenIO` \ name2 ->
+            xMArrayUpdate board (19*(x-1)+y-1) next_player_num 
+            `thenIO` \() ->
+            human_unit board x y `thenIO` \ win ->
+            if win 
+            then drawCmd ("Player " ++ (show next_player_num) ++ " has won!")
+                         xinfo state `thenIO` \ _ ->
+                 let loop xinfo state = waitButton xinfo state (\ _ -> loop)
+                 in loop xinfo state
+            else if (name1 == "computer" || name2 == "computer")
+                 then draw_unit board weight1 weight2 x y `thenIO` \() ->
+                      xMArrayUpdate weight1 (19*(x-1)+y-1) (-1) `thenIO` \() ->
+                      xMArrayUpdate weight2 (19*(x-1)+y-1) (-1) `thenIO` \() ->
+                      playGame xinfo state
+                 else playGame xinfo state
+
+choice :: XPoint -> XInfo -> GameState -> IO ()
+choice (XPoint x y) xinfo@(XInfo display _ _ _ _) state =
+   let (GameState player1 player2 board steps weight1 weight2 time
+                  numbersteps promptString next_player) = state
+   in
+   case (getposition x y) of
+     XNull -> humanplay xinfo state
+     XSome (x, y) -> 
+       xMArrayLookup board (19*(x-1)+y-1) `thenIO` \ z ->
+       if (z>0)
+       then xBell display 0 `thenIO` \ _ ->
+            drawCmd "Wrong point, please re-enter" xinfo state `thenIO` \() ->
+            humanplay xinfo state
+       else xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
+            drawPiece x y xinfo (next_player_num == 1) `thenIO` \() ->
+            updateboard xinfo state x y
+
+humanplay :: XInfo -> GameState -> IO ()
+humanplay xinfo state =  waitButton xinfo state choice
+
+computerplay :: XInfo -> GameState -> IO ()
+computerplay xinfo@(XInfo display window gcontext gcontext2 gcontextp)
+             state = 
+    let process_events xinfo state cont =
+          xEventListen display `thenIO` \ n_event ->
+          if n_event == 0 then cont xinfo state
+          else xGetEvent display `thenIO` \ event ->
+               case (xEventType event) of
+                 XButtonPressEvent -> 
+                            handleButton (xEventPos event) xinfo state cont
+                 XExposureEvent    -> 
+                            may_redraw (xEventCount event == 0)
+                                       xinfo state 
+                            `thenIO` \ _ ->
+                            process_events xinfo state cont
+                 XKeyPressEvent    ->
+                            process_events xinfo state cont
+    in
+    process_events xinfo state $ 
+    \ xinfo@(XInfo display window gcontext gcontext2 gcontextp)              
+      state@(GameState _ _ _ _ weight1 weight2 _ numbersteps _ next_player) ->
+    robot numbersteps weight1 weight2 `thenIO` \pt ->
+    let (XPoint x y) = pt
+    in 
+    xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
+    drawPiece x y xinfo (next_player_num == 1) `thenIO` \() ->
+    updateboard xinfo state x y
+
+
+
+
diff --git a/progs/demo/X11/gobang/gobang.hu b/progs/demo/X11/gobang/gobang.hu
new file mode 100644
index 0000000..d228bb2
--- /dev/null
+++ b/progs/demo/X11/gobang/gobang.hu
@@ -0,0 +1,7 @@
+:o= foldr inline constant
+$HASKELL_LIBRARY/X11/xlib.hu
+gobang.hs
+misc.hi
+utilities.hs
+redraw.hs
+weights.hs
diff --git a/progs/demo/X11/gobang/misc.hi b/progs/demo/X11/gobang/misc.hi
new file mode 100644
index 0000000..29a29be
--- /dev/null
+++ b/progs/demo/X11/gobang/misc.hi
@@ -0,0 +1,7 @@
+interface Misc where
+
+random :: Int -> IO Int
+
+{-#
+random :: LispName("lisp:random")
+#-}
\ No newline at end of file
diff --git a/progs/demo/X11/gobang/misc.hu b/progs/demo/X11/gobang/misc.hu
new file mode 100644
index 0000000..42a9c68
--- /dev/null
+++ b/progs/demo/X11/gobang/misc.hu
@@ -0,0 +1,2 @@
+misc.hi
+
diff --git a/progs/demo/X11/gobang/redraw.hs b/progs/demo/X11/gobang/redraw.hs
new file mode 100644
index 0000000..9ec772f
--- /dev/null
+++ b/progs/demo/X11/gobang/redraw.hs
@@ -0,0 +1,160 @@
+module Redraw where
+
+import Xlib 
+import Utilities
+
+may_redraw :: Bool -> XInfo -> GameState -> IO ()
+may_redraw ok xinfo state = if ok then redraw xinfo state else returnIO ()
+
+redraw :: XInfo -> GameState -> IO ()
+
+redraw xinfo state = 
+  let (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+  in
+  xDrawRectangle (XDrawWindow window) gcontext2 (XRect 0 0 900 600) True 
+  `thenIO` \ _ ->
+  drawBoard xinfo `thenIO` \ () ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 65) "Player 1" 
+  `thenIO` \ _  ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 125) "Clock 1"
+  `thenIO` \ _  ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 610 205) "Player 2"
+  `thenIO` \ _  ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 620 265) "Clock 2"
+  `thenIO` \ _  ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 45 130 30) False 
+  `thenIO` \ () ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 105 90 30) False
+  `thenIO` \ () ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 185 130 30) False
+  `thenIO` \() ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 700 245 90 30) False 
+  `thenIO` \() ->
+  button 700 330 "New players"  xinfo `thenIO` \() ->
+  button 700 360 "New game"  xinfo `thenIO` \() ->
+  button 700 390 "Undo" xinfo `thenIO` \() ->
+  button 700 420 "Load" xinfo `thenIO` \() ->
+  button 700 450 "Save"  xinfo `thenIO` \() ->
+  button 700 480 "Quit" xinfo `thenIO` \() ->
+  helpButton xinfo `thenIO` \ _ ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 615 535 250 30) False
+  `thenIO` \ _ ->
+  let (GameState player1 player2 board steps weight1 weight2 time
+                 numbersteps promptString next_player) = state
+  in
+  xMArrayLookup time 0 `thenIO` \ lstm0 ->
+  xMArrayLookup time 1 `thenIO` \ lstm1 ->
+  showtime 705 270 (lstm1) xinfo `thenIO` \() ->
+  showtime 705 130 (lstm0) xinfo `thenIO` \() ->
+  xMArrayLookup player1 0 `thenIO` \ player1_name ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 65) player1_name
+  `thenIO` \ _ ->
+  xMArrayLookup player2 0 `thenIO` \ player2_name ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 710 205) player2_name
+  `thenIO` \ _ ->
+  xMArrayLookup promptString 0 `thenIO` \ ps ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) ps
+  `thenIO` \ _ ->
+  xMArrayLookup next_player 0 `thenIO` \ next_player_num ->
+  (if (next_player_num == 1)
+   then xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 70) '<' 
+   else xDrawGlyph (XDrawWindow window) gcontextp (XPoint 850 210) '<')
+  `thenIO` \ _ ->
+  drawPieces 1 1 board xinfo `thenIO` \ _ ->
+  returnIO ()  
+
+drawHelp (XInfo display window gcontext gcontext2 gcontextp) = 
+  xDrawRectangle (XDrawWindow window) gcontext2 (XRect 100 100 300 200) True
+  `thenIO` \ _ ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 100 100 300 200) False
+  `thenIO` \ _ ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 102 102 296 196) False
+  `thenIO` \ _ ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 200 230 100 60) False
+  `thenIO` \ _ ->
+  xDrawRectangle (XDrawWindow window) gcontext (XRect 202 232 96 56) False
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 240 265) "OK"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 120)
+              "Two players in turn place black and white"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 135)
+              "pieces on the board. The winner is the"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 150)
+              "player who first makes five consecutive"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 165)
+              "pieces in either vertical, horizontal or"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 180)
+              "diagonal directions."
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 200)
+              "To play with a robot, type \"computer\" as"
+  `thenIO` \ _ ->
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 120 215)
+              "the name of another player."
+
+
+drawBoard (XInfo display window gcontext gcontext2 gcontextp) =
+  drawvlines 30 30 1 `thenIO` \() ->
+  drawhlines 30 30 1 `thenIO` \() ->  
+  drawmarks where
+
+  drawvlines :: Int -> Int -> Int -> IO ()
+  drawvlines x y z 
+                | z <= 19 
+                   = xDrawLine (XDrawWindow window) gcontext
+                     (XPoint x y) (XPoint x (y+30*18)) `thenIO` \() ->  
+		       drawvlines (x+30) y (z+1)
+                | otherwise
+                   = returnIO ()
+
+  drawhlines :: Int -> Int -> Int -> IO ()
+  drawhlines x y z 
+                | z <= 19
+                   = xDrawLine (XDrawWindow window) gcontext
+                     (XPoint x y) (XPoint (x+30*18) y) `thenIO` \() -> 
+                       drawhlines x (y+30) (z+1)
+                | otherwise 
+                   = returnIO ()
+
+  drawmarks :: IO ()
+  drawmarks =
+            map2IO (\x y ->
+                     xDrawArc (XDrawWindow window) gcontext 
+                              (XArc x y 6 6 (-1.0) 6.283) True)
+                   (map (\x -> 30 + x*30-3) [3,9,15,3,9,15,3,9,15])
+                   (map (\x -> 30 + x*30-3) [3,3,3,9,9,9,15,15,15])
+            `thenIO` \ _ -> returnIO ()
+
+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)
+
+drawPieces 20 _ board xinfo = returnIO ()
+drawPieces x 20 board xinfo = drawPieces (x+1) 1 board xinfo
+drawPieces x y board xinfo = 
+  xMArrayLookup board ((x-1)*19 + y-1) `thenIO` \ piece ->
+  (if (piece == 1 || piece == 2)
+   then drawPiece x y xinfo (piece == 1)
+   else returnIO ()) `thenIO` \ _ ->
+  drawPieces x (y+1) board xinfo
+  
+drawPiece x y (XInfo display window gcontext gcontext2 _ ) is_black =
+  (if is_black then returnIO ()
+               else xDrawArc (XDrawWindow window) gcontext2 
+                             (XArc (30*x-10) (30*y-10) 20 20
+                             (-1.0) 6.283)
+                             True) `thenIO` \ _ -> 
+  xDrawArc (XDrawWindow window) gcontext 
+           (XArc (30*x-10) (30*y-10) 20 20
+  	   (-1.0) 6.283)
+           is_black `thenIO` \ _ ->
+  xDisplayForceOutput display
+
diff --git a/progs/demo/X11/gobang/redraw.hu b/progs/demo/X11/gobang/redraw.hu
new file mode 100644
index 0000000..7d5aa14
--- /dev/null
+++ b/progs/demo/X11/gobang/redraw.hu
@@ -0,0 +1,4 @@
+:o= all
+$HASKELL_LIBRARY/X11/xlib.hu
+redraw.hs
+utilities.hs
diff --git a/progs/demo/X11/gobang/utilities.hs b/progs/demo/X11/gobang/utilities.hs
new file mode 100644
index 0000000..fe2483b
--- /dev/null
+++ b/progs/demo/X11/gobang/utilities.hs
@@ -0,0 +1,305 @@
+module Utilities where
+
+import Xlib
+import Weights
+import Redraw
+import Misc
+ 
+data XInfo = XInfo XDisplay XWindow XGcontext XGcontext XGcontext
+data GameState = GameState (XMArray String) (XMArray String) (XMArray Int)
+                           (XMArray Int) (XMArray Int) (XMArray Int) 
+                           (XMArray Integer) (XMArray Int)
+                           (XMArray String) (XMArray Int)
+
+type GameCont = XInfo -> GameState -> IO ()
+
+xMArrayToList :: XMArray a -> IO [a]
+xMArrayToList a = 
+   let la = xMArrayLength a
+       loop i a = if i == la then returnIO []
+                  else xMArrayLookup a i `thenIO` \ x ->
+                       loop (i+1) a `thenIO` \ xs ->
+                       returnIO (x:xs)
+   in
+   loop 0 a
+
+
+readGameState str =
+  let
+    [(board_lst, r1)] = reads str
+    [(weight1_lst, r2)] = reads r1
+    [(weight2_lst, r3)] = reads r2
+    [(steps_lst, r4)] = reads r3
+    [(player1_lst, r5)] = reads r4
+    [(player2_lst, r6)] = reads r5
+    [(time_lst, r7)] = reads r6
+    [(numbersteps_lst, r8)] = reads r7
+    [(promptString_lst, r9)] = reads r8
+    [(next_player_lst, [])] = reads r9
+  in
+  xMArrayCreate board_lst `thenIO` \ board ->
+  xMArrayCreate weight1_lst `thenIO` \ weight1 ->
+  xMArrayCreate weight2_lst `thenIO` \ weight2 ->
+  xMArrayCreate steps_lst `thenIO` \ steps ->
+  xMArrayCreate player1_lst `thenIO` \ player1 ->
+  xMArrayCreate player2_lst `thenIO` \ player2 ->
+  xMArrayCreate time_lst `thenIO`  \ time ->
+  xMArrayCreate numbersteps_lst `thenIO` \ numbersteps ->
+  xMArrayCreate promptString_lst `thenIO` \ promptString ->
+  xMArrayCreate next_player_lst `thenIO` \ next_player ->
+  returnIO (GameState player1 player2 board steps weight1 weight2 time
+                      numbersteps promptString next_player)
+
+showGameState (GameState player1 player2 board steps weight1 weight2 time
+                      numbersteps promptString next_player) =
+  xMArrayToList board `thenIO` \ board_lst ->
+  xMArrayToList weight1 `thenIO` \ weight1_lst ->
+  xMArrayToList weight2 `thenIO` \ weight2_lst ->
+  xMArrayToList steps `thenIO` \ steps_lst ->
+  xMArrayToList player1 `thenIO` \ player1_lst ->
+  xMArrayToList player2 `thenIO` \ player2_lst ->
+  xMArrayToList time `thenIO`  \ time_lst ->
+  xMArrayToList numbersteps `thenIO` \ numbersteps_lst ->
+  xMArrayToList promptString `thenIO` \ promptString_lst ->
+  xMArrayToList next_player `thenIO` \ next_player_lst ->
+  let
+    str =(shows board_lst .
+          shows weight1_lst .
+          shows weight2_lst .
+          shows steps_lst .
+          shows player1_lst .
+          shows player2_lst .
+          shows time_lst .
+          shows numbersteps_lst .
+          shows promptString_lst .
+          shows next_player_lst) []
+  in
+  returnIO str
+
+                   
+xMod      :: Int -> Int -> Int
+xMod x y | x >= y      = xMod (x-y) y 
+         | otherwise   = x
+
+xRes      :: Int -> Int -> Int -> Int
+xRes x y z | x >= y     = xRes (x-y) y (z+1) 
+           | otherwise = z
+
+drawCmd :: String -> XInfo -> GameState -> IO ()
+drawCmd a (XInfo display window gcontext gcontext2 gcontextp)
+          (GameState _ _ _ _ _ _ _ _ str _)
+           = xDrawRectangle (XDrawWindow window) gcontext2
+                (XRect 616 536 248 28) True `thenIO` \ () ->
+             xDrawGlyphs (XDrawWindow window) gcontext 
+                         (XPoint 620 550) a  `thenIO` \ _ ->
+             xMArrayUpdate str 0 a `thenIO` \ _ ->
+             xDisplayForceOutput display
+
+clearCmd :: XInfo -> GameState -> IO ()
+clearCmd (XInfo display window gcontext gcontext2 gcontextp)
+         (GameState _ _ _ _ _ _ _ _ str _)
+          = xDrawRectangle (XDrawWindow window) gcontext2
+                (XRect 616 536 248 28) True `thenIO` \() ->
+            xMArrayUpdate str 0 "" `thenIO` \ _ ->
+            xDisplayForceOutput display 
+
+xPosition :: Int -> XPoint
+xPosition  a = (XPoint (xRes a 19 1) (1+ (xMod a 19)))
+
+initArray :: XMArray a -> Int -> Int -> a -> IO ()
+initArray mary x y z | x<y       = xMArrayUpdate mary x z `thenIO` \() ->
+                                   initArray mary (x+1) y z
+                     | otherwise = returnIO ()
+
+getposition :: Int -> Int -> XMaybe (Int, Int)
+getposition x y = let x1 = round ((fromIntegral x) / 30.0)
+                      y1 = round ((fromIntegral y) / 30.0)
+                  in
+                  if (x1 < 1 || x1 > 19 || y1 < 1 || y1 > 19) then XNull
+                  else XSome (x1, y1)
+
+addZero :: Int -> String
+addZero a | a < 10    = "0"
+          | otherwise =  ""
+
+printTime :: Int -> Int -> [Int] -> XInfo -> IO()
+printTime x y zs (XInfo display window gcontext gcontext2 gcontextp)
+           = let s = head zs
+                 m = head (tail zs)
+                 h = head (tail (tail zs))
+             in  xDrawRectangle (XDrawWindow window) gcontext2 
+                     (XRect (x-4) (y-24) 88 28) True `thenIO` \() ->
+                 xDrawGlyphs (XDrawWindow window) gcontextp (XPoint x y)
+                    ((addZero h)++(show h)++":"++(addZero m)++(show m)++
+                          ":"++(addZero s)++(show s))
+                    `thenIO` \(trash) ->
+                 xDisplayForceOutput display
+
+showtime :: Int -> Int -> Integer -> XInfo -> IO()
+showtime x y z a = 
+  let (curtm, c) = (decodeTime z (WestOfGMT 0))
+  in  printTime x y curtm a
+
+helpButton :: XInfo -> IO ()
+helpButton (XInfo display window  gcontext gcontext2 gcontextp) = 
+        xDrawRectangle (XDrawWindow window) gcontext (XRect 800 420 70 70)
+                       False `thenIO` \ _ ->
+        xDrawRectangle (XDrawWindow window) gcontext (XRect 802 422 66 66)
+                       False `thenIO` \ _ ->
+        xDrawGlyphs (XDrawWindow window) gcontextp (XPoint 810 450) "About" 
+        `thenIO` \ _ ->
+        xDrawGlyphs (XDrawWindow window) gcontext (XPoint 820 470) "Gobang" 
+        `thenIO` \ _ ->
+        returnIO ()
+
+ishelp :: Int -> Int -> Bool
+ishelp x y = (x > 800 && x < 870 && y > 420 && y < 490)
+
+button :: Int -> Int -> String -> XInfo -> IO()
+button x y a (XInfo display window  gcontext gcontext2 gcontextp) = 
+        xDrawArc (XDrawWindow window) gcontext 
+          (XArc (x-40) (y-10) 20 20 1.5708 4.7124) True  `thenIO` \() ->
+        xDrawRectangle (XDrawWindow window) gcontext 
+          (XRect (x-30) (y-10) 60 20) True  `thenIO` \() ->
+        xDrawArc (XDrawWindow window) gcontext
+          (XArc (x+20) (y-10) 20 20 (-1.0) 6.283) True `thenIO` \() ->
+        xDrawGlyphs (XDrawWindow window) gcontext2 
+          (XPoint (x-(length a * 3)) (y+4)) a   `thenIO` \(trash) ->
+        xDisplayForceOutput display
+
+-- a b are the location of the button, c d are the point where we press the
+-- button.
+
+buttonPress :: Int -> Int -> Int -> Int -> Bool
+buttonPress a b c d | (abs (c-a))<=30 && (abs (d-b))<=10   = True
+                    | (c-a+30)*(c-a+30)+(d-b)*(d-b)<=100   = True
+                    | (c-a-30)*(c-a-30)+(d-b)*(d-b)<=100   = True
+                    | otherwise                            = False
+
+
+
+randmax :: XMArray Int -> Int -> Int -> [Int] -> IO Int
+randmax a ind max mi | ind > 360  = 
+                       let lmi = length mi
+                       in case lmi of
+                          0 -> returnIO (-1)
+                          1 -> returnIO (head mi)
+                          _ -> random lmi `thenIO` \ i ->
+                               returnIO (mi !! i)
+                     | otherwise  = xMArrayLookup a ind `thenIO` \ tt3 ->
+                                    if (tt3 > max) 
+                                    then randmax a (ind+1) tt3 [ind]
+                                    else if (tt3 == max) 
+                                         then randmax a (ind+1) max (ind:mi)
+                                         else randmax a (ind+1) max mi
+
+robot :: XMArray Int -> XMArray Int -> XMArray Int -> IO XPoint
+robot numbersteps weight1 weight2
+      = xMArrayLookup numbersteps 0 `thenIO` \(tt5) ->
+        if (tt5 == 0)
+           then returnIO (XPoint 10 10)
+           else
+		randmax weight1 0 0 [] `thenIO` \ tmp1 ->
+		randmax weight2 0 0 [] `thenIO` \ tmp2 ->
+		xMArrayLookup weight1 tmp1 `thenIO` \ tmp3 ->
+                xMArrayLookup weight2 tmp2 `thenIO` \ tmp4 ->
+                  if (tmp3 >= 200) 
+                      then returnIO (xPosition tmp1)
+                      else if (tmp3 > tmp4)
+                               then returnIO (xPosition tmp1)
+                               else returnIO (xPosition tmp2)
+
+
+promptFor prompt xinfo state =
+  let (GameState player1 player2 board steps weight1 weight2 time
+                 numbersteps promptString next_player) = state
+      (XInfo display window gcontext gcontext2 gcontextp) = xinfo
+  in
+  xDrawRectangle (XDrawWindow window) gcontext2
+                 (XRect 616 536 248 28) True `thenIO` \() ->
+  xMArrayUpdate promptString 0 prompt `thenIO` \ _ -> 
+  xDrawGlyphs (XDrawWindow window) gcontext (XPoint 620 550) prompt
+  `thenIO` \ _ ->
+  xDisplayForceOutput display `thenIO` \ _ ->
+  let h_base = (length prompt + 1) * 6 + 620
+      getString :: Int -> String -> IO String
+      getString h_pos sofar =
+        xGetEvent display `thenIO` \event ->
+        case (xEventType event) of
+          XButtonPressEvent -> 
+            let (XPoint x y) = xEventPos event
+            in 
+            (if ishelp x y then helpGame xinfo state 
+             else xBell display 0)
+            `thenIO` \ _ ->
+            getString h_pos sofar
+          XExposureEvent -> 
+            may_redraw (xEventCount event == 0) xinfo state `thenIO` \ _ ->
+            xDrawGlyphs (XDrawWindow window) gcontext (XPoint h_base 550) sofar
+            `thenIO` \ _ ->
+            xDrawRectangle (XDrawWindow window) gcontext
+                           (XRect (h_base + 6 * h_pos) (550-10) 6 13) True
+            `thenIO` \ _ -> getString h_pos sofar
+          XKeyPressEvent -> 
+            let code = xEventCode event
+                state = xEventState event
+                bs = if (sofar == "") then getString h_pos sofar
+                     else xDrawRectangle (XDrawWindow window) gcontext2 
+                                         (XRect (h_base + 6 * h_pos) 
+                                                (550-10) 6 13) 
+                                         True `thenIO` \ _ ->
+                          xDrawRectangle (XDrawWindow window) gcontext 
+                                         (XRect (h_base + 6 * (h_pos - 1)) 
+                                                (550-10) 6 13) 
+                                         True `thenIO` \ _ -> 
+                          getString (h_pos-1) (take (length sofar - 1) sofar) 
+            in  
+            xKeycodeCharacter display code state `thenIO` \ char ->
+            case char of
+               (XSome '\r') -> returnIO sofar
+               (XSome '\DEL') -> bs
+               (XSome '\BS') -> bs
+               XNull     -> getString h_pos sofar
+               (XSome c) -> xDrawRectangle (XDrawWindow window) gcontext2 
+                                           (XRect (h_base + 6 * h_pos) 
+                                                  (550-10) 6 13) 
+                                           True `thenIO` \ _ -> 
+                            xDrawGlyph (XDrawWindow window) gcontext
+                                       (XPoint (h_base + 6 * h_pos) 550) c
+                            `thenIO` \ _ ->
+                            xDrawRectangle (XDrawWindow window) gcontext 
+                                           (XRect (h_base + 6 * (h_pos + 1)) 
+                                                  (550-10) 6 13) 
+                                           True `thenIO` \ _ -> 
+                            getString (h_pos + 1) (sofar ++ [c])
+
+  in 
+  xDrawRectangle (XDrawWindow window) gcontext
+                 (XRect h_base (550-10) 6 13) True
+  `thenIO` \ _ ->
+  getString 0 ""
+
+
+helpGame xinfo@(XInfo display window gcontext gcontext2 gcontextp) state =
+  drawHelp xinfo `thenIO` \ _ ->
+  let
+    loop xinfo state = 
+      xGetEvent display `thenIO` \ event ->
+      case (xEventType event) of
+        XExposureEvent -> may_redraw (xEventCount event == 0) xinfo state 
+                          `thenIO` \ _ ->
+                          drawHelp xinfo `thenIO` \ _ ->
+                          loop xinfo state
+        XButtonPressEvent -> 
+                          let (XPoint x y) = xEventPos event
+                          in
+                          if (x > 200 && x < 300 && y > 230 && y < 290) 
+                          then redraw xinfo state `thenIO` \ _ -> 
+                               returnIO ()
+                          else loop xinfo state
+        _              -> xBell display 0 `thenIO` \ _ ->
+                          loop xinfo state
+  in
+  loop xinfo state
+
+
diff --git a/progs/demo/X11/gobang/utilities.hu b/progs/demo/X11/gobang/utilities.hu
new file mode 100644
index 0000000..bfccbfe
--- /dev/null
+++ b/progs/demo/X11/gobang/utilities.hu
@@ -0,0 +1,6 @@
+:o= all
+$HASKELL_LIBRARY/X11/xlib.hu
+utilities.hs
+weights.hs
+redraw.hs
+misc.hi
diff --git a/progs/demo/X11/gobang/weights.hs b/progs/demo/X11/gobang/weights.hs
new file mode 100644
index 0000000..1b55553
--- /dev/null
+++ b/progs/demo/X11/gobang/weights.hs
@@ -0,0 +1,323 @@
+module Weights where
+
+import Xlib
+import Utilities
+
+xlookup :: XMArray Int -> Int -> Int -> IO Int
+xlookup keyboard x y =
+      if (x < 1 || x > 19 || y < 1 || y > 19) 
+      then returnIO (-2)
+      else xMArrayLookup keyboard ((x-1)*19+(y-1))
+
+
+draw_unit :: XMArray Int -> XMArray Int -> XMArray Int -> Int -> Int  -> IO()
+draw_unit keyboard weight1 weight2 x y = 
+  let 
+    update_weight :: XMArray Int->Int->Int->Int->Int->Int->Int->IO()
+    update_weight weight counter player x y incr_x incr_y 
+      | x>=1 && x<=19 && y>=1 && y<=19 && counter<=4 = 
+          cpt_weight x y player `thenIO` \wt -> 
+            xMArrayUpdate weight ((x-1)*19+(y-1)) wt `thenIO` \() ->
+              update_weight weight (counter+1) player (x+incr_x) (y+incr_y)
+	                    incr_x incr_y
+      | otherwise = returnIO ()
+----------------------------------------------------------------------------
+
+    pattern0 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool
+    pattern0 a b c d e p | a==p && b==p && c==p && d==p && e==p = True
+	                 | otherwise                            = False
+----------------------------------------------------------------------------
+
+    pattern1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool 
+    pattern1 a b c d e f p  | (a==0) && (b==p) && (c==p) && (d==p) && (e==p) &&
+                              (f==0)     = True
+	       		    | otherwise  = False     
+----------------------------------------------------------------------------
+ 
+    pattern2 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern2 a b c d e p | (a==0 && b==p && c==p && d==p && e==p)||
+                           (a==p && b==p && c==p && d==p && e==0) = True 
+			 | otherwise                              = False     
+----------------------------------------------------------------------------
+           
+    pattern3 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern3 a b c d e p | (a==0 && b==p && c==p && d==p && e==0) = True
+                         | otherwise                              = False 
+----------------------------------------------------------------------------
+           
+    pattern4 :: Int -> Int -> Int -> Int -> Int ->  Bool  
+    pattern4 a b c d p | (a==0 && b==p && c==p && d==p) ||
+                         (a==p && b==p && c==p && d==0) = True
+                       | otherwise                      = False      
+----------------------------------------------------------------------------
+           
+    pattern5 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern5 a b c d e f p  | (a==0 && b==p && c==p && d==0 && e==p && 
+                               f==0) ||
+                              (a==0 && b==p && c==0 && d==p && e==p &&
+                               f==0)    = True
+			    | otherwise = False     
+----------------------------------------------------------------------------
+           
+    pattern6 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern6 a b c d e p | (a==0 && b==p && c==p && d==0 && e==p) ||
+                           (a==0 && b==p && c==0 && d==p && e==p) || 
+                           (a==p && b==p && c==0 && d==p && e==0) || 
+                           (a==p && b==0 && c==p && d==p && e==0) = True
+			 | otherwise = False     
+----------------------------------------------------------------------------
+           
+    pattern7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int-> Bool
+    pattern7 a b c d e f g p | (a==0 && b==p && c==0 && d==p && e==0 &&
+                                 f==p && g==0) = True
+			     | otherwise       = False     
+----------------------------------------------------------------------------
+           
+    pattern8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern8 a b c d e f p | (a==0 && b==p && c==0 && d==p && e==0 &&
+                              f==p) ||
+                             (a==p && b==0 && c==p && d==0 && e==p &&
+		              f==0) = True 
+                           | otherwise = False     
+----------------------------------------------------------------------------
+           
+    pattern9 :: Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern9 a b c d p | (a==0 && b==p && c==p && d==0) = True
+                       | otherwise                      = False     
+----------------------------------------------------------------------------
+           
+    pattern10 :: Int -> Int -> Int -> Int -> Bool  
+    pattern10 a b c p | (a==0 && b==p && c==p) ||
+                        (a==p && b==p && c==0) = True
+                      | otherwise              = False         
+----------------------------------------------------------------------------
+           
+    pattern11 :: Int -> Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern11 a b c d e p | (a==0 && b==p && c==0 && d==p && e==0) = True
+                          | otherwise                              = False     
+----------------------------------------------------------------------------
+           
+    pattern12 :: Int -> Int -> Int -> Int -> Int -> Bool  
+    pattern12 a b c d p | (a==0 && b==p && c==0 && d==p) ||
+                          (a==p && b==0 && c==p && d==0) = True
+                        | otherwise                      = False   
+----------------------------------------------------------------------------
+ 
+    direct1 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> 
+               Int -> Int -> Int -> Int -> Int -> Int
+    direct1 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1 pl) ||
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2 pl) ||
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3 pl) ||
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4 pl) = 200
+      | (pattern1  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern1  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
+    	(pattern1  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
+	(pattern1  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 40
+      | (pattern2  ptN4 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern2  ptN3 ptN2 ptN1 pt ptP1 pl) ||
+    	(pattern2  ptN2 ptN1 pt ptP1 ptP2 pl) ||
+	(pattern2  ptN1 pt ptP1 ptP2 ptP3 pl) = 13
+      | (pattern3  ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern3  ptN2 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern3  ptN1 pt ptP1 ptP2 ptP3 pl) = 10
+      | (pattern4  ptN3 ptN2 ptN1 pt pl) ||
+        (pattern4  ptN2 ptN1 pt ptP1 pl) ||
+        (pattern4  ptN1 pt ptP1 ptP2 pl) = 8
+      | (pattern5  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern5  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern5  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || 
+        (pattern5  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) = 9
+      | (pattern6  ptN4 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern6  ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern6  ptN2 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern6  ptN1 pt ptP1 ptP2 ptP3 pl) = 7
+      | (pattern7  ptN5 ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern7  ptN4 ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
+	(pattern7  ptN3 ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) || 
+        (pattern7  ptN2 ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) ||
+        (pattern7  ptN1 pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 6   
+      | (pattern8  ptN5 ptN4 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern8  ptN4 ptN3 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern8  ptN3 ptN2 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern8  ptN2 ptN1 pt ptP1 ptP2 ptP3 pl) ||
+        (pattern8  ptN1 pt ptP1 ptP2 ptP3 ptP4 pl) || 
+        (pattern8  pt ptP1 ptP2 ptP3 ptP4 ptP5 pl) = 5
+      | (pattern9  ptN2 ptN1 pt ptP1 pl) || 
+        (pattern9  ptN1 pt ptP1 ptP2 pl) = 4
+      | (pattern10 ptN2 ptN1 pt pl) ||
+        (pattern10 ptN1 pt ptP1 pl) ||
+        (pattern10 pt ptP1 ptP2 pl) = 2
+      | (pattern11 ptN3 ptN2 ptN1 pt ptP1 pl) || 
+        (pattern11 ptN2 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern11 ptN1 pt ptP1 ptP2 ptP3 pl) = 3
+      | (pattern12 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern12 ptN2 ptN1 pt ptP1 pl) ||
+        (pattern12 ptN1 pt ptP1 ptP2 pl) ||
+        (pattern12 pt ptP1 ptP2 ptP3 pl) = 1
+      | otherwise = 0
+----------------------------------------------------------------------------
+
+    direct2 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> 
+               Int -> Int -> Int -> Int -> Int -> Int
+    direct2 x y pl ptN1 ptN2 ptN3 ptN4 ptN5 pt ptP1 ptP2 ptP3 ptP4 ptP5
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt pl) ||
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1 pl) ||
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2 pl) ||
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3 pl) ||
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4 pl) = 200
+      | otherwise = 0
+-----------------------------------------------------------------------------
+
+    cpt_weight :: Int -> Int -> Int -> IO Int
+    cpt_weight x y player = 
+      xMArrayLookup keyboard ((x-1)*19+(y-1)) `thenIO` \(unit) -> 
+      if (unit /= 0) 
+        then returnIO (-1) 
+        else xlookup keyboard x (y-1) `thenIO` \(xyN1) ->
+             xlookup keyboard x (y-2) `thenIO` \(xyN2) ->
+             xlookup keyboard x (y-3) `thenIO` \(xyN3) ->
+	     xlookup keyboard x (y-4) `thenIO` \(xyN4) ->
+	     xlookup keyboard x (y-5) `thenIO` \(xyN5) ->
+	     xlookup keyboard x (y+1) `thenIO` \(xyP1) ->
+	     xlookup keyboard x (y+2) `thenIO` \(xyP2) ->
+	     xlookup keyboard x (y+3) `thenIO` \(xyP3) ->
+	     xlookup keyboard x (y+4) `thenIO` \(xyP4) ->
+	     xlookup keyboard x (y+5) `thenIO` \(xyP5) ->
+	     xlookup keyboard (x-1) y `thenIO` \(xN1y) ->
+	     xlookup keyboard (x-2) y `thenIO` \(xN2y) ->
+             xlookup keyboard (x-3) y `thenIO` \(xN3y) ->
+	     xlookup keyboard (x-4) y `thenIO` \(xN4y) ->
+	     xlookup keyboard (x-5) y `thenIO` \(xN5y) ->
+	     xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
+	     xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
+	     xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
+	     xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
+	     xlookup keyboard (x+5) y `thenIO` \(xP5y) ->
+	     xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)->
+             xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) ->
+             xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) ->
+             xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) ->
+             xlookup keyboard (x-5) (y-5) `thenIO` \(xN5yN5) ->
+             xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) ->
+             xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) ->
+             xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) ->
+             xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) ->
+             xlookup keyboard (x+5) (y+5) `thenIO` \(xP5yP5) ->
+             xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> 
+             xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) ->
+             xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> 
+             xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> 
+             xlookup keyboard (x-5) (y+5) `thenIO` \(xN5yP5) -> 
+             xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> 
+             xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> 
+             xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> 
+             xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> 
+             xlookup keyboard (x+5) (y-5) `thenIO` \(xP5yN5) ->
+	     returnIO ( (direct1 x y player xyN1 xyN2 xyN3 xyN4 xyN5 player
+	                         xyP1 xyP2 xyP3 xyP4 xyP5) + 
+	                (direct1 x y player xN1y xN2y xN3y xN4y xN5y player
+	                         xP1y xP2y xP3y xP4y xP5y) +
+                        (direct1 x y player xN1yN1 xN2yN2 xN3yN3 xN4yN4 
+			         xN5yN5 player xP1yP1 xP2yP2 xP3yP3 xP4yP4
+				 xP5yP5) + 
+	                (direct1 x y player xN1yP1 xN2yP2 xN3yP3 xN4yP4 
+			         xN5yP5 player xP1yN1 xP2yN2 xP3yN3 xP4yN4
+				 xP5yN5) )
+-----------------------------------------------------------------------------
+
+--                        | 1111 && no_block = 20
+--			  | 1111 && one_block = 13
+--			  | 111 && no_block = 10
+--			  | 111 && one_block = 8
+--			  | 11 1 or 1 11 && no_block = 9
+--			  | 11 1 or 1 11 && one_block =7
+--                        | 1 1 1 && no_block = 6
+--			  | 1 1 1 && one_block= 5
+--			  | 11 && no_block = 4
+--			  | 11 && one_block =2
+--			  | 1 1 && no_block =3
+--			  | 1 1 && one_block=1
+
+  in
+    update_weight weight1 0 1 x y 1    1    `thenIO` \() ->
+    update_weight weight2 0 2 x y 1    1    `thenIO` \() ->
+    update_weight weight1 0 1 x y 1    (-1) `thenIO` \() ->
+    update_weight weight2 0 2 x y 1    (-1) `thenIO` \() ->
+    update_weight weight1 0 1 x y (-1) (-1) `thenIO` \() ->
+    update_weight weight2 0 2 x y (-1) (-1) `thenIO` \() ->
+    update_weight weight1 0 1 x y (-1) 1    `thenIO` \() ->  
+    update_weight weight2 0 2 x y (-1) 1    `thenIO` \() ->    
+    update_weight weight1 0 1 x y 0    1    `thenIO` \() ->
+    update_weight weight2 0 2 x y 0    1    `thenIO` \() ->
+    update_weight weight1 0 1 x y 0    (-1) `thenIO` \() ->
+    update_weight weight2 0 2 x y 0    (-1) `thenIO` \() ->
+    update_weight weight1 0 1 x y (-1) 0    `thenIO` \() ->
+    update_weight weight2 0 2 x y (-1) 0    `thenIO` \() ->  
+    update_weight weight1 0 1 x y 1    0    `thenIO` \() ->   
+    update_weight weight2 0 2 x y 1    0    `thenIO` \() ->  
+    returnIO ()
+
+
+human_unit :: XMArray Int -> Int -> Int  -> IO(Bool)
+human_unit keyboard x y =
+  let    
+    pattern0 :: Int -> Int -> Int -> Int -> Int -> Bool
+    pattern0 a b c d e | a==b && b==c && c==d && d==e = True
+	               | otherwise                    = False    
+			 
+    direct3 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> 
+               Int
+    direct3 ptN1 ptN2 ptN3 ptN4 pt ptP1 ptP2 ptP3 ptP4 
+      | (pattern0  ptN4 ptN3 ptN2 ptN1 pt) ||
+        (pattern0  ptN3 ptN2 ptN1 pt ptP1) ||
+    	(pattern0  ptN2 ptN1 pt ptP1 ptP2) ||
+	(pattern0  ptN1 pt ptP1 ptP2 ptP3) ||
+        (pattern0  pt ptP1 ptP2 ptP3 ptP4) = 200
+      | otherwise = 0
+  in
+    xlookup keyboard x y `thenIO` \(xy) ->
+    xlookup keyboard x (y-1) `thenIO` \(xyN1) ->
+    xlookup keyboard x (y-2) `thenIO` \(xyN2) ->
+    xlookup keyboard x (y-3) `thenIO` \(xyN3) ->
+    xlookup keyboard x (y-4) `thenIO` \(xyN4) ->
+    xlookup keyboard x (y+1) `thenIO` \(xyP1) ->
+    xlookup keyboard x (y+2) `thenIO` \(xyP2) ->
+    xlookup keyboard x (y+3) `thenIO` \(xyP3) ->
+    xlookup keyboard x (y+4) `thenIO` \(xyP4) ->
+    xlookup keyboard (x-1) y `thenIO` \(xN1y) ->
+    xlookup keyboard (x-2) y `thenIO` \(xN2y) ->
+    xlookup keyboard (x-3) y `thenIO` \(xN3y) ->
+    xlookup keyboard (x-4) y `thenIO` \(xN4y) ->            
+    xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
+    xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
+    xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
+    xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
+    xlookup keyboard (x-1) (y-1) `thenIO` \(xN1yN1)->
+    xlookup keyboard (x-2) (y-2) `thenIO` \(xN2yN2) ->
+    xlookup keyboard (x-3) (y-3) `thenIO` \(xN3yN3) ->
+    xlookup keyboard (x-4) (y-4) `thenIO` \(xN4yN4) ->
+    xlookup keyboard (x+1) (y+1) `thenIO` \(xP1yP1) ->
+    xlookup keyboard (x+2) (y+2) `thenIO` \(xP2yP2) ->
+    xlookup keyboard (x+3) (y+3) `thenIO` \(xP3yP3) ->
+    xlookup keyboard (x+4) (y+4) `thenIO` \(xP4yP4) ->
+    xlookup keyboard (x-1) (y+1) `thenIO` \(xN1yP1) -> 
+    xlookup keyboard (x-2) (y+2) `thenIO` \(xN2yP2) ->
+    xlookup keyboard (x-3) (y+3) `thenIO` \(xN3yP3) -> 
+    xlookup keyboard (x-4) (y+4) `thenIO` \(xN4yP4) -> 
+    xlookup keyboard (x+1) (y-1) `thenIO` \(xP1yN1) -> 
+    xlookup keyboard (x+2) (y-2) `thenIO` \(xP2yN2) -> 
+    xlookup keyboard (x+3) (y-3) `thenIO` \(xP3yN3) -> 
+    xlookup keyboard (x+4) (y-4) `thenIO` \(xP4yN4) -> 
+    xlookup keyboard (x+1) y `thenIO` \(xP1y) ->
+    xlookup keyboard (x+2) y `thenIO` \(xP2y) ->
+    xlookup keyboard (x+3) y `thenIO` \(xP3y) ->
+    xlookup keyboard (x+4) y `thenIO` \(xP4y) ->
+    if ((direct3 xyN1 xyN2 xyN3 xyN4 xy xyP1 xyP2 xyP3 xyP4) +
+        (direct3 xN1y xN2y xN3y xN4y xy xP1y xP2y xP3y xP4y) +  
+	(direct3 xN1yN1 xN2yN2 xN3yN3 xN4yN4 xy xP1yP1 xP2yP2 xP3yP3 xP4yP4) +
+        (direct3 xN1yP1 xN2yP2 xN3yP3 xN4yP4 xy xP1yN1 xP2yN2 xP3yN3 xP4yN4)) 
+       >=200 
+      then returnIO (True)
+      else returnIO (False)
\ No newline at end of file
diff --git a/progs/demo/X11/gobang/weights.hu b/progs/demo/X11/gobang/weights.hu
new file mode 100644
index 0000000..f13aba0
--- /dev/null
+++ b/progs/demo/X11/gobang/weights.hu
@@ -0,0 +1,4 @@
+:o= all
+$HASKELL_LIBRARY/X11/xlib.hu
+weights.hs
+utilities.hs
diff --git a/progs/demo/X11/graphics/README b/progs/demo/X11/graphics/README
new file mode 100644
index 0000000..77a2d66
--- /dev/null
+++ b/progs/demo/X11/graphics/README
@@ -0,0 +1,31 @@
+HENDERSON GRAPHICS LIBRARY
+by Syam Gadde
+and Bo Whong
+
+-------------------------------------------------
+
+To use the Henderson Library, run emacs with a module that
+imports HendersonLib, such as "sqrlmt.hs".  For "sqrlmt.hs",
+run the dialogue "final" or "skewedfinal".  
+
+-------------------------------------------------
+
+henderson.hs	- Haskell source for the Henderson library.
+henderson.hu	
+sqrlmt.hs	- Haskell source for dialogue that draws "Square Limit".
+sqrlmt.hu	
+p.pic		- First of four pictures used to construct "Square Limit".
+q.pic		- Second of four pictures used to construct "Square Limit".
+r.pic		- Third of four pictures used to construct "Square Limit".
+s.pic		- Four of four pictures used to construct "Square Limit".
+new.pic		- Hudak's house
+stop.pic	- A "hand-drawn" stop sign border
+text.pic	- The word "STOP!" (hand-drawn)
+strange.pic	- Overlays stop.pic and Flip of text.pic
+squarebox.xwd	- A window dump of a box-like structure made of four
+			square limits.  Use "xwud -in squarebox.xwd" to view.
+sksl.xwd	- A window dump of "squarelimit" in a skewed bounding box.
+			("skewedfinal" from sqrlmt.hs.)
+sl.xwd		- A window dump of Square Limit.
+			("squarelimit" from sqrlmt.hs.)
+manual		- The manual in Island Write format.
diff --git a/progs/demo/X11/graphics/henderson.hs b/progs/demo/X11/graphics/henderson.hs
new file mode 100644
index 0000000..8b7e4ce
--- /dev/null
+++ b/progs/demo/X11/graphics/henderson.hs
@@ -0,0 +1,465 @@
+-- Peter Henderson's Recursive Geometry
+-- Syam Gadde and Bo Whong
+-- full set of modules
+-- CS429 Project
+-- 4/30/93
+
+module HendersonLib (Hostname(..), Filename(..), VTriple(..), HendQuartet(..),
+                     Picture(..), sendToDraw, draw, create, modify, plot) where
+import Xlib
+
+-- ADTs and Type Synonyms --------------------------------------------------
+data Picture = Nil
+             | Flip Picture
+             | Beside Float Picture Float Picture
+	     | Above Float Picture Float Picture
+	     | Rot Picture
+	     | File String
+	     | Overlay Picture Picture
+	     | Grid Int Int SegList
+	     deriving Text
+
+data Plot = Plot Picture VTriple
+          | Union Plot Plot
+
+type Hostname = String
+type Filename = String
+type IntPoint = (Int,Int)
+type IntSegment = (IntPoint, IntPoint)
+type IntSegList = [IntSegment]
+type Point = (Float,Float)
+type Segment = (Point, Point)
+type SegList = [Segment]
+type Vector = Point
+type VTriple = (Vector, Vector, Vector)
+type HendQuartet = (Int, Int, Int, Int)
+type PEnv = [(Filename, Picture)]
+
+-- vector Functions --------------------------------------------------------
+-- for adding, negating, multiplying, and dividing vectors
+
+addV :: Vector -> Vector -> Vector
+addV (x1,y1) (x2,y2) = (x1+x2, y1+y2)
+
+negateV :: Vector -> Vector
+negateV (x,y) = (-x,-y)
+
+multV ::  Float-> Vector -> Vector
+multV a (x,y) = (a*x, a*y)
+
+divV :: Float -> Vector -> Vector
+divV a (x,y) = (x/a, y/a)
+
+-- plot Function -----------------------------------------------------------
+-- picture manipulation function
+
+plot :: Picture -> VTriple -> PEnv -> ((Plot, PEnv) -> IO()) -> IO()
+
+-- the Nil Picture is just "nothingness" so choose an abritrary representation
+--  of nothingness.
+plot Nil (v1, v2, v3) env cont = 
+  plot (Grid 1 1 []) (v1,v2,v3) env cont
+
+-- Flipping a Picture
+plot (Flip p1) (v1, v2, v3) env cont = 
+  plot p1 (addV v1 v2, negateV v2, v3) env cont
+
+-- Rotate a Picture 90 degrees counterclockwise
+plot (Rot p1) (v1, v2, v3) env cont = 
+  plot p1 (addV v1 v3, negateV v3, v2) env cont
+
+-- Overlay one Picture over another Picture
+plot (Overlay p q) (a,b,c) env cont =
+  plot p (a,b,c) env $ \ (plot1, env1) ->
+  plot q (a,b,c) env1 $ \ (plot2, env2) ->
+  cont ((Union plot1 plot2), env2)
+
+-- Place p1 Beside p2 with width ratio m to n
+plot (Beside m p1 n p2) (v1, v2, v3) env cont = 
+  plot p1 (v1, multV (m/(m+n)) v2, v3) env $ \ (plot1, env1) ->
+  plot p2 ((addV (multV (m/(m+n)) v2) v1), 
+	         (multV (n/(m+n)) v2), 
+                 v3) env1                  $ \ (plot2, env2) ->
+  cont ((Union plot1 plot2), env2)
+
+-- Place p Above q with height ratio m to n
+plot (Above m p n q) (a,b,c) env cont =
+  plot q (addV a (multV (m/(n+m)) c), b,  multV (n/(m+n)) c) env 
+    $ \ (plot1, env1) ->
+  plot p (a, b, multV (m/(m+n)) c) env1 $ \ (plot2, env2) ->
+  cont ((Union plot1 plot2), env2)
+
+-- the 'real' Picture
+plot (Grid x y s) (a,b,c) env cont =
+  cont ((Plot (Grid x y s) (a,b,c)), env)
+
+-- this picture is located in a File with name name
+--  lookup table: thanks to Sheng
+plot (File name) (a,b,c) env cont =
+  case (lookupEnv env name) of
+    ((_, pic):_) -> plot pic (a,b,c) env cont
+    []           ->
+       readFile name (\s -> appendChan stdout ("File "++name++" not able to be read\n") exit done)
+                     $ \s ->
+       let 
+        pic = read s 
+        newenv = (name,pic):env
+       in
+       plot pic (a,b,c) newenv cont 
+
+lookupEnv :: PEnv -> Filename -> PEnv
+lookupEnv [] _ = []
+lookupEnv ((a,b):es) name | a==name   = ((a,b):es)
+                          | otherwise = lookupEnv es name
+
+-- Draw Function -----------------------------------------------------------
+-- user function to draw pictures 
+
+draw :: Hostname -> Picture -> VTriple -> HendQuartet -> IO()
+
+-- opens a display, screen, and window (of size specified in HendQuartet)
+--  and draws Picture in the window
+draw host p (a,b,c) (hm,hn,ho,hp) = 
+ xOpenDisplay host `thenIO` \display ->       -- opens display
+  let (screen:_) = xDisplayRoots display
+      fg_color = xScreenBlackPixel screen
+      bg_color = xScreenWhitePixel screen
+      root = xScreenRoot screen
+  in 
+  xCreateWindow root                          -- opens window
+                (XRect hm hn ho hp)
+		[XWinBackground bg_color,
+		 XWinEventMask (XEventMask [XKeyPress, 
+		                            XExposure, 
+                                            XButtonPress])]
+  `thenIO` \window ->
+  xSetWmName window "Henderson Graphics" `thenIO` \() ->
+  xSetWmIconName window "Henderson Graphics" `thenIO` \() ->
+  xMapWindow window `thenIO` \() ->          -- show window
+  xDisplayForceOutput display `thenIO` \ () ->  -- show window NOW
+  xCreateGcontext (XDrawWindow (xScreenRoot screen))   -- open a GC
+                  [XGCBackground bg_color,
+		   XGCForeground fg_color] `thenIO` \ gcontext ->
+  plot p (a,b,c) [] $ \(plt,_) ->            -- make pic easier to work with
+  let
+    handleEvent =
+      xGetEvent display `thenIO` \event ->
+        case (xEventType event) of
+	  -- Has a part of the window been uncovered?
+	  XExposureEvent ->  sendToDraw window screen display gcontext plt
+	                     `thenIO` \() -> handleEvent
+          _              -> xCloseDisplay display
+  in
+  handleEvent
+
+-- SendToDraw Function -----------------------------------------------------
+-- called by draw to actually draw the lines onto the window
+
+sendToDraw :: XWindow -> XScreen -> XDisplay -> XGcontext -> Plot -> IO()
+
+-- have a Union.  so do one, and then the other. simple.
+sendToDraw win screen display gcontext (Union p1 p2) = 
+  sendToDraw win screen display gcontext p1 `thenIO` \() ->
+  sendToDraw win screen display gcontext p2
+
+-- have just a Plot.  have to do some dirty work.
+sendToDraw window screen display gcontext (Plot (Grid x y s) (a,b,c)) = 
+  let 
+    v2p :: Vector -> XPoint
+    v2p (e,f) = XPoint (round e) (round f)  -- convert Vector to an XPoint
+    fx :: Float
+    fx = fromIntegral x
+    fy :: Float
+    fy = fromIntegral y
+    drawit :: SegList -> IO()
+    -- draw the Grid one line at a time
+    drawit [] = done
+    drawit (((x0,y0),(x1,y1)):ss) =
+      xDrawLine (XDrawWindow window) 
+              gcontext 
+	      (v2p (addV (addV a (multV (x0/fx) b))
+	                 (multV (y0/fy) c)))
+	      (v2p (addV (addV a (multV (x1/fx) b))
+	                 (multV (y1/fy) c))) `thenIO` \() ->
+      drawit ss
+  in
+  drawit s `thenIO` \ () ->
+  xDisplayForceOutput display
+
+-- create function ---------------------------------------------------------
+-- opens up a window to allow the user to create a file 
+-- and save it onto a file
+
+create :: Hostname -> Filename -> Int -> Int -> IO()
+
+create host filename x y =
+  xOpenDisplay host `thenIO` \ display ->
+  let 
+   (screen:_) = xDisplayRoots display
+   fg_color = xScreenWhitePixel screen
+   bg_color = xScreenBlackPixel screen
+   root = xScreenRoot screen
+  in
+  xCreateWindow root
+                (XRect 0 0 (x+1) (y+1))
+                [XWinBackground bg_color,
+                 XWinEventMask (XEventMask [XExposure,
+		                            XKeyPress, 
+					    XButtonPress,
+					    XPointerMotion])]
+  `thenIO` \window ->
+  xSetWmName window filename `thenIO` \() ->
+  xSetWmIconName window filename `thenIO` \() ->
+  xCreateWindow root
+                (XRect 0 0 100 40)
+		[XWinBackground bg_color] `thenIO` \window2 ->
+  xSetWmName window2 "pos" `thenIO` \() ->
+  xSetWmIconName window2 "pos" `thenIO` \() ->
+  xMapWindow window `thenIO` \() ->
+  xMapWindow window2 `thenIO` \() ->
+  xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
+  xCreateGcontext (XDrawWindow root)
+                  [XGCBackground bg_color,
+                   XGCForeground fg_color,
+		   XGCFont (head fontlist)] `thenIO` \gcontext ->
+  let
+   handleEvent :: IntSegList -> IO()
+   handleEvent list =
+     xGetEvent display `thenIO` \event ->
+     let 
+      point = xEventPos event 
+      XPoint pointx pointy = point
+      handleEvent' :: XPoint -> IO()
+      handleEvent' last = 
+       xGetEvent display `thenIO` \event2 ->
+       let 
+        pos = xEventPos event2
+	XPoint posx posy = pos 
+       in
+        case (xEventType event2) of
+         XKeyPressEvent  -> 
+           appendChan stdout ((show (tup pos))++ "\n") abort $
+           xDrawLine (XDrawWindow window) gcontext point pos 
+           `thenIO` \() -> handleEvent (store list point pos)
+         XExposureEvent  -> 
+           redraw window gcontext list `thenIO` \() -> handleEvent' last
+	 XMotionNotifyEvent ->
+	   xDrawImageGlyphs (XDrawWindow window2)
+	                    gcontext
+			    (XPoint 2 18)
+			    ((show posx)++", "++(show posy)++"      ") 
+			    `thenIO` \dummy -> handleEvent' last
+         _                  -> 
+           handleEvent' last
+     in 
+     case (xEventType event) of 
+       XButtonPressEvent     -> 
+         putFile display filename list x y "create"
+       XKeyPressEvent  -> 
+         appendChan stdout (show (tup point)) abort $ 
+         handleEvent' point 
+       XExposureEvent  -> 
+         redraw window gcontext list `thenIO` \() -> handleEvent list
+       XMotionNotifyEvent ->
+	 xDrawImageGlyphs (XDrawWindow window2)
+	                  gcontext
+			  (XPoint 2 18)
+			  ((show pointx)++", "++(show pointy)++"      ") 
+			  `thenIO` \dummy -> handleEvent list
+       _                  -> 
+         handleEvent list
+  in 
+   case (checkFile filename) of 
+     True  -> handleEvent []
+     False -> appendChan stdout picTypeError abort $
+              xCloseDisplay display
+
+-- modify function ---------------------------------------------------------
+-- allows the user to add onto an already existing picture file
+
+modify :: Hostname -> Filename -> IO()
+
+modify host filename =
+  case (checkFile filename) of 
+   False -> appendChan stdout picTypeError abort done
+   True  -> 
+    readFile filename (\s -> appendChan stdout 
+                                        readError abort done) $ \s->
+    let 
+     dat = read s 
+     origlist = fFloat (getlist dat)
+     x = getx dat
+     y = gety dat
+    in
+     xOpenDisplay host `thenIO` \ display ->
+     let 
+      (screen:_) = xDisplayRoots display
+      fg_color = xScreenWhitePixel screen
+      bg_color = xScreenBlackPixel screen
+      root = xScreenRoot screen
+     in
+     xCreateWindow root
+       (XRect 0 0 (x + 1) (y + 1))
+        [XWinBackground bg_color,
+        XWinEventMask (XEventMask [XExposure, XKeyPress, 
+                                   XButtonPress, XPointerMotion])]
+     `thenIO` \window ->
+     xSetWmName window filename `thenIO` \() ->
+     xSetWmIconName window filename `thenIO` \() ->
+     xCreateWindow root (XRect 0 0 100 40)
+	[XWinBackground bg_color] `thenIO` \window2 ->
+     xSetWmName window2 "pos" `thenIO` \() ->
+     xSetWmIconName window2 "pos" `thenIO` \() ->
+     xMapWindow window `thenIO` \() -> 
+     xMapWindow window2 `thenIO` \() ->
+     xListFonts display "*times*bold*r*normal*18*" `thenIO` \fontlist ->
+     xCreateGcontext (XDrawWindow root) [XGCBackground bg_color, 
+                                         XGCForeground fg_color, 
+                                         XGCFont (head fontlist)] 
+     `thenIO` \ gcontext ->
+    let
+     handleEvent :: IntSegList -> IO()
+     handleEvent list =
+      xGetEvent display `thenIO` \event ->
+      let 
+       point = xEventPos event 
+       XPoint pointx pointy = point
+       handleEvent' :: XPoint -> IO()
+       handleEvent' last = xGetEvent display `thenIO` \event2 ->
+        let 
+         pos = xEventPos event2
+	 XPoint posx posy = pos 
+        in
+         case (xEventType event2) of
+          XExposureEvent  -> 
+            redraw window gcontext list `thenIO` \() -> 
+            handleEvent' last
+          XKeyPressEvent  -> 
+            appendChan stdout ((show (tup pos))++ "\n") abort $
+            xDrawLine (XDrawWindow window) gcontext point pos 
+            `thenIO` \() -> handleEvent (store list point pos)
+     	  XMotionNotifyEvent ->
+	    xDrawImageGlyphs (XDrawWindow window2) gcontext 
+             (XPoint 2 18) ((show posx)++", "++(show posy)++"      ") 
+	    `thenIO` \dummy -> handleEvent' last
+	  _                  -> handleEvent' last
+      in
+       case (xEventType event) of 
+        XButtonPressEvent  ->
+          putFile display filename list x y "modify"
+        XKeyPressEvent     ->
+          appendChan stdout (show (tup point)) abort $ 
+          handleEvent' point 
+        XExposureEvent  -> 
+          redraw window gcontext list `thenIO` \() -> 
+          handleEvent list
+        XMotionNotifyEvent ->
+          xDrawImageGlyphs (XDrawWindow window2) 
+                           gcontext (XPoint 2 18)
+           ((show pointx)++", "++(show pointy)++"      ")
+          `thenIO` \dummy -> handleEvent list
+        _                  -> 
+          handleEvent list
+    in
+     redraw window gcontext origlist `thenIO` \() -> 
+      handleEvent origlist
+
+-- Miscellaneous functions -------------------------------------------------
+-- shared by the create and modify functions
+
+checkFile :: Filename -> Bool
+checkFile name =
+  case (take 4 (reverse name)) of
+   "cip." -> True
+   _      -> False
+
+store :: IntSegList -> XPoint -> XPoint -> IntSegList 
+store l a b =  [((xof a,yof a),(xof b,yof b))] ++ l
+
+xof :: XPoint -> Int
+xof (XPoint x y) = x
+
+yof :: XPoint -> Int
+yof (XPoint x y) = y
+
+tup :: XPoint -> IntPoint
+tup (XPoint a b) = (a,b)
+  
+ll:: IntSegment -> Int
+ll ((a1,a2),(b1,b2)) = a1
+
+lr:: IntSegment -> Int
+lr ((a1,a2),(b1,b2)) = a2
+
+rl:: IntSegment -> Int
+rl ((a1,a2),(b1,b2)) = b1
+
+rr:: IntSegment -> Int
+rr ((a1,a2),(b1,b2)) = b2
+
+getx :: Picture -> Int
+getx (Grid m n o) = m
+
+gety :: Picture -> Int
+gety(Grid m n o) = n
+
+getlist :: Picture -> SegList
+getlist (Grid m n o) = o
+
+fFloat :: SegList -> IntSegList
+fFloat = map (\ ((ix,iy),(jx,jy)) ->
+             ((round ix,round iy), (round jx,round jy)))
+
+readError :: String
+readError  = "Error: reading an invalid file\n"
+
+picTypeError :: String
+picTypeError = "Error: files need to be of .pic type\n"
+
+deleteError :: String
+deleteError = "Error: file can not be deleted\n"
+
+writeError :: String
+writeError = "Error: file can not be written\n"
+
+modError :: String
+modError = "Error: file can not be modified\n"
+
+redraw :: XWindow-> XGcontext -> IntSegList -> IO()
+redraw window gcontext [] = done
+redraw window gcontext (l:ls) = 
+ xDrawLine (XDrawWindow window) gcontext (XPoint (ll l) (lr l)) 
+                                         (XPoint (rl l) (rr l))
+ `thenIO` \() -> redraw window gcontext ls
+
+changeList :: IntSegList -> SegList
+changeList = 
+  map (\ ((ix,iy),(jx,jy)) -> ((fromIntegral ix,fromIntegral iy),
+                               (fromIntegral jx,fromIntegral jy)))
+
+putFile :: XDisplay -> Filename -> IntSegList -> 
+           Int -> Int -> String -> IO()
+putFile display name list x y flag = 
+ let  
+  text = show (Grid x y (changeList list))
+  finishMsg  = name ++ ": Done...Process completed\n"
+  modMsg = name ++ ": Modifying file\n"
+  createMsg = name ++ ": Creating file\n"
+  continue = 
+   deleteFile name (\s -> appendChan stdout deleteError abort done) $
+   writeFile name text (\s -> appendChan stdout writeError abort done) $
+   appendChan stdout finishMsg abort $ 
+   xCloseDisplay display
+ in 
+  case (flag == "create") of
+   False -> appendChan stdout modMsg 
+                       (\s -> appendChan stdout modError abort done) $
+            continue
+   True  -> readFile name (\s -> appendChan stdout createMsg abort $
+                                 writeFile name text abort 
+                                   (xCloseDisplay display)) $ \s ->
+            continue
+
+
+
+
diff --git a/progs/demo/X11/graphics/henderson.hu b/progs/demo/X11/graphics/henderson.hu
new file mode 100644
index 0000000..e92b66d
--- /dev/null
+++ b/progs/demo/X11/graphics/henderson.hu
@@ -0,0 +1,3 @@
+:o= foldr inline constant
+$HASKELL_LIBRARY/X11/xlib.hu
+henderson.hs
diff --git a/progs/demo/X11/graphics/manual b/progs/demo/X11/graphics/manual
new file mode 100644
index 0000000..17772f1
--- /dev/null
+++ b/progs/demo/X11/graphics/manual
@@ -0,0 +1,454 @@
+104 pgscriptver 
+
+100 DefSpaceEx 100 DefCharEx 1 DefNormalHyphenationOn 100 
+DefTypeColor (Times-Roman) DefTypeFace ENGLISH DefLanguage 12 DefPointSize 
+USE_POINTSIZE DefSetSize (@default) DefTypeResource 
+
+LEFT DefJustifyFlags 2 DefBeginParaLeadValue ABSOLUTE DefBeginParaLeadMode 2 
+DefEndParaLeadValue ABSOLUTE DefEndParaLeadMode 120 DefLeadValue 
+PROPORTIONAL DefLeadMode 1 46 0 TAB_LEFT  720 DefTab 1 46 0 
+TAB_LEFT  2160 DefTab 1 46 0 TAB_LEFT  3600 DefTab 1 46 0 
+TAB_LEFT  5040 DefTab 1 46 0 TAB_LEFT  6480 DefTab 1 46 0 
+TAB_LEFT  7920 DefTab 1 46 0 TAB_LEFT  9360 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 0 46 0 TAB_LEFT  24480 DefTab 0 46 0 
+TAB_LEFT  24480 DefTab 80 DefWSMN 100 DefWSNM 150 DefWSMX 110 
+DefLSMX 100 DefLeaderEx 46 DefLeaderChar 0 DefFirstIndent 0 
+DefLeftIndent 0 DefRightIndent 0 DefNumberingOn 0 DefNumberingType 0 
+DefNumberingRestart 1 DefNumberingLevel 0 DefNumberingStyle 0 
+DefNumberingTabAfter 1 DefNumberingShowAllLevels 1 DefNumberingStart 1 
+DefNumberingIncrement () DefNumberingPrefix () DefNumberingSuffix (.) 
+DefNumberingSeparator (*default) DefParaResource 
+
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResource 
+
+0 DefPageDimensions 12240 DefPageWidth 15840 DefPageHeight 1440 
+DefInsideMargin 1080 DefOutsideMargin 1080 DefTopMargin 1080 
+DefBottomMargin 0 DefOrientation 0 DefPageStyle 1 DefColumns 360 
+DefGutter (%default) DefMasterPage ResDefEnd 
+
+0 DefFirstLeft 0 DefDocSetup 1 DefNumPages 1 AutoPage 1 
+DefStartPageNum () DefPageNumPrefix 1 DefGraphicLocation document 
+
+1 DefAutoPage 
+0 (%default) 1 DefPage 
+1 DefAutoPage 
+0 (%default) 2 DefPage 
+
+POLY_OBJECT POLY_EMPTY |  DefPolyType 
+
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 0 
+DefMasterRef 
+MP_CPSUCC_LINK MP_CPPRED_LINK POLY_COLUMN | |  DefSLinksFlags 0 DefStreamSucc 0 
+DefStreamPred 
+1440 1080 11160 1080 11160 14760 1440 14760 4 
+POLY_OBJECT POLY_EMPTY |  (%default) 0 1 TextPolygon 
+
+POLY_OBJECT POLY_TEXT |  DefPolyType 
+
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 
+DefMasterRef 
+
+MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | 
+DefSLinksFlags 4 DefStreamSucc 0 DefStreamPred 3 DefTextHandle 
+1440 1080 11160 1080 11160 14760 1440 14760 4 
+POLY_OBJECT POLY_TEXT |  (1) 0 2 TextPolygon 
+
+3 asciitextstream 
+<(Courier) cf ><9 cs>The Henderson Library--<eop>
+by Syam Gadde<eop>
+and Bo Whong<eop>
+<eop>
+The Henderson Library is a toolkit with which one can use Functional Geometry, 
+as proposed by Peter Henderson in his paper "Functional Geometry".  This is a s
+cheme by which "Picture"s can be described in an abstract data type, and a numb
+er of functions can be applied to it.  This results in a very elegant method to
+ produce complex pictures from simple ones.  The example Henderson uses is "Squ
+are Limit" by M. C. Escher,  which can be constructed with four simple pictures
+.<eop>
+<eop>
+------------------------<eop>
+ADTs and Type Synonyms<eop>
+<eop>
+The Picture data type is composed of eight different types of pictures.  They a
+re:<eop>
+<eop>
+data<eop>
+Picture = Nil                                 - empty picture<eop>
+        | Flip Picture                        - picture flipped on the y-axis<e
+op>
+        | Beside Float Picture Float Picture  - two pictures placed side by sid
+e <eop>
+                                              - in accordance to the ratio of t
+he<eop>
+                                              - two floats<eop>
+        | Above Float Picture Float Picture   - two pictures placed one on top 
+of<eop>
+                                              - another in accordance to the ra
+tio<eop>
+                                              - of the two floats<eop>
+        | Rot Picture                         - picture is rotated 90 degrees <
+eop>
+                                              - counterclockwise<eop>
+        | File String                         - picture is stored as an externa
+l<eop>
+                                              - file<eop>
+        | Overlay Picture Picture             - two pictures are drawn such tha
+t<eop>
+                                              - one lays on top of the other<eo
+p>
+        | Grid Int Int SegList                - picture type that contains the 
+list<eop>
+                                              - of picture's line segments alon
+g<eop>
+                                              - with the size of the inital pic
+ture<eop>
+<eop>
+The type synonyms are pretty much self explanatory.<eop>
+<eop>
+        Hostname<tab><tab><tab>- a string of the hostname<eop>
+        Filename                              <tab>- a string of the filename<e
+op>
+        IntPoint                              <tab>- a tuple of integers repres
+enting<eop>
+                                              <tab>- the coordinates of a point
+<eop>
+        IntSegment                            <tab>- a tuple of Intpoints repre
+senting<eop>
+                                              <tab>- the endpoints of a line se
+gment<eop>
+        IntSegList                            <tab>- a list of IntSegments <eop
+>
+        Point                                 <tab>- same as IntPoint except in
+ place of<eop>
+<tab><tab><tab>             <tab>- intergers, they are floating points<eop>
+        Segment                               <tab>- same as IntSegment except 
+in place<eop>
+       <tab><tab>            <tab>- of intergers, they are floating <eop>
+         <tab><tab><tab>- points<eop>
+        SegList                               <tab>- same as IntsegList except 
+in place<eop>
+      <tab><tab><tab><tab>- of intergers, they are floating <eop>
+         <tab><tab><tab>- points<eop>
+        Vector                                <tab>- a tuple of floating points
+ to<eop>
+        <tab><tab><tab>- to represent a vector<eop>
+        Vtriple                               - a 3-tuple of Vectors<eop>
+        HendQuartet                           - a 4-tuple of Integers for the s
+ize<eop>
+                                              - of the Henderson window<eop>
+        PEnv                                  - a tuple of a Filename and a Pic
+ture<eop>
+                                              - for storing already opened file
+s in<eop>
+                                              - in order to save time and memor
+y<eop>
+                                              - when a file needs to be opened 
+more<eop>
+                                              - than once<eop>
+<eop>
+-------------------------------------------------------------------------------
+----<eop>
+Function: create (an exported function from the HendersonLib)<eop>
+<eop>
+The purpose of the create function is to provide the user with a function to <e
+op>
+draw a picture from a graphics interface.  The user may choose to create a pict
+ure<eop>
+file by inputing the the lines and points manually into a file or (s)he may cho
+ose<eop>
+to use the create function.<eop>
+<eop>
+Functionality of create:<eop>
+           create :: Hostname -<ra> Filaname -<ra> Int -<ra> Int -<ra> IO()<eop
+>
+<eop>
+create takes as input a hostname, a filename, and two integers for the size of 
+the <eop>
+window to be opened.  Two windows should appear, one for the input of lines and
+<eop>
+another showing the current position of the mouse.  These windows will be label
+ed<eop>
+accordingly.<eop>
+To draw a line on the file window, move the cursor to the desired position, the
+n<eop>
+hit any key on the keybroad. This point will be the beginning of the line segme
+nt.<eop>
+Next move the cursor to the position of where the user wants the end of the lin
+e<eop>
+segment to be, then hit any key from the keyboard again.  A line should appear.
+<eop>
+The coordinates of the endpoints of each line drawn  will also be printed out o
+nto <eop>
+standard output.<eop>
+To signal completion of a file, press any button on the mouse.  The user must <
+eop>
+remember though that this is only applicable after a completed drawing of a lin
+e.<eop>
+For example, pressing the mouse button will not work if one of the endpoints of
+ a<eop>
+line is drawn but the other endpoint is not. create will not recognize the mous
+e <eop>
+button press event until a second endpoint is drawn.<eop>
+<eop>
+Advantages of create:<eop>
+ provides a quick and fun way to create a picture file.<eop>
+<eop>
+Disadvantages of create:<eop>
+ If the file does not exist, create will create the file and then store the pic
+ture<eop>
+ to it.  However, if the file exists, create will automatically delete the cont
+ents<eop>
+ of that file before storing the new picture.<eop>
+<eop>
+-------------------------------------------------------------------------------
+----<eop>
+Function: modify (an exported function from the HendersonLib)<eop>
+<eop>
+The purpose of the modify function is to provide the user with a function make 
+<eop>
+additions to an already existing picture file using a graphics interface.  The 
+user<eop>
+may choose to modify the picture file by adding the the lines and points manual
+ly <eop>
+into the file or (s)he may choose to use the modify function.<eop>
+<eop>
+Functionality of modify:<eop>
+           modify :: Hostname -<ra> Filaname -<ra> IO()<eop>
+<eop>
+modify takes as input a hostname and a filename. Tow windows should appear.  Th
+e <eop>
+size of the draw window will be the same as the x and y coordinates already in 
+the<eop>
+file. These windows will be labeled accordingly.  The existing picture will app
+ear<eop>
+first before any input is allowed.<eop>
+To draw a line on the file window, move the cursor to the desired position, the
+n<eop>
+hit any key on the keybroad. This point will be the beginning of the line segme
+nt.<eop>
+Next move the cursor to the position of where the user wants the end of the lin
+e<eop>
+segment to be, then hit any key from the keyboard again.  A line should appear.
+<eop>
+The coordinates of the endpoints of each line drawn  will also be printed out o
+nto <eop>
+standard output.<eop>
+To signal completion of a file, press any button on the mouse.  The user must <
+eop>
+remember though that this is only applicable after a completed drawing of a lin
+e.<eop>
+For example, pressing the mouse button will not work if one of the endpoints of
+ a<eop>
+line is drawn but the other endpoint is not.  modify will not recognize the mou
+se <eop>
+button press event until a second endpoint is drawn.<eop>
+<eop>
+Advantages of modify:<eop>
+ provides a quick and fun way to modify a picture file without having to go int
+o<eop>
+ the file and manually add on the coordinates of the additional lines<eop>
+<eop>
+Disadvantages of modify:<eop>
+ Existing lines can not be deleted and any additional lines, whether intentiona
+l or<eop>
+ unintentional, will be appended to the picture and stored in the file.<eop>
+<eop>
+--------------------------------------------------------<eop>
+Function: sendToDraw<eop>
+<eop>
+Type of sendToDraw:<eop>
+  sendToDraw :: XWindow -<ra> XScreen -<ra> XDisplay -<ra> <eop>
+              XPixel -<ra> XPixel -<ra> Plot -<ra> IO()<eop>
+<eop>
+Usage:<eop>
+  sendToDraw win scn dis fg_color bg_color plt<eop>
+<eop>
+'sendToDraw' is the most primitive function in the part of the Henderson<eop>
+library that deals with X windows, and therefore, can be used as a very<eop>
+powerful tool.  It draws a Plot plt (see 'plot' function) in the given XWindow<
+eop>
+win, and on the given XScreen and XDisplay scn and dis, drawing the lines in<eo
+p>
+the foreground color.  This function allows the programmer to draw more than<eo
+p>
+one Picture to the same window.<eop>
+<eop>
+Arguments:<eop>
+  win - the XWindow in which to draw plt<eop>
+  scn - the screen which contains win<eop>
+  dis - the display which contains scn<eop>
+  fg_color - an XPixel the color of which the plt will be drawn in.  Note that<
+eop>
+<tab>this allows the programmer to draw different plt's in different colors.<eo
+p>
+  bg_color - unused, but required.<eop>
+--------------------------------------------------------<eop>
+Function: plot<eop>
+<eop>
+Type of 'plot':<eop>
+  plot :: Picture -<ra> VTriple -<ra> PEnv -<ra> ((Plot, PEnv) -<ra> IO()) -<ra
+> IO()<eop>
+<eop>
+Usage:<eop>
+  plot pic (a,b,c) env func<eop>
+<eop>
+The 'plot' function is needed to create a Plot which would be normally sent to<
+eop>
+a function such as sendToDraw.  'plot' converts a Picture pic into a format<eop
+>
+that sendToDraw can deal with.<eop>
+'plot' also takes three vectors which specify the bounding box in which the<eop
+>
+Picture is to be drawn.  The first vector (a) specifies the upper left corner<e
+op>
+of the bounding box.  The next two vectors specify the bounding box itself,<eop
+>
+with respect to the first vector.  This allows for non-rectangular bounding<eop
+>
+boxes.  For example, the vector triple ((50,50), (100,0), (0,100)) specifies<eo
+p>
+the following bounding box:<eop>
+<eop>
+            (0,0)----------------------------------<eop>
+                 |<eop>
+                 |  (50,50)<eop>
+                 |     _______________ (150,0)  <eop>
+                 |     |             |<eop>
+                 |     |             |<eop>
+                 |     |             |<eop>
+                 |     |             |<eop>
+                 |     |             |<eop>
+                 |     |_____________| (150,150)<eop>
+                 |  (0,150)<eop>
+<eop>
+<eop>
+A vector triple of ((0,0), (100,300), (0,100)) would specify:<eop>
+<eop>
+            (0,0)-------------------------------------<eop>
+                 ||\<eop>
+                 || \<eop>
+                 ||  \<eop>
+          (0,100)||   \<eop>
+                 |\    \<eop>
+                 | \    \<eop>
+                 |  \    \<eop>
+                 |   \    \ (100,300)<eop>
+                 |    \   | <eop>
+                 |     \  |<eop>
+                 |      \ |<eop>
+                 |       \| (100,400)<eop>
+<eop>
+Arguments:                 <eop>
+  pic - the Picture to be converted<eop>
+  a - a vector specifying the upper left corner of the bounding box<eop>
+<tab>of the picture.<eop>
+  b - a vector understood to start at 'a' and specifying the upper edge of<eop>
+
+<tab>the bounding box.<eop>
+  c - a vector understood to start at 'a' and specifying the left edge of<eop>
+<tab>the bounding box.<eop>
+--------------------------------------------------------<eop>
+Function: draw<eop>
+<eop>
+Type of draw:<eop>
+  draw :: Hostname -<ra> Picture -<ra> VTriple -<ra> HendQuartet -<ra> IO()<eop
+>
+<eop>
+Usage:<eop>
+  draw host pic (a,b,c) (m,n,p,q)<eop>
+<eop>
+'draw' is a higher-level function than sendToDraw, and is useful to use when<eo
+p>
+the programmer wishes only to draw one Picture on the screen.  This function<eo
+p>
+does most of the work that the programmer would normally have to do when using<
+eop>
+sendToDraw.  'draw' opens a window at host with upper left coordinates m and n<
+eop>
+(on an X server that lets the user position any child window of the root<eop>
+window, these coordinates mean nothing), and with width p and height q.<eop>
+'draw' then calls 'plot' on pic and (a,b,c) and sends the result to sendToDraw,
+<eop>
+which finally draws the picture to the window.<eop>
+<eop>
+Arguments:<eop>
+  host - host on which to open a display, i.e. "tucan:0"<eop>
+  pic - the Picture to be drawn<eop>
+  (a,b,c) - the vector triple specifying the bounding box to be sent to<eop>
+<tab>plot (see 'plot' function)<eop>
+  (m,n,p,q) - upper left corner x (m), upper left corner y (n), width (p),<eop>
+
+<tab>and height (q), of window to be opened.<eop>
+<eop>
+-----------------------------------------------------------<eop>
+<eop>
+Module: SquareLimit<eop>
+<eop>
+This module is a sample user module that can be used to draw Square Limit, a wo
+odcut by M. C. Escher.  To draw "SquareLimit" on your host, run the dialogue:<e
+op>
+<tab>final host<eop>
+where 'host' is the host running X, such as "turtle:0".<eop>
+<eop>
+To draw a slightly more interesting picture, tun the dialogue:<eop>
+<tab>skewedfinal host<eop>
+and it will draw "SquareLimit" in a bounding box shaped as a diamond.<eop>
+<eop>
+
+<textstream_end> 
+
+POLY_OBJECT POLY_TEXT |  DefPolyType 
+
+0 DefLineWidth TRANSPARENT DefPenColor TRANSPARENT DefFillColor 1 DefIG 300 
+DefResolution 100 DefYScale 100 DefXScale (=default) DefPolyResId 1 
+DefMasterRef 
+
+MP_CPSUCC_LINK MP_CPPRED_LINK LINK_OVERFLOW MPREF_VALID POLY_COLUMN AUTO_STREAM | | | | | 
+DefSLinksFlags 0 DefStreamSucc 2 DefStreamPred 3 DefTextHandle 
+1440 1080 11160 1080 11160 14760 1440 14760 4 
+POLY_OBJECT POLY_TEXT |  (2) 0 4 TextPolygon 
+
+BeginProfile 
+(Number of Pages) (5)  DefProfileString 
+(Language) (ENGLISH)  DefProfileString 
+(Version) (IslandWrite Version 2.3)  DefProfileString 
+(Creation Date) (gadde May 7, 1993 3:55 PM)  DefProfileString 
+(Text Formats) (default)  DefProfileString 
+(Container Formats) (default)  DefProfileString 
+(Page Formats) (default)  DefProfileString 
+(Fonts) (Courier)  DefProfileString 
+(Fonts) (Times-Roman)  DefProfileString 
+(File Path) ()  DefProfileString 
+(External Contents) ()  DefProfileString 
+(Title) ()  DefProfileString 
+(Status) ()  DefProfileString 
+(Distribution List) ()  DefProfileString 
+(Preparer) ()  DefProfileString 
+(Owner) ()  DefProfileString 
+(Author) ()  DefProfileString 
+(Superseded Documents) ()  DefProfileString 
+EndProfile 
+
+pgscriptdone 
diff --git a/progs/demo/X11/graphics/p.pic b/progs/demo/X11/graphics/p.pic
new file mode 100644
index 0000000..240b386
--- /dev/null
+++ b/progs/demo/X11/graphics/p.pic
@@ -0,0 +1 @@
+Grid 640 640 [((560.00000000000000,560.00000000000000),(440.00000000000000,640.00000000000000)), ((640.00000000000000,560.00000000000000),(560.00000000000000,560.00000000000000)), ((520.00000000000000,440.00000000000000),(640.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(520.00000000000000,440.00000000000000)), ((480.00000000000000,360.00000000000000),(360.00000000000000,400.00000000000000)), ((480.00000000000000,360.00000000000000),(640.00000000000000,400.00000000000000)), ((480.00000000000000,280.00000000000000),(640.00000000000000,320.00000000000000)), ((320.00000000000000,320.00000000000000),(480.00000000000000,280.00000000000000)), ((280.00000000000000,400.00000000000000),(160.00000000000000,440.00000000000000)), ((160.00000000000000,240.00000000000000),(280.00000000000000,400.00000000000000)), ((160.00000000000000,440.00000000000000),(160.00000000000000,240.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,320.00000000000000)), ((0.0000000000000000,320.00000000000000),(0.0000000000000000,520.00000000000000)), ((120.00000000000000,480.00000000000000),(0.0000000000000000,520.00000000000000)), ((240.00000000000000,640.00000000000000),(160.00000000000000,480.00000000000000)), ((400.00000000000000,480.00000000000000),(440.00000000000000,640.00000000000000)), ((320.00000000000000,320.00000000000000),(400.00000000000000,480.00000000000000)), ((160.00000000000000,120.00000000000000),(320.00000000000000,320.00000000000000)), ((0.0000000000000000,0.0000000000000000),(160.00000000000000,120.00000000000000)), ((640.00000000000000,240.00000000000000),(320.00000000000000,160.00000000000000)), ((640.00000000000000,40.000000000000000),(560.00000000000000,0.0000000000000000)), ((520.00000000000000,40.000000000000000),(640.00000000000000,80.000000000000000)), ((480.00000000000000,0.0000000000000000),(520.00000000000000,40.000000000000000)), ((480.00000000000000,80.000000000000000),(400.00000000000000,0.0000000000000000)), ((640.00000000000000,120.00000000000000),(480.00000000000000,80.000000000000000)), ((480.00000000000000,160.00000000000000),(640.00000000000000,160.00000000000000)), ((320.00000000000000,0.0000000000000000),(480.00000000000000,160.00000000000000)), ((240.00000000000000,40.000000000000000),(320.00000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(240.00000000000000,40.000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/graphics/q.pic b/progs/demo/X11/graphics/q.pic
new file mode 100644
index 0000000..84e27a4
--- /dev/null
+++ b/progs/demo/X11/graphics/q.pic
@@ -0,0 +1,2 @@
+Grid 16 16 
+[((10.000000000000000,6.0000000000000000),(9.0000000000000000,4.0000000000000000)), ((12.000000000000000,4.0000000000000000),(10.000000000000000,6.0000000000000000)), ((9.0000000000000000,4.0000000000000000),(12.000000000000000,4.0000000000000000)), ((0.0000000000000000,6.0000000000000000),(7.0000000000000000,5.0000000000000000)), ((0.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((0.0000000000000000,0.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((15.000000000000000,16.000000000000000),(16.000000000000000,14.000000000000000)), ((16.000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((13.000000000000000,16.000000000000000),(16.000000000000000,10.000000000000000)), ((13.000000000000000,12.000000000000000),(12.000000000000000,16.000000000000000)), ((16.000000000000000,8.0000000000000000),(13.000000000000000,12.000000000000000)), ((15.000000000000000,6.0000000000000000),(16.000000000000000,8.0000000000000000)), ((16.000000000000000,0.0000000000000000),(15.000000000000000,6.0000000000000000)), ((10.000000000000000,16.000000000000000),(14.000000000000000,5.0000000000000000)), ((10.000000000000000,10.000000000000000),(10.000000000000000,7.0000000000000000)), ((8.0000000000000000,16.000000000000000),(10.000000000000000,10.000000000000000)), ((8.0000000000000000,11.000000000000000),(8.0000000000000000,8.0000000000000000)), ((6.0000000000000000,16.000000000000000),(8.0000000000000000,11.000000000000000)), ((6.0000000000000000,11.000000000000000),(4.0000000000000000,16.000000000000000)), ((6.0000000000000000,9.0000000000000000),(6.0000000000000000,11.000000000000000)), ((4.0000000000000000,11.000000000000000),(4.0000000000000000,9.0000000000000000)), ((2.0000000000000000,16.000000000000000),(4.0000000000000000,11.000000000000000)), ((4.0000000000000000,9.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((6.0000000000000000,9.0000000000000000),(4.0000000000000000,9.0000000000000000)), ((12.000000000000000,6.0000000000000000),(6.0000000000000000,9.0000000000000000)), ((16.000000000000000,0.0000000000000000),(12.000000000000000,6.0000000000000000)), ((9.0000000000000000,3.0000000000000000),(8.0000000000000000,1.0000000000000000)), ((11.000000000000000,1.0000000000000000),(9.0000000000000000,3.0000000000000000)), ((8.0000000000000000,1.0000000000000000),(11.000000000000000,1.0000000000000000)), ((8.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((6.0000000000000000,0.0000000000000000),(7.0000000000000000,1.0000000000000000)), ((5.0000000000000000,2.0000000000000000),(4.0000000000000000,0.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(5.0000000000000000,2.0000000000000000)), ((3.0000000000000000,3.0000000000000000),(0.0000000000000000,4.0000000000000000)), ((2.0000000000000000,0.0000000000000000),(3.0000000000000000,3.0000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/graphics/r.pic b/progs/demo/X11/graphics/r.pic
new file mode 100644
index 0000000..6e37979
--- /dev/null
+++ b/progs/demo/X11/graphics/r.pic
@@ -0,0 +1,2 @@
+Grid 32 32 
+[((32.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((32.000000000000000,4.0000000000000000),(30.000000000000000,2.0000000000000000)), ((28.000000000000000,4.0000000000000000),(32.000000000000000,8.0000000000000000)), ((32.000000000000000,12.000000000000000),(26.000000000000000,6.0000000000000000)), ((24.000000000000000,8.0000000000000000),(32.000000000000000,16.000000000000000)), ((22.000000000000000,0.0000000000000000),(24.000000000000000,8.0000000000000000)), ((22.000000000000000,12.000000000000000),(12.000000000000000,0.0000000000000000)), ((32.000000000000000,20.000000000000000),(22.000000000000000,12.000000000000000)), ((24.000000000000000,26.000000000000000),(10.000000000000000,22.000000000000000)), ((32.000000000000000,32.000000000000000),(24.000000000000000,26.000000000000000)), ((16.000000000000000,28.000000000000000),(24.000000000000000,32.000000000000000)), ((6.0000000000000000,26.000000000000000),(16.000000000000000,28.000000000000000)), ((16.000000000000000,32.000000000000000),(4.0000000000000000,28.000000000000000)), ((2.0000000000000000,30.000000000000000),(8.0000000000000000,32.000000000000000)), ((0.0000000000000000,32.000000000000000),(16.000000000000000,16.000000000000000)), ((0.0000000000000000,24.000000000000000),(10.000000000000000,12.000000000000000)), ((4.0000000000000000,8.0000000000000000),(0.0000000000000000,16.000000000000000)), ((28.000000000000000,20.000000000000000),(32.000000000000000,24.000000000000000)), ((16.000000000000000,16.000000000000000),(28.000000000000000,20.000000000000000)), ((4.0000000000000000,8.0000000000000000),(16.000000000000000,16.000000000000000)), ((2.0000000000000000,4.0000000000000000),(4.0000000000000000,8.0000000000000000)), ((2.0000000000000000,4.0000000000000000),(0.0000000000000000,8.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(2.0000000000000000,4.0000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/graphics/s.pic b/progs/demo/X11/graphics/s.pic
new file mode 100644
index 0000000..74659b7
--- /dev/null
+++ b/progs/demo/X11/graphics/s.pic
@@ -0,0 +1 @@
+Grid 32 32 [((24.000000000000000,0.0000000000000000),(32.000000000000000,0.0000000000000000)), ((0.0000000000000000,0.0000000000000000),(16.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(32.000000000000000,12.000000000000000)), ((32.000000000000000,8.0000000000000000),(28.000000000000000,10.000000000000000)), ((26.000000000000000,6.0000000000000000),(32.000000000000000,4.0000000000000000)), ((26.000000000000000,6.0000000000000000),(24.000000000000000,0.0000000000000000)), ((30.000000000000000,14.000000000000000),(26.000000000000000,6.0000000000000000)), ((32.000000000000000,16.000000000000000),(30.000000000000000,14.000000000000000)), ((30.000000000000000,16.000000000000000),(26.000000000000000,18.000000000000000)), ((30.000000000000000,22.000000000000000),(30.000000000000000,16.000000000000000)), ((26.000000000000000,18.000000000000000),(30.000000000000000,22.000000000000000)), ((24.000000000000000,24.000000000000000),(20.000000000000000,20.000000000000000)), ((24.000000000000000,18.000000000000000),(24.000000000000000,24.000000000000000)), ((20.000000000000000,20.000000000000000),(24.000000000000000,18.000000000000000)), ((20.000000000000000,0.0000000000000000),(22.000000000000000,12.000000000000000)), ((14.000000000000000,6.0000000000000000),(16.000000000000000,0.0000000000000000)), ((14.000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((14.000000000000000,6.0000000000000000),(14.000000000000000,16.000000000000000)), ((20.000000000000000,24.000000000000000),(16.000000000000000,20.000000000000000)), ((32.000000000000000,32.000000000000000),(20.000000000000000,24.000000000000000)), ((16.000000000000000,28.000000000000000),(32.000000000000000,32.000000000000000)), ((8.0000000000000000,28.000000000000000),(16.000000000000000,28.000000000000000)), ((0.0000000000000000,32.000000000000000),(8.0000000000000000,28.000000000000000)), ((0.0000000000000000,24.000000000000000),(4.0000000000000000,30.000000000000000)), ((0.0000000000000000,20.000000000000000),(14.000000000000000,24.000000000000000)), ((0.0000000000000000,16.000000000000000),(16.000000000000000,20.000000000000000)), ((0.0000000000000000,12.000000000000000),(14.000000000000000,16.000000000000000)), ((0.0000000000000000,8.0000000000000000),(14.000000000000000,12.000000000000000)), ((0.0000000000000000,4.0000000000000000),(14.000000000000000,6.0000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/graphics/sqrlmt.hs b/progs/demo/X11/graphics/sqrlmt.hs
new file mode 100644
index 0000000..662cdfa
--- /dev/null
+++ b/progs/demo/X11/graphics/sqrlmt.hs
@@ -0,0 +1,177 @@
+-- Peter Henderson's Recursive Geometry
+-- Syam Gadde and Bo Whong
+-- CS429 Project
+-- SquareLimit User Program
+
+module SqrLimit where
+import HendersonLib
+import Xlib
+{-
+p = File "p.pic"
+
+q = File "q.pic"
+
+r = File "r.pic"
+
+s = File "s.pic"
+-}
+p = Grid 640 640 [((560.0,560.0),(440.0,640.0)), 
+              ((640.0,560.0),(560.0,560.0)), 
+	      ((520.0,440.0),(640.0,480.0)), 
+	      ((400.0,480.0),(520.0,440.0)), 
+	      ((480.0,360.0),(360.0,400.0)), 
+	      ((480.0,360.0),(640.0,400.0)), 
+	      ((480.0,280.0),(640.0,320.0)), 
+	      ((320.0,320.0),(480.0,280.0)), 
+	      ((280.0,400.0),(160.0,440.0)), 
+	      ((160.0,240.0),(280.0,400.0)), 
+	      ((160.0,440.0),(160.0,240.0)), 
+	      ((120.0,480.0),(0.0,320.0)), 
+	      ((0.0,320.0),(0.0,520.0)), 
+	      ((120.0,480.0),(0.0,520.0)), 
+	      ((240.0,640.0),(160.0,480.0)), 
+	      ((400.0,480.0),(440.0,640.0)), 
+	      ((320.0,320.0),(400.0,480.0)), 
+	      ((160.0,120.0),(320.0,320.0)), 
+	      ((0.0,0.0),(160.0,120.0)), 
+	      ((640.0,240.0),(320.0,160.0)), 
+	      ((640.0,40.0),(560.0,0.0)), 
+	      ((520.0,40.0),(640.0,80.0)), 
+	      ((480.0,0.0),(520.0,40.0)), 
+	      ((480.0,80.0),(400.0,0.0)), 
+	      ((640.0,120.0),(480.0,80.0)), 
+	      ((480.0,160.0),(640.0,160.0)), 
+	      ((320.0,0.0),(480.0,160.0)), 
+	      ((240.0,40.0),(320.0,0.0)), 
+	      ((0.0,0.0),(240.0,40.0))]
+
+q = Grid 16 16 [((10.0,6.0),(9.0,4.0)), 
+            ((12.0,4.0),(10.0,6.0)), 
+	    ((9.0,4.0),(12.0,4.0)), 
+	    ((0.0,6.0),(7.0,5.0)), 
+	    ((0.0,8.0),(0.0,16.0)), 
+	    ((0.0,0.0),(0.0,4.0)), 
+	    ((15.0,16.0),(16.0,14.0)), 
+	    ((16.0,12.0),(14.0,16.0)), 
+	    ((13.0,16.0),(16.0,10.0)), 
+	    ((13.0,12.0),(12.0,16.0)), 
+	    ((16.0,8.0),(13.0,12.0)), 
+	    ((15.0,6.0),(16.0,8.0)), 
+	    ((16.0,0.0),(15.0,6.0)), 
+	    ((10.0,16.0),(14.0,5.0)), 
+	    ((10.0,10.0),(10.0,7.0)), 
+	    ((8.0,16.0),(10.0,10.0)), 
+	    ((8.0,11.0),(8.0,8.0)), 
+	    ((6.0,16.0),(8.0,11.0)), 
+	    ((6.0,11.0),(4.0,16.0)), 
+	    ((6.0,9.0),(6.0,11.0)), 
+	    ((4.0,11.0),(4.0,9.0)), 
+	    ((2.0,16.0),(4.0,11.0)), 
+	    ((4.0,9.0),(0.0,8.0)), 
+	    ((6.0,9.0),(4.0,9.0)), 
+	    ((12.0,6.0),(6.0,9.0)), 
+	    ((16.0,0.0),(12.0,6.0)), 
+	    ((9.0,3.0),(8.0,1.0)), 
+	    ((11.0,1.0),(9.0,3.0)), 
+	    ((8.0,1.0),(11.0,1.0)), 
+	    ((8.0,0.0),(7.0,1.0)), 
+	    ((5.0,2.0),(7.0,1.0)), 
+	    ((6.0,0.0),(7.0,1.0)), 
+	    ((5.0,2.0),(4.0,0.0)), 
+	    ((3.0,3.0),(5.0,2.0)), 
+	    ((3.0,3.0),(0.0,4.0)), 
+	    ((2.0,0.0),(3.0,3.0))]
+
+r = Grid 32 32 [((32.0,0.0),(24.0,8.0)), 
+            ((32.0,4.0),(30.0,2.0)), 
+	    ((28.0,4.0),(32.0,8.0)), 
+	    ((32.0,12.0),(26.0,6.0)), 
+	    ((24.0,8.0),(32.0,16.0)), 
+	    ((22.0,0.0),(24.0,8.0)), 
+	    ((22.0,12.0),(12.0,0.0)), 
+	    ((32.0,20.0),(22.0,12.0)), 
+	    ((24.0,26.0),(10.0,22.0)), 
+	    ((32.0,32.0),(24.0,26.0)), 
+	    ((16.0,28.0),(24.0,32.0)), 
+	    ((6.0,26.0),(16.0,28.0)), 
+	    ((16.0,32.0),(4.0,28.0)), 
+	    ((2.0,30.0),(8.0,32.0)), 
+	    ((0.0,32.0),(16.0,16.0)), 
+	    ((0.0,24.0),(10.0,12.0)), 
+	    ((4.0,8.0),(0.0,16.0)), 
+	    ((28.0,20.0),(32.0,24.0)), 
+	    ((16.0,16.0),(28.0,20.0)), 
+	    ((4.0,8.0),(16.0,16.0)), 
+	    ((2.0,4.0),(4.0,8.0)), 
+	    ((2.0,4.0),(0.0,8.0)), 
+	    ((0.0,0.0),(2.0,4.0))]
+
+s = Grid 32 32 [((24.0,0.0),(32.0,0.0)), 
+            ((0.0,0.0),(16.0,0.0)), 
+	    ((30.0,14.0),(32.0,12.0)), 
+	    ((32.0,8.0),(28.0,10.0)), 
+	    ((26.0,6.0),(32.0,4.0)), 
+	    ((26.0,6.0),(24.0,0.0)), 
+	    ((30.0,14.0),(26.0,6.0)), 
+	    ((32.0,16.0),(30.0,14.0)), 
+	    ((30.0,16.0),(26.0,18.0)), 
+	    ((30.0,22.0),(30.0,16.0)), 
+	    ((26.0,18.0),(30.0,22.0)), 
+	    ((24.0,24.0),(20.0,20.0)), 
+	    ((24.0,18.0),(24.0,24.0)), 
+	    ((20.0,20.0),(24.0,18.0)), 
+	    ((20.0,0.0),(22.0,12.0)), 
+	    ((14.0,6.0),(16.0,0.0)), 
+	    ((14.0,16.0),(16.0,20.0)), 
+	    ((14.0,6.0),(14.0,16.0)), 
+	    ((20.0,24.0),(16.0,20.0)), 
+	    ((32.0,32.0),(20.0,24.0)), 
+	    ((16.0,28.0),(32.0,32.0)), 
+	    ((8.0,28.0),(16.0,28.0)), 
+	    ((0.0,32.0),(8.0,28.0)), 
+	    ((0.0,24.0),(4.0,30.0)), 
+	    ((0.0,20.0),(14.0,24.0)), 
+	    ((0.0,16.0),(16.0,20.0)), 
+	    ((0.0,12.0),(14.0,16.0)), 
+	    ((0.0,8.0),(14.0,12.0)), 
+	    ((0.0,4.0),(14.0,6.0))]
+
+quartet p1 p2 p3 p4 =
+  Above 1 (Beside 1 p1 1 p2) 1 (Beside 1 p3 1 p4) 
+
+cyc p1 =
+  quartet p1 (Rot (Rot (Rot p1))) (Rot p1) (Rot (Rot p1))
+
+t = quartet p q r s 
+
+u = cyc (Rot q)
+
+side1 = quartet Nil Nil (Rot t) t
+
+side2 = quartet side1 side1 (Rot t) t
+
+corner1 = quartet Nil Nil Nil u
+
+corner2 = quartet corner1 side1 (Rot side1) u
+
+pseudocorner = quartet corner2 side2 (Rot side2) (Rot t)
+
+pseudolimit = cyc pseudocorner
+
+nonet p1 p2 p3 p4 p5 p6 p7 p8 p9 = 
+  Above 1 (Beside 1 p1 2 (Beside 1 p2 1 p3))
+        2 (Above 1 (Beside 1 p4 2 (Beside 1 p5 1 p6))
+	         1 (Beside 1 p7 2 (Beside 1 p8 1 p9)))
+
+corner = nonet corner2 side2 side2
+               (Rot side2) u (Rot t)
+	       (Rot side2) (Rot t) (Rot q)
+
+squarelimit = cyc corner
+
+final host = draw host corner ((0,0),(500,0),(0,500)) (0,0,500,500)
+skewedfinal host = draw host squarelimit ((0,0),(600,200),(200,600)) (0,0,800,800)
+
+main = getEnv "DISPLAY" exit $ \ host ->
+       xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $
+       final host
diff --git a/progs/demo/X11/graphics/sqrlmt.hu b/progs/demo/X11/graphics/sqrlmt.hu
new file mode 100644
index 0000000..7d46b0e
--- /dev/null
+++ b/progs/demo/X11/graphics/sqrlmt.hu
@@ -0,0 +1,3 @@
+:o= foldr inline constant
+henderson.hu
+sqrlmt.hs
diff --git a/progs/demo/X11/graphics/stop.pic b/progs/demo/X11/graphics/stop.pic
new file mode 100644
index 0000000..01ed7d6
--- /dev/null
+++ b/progs/demo/X11/graphics/stop.pic
@@ -0,0 +1 @@
+Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/graphics/strange.pic b/progs/demo/X11/graphics/strange.pic
new file mode 100644
index 0000000..5484b0b
--- /dev/null
+++ b/progs/demo/X11/graphics/strange.pic
@@ -0,0 +1,2 @@
+Overlay (Grid 200 200 [((110.00000000000000,28.000000000000000),(48.000000000000000,39.000000000000000)), ((143.00000000000000,45.000000000000000),(118.00000000000000,32.000000000000000)), ((165.00000000000000,97.000000000000000),(143.00000000000000,45.000000000000000)), ((149.00000000000000,142.00000000000000),(166.00000000000000,98.000000000000000)), ((80.000000000000000,155.00000000000000),(153.00000000000000,146.00000000000000)), ((31.000000000000000,124.00000000000000),(80.000000000000000,156.00000000000000)), ((24.000000000000000,64.000000000000000),(31.000000000000000,124.00000000000000)), ((52.000000000000000,34.000000000000000),(24.000000000000000,64.000000000000000))]) (Flip (File "text.pic"))
+
diff --git a/progs/demo/X11/graphics/text.pic b/progs/demo/X11/graphics/text.pic
new file mode 100644
index 0000000..87fd55c
--- /dev/null
+++ b/progs/demo/X11/graphics/text.pic
@@ -0,0 +1 @@
+Grid 200 200 [((177.00000000000000,91.000000000000000),(177.00000000000000,91.000000000000000)), ((172.00000000000000,63.000000000000000),(175.00000000000000,79.000000000000000)), ((164.00000000000000,73.000000000000000),(148.00000000000000,77.000000000000000)), ((159.00000000000000,63.000000000000000),(164.00000000000000,71.000000000000000)), ((148.00000000000000,63.000000000000000),(159.00000000000000,62.000000000000000)), ((146.00000000000000,61.000000000000000),(149.00000000000000,92.000000000000000)), ((122.00000000000000,61.000000000000000),(115.00000000000000,61.000000000000000)), ((130.00000000000000,62.000000000000000),(122.00000000000000,61.000000000000000)), ((133.00000000000000,75.000000000000000),(130.00000000000000,63.000000000000000)), ((124.00000000000000,89.000000000000000),(131.00000000000000,79.000000000000000)), ((111.00000000000000,81.000000000000000),(124.00000000000000,89.000000000000000)), ((114.00000000000000,61.000000000000000),(108.00000000000000,78.000000000000000)), ((88.000000000000000,64.000000000000000),(91.000000000000000,91.000000000000000)), ((73.000000000000000,62.000000000000000),(96.000000000000000,60.000000000000000)), ((65.000000000000000,97.000000000000000),(49.000000000000000,100.00000000000000)), ((61.000000000000000,80.000000000000000),(65.000000000000000,97.000000000000000)), ((46.000000000000000,79.000000000000000),(61.000000000000000,80.000000000000000)), ((45.000000000000000,61.000000000000000),(46.000000000000000,79.000000000000000)), ((61.000000000000000,63.000000000000000),(41.000000000000000,62.000000000000000))]
\ No newline at end of file
diff --git a/progs/demo/X11/logo/EXAMPLES.LOGO b/progs/demo/X11/logo/EXAMPLES.LOGO
new file mode 100644
index 0000000..bb89632
--- /dev/null
+++ b/progs/demo/X11/logo/EXAMPLES.LOGO
@@ -0,0 +1,70 @@
+(to nth :index :lst
+  (if (equal :index 1)
+     then (first :lst)
+     else (nth (difference :index 1) (butfirst :lst))))
+
+(to makelist :begin :end
+  (fput :begin (if (equal :begin :end)
+                   then [[]]
+                   else (makelist (sum :begin 1) :end))))
+
+(to wheel :centerright
+  [(hideturtle)
+   (pendown)
+   (setangle 90)
+   (setxy :centerright 350)
+   (repeat 72 times
+     [(forward 2)
+      (left 5)])])
+
+(to car 
+  [(pendown)
+   (hideturtle)
+   (setxy 400 350)
+   (setangle 90)
+   (forward 70)
+   (left 90)
+   (forward 100)
+   (right 60)
+   (forward 80)
+   (left 60)
+   (forward 100)
+   (left 60)
+   (forward 80)
+   (right 60)
+   (forward 70)
+   (left 90)
+   (forward 70)
+   (left 90)
+   (forward 350)
+   (wheel 350)
+   (wheel 150)])
+
+(to docar?
+  [(local "ans)
+   (print [do you want a car?])
+   (make "ans (read))
+   (if (equal (first ans) "yes)
+      then (car)
+      else [[oh well]])])
+
+(to poly :size :angles
+    [(hideturtle)
+     (pendown)
+     (setangle 90)
+     (repeat :angles times
+             [(forward :size)
+              (right (div 360 :angles))])])
+
+(make "x (makelist 3 12))
+
+(while (less (first x) 12)
+ [(make "x (butfirst x))
+  (print x)])
+
+(clean)
+
+(car)
+
+(poly 100 5)
+
diff --git a/progs/demo/X11/logo/README b/progs/demo/X11/logo/README
new file mode 100644
index 0000000..b483e2a
--- /dev/null
+++ b/progs/demo/X11/logo/README
@@ -0,0 +1,104 @@
+Ki-Wing Ho and Eric Fox
+Computer Science 429b
+Professor Hudak
+Final Project:  User Manual
+
+
+Control Commands:
+
+
+(DO <clause> WHILE <cond>)
+
+   Loop, executing a list of commands, then checking a condition and
+looping again if the condition is true.
+
+
+(REPEAT n TIMES)
+  WHILE cn cl
+  IF cn THEN cl1 [ELSE cl2]
+
+Load a file:
+  USE "filename
+
+Environment Commands:
+  MAKE "nm v
+  LOCAL "nm
+  TO :nm1 :nm2 :nm3 ... cl
+
+Text I/O:
+  PRINT v
+  READ
+
+Graphics Commands:
+  FORWARD n
+  BACKWARD n
+  SETXY n1 n2
+  LEFT n
+  RIGHT n
+  PENUP
+  PENDOWN
+  HIDETURTLE
+  SHOWTURTLE
+  CLEARSCREEN
+  CLEAN
+
+Graphics Functions:
+  XCOR
+  YCOR
+  GETANGLE
+  GETPEN
+  GETTURTLE
+
+Mathematical:
+  SUM n1 n2
+  DIFFERENCE n1 n2
+  PRODUCT n1 n2
+  MOD n1 n2
+  DIV n1 n2
+  POWER n1 n2
+
+Boolean:
+  AND b1 b2
+  OR b1 b2
+  NOT b
+
+Predicates:
+  WORDP v
+  LISTP v
+  NUMBERP v
+  GREATER n1 n2
+  LESS n1 n2
+  EQUAL v1 v2
+  
+Word/List:
+  FIRST t
+  LAST t
+  FPUT t l
+  BUTFIRST l
+  WORD w1 w2 w3 ...
+  LIST t1 t2 t3 ...
+  CONCAT l1 l2
+  SENTENCE t1 t2 t3 ...
+
+
+Our Logo interpreter will only support one of the three windowing
+modes: window mode, where the turtle, if it walks off the end of the
+screen, just continues going and does not wrap.  The two (unsupported)
+modes are fence mode where the turtle cannot walk off the end, and
+wrap mode.  The initial turtle state will be with the turtle hidden,
+the pen down, and the turtle in the center of the screen facing
+upwards.
+
+All input (both for commands as well as user-input) will be
+case-insensitive, and the interpreter needs to handle lists, words,
+integers, and boolean values.  Also, typing "GoodBye" at the LOGO>
+prompt exits the interpreter.
+
+All commands will be enclosed in parentheses, and all lists of
+commands will be enclosed in square brackets, so that there is no
+longer any need for the keyword "End". Also, all procedures will
+return the value of their last command, so that there are no Stop or
+Output commands.  IF statements should return the value of the last
+statement executed, but all looping constructs should return no value.
+
+
diff --git a/progs/demo/X11/logo/logo.hs b/progs/demo/X11/logo/logo.hs
new file mode 100644
index 0000000..458eca1
--- /dev/null
+++ b/progs/demo/X11/logo/logo.hs
@@ -0,0 +1,1345 @@
+{-
+
+Ki-Wing Ho and Eric Fox
+Computer Science 429b
+Professor Hudak
+Final Project:  LOGO Interpreter
+
+-}
+
+
+
+-------------------------------------------------------------------------------
+module REPLoop where
+
+{-
+
+REPLoop has two main parts: the first part (function logo) sets up the
+graphics window, prints a welcome message, initializes the variable
+and procedure environments and the turtle, accepts and lines's the
+user input, runs the read-eval-print loop (part two), and then closes
+the graphics window and exists; the second part (function repLoop)
+lexes and parses each command, prints an error message if there was a
+syntax error and evaluates (or tries to) if there wasn't, and then
+either prints the value or an error message or exits if the value
+returnd by the evaluator is "GoodBye".
+
+-}
+
+import Lexer
+import Parser
+import Evaluator
+import Xlib
+
+demo = main
+
+main = getEnv "DISPLAY" exit $ \ host ->
+       xHandleError ( \ (XError msg) -> appendChan stdout msg exit done) $
+       logo host
+
+logo :: String -> IO ()
+
+logo host =
+  xOpenDisplay host `thenIO` \ display ->
+
+  let (screen:_) = xDisplayRoots display
+      fg_color = xScreenWhitePixel screen
+      bg_color = xScreenBlackPixel screen
+      root = xScreenRoot screen
+  in
+  xCreateWindow root
+                (XRect 100 100 500 500)
+                [XWinBackground bg_color,
+                 XWinBackingStore XAlwaysBackStore] 
+  `thenIO` \ graphWindow ->
+  xSetWmName graphWindow "Logo" `thenIO` \ () ->
+  xSetWmIconName graphWindow "Logo" `thenIO` \ () ->
+  xMapWindow graphWindow `thenIO` \ () ->
+
+  xCreateGcontext (XDrawWindow root)
+                  [XGCBackground bg_color,
+                   XGCForeground fg_color] `thenIO` \ graphContext ->
+
+  xDisplayForceOutput display `thenIO` \ () ->
+
+  appendChan stdout ("Welcome to LOGO!\n" ++ prompt) exit $
+  readChan stdin exit $ \userInput ->
+  repLoop 
+    (varEnvsInit,procEnvsInit,turtleInit)
+    ((lines userInput,Lexer),
+     (graphWindow,display,graphContext,bg_color,fg_color)) $
+  xCloseDisplay display
+
+-- Initial Environments --
+
+varEnvsInit :: VarsType
+varEnvsInit  = [[("GOODBYE",GoodBye)]]
+
+-- all user-defined commands must have dummy entries
+procEnvsInit :: ProcsType
+procEnvsInit = (map (makeFakeProc)
+                    [("XCOR",0),("YCOR",0),("GETANGLE",0),("GETPEN",0),
+                     ("GETTURTLE",0),
+                     ("SUM",2),("DIFFERENCE",2),("PRODUCT",2),("MOD",2),
+                     ("DIV",2),("POWER",2),
+                     ("AND",2),("OR",2),("NOT",1),
+                     ("WORDP",1),("LISTP",1),("NUMBERP",1),("GREATER",2),
+                     ("EQUAL",2),("LESS",2),
+                     ("BUTFIRST",1),("FPUT",2),("CONCAT",2),
+                     ("FIRST",1),("LAST",1),("WORD",-2),("LIST",-2),
+                     ("SENTENCE",-2), ("USE",1)]):[]
+
+turtleInit :: TurtleType
+turtleInit   = (500 `div` 2,500 `div` 2,90,True,False)
+
+-- makes a dummy procedure
+makeFakeProc :: (NameType , Int) -> (NameType , ProcType)
+makeFakeProc (name,num) = (name,(makeArgs num,[]))
+
+makeArgs :: Int -> [NameType]
+makeArgs n | n > 0     = "" : makeArgs (n-1)
+           | otherwise = []
+
+-- keep running Read-Eval-Print Loop until user types GoodBye
+-- repLoop keeps running until user types "GoodBye", alternately
+--   lexing, parsing, and evaluating each command
+-- after a syntax error, the lex state is reset
+repLoop :: EnvsType -> StateType -> IO () -> IO ()
+repLoop e1 (inS1,gs1) end = 
+  let fail1 msg (is1,ls1) = errorOutput msg $
+                            repLoop e1 ((is1,Lexer),gs1) end
+        -- parser fail continuation doesn't contain graphics state
+      fail2 msg ((is2,ls2),gs2) = errorOutput msg $
+                                  repLoop e1 ((is2,Lexer),gs1) end
+        -- evaluator fail continuation does contain graphics state
+  in
+    parse [] inS1 fail1 $ \a ts inS2 ->
+    if (null ts)
+      then
+        evaluate e1 a (inS2,gs1) fail2 $ \v e2 ((is3,ls3),gs3) ->
+        output v end $
+        repLoop e2 ((is3,Lexer),gs3) end
+      else
+        fail1 "Syntax error:  expected end of line" inS2
+        -- repLoop will still be rerun
+
+-- print error message
+errorOutput :: String -> IO () -> IO ()
+errorOutput error = appendChan stdout (error ++ prompt) abort
+
+-- print expression value, exiting if GoodBye
+output :: Value -> IO () -> IO () -> IO ()
+output GoodBye end succ 
+  = appendChan stdout "\nGoodbye!\n"abort end
+output v       end succ
+  = appendChan stdout ((valueToString v) ++ prompt) abort succ
+
+prompt :: String
+prompt = "\nLOGO> "
+
+
+
+-------------------------------------------------------------------------------
+module Evaluator where
+
+{-
+
+Evaluator takes an Abstract Syntax Tree and evaluates it in the
+current environment, returning both the resultant value and the new
+environment (as well as the updated state, of which only the user
+input can actually be changed in the evaluator).
+
+A value can be of one of six types:  integer, string, list, and
+boolean, as well as null (for commands which don't return anything and
+newly-declared local variables), and goodbye, which allows logo to
+quit.
+
+The environment consists of three parts.  The variable environment and
+the procedure environment are separate (so that a name can refer both
+to a variable and a procedure:  Logo syntax is such that there is
+never any ambiguity) are both lists of name-value association lists.
+Each association list representes a "local environment", with each
+successive one being more "global", so that the last environment in
+the list is the global environment.  Local environments are produced
+by user-function invocations and removed at the end of those
+invocations.
+
+-}
+
+import Lexer
+import Parser
+import Xlib
+
+type NameType      = [Char]
+type WordType      = [Char]
+type Error         = [Char]
+
+type StateType     = (InputState , GraphicsState)
+type GraphicsState = (XWindow , XDisplay , XGcontext , XPixel , XPixel)
+type EnvsType      = (VarsType,ProcsType,TurtleType)
+type VarsType      = [[(NameType , Value)]]
+type ProcsType     = [[(NameType , ProcType)]]
+type TurtleType    = (Int , Int , Int , Bool , Bool)
+type ProcType      = ([NameType] , ClauseType)
+
+data Value         = Null
+                   | Num Int
+                   | Word WordType
+                   | List ListType
+                   | Boolean Bool
+                   | GoodBye
+                     deriving Text
+
+data ListType      = NullList | Value :* ListType
+                     deriving Text
+
+
+type EvalFailType  = Error -> StateType -> IO ()
+type EvalSuccType  = Value -> EnvsType -> StateType -> IO ()
+type EvalResType   = StateType -> EvalFailType -> EvalSuccType -> IO ()
+type EvaluateType  = EnvsType -> AST -> EvalResType
+
+
+evaluate :: EvaluateType
+
+evaluate (vs,p:ps,ttl) (To newName newProc)         ss fail succ
+  = succ Null (vs,((newName,newProc):p):ps,ttl) ss
+  -- procedures
+
+evaluate e             (Read)                       ((i:is,ls),gs) fail succ
+  = succ (List (makeReadList (lexerReadLine i))) e ((is,ls),gs)
+  -- user input
+
+evaluate e1            (Print [a])                  ss fail succ
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
+    appendChan stdout ((valueToString v)++"\n") abort $
+    succ Null e2 ss2
+  -- user output
+
+evaluate e             (Argument (Val (Word n)))    ss fail succ
+  = lookup e n ss fail $ \v ->
+    succ v e ss
+  -- variable reference
+
+evaluate e             (Argument (Val v))           ss fail succ
+  = succ v e ss
+  -- constant
+
+evaluate e             (Argument (QuotedWordArg n)) ss fail succ
+  = succ (Word n) e ss
+  -- string constant
+
+evaluate (v:vs,ps,ttl) (Local n)                    ss fail succ
+  = succ Null (((n,Null):v):vs,ps,ttl) ss
+  -- local variable declaraion
+  -- local returns null, and sets the new local variable to null also
+
+evaluate e             (ParseList l)                ss fail succ
+  = succ (List l) e ss
+  -- lists (also constant)
+
+evaluate e             (Loop l cond insts)          ss fail succ
+  = evalLoop l e cond insts ss fail succ
+  -- loops
+
+evaluate e             (If cond thens elses)        ss fail succ
+  = evalIf e cond thens elses ss fail succ
+  -- if-then[-eles] conditionals
+
+evaluate e1            (Command name as1)           ss fail succ
+  | ((na == length as1) || (na == -2))
+    = evalArgs e1 as1 ss fail $ \e2 as2 ss2 ->
+      apply name as2 e2 ss2 fail $ \v e3 ss3 ->
+      succ v e3 ss3
+  | na == -1
+    = fail ("Function does not exist:  " ++ name) ss
+  | otherwise
+    = fail ("Wrong number of arguments to " ++ name) ss
+  where na = numArgs e1 name
+  -- function applications
+
+evaluate e1            (Make n a)                   ss fail succ
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
+    update e2 n v $ \e3 ->
+    succ v e3 ss2
+  -- assignment statements, which return the assigned value
+
+evaluate e1            (Graphics name as1)          ss fail succ
+  = evalArgs e1 as1 ss fail $ \e2 as2 ss2 ->
+    doGraphics name as2 e2 ss2 fail $ \e3 ss3 ->
+    succ Null e3 ss3
+  -- side-effecting graphics statements, which all return null
+-- end evaluate
+
+
+-- evaluate a list of actual parameters, returning the corresponding
+--   list of values
+evalArgs :: EnvsType -> ParseArgs -> StateType -> EvalFailType ->
+            (EnvsType -> EvalArgs -> StateType -> IO ()) -> IO ()
+evalArgs e  []      ss fail succ
+  = succ e [] ss
+evalArgs e1 (a:as1) ss fail succ
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
+    evalArgs e2 as1 ss2 fail $ \e3 as2 ss3 ->
+    succ e3 (v:as2) ss3
+
+
+-- evaluate a list of commands, returning the value of the last one
+evalClause :: EnvsType -> ClauseType -> EvalResType
+evalClause e  []     ss fail succ
+  = succ Null e ss
+evalClause e  (a:[]) ss fail succ
+  = evaluate e a ss fail succ
+evalClause e1 (a:as) ss fail succ
+  = evaluate e1 a ss fail $ \v e2 ss2 ->
+    evalClause e2 as ss2 fail succ
+
+-- convert a lexed user-input list to a list constant
+makeReadList :: [WordType] -> ListType
+makeReadList []              = NullList
+makeReadList (w:ws) = (Word w) :* (makeReadList ws)
+
+
+-- Variable routines --
+
+-- look up a variable reference in the variable environment
+-- search the most-local environments first
+-- return an error if not found
+lookup :: EnvsType -> NameType -> StateType -> EvalFailType ->
+          (Value -> IO ()) -> IO ()
+lookup ([],ps,ttl)             name ss fail succ
+  = fail ("Unbound variable:  " ++ name) ss
+lookup ([]:vss,ps,ttl)         name ss fail succ
+  = lookup (vss,ps,ttl) name ss fail succ
+lookup (((n,v):vs):vss,ps,ttl) name ss fail succ
+  | n == name = succ v
+  | otherwise = lookup (vs:vss,ps,ttl) name ss fail succ
+
+-- update the variable environment
+-- replace the most-local occurrance  first; if none are found,
+--   create a new variable and place it in the most-global environment
+update :: EnvsType -> NameType -> Value -> (EnvsType -> IO ()) -> IO ()
+update ([]:[],ps,ttl) name value succ
+  = succ (((name,value):[]):[],ps,ttl)
+update ([]:vss,ps,ttl) name value succ
+  = update (vss,ps,ttl) name value $ \(vss2,ps2,ttl2) ->
+    succ ([]:vss2,ps2,ttl2)
+update (((n,v):vs):vss,ps,ttl) name value succ
+  | n == name = succ (((n,value):vs):vss,ps,ttl)
+  | otherwise = update (vs:vss,ps,ttl) name value $ \(vs2:vss2,ps2,ttl2) ->
+                succ (((n,v):vs2):vss2,ps2,ttl2)
+
+
+-- Control structures --
+
+-- evaluate loops
+evalLoop :: LoopType -> EnvsType -> ConditionType -> ClauseType ->
+            EvalResType
+evalLoop Do     = evalDo
+evalLoop While  = evalWhile
+evalLoop Repeat = evalRepeat
+
+-- evaluate while statements
+-- loop semantics:  evaluate condition; if true, evaluate clause, then loop
+-- while returns null
+evalWhile :: EnvsType -> ConditionType -> ClauseType -> EvalResType
+evalWhile e1 cond insts ss fail succ
+  = evalCond e1 cond ss fail $ \b e2 ss2 ->
+    if b
+      then
+        evalClause e2 insts ss2 fail $ \v e3 ss3 ->
+        evalWhile e3 cond insts ss3 fail succ
+      else
+        succ Null e2 ss2
+
+-- evaluate do-while statements
+-- loop semantics:  evaluate clause then evaluate condition; if true, loop
+evalDo :: EnvsType -> ConditionType -> ClauseType -> EvalResType
+evalDo e1 cond insts ss fail succ
+  = evalClause e1 insts ss fail $ \v e2 ss2 ->
+    evalCond e2 cond ss2 fail $ \b e3 ss3 ->
+    if b
+      then 
+        evalDo e3 cond insts ss3 fail succ
+      else
+        succ Null e3 ss3
+
+-- evaluate repeat statements
+-- loop semantics:  evaluate loop number as n; evaluate clause n times
+-- evaluate loop number and print error if it is negative or not an integer
+evalRepeat :: EnvsType -> ConditionType -> ClauseType -> EvalResType
+evalRepeat e1 cond insts ss fail succ
+  = evaluate e1 cond ss fail $ \v e2 ss2 ->
+    case v of
+      Num n     -> if (n >= 0)
+                     then doIterations e2 n insts ss2 fail succ
+                     else fail "Repeat: Iteration count cannot be negative" ss2
+      otherwise -> fail "Repeat:  Invalid iteration count" ss2
+
+-- perform loop interations:  evaluate "insts" "n" times
+doIterations :: EnvsType -> Int -> ClauseType -> EvalResType
+doIterations e  0     insts ss fail succ
+  = succ Null e ss
+doIterations e1 (n+1) insts ss fail succ
+  = evalClause e1 insts ss fail $ \v e2 ss2 ->
+    doIterations e2 n insts ss2 fail succ
+
+-- evaluates conditions and returns either true, false, or an error
+evalCond :: EnvsType -> ConditionType -> StateType -> EvalFailType ->
+            (Bool -> EnvsType -> StateType -> IO ()) -> IO ()
+evalCond e1 cond ss fail succ 
+  = evaluate e1 cond ss fail $ \v e2 ss2 ->
+    case v of
+      Boolean b -> succ b e2 ss2
+      otherwise -> fail "Invalid condition" ss2
+
+-- evaluate if-then[-else] statements
+evalIf :: EnvsType -> ConditionType -> ClauseType -> ClauseType -> EvalResType
+evalIf e1 cond thens elses ss fail succ
+  = evalCond e1 cond ss fail $ \b e2 ss2 ->
+    if b
+      then evalClause e2 thens ss2 fail succ
+      else evalClause e2 elses ss2 fail succ
+
+
+-- Function application --
+
+-- returns the number of arguments to a user-defined or built-in function
+-- -1 means the function wasn't found
+-- -2 means the function can take any number of arguments
+numArgs :: EnvsType -> CommandName -> Int
+numArgs (vs,[],ttl)     name
+  = -1
+numArgs (vs,[]:pss,ttl) name 
+  = numArgs (vs,pss,ttl) name
+numArgs (vs,((n,(formals,body)):ps):pss,ttl) name
+  | inList ["WORD","SENTENCE","LIST"] name = -2
+  | n == name                              = length formals
+  | otherwise                              = numArgs (vs,ps:pss,ttl) name
+
+-- apply a function to its arguments
+-- mostly just decides if it's user-defined or built-in, then dispatches
+apply :: CommandName -> EvalArgs -> EnvsType -> EvalResType
+apply n as e ss fail succ
+  | isBuiltIn n = applyPrimProc n as e ss fail succ
+  | otherwise   = applyUserProc (getProc e n) as e ss fail succ
+
+
+
+-- returns procedure "name" from the procedure environment
+-- searches most-local environments first
+-- precondition:  procedure does exist somewhere
+getProc :: EnvsType -> CommandName -> ProcType
+getProc (vss,[]:pss,ttl)        name
+  = getProc (vss,pss,ttl) name
+getProc (vs,((n,p):ps):pss,ttl) name
+  | n == name = p
+  | otherwise = getProc (vs,ps:pss,ttl) name
+
+-- apply user function:
+--   bind formal parameters
+--   create local enviroments
+--   evaluate body of function
+--   destroy local environments
+--   return value of body
+applyUserProc :: ProcType -> EvalArgs -> EnvsType -> EvalResType
+applyUserProc (formals,body) actuals e1 ss fail succ
+  = bind formals actuals e1 $ \e2 ->
+    evalClause e2 body ss fail $ \v (vs:vss,ps:pss,ts) ss2 ->
+    succ v (vss,pss,ts) ss2
+
+-- bind formal parameters to actuals in local environment
+bind :: [NameType] -> EvalArgs -> EnvsType -> (EnvsType -> IO ()) -> IO ()
+bind formals actuals (vss,pss,ttl) succ
+  = succ ((zip formals actuals):vss,[]:pss,ttl)
+
+
+-- Built-in functions --
+
+-- returns true for built-in functions
+isBuiltIn :: CommandName -> Bool
+isBuiltIn = inList ["XCOR","YCOR","GETANGLE","GETPEN","GETTURTLE",
+                    "SUM","DIFFERENCE","PRODUCT","MOD","DIV","POWER",
+                    "AND","OR","NOT",
+                    "WORDP","LISTP","NUMBERP","GREATER","EQUAL","LESS",
+                    "BUTFIRST","FPUT","CONCAT",
+                    "FIRST","LAST","WORD","LIST","SENTENCE", "USE"]
+
+
+-- applies a built-in function to its arguments
+applyPrimProc :: CommandName -> [Value] -> EnvsType -> EvalResType
+
+applyPrimProc "XCOR"      [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = succ (Num x) (vs,ps,(x,y,a,p,t)) ss
+applyPrimProc "YCOR"      [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = succ (Num y) (vs,ps,(x,y,a,p,t)) ss
+applyPrimProc "GETANGLE"  [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = succ (Num a) (vs,ps,(x,y,a,p,t)) ss
+applyPrimProc "GETPEN"    [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = succ (Boolean p) (vs,ps,(x,y,a,p,t)) ss
+applyPrimProc "GETTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = succ (Boolean t) (vs,ps,(x,y,a,p,t)) ss
+
+applyPrimProc "SUM"        [Num a , Num b] e ss fail succ
+  = succ (Num (a+b)) e ss
+applyPrimProc "DIFFERENCE" [Num a , Num b] e ss fail succ
+  = succ (Num (a-b)) e ss
+applyPrimProc "PRODUCT"    [Num a , Num b] e ss fail succ
+  = succ (Num (a*b)) e ss
+applyPrimProc "MOD"        [Num a , Num b] e ss fail succ
+  = succ (Num (a `mod` b)) e ss
+applyPrimProc "DIV"        [Num a , Num b] e ss fail succ
+  = succ (Num (a `div` b)) e ss
+applyPrimProc "POWER"      [Num a , Num b] e ss fail succ
+  | b >= 0 = succ (Num (a^b)) e ss
+  | otherwise = fail ("Negative exponent:  " ++ (show b)) ss
+
+applyPrimProc "AND" [Boolean a , Boolean b] e ss fail succ
+  = succ (Boolean (a && b)) e ss
+applyPrimProc "OR"  [Boolean a , Boolean b] e ss fail succ
+  = succ (Boolean (a || b)) e ss
+applyPrimProc "NOT" [Boolean a]             e ss fail succ
+  = succ (Boolean (not a)) e ss
+
+applyPrimProc "WORDP"   [Word w]                e ss fail succ
+  = succ (Boolean True) e ss
+applyPrimProc "WORDP"   [v]                     e ss fail succ
+  = succ (Boolean False) e ss
+applyPrimProc "NUMBERP" [Num n]                 e ss fail succ
+  = succ (Boolean True) e ss
+applyPrimProc "NUMBERP" [v]                     e ss fail succ
+  = succ (Boolean False) e ss
+applyPrimProc "LISTP"   [List l]                e ss fail succ
+  = succ (Boolean True) e ss
+applyPrimProc "LISTP"   [v]                     e ss fail succ
+  = succ (Boolean False) e ss
+applyPrimProc "GREATER" [Num a , Num b]         e ss fail succ
+  = succ (Boolean (a > b)) e ss
+applyPrimProc "EQUAL"   [Num a , Num b]         e ss fail succ
+  = succ (Boolean (a == b)) e ss
+applyPrimProc "EQUAL"   [Word a , Word b]       e ss fail succ
+  = succ (Boolean (a == b)) e ss
+applyPrimProc "EQUAL"   [Boolean a , Boolean b] e ss fail succ
+  = succ (Boolean (a == b)) e ss
+applyPrimProc "LESS"    [Num a , Num b]         e ss fail succ
+  = succ (Boolean (a < b)) e ss
+
+applyPrimProc "BUTFIRST" [Word ""]                     e ss fail succ
+  = succ (Word "") e ss
+applyPrimProc "BUTFIRST" [Word (c:cs)]                 e ss fail succ
+  = succ (Word cs) e ss
+applyPrimProc "BUTFIRST" [List NullList]               e ss fail succ
+  = succ (List NullList) e ss
+applyPrimProc "BUTFIRST" [List (v :* vs)]              e ss fail succ
+  = succ (List vs) e ss
+applyPrimProc "FPUT"     [v , List l]                  e ss fail succ
+  = succ (List (v :* l)) e ss
+applyPrimProc "CONCAT"   [List l1 , List l2]           e ss fail succ
+  = succ (List (listConcatenate l1 l2)) e ss
+applyPrimProc "FIRST"    [Word (c:cs)]                 e ss fail succ
+  = succ (Word (c:[])) e ss
+applyPrimProc "FIRST"    [List (v :* vs)]              e ss fail succ
+  = succ v e ss
+applyPrimProc "LAST"     [Word (c:[])]                 e ss fail succ
+  = succ (Word (c:[])) e ss
+applyPrimProc "LAST"     [Word ""]                     e ss fail succ
+  = succ Null e ss
+applyPrimProc "LAST"     [Word (c:cs)]                 e ss fail succ
+  = applyPrimProc "LAST" [(Word cs)] e ss fail succ
+applyPrimProc "LAST"     [List (v :* NullList)]        e ss fail succ
+  = succ v e ss
+applyPrimProc "LAST"     [List (v :* vs)]              e ss fail succ
+  = applyPrimProc "LAST" [(List vs)] e ss fail succ
+applyPrimProc "WORD"     []                            e ss fail succ
+  = succ (Word "") e ss
+applyPrimProc "WORD"     ((Word w):ws)                 e ss fail succ
+  = applyPrimProc "WORD" ws e ss fail $ \(Word wsc) e2 ss2 ->
+    succ (Word (w ++ wsc)) e2 ss2
+applyPrimProc "LIST"     (v:vs)                        e ss fail succ
+  = applyPrimProc "LIST" vs e ss fail $ \(List l) e2 ss2 ->
+    succ (List (v :* l)) e2 ss2
+applyPrimProc "LIST"     []                            e ss fail succ
+  = succ (List NullList) e ss
+applyPrimProc "SENTENCE" []                            e ss fail succ
+  = succ (List NullList) e ss
+applyPrimProc "SENTENCE" ((List l):[])                 e ss fail succ
+  = succ (List l) e ss
+applyPrimProc "SENTENCE" ((List l):vs)                 e ss fail succ
+  = applyPrimProc "SENTENCE" [List l] e  ss  fail $ \(List s1) e2 ss2 ->
+    applyPrimProc "SENTENCE" vs       e2 ss2 fail $ \(List s2) e3 ss3 ->
+    succ (List (listConcatenate s1 s2)) e3 ss3
+applyPrimProc "SENTENCE" (v:vs)                        e ss fail succ
+  = applyPrimProc "SENTENCE" vs e ss fail $ \(List ws) e2 ss2 ->
+    succ (List (v :* ws)) e2 ss2
+
+applyPrimProc "USE" [Word filename]                   
+              e 
+              ss@((ins, ls), gs)
+              fail succ
+  = readFile filename (\ _ -> fail ("Can't read file: " ++ filename) ss) 
+    $ \filecontents ->
+    useRepLoop e ((lines filecontents, Lexer), gs) 
+               (\ msg s -> fail msg ss) $ \ v e s -> 
+    succ v e ss
+                         
+applyPrimProc n          _                             _ ss fail _
+  = fail ("Incorrect arguments:  " ++ n) ss
+
+useRepLoop :: EnvsType -> EvalResType 
+useRepLoop e  s@(([], ls), gs) fail succ = succ (Word "OK") e s
+useRepLoop e1 s1@(inS1,gs1) fail succ = 
+    parse [] inS1 (\ msg ins -> fail msg (ins, gs1)) $ \a ts inS2 ->
+    if (null ts)
+      then
+        evaluate e1 a (inS2,gs1) fail $ \v e2 s3 ->
+        useRepLoop e2 s3 fail succ
+      else
+        fail "Syntax error:  expected end of line" (inS2, gs1)
+
+
+
+-- concatenates two lists
+listConcatenate :: ListType -> ListType -> ListType
+listConcatenate NullList  l2 = l2
+listConcatenate (v :* l1) l2 = (v :* (listConcatenate l1 l2))
+
+
+-- Graphics --
+
+type EvalArgs = [Value]
+type GraphEnv = (Int,Int,Int,Bool)
+
+-- evaluates side-effecting graphics functions
+-- note:  none of them return values
+doGraphics :: CommandName -> EvalArgs -> EnvsType -> StateType -> 
+              EvalFailType -> (EnvsType -> StateType -> IO ()) -> IO ()
+
+doGraphics "HIDETURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = hideTurtle x y a ss $
+    succ (vs,ps,(x,y,a,p,False)) ss
+  -- hide turtle, appropriately adjust environment
+
+doGraphics "SHOWTURTLE" [] (vs,ps,(x,y,a,p,t)) ss fail succ
+  = showTurtle x y a ss $
+    succ (vs,ps,(x,y,a,p,True)) ss
+  -- show turtle, appropriately adjust environment
+
+doGraphics name as (vs,ps,(x,y,a,p,True)) ss fail succ
+  = hideTurtle x y a ss $
+    moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) ->
+    showTurtle x2 y2 a2 ss $
+    succ (vs,ps,(x2,y2,a2,p2,True)) ss
+  -- executes graphics commands if turtle is shownn
+
+doGraphics name as (vs,ps,(x,y,a,p,False)) ss fail succ
+  = moveTurtle name as (x,y,a,p) ss $ \(x2,y2,a2,p2) ->
+    succ (vs,ps,(x2,y2,a2,p2,False)) ss
+  -- executes graphics commands if turtle is not shown
+
+-- converts an integer to a float
+toFloat :: Int -> Float
+toFloat = fromInteger . toInteger
+
+newmod a b = let c = a `mod` b
+             in if (c < 0) then (c + b) else c
+
+-- shows the turtle, but returns nothing
+showTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO ()
+showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ
+  = let dx1 = round (12 * cos (toFloat a * pi/180))
+        dx2 = round (4  * sin (toFloat a * pi/180))
+	dy1 = round (12 * sin (toFloat a * pi/180))
+	dy2 = round (4  * cos (toFloat a * pi/180))
+    in 
+    xDrawLine (XDrawWindow graphWindow) 
+              graphContext
+	      (XPoint x y) 
+	      (XPoint (x-dx1-dx2) (y+dy1-dy2))
+    `thenIO` \ () ->
+    xDrawLine (XDrawWindow graphWindow)
+              graphContext
+	      (XPoint x y)
+	      (XPoint (x-dx1+dx2) (y+dy1+dy2))
+    `thenIO` \ () ->
+    xDrawLine (XDrawWindow graphWindow)
+              graphContext
+	      (XPoint (x-dx1-dx2) (y+dy1-dy2))
+	      (XPoint (x-dx1+dx2) (y+dy1+dy2))
+    `thenIO` \ () ->
+    xDisplayForceOutput display
+    `thenIO_`
+    succ
+
+-- hides the turtle, but returns nothing
+hideTurtle :: Int -> Int -> Int -> StateType -> IO () -> IO ()
+hideTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) succ
+  = xUpdateGcontext graphContext [XGCForeground bg] 
+    `thenIO_`
+    (showTurtle x y a (is,(graphWindow,display,graphContext,bg,fg)) $
+    (xUpdateGcontext graphContext [XGCForeground fg]
+    `thenIO_`
+    succ))
+
+-- performs all graphics commands that don't involve hiding/showing 
+--   the turtle
+moveTurtle :: CommandName -> EvalArgs -> GraphEnv -> StateType ->
+              (GraphEnv -> IO ()) -> IO ()
+moveTurtle "SETXY"       [Num xp,Num yp] (x,y,a,p) ss succ
+  = succ (xp,yp,a,p)
+
+-- move the turtle forward "d" times, drawing a line if pen is down
+moveTurtle "FORWARD"     [Num d]         (x,y,a,p) 
+           (is,(graphWindow,display,graphContext,fg,bg)) succ
+  = let xp = x + round (toFloat d * cos (toFloat a * pi/180))
+        yp = y - round (toFloat d * sin (toFloat a * pi/180)) in 
+     (if p 
+        then (xDrawLine (XDrawWindow graphWindow) 
+	                graphContext
+			(XPoint x y) 
+			(XPoint xp yp))
+        else returnIO ()) `thenIO` \ () ->
+     xDisplayForceOutput display `thenIO` \ () ->
+     succ (xp,yp,a,p)
+
+-- move the turtle backward "d" pixels, drawing a line if pen is down
+moveTurtle "BACKWARD"    [Num d]         (x,y,a,p) ss succ
+  = moveTurtle "FORWARD" [Num (-d)] (x,y,a,p) ss succ
+
+-- rotate turtle to "ap" degrees from facing due east
+moveTurtle "SETANGLE"    [Num ap]        (x,y,a,p) ss succ
+  = succ (x,y,ap,p)
+
+-- rotate turtle counterclockwise "ap" degrees
+moveTurtle "LEFT"        [Num ap]        (x,y,a,p) ss succ
+  = succ (x,y, (a + ap) `newmod` 360 ,p)
+
+-- rotate turtle clockwise "ap" degrees
+moveTurtle "RIGHT"       [Num ap]        (x,y,a,p) ss succ
+  = succ (x,y, (a - ap) `newmod` 360 ,p)
+
+-- pick pen up
+moveTurtle "PENUP"       []              (x,y,a,p) ss succ
+  = succ (x,y,a,False)
+
+-- put pen down
+moveTurtle "PENDOWN"     []              (x,y,a,p) ss succ
+  = succ (x,y,a,True)
+
+-- clear screen but don't otherwise alter turtle state
+moveTurtle "CLEARSCREEN" []              (x,y,a,p) 
+           (is,(graphWindow,display,graphContext,bg,fg)) succ
+  = xClearArea graphWindow (XRect 0 0 500 500) True 
+    `thenIO` \() ->
+    xDisplayForceOutput display 
+    `thenIO` \() ->
+    succ (x,y,a,p)
+
+-- pick pen up and reset turtle
+moveTurtle "CLEAN"       []              (x,y,a,p) 
+           (is,(graphWindow,display,graphContext,bg,fg)) succ
+  = xClearArea graphWindow (XRect 0 0 500 500) True 
+    `thenIO` \() ->
+    xDisplayForceOutput display 
+    `thenIO` \() ->
+    succ (500 `div` 2,500 `div` 2,90,True)
+
+-- do nothing if arguments are incorrect
+moveTurtle _ _ e _ succ = succ e
+
+
+-- valueToString, etc. --
+
+-- convert a value to a string
+valueToString :: Value -> String
+valueToString (Word w)        = w
+valueToString (Num n)         = show n
+valueToString (Boolean True)  = "TRUE"
+valueToString (Boolean False) = "FALSE"
+valueToString Null            = ""
+valueToString (List l)        = "[" ++ (listToString l) ++ "]"
+valueToString GoodBye         = "Don't play around with this variable!"
+
+-- convert a list to a string
+listToString :: ListType -> String
+listToString NullList        = ""
+listToString (v :* NullList) = valueToString v
+listToString (v :* l)        = (valueToString v) ++ " " ++ (listToString l)
+
+
+
+-------------------------------------------------------------------------------
+module Lexer where
+
+{-
+
+Lexer takes as input a line from standard input and returns an ordered
+pair containing the translation of that list into tokens as well as
+the current state of the lexer (how many parentheses and brackets are
+still open).  The state is necessary because some commands may take
+multiple lines, so a bracket (say) may be left open on one line to be
+closed later on.
+
+All unmatched close brackets and parentheses are treated as spaces
+(and therefore ignored).
+
+The method for tokenizing commands is:
+
+  All words are delimited by spaces, parenthesis, or brackets.
+
+  All words beginning with a double quote are returned as quoted words
+  rather than normal words.
+
+  Any character preceded by a backslash is taken as is, rather than
+  tokenized normally.
+
+  All words are translated to upper case..
+
+The method for tokenizing user input is:
+
+  All words are delimited by spaces and translated to upper case.
+  
+-}
+
+import Parser
+import Evaluator
+
+
+data LexState = Lexer | LexerBracket Int LexState | LexerParen Int LexState
+                deriving Text
+
+type LexerType = [Char] -> ([Token] , LexState)
+
+data Token   = OpenBracket 
+             | CloseBracket 
+             | OpenParen 
+             | CloseParen
+             | QuotedWord WordType
+             | Normal WordType     deriving (Text,Eq)
+
+
+-- call appropriate lex procedure depending upon the current lex state
+lexDispatch :: LexState -> LexerType
+lexDispatch (Lexer)            = lexer
+lexDispatch (LexerBracket n s) = lexerBracket n s
+lexDispatch (LexerParen n s)   = lexerParen n s
+
+
+-- handle commands
+lexer :: LexerType
+lexer []       = ([] , Lexer)
+lexer (' ':cs) = lexer cs
+lexer ('[':cs) = let (ts , s) = lexerBracket 1 (Lexer) cs
+                 in (OpenBracket : ts , s)
+lexer ('(':cs) = let (ts , s) = lexerParen 1 (Lexer) cs
+                 in (OpenParen : ts , s)
+lexer (')':cs) = lexer cs
+lexer (']':cs) = lexer cs
+lexer ('"':cs) = let (t , cs2) = lexerWord (isDelimiter) cs
+                     (ts , s)  = lexer cs2
+                 in ((QuotedWord (upWord t)):ts , s)
+lexer cs       = let (t , cs2) = lexerWord (isDelimiter) cs
+                     (ts , s)  = lexer cs2
+                 in ((Normal (upWord t)):ts , s)
+
+lexerWord :: (Char -> Bool) -> [Char] -> (WordType , [Char])
+lexerWord endCond []
+  = ([] , [])
+lexerWord endCond (c:cs)
+  | c == '\\' = if cs == []
+                  then ("\\" , cs)
+                  else 
+                    let (t , cs2) = lexerWord endCond (tail cs)
+                    in ((head cs):t , cs2)
+  | endCond c = ([] , (c:cs))
+  | otherwise = let (t , cs2) = lexerWord endCond cs
+                in ((toUpper c):t , cs2)
+
+
+-- performs lexing inside brackets
+lexerBracket :: Int -> LexState -> LexerType
+lexerBracket n s []
+  = ([] , LexerBracket n s)
+lexerBracket n s (' ':cs)
+  = lexerBracket n s cs
+lexerBracket 1 s (']':cs)
+  = let (ts , s2) = lexDispatch s cs
+    in (CloseBracket:ts , s2)
+lexerBracket n s (']':cs)
+  = let (ts , s2) = lexerBracket (n-1) s cs
+    in (CloseBracket:ts , s2)
+lexerBracket n s ('[':cs)
+  = let (ts , s2) = lexerBracket (n+1) s cs
+    in (OpenBracket:ts , s2)
+lexerBracket n s ('(':cs)
+  = let (ts , s2) = lexerParen 1 (LexerBracket n s) cs
+    in (OpenParen:ts , s2)
+lexerBracket n s (')':cs)
+  = lexerBracket n s cs
+lexerBracket n s cs
+  = let (t , cs2) = lexerWord (isDelimiter) cs
+        (ts , s2) = lexerBracket n s cs2
+    in ((Normal (upWord t)):ts , s2)
+
+
+-- performs lexing inside parentheses
+lexerParen :: Int -> LexState -> LexerType
+lexerParen n s []
+  = ([] , LexerParen n s)
+lexerParen n s (' ':cs)
+  = lexerParen n s cs
+lexerParen 1 s (')':cs)
+  = let (ts , s2) = lexDispatch s cs
+    in (CloseParen:ts , s2)
+lexerParen n s (')':cs)
+  = let (ts , s2) = lexerParen (n-1) s cs
+    in (CloseParen:ts , s2)
+lexerParen n s ('(':cs)
+  = let (ts , s2) = lexerParen (n+1) s cs
+    in (OpenParen:ts , s2)
+lexerParen n s ('[':cs)
+  = let (ts , s2) = lexerBracket 1 (LexerParen n s) cs
+    in (OpenBracket:ts , s2)
+lexerParen n s (']':cs)
+  = lexerParen n s cs
+lexerParen n s ('"':cs)
+  = let (t , cs2) = lexerWord (isDelimiter) cs
+        (ts , s2) = lexerParen n s cs2
+    in ((QuotedWord (upWord t)):ts , s2)
+lexerParen n s cs
+  = let (t , cs2) = lexerWord (isDelimiter) cs
+        (ts , s2) = lexerParen n s cs2
+    in ((Normal (upWord t)):ts , s2)
+
+
+-- returns true for delimiters
+isDelimiter :: Char -> Bool
+isDelimiter = inList " []()"
+
+-- returns true of p is in cs
+inList :: (Eq a) => [a] -> a -> Bool
+inList [] p     = False
+inList (c:cs) p = (c == p) || (inList cs p)
+
+
+-- handle user input
+lexerReadLine :: [Char] -> [WordType]
+lexerReadLine []
+  = []
+lexerReadLine (' ':cs)
+  = lexerReadLine cs
+lexerReadLine cs
+  = let (firstWord,restOfWords) = span (/= ' ') cs 
+    in (upWord firstWord) : lexerReadLine restOfWords
+
+-- translate a word to upper case
+upWord :: WordType -> WordType
+upWord = map (toUpper)
+
+
+
+-------------------------------------------------------------------------------
+module Parser where
+
+{-
+
+Parser takes a list of tokens, the input state, and fail and success
+continuations and returns an Abstract Syntax Tree, the remaining
+tokens (hopefully none), and the new input state.  The input state
+will be changed every time Parser runs out of tokens:  it simply grabs
+(and lexes) the next line of user-input.  It therefore doesn't return
+anything until the entire AST has been be read in, even if it spans
+several lines, though parse may catch some errors before all lines
+have been input.  In this case, it ceases taking input and returns the
+error.
+
+An Abstract Syntax Tree represents one command, and breaks those
+commands into Ifs, Loops, Tos, Locals, Makes, Reads, Prints,
+Constants, List constants, Graphics commands (which produce
+side-effects), and function applications.  All built-in commands that
+don't fit into one of those categories are lumped into function
+applications along with user-defined functions.  Each type of AST is
+parsed into subcommands, subclauses (lists of commands), command
+arguments (also subcommands), and any other values that will be
+immediately-evaluatable (such as function names).
+
+-}
+
+
+import Lexer
+import Evaluator
+
+
+type CommandName     = [Char]
+type ClauseType      = [AST]
+type ConditionType   = AST
+
+type ParseArgs       = [AST]
+
+data ArgType         = Val Value | QuotedWordArg WordType
+                       deriving Text
+
+data AST             = ParseList ListType
+                     | If ConditionType ClauseType ClauseType
+                     | Loop LoopType ConditionType ClauseType
+                     | To NameType ProcType
+                     | Make NameType AST
+                     | Local NameType
+                     | Read
+                     | Print ParseArgs
+                     | Argument ArgType
+                     | Graphics CommandName ParseArgs
+                     | Command CommandName ParseArgs      deriving Text
+
+data LoopType        = Do | While | Repeat
+                       deriving Text
+
+type ParseFailType   = Error -> InputState -> IO ()
+type ParseType       = [Token] -> InputState -> ParseFailType ->
+                       (AST -> [Token] -> InputState -> IO ()) -> IO ()
+type ParseClauseType = [Token] -> InputState -> ParseFailType -> 
+                       (ClauseType -> [Token] -> InputState -> IO ()) -> IO ()
+
+type InputState      = ([[Char]] , LexState)
+
+parse :: ParseType
+
+parse [] (i:is , ls) fail succ 
+  = let (ts , ls2) = lexDispatch ls i
+    in parse ts (is , ls2) fail succ  
+
+parse ((QuotedWord s) : ts) inS fail succ 
+  = succ (Argument (QuotedWordArg s)) ts inS
+
+parse ((Normal s) : ts) inS fail succ
+  = succ (Argument (Val (process s))) ts inS
+
+parse (OpenParen : []) (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parse (OpenParen:ts) (is,ls2) fail succ
+
+parse (OpenParen : (Normal t) : ts) inS fail succ
+  | t == "TO"    = makeProc ts inS fail succ
+  | t == "MAKE"  = makeMake ts inS fail succ
+  | t == "LOCAL" = makeLocal ts inS fail succ
+  | t == "READ"  = makeRead ts inS fail succ
+  | t == "PRINT" = makePrint ts inS fail succ
+  | t == "IF"    = makeIf ts inS fail succ
+  | isLoop t     = makeLoop t ts inS fail succ
+  | isGraphics t = makeGraphics t ts inS fail succ
+  | otherwise    = makeCommand t ts inS fail succ
+
+parse (OpenBracket : ts) inS fail succ
+  = parseList ts inS fail succ
+
+parse ts inS@([], _) _ succ = succ (Argument (Val (Word "GOODBYE"))) ts inS
+
+parse _ inS fail _
+  = fail "Syntax error" inS
+
+
+-- returns true for all loop names
+isLoop :: CommandName -> Bool
+isLoop = inList ["DO","WHILE","REPEAT"]
+
+-- returns true for all side-effecting graphics command names
+isGraphics :: CommandName -> Bool
+isGraphics = inList ["FORWARD","BACKWARD","LEFT","RIGHT",
+                     "SETXY","SETANGLE","PENUP","PENDOWN",
+                     "HIDETURTLE","SHOWTURTLE","CLEARSCREEN","CLEAN"]
+
+-- Parse lists --
+
+-- parses a list constant
+parseList :: ParseType
+parseList []                  (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseList ts (is,ls2) fail succ
+parseList (CloseBracket:ts)   inS fail succ
+  = succ (ParseList NullList) ts inS
+parseList (OpenBracket:ts)    inS fail succ
+  = parseList ts inS fail $ \(ParseList l1) ts2 inS2 ->
+    parseList ts2 inS2 fail $ \(ParseList l2) ts3 inS3 ->
+    succ (ParseList ((List l1) :* l2)) ts3 inS3
+parseList ((Normal w):ts)     inS fail succ
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
+    succ (ParseList ((process w) :* l)) ts2 inS2
+parseList (OpenParen:ts)      inS fail succ
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
+    succ (ParseList ((Word "(") :* l)) ts2 inS2
+parseList (CloseParen:ts)     inS fail succ
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
+    succ (ParseList ((Word ")") :* l)) ts2 inS2
+parseList ((QuotedWord w):ts) inS fail succ
+  = parseList ts inS fail $ \(ParseList l) ts2 inS2 ->
+    succ (ParseList ((Word w) :* l)) ts2 inS2
+
+
+-- parses constant values, distinguishing words from integers and booleans
+process :: WordType -> Value
+process "TRUE"  = Boolean True
+process "FALSE" = Boolean False
+process ('-':w)
+  | all isDigit w = Num (- (stringToNum (reverse w)))
+  | otherwise     = Word ('-':w)
+process w
+  | all isDigit w = Num (stringToNum (reverse w))
+  | otherwise     = Word w
+
+-- converts a string to a positive integer
+stringToNum :: String -> Int
+stringToNum (d:[]) = charToDigit d
+stringToNum (d:ds) = (charToDigit d) + 10 * stringToNum ds
+
+-- converts a character to a digit
+charToDigit :: Char -> Int
+charToDigit c = ord c - ord '0'
+
+
+-- Parse command statements --
+
+-- parses commands
+-- format:  (<name> <arg1> <arg2> ...)
+makeCommand :: CommandName -> ParseType
+makeCommand n ts inS fail succ
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
+    succ (Command n as) ts2 inS2
+
+
+-- parses a list of commands that are terminated by token "term""
+parseArgs :: Token -> ParseClauseType
+parseArgs term [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseArgs term ts (is,ls2) fail succ
+parseArgs term (t:ts) inS fail succ
+  | t == term = succ [] ts inS
+  | otherwise = parse (t:ts) inS fail $ \a ts2 inS2 ->
+                parseArgs term ts2 inS2 fail $ \as ts3 inS3 ->
+                succ (a:as) ts3 inS3
+
+
+-- Parse I/O statements --
+
+-- parses read statements
+-- format:  (READ)
+makeRead :: ParseType
+makeRead (CloseParen:ts) inS fail succ
+  = succ Read ts inS
+makeRead _ inS fail _
+  = fail "Read:  too many arguments" inS
+
+-- parses print statements
+-- format:  (PRINT <arg1>)
+makePrint :: ParseType
+makePrint ts inS fail succ
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
+    if (length as) == 1
+      then succ (Print as) ts2 inS2
+      else fail "Print:  too many arguments" inS
+
+
+
+-- Parse TO statements --
+
+
+-- parses to statements
+-- format:  (TO <name> <fpname1> <fpname2> ... <clause>)
+-- note:  all formal parameter names must begin with a colon
+makeProc :: ParseType
+makeProc [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in makeProc ts (is,ls2) fail succ
+makeProc ((Normal t):ts) inS fail succ
+  = parseFormals ts inS fail $ \p ts2 inS2 -> 
+    getParen ts2 inS2 fail $ \ts3 inS3 ->
+    succ (To t p) ts3 inS3
+makeProc _ inS fail _
+  = fail "Invalid procedure name" inS
+
+-- parses the formal parameters
+-- takes all words beginning with a colon, and assumes everything
+--   after that is part of the body
+parseFormals :: [Token] -> InputState -> ParseFailType ->
+                (([NameType] , ClauseType) -> [Token] -> InputState -> IO ())
+                -> IO ()
+parseFormals [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseFormals ts (is,ls2) fail succ
+parseFormals (OpenBracket:ts) inS fail succ
+  = parseClause (OpenBracket:ts) inS fail $ \pb ts2 inS2 ->
+    succ ([],pb) ts2 inS2
+parseFormals ((Normal (':':c:cs)):ts) inS fail succ
+  = parseFormals ts inS fail $ \(formals,pb) ts2 inS2 ->
+    succ ((':':c:cs):formals , pb) ts2 inS2
+parseFormals ts inS fail succ
+  = parseClause ts inS fail $ \pb ts2 inS2 ->
+    succ ([],pb) ts2 inS2
+
+
+-- Parse MAKE statements --
+
+-- parses make statements
+-- format:  (MAKE <name> <arg>)
+-- note:  <name> must be quoted
+makeMake :: ParseType
+makeMake [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in makeMake ts (is,ls2) fail succ
+makeMake ((QuotedWord s):ts) inS fail succ
+  = parse ts inS fail $ \a ts2 inS2 ->
+    getParen ts2 inS2 fail $ \ts3 inS3 ->
+    succ (Make s a) ts3 inS3
+makeMake _ inS fail _
+  = fail "Make:  Improper variable name" inS
+
+
+-- Parse LOCAL statements --
+
+-- parses local statements
+-- format:  (LOCAL <name>)
+-- note:  <name> must be quoted  
+makeLocal :: ParseType
+makeLocal [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in makeLocal ts (is,ls2) fail succ
+makeLocal (t:[]) (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in makeLocal (t:ts) (is,ls2) fail succ
+makeLocal ((QuotedWord s):CloseParen:ts) inS fail succ
+  = succ (Local s) ts inS
+makeLocal _ inS fail _
+  = fail "Local:  improper variable name" inS
+
+
+-- Parse IF statements --
+
+-- parses if-then and if-then-else statements
+-- format:  (IF <cond> then <clause> [else <clause>])
+makeIf :: ParseType
+makeIf [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in makeIf ts (is,ls2) fail succ
+makeIf ts inS fail succ
+  = parse ts inS fail $ \cond ts2 inS2 ->
+    parseThen ts2 inS2 fail $ \thens elses ts3 inS3 ->
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
+    succ (If cond thens elses) ts4 inS4
+
+
+-- parses then clauses
+parseThen :: [Token] -> InputState -> ParseFailType ->
+             (ClauseType -> ClauseType -> [Token] -> InputState -> IO ()) -> 
+             IO ()
+parseThen [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseThen ts (is,ls2) fail succ
+parseThen ((Normal "THEN"):ts) inS fail succ
+  = parseClause ts inS fail $ \thens ts2 inS2 ->
+    parseElse ts2 inS2 fail $ \elses ts3 inS3 ->
+    succ thens elses ts3 inS3
+parseThen _ inS fail _
+  = fail "IF:  improper THEN clause" inS
+
+-- parses (optional) else clauses
+parseElse :: ParseClauseType
+parseElse [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseElse ts (is,ls2) fail succ
+parseElse (CloseParen:ts) inS fail succ
+  = succ [] (CloseParen:ts) inS
+parseElse ((Normal "ELSE"):ts) inS fail succ
+  = parseClause ts inS fail succ
+parseElse _ inS fail _
+  = fail "IF:  improper ELSE clause" inS
+
+-- parses clauses
+-- a clause is either a list of commands enclosed in brackets, or a
+--   single command
+parseClause :: ParseClauseType
+parseClause [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseClause ts (is,ls2) fail succ
+parseClause (OpenBracket:ts) inS fail succ
+  = parseArgs CloseBracket ts inS fail succ
+parseClause ts inS fail succ
+  = parse ts inS fail $ \a ts2 inS2 ->
+    succ [a] ts2 inS2
+
+
+-- Parse Loop Statements --
+
+-- parses loop statements
+-- basically a dispatcher for other parse functions
+makeLoop :: NameType -> ParseType
+makeLoop "DO"     = makeDo
+makeLoop "WHILE"  = makeWhile
+makeLoop "REPEAT" = makeRepeat
+
+-- parses do statements
+-- format:  (DO <clause> WHILE <cond>)
+makeDo :: ParseType
+makeDo ts inS fail succ
+  = parseClause ts inS fail $ \insts ts2 inS2 ->
+    parseWhileCond ts2 inS2 fail $ \cond ts3 inS3 ->
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
+    succ (Loop Do cond insts) ts4 inS4
+
+-- parses while conditions (both in while and do-while loops)
+-- a condition is simply a command that (hopefully) returns a boolean
+parseWhileCond :: ParseType
+parseWhileCond [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseWhileCond ts (is,ls2) fail succ
+parseWhileCond ((Normal "WHILE"):ts) inS fail succ
+  = parse ts inS fail succ
+
+-- parses while statements
+-- format:  (WHILE <cond> <clause>)
+makeWhile :: ParseType
+makeWhile ts inS fail succ
+  = parse ts inS fail $ \cond ts2 inS2 ->
+    parseClause ts2 inS fail $ \insts ts3 inS3 ->
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
+    succ (Loop While cond insts) ts4 inS4
+
+-- parses repeat statements
+-- format:  (REPEAT <num> TIMES <clause>)
+-- note:  <num> is simply a command that (hopefully) returns an integer
+makeRepeat :: ParseType
+makeRepeat ts inS fail succ
+  = parse ts inS fail $ \num ts2 inS2 ->
+    parseRepeatBody ts2 inS fail $ \insts ts3 inS3 ->
+    getParen ts3 inS3 fail $ \ts4 inS4 ->
+    succ (Loop Repeat num insts) ts4 inS4
+
+-- parses repeat body (just a clause)
+parseRepeatBody :: ParseClauseType
+parseRepeatBody [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in parseRepeatBody ts (is,ls2) fail succ
+parseRepeatBody ((Normal "TIMES"):ts) inS fail succ
+  = parseClause ts inS fail succ
+parseRepeatBody _ inS fail _
+  = fail "Repeat:  invalid format" inS
+
+
+-- Parse Graphics Statements --
+
+-- parses all side-effecting graphics statements
+makeGraphics :: CommandName -> ParseType
+makeGraphics n ts inS fail succ
+  = parseArgs CloseParen ts inS fail $ \as ts2 inS2 ->
+    succ (Graphics n as) ts2 inS2
+
+-- Parse Trailing Parenthesis --
+
+-- parses the closing paren terminating most commands
+getParen :: [Token] -> InputState -> ParseFailType ->
+            ([Token] -> InputState -> IO ()) -> IO ()
+getParen [] (i:is,ls) fail succ
+  = let (ts,ls2) = lexDispatch ls i
+    in getParen ts (is,ls) fail succ
+getParen (CloseParen:ts) inS fail succ
+  = succ ts inS
+getParen _ inS fail _
+  = fail "Expected )" inS
+
diff --git a/progs/demo/X11/logo/logo.hu b/progs/demo/X11/logo/logo.hu
new file mode 100644
index 0000000..388e926
--- /dev/null
+++ b/progs/demo/X11/logo/logo.hu
@@ -0,0 +1,3 @@
+:o= foldr inline constant
+$HASKELL_LIBRARY/X11/xlib.hu
+logo.hs
diff --git a/progs/demo/X11/mdraw/README b/progs/demo/X11/mdraw/README
new file mode 100644
index 0000000..c78f7d9
--- /dev/null
+++ b/progs/demo/X11/mdraw/README
@@ -0,0 +1 @@
+This is a multiple screen version of the draw program.
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 ()
+
diff --git a/progs/demo/X11/mdraw/mdraw.hu b/progs/demo/X11/mdraw/mdraw.hu
new file mode 100644
index 0000000..16296d5
--- /dev/null
+++ b/progs/demo/X11/mdraw/mdraw.hu
@@ -0,0 +1,3 @@
+:o= all
+$HASKELL_LIBRARY/X11/xlib.hu
+mdraw.hs
diff --git a/progs/demo/X11/mdraw/t.hs b/progs/demo/X11/mdraw/t.hs
new file mode 100644
index 0000000..77f2baf
--- /dev/null
+++ b/progs/demo/X11/mdraw/t.hs
@@ -0,0 +1,16 @@
+module Test where
+import Xlib
+
+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
+
diff --git a/progs/demo/X11/mdraw/t.hu b/progs/demo/X11/mdraw/t.hu
new file mode 100644
index 0000000..657234c
--- /dev/null
+++ b/progs/demo/X11/mdraw/t.hu
@@ -0,0 +1,3 @@
+:o= all
+$HASKELL_LIBRARY/X11/xlib.hu
+t.hs
diff --git a/progs/demo/add.hs b/progs/demo/add.hs
new file mode 100644
index 0000000..bdfcc2f
--- /dev/null
+++ b/progs/demo/add.hs
@@ -0,0 +1,21 @@
+-- this is an interactive program to read in two numbers and print their sum.
+
+module Main where
+
+main = readChan stdin abort $ \userInput -> 
+       let inputLines = lines userInput in
+        readInt "Enter first number: " inputLines $ \num1 inputLines1 ->
+        readInt "Enter second number: " inputLines1 $ \ num2 _ ->
+        appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done
+
+readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue
+
+readInt prompt inputLines succ =
+  appendChan stdout prompt abort $
+  case inputLines of
+     (l1 : rest) -> case (reads l1) of
+                       [(x,"")] -> succ x rest
+                       _        -> appendChan stdout
+	                              "Error - retype the number\n" abort $
+	                           readInt prompt rest succ
+     _          -> appendChan stdout "Early EOF" abort done
diff --git a/progs/demo/eliza.hs b/progs/demo/eliza.hs
new file mode 100644
index 0000000..d7bf975
--- /dev/null
+++ b/progs/demo/eliza.hs
@@ -0,0 +1,267 @@
+-- Eliza: an implementation of the classic pseudo-psychoanalyst ---------------
+--
+-- Gofer version by Mark P. Jones, January 12 1992
+--
+-- Adapted from a pascal implementation provided as part of an experimental
+-- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original
+-- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu).
+-------------------------------------------------------------------------------
+
+import Prelude hiding (conjugate)
+
+main  :: Dialogue
+main   = interact (("\n\
+		    \Hi! I'm Eliza. I am your personal therapy computer.\n\
+		    \Please tell me your problem.\n\
+		    \\n" ++)
+                   . session initial []
+                   . filter (not.null)
+                   . map (words . trim)
+                   . lines)
+
+trim  :: String -> String                     -- strip punctuation characters
+trim   = foldr cons "" . dropWhile (`elem` punct)
+         where x `cons` xs | x `elem` punct && null xs = []
+                           | otherwise                 = x : xs
+               punct = [' ', '.', '!', '?', ',']
+
+-- Read a line at a time, and produce some kind of response -------------------
+
+session               :: State -> Words -> [Words] -> String
+session rs prev []     = []
+session rs prev (l:ls) = response ++ "\n\n" ++ session rs' l ls
+                         where (response, rs') | prev == l = repeated rs
+                                               | otherwise = answer rs l
+
+answer                :: State -> Words -> (String, State)
+answer st l            = (response, newKeyTab kt st)
+ where (response, kt)         = ans (keyTabOf st)
+       e `cons` (r, es)       = (r, e:es)
+       ans (e:es) | null rs   = e `cons` ans es
+                  | otherwise = (makeResponse a (head rs), (key,as):es)
+                         where rs           = replies key l
+                               (key,(a:as)) = e
+
+-- Find all possible replies (without leading string for given key ------------
+
+replies                 :: Words -> Words -> [String]
+replies key l            = ( map (conjugate l . drop (length key))
+                           . filter (prefix key . map ucase)
+                           . tails) l
+
+prefix                  :: Eq a => [a] -> [a] -> Bool
+[]     `prefix` xs       = True
+(x:xs) `prefix` []       = False
+(x:xs) `prefix` (y:ys)   = x==y && (xs `prefix` ys)
+
+tails                   :: [a] -> [[a]]          -- non-empty tails of list
+tails []                 = []
+tails xs                 = xs : tails (tail xs)
+
+ucase                   :: String -> String      -- map string to upper case
+ucase                    = map toUpper
+
+-- Replace keywords in a list of words with appropriate conjugations ----------
+
+conjugate  :: Words -> Words -> String
+conjugate d = unwords . trailingI . map conj . maybe d  -- d is default input
+              where maybe d xs = if null xs then d else xs
+                    conj  w    = head ([m | (w',m)<-conjugates, uw==w'] ++ [w])
+                                 where uw = ucase w
+                    trailingI  = foldr cons []
+                                 where x `cons` xs | x=="I" && null xs = ["me"]
+                                                   | otherwise         = x:xs
+
+conjugates :: [(Word, Word)]
+conjugates  = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways])
+              where oneways  = [ ("me",   "you") ]
+                    bothways = [ ("are",  "am"),     ("we're", "was"),
+				("you",  "I"),      ("your",  "my"),
+				("I've", "you've"), ("I'm",   "you're") ]
+                    prepare  = map (\(w,r) -> (ucase w, r))
+
+-- Response data --------------------------------------------------------------
+
+type Word     = String
+type Words    = [Word]
+type KeyTable = [(Key, Replies)]
+type Replies  = [String]
+type State    = (KeyTable, Replies)
+type Key      = Words
+
+repeated		  :: State -> (String, State)
+repeated (kt, (r:rp))      = (r, (kt, rp))
+
+newKeyTab                 :: KeyTable -> State -> State
+newKeyTab kt' (kt, rp)     = (kt', rp)
+
+keyTabOf                  :: State -> KeyTable
+keyTabOf (kt, rp)          = kt
+
+makeResponse             :: String -> String -> String
+makeResponse ('?':cs) us  = cs ++ " " ++ us ++ "?"
+makeResponse ('.':cs) us  = cs ++ " " ++ us ++ "."
+makeResponse cs       us  = cs
+
+initial     :: State
+initial      = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs)
+
+respMsgs     = [ ("CAN YOU",		canYou),
+		 ("CAN I",		canI),
+		 ("YOU ARE",		youAre),
+		 ("YOU'RE",		youAre),
+		 ("I DON'T",		iDont),
+		 ("I FEEL",		iFeel),
+		 ("WHY DON'T YOU",	whyDont),
+		 ("WHY CAN'T I",	whyCant),
+		 ("ARE YOU",		areYou), 
+		 ("I CAN'T",		iCant),
+		 ("I AM",		iAm),
+		 ("I'M",		iAm),
+		 ("YOU", 		you),
+		 ("YES",		yes),
+		 ("NO",			no),
+		 ("COMPUTER",		computer),
+		 ("COMPUTERS",		computer),
+		 ("I WANT",		iWant),
+		 ("WHAT",		question),
+		 ("HOW",		question),
+		 ("WHO",		question),
+		 ("WHERE",		question),
+		 ("WHEN",		question),
+		 ("WHY",		question),
+		 ("NAME",		name),
+		 ("BECAUSE",		because),
+		 ("CAUSE",		because),
+		 ("SORRY",		sorry),
+		 ("DREAM",		dream),
+		 ("DREAMS",		dream),
+		 ("HI",			hello),
+		 ("HELLO",		hello),
+		 ("MAYBE",		maybe),
+		 ("YOUR",		your),
+		 ("ALWAYS",		always),
+		 ("THINK",		think),
+		 ("ALIKE",		alike),
+		 ("FRIEND",		friend),
+		 ("FRIENDS",		friend),
+		 ("",			nokeyMsgs) ]
+
+canYou	     = [ "?Don't you believe that I can",
+		 "?Perhaps you would like to be able to",
+		 "?You want me to be able to" ]
+canI	     = [ "?Perhaps you don't want to",
+		 "?Do you want to be able to" ]
+youAre	     = [ "?What makes you think I am",
+		 "?Does it please you to believe I am",
+		 "?Perhaps you would like to be",
+		 "?Do you sometimes wish you were" ]
+iDont	     = [ "?Don't you really",
+		 "?Why don't you",
+		 "?Do you wish to be able to",
+		 "Does that trouble you?" ]
+iFeel	     = [ "Tell me more about such feelings.",
+		 "?Do you often feel",
+		 "?Do you enjoy feeling" ]
+whyDont	     = [ "?Do you really believe I don't",
+		 ".Perhaps in good time I will",
+		 "?Do you want me to" ]
+whyCant	     = [ "?Do you think you should be able to",
+		 "?Why can't you" ]
+areYou	     = [ "?Why are you interested in whether or not I am",
+		 "?Would you prefer if I were not",
+		 "?Perhaps in your fantasies I am" ]
+iCant	     = [ "?How do you know you can't",
+		 "Have you tried?",
+		 "?Perhaps you can now" ]
+iAm	     = [ "?Did you come to me because you are",
+		 "?How long have you been",
+		 "?Do you believe it is normal to be",
+		 "?Do you enjoy being" ]
+you	     = [ "We were discussing you --not me.",
+		 "?Oh,",
+		 "You're not really talking about me, are you?" ]
+yes	     = [ "You seem quite positive.",
+		 "Are you Sure?",
+		 "I see.",
+		 "I understand." ]
+no	     = [ "Are you saying no just to be negative?",
+		 "You are being a bit negative.",
+		 "Why not?",
+		 "Are you sure?",
+		 "Why no?" ]
+computer     = [ "Do computers worry you?",
+		 "Are you talking about me in particular?",
+		 "Are you frightened by machines?",
+		 "Why do you mention computers?",
+		 "What do you think machines have to do with your problems?",
+		 "Don't you think computers can help people?",
+		 "What is it about machines that worries you?" ]
+iWant	     = [ "?Why do you want",
+		 "?What would it mean to you if you got",
+		 "?Suppose you got",
+		 "?What if you never got",
+		 ".I sometimes also want" ]
+question     = [ "Why do you ask?",
+		 "Does that question interest you?",
+		 "What answer would please you the most?",
+		 "What do you think?",
+		 "Are such questions on your mind often?",
+		 "What is it that you really want to know?",
+		 "Have you asked anyone else?",
+		 "Have you asked such questions before?",
+		 "What else comes to mind when you ask that?" ]
+name	     = [ "Names don't interest me.",
+		 "I don't care about names --please go on." ]
+because	     = [ "Is that the real reason?",
+		 "Don't any other reasons come to mind?",
+		 "Does that reason explain anything else?",
+		 "What other reasons might there be?" ]
+sorry	     = [ "Please don't apologise!",
+		 "Apologies are not necessary.",
+		 "What feelings do you have when you apologise?",
+		 "Don't be so defensive!" ]
+dream	     = [ "What does that dream suggest to you?",
+		 "Do you dream often?",
+		 "What persons appear in your dreams?",
+		 "Are you disturbed by your dreams?" ]
+hello	     = [ "How do you...please state your problem." ]
+maybe	     = [ "You don't seem quite certain.",
+		 "Why the uncertain tone?",
+		 "Can't you be more positive?",
+		 "You aren't sure?",
+		 "Don't you know?" ]
+your	     = [ "?Why are you concerned about my",
+		 "?What about your own" ]
+always	     = [ "Can you think of a specific example?",
+		 "When?",
+		 "What are you thinking of?",
+		 "Really, always?" ]
+think	     = [ "Do you really think so?",
+		 "?But you are not sure you",
+		 "?Do you doubt you" ]
+alike	     = [ "In what way?",
+		 "What resemblence do you see?",
+		 "What does the similarity suggest to you?",
+		 "What other connections do you see?",
+		 "Cound there really be some connection?",
+		 "How?" ]
+friend	     = [ "Why do you bring up the topic of friends?",
+		 "Do your friends worry you?",
+		 "Do your friends pick on you?",
+		 "Are you sure you have any friends?",
+		 "Do you impose on your friends?",
+		 "Perhaps your love for friends worries you." ]
+
+repeatMsgs   = [ "Why did you repeat yourself?",
+		 "Do you expect a different answer by repeating yourself?",
+		 "Come, come, elucidate your thoughts.",
+		 "Please don't repeat yourself!" ]
+
+nokeyMsgs    = [ "I'm not sure I understand you fully.",
+		 "What does that suggest to you?",
+		 "I see.",
+		 "Can you elaborate on that?",
+		 "Say, do you have any psychological problems?" ]
+
+-------------------------------------------------------------------------------
diff --git a/progs/demo/fact.hs b/progs/demo/fact.hs
new file mode 100755
index 0000000..054183e
--- /dev/null
+++ b/progs/demo/fact.hs
@@ -0,0 +1,14 @@
+{- This is a simple factorial program which uses the I/O system
+   to read the input and print the result -}
+
+module Main where
+
+fact :: Integer -> Integer    
+fact 0 = 1
+fact (n+1) = (n+1)*fact n
+fact _ = error "Negative argument to factorial"
+
+main = appendChan stdout "Type in N: " abort $
+       readChan stdin abort $ \ input ->
+       appendChan stdout (show (fact (read (head (lines input))))) abort done
+
diff --git a/progs/demo/improved-add.hs b/progs/demo/improved-add.hs
new file mode 100644
index 0000000..bdfcc2f
--- /dev/null
+++ b/progs/demo/improved-add.hs
@@ -0,0 +1,21 @@
+-- this is an interactive program to read in two numbers and print their sum.
+
+module Main where
+
+main = readChan stdin abort $ \userInput -> 
+       let inputLines = lines userInput in
+        readInt "Enter first number: " inputLines $ \num1 inputLines1 ->
+        readInt "Enter second number: " inputLines1 $ \ num2 _ ->
+        appendChan stdout ("Their sum is: " ++ show (num1 + num2)) abort done
+
+readInt :: String -> [String] -> (Integer -> [String] -> Dialogue) -> Dialogue
+
+readInt prompt inputLines succ =
+  appendChan stdout prompt abort $
+  case inputLines of
+     (l1 : rest) -> case (reads l1) of
+                       [(x,"")] -> succ x rest
+                       _        -> appendChan stdout
+	                              "Error - retype the number\n" abort $
+	                           readInt prompt rest succ
+     _          -> appendChan stdout "Early EOF" abort done
diff --git a/progs/demo/merge.hs b/progs/demo/merge.hs
new file mode 100755
index 0000000..cf61f8f
--- /dev/null
+++ b/progs/demo/merge.hs
@@ -0,0 +1,26 @@
+{- This is a simple merge sort -}
+
+module Merge where
+                
+merge :: [Int] -> [Int] -> [Int]
+merge [] x = x  
+merge x [] = x
+merge l1@(a:b) l2@(c:d) | a < c     = a:(merge b l2)
+			| otherwise = c:(merge l1 d)
+
+half [] = []
+half [x] = [x]
+half (x:y:z) = x:r where r = half z
+
+sort [] = []
+sort [x] = [x]
+sort l = merge (sort odds) (sort evens) where
+	     odds = half l
+	     evens = half (tail l)
+
+main =
+  appendChan stdout "Enter a list of integers separated by \",\"\n" abort $
+  readChan stdin abort $ \ input ->
+  appendChan stdout 
+      (show (sort (read ("[" ++ (head (lines input)) ++ "]"))))
+      abort done
diff --git a/progs/demo/pascal.hs b/progs/demo/pascal.hs
new file mode 100644
index 0000000..a26e9c9
--- /dev/null
+++ b/progs/demo/pascal.hs
@@ -0,0 +1,24 @@
+{- This uses lazy evaluation to define Pascals triangle -}
+
+module Main where
+
+pascal :: [[Int]]
+pascal = [1] : [[x+y | (x,y) <- zip ([0]++r) (r++[0])] | r <- pascal]
+
+tab :: Int -> ShowS
+tab 0     = id
+tab (n+1) = showChar ' ' . tab n
+
+showRow :: [Int] -> ShowS 
+showRow []     = showChar '\n'
+showRow (n:ns) = shows n . showChar ' ' . showRow ns
+
+showTriangle 1     (t:_)  = showRow t
+showTriangle (n+1) (t:ts) = tab n . showRow t . showTriangle n ts
+
+main = appendChan stdout "Number of rows: " abort $
+       readChan stdin abort $ \input ->
+       appendChan stdout
+         (showTriangle (read (head (lines input))) pascal "")
+         abort done
+
diff --git a/progs/demo/pfac.hs b/progs/demo/pfac.hs
new file mode 100644
index 0000000..516fc85
--- /dev/null
+++ b/progs/demo/pfac.hs
@@ -0,0 +1,21 @@
+   
+-- This is a parallel varient of factorial
+
+module Main where
+
+fac :: Int -> Int
+fac 0 = 1
+fac n = pfac 1 n
+
+pfac :: Int -> Int -> Int
+pfac low high | low == high     = low
+              | low + 1 == high = (low * high)
+              | otherwise       = pfac low mid * pfac (mid + 1) high
+    where
+       mid = (high + low) `div` 2
+
+main = appendChan stdout "Type in N: " abort $
+       readChan stdin abort $ \ input ->
+       appendChan stdout (show (fac (read (head (lines input))))) abort done
+
+
diff --git a/progs/demo/primes.hs b/progs/demo/primes.hs
new file mode 100755
index 0000000..6c8fe79
--- /dev/null
+++ b/progs/demo/primes.hs
@@ -0,0 +1,16 @@
+-- This program implements Eratosthenes Sieve
+-- to generate prime numbers.
+
+module Main where
+
+primes :: [Int]
+primes = map head (iterate sieve [2 ..])
+
+sieve :: [Int] -> [Int]
+sieve (p:ps) = [x | x <- ps, (x `mod` p) /= 0]
+
+main = appendChan stdout "How many primes? " abort $
+       readChan stdin abort $ \ input ->
+       appendChan stdout (show (take (read (head (lines input))) primes))
+	                 abort done
+
diff --git a/progs/demo/prolog/Engine.hs b/progs/demo/prolog/Engine.hs
new file mode 100644
index 0000000..a269503
--- /dev/null
+++ b/progs/demo/prolog/Engine.hs
@@ -0,0 +1,61 @@
+--
+-- Stack based Prolog inference engine
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module Engine(prove) where
+
+import PrologData
+import Subst
+
+--- Calculation of solutions:
+
+-- the stack based engine maintains a stack of triples (s,goal,alts)
+-- corresponding to backtrack points, where s is the substitution at that
+-- point, goal is the outstanding goal and alts is a list of possible ways
+-- of extending the current proof to find a solution.  Each member of alts
+-- is a pair (tp,u) where tp is a new subgoal that must be proved and u is
+-- a unifying substitution that must be combined with the substitution s.
+--
+-- the list of relevant clauses at each step in the execution is produced
+-- by attempting to unify the head of the current goal with a suitably
+-- renamed clause from the database.
+
+type Stack = [ (Subst, [Term], [Alt]) ]
+type Alt   = ([Term], Subst)
+
+alts       :: Database -> Int -> Term -> [Alt]
+alts db n g = [ (tp,u) | (tm:*tp) <- renClauses db n g, u <- unify g tm ]
+      
+-- The use of a stack enables backtracking to be described explicitly,
+-- in the following `state-based' definition of prove:
+
+prove      :: Database -> [Term] -> [Subst]
+prove db gl = solve 1 nullSubst gl []
+ where
+   solve :: Int -> Subst -> [Term] -> Stack -> [Subst]
+   solve n s []     ow          = s : backtrack n ow
+   solve n s (g:gs) ow
+                    | g==theCut = solve n s gs (cut ow)
+                    | otherwise = choose n s gs (alts db n (apply s g)) ow
+
+   choose :: Int -> Subst -> [Term] -> [Alt] -> Stack -> [Subst]
+   choose n s gs []          ow = backtrack n ow
+   choose n s gs ((tp,u):rs) ow = solve (n+1) (u@@s) (tp++gs) ((s,gs,rs):ow)
+
+   backtrack                   :: Int -> Stack -> [Subst]
+   backtrack n []               = []
+   backtrack n ((s,gs,rs):ow)   = choose (n-1) s gs rs ow
+
+
+--- Special definitions for the cut predicate:
+
+theCut    :: Term
+theCut     = Struct "!" []
+
+cut                  :: Stack -> Stack
+cut (top:(s,gl,_):ss) = top:(s,gl,[]):ss
+cut ss                = ss
+
+--- End of Engine.hs
diff --git a/progs/demo/prolog/Engine.hu b/progs/demo/prolog/Engine.hu
new file mode 100644
index 0000000..5a64277
--- /dev/null
+++ b/progs/demo/prolog/Engine.hu
@@ -0,0 +1,3 @@
+Engine.hs
+PrologData.hu
+Subst.hu
diff --git a/progs/demo/prolog/Interact.hs b/progs/demo/prolog/Interact.hs
new file mode 100644
index 0000000..c8bf516
--- /dev/null
+++ b/progs/demo/prolog/Interact.hs
@@ -0,0 +1,76 @@
+--
+-- Interactive utility functions
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module Interact(Interactive(..), skip, end, readln, writeln, readch) where
+
+-- The functions defined in this module provide basic facilities for
+-- writing line-oriented interactive programs (i.e. a function mapping
+-- an input string to an appropriate output string).  These definitions
+-- are an enhancement of thos in B+W 7.8
+--
+-- skip p         is an interactive program which consumes no input, produces
+--                no output and then behaves like the interactive program p.
+-- end            is an interactive program which ignores the input and
+--                produces no output.
+-- writeln txt p  is an interactive program which outputs the message txt
+--                and then behaves like the interactive program p
+-- readch act def is an interactive program which reads the first character c
+--                from the input stream and behaves like the interactive
+--                program act c.  If the input character stream is empty,
+--                readch act def prints the default string def and terminates.
+-- 
+-- readln p g     is an interactive program which prints the prompt p and
+--                reads a line (upto the first carriage return, or end of
+--                input) from the input stream.  It then behaves like g line.
+--                Backspace characters included in the input stream are
+--                interpretted in the usual way.
+
+type Interactive = String -> String
+
+--- Interactive program combining forms:
+
+skip                 :: Interactive -> Interactive
+skip p inn             = p inn    -- a dressed up identity function
+
+end                  :: Interactive
+end inn                = ""
+
+writeln              :: String -> Interactive -> Interactive
+writeln txt p inn      = txt ++ p inn
+
+readch               :: (Char -> Interactive) -> String -> Interactive
+readch act def ""     = def
+readch act def (c:cs) = act c cs
+
+readln               :: String -> (String -> Interactive) -> Interactive
+readln prompt g inn    = prompt ++ lineOut 0 line ++ "\n"
+                               ++ g (noBackSpaces line) input'
+                        where line     = before '\n' inn
+                              input'   = after  '\n' inn
+                              after x  = tail . dropWhile (x/=)
+                              before x = takeWhile (x/=)
+
+--- Filter out backspaces etc:
+
+rubout  :: Char -> Bool
+rubout c = (c=='\DEL' || c=='\BS')
+
+lineOut                      :: Int -> String -> String
+lineOut n ""                  = ""
+lineOut n (c:cs)
+          | n>0  && rubout c  = "\BS \BS" ++ lineOut (n-1) cs
+          | n==0 && rubout c  = lineOut 0 cs
+          | otherwise         = c:lineOut (n+1) cs
+
+noBackSpaces :: String -> String
+noBackSpaces  = reverse . delete 0 . reverse
+                where delete n ""          = ""
+                      delete n (c:cs)
+                               | rubout c  = delete (n+1) cs
+                               | n>0       = delete (n-1) cs
+                               | otherwise = c:delete 0 cs
+
+--- End of Interact.hs
diff --git a/progs/demo/prolog/Interact.hu b/progs/demo/prolog/Interact.hu
new file mode 100644
index 0000000..41ebb9d
--- /dev/null
+++ b/progs/demo/prolog/Interact.hu
@@ -0,0 +1,2 @@
+Interact.hs
+
diff --git a/progs/demo/prolog/Main.hs b/progs/demo/prolog/Main.hs
new file mode 100644
index 0000000..56d83a8
--- /dev/null
+++ b/progs/demo/prolog/Main.hs
@@ -0,0 +1,87 @@
+--
+-- Prolog interpreter top level module
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module Main(main) where
+
+import PrologData
+import Parse
+import Interact
+import Subst
+import Engine
+import Version
+
+--- Command structure and parsing:
+
+data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange
+
+command :: Parser Command
+command  = just (sptok "bye" `orelse` sptok "quit") `do` (\quit->Quit)
+               `orelse`
+           just (okay NoChange)
+               `orelse`
+           just (sptok "??") `do` (\show->Show)
+               `orelse`
+           just clause `do` Fact
+               `orelse`
+           just (sptok "?-" `seq` termlist) `do` (\(q,ts)->Query ts)
+               `orelse`
+           okay Error
+
+--- Main program read-solve-print loop:
+
+signOn           :: String
+signOn            = "Mini Prolog Version 1.5 (" ++ version ++ ")\n\n"
+
+main             :: Dialogue
+main              = --echo False abort
+                    (appendChan stdout signOn abort
+                    (appendChan stdout ("Reading " ++ stdlib ++ "...") abort
+                    (readFile stdlib
+                      (\fail -> appendChan stdout "not found\n" abort
+                                (interpreter ""))
+                      (\lib  -> appendChan stdout "done\n"      abort
+                                (interpreter lib))
+                    )))
+
+stdlib           :: String
+stdlib            = "$HASKELL/progs/demo/prolog/stdlib"
+
+interpreter      :: String -> Dialogue
+interpreter lib   = readChan stdin abort
+                    (\inn -> appendChan stdout (loop startDb inn) abort done)
+                    where startDb = foldl addClause emptyDb clauses
+                          clauses = [r | ((r,""):_)<-map clause (lines lib)]
+
+loop             :: Database -> String -> String
+loop db           = readln "> " (exec db . fst . head . command)
+
+exec             :: Database -> Command -> String -> String
+exec db (Fact r)  = skip                              (loop (addClause db r))
+exec db (Query q) = demonstrate db q
+exec db Show      = writeln (show db)                 (loop db)
+exec db Error     = writeln "I don't understand\n"    (loop db)
+exec db Quit      = writeln "Thank you and goodbye\n" end
+exec db NoChange  = skip                              (loop db)
+
+--- Handle printing of solutions etc...
+
+solution      :: [Id] -> Subst -> [String]
+solution vs s  = [ show (Var i) ++ " = " ++ show v
+                                | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ]
+
+demonstrate     :: Database -> [Term] -> Interactive
+demonstrate db q = printOut (map (solution vs) (prove db q))
+ where vs               = (nub . concat . map varsIn) q
+       printOut []      = writeln "no.\n"     (loop db)
+       printOut ([]:bs) = writeln "yes.\n"    (loop db)
+       printOut (b:bs)  = writeln (doLines b) (nextReqd bs)
+       doLines          = foldr1 (\xs ys -> xs ++ "\n" ++ ys)
+       nextReqd bs      = writeln " "
+                            (readch (\c->if c==';'
+                                           then writeln ";\n" (printOut bs)
+                                           else writeln "\n"  (loop db)) "")
+
+--- End of Main.hs
diff --git a/progs/demo/prolog/Main.hu b/progs/demo/prolog/Main.hu
new file mode 100644
index 0000000..a936ca6
--- /dev/null
+++ b/progs/demo/prolog/Main.hu
@@ -0,0 +1,6 @@
+Main.hs
+Parse.hu
+PrologData.hu
+Interact.hu
+Engine.hu
+Version.hu
diff --git a/progs/demo/prolog/Parse.hs b/progs/demo/prolog/Parse.hs
new file mode 100644
index 0000000..0487432
--- /dev/null
+++ b/progs/demo/prolog/Parse.hs
@@ -0,0 +1,116 @@
+--
+-- General parsing library, based on Richard Bird's parselib.orw for Orwell
+-- (with a number of extensions)
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module Parse(Parser(..), fail, okay, tok, sat, orelse, seq, do,
+             sptok, just, listOf, many, sp, many1) where
+
+infixr 6 `seq`
+infixl 5 `do`
+infixr 4 `orelse`
+
+--- Type definition:
+
+type Parser a = [Char] -> [(a,[Char])]
+
+-- A parser is a function which maps an input stream of characters into
+-- a list of pairs each containing a parsed value and the remainder of the
+-- unused input stream.  This approach allows us to use the list of
+-- successes technique to detect errors (i.e. empty list ==> syntax error).
+-- it also permits the use of ambiguous grammars in which there may be more
+-- than one valid parse of an input string.
+
+--- Primitive parsers:
+
+-- fail     is a parser which always fails.
+-- okay v   is a parser which always succeeds without consuming any characters
+--          from the input string, with parsed value v.
+-- tok w    is a parser which succeeds if the input stream begins with the
+--          string (token) w, returning the matching string and the following
+--          input.  If the input does not begin with w then the parser fails.
+-- sat p    is a parser which succeeds with value c if c is the first input
+--          character and c satisfies the predicate p.
+
+fail        :: Parser a 
+fail inn      = []
+
+okay        :: a -> Parser a  
+okay v inn    = [(v,inn)]
+
+tok         :: [Char] -> Parser [Char]
+tok w inn     = [(w, drop n inn) | w == take n inn]
+               where n = length w
+
+sat         :: (Char -> Bool) -> Parser Char 
+sat p []     = []
+sat p (c:inn) = [ (c,inn) | p c ]
+
+--- Parser combinators:
+
+-- p1 `orelse` p2 is a parser which returns all possible parses of the input
+--                string, first using the parser p1, then using parser p2.
+-- p1 `seq` p2    is a parser which returns pairs of values (v1,v2) where
+--                v1 is the result of parsing the input string using p1 and
+--                v2 is the result of parsing the remaining input using p2.
+-- p `do` f       is a parser which behaves like the parser p, but returns
+--                the value f v wherever p would have returned the value v.
+--
+-- just p         is a parser which behaves like the parser p, but rejects any
+--                parses in which the remaining input string is not blank.
+-- sp p           behaves like the parser p, but ignores leading spaces.
+-- sptok w        behaves like the parser tok w, but ignores leading spaces.
+--
+-- many p         returns a list of values, each parsed using the parser p.
+-- many1 p        parses a non-empty list of values, each parsed using p.
+-- listOf p s     parses a list of input values using the parser p, with
+--                separators parsed using the parser s.
+
+orelse             :: Parser a -> Parser a -> Parser a 
+p1 `orelse` p2     = \inn->p1 inn ++ p2 inn
+ 
+seq                :: Parser a -> Parser b -> Parser (a,b)
+p1 `seq` p2        = \inn->[((v1,v2),inn2) | (v1,inn1) <- p1 inn, (v2,inn2) <- p2 inn1]
+
+do                 :: Parser a -> (a -> b) -> Parser b 
+p `do` f           = \inn->[(f v, inn1) | (v,inn1) <- p inn]
+
+just               :: Parser a -> Parser a
+just p inn           = [ (v,"") | (v,inn')<- p inn, dropWhile (' '==) inn' == "" ]
+
+sp                 :: Parser a -> Parser a
+sp p                = p . dropWhile (' '==)
+
+sptok              :: [Char] -> Parser [Char]
+sptok               =  sp . tok
+
+many               :: Parser a  -> Parser [a]
+many p              = q
+                      where q = ((p `seq` q) `do` makeList) `orelse` (okay [])
+
+many1              :: Parser a -> Parser [a]
+many1 p             = p `seq` many p `do` makeList
+
+listOf             :: Parser a -> Parser b -> Parser [a]
+listOf p s          = p `seq` many (s `seq` p) `do` nonempty
+                      `orelse` okay []
+                      where nonempty (x,xs) = x:(map snd xs)
+
+--- Internals:
+
+makeList       :: (a,[a]) -> [a]
+makeList (x,xs) = x:xs
+
+{-
+-- an attempt to optimise the performance of the standard prelude function
+-- `take' in Haskell B 0.99.3 gives the wrong semantics.  The original
+-- definition, given below works correctly and is used in the above.
+
+safetake              :: (Integral a) => a -> [b] -> [b]
+safetake  _     []     =  []
+safetake  0     _      =  []
+safetake (n+1) (x:xs)  =  x : safetake n xs
+-}
+--- End of Parse.hs
diff --git a/progs/demo/prolog/Parse.hu b/progs/demo/prolog/Parse.hu
new file mode 100644
index 0000000..44cc302
--- /dev/null
+++ b/progs/demo/prolog/Parse.hu
@@ -0,0 +1 @@
+Parse.hs
diff --git a/progs/demo/prolog/PrologData.hs b/progs/demo/prolog/PrologData.hs
new file mode 100644
index 0000000..4ff3173
--- /dev/null
+++ b/progs/demo/prolog/PrologData.hs
@@ -0,0 +1,121 @@
+--
+-- Representation of Prolog Terms, Clauses and Databases
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module PrologData(Id(..), Atom(..), Term(..), term, termlist, varsIn,
+                  Clause((:*)), clause,
+                  Database, emptyDb, renClauses, addClause) where
+
+import Parse
+
+infix 6 :*
+
+--- Prolog Terms:
+
+type Id       = (Int,String)
+type Atom     = String
+data Term     = Var Id | Struct Atom [Term]
+                deriving Eq
+data Clause   = Term :* [Term]
+data Database = Db [(Atom,[Clause])]
+
+--- Determine the list of variables in a term:
+
+varsIn              :: Term -> [Id]
+varsIn (Var i)       = [i]
+varsIn (Struct i ts) = (nub . concat . map varsIn) ts
+
+renameVars                  :: Int -> Term -> Term
+renameVars lev (Var (n,s))   = Var (lev,s)
+renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
+
+--- Functions for manipulating databases (as an abstract datatype)
+
+emptyDb      :: Database
+emptyDb       = Db []
+
+renClauses                  :: Database -> Int -> Term -> [Clause]
+renClauses db n (Var _)      = []
+renClauses db n (Struct a _) = [ r tm:*map r tp | (tm:*tp)<-clausesFor a db ]
+                               where r = renameVars n
+
+clausesFor           :: Atom -> Database -> [Clause]
+clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
+                         []         -> []
+                         ((n,rs):_) -> if a==n then rs else []
+
+addClause :: Database -> Clause -> Database
+addClause (Db rss) r@(Struct a _ :* _)
+         = Db (initialPart ++
+               case lastPart of
+                 []            -> [(a,[r])]
+                 ((n,rs):rss') -> if a==n then (n,rs++[r]):rss'
+                                          else (a,[r]):lastPart)
+           where (initialPart,lastPart) = span (\(n,rs) -> n<a) rss
+
+--- Output functions (defined as instances of Text):
+
+instance Text Term where
+  showsPrec p (Var (n,s))
+              | n==0        = showString s
+              | otherwise   = showString s . showChar '_' . shows n
+  showsPrec p (Struct a []) = showString a
+  showsPrec p (Struct a ts) = showString a . showChar '('
+                                           . showWithSep "," ts
+                                           . showChar ')'
+
+instance Text Clause where
+   showsPrec p (t:*[]) = shows t . showChar '.'
+   showsPrec p (t:*gs) = shows t . showString ":-"
+                                 . showWithSep "," gs
+                                 . showChar '.'
+
+instance Text Database where
+    showsPrec p (Db [])  = showString "-- Empty Database --\n"
+    showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v)
+                                  [ showWithTerm "\n" rs | (i,rs)<-rss ]
+
+--- Local functions for use in defining instances of Text:
+
+showWithSep          :: Text a => String -> [a] -> ShowS
+showWithSep s [x]     = shows x
+showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
+
+showWithTerm         :: Text a => String -> [a] -> ShowS
+showWithTerm s xs     = foldr1 (.) [shows x . showString s | x<-xs]
+
+--- String parsing functions for Terms and Clauses:
+--- Local definitions:
+
+letter       :: Parser Char
+letter        = sat (\c -> isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!")
+
+variable     :: Parser Term
+variable      = sat isUpper `seq` many letter `do` makeVar
+                where makeVar (initial,rest) = Var (0,(initial:rest))
+
+struct       :: Parser Term
+struct        = many letter `seq` (sptok "(" `seq` termlist `seq` sptok ")"
+                                       `do` (\(o,(ts,c))->ts)
+                                  `orelse`
+                                   okay [])
+                `do` (\(name,terms)->Struct name terms)
+
+--- Exports:
+
+term         :: Parser Term
+term          = sp (variable `orelse` struct)
+
+termlist     :: Parser [Term]
+termlist      = listOf term (sptok ",")
+
+clause       :: Parser Clause
+clause        = sp struct `seq` (sptok ":-" `seq` listOf term (sptok ",")
+                                 `do` (\(from,body)->body)
+                                `orelse` okay [])
+                          `seq` sptok "."
+                     `do` (\(head,(goals,dot))->head:*goals)
+
+--- End of PrologData.hs
diff --git a/progs/demo/prolog/PrologData.hu b/progs/demo/prolog/PrologData.hu
new file mode 100644
index 0000000..362d35f
--- /dev/null
+++ b/progs/demo/prolog/PrologData.hu
@@ -0,0 +1,2 @@
+PrologData.hs
+Parse.hu
diff --git a/progs/demo/prolog/README b/progs/demo/prolog/README
new file mode 100644
index 0000000..73dbc1b
--- /dev/null
+++ b/progs/demo/prolog/README
@@ -0,0 +1,3 @@
+This is a mini prolog interpreter written my Mark Jones.  It
+was slightly adapted from version in the hbc release.
+
diff --git a/progs/demo/prolog/Subst.hs b/progs/demo/prolog/Subst.hs
new file mode 100644
index 0000000..f96e462
--- /dev/null
+++ b/progs/demo/prolog/Subst.hs
@@ -0,0 +1,65 @@
+--
+-- Substitutions and Unification of Prolog Terms
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module Subst(Subst(..), nullSubst, (>!), (@@), apply, unify) where
+
+import PrologData
+
+infixr 3 @@
+infix  4 >!
+
+--- Substitutions:
+
+type Subst = Id -> Term
+
+-- substitutions are represented by functions mapping identifiers to terms.
+--
+-- apply s   extends the substitution s to a function mapping terms to terms
+-- nullSubst is the empty substitution which maps every identifier to the
+--           same identifier (as a term).
+-- i >! t   is the substitution which maps the identifier i to the term t,
+--           but otherwise behaves like nullSubst.
+-- s1 @@ s2  is the composition of substitutions s1 and s2
+--           N.B.  apply is a monoid homomorphism from (Subst,nullSubst,(@@))
+--           to (Term -> Term, id, (.)) in the sense that:
+--                  apply (s1 @@ s2) = apply s1 . apply s2
+--                    s @@ nullSubst = s = nullSubst @@ s
+
+apply                   :: Subst -> Term -> Term
+apply s (Var i)          = s i
+apply s (Struct a ts)    = Struct a (map (apply s) ts)
+
+nullSubst               :: Subst
+nullSubst i              = Var i
+
+(>!)                  :: Id -> Term -> Subst
+(>!) i t j | j==i       = t
+            | otherwise  = Var j
+
+(@@)                    :: Subst -> Subst -> Subst
+s1 @@ s2                 = apply s1 . s2 
+
+--- Unification:
+
+-- unify t1 t2 returns a list containing a single substitution s which is
+--             the most general unifier of terms t1 t2.  If no unifier
+--             exists, the list returned is empty.
+
+unify :: Term -> Term -> [Subst]
+unify (Var x)       (Var y)       = if x==y then [nullSubst] else [x>!Var y]
+unify (Var x)       t2            = [ x >! t2 | not (x `elem` varsIn t2) ]
+unify t1            (Var y)       = [ y >! t1 | not (y `elem` varsIn t1) ]
+unify (Struct a ts) (Struct b ss) = [ u | a==b, u<-listUnify ts ss ]
+
+listUnify :: [Term] -> [Term] -> [Subst]
+listUnify []     []     = [nullSubst]
+listUnify []     (r:rs) = []
+listUnify (t:ts) []     = []
+listUnify (t:ts) (r:rs) = [ u2 @@ u1 | u1<-unify t r,
+                                       u2<-listUnify (map (apply u1) ts)
+                                                     (map (apply u1) rs) ]
+
+--- End of Subst.hs
diff --git a/progs/demo/prolog/Subst.hu b/progs/demo/prolog/Subst.hu
new file mode 100644
index 0000000..1bb92fb
--- /dev/null
+++ b/progs/demo/prolog/Subst.hu
@@ -0,0 +1,2 @@
+Subst.hs
+PrologData.hu
diff --git a/progs/demo/prolog/Version.hs b/progs/demo/prolog/Version.hs
new file mode 100644
index 0000000..c580f4b
--- /dev/null
+++ b/progs/demo/prolog/Version.hs
@@ -0,0 +1 @@
+module Version where version="tree based"
diff --git a/progs/demo/prolog/Version.hu b/progs/demo/prolog/Version.hu
new file mode 100644
index 0000000..244a511
--- /dev/null
+++ b/progs/demo/prolog/Version.hu
@@ -0,0 +1 @@
+Version.hs
diff --git a/progs/demo/prolog/stdlib b/progs/demo/prolog/stdlib
new file mode 100644
index 0000000..76d2b8c
--- /dev/null
+++ b/progs/demo/prolog/stdlib
@@ -0,0 +1,38 @@
+This file contains a list of predicate definitions that will automatically
+be read into Mini Prolog at the beginning of a session.  Each clause in this
+file must be entered on a single line and lines containing syntax errors are
+always ignored.  This includes the first few lines of this file and provides
+a simple way to include comments.
+
+append(nil,X,X).
+append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W).
+
+equals(X,X).
+
+not(X):-X,!,false.
+not(X).
+
+or(X,Y):-X.
+or(X,Y):-Y.
+
+and(X,Y):-X,Y.
+
+reverse(nil,nil).
+reverse(cons(A,X),Y):-and(reverse(X,Z),append(Z,cons(A,nil),Y)).
+
+palindromes(X):-and(reverse(X,Y),equals(X,Y)).
+
+mul2(A,B):-append(A,A,B).
+mul4(A,B):-and(mul2(A,C),mul2(C,B)).
+mul8(A,B):-and(mul4(A,C),mul2(C,B)).
+mul16(A,B):-and(mul8(A,C),mul2(C,B)).
+mul32(A,B):-and(mul16(A,C),mul2(C,B)).
+mul64(A,B):-and(mul32(A,C),mul2(C,B)).
+mul128(A,B):-and(mul64(A,C),mul2(C,B)).
+mul256(A,B):-and(mul128(A,C),mul2(C,B)).
+mul512(A,B):-and(mul256(A,C),mul2(C,B)).
+mul1024(A,B):-and(mul512(A,C),mul2(C,B)).
+
+true.
+
+End of stdlib
diff --git a/progs/demo/queens.hs b/progs/demo/queens.hs
new file mode 100755
index 0000000..0f8de59
--- /dev/null
+++ b/progs/demo/queens.hs
@@ -0,0 +1,40 @@
+{- This is the n Queens problem. -}
+
+module Main where
+
+queens :: Int -> [[Int]]
+queens size  = queens' size size
+
+queens' :: Int -> Int -> [[Int]]
+queens' 0     _    = [[]]
+queens' (n+1) size = [q:qs | qs <- queens' n size, q <- [1..size],
+			     not (threatens q qs)]
+
+threatens :: Int -> [Int] -> Bool
+threatens q qs = q `elem` qs || q `elem` (diagonals 1 qs)
+
+diagonals :: Int -> [Int] -> [Int]
+diagonals _  []    = []
+diagonals n (q:qs) = (q+n) : (q-n) : diagonals (n+1) qs
+
+main = appendChan stdout "Enter board size: " abort $
+       readChan stdin abort $ \input -> 
+       let line1 : ~(line2 : _) = lines input
+	   size = read line1
+           solns = read line2
+       in if size == 0 then done else  -- This causes the size to actually read
+         appendChan stdout "Number of solutions: " abort $
+         appendChan stdout (concat (map (\x -> showBoard size x)
+                                        (take solns (queens size))))
+  	 abort done
+
+showBoard :: Int -> [Int] -> String
+
+showBoard size pos =
+  concat (map showRow pos) ++ "\n"
+    where
+      showRow n = concat [if i == n then "Q " else ". " | i <- [1..size]]
+                  ++ "\n"
+                
+
+
diff --git a/progs/demo/quicksort.hs b/progs/demo/quicksort.hs
new file mode 100644
index 0000000..30b4ab4
--- /dev/null
+++ b/progs/demo/quicksort.hs
@@ -0,0 +1,13 @@
+-- Quick sort for Haskell.
+
+module Main where
+
+qs :: [Int] -> [Int]
+qs []     = []
+qs (a:as) = qs [x | x <- as, x <= a] ++ [a] ++ qs [x | x <- as, x > a]
+
+main =
+  appendChan stdout "Enter a list of integers separated by \",\"\n" abort $
+  readChan stdin abort $ \ input ->
+  appendChan stdout (show (qs (read ("[" ++ (head (lines input)) ++ "]"))))
+             abort done
diff --git a/progs/lib/README b/progs/lib/README
new file mode 100644
index 0000000..910be2d
--- /dev/null
+++ b/progs/lib/README
@@ -0,0 +1 @@
+This directory contains supported libraries for Yale Haskell.
diff --git a/progs/lib/X11/README b/progs/lib/X11/README
new file mode 100644
index 0000000..db748e4
--- /dev/null
+++ b/progs/lib/X11/README
@@ -0,0 +1,11 @@
+This directory contains the Haskell->CLX support code.
+
+If you see errors like "ID 42 is a :WM_RESIZE_HINTS, not a window",
+you can get rid of them by loading clx-patch.lisp.  This seems to be a
+bug where CLX is not consistent with the protocol in some way; we've
+seen it on some machines and not others.  The line
+
+(load "$HASKELL/progs/lib/X11/clx-patch.lisp")
+
+can be placed in your .yhaskell file to load the patch on startup.
+
diff --git a/progs/lib/X11/clx-patch.lisp b/progs/lib/X11/clx-patch.lisp
new file mode 100644
index 0000000..fe2a5e3
--- /dev/null
+++ b/progs/lib/X11/clx-patch.lisp
@@ -0,0 +1,39 @@
+(lisp:in-package 'xlib)
+(defmacro generate-lookup-functions (useless-name &body types)
+            `(within-definition (,useless-name generate-lookup-functions)
+               ,@(mapcar
+                   #'(lambda (type)
+                       `(defun ,(xintern 'lookup- type)
+                               (display id)
+                          (declare (type display display)
+                                   (type resource-id id))
+                          (declare (values ,type))
+                          ,(if (member type *clx-cached-types*)
+                               `(let ((,type (lookup-resource-id display id)))
+                                  (cond ((null ,type) ;; Not found, create and s
+ave it.
+                                         (setq ,type (,(xintern 'make- type)
+                                                      :display display :id id))
+                                         (save-id display id ,type))
+                                        ;; Found.  Check the type
+                                        ,(cond ((null '()) ;*type-check?*)
+                                                `(t ,type))
+                                               ((member type '(window pixmap))
+                                                `((type? ,type 'drawable) ,type)
+)
+                                               (t `((type? ,type ',type) ,type))
+)
+                                        ,@(when '() ;*type-check?*
+                                            `((t (x-error 'lookup-error
+                                                          :id id
+                                                          :display display
+                                                          :type ',type
+                                                          :object ,type))))))
+                               ;; Not being cached.  Create a new one each time.
+                               `(,(xintern 'make- type)
+                                 :display display :id id))))
+                   types)))
+(macroexpand 
+  (generate-lookup-functions ignore
+    window))
+
diff --git a/progs/lib/X11/xlib.hs b/progs/lib/X11/xlib.hs
new file mode 100644
index 0000000..716cc8c
--- /dev/null
+++ b/progs/lib/X11/xlib.hs
@@ -0,0 +1,877 @@
+module Xlib(XLibTypes..,XLibPrims..) where
+import XLibTypes
+import XLibPrims
+
+module XLibTypes(XDisplay, XScreen, XWindow, XGcontext, XPixmap,
+                 XColormap, XCursor, XFont, XImage, XMaybe(..), XError(..),
+                 XBitmap(..), XKeysymTable(..), XBitVec(..),
+                 XPixarray(..), XByteVec(..), XAtom(..), XProperty(..),
+                 XPixel(..), XDrawable(..), XTime(..), XSwitch(..),
+		 XWindowPlace(..), XEventMode(..), XEventKind(..),
+		 XWindowVisibility(..), XWindowStackMode(..),
+		 XPropertyState(..), XMapReqType(..), XGraphFun(..),
+		 XEvent(..), XEventType(..), XEventSlot(..), XEventMask(..),
+		 XEventMaskKey(..), XStateMask(..), XStateMaskKey(..),
+		 XWinAttribute(..),XGCAttribute(..), XImAttribute(..), 
+		 XGrabAttribute(..), XArcMode(..), XCapStyle(..),
+		 XClipMask(..), XFillRule(..), XFillStyle(..), 
+		 XFunction(..), XJoinStyle(..), XLineStyle(..),
+		 XSubwindowMode(..), XPoint(..), XSize(..), XRect(..),
+		 XArc(..), XBitmapFormat(..), XByteOrder(..),
+		 XPixmapFormat(..), XVisualInfo(..), XVisualClass(..),
+		 XFillContent(..), XBackingStore(..), XGravity(..),
+		 XWindowClass(..), XMapState(..), XImageData(..), 
+		 XImageFormat(..), XImageType(..), XDrawDirection(..),
+		 XColor(..), XInputFocus(..), XGrabStatus(..),
+		 XKeysym(..), XCloseDownMode(..), XScreenSaver(..))
+    where
+
+data XMaybe a {-# STRICT #-} = XSome a 		
+                 	     | XNull
+	      --deriving (Printers)
+
+data XDisplay 		= XDisplay 	 --deriving (Printers)
+data XScreen 		= XScreen	 --deriving (Printers)
+data XWindow 		= XWindow	 --deriving (Printers)
+data XGcontext 		= XGcontext	 --deriving (Printers)
+data XPixmap 		= XPixmap	 --deriving (Printers)
+data XColormap 		= XColormap	 --deriving (Printers)
+data XCursor 		= XCursor	 --deriving (Printers)
+data XFont 		= XFont		 --deriving (Printers)
+data XImage 		= XImage	 --deriving (Printers)
+
+data XError {-# STRICT #-}
+              = XError String 	
+                --deriving Printers
+data XBitmap {-# STRICT #-}
+             = XBitmap [[Int]]
+instance Text(XBitmap) where
+  showsPrec p x = showString "<<XBitMap>>"
+   
+data XKeysymTable {-# STRICT #-}
+             = XKeysymTable [[Integer]]	
+instance Text(XKeysymTable) where
+  showsPrec p x = showString "<<XKeysymTable>>"
+
+data XBitVec {-# STRICT #-}
+             = XBitVec [Int]			
+instance Text(XBitVec) where
+  showsPrec p x = showString "<<XBitVec>>"
+
+data XPixarray {-# STRICT #-}
+   	     = XPixarray [[Integer]]		
+instance Text(XPixarray) where
+  showsPrec p x = showString "<<XPixarray>>"
+
+data XByteVec {-# STRICT #-}
+             = XByteVec [Int]
+instance Text(XByteVec) where
+  showsPrec p x = showString "<<XByteVec>>"
+
+
+data XAtom {-# STRICT #-}
+             = XAtom String 		
+	--deriving (Printers)
+
+data XProperty {-#STRICT #-}
+             = XProperty [Integer]  	-- data
+	                 XAtom  	-- type
+                         Int    	-- format
+       --deriving (Printers)
+
+data XPixel {-# STRICT #-}
+            = XPixel Integer
+       --deriving (Printers)
+
+data XDrawable {-# STRICT #-}
+            = XDrawWindow XWindow 
+            | XDrawPixmap XPixmap
+	--deriving (Printers)
+
+data XTime {-# STRICT #-}
+            = XTime Integer 
+	--deriving (Printers)
+
+data XSwitch    = XOn
+                | XOff
+        --deriving (Printers)
+
+data XWindowPlace 	= XTopPlace
+			| XBottomPlace
+	--deriving (Printers)
+
+data XEventMode		= XNormalMode
+			| XGrabMode
+			| XUngrabMode
+			| XWhileGrabbedMode
+	--deriving (Printers)
+
+data XEventKind		= XAncestorKind
+			| XVirtualKind
+			| XInferiorKind
+			| XNonlinearKind
+			| XNonlinearVirtualKind
+			| XPointerKind
+			| XPointerRootKind
+			| XNoneKind
+	--deriving (Printers)
+
+data XWindowVisibility	= XUnobscured
+			| XPartiallyObscured
+			| XFullyObscured
+	--deriving (Printers)
+
+data XWindowStackMode	= XStackAbove
+			| XStackBelow
+			| XStackTopIf
+			| XStackBottomIf
+			| XStackOpposite
+	--deriving (Printers)
+
+data XPropertyState	= XNewValueProperty
+			| XDeletedProperty
+	--deriving (Printers)
+
+data XMapReqType	= XModifierMapping
+			| XKeyboardMapping
+			| XPointerMapping
+	--deriving (Printers)
+
+data XGraphFun {-# STRICT #-}
+        	= XGraphFun Int  -- major opcode
+	         	    Int  -- minor opcode
+	--deriving (Printers)
+
+data XEvent {-# STRICT #-}
+        	= XEvent XEventType
+		         [XEventSlot]
+
+data XEventType = 	  XKeyPressEvent
+		        | XKeyReleaseEvent
+	        	| XButtonPressEvent
+	        	| XButtonReleaseEvent
+		        | XMotionNotifyEvent
+		        | XEnterNotifyEvent
+		        | XLeaveNotifyEvent
+		        | XFocusInEvent
+			| XFocusOutEvent
+            		| XKeymapNotifyEvent
+            		| XMappingNotifyEvent
+            		| XExposureEvent
+            		| XGraphicsExposureEvent
+            		| XNoExposureEvent
+            		| XCirculateNotifyEvent 
+            		| XConfigureNotifyEvent
+            		| XCreateNotifyEvent
+            		| XDestroyNotifyEvent
+            		| XGravityNotifyEvent
+            		| XMapNotifyEvent
+            		| XReparentNotifyEvent
+            		| XUnmapNotifyEvent
+            		| XVisibilityNotifyEvent
+            		| XCirculateRequestEvent
+            		| XColormapNotifyEvent
+            		| XConfigureRequestEvent
+            		| XMapRequestEvent
+            		| XResizeRequestEvent
+            		| XClientMessageEvent
+            		| XPropertyNotifyEvent
+            		| XSelectionClearEvent
+            		| XSelectionNotifyEvent
+            		| XSelectionRequestEvent
+            		| XOtherEvents
+       --deriving Printers
+
+data XEventSlot {-# STRICT #-}
+                = XEventWindow XWindow		
+		| XEventEventWindow XWindow	
+		| XEventCode Int		
+		| XEventPos XPoint		
+		| XEventState XStateMask	
+		| XEventTime XTime		 
+		| XEventRoot XWindow		 
+		| XEventRootPos XPoint		
+		| XEventChild (XMaybe XWindow)	
+		| XEventSameScreenP Bool	
+		| XEventHintP Bool		
+		| XEventMode XEventMode		
+		| XEventKind XEventKind		
+		| XEventFocusP Bool		
+		| XEventKeymap XBitVec		
+		| XEventRequest XMapReqType	
+		| XEventStart Int		
+		| XEventCount Int		
+		| XEventRect XRect		
+		| XEventDrawable XDrawable	
+		| XEventXGraphFun XGraphFun	
+		| XEventPlace XWindowPlace	
+		| XEventBorderWidth Int		
+		| XEventAboveSibling (XMaybe XWindow)
+		| XEventOverrideRedirectP Bool	
+		| XEventParent XWindow		
+		| XEventConfigureP Bool		
+		| XEventVisibility XWindowVisibility
+		| XEventNewP Bool		
+		| XEventInstalledP Bool		
+		| XEventStackMode XWindowStackMode
+		| XEventValueMask Int		
+		| XEventSize XSize		
+		| XEventMessage XProperty	
+		| XEventPropertyState XPropertyState
+		| XEventAtom XAtom		
+		| XEventSelection XAtom		
+		| XEventTarget XAtom		
+		| XEventProperty (XMaybe XAtom)	
+		| XEventRequestor XWindow
+       --deriving Printers
+
+data XEventMask {-# STRICT #-}
+             = XEventMask [XEventMaskKey] 
+       --deriving (Printers)
+
+data XEventMaskKey 
+		= XButton1Motion
+		| XButton2Motion
+		| XButton3Motion
+		| XButton4Motion
+		| XButton5Motion
+		| XButtonMotion
+                | XButtonPress
+		| XButtonRelease
+		| XColormapChange
+		| XEnterWindow
+		| XExposure
+		| XFocusChange
+		| XKeyPress
+		| XKeyRelease
+		| XKeymapState
+		| XLeaveWindow
+		| XOwnerGrabButton
+		| XPointerMotion
+		| XPointerMotionHint
+		| XPropertyChange
+		| XResizeRedirect
+		| XStructureNotify
+		| XSubstructureRedirect
+		| XVisibilityChange
+	  --deriving (Printers)
+
+data XStateMask	{-# STRICT #-}
+            = XStateMask [XStateMaskKey] 
+        --deriving (Printers)
+
+data XStateMaskKey
+		= XShift
+		| XLock
+		| XControl
+		| XMod1
+		| XMod2
+		| XMod3
+		| XMod4
+		| XMod5
+		| XButton1
+		| XButton2
+		| XButton3
+		| XButton4
+		| XButton5
+	--deriving (Printers)
+
+data XWinAttribute {-# STRICT #-} 
+		= XWinBackground XPixel 
+                | XWinEventMask XEventMask 
+                | XWinDepth Int 	
+		| XWinBorderWidth Int 	
+		| XWinClass XWindowClass 
+		| XWinVisual Int 	
+		| XWinBorder XFillContent 
+		| XWinBackingStore XBackingStore
+		| XWinBackingPlanes XPixel 
+		| XWinBackingPixel XPixel 
+		| XWinSaveUnder XSwitch	
+		| XWinDoNotPropagateMask XEventMask
+		| XWinOverrideRedirect XSwitch 
+		| XWinColormap XColormap 
+		| XWinCursor XCursor 	
+     --deriving (Printers)
+
+data XGCAttribute {-# STRICT #-}
+		= XGCArcMode XArcMode 	
+		| XGCBackground XPixel 	
+		| XGCCapStyle XCapStyle 
+		| XGCClipMask XClipMask 
+		| XGCClipOrigin XPoint 	
+		| XGCDashOffset Int 	
+		| XGCDashes [Int] 	
+		| XGCExposures XSwitch 	
+		| XGCFillRule XFillRule 
+		| XGCFillStyle XFillStyle 
+		| XGCFont XFont 	
+		| XGCForeground XPixel 	
+		| XGCFunction XFunction 
+		| XGCJoinStyle XJoinStyle 
+		| XGCLineStyle XLineStyle 
+		| XGCLineWidth Int 	
+		| XGCPlaneMask XPixel 	
+		| XGCStipple XPixmap 	
+		| XGCSubwindowMode XSubwindowMode
+		| XGCTile XPixmap 	
+		| XGCTileOrigin XPoint 	
+        --deriving (Printers)
+
+data XImAttribute {-# STRICT #-}
+		= XImBitLsbFirstP Bool 	
+		| XImBitsPerPixel Int 	
+		| XImBlueMask XPixel 	
+		| XImByteLsbFirstP Bool 
+		| XImBytesPerLine Int 	
+		| XImData XImageData 	
+		| XImDepth Int 		
+		| XImFormat XImageFormat 
+		| XImGreenMask XPixel 	
+		| XImSize XSize 	
+		| XImName String 	
+		| XImRedMask XPixel 	
+		| XImHotSpot XPoint 	
+	   --deriving (Printers)
+
+data XGrabAttribute {-# STRICT #-}
+		= XGrabOwnerP Bool 	
+		| XGrabSyncPointerP Bool 
+		| XGrabSyncKeyboardP Bool 
+		| XGrabConfineTo XWindow 
+		| XGrabCursor XCursor 	
+	   --deriving (Printers)
+
+data XArcMode	= XChord
+		| XPieSlice
+          --deriving (Printers)
+
+data XCapStyle	= XButt
+		| XNotLast
+		| XProjecting
+		| XRound
+	   --deriving (Printers)
+
+data XClipMask {-# STRICT #-}
+        	= XClipMaskPixmap XPixmap 
+		| XClipMaskRects [XRect]
+		| XClipMaskNone
+	   --deriving (Printers)
+
+data XFillRule  = XFillEvenOdd
+		| XFillWinding
+	   --deriving (Printers)
+
+data XFillStyle = XFillOpaqueStippled
+		| XFillSolid
+		| XFillStippled
+		| XFillTiled
+	   --deriving (Printers)
+
+data XFunction	= XBoole1
+		| XBoole2
+		| XBooleAndC1
+		| XBooleAndC2
+		| XBooleAnd
+		| XBooleC1
+		| XBooleC2
+		| XBooleClr
+		| XBooleEqv
+		| XBooleIor
+		| XBooleNand
+		| XBooleNor
+		| XBooleOrc1
+		| XBooleOrc2
+		| XBooleSet
+		| XBooleXor
+	   --deriving (Printers)
+
+data XJoinStyle	= XJoinBevel
+		| XJoinMiter
+		| XJoinRound
+	   --deriving (Printers)
+ 
+data XLineStyle = XLineSolid
+		| XLineDoubleDash
+		| XLineOnOffDash
+	   --deriving (Printers)
+
+data XSubwindowMode	= XClipByChildren
+			| XIncludeInferiors
+	   --deriving (Printers)
+
+-- BASIC GEOMETRY
+
+data XPoint {-# STRICT #-} = XPoint Int Int		-- x,y
+	   --deriving (Printers)
+
+data XSize {-# STRICT #-} = XSize Int Int               -- width, height
+	   --deriving (Printers)
+
+data XRect {-# STRICT #-} = XRect Int Int Int Int       -- x, y, width, height
+	   --deriving (Printers)
+
+data XArc {-# STRICT #-} = XArc Int Int Int Int Float Float
+	   --deriving (Printers)  -- x, y, width, height, angle1, angle2
+
+data XBitmapFormat {-# STRICT #-} = XBitmapFormat Int Int Bool
+          --deriving (Printers) -- unit, pad, lsb-first-p
+
+data XByteOrder = XLsbFirst
+                | XMsbFirst
+		   --deriving (Printers)
+
+data XPixmapFormat {-# STRICT #-} = XPixmapFormat Int Int Int
+         --deriving (Printers) -- depth, bits-per-pixel, scanline-pad
+
+data XVisualInfo {-# STRICT #-} = XVisualInfo 
+			Int 		-- id 
+                        XVisualClass 	-- class 
+                        XPixel 		-- red-mask 
+                        XPixel 		-- green-mask 
+                        XPixel 		-- blue-mask 
+                        Int 		-- bits-per-rgb
+			Int 		-- colormap-entries
+        --deriving (Printers)
+
+data XVisualClass	= XDirectColor
+			| XGrayScale
+			| XPseudoColor
+			| XStaticColor
+			| XStaticGray
+			| XTrueColor
+        --deriving (Printers)
+
+data XFillContent {-# STRICT #-} 
+	                = XFillPixel XPixel
+			| XFillPixmap XPixmap 
+			| XFillNone
+			| XFillParentRelative
+			| XFillCopy
+        --deriving (Printers)
+
+data XBackingStore 	= XAlwaysBackStore
+			| XNeverBackStore
+			| XBackStoreWhenMapped
+			| XBackStoreNotUseful
+        --deriving (Printers)
+
+data XGravity	= XForget
+		| XStatic
+		| XCenter
+		| XEast
+		| XNorth
+		| XNorthEast
+		| XNorthWest
+		| XSouth
+		| XSouthEast
+		| XSouthWest
+		| XWest
+        --deriving (Printers)
+
+data XWindowClass 	= XInputOutput
+			| XInputOnly
+        --deriving (Printers)
+
+data XMapState		= XUnmapped
+			| XUnviewable
+			| XViewable
+        --deriving (Printers)
+
+data XImageData	{-# STRICT #-} 
+                = XBitmapData [XBitmap]
+		| XPixarrayData XPixarray
+		| XByteVecData XByteVec
+        --deriving (Printers)
+
+data XImageFormat 	= XXyPixmapImage
+			| XZPixmapImage
+			| XBitmapImage
+        --deriving (Printers)
+
+data XImageType	= XImageX
+		| XImageXy
+		| XImageZ
+        --deriving (Printers)
+
+data XDrawDirection	= XLeftToRight
+			| XRightToLeft
+        --deriving (Printers)
+
+data XColor {-# STRICT #-} = XColor Float Float Float
+        --deriving (Printers)
+
+data XInputFocus {-# STRICT #-}
+                	= XFocusWindow XWindow
+			| XFocusNone
+			| XFocusPointerRoot
+			| XFocusParent
+        --deriving (Printers)
+
+data XGrabStatus	= XAlreadyGrabbed
+			| XFrozen
+			| XInvalidTime
+			| XNotViewable
+			| XSuccess
+        --deriving (Printers)
+
+
+data XKeysym {-# STRICT #-} = XKeysym Integer
+        --deriving (Printers)
+
+
+data XCloseDownMode	= XDestroy
+			| XRetainPermanent
+			| XRetainTemporary
+        --deriving (Printers)
+
+data XScreenSaver {-# STRICT #-} = XScreenSaver Int Int Bool Bool
+       --deriving (Printers)
+
+{-#
+ImportLispType (
+   XMaybe (XSome ("not-null?", "identity", "identity"),
+           XNull ("null?", "'()")),
+   XError (XError ("cons-xerror", "x-error-string")),
+   XBitmap (XBitmap ("mk-bitmap", "sel-bitmap")),
+   XKeysymTable (XKeysymTable ("mk-keysym-table", "sel-keysym-table")),
+   XBitVec (XBitVec ("mk-bitvec", "sel-bitvec")),
+   XPixarray (XPixarray ("mk-pixarray", "sel-pixarray")),
+   XByteVec (XByteVec ("mk-bytevec", "sel-bytevec")),
+   XAtom (XAtom ("mk-atom", "sel-atom")),
+   XProperty (XProperty ("mk-xproperty", "sel-xproperty-data", 
+	                 "sel-xproperty-type", "sel-xproperty-format")),
+   XDrawable (XDrawWindow ("xlib:window-p", "identity", "identity"),
+ 	      XDrawPixmap ("xlib:pixmap-p", "identity", "identity")),
+   XSwitch ( XOn(":on"), XOff(":off")),
+   XWindowPlace (XTopPlace (":top"), XBottomPlace (":bottom")),
+   XEventMode (XNormalMode (":normal"),
+               XGrabMode (":grab"),
+	       XUngrabMode (":ungrab"),
+	       XWhileGrabbedMode (":while-grabbed")),
+   XEventKind (XAncestorKind (":ancestor"),
+               XVirtualKind (":virtual"),
+               XInferiorKind (":inferior"),
+               XNonlinearKind (":nonlinear"),
+               XNonlinearVirtualKind (":nonlinear-virtual"),
+               XPointerKind (":pointer"),
+               XPointerRootKind (":pointer-root"),
+               XNoneKind (":none")),
+   XWindowVisibility (XUnobscured (":unobscured"),
+                      XPartiallyObscured (":partially-obscured"),
+                      XFullyObscured (":fully-obscured")),
+   XWindowStackMode (XStackAbove (":above"),
+                     XStackBelow (":below"),
+		     XStackTopIf (":top-if"),
+		     XStackBottomIf (":bottom-if"),
+		     XStackOpposite (":opposite")),
+   XPropertyState (XNewValueProperty (":new-value"),
+                   XDeletedProperty (":deleted")),
+   XMapReqType (XModifierMapping (":modifier"),
+                XKeyboardMapping (":keyboard"),
+		XPointerMapping (":pointer")),
+   XGraphFun (XGraphFun ("cons", "car", "cdr")),
+   XEvent (XEvent ("mk-event", "sel-event-type", "sel-event-slots")),
+   XEventType (XKeyPressEvent (":key-press"),
+               XKeyReleaseEvent (":key-release"),
+	       XButtonPressEvent (":button-press"),
+	       XButtonReleaseEvent (":button-release"),
+	       XMotionNotifyEvent (":motion-notify"),
+	       XEnterNotifyEvent (":enter-notify"),
+	       XLeaveNotifyEvent (":leave-notify"),
+	       XFocusInEvent (":focus-in"),
+	       XFocusOutEvent (":focus-out"),
+	       XKeymapNotifyEvent (":keymap-notify"),
+	       XMappingNotifyEvent (":mapping-notify"),
+	       XExposureEvent (":exposure"),
+	       XGraphicsExposureEvent (":graphics-exposure"),
+	       XNoExposureEvent (":no-exposure"),
+	       XCirculateNotifyEvent (":circulate-notify"),
+	       XConfigureNotifyEvent (":configure-notify"),
+	       XCreateNotifyEvent (":create-notify"),
+	       XDestroyNotifyEvent (":destroy-notify"),
+	       XGravityNotifyEvent (":gravity-notify"),
+	       XMapNotifyEvent (":map-notify"),
+	       XReparentNotifyEvent (":reparent-notify"),
+	       XUnmapNotifyEvent (":unmap-notify"),
+	       XVisibilityNotifyEvent (":visibility-notify"),
+	       XCirculateRequestEvent (":circulate-notify"),
+	       XColormapNotifyEvent (":colormap-notify"),
+	       XConfigureRequestEvent (":configure-request"),
+	       XMapRequestEvent (":map-request"),
+	       XResizeRequestEvent (":resize-request"),
+	       XClientMessageEvent (":client-message"),
+	       XPropertyNotifyEvent (":property-notify"),
+	       XSelectionClearEvent (":selection-clear"),
+	       XSelectionNotifyEvent (":selection-notify"),
+	       XSelectionRequestEvent (":selection-request"),
+	       XOtherEvents (":others")),
+   XEventSlot (XEventWindow ("is-window", "mk-window", "keyword-val"),
+               XEventEventWindow
+                  ("is-event-window", "mk-event-window", "keyword-val"),
+	       XEventCode ("is-code", "mk-code", "keyword-val"),
+	       XEventPos ("is-pos", "mk-pos", "keyword-val"),
+	       XEventState ("is-state", "mk-state", "keyword-val"),
+	       XEventTime ("is-time", "mk-time", "keyword-val"),
+	       XEventRoot ("is-root", "mk-root", "keyword-val"),
+	       XEventRootPos ("is-root-pos", "mk-root-pos", "keyword-val"),
+	       XEventChild ("is-child", "mk-child", "keyword-val"),
+	       XEventSameScreenP
+                  ("is-same-screen-p", "mk-same-screen-p", "keyword-val"),
+	       XEventHintP ("is-hint-p", "mk-hint-p", "keyword-val"),
+	       XEventMode ("is-mode", "mk-mode", "keyword-val"),
+	       XEventKind ("is-kind", "mk-kind", "keyword-val"),
+	       XEventFocusP ("is-focus-p", "mk-focus-p", "keyword-val"),
+	       XEventKeymap ("is-keymap", "mk-keymap", "keyword-val"),
+	       XEventRequest ("is-request", "mk-request", "keyword-val"),
+	       XEventStart ("is-start", "mk-start", "keyword-val"),
+	       XEventCount ("is-count", "mk-count", "keyword-val"),
+	       XEventRect ("is-rect", "mk-rect", "keyword-val"),
+	       XEventDrawable ("is-drawable", "mk-drawable", "keyword-val"),
+	       XEventXGraphFun ("is-graph-fun", "mk-graph-fun", "keyword-val"),
+	       XEventPlace ("is-place", "mk-place", "keyword-val"),
+	       XEventBorderWidth
+                ("is-border-width", "mk-border-width", "keyword-val"),
+	       XEventAboveSibling 
+                ("is-above-sibling", "mk-above-sibling", "keyword-val"),
+	       XEventOverrideRedirectP
+                ("is-override-redirect-p", "mk-override-redirect-p", "keyword-val"),
+	       XEventParent ("is-parent", "mk-parent", "keyword-val"),
+	       XEventConfigureP ("is-configure-p", "mk-configure-p", "keyword-val"),
+	       XEventVisibility ("is-visibility", "mk-visibility", "keyword-val"),
+	       XEventNewP ("is-new-p", "mk-new-p", "keyword-val"),
+	       XEventInstalledP ("is-installed-p", "mk-installed-p", "keyword-val"),
+	       XEventStackMode ("is-stack-mode", "mk-stack-mode", "keyword-val"),
+	       XEventValueMask ("is-value-mask", "mk-value-mask", "keyword-val"),
+	       XEventSize ("is-size", "mk-size", "keyword-val"),
+	       XEventMessage ("is-message", "mk-message", "keyword-val"),
+	       XEventPropertyState
+                 ("is-property-state", "mk-property-state", "keyword-val"),
+	       XEventAtom ("is-atom", "mk-atom", "keyword-val"),
+	       XEventSelection ("is-selection", "mk-selection", "keyword-val"),
+	       XEventTarget ("is-target", "mk-target", "keyword-val"),
+	       XEventProperty ("is-property", "mk-property", "keyword-val"),
+	       XEventRequestor ("is-requestor", "mk-requestor", "keyword-val")),
+   XEventMask (XEventMask ("x-make-event-mask", "x-event-mask-key-list")),
+   XEventMaskKey (XButton1Motion (":button-1-motion"),
+                  XButton2Motion (":button-2-motion"),
+		  XButton3Motion (":button-3-motion"),
+		  XButton4Motion (":button-4-motion"),
+		  XButton5Motion (":button-5-motion"),
+		  XButtonMotion (":button-motion"),
+		  XButtonPress (":button-press"),
+		  XButtonRelease (":button-release"),
+		  XColormapChange (":colormap-change"),
+		  XEnterWindow (":enter-window"),
+		  XExposure (":exposure"),
+		  XFocusChange (":focus-change"),
+		  XKeyPress (":key-press"),
+		  XKeyRelease (":key-release"),
+		  XKeymapState (":keymap-state"),
+		  XLeaveWindow (":leave-window"),
+		  XOwnerGrabButton (":owner-grab-button"),
+		  XPointerMotion (":pointer-motion"),
+		  XPointerMotionHint (":pointer-motion-hint"),
+		  XPropertyChange (":property-change"),
+		  XResizeRedirect (":resize-redirect"),
+		  XStructureNotify (":structure-notify"),
+		  XSubstructureRedirect (":substructure-notify"),
+		  XVisibilityChange (":visibility-change")),
+   XStateMask (XStateMask ("x-make-state-mask", "x-state-mask-key-list")),
+   XStateMaskKey (XShift (":shift"),
+                  XLock (":lock"),
+		  XControl (":control"),
+		  XMod1 (":mod-1"),
+		  XMod2 (":mod-2"),
+		  XMod3 (":mod-3"),
+		  XMod4 (":mod-4"),
+		  XMod5 (":mod-5"),
+		  XButton1 (":button-1"),
+		  XButton2 (":button-2"),
+		  XButton3 (":button-3"),
+		  XButton4 (":button-4"),
+		  XButton5 (":button-5")),
+  XWinAttribute
+    (XWinBackground ("is-background","mk-background","keyword-val"),
+     XWinEventMask ("is-event-mask","mk-event-mask","keyword-val"),
+     XWinDepth ("is-depth","mk-depth","keyword-val"),
+     XWinBorderWidth ("is-border-width","mk-border-width","keyword-val"),
+     XWinClass ("is-class","mk-class","keyword-val"),
+     XWinVisual ("is-visual","mk-visual","keyword-val"),
+     XWinBorder ("is-border","mk-border","keyword-val"),
+     XWinBackingStore ("is-backing-store","mk-backing-store","keyword-val"),
+     XWinBackingPlanes ("is-backing-planes","mk-backing-planes","keyword-val"),
+     XWinBackingPixel ("is-backing-pixel","mk-backing-pixel","keyword-val"),
+     XWinSaveUnder ("is-save-under","mk-save-under","keyword-val"),
+     XWinDoNotPropagateMask ("is-do-not-propagate-mask",
+	  	             "mk-do-not-propagate-mask","keyword-val"),
+     XWinOverrideRedirect("is-override-redirect",
+                          "mk-override-redirect","keyword-val"),
+     XWinColormap ("is-colormap","mk-colormap","keyword-val"),
+     XWinCursor ("is-cursor","mk-cursor","keyword-val")),
+   XGCAttribute(
+     XGCArcMode ("is-arc-mode","mk-arc-mode","keyword-val"),
+     XGCBackground ("is-background","mk-background","keyword-val"),
+     XGCCapStyle ("is-cap-style","mk-cap-style","keyword-val"),
+     XGCClipMask ("is-clip-mask","mk-clip-mask","keyword-val"),
+     XGCClipOrigin ("is-clip-origin","mk-clip-origin","keyword-val"),
+     XGCDashOffset ("is-dash-offset","mk-dash-offset","keyword-val"),
+     XGCDashes ("is-dashes","mk-dashes","keyword-val"),
+     XGCExposures ("is-exposures","mk-exposures","keyword-val"),
+     XGCFillRule ("is-fill-rule","mk-fill-rule","keyword-val"),
+     XGCFillStyle ("is-fill-style","mk-fill-style","keyword-val"),
+     XGCFont ("is-font","mk-font","keyword-val"),
+     XGCForeground ("is-foreground","mk-foreground","keyword-val"),
+     XGCFunction ("is-function","mk-function","keyword-val"),
+     XGCJoinStyle ("is-join-style","mk-join-style","keyword-val"),
+     XGCLineStyle ("is-line-style","mk-line-style","keyword-val"),
+     XGCLineWidth ("is-line-width","mk-line-width","keyword-val"),
+     XGCPlaneMask ("is-plane-mask","mk-plane-mask","keyword-val"),
+     XGCStipple ("is-stipple","mk-stipple","keyword-val"),
+     XGCSubwindowMode ("is-subwindow-mode","mk-subwindow-mode","keyword-val"),
+     XGCTile ("is-tile","mk-tile","keyword-val"),
+     XGCTileOrigin ("is-tile-origin","mk-tile-origin","keyword-val")),
+   XImAttribute (
+     XImBitLsbFirstP ("is-bit-lsb-first-p","mk-bit-lsb-first-p","keyword-val"),
+     XImBitsPerPixel ("is-bits-per-pixel","mk-bits-per-pixel","keyword-val"),
+     XImBlueMask ("is-blue-mask","mk-blue-mask","keyword-val"),
+     XImByteLsbFirstP ("is-byte-lsb-first-p","mk-byte-lsb-first-p","keyword-val"),
+     XImBytesPerLine ("is-bytes-per-line","mk-bytes-per-line","keyword-val"),
+     XImData ("is-data","mk-data","keyword-val"),
+     XImDepth ("is-depth","mk-depth","keyword-val"),
+     XImFormat ("is-format","mk-format","keyword-val"),
+     XImGreenMask ("is-green-mask","mk-green-mask","keyword-val"),
+     XImSize ("is-size","mk-size","keyword-val"),
+     XImName ("is-name","mk-name","keyword-val"),
+     XImRedMask ("is-red-mask","mk-red-mask","keyword-val"),
+     XImHotSpot ("is-hot-spot","mk-hot-spot","keyword-val")),
+   XGrabAttribute (
+     XGrabOwnerP ("is-owner-p", "mk-owner-p", "keyword-val"),
+     XGrabSyncPointerP ("is-sync-pointer-p", "mk-sync-pointer-p", "keyword-val"),
+     XGrabSyncKeyboardP ("is-sync-keyboard-p", "mk-sync-keyboard-p", "keyword-val"),
+     XGrabConfineTo ("is-confine-to", "mk-confine-to", "keyword-val"),
+     XGrabCursor ("is-cursor", "mk-cursor", "keyword-val")),
+   XArcMode (XChord (":chord"),
+             XPieSlice (":pie-slice")),
+   XCapStyle (XButt (":butt"),
+              XNotLast (":not-last"),
+	      XProjecting (":projecting"),
+	      XRound (":round")),
+   XClipMask (XClipMaskPixmap ("xlib:pixmap-p","identity","identity"),
+	      XClipMaskRects ("not-pixmap-and-list-p","mk-clip-mask-rects",
+	                      "sel-clip-mask-rects"),
+	      XClipMaskNone ("null?", "()")),
+   XFillRule (XFillEvenOdd (":even-odd"),
+              XFillWinding (":winding")),
+   XFillStyle (XFillOpaqueStippled (":opaque-stippled"),
+               XFillSolid (":solid"),
+	       XFillStippled (":stippled"),
+	       XFillTiled (":tiled")),
+   XFunction (XBoole1 ("xlib::boole-1"),
+              XBoole2 ("xlib::boole-2"),
+	      XBooleAndC1 ("xlib::boole-andc1"),
+	      XBooleAndC2 ("xlib::boole-andc2"),
+	      XBooleAnd ("xlib::boole-and"),
+	      XBooleC1 ("xlib::boole-c1"),
+	      XBooleC2 ("xlib::boole-c2"),
+	      XBooleClr ("xlib::boole-clr"),
+	      XBooleEqv ("xlib::boole-eqv"),
+	      XBooleIor ("xlib::boole-ior"),
+	      XBooleNand ("xlib::boole-nand"),
+	      XBooleNor ("xlib::boole-nor"),
+	      XBooleOrc1 ("xlib::boole-orc1"),
+	      XBooleOrc2 ("xlib::boole-orc2"),
+	      XBooleSet ("xlib::boole-set"),
+	      XBooleXor ("xlib::boole-xor")),
+   XJoinStyle (XJoinBevel (":bevel"),
+               XJoinMiter (":miter"),
+	       XJoinRound (":round")),
+   XLineStyle (XLineSolid (":solid"),
+               XLineDoubleDash (":double-dash"),
+	       XLineOnOffDash (":on-off-dash")),
+   XSubwindowMode (XClipByChildren (":clip-by-children"),
+   	           XIncludeInferiors (":include-inferiors")),
+   XPoint(XPoint("mk-xpoint", "xpoint-x", "xpoint-y")),
+   XSize (XSize ("mk-xsize", "xsize-w", "xsize-h")),
+   XRect (XRect ("mk-xrect", "xrect-x", "xrect-y", "xrect-w", "xrect-h")),
+   XArc	(XArc ("mk-xarc", "xarc-x", "xarc-y", "xarc-w", "xarc-h",
+	       "xarc-a1", "xarc-a2")),
+   XBitmapFormat 
+	(XBitmapFormat ("bitmap-format-p", "mk-bitmap-format",
+			"xlib:bitmap-format-unit",
+			"xlib:bitmap-format-pad",
+			"xlib:bitmap-format-lsb-first-p")),
+   XByteOrder (XLsbFirst (":lsbfirst"),
+               XMsbFirst (":msbfirst")),
+   XPixmapFormat (XPixmapFormat ("pixmap-format-p", "mk-pixmap-format", 
+			         "xlib:pixmap-format-depth",
+			         "xlib:pixmap-format-bits-per-pixel",
+			         "xlib:pixmap-format-scanline-pad")),
+   XVisualInfo 
+	(XVisualInfo (	"visual-info-p", "mk-xvisual-info", 
+		      	"xlib:visual-info-id", 
+		      	"xlib:visual-info-class",
+		      	"xlib:visual-info-red-mask",
+			"xlib:visual-info-green-mask",
+			"xlib:visual-info-blue-mask",
+ 			"xlib:visual-info-bits-per-rgb", 
+			"xlib:visual-info-colormap-entries")),
+   XVisualClass (XDirectColor (":direct-color"),
+	         XGrayScale (":gray-scale"),
+		 XPseudoColor (":pseudo-color"),
+		 XStaticColor (":static-color"),
+		 XStaticGray  (":static-gray"),
+		 XTrueColor   (":true-color")),
+   XFillContent (XFillPixel  ("is-fill-pixel", "identity","identity"),
+   	         XFillPixmap ("xlib:pixmap-p", "identity","identity"),
+		 XFillNone (":none"),
+		 XFillParentRelative (":parent-relative"),
+		 XFillCopy (":copy")),
+   XBackingStore (XAlwaysBackStore (":always"),
+                  XNeverBackStore (":never"),
+                  XBackStoreWhenMapped (":when-mapped"),
+		  XBackStoreNotUseful (":not-useful")),
+   XGravity (XForget (":forget"),
+             XStatic (":static"),
+	     XCenter (":center"),
+	     XEast (":east"),
+	     XNorth (":north"),
+	     XNorthEast (":north-east"),
+	     XNorthWest (":north-west"),
+	     XSouth (":south"),
+	     XSouthEast (":south-east"),
+	     XSouthWest (":south-west"),
+	     XWest ("west")),
+   XWindowClass (XInputOutput (":input-output"),
+                 XInputOnly (":input-only")),
+   XMapState (XUnmapped (":unmapped"),
+              XUnviewable (":unviewable"),
+	      XViewable (":viewable")),
+   XImageData (XBitmapData ("bitmap-list-p", "haskell-list->list/identity", "list->haskell-list/identity"),
+	       XPixarrayData ("pixarray-p", "identity", "identity"),
+	       XByteVecData ("bytevec-p", "identity", "identity")),
+   XImageFormat (XXyPixmapImage (":xy-pixmap"),
+                 XZPixmapImage (":z-pixmap"),
+		 XBitmapImage (":bitmap")),
+   XImageType (XImageX ("'xlib:image-x"),
+               XImageXy ("'xlib:image-xy"),
+	       XImageZ ("'xlib:image-z")),
+   XDrawDirection (XLeftToRight (":left-to-right"),
+	           XRightToLeft (":right-to-left")),
+   XColor (XColor ("xlib:color-p", "mk-color", 
+                   "xlib:color-red", "xlib:color-green", "xlib:color-blue")),
+   XInputFocus (XFocusWindow ("xlib:window-p", "identity", "identity"),
+                XFocusNone (":none"),
+		XFocusPointerRoot (":pointer-root"),
+		XFocusParent (":parent")),
+   XGrabStatus (XAlreadyGrabbed (":already-grabbed"),
+                XFrozen (":frozen"),
+                XInvalidTime (":invalid-time"),
+		XSuccess (":success")),
+   XCloseDownMode (XDestroy (":destroy"),
+	           XRetainPermanent (":retain-permanent"),
+		   XRetainTemporary (":retain-temporary")),
+   XScreenSaver (XScreenSaver ("list", "car", "cadr", "caddr", "cadddr")))
+
+#-}
+
diff --git a/progs/lib/X11/xlib.hu b/progs/lib/X11/xlib.hu
new file mode 100644
index 0000000..b86b2ac
--- /dev/null
+++ b/progs/lib/X11/xlib.hu
@@ -0,0 +1,5 @@
+:output $LIBRARYBIN/
+:stable
+:o= all
+xlib.hs
+xlibprims.hu
diff --git a/progs/lib/X11/xlibclx.scm b/progs/lib/X11/xlibclx.scm
new file mode 100644
index 0000000..1f1fd6a
--- /dev/null
+++ b/progs/lib/X11/xlibclx.scm
@@ -0,0 +1,1262 @@
+;;; xlibclx.scm -- Lisp support for Haskell/CLX interface
+
+;; general
+
+(define-syntax (nth-value n form)
+  (cond ((eqv? n 0)
+	 `(values ,form))
+	((number? n)
+	 (let ((temps  '()))
+	   (dotimes (i n)
+	     (declare (ignorable i))
+	     (push (gensym) temps))
+	   `(multiple-value-bind ,(reverse temps) ,form
+	      (declare (ignore ,@(reverse (cdr temps))))
+	      ,(car temps))))
+	(else
+	 `(lisp:nth ,n (lisp:multiple-value-list ,form)))
+	))
+
+
+(define-local-syntax (keywordify string)
+  `(lisp:intern ,string (lisp:find-package "KEYWORD")))
+
+(define-local-syntax (xlibify string)
+  `(lisp:intern ,string (lisp:find-package "XLIB")))
+
+
+
+;;; This is stuff to support slots that consist of a keyword/value
+;;; pair.  Note that the value is always unboxed.
+
+(define-syntax (make-keyword key value)
+  `(cons ,key ,value))
+
+(define-syntax (is-keyword? x key)
+  `(eq? (car ,x) ,key))
+
+(define-syntax (keyword-key x) `(car ,x))
+(define-syntax (keyword-val x) `(cdr ,x))
+
+(define-syntax (define-keyword-constructor name)
+  (let* ((name-str (symbol->string name))
+	 (key      (keywordify name-str))
+	 (is-name  (string->symbol (string-append "IS-" name-str)))
+	 (mk-name  (string->symbol (string-append "MK-" name-str))))
+    `(begin
+       (define (,mk-name x) (make-keyword ,key x))
+       (define (,is-name x) (is-keyword? x ,key)))
+    ))
+
+(define-syntax (define-event-slot-finder slot)
+  (let* ((slot-str (symbol->string slot))
+	 (slot-key (keywordify slot-str))
+	 (fun      (string->symbol (string-append "X-EVENT-" slot-str))))
+    `(define (,fun event) (lookup-event-slot (cdr event) ,slot-key))))    
+    
+(define (lookup-event-slot event key)
+  (if (null? event)
+      (error "non-existent event slot: ~A" key)
+      (if (eq? key (car event))
+	  (cadr event)
+	  (lookup-event-slot (cddr event) key))))
+
+
+(define-syntax (define-attribute-setter entity attribute)
+  (let* ((entity-attr (string-append (symbol->string entity)
+				     "-"
+				     (symbol->string attribute)))
+	 (fun-name    (string->symbol (string-append "X-SET-" entity-attr)))
+	 (xfun-name   (xlibify entity-attr)))
+    `(define (,fun-name ,entity ,attribute)
+       (setf (,xfun-name ,entity) ,attribute))))
+
+(define-syntax (make-h-tuple . args)
+  (let ((nargs (map (lambda (arg) `(box ,arg)) args)))
+    `(make-tuple ,@nargs)))
+
+;; type XError
+
+(define (cons-xerror x)
+  (declare (ignore x))
+  (error "can't construct XError"))
+
+(define (x-error-string c)
+  (make-haskell-string (format '#f "~A" c)))
+
+
+;;; The forces here are necessary because the thing being funcalled
+;;; returns a data structure of type (IO a), and we need to do
+;;; an  IO a -> a transformation.
+
+#+lucid
+(define (x-handle-error handler body)
+  (lisp:catch 'x-error-handle
+	      (lcl:handler-bind ((lisp:error (mk-handler handler)))
+				(force (funcall body (box 'state))))))
+
+#+(or cmu allegro lispworks)
+(define (x-handle-error handler body)
+  (lisp:catch 'x-error-handle
+	      (lisp:handler-bind ((lisp:error (mk-handler handler)))
+				 (force (funcall body (box 'state))))))
+
+#+akcl
+(define (x-handle-error handler body)
+  (error "AKCL does not support HANDLER-BIND!"))
+
+(define (mk-handler handler)
+  (lambda (c) 
+    (lisp:throw 'x-error-handle 
+		(force (funcall handler 
+				(box c)
+				(box 'state))))))
+
+;; for type XMaybe
+
+(define (not-null? x) (not (null? x)))
+
+
+;; For Bitmap, Pixarray, KeysymTable
+
+(define (array2->haskell-list a)
+  (let* ((dims    (lisp:array-dimensions a))
+	 (i1max   (car dims))
+	 (i2max   (cadr dims)))
+    (declare (type fixnum i1max i2max))
+    (do ((i1     (the fixnum (1- i1max)) (the fixnum (1- i1)))
+	 (outer  '()))
+	((< i1 0) outer)
+	(declare (type fixnum i1))
+	(setf outer
+	      (cons
+	        (box
+		  (do ((i2    (the fixnum (1- i2max)) (the fixnum (1- i2)))
+		       (inner '()))
+		      ((< i2 0) inner)
+		      (declare (type fixnum i2))
+		      (setf inner
+			    (cons (box (lisp:aref a i1 i2))
+				  (box inner)))))
+		(box outer))))
+    ))
+
+
+;; Bitmap
+
+(define (mk-bitmap ll)
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
+    (lisp:make-array `(,(length l) , (length (car l))) 
+		     :element-type 'lisp:bit
+		     :initial-contents l)))
+
+(define (sel-bitmap l)
+  (array2->haskell-list l))
+
+
+;; XKeysymTable
+
+(define (mk-keysym-table ll)
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
+    (lisp:make-array `(,(length l) , (length (car l))) 
+		     :element-type 'xlib:card32
+		     :initial-contents l)))
+
+(define (sel-keysym-table l)
+  (array2->haskell-list l))
+
+;; XPixarray
+
+(define (mk-pixarray ll)
+  (let ((l (haskell-list->list #'haskell-list->list/identity ll)))
+    (let* ((max-num  (find-max l))
+	   (pix-type (cond ((<= max-num 1) 'lisp:bit)
+			   ((<= max-num 15) '(lisp:unsigned-byte 4))
+			   ((<= max-num 255) 'xlib:card8)
+			   ((<= max-num 65535) 'xlib:card16)
+			   (else 'xlib:card32))))
+      (declare (type integer max-num))
+      (lisp:make-array `(,(length l) , (length (car l)))
+		       :element-type pix-type
+		       :initial-contents l))))
+
+(define (find-max l)
+  (let ((max  0))
+    (dolist (ll l)
+      (dolist (lll ll)
+	(when (> (the integer lll) (the integer max))
+	  (setf max lll))))
+    max))
+
+(define (sel-pixarray l)
+  (array2->haskell-list l))
+
+
+
+
+;;; Can't use mumble vector primitives on arrays of specialized types!
+
+(define (array1->haskell-list a)
+  (declare (type lisp:vector a))
+  (let ((imax  (lisp:length a)))
+    (declare (type fixnum imax))
+    (do ((i      (the fixnum (1- imax)) (the fixnum (1- i)))
+	 (result '()))
+	((< i 0) result)
+	(declare (type fixnum i))
+	(setf result
+	      (cons (box (lisp:aref a i))
+		    (box result))))))
+
+;; BitVec
+
+(define (mk-bitvec ll)
+  (let ((l (haskell-list->list/identity ll)))
+    (lisp:make-array `(,(length l)) :element-type 'lisp:bit
+		     :initial-contents l)))
+
+(define (sel-bitvec l)
+  (array1->haskell-list l))
+
+;; ByteVec
+
+(define (mk-bytevec ll)
+  (let ((l (haskell-list->list/identity ll)))
+    (lisp:make-array `(,(length l)) :element-type 'xlib:card8
+		     :initial-contents l)))
+
+(define (sel-bytevec l)
+  (array1->haskell-list l))
+
+
+;; XAtom
+(define (mk-atom name)
+  (keywordify (haskell-string->string name)))
+
+(define (sel-atom atom)
+  (make-haskell-string (symbol->string atom)))
+
+;; XProperty
+;;; watch out for name conflict with :property keyword stuff
+(define (mk-xproperty d ty f) (list (haskell-list->list/identity d) ty f))
+(define (sel-xproperty-data p) (list->haskell-list/identity (car p)))
+(define (sel-xproperty-type p) (cadr p))
+(define (sel-xproperty-format p) (caddr p))
+
+(define (mk-event type slots)
+  (cons type (slots->keywords (haskell-list->list/identity slots))))
+
+(define (sel-event-type event) (car event))
+
+(define (sel-event-slots event) 
+  (list->haskell-list/identity (keywords->slots (car event) (cdr event) event)))
+
+;; XEventSlot
+
+(define-keyword-constructor window)
+(define-keyword-constructor event-window)
+(define-keyword-constructor code)
+(define-keyword-constructor pos)
+(define-keyword-constructor state)
+(define-keyword-constructor time)
+(define-keyword-constructor root)
+(define-keyword-constructor root-pos)
+(define-keyword-constructor child)
+(define-keyword-constructor same-screen-p)
+(define-keyword-constructor hint-p)
+(define-keyword-constructor mode)
+(define-keyword-constructor kind)
+(define-keyword-constructor focus-p)
+(define-keyword-constructor keymap)
+(define-keyword-constructor request)
+(define-keyword-constructor start)
+(define-keyword-constructor count)
+(define-keyword-constructor rect)
+(define-keyword-constructor drawable)
+(define-keyword-constructor graph-fun)
+(define-keyword-constructor place)
+(define-keyword-constructor border-width)
+(define-keyword-constructor above-sibling)
+(define-keyword-constructor override-redirect-p)
+(define-keyword-constructor parent)
+(define-keyword-constructor configure-p)
+(define-keyword-constructor visibility)
+(define-keyword-constructor new-p)
+(define-keyword-constructor installed-p)
+(define-keyword-constructor stack-mode)
+(define-keyword-constructor value-mask)
+(define-keyword-constructor size)
+(define-keyword-constructor message)
+(define-keyword-constructor property-state)
+(define-keyword-constructor atom)
+(define-keyword-constructor selection)
+(define-keyword-constructor target)
+(define-keyword-constructor property)
+(define-keyword-constructor requestor)
+
+(define-event-slot-finder window)
+(define-event-slot-finder event-window)
+(define-event-slot-finder code)
+(define-event-slot-finder x)
+(define-event-slot-finder y)
+(define-event-slot-finder state)
+(define-event-slot-finder time)
+(define-event-slot-finder root)
+(define-event-slot-finder root-x)
+(define-event-slot-finder root-y)
+(define-event-slot-finder child)
+(define-event-slot-finder same-screen-p)
+(define-event-slot-finder hint-p)
+(define-event-slot-finder mode)
+(define-event-slot-finder kind)
+(define-event-slot-finder focus-p)
+(define-event-slot-finder keymap)
+(define-event-slot-finder request)
+(define-event-slot-finder start)
+(define-event-slot-finder count)
+(define-event-slot-finder width)
+(define-event-slot-finder height)
+(define-event-slot-finder drawable)
+(define-event-slot-finder major)
+(define-event-slot-finder minor)
+(define-event-slot-finder place)
+(define-event-slot-finder border-width)
+(define-event-slot-finder above-sibling)
+(define-event-slot-finder override-redirect-p)
+(define-event-slot-finder parent)
+(define-event-slot-finder configure-p)
+(define-event-slot-finder new-p)
+(define-event-slot-finder installed-p)
+(define-event-slot-finder stack-mode)
+(define-event-slot-finder value-mask)
+(define-event-slot-finder data)
+(define-event-slot-finder type)
+(define-event-slot-finder format)
+(define-event-slot-finder atom)
+(define-event-slot-finder selection)
+(define-event-slot-finder target)
+(define-event-slot-finder property)
+(define-event-slot-finder requestor)
+
+(define (x-event-pos event) (mk-xpoint (x-event-x event) (x-event-y event)))
+
+(define (x-event-root-pos event) 
+  (mk-xpoint (x-event-root-x event) (x-event-root-y event)))
+
+(define (x-event-size event) 
+  (mk-xsize (x-event-width event) (x-event-height event)))
+
+(define (x-event-rect event) 
+  (mk-xrect (x-event-x event) (x-event-y event)
+	    (x-event-width event) (x-event-height event)))
+
+(define (x-event-graph-fun event)
+  (cons (x-event-major event) (x-event-minor event)))
+
+(define (x-event-message event)
+  (list (sequence->list (x-event-data event))
+	(x-event-type event)
+	(x-event-format event)))
+
+
+;; XEventMask
+
+(define (x-make-event-mask keys)
+  (apply (function xlib:make-event-mask) (haskell-list->list/identity keys)))
+
+(define (x-event-mask-key-list mask)
+  (list->haskell-list/identity (xlib:make-event-keys mask)))
+
+;; XStateMask
+
+(define (x-make-state-mask keys)
+  (apply (function xlib:make-state-mask) (haskell-list->list/identity keys)))
+
+(define (x-state-mask-key-list mask)
+  (list->haskell-list/identity (xlib:make-state-keys mask)))
+
+
+(define-keyword-constructor background)
+(define-keyword-constructor foreground)
+(define-keyword-constructor event-mask)
+(define-keyword-constructor depth)
+(define-keyword-constructor border-width)
+(define-keyword-constructor class)
+(define-keyword-constructor visual)
+(define-keyword-constructor border)
+(define-keyword-constructor backing-store)
+(define-keyword-constructor backing-planes)
+(define-keyword-constructor backing-pixel)
+(define-keyword-constructor save-under)
+(define-keyword-constructor do-not-propagate-mask)
+(define-keyword-constructor override-redirect)
+(define-keyword-constructor colormap)
+(define-keyword-constructor cursor)
+
+(define-keyword-constructor arc-mode)
+(define-keyword-constructor cap-style)
+(define-keyword-constructor clip-mask)
+(define-keyword-constructor clip-origin)
+(define-keyword-constructor dash-offset)
+(define-keyword-constructor dashes)
+(define-keyword-constructor exposures)
+(define-keyword-constructor fill-rule)
+(define-keyword-constructor fill-style)
+(define-keyword-constructor font)
+(define-keyword-constructor function)
+(define-keyword-constructor join-style)
+(define-keyword-constructor line-style)
+(define-keyword-constructor line-width)
+(define-keyword-constructor plane-mask)
+(define-keyword-constructor stipple)
+(define-keyword-constructor subwindow-mode)
+(define-keyword-constructor tile)
+(define-keyword-constructor tile-origin)
+
+(define-keyword-constructor bit-lsb-first-p)
+(define-keyword-constructor bits-per-pixel)
+(define-keyword-constructor blue-mask)
+(define-keyword-constructor byte-lsb-first-p)
+(define-keyword-constructor bytes-per-line)
+(define-keyword-constructor data)
+(define-keyword-constructor format)
+(define-keyword-constructor green-mask)
+(define-keyword-constructor size)
+(define-keyword-constructor name)
+(define-keyword-constructor red-mask)
+(define-keyword-constructor hot-spot)
+
+
+(define-keyword-constructor owner-p)
+(define-keyword-constructor sync-pointer-p)
+(define-keyword-constructor sync-keyboard-p)
+(define-keyword-constructor confine-to)
+
+
+;; XClipMask
+
+(define (not-pixmap-and-list-p x) 
+  (and (pair? x) (not (xlib:pixmap-p x))))
+(define (mk-clip-mask-rects rects) 
+  (rects->point-seq (haskell-list->list/identity rects)))
+(define (sel-clip-mask-rects point-seq) 
+  (list->haskell-list/identity (point-seq->rects point-seq)))
+
+;; XPoint
+
+(define (mk-xpoint x y) (cons x y))
+(define (xpoint-x x) (car x))
+(define (xpoint-y x) (cdr x))
+
+;; XSize
+
+(define (mk-xsize x y) (cons x y))
+(define (xsize-w x) (car x))
+(define (xsize-h x) (cdr x))
+
+;; XRect
+(define (mk-xrect x y w h) (vector x y w h))
+(define (xrect-x x) (vector-ref x 0))
+(define (xrect-y x) (vector-ref x 1))
+(define (xrect-w x) (vector-ref x 2))
+(define (xrect-h x) (vector-ref x 3))
+
+;; XArc
+
+(define (mk-xarc x y w h a1 a2) (vector x y w h a1 a2))
+
+(define (xarc-x x) (vector-ref x 0))
+(define (xarc-y x) (vector-ref x 1))
+(define (xarc-w x) (vector-ref x 2))
+(define (xarc-h x) (vector-ref x 3))
+(define (xarc-a1 x) (vector-ref x 4))
+(define (xarc-a2 x) (vector-ref x 5))
+
+;; BitmapFormat
+
+(define (mk-bitmap-format u p l) 
+  (xlib::make-bitmap-format :unit u :pad p :lsb-first-p l))
+
+;; PixmapFormat
+
+(define (mk-pixmap-format u p l) 
+  (xlib::make-pixmap-format :depth u :bits-per-pixel p :scanline-pad l))
+
+;; XVisualInfo
+
+(define (mk-xvisual-info id cl rm gm bm bs es) 
+  (xlib::make-visual-info :id id :class cl :red-mask rm :green-mask gm 
+			  :blue-mask bm :bits-per-rgb bs :colormap-entries es))
+
+;; XFillContent
+
+(define (is-fill-pixel x) (not (or (xlib:pixmap-p x) (symbol? x))))
+
+;; XBackingStore
+
+;; XImageData
+
+(define (bitmap-list-p x) (pair? x))
+(define (pixarray-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 2)))
+(define (bytevec-p x) (and (not (pair? x)) (eq? (lisp:array-rank x) 1)))
+
+;; XColor
+(define (mk-color r g b) 
+  (xlib:make-color :red r :green g :blue b))
+
+
+(define (x-print x)
+  (print x))
+
+(define (x-set-event-mask-key mask key-sym) 
+  (lisp:logior mask (xlib:make-event-mask key-sym)))
+
+(define (x-clear-event-mask-key mask key-sym) 
+  (lisp:logand mask (lisp:lognot (xlib:make-event-mask key-sym))))
+
+
+(define (x-test-event-mask-key mask key-sym)
+  (if (eqv? 0 (lisp:logand mask (xlib:make-event-mask key-sym))) '#f '#t))
+
+(define (x-set-state-mask-key mask key-sym) 
+  (lisp:logior mask (xlib:make-state-mask key-sym)))
+
+(define (x-clear-state-mask-key mask key-sym) 
+  (lisp:logand mask (lisp:lognot (xlib:make-state-mask key-sym))))
+
+(define (x-test-state-mask-key mask key-sym)
+  (if (eqv? 0 (lisp:logand mask (xlib:make-state-mask key-sym))) '#f '#t))
+
+
+;;; Display is a string of the format name:d.s
+;;; ignore s; if d is omitted, default it to zero.
+
+(define (x-open-display display)
+  (let* ((end    (string-length display))
+	 (colon  (or (string-position #\: display 0 end) end))
+	 (dot    (or (string-position #\. display colon end) end)))
+    (declare (type fixnum end colon dot))
+    (xlib:open-display
+      (substring display 0 colon)
+      :display (if (eqv? colon dot)
+		   0
+		   (string->number (substring display (1+ colon) dot))))))
+
+(define (x-set-display-error-handler display error-fun)
+  (declare (ignore display error-fun))
+  (error "not implemented"))
+
+(define (x-set-display-after-function display after-fun)
+  (declare (ignore display after-fun))
+  (error "not implemented"))
+
+(define (x-screen-depths screen)
+  (let ((depths (xlib:screen-depths screen)))
+    (map (lambda (l) (make-h-tuple (car l) (list->haskell-list/identity (cdr l))))
+	 depths)))
+
+(define (x-screen-size screen)
+  (mk-xsize (xlib:screen-width screen) (xlib:screen-height screen)))
+
+(define (x-screen-mmsize screen)
+  (mk-xsize (xlib:screen-width-in-millimeters screen) 
+	    (xlib:screen-height-in-millimeters screen)))
+
+(define (x-create-window parent rect attrs)
+  (apply (function XLIB:CREATE-WINDOW)
+	 `(:parent ,parent :x ,(xrect-x rect) :y ,(xrect-y rect)
+	   :width ,(xrect-w rect) :height ,(xrect-h rect)
+	   ,@(attrs->keywords attrs))))
+
+(define-attribute-setter drawable border-width)
+
+(define (x-drawable-size drawable)
+  (mk-xsize (xlib:drawable-width drawable) (xlib:drawable-height drawable)))
+
+(define (x-drawable-resize drawable size)
+  (setf (xlib:drawable-width drawable) (xsize-w size))
+  (setf (xlib:drawable-height drawable) (xsize-h size)))
+
+(define (x-window-pos window)
+  (mk-xpoint (xlib:drawable-x window) (xlib:drawable-y window)))
+
+(define (x-window-move window point)
+  (setf (xlib:drawable-x window) (xpoint-x point))
+  (setf (xlib:drawable-y window) (xpoint-y point)))
+
+(define-attribute-setter window background)
+(define-attribute-setter window backing-pixel)
+(define-attribute-setter window backing-planes)
+(define-attribute-setter window backing-store)
+(define-attribute-setter window bit-gravity)
+(define-attribute-setter window border)
+(define-attribute-setter window colormap)
+
+(define (x-set-window-cursor window cursor)
+  (let ((val (if (null? cursor) :none cursor)))
+    (setf (xlib:window-cursor window) val)))
+
+(define-attribute-setter window do-not-propagate-mask)
+(define-attribute-setter window event-mask)
+(define-attribute-setter window gravity)
+(define-attribute-setter window override-redirect)
+(define-attribute-setter window priority)
+(define-attribute-setter window save-under)
+
+(define (x-query-tree window)
+  (multiple-value-bind (children parent root)
+		       (xlib:query-tree window)
+     (make-h-tuple (list->haskell-list/identity children) parent root)))
+
+(define (x-reparent-window window parent point)
+  (xlib:reparent-window window parent (xpoint-x point) (xpoint-y point)))
+
+(define (x-translate-coordinates source point dest)
+  (xlib:translate-coordinates source (xpoint-x point) (xpoint-y point) dest))
+
+(define (x-create-pixmap size depth drawable)
+  (xlib:create-pixmap :width (xsize-w size)
+		      :height (xsize-h size)
+		      :depth depth
+		      :drawable drawable))
+
+(define (x-create-gcontext drawable attrs)
+  (apply (function XLIB:CREATE-GCONTEXT)
+	 `(:drawable ,drawable ,@(attrs->keywords attrs))))
+
+(define (x-update-gcontext gcontext attrs)
+  (do ((keys (attrs->keywords attrs) (cddr keys)))
+      ((null? keys))
+    (x-update-gcontext-attr gcontext (car keys) (cadr keys))))
+
+(define (x-update-gcontext-attr gcontext key attr)
+  (case key
+    (:arc-mode (setf (xlib:gcontext-arc-mode gcontext) attr))
+    (:background (setf (xlib:gcontext-background gcontext) attr))
+    (:cap-style (setf (xlib:gcontext-cap-style gcontext) attr))
+    (:fill-style (setf (xlib:gcontext-fill-style gcontext) attr))
+    (:clip-mask (setf (xlib:gcontext-clip-mask gcontext) attr))
+    (:clip-x (setf (xlib:gcontext-clip-x gcontext) attr))
+    (:clip-y (setf (xlib:gcontext-clip-y gcontext) attr))
+    (:dash-offset (setf (xlib:gcontext-dash-offset gcontext) attr))
+    (:dashes (setf (xlib:gcontext-dashes gcontext) attr))
+    (:exposures (setf (xlib:gcontext-exposures gcontext) attr))
+    (:fill-rule (setf (xlib:gcontext-fill-rule gcontext) attr))
+    (:font (setf (xlib:gcontext-font gcontext) attr))
+    (:foreground (setf (xlib:gcontext-foreground gcontext) attr))
+;    (:function (setf (xlib:gcontext-function gcontext) attr))
+    (:join-style (setf (xlib:gcontext-join-style gcontext) attr))
+    (:line-style (setf (xlib:gcontext-line-style gcontext) attr))
+;    (:line-width (setf (xlib:gcontext-line-width gcontext) attr))
+;    (:plane-mask (setf (xlib:gcontext-plane-mask gcontext) attr))
+;    (:stipple (setf (xlib:gcontext-stipple gcontext) attr))
+    (:subwindow-mode (setf (xlib:gcontext-subwindow-mode gcontext) attr))
+;    (:tile (setf (xlib:gcontext-tile gcontext) attr))
+;    (:ts-x (setf (xlib:gcontext-ts-x gcontext) attr))
+;    (:ts-y (setf (xlib:gcontext-ts-y gcontext) attr))
+    (else (format '#t "Graphics context attribute ~A is not settable.~%"
+		  key))))
+
+(define (x-query-best-stipple dsize drawable)
+  (multiple-value-bind (w h) 
+        (xlib:query-best-stipple (xsize-w dsize) (xsize-h dsize) drawable)
+     (mk-xsize w h)))
+
+(define (x-query-best-tile dsize drawable)
+  (multiple-value-bind (w h) 
+        (xlib:query-best-tile (xsize-w dsize) (xsize-h dsize) drawable)
+     (mk-xsize w h)))
+
+(define (x-clear-area window rect exposures-p)
+  (xlib:clear-area window 
+		   :x (xrect-x rect)
+		   :y (xrect-y rect)
+		   :width (xrect-w rect)
+		   :height (xrect-h rect)
+		   :exposures-p exposures-p))
+
+(define (x-copy-area src gcontext rect dest point)
+  (xlib:copy-area src 
+		  gcontext 
+		  (xrect-x rect) (xrect-y rect) 
+		  (xrect-w rect) (xrect-h rect) 
+		  dest 
+		  (xpoint-x point) (xpoint-y point)))
+
+(define (x-copy-plane src gcontext plane rect dest point)
+  (xlib:copy-plane src 
+		   gcontext 
+		   plane 
+		   (xrect-x rect) (xrect-y rect) 
+		   (xrect-w rect) (xrect-h rect) 
+		   dest 
+		   (xpoint-x point) (xpoint-y point)))
+
+(define (x-draw-point drawable gcontext point)
+  (xlib:draw-point drawable gcontext (xpoint-x point) (xpoint-y point)))
+
+(define (x-draw-points drawable gcontext points)
+  (xlib:draw-points drawable gcontext (points->point-seq points)))
+
+(define (points->point-seq points)
+  (if (null? points)
+      '()
+      (let ((point (car points)))
+	(lisp:list* (xpoint-x point)
+		    (xpoint-y point)
+		    (points->point-seq (cdr points))))))
+
+(define (segments->point-seq segments)
+  (if (null? segments)
+      '()
+      (let* ((first-pair (car segments))
+	     (point-1 (force (tuple-select 2 0 first-pair)))
+	     (point-2 (force (tuple-select 2 1 first-pair))))
+	(lisp:list* (xpoint-x point-1)
+		    (xpoint-y point-1) 
+		    (xpoint-x point-2)
+		    (xpoint-y point-2) 
+		    (segments->point-seq (cdr segments))))))
+
+(define (rects->point-seq rects)
+  (if (null? rects)
+      '()
+      (let ((rect (car rects)))
+	(lisp:list* (xrect-x rect)
+		    (xrect-y rect)
+		    (xrect-w rect)
+		    (xrect-h rect)
+		    (rects->point-seq (cdr rects))))))
+
+(define (point-seq->rects point-seq)
+  (if (null? point-seq)
+      '()
+      (cons (mk-xrect (car point-seq) (cadr point-seq) 
+		      (caddr point-seq) (cadddr point-seq))
+	    (point-seq->rects (cddddr point-seq)))))
+
+(define (arcs->point-seq arcs)
+  (if (null? arcs)
+      '()
+      (let ((arc (car arcs)))
+	(lisp:list* (xarc-x arc)
+		    (xarc-y arc)
+		    (xarc-w arc)
+		    (xarc-h arc)
+		    (xarc-a1 arc)
+		    (xarc-a2 arc)
+		    (arcs->point-seq (cdr arcs))))))
+
+(define (x-draw-line drawable gcontext point-1 point-2)
+  (xlib:draw-line drawable gcontext (xpoint-x point-1) (xpoint-y point-1)
+		  (xpoint-x point-2) (xpoint-y point-2)))
+
+(define (x-draw-lines drawable gcontext points fill-p)
+  (xlib:draw-lines drawable gcontext 
+		   (points->point-seq points) :fill-p fill-p))
+
+(define (x-draw-segments drawable gcontext segments)
+  (xlib:draw-segments drawable gcontext (segments->point-seq segments)))
+
+(define (x-draw-rectangle drawable gcontext rect fill-p)
+  (xlib:draw-rectangle drawable gcontext
+		       (xrect-x rect) (xrect-y rect) 
+		       (xrect-w rect) (xrect-h rect)
+		       fill-p))
+
+(define (x-draw-rectangles drawable gcontext rects fill-p)
+  (xlib:draw-rectangles drawable gcontext
+			(rects->point-seq rects)
+			fill-p))
+
+(define (x-draw-arc drawable gcontext arc fill-p)
+  (xlib:draw-arc drawable gcontext
+		 (xarc-x arc) (xarc-y arc) 
+		 (xarc-w arc) (xarc-h arc)
+		 (xarc-a1 arc) (xarc-a2 arc)
+		 fill-p))
+
+(define (x-draw-arcs drawable gcontext arcs fill-p)
+  (xlib:draw-arcs drawable gcontext
+		  (arcs->point-seq arcs)
+		  fill-p))
+
+(define (x-draw-glyph drawable gcontext point element)
+  (nth-value 1
+	     (xlib:draw-glyph drawable gcontext (xpoint-x point) 
+			      (xpoint-y point) element)))
+
+(define (x-draw-glyphs drawable gcontext point element)
+  (nth-value 1 (xlib:draw-glyphs drawable gcontext (xpoint-x point) 
+				 (xpoint-y point) element)))
+
+(define (x-draw-image-glyph drawable gcontext point element)
+  (nth-value 1 (xlib:draw-image-glyph drawable gcontext (xpoint-x point) 
+				      (xpoint-y point) element)))
+
+(define (x-draw-image-glyphs drawable gcontext point element)
+  (nth-value 1 (xlib:draw-image-glyphs drawable gcontext (xpoint-x point) 
+				       (xpoint-y point) element)))
+
+(define (x-image-size image)
+  (mk-xsize (xlib:image-width image) (xlib:image-height image)))
+
+(define (x-image-name image)
+  (let ((lisp-name (xlib:image-name image)))
+    (cond ((null? lisp-name) "")
+	  ((symbol? lisp-name) (symbol->string lisp-name))
+	  (else lisp-name))))
+    
+(define-attribute-setter image name)
+
+(define (x-image-hot-spot image)
+  (mk-xpoint (xlib:image-x-hot image) (xlib:image-y-hot image)))
+
+(define (x-set-image-hot-spot image point)
+  (setf (xlib:image-x-hot image) (xpoint-x point))
+  (setf (xlib:image-y-hot image) (xpoint-y point)))
+
+(define-attribute-setter image xy-bitmap-list)
+(define-attribute-setter image z-bits-per-pixel)
+(define-attribute-setter image z-pixarray)
+
+(define (x-create-image attrs)
+  (apply (function xlib:create-image) (attrs->keywords attrs)))
+
+(define (x-copy-image image rect type)
+  (xlib:copy-image image :x (xrect-x rect) :y (xrect-y rect)
+		   :width (xrect-w rect) :height (xrect-h rect)
+		   :result-type type))
+
+(define (x-get-image drawable rect pmask format type)
+  (xlib:get-image drawable :x (xrect-x rect) :y (xrect-y rect)
+		  :width (xrect-w rect) :height (xrect-h rect)
+		  :plane-mask pmask :format format :result-type type))
+
+(define (x-put-image drawable gcontext image point rect)
+  (xlib:put-image drawable gcontext image 
+		  :src-x (xpoint-x point) :src-y (xpoint-y point)
+		  :x (xrect-x rect) :y (xrect-y rect)
+		  :width (xrect-w rect) :height (xrect-h rect)))
+
+(define (x-get-raw-image drawable rect pmask format)
+  (xlib:get-raw-image drawable 
+		      :x (xrect-x rect) :y (xrect-y rect) 
+		      :width (xrect-w rect) :height (xrect-h rect)
+		      :plane-mask pmask :format format))
+
+(define (x-put-raw-image drawable gcontext data depth rect left-pad format)
+  (xlib:put-raw-image drawable gcontext data
+		      :depth depth 
+		      :x (xrect-x rect) :y (xrect-y rect) 
+		      :width (xrect-w rect) :height (xrect-h rect)
+		      :left-pad left-pad :format format))
+
+(define (x-font-name font)
+  (let ((lisp-name (xlib:font-name font)))
+    (cond ((null? lisp-name) "")
+	  ((symbol? lisp-name) (symbol->string lisp-name))
+	  (else lisp-name))))
+
+(define (x-alloc-color colormap color)
+  (multiple-value-bind (pixel screen-color exact-color)
+       (xlib:alloc-color colormap color)
+     (make-h-tuple pixel screen-color exact-color)))
+
+(define (x-alloc-color-cells colormap colors planes contiguous-p)
+  (multiple-value-bind (pixels mask)
+       (xlib:alloc-color-cells colormap colors :planes planes 
+			       :contiguous-p contiguous-p)
+     (make-h-tuple (list->haskell-list/identity pixels) (list->haskell-list/identity mask))))
+
+(define (x-alloc-color-planes colormap colors reds greens blues contiguous-p)
+  (multiple-value-bind (pixels red-mask green-mask blue-mask)
+       (xlib:alloc-color-planes colormap colors :reds reds :greens greens
+				:blues blues :contiguous-p contiguous-p)
+     (make-h-tuple (list->haskell-list/identity pixels) 
+		   red-mask
+		   green-mask
+		   blue-mask)))
+
+(define (x-lookup-color colormap name)
+  (multiple-value-bind (screen-color exact-color)
+      (xlib:lookup-color colormap name)
+    (make-h-tuple screen-color exact-color)))
+
+(define (unzip l)
+  (if (null? l)
+      '()
+      (let ((h (car l)))
+	(lisp:list* (force (tuple-select 2 0 h))
+		    (force (tuple-select 2 1 h))
+		    (unzip (cdr l))))))
+
+(define (x-store-colors colormap pixel-colors)
+  (xlib:store-colors colormap (unzip pixel-colors)))
+
+(define (x-create-cursor source mask point foreground background)
+  (apply (function xlib:create-cursor)
+	 `(:source ,source
+	   ,@(if mask `(:mask ,mask) '())
+	   :x ,(xpoint-x point) :y ,(xpoint-y point)
+	   :foreground ,foreground :background ,background)))
+
+(define (x-create-glyph-cursor src mask foreground background)
+  (apply (function xlib:create-glyph-cursor)
+	 `(:source-font ,(force (tuple-select 2 0 src))
+	   :source-char ,(integer->char (force (tuple-select 2 1 src)))
+	   ,@(if mask 
+		 `(:mask-font ,(force (tuple-select 2 0 mask))
+		 :mask-char ,(integer->char (force (tuple-select 2 1 mask))))
+		 '())
+	   :foreground ,foreground :background ,background)))
+
+(define (x-query-best-cursor size display)
+  (multiple-value-bind (w h)
+      (xlib:query-best-cursor (xsize-w size) (xsize-h size) display)
+    (mk-xsize w h)))
+
+(define (x-change-property window property content)
+  (xlib:change-property window property 
+			(car content) (cadr content) 
+			(caddr content)))
+
+(define (x-get-property window property)
+  (lisp:multiple-value-bind (data type format) 
+			    (xlib:get-property window property)
+	 (list (sequence->list data) type format)))
+
+(define (x-convert-selection selection type requestor property time)
+  (apply (function xlib:convert-selection)
+	 `(,selection ,type ,requestor ,property ,@(if time `(,time) '()))))
+
+(define (x-set-selection-owner display selection time owner)
+  (if time
+      (setf (xlib:selection-owner display selection time) owner)
+      (setf (xlib:selection-owner display selection) owner)))
+
+(define (sequence->list seq)
+  (if (list? seq) seq
+      (do ((i (1- (lisp:length seq)) (1- i))
+	   (res '() (cons (lisp:elt seq i) res)))
+	  ((< i 0) res))))
+
+(define *this-event* '())
+
+(define (translate-event lisp:&rest event-slots lisp:&key event-key 
+			 lisp:&allow-other-keys)
+  (setf *this-event* (cons event-key event-slots))
+  '#t)
+
+
+(define (x-get-event display)
+  (xlib:process-event display :handler #'translate-event :force-output-p '#t)
+  *this-event*)
+
+(define (x-queue-event display event append-p)
+  (apply (function xlib:queue-event)
+	 `(,display ,(car event) ,@(cdr event) :append-p ,append-p)))
+
+(define (x-event-listen display)
+  (let ((res (xlib:event-listen display)))
+    (if (null? res) 0 res)))
+
+(define (x-send-event window event mask)
+  (apply (function xlib:send-event)
+	 `(,window ,(car event) ,mask ,@(cdr event))))
+
+(define (x-global-pointer-position display)
+  (multiple-value-bind (x y) (xlib:global-pointer-position display)
+    (mk-xpoint x y)))
+
+(define (x-pointer-position window)
+  (multiple-value-bind (x y same) (xlib:pointer-position window)
+    (if same (mk-xpoint x y) '())))
+
+(define (x-motion-events window start stop)
+  (do ((npos '() (cons (mk-xpoint (car pos) (cadr pos)) npos))
+       (pos (xlib:motion-events window :start start :stop stop) 
+	    (cdddr pos)))
+      ((null? pos) (nreverse npos))))
+
+(define (x-warp-pointer dest-win point)
+  (xlib:warp-pointer dest-win (xpoint-x point) (xpoint-y point)))
+
+(define (x-set-input-focus display focus revert-to time)
+  (apply (function xlib:set-input-focus)
+	 `(,display ,focus ,revert-to ,@(if time `(,time) '()))))
+
+(define (x-input-focus display)
+  (multiple-value-bind (focus revert-to) (xlib:input-focus display)
+    (make-h-tuple focus revert-to)))
+
+(define (x-grab-pointer window event-mask attrs time)
+  (apply (function xlib:grab-pointer)
+	 `(,window ,event-mask
+           ,@(attrs->keywords attrs)
+	   ,@(if time `(:time ,time) '()))))
+
+(define (x-ungrab-pointer display time)
+  (if time
+      (xlib:ungrab-pointer display :time time)
+      (xlib:ungrab-pointer display)))
+      
+(define (x-change-active-pointer-grab display event-mask attrs time)
+  (apply (function xlib:change-active-pointer-grab)
+	 `(,display ,event-mask
+           ,@(attrs->keywords attrs)
+	   ,@(if time `(,time) '()))))
+
+(define (x-grab-button window button event-mask state-mask attrs)
+  (apply (function xlib:grab-button)
+	 `(,window ,button ,event-mask :modifiers ,state-mask
+	   ,@(attrs->keywords attrs))))
+
+(define (x-ungrab-button window button modifiers)
+  (xlib:ungrab-button window button :modifiers modifiers))
+
+(define (x-grab-keyboard window attrs time)
+  (apply (function xlib:grab-keyboard)
+	 `(,window ,@(attrs->keywords attrs)
+	   ,@(if time `(:time ,time) '()))))
+
+(define (x-ungrab-keyboard display time)
+  (if time
+      (xlib:ungrab-keyboard display :time time)
+      (xlib:ungrab-keyboard display)))
+      
+(define (x-grab-key window key state-mask attrs)
+  (apply (function xlib:grab-key)
+	 `(,window ,key :modifiers ,state-mask ,@(attrs->keywords attrs))))
+
+(define (x-ungrab-key window key modifiers)
+  (xlib:ungrab-button window key :modifiers modifiers))
+
+(define (x-set-pointer-acceleration display val)
+  (xlib:change-pointer-control display :acceleration val))
+
+(define (x-set-pointer-threshold display val)
+  (xlib:change-pointer-control display :threshold val))
+
+(define (x-pointer-acceleration display)
+  (lisp:coerce (nth-value 0 (xlib:pointer-control display)) 
+	       'lisp:single-float))
+
+(define (x-pointer-threshold display)
+  (lisp:coerce (nth-value 1 (xlib:pointer-control display)) 
+	       'lisp:single-float))
+
+(define-attribute-setter pointer mapping)
+
+(define (x-set-keyboard-key-click-percent display v)
+  (xlib:change-keyboard-control display :key-click-percent v))
+
+(define (x-set-keyboard-bell-percent display v)
+  (xlib:change-keyboard-control display :bell-percent v))
+
+(define (x-set-keyboard-bell-pitch display v)
+  (xlib:change-keyboard-control display :bell-pitch v))
+
+(define (x-set-keyboard-bell-duration display v)
+  (xlib:change-keyboard-control display :bell-duration v))
+
+
+;;; Yes, leds are really counted from 1 rather than 0.
+
+(define (x-set-keyboard-led display v)
+  (declare (type integer v))
+  (do ((led 1 (1+ led))
+       (vv v (lisp:ash vv -1)))
+      ((> led 32))
+      (declare (type fixnum led) (type integer vv))
+      (xlib:change-keyboard-control display
+        :led led
+	:led-mode (if (lisp:logand vv 1) :on :off))))
+
+(define (x-set-keyboard-auto-repeat-mode display v)
+  (do ((key 0 (1+ key)))
+      ((>= key (lisp:length v)))
+      (declare (type fixnum key))
+      (xlib:change-keyboard-control display
+        :key key
+	:auto-repeat-mode (if (eqv? (the fixnum (lisp:aref v key)) 1) :on :off)
+	)))
+
+(define (x-keyboard-key-click-percent display)
+  (nth-value 0 (xlib:keyboard-control display)))
+
+(define (x-keyboard-bell-percent display)
+  (nth-value 1 (xlib:keyboard-control display)))
+
+(define (x-keyboard-bell-pitch display)
+  (nth-value 2 (xlib:keyboard-control display)))
+
+(define (x-keyboard-bell-duration display)
+  (nth-value 3 (xlib:keyboard-control display)))
+
+(define (x-keyboard-led display)
+  (nth-value 4 (xlib:keyboard-control display)))
+
+(define (x-keyboard-auto-repeat-mode display)
+  (nth-value 6 (xlib:keyboard-control display)))
+
+(define (x-modifier-mapping display)
+  (lisp:multiple-value-list (xlib:modifier-mapping display)))
+
+(define (x-set-modifier-mapping display l)
+  (let ((l1 (cddddr l)))
+    (xlib:set-modifier-mapping display 
+			       :shift (car l)
+			       :lock (cadr l)
+			       :control (caddr l)
+			       :mod1 (cadddr l)
+			       :mod2 (car l1)
+			       :mod3 (cadr l1)
+			       :mod4 (caddr l1)
+			       :mod5 (cadddr l1))))
+
+(define (x-keysym-character display keysym state)
+  (let ((res (xlib:keysym->character display keysym state)))
+    (if (char? res) (char->integer res) '())))
+
+(define (x-keycode-character display keycode state)
+  (let ((res (xlib:keycode->character display keycode state)))
+    (if (char? res) (char->integer res) '())))
+
+(define-attribute-setter close-down mode)
+
+(define-attribute-setter access control)
+
+(define (x-screen-saver display)
+  (lisp:multiple-value-list (xlib:screen-saver display)))
+
+(define (x-set-screen-saver display ss)
+  (xlib:set-screen-saver display (car ss) (cadr ss) (caddr ss) (cadddr ss)))
+
+(define (slots->keywords slots)
+  (if (null slots) '()
+      `(,@(slot->keyword (car slots)) ,@(slots->keywords (cdr slots)))))
+
+(define (slot->keyword slot)
+  (let* ((tag (keyword-key slot))
+	 (val (keyword-val slot)))
+    (case tag
+      (:pos `(:x ,(xpoint-x val) :y ,(xpoint-y val)))
+      (:root-pos `(:root-x ,(xpoint-x val) :root-y ,(xpoint-y val)))
+      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
+      (:rect `(:x ,(xrect-x val) :y ,(xrect-y val)
+	       :width ,(xrect-w val) :height ,(xrect-h val)))
+      (:graph-fun `(:major ,(car val) :minor ,(cdr val)))
+      (:visibility `(:state ,val))
+      (:property-state `(:state ,val))
+      (:message `(:data ,(car val) :type ,(cadr val) :format ,(caddr val)))
+      (else `(,tag ,val)))))
+
+(define (keywords->slots type keywords event)
+  (let* ((slots (keywords->slots1 type keywords))
+	 (has-root-xy (memq type '(:key-press :key-release :button-press 
+					      :button-release :motion-notify 
+					      :enter-notify :leave-notify)))
+	 (has-xy (or has-root-xy 
+		     (memq type '(:gravity-notify :reparent-notify))))
+	 (has-graph-fun (memq type '(:graphics-exposure :no-exposure)))
+	 (has-rect (memq type '(:exposure :graphics-exposure 
+					  :configure-notify
+					  :create-notify :configure-request)))
+	 (has-size (memq type '(:resize-request)))
+	 (has-message (memq type '(:client-message))))
+    (when has-xy
+      (push (make-keyword :pos (x-event-pos event)) slots))
+    (when has-root-xy
+      (push (make-keyword :root-pos (x-event-root-pos event))	slots))
+    (when has-graph-fun
+      (push (make-keyword :graph-fun (x-event-graph-fun event)) slots))
+    (when has-rect
+      (push (make-keyword :rect (x-event-rect event))	slots))
+    (when has-size
+      (push (make-keyword :size (x-event-size event))	slots))
+    (when has-message
+      (push (make-keyword :message (x-event-message event)) slots))
+    slots))
+      
+(define (keywords->slots1 type keywords)
+  (if (null? keywords)
+      '()
+      (if (memq (car keywords) 
+		'(:x :y :width :height :root-x :root-y 
+		     :major :minor :type :data :format))
+	  (keywords->slots1 type (cddr keywords))
+	  (cons (keyword->slot type (car keywords) (cadr keywords))
+		(keywords->slots1 type (cddr keywords))))))
+
+(define (keyword->slot type slot val)
+  (if (eq? slot :state)
+      (case type
+	(:property-state (make-keyword :property-state val))
+	(:visibility (make-keyword :visibility val))
+	(else (make-keyword :state val)))
+      (make-keyword slot val)))
+		 
+(define (attrs->keywords attrs)
+  (if (null attrs)
+      '()
+      (nconc (attr->keyword (car attrs))
+	     (attrs->keywords (cdr attrs)))))
+
+(define (attr->keyword attr)
+  (let* ((tag (keyword-key attr))
+	 (val (keyword-val attr)))
+    (case tag
+      (:clip-origin `(:clip-x ,(xpoint-x val) :clip-y ,(xpoint-y val)))
+      (:dashes `(,tag ,(haskell-list->list/identity val)))
+      (:tile-origin `(:ts-x ,(xpoint-x val) :ts-y ,(xpoint-y val)))
+      (:size `(:width ,(xsize-w val) :height ,(xsize-h val)))
+      (:name `(:name ,(haskell-string->string val)))
+      (:hot-spot `(:x-hot ,(xpoint-x val) :y-hot ,(xpoint-y val)))
+      (else `(,tag ,val)))))
+
+(define (x-mutable-array-create inits)
+  (list->vector inits))
+
+(define (x-mutable-array-lookup a i)
+  (vector-ref a i))
+
+(define (x-mutable-array-update a i x)
+  (setf (vector-ref a i) x))
+
+(define (x-mutable-array-length a)
+  (vector-length a))
+
+(define (get-time-zone)
+  (nth-value 8 (lisp:get-decoded-time)))
+
+(define (decode-time time zone)
+  (multiple-value-bind (sec min hour date mon year week ds-p)
+		       (if zone
+			   (lisp:decode-universal-time time zone)
+			   (lisp:decode-universal-time time))   
+    (make-h-tuple
+      (list->haskell-list/identity (list sec min hour date mon year week))
+      ds-p)))
+
+(define (encode-time time zone)
+  (apply (function lisp:encode-universal-time)
+	 (if (null? zone) time (append time (list zone)))))
+
+(define (get-run-time)
+  (/ (lisp:coerce (lisp:get-internal-run-time) 'lisp:single-float)
+     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))
+
+(define (get-elapsed-time)
+  (/ (lisp:coerce (lisp:get-internal-real-time) 'lisp:single-float)
+     (lisp:coerce lisp:internal-time-units-per-second 'lisp:single-float)))
+
+(define (prim.thenio---1 x fn)
+  (lambda (state)
+    (declare (ignore state))
+    (let ((res (funcall x (box 'state))))
+      (format '#t "~A~%" res)
+      (funcall fn res (box 'state)))))
+
+(define-attribute-setter wm name)
+(define-attribute-setter wm icon-name)
diff --git a/progs/lib/X11/xlibprims.hi b/progs/lib/X11/xlibprims.hi
new file mode 100644
index 0000000..02d4163
--- /dev/null
+++ b/progs/lib/X11/xlibprims.hi
@@ -0,0 +1,1465 @@
+-- 4/13/93 add xTestEventMask, xTestStateMask
+-- 4/14/93 add xMArrayLength,
+--             xGetEventN
+-- 4/15/93 change xKeycodeCharacter
+--         add xKeysymCharacter
+--         add xHandleError
+--         add xError
+-- 4/27/93 Change Bool to XSwitch in XWinAttribute, XGCAttribute
+
+interface XLibPrims where
+
+import XLibTypes(
+                 XDisplay, XScreen, XWindow, XGcontext, XPixmap,
+                 XColormap, XCursor, XFont, XImage, XMaybe, XError,
+                 XBitmap, XKeysymTable, XBitVec,
+                 XPixarray, XByteVec, XAtom, XProperty,
+                 XPixel, XDrawable, XTime, XSwitch,
+		 XWindowPlace, XEventMode, XEventKind,
+		 XWindowVisibility, XWindowStackMode,
+		 XPropertyState, XMapReqType, XGraphFun,
+		 XEvent, XEventType, XEventSlot, XEventMask,
+		 XEventMaskKey, XStateMask, XStateMaskKey,
+		 XWinAttribute,XGCAttribute, XImAttribute, 
+		 XGrabAttribute, XArcMode, XCapStyle,
+		 XClipMask, XFillRule, XFillStyle, 
+		 XFunction, XJoinStyle, XLineStyle,
+		 XSubwindowMode, XPoint, XSize, XRect,
+		 XArc, XBitmapFormat, XByteOrder,
+		 XPixmapFormat, XVisualInfo, XVisualClass,
+		 XFillContent, XBackingStore, XGravity,
+		 XWindowClass, XMapState, XImageData, 
+		 XImageFormat, XImageType, XDrawDirection,
+		 XColor, XInputFocus, XGrabStatus,
+		 XKeysym, XCloseDownMode, XScreenSaver)
+
+xHandleError		:: (XError -> IO a) -> IO a -> IO a
+xError			:: String -> IO a
+
+xEventType		:: XEvent -> XEventType
+xEventWindow 		:: XEvent -> XWindow
+xEventEventWindow	:: XEvent -> XWindow
+xEventCode		:: XEvent -> Int
+xEventPos		:: XEvent -> XPoint
+xEventState		:: XEvent -> XStateMask
+xEventTime		:: XEvent -> XTime
+xEventRoot		:: XEvent -> XWindow
+xEventRootPos		:: XEvent -> XPoint
+xEventChild		:: XEvent -> (XMaybe XWindow)
+xEventSameScreenP	:: XEvent -> Bool
+xEventHintP		:: XEvent -> Bool
+xEventMode		:: XEvent -> XEventMode
+xEventKind		:: XEvent -> XEventKind
+xEventFocusP		:: XEvent -> Bool
+xEventKeymap		:: XEvent -> XBitVec
+xEventRequest		:: XEvent -> XMapReqType
+xEventStart		:: XEvent -> Int
+xEventCount		:: XEvent -> Int
+xEventRect		:: XEvent -> XRect
+xEventDrawable		:: XEvent -> XDrawable
+xEventXGraphFun		:: XEvent -> XGraphFun
+xEventPlace		:: XEvent -> XWindowPlace
+xEventBorderWidth	:: XEvent -> Int
+xEventAboveSibling	:: XEvent -> (XMaybe XWindow)
+xEventOverrideRedirectP	:: XEvent -> Bool
+xEventParent		:: XEvent -> XWindow
+xEventConfigureP	:: XEvent -> Bool
+xEventVisibility	:: XEvent -> XWindowVisibility
+xEventNewP		:: XEvent -> Bool
+xEventInstalledP	:: XEvent -> Bool
+xEventStackMode		:: XEvent -> XWindowStackMode
+xEventValueMask		:: XEvent -> Int
+xEventSize		:: XEvent -> XSize
+xEventMessage		:: XEvent -> XProperty
+xEventPropertyState	:: XEvent -> XPropertyState
+xEventAtom		:: XEvent -> XAtom
+xEventSelection		:: XEvent -> XAtom
+xEventTarget		:: XEvent -> XAtom
+xEventProperty		:: XEvent -> (XMaybe XAtom)
+xEventRequestor		:: XEvent -> XWindow
+
+xSetEventMaskKey 	:: XEventMask -> XEventMaskKey -> XEventMask
+xClearEventMaskKey 	:: XEventMask -> XEventMaskKey -> XEventMask
+xTestEventMaskKey 	:: XEventMask -> XEventMaskKey -> Bool
+
+xSetStateMaskKey 	:: XStateMask -> XStateMaskKey -> XStateMask
+xClearStateMaskKey 	:: XStateMask -> XStateMaskKey -> XStateMask
+xTestStateMaskKey 	:: XStateMask -> XStateMaskKey -> Bool
+
+
+-- DISPLAYS
+
+-- open
+
+xOpenDisplay 			:: String 		-- host:display
+				-> IO XDisplay
+
+-- display attributes
+
+xDisplayAuthorizationData	:: XDisplay -> String
+xDisplayAuthorizationName	:: XDisplay -> String
+xDisplayBitmapFormat		:: XDisplay -> XBitmapFormat
+xDisplayByteOrder		:: XDisplay -> XByteOrder
+xDisplayDisplay 		:: XDisplay -> Int
+xSetDisplayErrorHandler		:: XDisplay -> (XError -> IO ()) -> IO () 
+xDisplayImageLsbFirstP		:: XDisplay -> Bool
+xDisplayMaxKeycode		:: XDisplay -> Int
+xDisplayMaxRequestLength	:: XDisplay -> Int
+xDisplayMinKeycode		:: XDisplay -> Int
+xDisplayMotionBufferSize	:: XDisplay -> Int
+xDisplayPixmapFormats		:: XDisplay -> [XPixmapFormat]
+xDisplayProtocolMajorVersion	:: XDisplay -> Int
+xDisplayProtocolMinorVersion	:: XDisplay -> Int
+xDisplayResourceIdBase		:: XDisplay -> Int
+xDisplayResourceIdMask		:: XDisplay -> Int 
+xDisplayRoots 			:: XDisplay -> [XScreen] 
+xDisplayVendorName		:: XDisplay -> String 
+xDisplayReleaseNumber		:: XDisplay -> Int
+
+-- output buffer
+
+xDisplayAfterFunction		:: XDisplay -> XMaybe (IO ())
+xSetDisplayAfterFunction 	:: XDisplay -> XMaybe (IO ()) -> IO ()
+xDisplayForceOutput 		:: XDisplay -> IO ()
+xDisplayFinishOutput		:: XDisplay -> IO ()
+
+-- close
+
+xCloseDisplay 			:: XDisplay -> IO ()
+
+-- SCREENS
+
+xScreenBackingStores		:: XScreen -> XBackingStore
+xScreenBlackPixel		:: XScreen -> XPixel
+xScreenDefaultColormap		:: XScreen -> XColormap
+xScreenDepths			:: XScreen -> [(Int, [XVisualInfo])]
+xScreenEventMaskAtOpen		:: XScreen -> XEventMask
+xScreenSize			:: XScreen -> XSize 
+xScreenMMSize 			:: XScreen -> XSize 
+xScreenMaxInstalledMaps		:: XScreen -> Int 
+xScreenMinInstalledMaps		:: XScreen -> Int 
+xScreenRoot			:: XScreen -> XWindow 
+xScreenRootDepth		:: XScreen -> Int
+xScreenRootVisual		:: XScreen -> Int
+xScreenSaveUndersP		:: XScreen -> Bool 
+xScreenWhitePixel		:: XScreen -> XPixel
+
+-- WINDOWS AND PIXMAPS
+
+-- drawables
+
+xDrawableDisplay	:: XDrawable -> XDisplay
+xDrawableEqual		:: XDrawable -> XDrawable -> Bool
+xDrawableId		:: XDrawable -> Int
+
+-- creating windows
+
+xCreateWindow 		:: XWindow 		-- parent
+			-> XRect		-- (x,y,width,height)
+			-> [XWinAttribute] 	-- optional arguments
+			-> IO XWindow
+
+-- window attributes
+
+xWindowBorderWidth 	:: XWindow -> IO Int 
+xSetWindowBorderWidth 	:: XWindow -> Int -> IO ()
+
+xDrawableDepth		:: XDrawable -> Int
+
+xDrawableSize 		:: XDrawable -> IO XSize 
+xDrawableResize 	:: XDrawable -> XSize -> IO ()
+
+xWindowPos 		:: XWindow -> IO XPoint 
+xWindowMove 		:: XWindow -> XPoint -> IO ()
+
+xWindowAllEventMasks	:: XWindow -> IO XEventMask
+xSetWindowBackground 	:: XWindow -> XFillContent -> IO ()
+
+xWindowBackingPixel 	:: XWindow -> IO XPixel 
+xSetWindowBackingPixel 	:: XWindow -> XPixel -> IO ()
+
+xWindowBackingPlanes 	:: XWindow -> IO XPixel 
+xSetWindowBackingPlanes	:: XWindow -> XPixel -> IO ()
+
+xWindowBackingStore 	:: XWindow -> IO XBackingStore
+xSetWindowBackingStore 	:: XWindow -> XBackingStore -> IO ()
+
+xWindowBitGravity	:: XWindow -> IO XGravity
+xSetWindowBitGravity	:: XWindow -> XGravity -> IO ()
+
+xSetWindowBorder 	:: XWindow -> XFillContent -> IO ()
+
+xWindowClass 		:: XWindow -> XWindowClass 
+
+xWindowColorMap 	:: XWindow -> IO (XMaybe XColormap)
+xSetWindowColorMap 	:: XWindow -> XColormap -> IO ()
+xWindowColormapInstalledP :: XWindow -> IO Bool
+
+xSetWindowCursor 	:: XWindow -> (XMaybe XCursor) -> IO () 
+
+xWindowDisplay 		:: XWindow -> XDisplay
+
+xWindowDoNotPropagateMask	:: XWindow -> IO XEventMask
+xSetWindowDoNotPropagateMask	:: XWindow -> XEventMask -> IO ()
+
+xWindowEqual		:: XWindow -> XWindow -> Bool
+
+xWindowEventMask	:: XWindow -> IO XEventMask
+xSetWindowEventMask	:: XWindow -> XEventMask -> IO ()
+
+xWindowGravity		:: XWindow -> IO XGravity
+xSetWindowGravity	:: XWindow -> XGravity -> IO ()
+
+xWindowId		:: XWindow -> Int
+
+xWindowMapState		:: XWindow -> IO XMapState
+
+xWindowOverrideRedirect		:: XWindow -> IO XSwitch
+xSetWindowOverrideRedirect	:: XWindow -> XSwitch -> IO ()
+
+xSetWindowPriority	:: XWindow -> XWindowStackMode -> IO ()
+
+xWindowSaveUnder	:: XWindow -> IO XSwitch
+xSetWindowSaveUnder	:: XWindow -> XSwitch -> IO ()
+
+xWindowVisual		:: XWindow -> Int
+
+-- stacking order
+
+xCirculateWindowDown	:: XWindow -> IO () 
+xCirculateWindowUp	:: XWindow -> IO ()
+
+-- window hierarchy
+
+xDrawableRoot		:: XDrawable -> IO XWindow
+xQueryTree		:: XWindow -> IO ([XWindow], 	-- children
+				         XMaybe XWindow,-- parent
+				         XWindow) 	-- root
+
+xReparentWindow		:: XWindow 			-- window
+			-> XWindow 			-- parent
+			-> XPoint 			-- (x,y)
+			-> IO ()
+
+xTranslateCoordinates	:: XWindow 			-- source
+			-> XPoint 			-- (source-x,source-y)
+			-> XWindow 			-- destination
+			-> IO (XMaybe XPoint)		-- (dest-x,dest-y)
+
+-- mapping windows
+
+xMapWindow 		:: XWindow -> IO () 
+xMapSubwindows 		:: XWindow -> IO ()
+xUnmapWindow		:: XWindow -> IO () 
+xUnmapSubwindows	:: XWindow -> IO ()
+
+-- destroying windows
+
+xDestroyWindow		:: XWindow -> IO () 
+xDestroySubwindows	:: XWindow -> IO ()
+
+-- pixmaps
+
+xCreatePixmap 		:: XSize 			-- (width,height)
+			-> Int 				-- depth
+			-> XDrawable 			-- drawable
+			-> IO XPixmap 
+
+xFreePixmap 		:: XPixmap -> IO ()
+
+xPixmapDisplay		:: XPixmap -> XDisplay
+xPixmapEqual		:: XPixmap -> XPixmap -> Bool
+
+-- GRAPHICS CONTEXTS
+
+xCreateGcontext		:: XDrawable 			-- drawable
+			-> [XGCAttribute] 		-- optional arguments
+			-> IO XGcontext
+
+xUpdateGcontext 	:: XGcontext 			-- old gcontext
+			-> [XGCAttribute] 		-- changes
+			-> IO ()			-- new gcontext
+
+xFreeGcontext		:: XGcontext -> IO ()
+
+xGcontextDisplay	:: XGcontext -> XDisplay
+xGcontextEqual		:: XGcontext -> XGcontext -> Bool
+
+xGcontextId		:: XGcontext -> Int
+
+xQueryBestStipple	:: XSize -> XDrawable -> XSize
+xQueryBestTile		:: XSize -> XDrawable -> XSize
+
+xCopyGcontext		:: XGcontext 			-- source
+			-> XGcontext			-- destination
+			-> IO ()
+
+-- GRAPHICS OPERATIONS
+
+xClearArea 		:: XWindow 			-- window
+			-> XRect 			-- (x,y,width,height)
+			-> Bool 			-- exposure-p
+			-> IO ()
+
+xCopyArea		:: XDrawable 			-- source
+			-> XGcontext 			-- gcontext
+			-> XRect 			-- (src-x,src-y,w,h)
+			-> XDrawable			-- destination
+			-> XPoint 			-- (dest-x,dest-y)
+			-> IO ()
+
+xCopyPlane		:: XDrawable 			-- source
+			-> XGcontext 			-- gcontext
+			-> XPixel 			-- plane
+			-> XRect			-- (src-x,src-y,w,h)
+                        -> XDrawable 			-- destination
+			-> XPoint 			-- (dest-x,dest-y)
+			-> IO ()
+
+xDrawPoint		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x,y)
+			-> IO ()
+
+xDrawPoints		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> [XPoint]			-- points
+			-> IO ()
+
+xDrawLine 		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x1,y1)
+			-> XPoint 			-- (x2,y2)
+			-> IO ()
+
+xDrawLines 		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> [XPoint] 			-- points
+			-> Bool 			-- fill-p
+			-> IO ()
+
+xDrawSegments		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> [(XPoint,XPoint)]		-- segments
+			-> IO ()
+
+xDrawRectangle 		:: XDrawable 			-- drawable
+			-> XGcontext			-- gcontext
+			-> XRect 			-- (x,y,width,height)
+			-> Bool 			-- fill-p
+			-> IO ()
+
+xDrawRectangles 	:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> [XRect] 			-- rectangles
+			-> Bool 			-- fill-p
+			-> IO ()
+
+xDrawArc		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XArc 			-- (x,y,w,h,a1,a2)
+			-> Bool 			-- fill-p
+			-> IO ()
+
+xDrawArcs		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> [XArc] 			-- arcs
+			-> Bool 			-- fill-p
+			-> IO ()
+
+xDrawGlyph		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x,y)
+			-> Char 			-- element
+			-> IO (XMaybe Int)		-- width
+
+xDrawGlyphs		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x,y)
+			-> String			-- sequence
+			-> IO (XMaybe Int)		-- width
+
+xDrawImageGlyph		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x,y)
+			-> Char 			-- element
+			-> IO (XMaybe Int)		-- width
+
+xDrawImageGlyphs	:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XPoint 			-- (x,y)
+			-> String 			-- sequence
+			-> IO (XMaybe Int)		-- width
+
+-- IMAGES
+
+xImageBlueMask		:: XImage -> XMaybe XPixel 
+xImageDepth 		:: XImage -> Int 
+xImageGreenMask		:: XImage -> XMaybe XPixel
+xImageSize		:: XImage -> XSize 
+xImageName		:: XImage -> String 
+xSetImageName		:: XImage -> String -> IO () 
+xImageRedMask		:: XImage -> XMaybe XPixel
+xImageHotSpot		:: XImage -> XMaybe XPoint
+xSetImageHotSpot	:: XImage -> XPoint -> IO ()
+
+-- XY-format images
+
+xImageXYBitmaps		:: XImage -> IO [XBitmap]
+xSetImageXYBitmaps	:: XImage -> [XBitmap] -> IO ()
+
+-- Z-format images
+
+xImageZBitsPerPixel	:: XImage -> IO Int
+xsetImageZBitsPerPixel	:: XImage -> Int -> IO ()
+xImageZPixarray		:: XImage -> IO XPixarray
+xSetImageZPixarray	:: XImage -> XPixarray -> IO ()
+
+-- image functions
+
+xCreateImage		:: [XImAttribute] -> IO XImage
+xCopyImage		:: XImage 			-- image
+			-> XRect 			-- (x,y,width,height)
+			-> XImageType 			-- result-type
+			-> XImage			-- new-image
+
+xGetImage		:: XDrawable 			-- drawable
+			-> XRect 			-- (x,y,width,height)
+			-> XPixel 			-- plane-mask
+			-> XImageFormat 		-- format
+			-> XImageType 			-- result-type
+			-> IO XImage			-- image
+
+xPutImage		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XImage 			-- ximage
+			-> XPoint 			-- (src-x,src-y)
+			-> XRect			-- (x,y,width,height)
+                        -> IO ()
+
+-- image files
+
+xReadBitmapFile		:: String 			-- pathname
+			-> IO XImage 
+
+xWriteBitmapFile	:: String 			-- pathname
+			-> XImage -> IO ()
+
+-- direct image transfer
+
+xGetRawImage		:: XDrawable 			-- drawable
+			-> XRect 			-- (x,y,width,height)
+			-> XPixel 			-- plane-mask
+			-> XImageFormat 		-- format
+			-> IO XImageData		-- data
+
+xPutRawImage		:: XDrawable 			-- drawable
+			-> XGcontext 			-- gcontext
+			-> XImageData 			-- data
+			-> Int 				-- depth
+			-> XRect			-- (x,y,width,height)
+			-> Int 				-- left-pad
+			-> XImageFormat 		-- format
+			-> IO ()
+
+-- FONTS
+
+-- opening fonts
+
+xOpenFont		:: XDisplay -> String -> IO XFont
+xCloseFont		:: XFont -> IO () 
+xDiscardFontInfo	:: XFont -> IO ()
+
+-- listing fonts
+
+xFontPath		:: XDisplay -> IO [String]
+xListFontNames		:: XDisplay -> String 		-- pattern
+			-> IO [String] 
+xListFonts		:: XDisplay -> String 		-- pattern
+			-> IO [XFont]
+
+-- font attriburtes
+
+xFontAllCharExistsP	:: XFont -> Bool 
+xFontAscent		:: XFont -> Int 
+xFontDefaultChar	:: XFont -> Int
+xFontDescent		:: XFont -> Int 
+xFontDirection		:: XFont -> XDrawDirection 
+xFontDisplay		:: XFont -> XDisplay
+xFontEqual		:: XFont -> XFont -> Int
+xFontId			:: XFont -> Int
+
+xFontMaxByte1		:: XFont -> Int 
+xFontMaxByte2		:: XFont -> Int 
+xFontMaxChar		:: XFont -> Int
+xFontMinByte1		:: XFont -> Int 
+xFontMinByte2		:: XFont -> Int 
+xFontMinChar		:: XFont -> Int
+
+xFontName		:: XFont -> String
+
+xFontMaxCharAscent	:: XFont -> Int 
+xFontMaxCharAttributes	:: XFont -> Int 
+xFontMaxCharDescent	:: XFont -> Int
+xFontMaxCharLeftBearing	:: XFont -> Int
+xFontMaxCharRightBearing	:: XFont -> Int
+xFontMaxCharWidth	:: XFont -> Int 
+xFontMinCharAscent	:: XFont -> Int 
+xFontMinCharAttributes	:: XFont -> Int
+xFontMinCharDescent	:: XFont -> Int 
+xFontMinCharLeftBearing	:: XFont -> Int 
+xFontMinCharRightBearing	:: XFont -> Int
+xFontMinCharWidth	:: XFont -> Int
+
+-- char attributes
+
+xCharAscent		:: XFont -> Int -> XMaybe Int
+xCharAttributes		:: XFont -> Int -> XMaybe Int
+xCharDescent		:: XFont -> Int -> XMaybe Int
+xCharLeftBearing	:: XFont -> Int -> XMaybe Int
+xCharRightBearing	:: XFont -> Int -> XMaybe Int
+xCharWidth		:: XFont -> Int -> XMaybe Int
+
+-- querying text size
+
+xTextWidth		:: XFont 			-- font
+			-> String 			-- sequence
+			-> Int				-- width
+
+-- COLORS
+
+-- creating colormaps
+
+xCreateColormap		:: XVisualInfo 			-- visual
+			-> XWindow 			-- window
+			-> Bool 			-- alloc-p
+			-> IO XColormap
+
+xCopyColormapAndFree	:: XColormap -> IO XColormap
+xFreeColormap		:: XColormap -> IO ()
+
+-- installing colormaps
+
+xInstallColormap	:: XColormap -> IO ()
+xInstalledColormaps	:: XWindow -> IO [XColormap]
+xUnInstallColormap	:: XColormap -> IO ()
+
+-- allocating colors
+
+xAllocColor		:: XColormap -> XColor
+			-> IO (XPixel, 			-- pixel
+			       XColor, 			-- screen-color
+			       XColor)			-- exact-color
+
+xAllocColorCells	:: XColormap 			-- pixel
+			-> Int 				-- colors
+			-> Int 				-- planes
+			-> Bool 			-- contiguous
+			-> IO ([XPixel], 		-- pixels
+			       [XPixel])		-- mask
+
+xAllocColorPlanes	:: XColormap 			-- colormap
+			-> Int 				-- colors
+			-> Int 				-- reds
+			-> Int 				-- greens
+			-> Int 				-- blues
+			-> Bool 			-- contiguous-p
+			-> IO ([XPixel], 		-- pixel
+			       XPixel, 			-- red-mask
+			       XPixel, 			-- green-mask
+			       XPixel)			-- blue-mask
+
+xFreeColors		:: XColormap -> [XPixel] 	-- pixels
+			-> XPixel 			-- plane-mask
+			-> IO ()
+
+-- finding colors
+
+xLookupColor		:: XColormap -> String 		-- name
+			-> IO (XColor, 			-- screen-color
+			       XColor)			-- exact-color
+
+xQueryColors		:: XColormap -> [XPixel] 	-- pixels
+			-> IO [XColor]
+
+-- changing colors
+
+xStoreColor		:: XColormap -> XPixel 		-- pixel
+			-> XColor 			-- color
+			-> IO ()
+
+xStoreColors		:: XColormap 			-- colormap
+			-> [(XPixel, XColor)] 		-- pixel-colors
+			-> IO ()
+
+-- colormap attributes
+
+xColormapDisplay	:: XColormap -> XDisplay
+xColormapEqual		:: XColormap -> XColormap -> Bool
+
+-- CURSORS
+
+xCreateCursor		:: XPixmap 			-- source
+			-> (XMaybe XPixmap) 		-- mask
+			-> XPoint 			-- (x,y)
+			-> XColor 			-- foreground
+			-> XColor 			-- background
+			-> IO XCursor
+
+xCreateGlyphCursor	:: (XFont, char) 		-- (src-font,src-char)
+			-> (XMaybe (XFont, Char)) 	-- (mask-font,mask-char)
+			-> XColor			-- foreground
+			-> XColor 			-- background
+			-> IO XCursor
+
+xFreeCursor		:: XCursor -> IO ()
+
+xQueryBestCursor	:: XSize 			-- (width,height)
+			-> XDisplay -> IO XSize
+
+xRecolorCursor		:: XCursor -> XColor 		-- foreground
+			-> XColor 			-- background
+			-> IO ()
+
+xCursorDisplay		:: XCursor -> XDisplay
+xCursorEqual		:: XCursor -> XCursor -> Bool
+
+-- ATOMS, PROPERTIES, AND SELECTIONS
+
+-- atoms
+
+xAtomName		:: XDisplay -> Int 		-- atom-id
+			-> XAtom
+
+xFindAtom		:: XDisplay -> XAtom 		-- atom-name
+			-> IO (XMaybe Int)
+
+xInternAtom		:: XDisplay -> XAtom 		-- atom-name
+			-> IO (XMaybe Int)
+
+-- properties
+
+xChangeProperty		:: XWindow 			-- window
+			-> XAtom 			-- property
+			-> XProperty 			-- (data,type,format)
+			-> IO ()
+
+xDeleteProperty		:: XWindow -> XAtom -> IO ()
+xGetProperty		:: XWindow			-- window
+			-> XAtom 			-- property
+			-> IO XProperty			-- (data,type,format)
+
+xListProperties		:: XWindow -> IO [XAtom]
+xRotateProperties	:: XWindow 			-- window
+			-> [XAtom] 			-- properties
+			-> Int 				-- delta
+			-> IO ()
+
+-- selections
+
+xConvertSelection	:: XAtom 			-- selection
+			-> XAtom 			-- type
+			-> XWindow 			-- requester
+			-> XAtom			-- property
+			-> (XMaybe XTime) 		-- time
+			-> IO ()
+
+xSelectionOwner		:: XDisplay 			-- display
+			-> XAtom 			-- selection
+			-> IO (XMaybe XWindow)
+
+xSetSelectionOwner	:: XDisplay 			-- display
+			-> XAtom 			-- selection
+			-> (XMaybe XTime) 		-- time
+			-> XWindow 			-- owner
+			-> IO ()
+
+-- EVENT
+
+-- Wait for the next event 
+
+xGetEvent		:: XDisplay -> IO XEvent
+
+-- managing the event queue 
+
+xQueueEvent		:: XDisplay -> XEvent -> Bool	-- append-p
+			-> IO ()
+
+xEventListen		:: XDisplay -> IO Int 		-- # of events in queue
+
+-- sending events 
+
+xSendEvent		:: XWindow 			-- window
+			-> XEvent 			-- event key and slots
+			-> XEventMask 			-- event-mask
+			-> IO ()
+
+-- pointer position
+
+xGlobalPointerPosition	:: XDisplay -> IO XPoint
+xPointerPosition	:: XWindow -> IO (XMaybe XPoint)
+xMotionEvents		:: XWindow -> XTime -> XTime -> IO [XPoint]
+xWarpPointer		:: XWindow -> XPoint -> IO ()
+
+-- keyboard input focus
+
+xSetInputFocus		:: XDisplay 			-- display
+			-> XInputFocus 			-- focus
+			-> XInputFocus			-- revert-to
+			-> (XMaybe XTime) 		-- time
+			-> IO ()
+
+xInputFucus		:: XDisplay -> IO (XInputFocus,	-- focus
+					   XInputFocus)	-- revert-to
+
+-- grabbing the pointer
+
+xGrabPointer		:: XWindow 			-- window
+			-> XEventMask			-- event-mask
+			-> [XGrabAttribute] 		-- optional attributes
+			-> XMaybe XTime 		-- time
+			-> IO XGrabStatus
+
+xUngrabPointer		:: XDisplay -> XMaybe XTime -> IO ()
+
+xChangeActivePointerGrab :: XDisplay -> XEventMask 	-- event-mask
+			 -> [XGrabAttribute] 		-- cursor
+			 -> XMaybe XTime -> IO ()
+
+-- grabbing a button
+
+xGrabButton		:: XWindow 			-- window
+			-> Int 				-- button
+			-> XEventMask 			-- event-mask
+			-> XStateMask 			-- modifiers
+			-> [XGrabAttribute]		-- optional attributes
+			-> IO ()
+
+xUngrabButton		:: XWindow -> Int 		-- button
+			-> XStateMask 			-- modifiers
+			-> IO ()
+
+-- grabbing the keyboard
+
+xGrabKeyboard		:: XWindow 			-- window
+			-> [XGrabAttribute] 		-- optional attributes
+			-> XMaybe XTime			-- time
+			-> IO XGrabStatus
+
+xUngrabkeyboard		:: XDisplay -> XMaybe XTime -> IO ()
+
+-- grabbing a key
+
+xGrabKey		:: XWindow 			-- window
+			-> Int 				-- key
+			-> XStateMask			-- modifiers
+			-> [XGrabAttribute] 		-- optional attributes
+			-> IO ()
+
+xUngrabKey		:: XWindow -> Int -> XStateMask -- modifiers
+			-> IO ()
+
+-- CONTROL FUNCTIONS
+
+-- grabbing the server
+
+xGrabServer		:: XDisplay -> IO ()
+xUngrabServer		:: XDisplay -> IO ()
+
+-- pointer control
+
+xSetPointerAcceleration	:: XDisplay -> Float -> IO ()
+xSetPointerThreshold	:: XDisplay -> Float -> IO ()
+xPointerAcceleration	:: XDisplay -> IO Float
+xPointerThreshold	:: XDisplay -> IO Float 
+xSetPointerMapping	:: XDisplay -> [Int] -> IO ()
+xPointerMapping		:: XDisplay -> IO [Int]
+
+-- keyboard control
+
+xBell			:: XDisplay -> Int -> IO ()
+
+xSetKeyboardKeyClickPercent	:: XDisplay -> Int -> IO ()
+xSetKeyboardBellPercent		:: XDisplay -> Int -> IO ()
+xSetKeyboardBellPitch		:: XDisplay -> Int -> IO ()
+xSetKeyboardBellDuration	:: XDisplay -> Int -> IO ()
+xSetKeyboardLed			:: XDisplay -> Integer -> IO ()
+xSetKeyboardAutoRepeatMode	:: XDisplay -> XBitVec -> IO ()
+
+xKeyboardKeyClickPercent	:: XDisplay -> IO Int
+xKeyboardBellPercent		:: XDisplay -> IO Int
+xKeyboardBellPitch		:: XDisplay -> IO Int
+xKeyboardBellDuration		:: XDisplay -> IO Int
+
+xKeyboardLed			:: XDisplay -> IO Integer
+xKeyboardAutoRepeatMode		:: XDisplay -> IO XBitVec
+
+xModifierMapping		:: XDisplay -> IO [[Int]]
+xSetModifierMapping		:: XDisplay -> [[Int]] -> IO (XMaybe ()) 
+xQueryKeymap			:: XDisplay -> IO XBitVec
+
+-- keyboard mapping
+
+xChangeKeyboardMapping 		:: XDisplay 		-- display
+				-> XKeysymTable 	-- keysyms
+				-> IO ()
+
+xKeyboardMapping		:: XDisplay 		-- display
+				-> IO XKeysymTable	-- mappings
+
+xKeycodeKeysym			:: XDisplay 		-- display
+				-> Int 			-- keycode
+				-> Int 			-- keysym-index
+				-> IO XKeysym
+
+xKeysymCharacter		:: XDisplay 		-- display
+				-> XKeysym               -- keysym
+				-> XStateMask		-- state
+				-> IO (XMaybe Char)
+
+xKeycodeCharacter		:: XDisplay 		-- display
+				-> Int                  -- keycode
+				-> XStateMask		-- state
+				-> IO (XMaybe Char)
+
+-- client termination
+
+xAddToSaveSet		:: XWindow -> IO ()
+xCloseDownMode		:: XDisplay -> IO XCloseDownMode
+xSetCloseDownMode	:: XDisplay -> XCloseDownMode -> IO ()
+xKillClient		:: XDisplay -> Int -> IO ()
+xKillTemporaryClients	:: XDisplay -> IO ()
+xRemoveFromSaveSet	:: XWindow -> IO ()
+
+-- managing host access
+
+xAccessControl		:: XDisplay -> IO Bool
+xSetAccessControl	:: XDisplay -> Bool -> IO ()
+xAccessHosts		:: XDisplay -> IO [String]
+xAddAccessHost		:: XDisplay -> String -> IO ()
+xRemoveAccessHost	:: XDisplay -> String -> IO ()
+
+-- screen saver
+
+xActivateScreenSaver	:: XDisplay -> IO ()
+xResetScreenSaver	:: XDisplay -> IO ()
+
+xScreenSaver		:: XDisplay -> IO XScreenSaver
+xSetScreenSaver		:: XDisplay -> XScreenSaver -> IO ()
+
+{-#
+
+
+xHandleError		:: LispName("x-handle-error")
+xError			:: LispName("xlib::x-error")
+
+xEventType 		:: LispName("sel-event-type")
+
+xEventWindow 		:: LispName ("x-event-window")
+xEventEventWindow	:: LispName ("x-event-event-window")
+xEventCode		:: LispName ("x-event-code")
+xEventPos		:: LispName ("x-event-pos")
+xEventState		:: LispName ("x-event-state")
+xEventTime		:: LispName ("x-event-time")
+xEventRoot		:: LispName ("x-event-root")
+xEventRootPos		:: LispName ("x-event-root-pos")
+xEventChild		:: LispName ("x-event-child")
+xEventSameScreenP	:: LispName ("x-event-same-screen-p")
+xEventHintP		:: LispName ("x-event-hint-p")
+xEventMode		:: LispName ("x-event-mode")
+xEventKind		:: LispName ("x-event-kind")
+xEventFocusP		:: LispName ("x-event-focus-p")
+xEventKeymap		:: LispName ("x-event-keymap")
+xEventRequest		:: LispName ("x-event-request")
+xEventStart		:: LispName ("x-event-start")
+xEventCount		:: LispName ("x-event-count")
+xEventRect		:: LispName ("x-event-rect")
+xEventDrawable		:: LispName ("x-event-drawable")
+xEventXGraphFun		:: LispName ("x-event-graph-fun")
+xEventPlace		:: LispName ("x-event-place")
+xEventBorderWidth	:: LispName ("x-event-border-width")
+xEventAboveSibling	:: LispName ("x-event-above-sibling")
+xEventOverrideRedirectP	:: LispName ("x-event-override-redirect-p")
+xEventParent		:: LispName ("x-event-parent")
+xEventConfigureP	:: LispName ("x-event-configure-p")
+xEventVisibility	:: LispName ("x-event-state")
+xEventNewP		:: LispName ("x-event-new-p")
+xEventInstalledP	:: LispName ("x-event-installed-p")
+xEventStackMode		:: LispName ("x-event-stack-mode")
+xEventValueMask		:: LispName ("x-event-value-mask")
+xEventSize		:: LispName ("x-event-size")
+xEventMessage		:: LispName ("x-event-message")
+xEventPropertyState	:: LispName ("x-event-state")
+xEventAtom		:: LispName ("x-event-atom")
+xEventSelection		:: LispName ("x-event-selection")
+xEventTarget		:: LispName ("x-event-target")
+xEventProperty		:: LispName ("x-event-property")
+xEventRequestor		:: LispName ("x-event-requestor")
+
+
+xSetEventMaskKey 	:: LispName ("x-set-event-mask-key")
+xClearEventMaskKey 	:: LispName ("x-clear-event-mask-key")
+xTestEventMaskKey 	:: LispName ("x-test-event-mask-key")
+
+xSetStateMaskKey 	:: LispName ("x-set-state-mask-key")
+xClearStateMaskKey 	:: LispName ("x-clear-state-mask-key")
+xTestStateMaskKey 	:: LispName ("x-test-state-mask-key")
+
+-- DISPLAYS
+
+-- open
+
+xOpenDisplay      		:: LispName("x-open-display")
+
+-- display attributes
+
+xDisplayAuthorizationData	:: LispName("xlib:display-authorization-data")
+xDisplayAuthorizationName	:: LispName("xlib:display-authorization-name")
+xDisplayBitmapFormat		:: LispName("xlib:display-bitmap-format")
+xDisplayByteOrder		:: LispName("xlib:display-byte-order")
+xDisplayDisplay           	:: LispName("xlib:display-display")
+xSetDisplayErrorHandler		:: LispName("x-set-display-error-handler")
+xDisplayImageLsbFirstP		:: LispName("xlib:display-image-lsb-first-p")
+xDisplayMaxKeycode		:: LispName("xlib:display-max-keycode")
+xDisplayMaxRequestLength	:: LispName("xlib:display-max-request-length")
+xDisplayMinKeycode		:: LispName("xlib:display-min-keycode")
+xDisplayMotionBufferSize	:: LispName("xlib:display-motion-buffer-size")
+xDisplayPixmapFormats		:: LispName("xlib:display-pixmap-formats")
+xDisplayProtocolMajorVersion :: LispName("xlib:display-protocol-major-version")
+xDisplayProtocolMinorVersion :: LispName("xlib:display-protocol-minor-version")
+xDisplayResourceIdBase		:: LispName("xlib:display-resource-id-base")
+xDisplayResourceIdMask		:: LispName("xlib:display-resource-id-mask")
+xDisplayRoots     		:: LispName("xlib:display-roots")
+xDisplayVendorName		:: LispName("xlib:display-vendor-name")
+xDisplayReleaseNumber		:: LispName("xlib:display-release-number")
+
+-- output buffer
+
+xDisplayAfterFunction    	:: LispName("xlib:display-after-function")
+xSetDisplayAfterFunction    	:: LispName("x-set-display-after-function")
+xDisplayForceOutput      	:: LispName("xlib:display-force-output")
+xDisplayFinishOutput      	:: LispName("xlib:display-finish-output")
+
+-- close
+
+xCloseDisplay     		:: LispName("xlib:close-display")
+
+-- SCREENS
+
+xScreenBackingStores		:: LispName("xlib:screen-backing-stores")
+xScreenBlackPixel		:: LispName("xlib:screen-black-pixel")
+xScreenDefaultColormap		:: LispName("xlib:screen-default-colormap")
+xScreenDepths			:: LispName("x-screen-depths")
+xScreenEventMaskAtOpen		:: LispName("xlib:screen-event-mask-at-open")
+xScreenSize			:: LispName("x-screen-size")
+xScreenMMSize                   :: LispName("x-screen-mmsize")
+xScreenMaxInstalledMaps		:: LispName("xlib:screen-max-installed-maps")
+xScreenMinInstalledMaps		:: LispName("xlib:screen-min-installed-maps")
+xScreenRoot                     :: LispName("xlib:screen-root")
+xScreenRootDepth		:: LispName("xlib:screen-root-depth")
+xScreenRootVisual		:: LispName("xlib:screen-root-visual")
+xScreenSaveUndersP		:: LispName("xlib:screen-save-unders-p")
+xScreenWhitePixel 		:: LispName("xlib:screen-white-pixel")
+
+-- WINDOWS AND PIXMAPS
+
+-- drawables
+
+xDrawableDisplay	:: LispName("xlib:drawable-display")
+xDrawableEqual		:: LispName("xlib:drawable-equal")
+xDrawableId		:: LispName("xlib:drawable-id")
+
+-- creating windows
+
+xCreateWindow           :: LispName("x-create-window")
+
+-- window attributes
+
+xWindowBorderWidth      :: LispName("xlib:drawable-border-width")
+xSetWindowBorderWidth   :: LispName("x-set-drawable-border-width")
+
+xDrawableDepth		:: LispName("xlib:drawable-depth")
+
+xDrawableSize           :: LispName("x-drawable-size")
+xDrawableResize         :: LispName("x-drawable-resize")
+
+xWindowPos              :: LispName("x-window-pos")
+xWindowMove             :: LispName("x-window-move")
+
+xWindowAllEventMasks	:: LispName("xlib:window-all-event-masks")
+
+xSetWindowBackground    :: LispName("x-set-window-background")
+
+xWindowBackingPixel     :: LispName("xlib:window-backing-pixel")
+xSetWindowBackingPixel  :: LispName("x-set-window-backing-pixel")
+
+xWindowBackingPlanes    :: LispName("xlib:window-backing-planes")
+xSetWindowBackingPlanes :: LispName("x-set-window-backing-planes")
+
+xWindowBackingStore     :: LispName("xlib:window-backing-store")
+xSetWindowBackingStore  :: LispName("x-set-window-backing-store")
+
+xWindowBitGravity	:: LispName("xlib:window-bit-gravity")
+xSetWindowBitGravity	:: LispName("x-set-window-bit-gravity")
+
+xSetWindowBorder        :: LispName("x-set-window-border")
+
+xWindowClass            :: LispName("xlib:window-class")
+
+xWindowColorMap         :: LispName("xlib:window-colormap")
+xSetWindowColorMap      :: LispName("x-set-window-colormap")
+xWindowColormapInstalledP :: LispName("xlib:window-colormap-installed-p")
+
+xSetWindowCursor        :: LispName("x-set-window-cursor")
+
+xWindowDisplay          :: LispName("xlib:window-display")
+
+xWindowDoNotPropagateMask    :: LispName("xlib:window-do-not-propagate-mask")
+xSetWindowDoNotPropagateMask :: LispName("x-set-window-do-not-propagate-mask")
+
+xWindowEqual		:: LispName("xlib:window-equal")
+
+xWindowEventMask	:: LispName("xlib:window-event-mask")
+xSetWindowEventMask	:: LispName("x-set-window-event-mask")
+
+xWindowGravity		:: LispName("xlib:window-gravity")
+xSetWindowGravity	:: LispName("x-set-window-gravity")
+
+xWindowId		:: LispName("xlib:window-id")
+
+xWindowMapState		:: LispName("xlib:window-map-state")
+
+xWindowOverrideRedirect		:: LispName("xlib:window-override-redirect")
+xSetWindowOverrideRedirect	:: LispName("x-set-window-override-redirect")
+
+xSetWindowPriority	:: LispName("x-set-window-priority")
+
+xWindowSaveUnder	:: LispName("xlib:window-save-under")
+xSetWindowSaveUnder	:: LispName("x-set-window-save-under")
+xWindowVisual		:: LispName("xlib:window-visual")
+
+-- stacking order
+
+xCirculateWindowDown	:: LispName("xlib:circulate-window-down")
+xCirculateWindowUp	:: LispName("xlib:circulate-window-up")
+
+-- window hierarchy
+
+xDrawableRoot		:: LispName("xlib:drawable-root")
+xQueryTree		:: LispName("x-query-tree")
+
+xReparentWindow		:: LispName("x-reparent-window")
+
+xTranslateCoordinates	:: LispName("x-translate-coordinates")
+
+-- mapping windows
+
+xMapWindow              :: LispName("xlib:map-window")
+xMapSubwindows          :: LispName("xlib:map-subwindows")
+xUnmapWindow		:: LispName("xlib:unmap-window")
+xUnmapSubwindows	:: LispName("xlib:unmap-subwindows")
+
+-- destroying windows
+
+xDestroyWindow		:: LispName("xlib:destroy-window")
+xDestroySubwindows	:: LispName("xlib:destroy-subwindows")
+
+-- pixmaps
+
+xCreatePixmap           :: LispName("x-create-pixmap")
+xFreePixmap             :: LispName("xlib:free-pixmap")
+xPixmapDisplay		:: LispName("xlib:pixmap-display")
+xPixmapEqual		:: LispName("xlib:pixmap-equal")
+
+-- GRAPHICS CONTEXTS
+
+xCreateGcontext   	:: LispName("x-create-gcontext")
+xUpdateGcontext	  	:: LispName("x-update-gcontext")
+xFreeGcontext     	:: LispName("xlib:free-gcontext")
+
+xGcontextDisplay	:: LispName("xlib:gcontext-display")
+xGcontextEqual		:: LispName("xlib:gcontext-equal")
+
+xGcontextId		:: LispName("xlib:gcontext-id")
+
+xQueryBestStipple	:: LispName("x-query-best-stipple")
+xQueryBestTile		:: LispName("x-query-best-tile")
+
+xCopyGcontext		:: LispName("xlib:copy-gcontext")
+
+-- GRAPHICS OPERATIONS
+
+xClearArea		:: LispName("x-clear-area")
+xCopyArea		:: LispName("x-copy-area")
+xCopyPlane		:: LispName("x-copy-plane")
+xDrawPoint		:: LispName("x-draw-point")
+xDrawPoints		:: LispName("x-draw-points")
+xDrawLine		:: LispName("x-draw-line")
+xDrawLines		:: LispName("x-draw-lines")
+xDrawSegments		:: LispName("x-draw-segments")
+xDrawRectangle		:: LispName("x-draw-rectangle")
+xDrawRectangles		:: LispName("x-draw-rectangles")
+xDrawArc		:: LispName("x-draw-arc")
+xDrawArcs		:: LispName("x-draw-arcs")
+xDrawGlyph		:: LispName("x-draw-glyph")
+xDrawGlyphs		:: LispName("x-draw-glyphs")
+xDrawImageGlyph		:: LispName("x-draw-image-glyph")
+xDrawImageGlyphs	:: LispName("x-draw-image-glyphs")
+
+-- IMAGES
+
+xImageBlueMask		:: LispName("xlib:image-blue-mask")
+xImageDepth 		:: LispName("xlib:image-depth")
+xImageGreenMask		:: LispName("xlib:image-green-mask")
+xImageSize		:: LispName("x-image-size")
+xImageName		:: LispName("x-image-name")
+xSetImageName		:: LispName("x-set-image-name")
+xImageRedMask		:: LispName("xlib:image-red-mask")
+xImageHotSpot		:: LispName("x-image-hot-spot")
+xSetImageHotSpot	:: LispName("x-set-image-hot-spot")
+
+-- XY-format images
+
+xImageXYBitmaps		:: LispName("xlib:image-xy-bitmap-list")
+xSetImageXYBitmaps	:: LispName("x-set-image-xy-bitmap-list")
+
+-- Z-format images
+
+xImageZBitsPerPixel	:: LispName("xlib:image-z-bits-per-pixel")
+xsetImageZBitsPerPixel	:: LispName("x-set-image-z-bits-per-pixel")
+xImageZPixarray		:: LispName("xlib:image-z-pixarray")
+xSetImageZPixarray	:: LispName("x-set-image-z-pixarray")
+
+-- image functions
+
+xCreateImage		:: LispName("x-create-image")
+xCopyImage		:: LispName("x-copy-image")
+xGetImage		:: LispName("x-get-image")
+xPutImage		:: LispName("x-put-image")
+
+-- image files
+
+xReadBitmapFile		:: LispName("xlib:read-bitmap-file")
+xWriteBitmapFile	:: LispName("xlib:write-bitmap-file")
+
+-- direct image transfer
+
+xGetRawImage		:: LispName("x-get-raw-image")	
+xPutRawImage		:: LispName("x-put-raw-image")	
+
+-- FONTS
+
+-- opening fonts
+
+xOpenFont		:: LispName ("xlib:open-font")
+xCloseFont		:: LispName ("xlib:close-font")
+xDiscardFontInfo	:: LispName ("xlib:discard-font-info")
+
+-- listing fonts
+
+xFontPath		:: LispName ("xlib:font-path")
+xListFontNames		:: LispName ("xlib:list-font-names")
+xListFonts		:: LispName ("xlib:list-fonts")
+
+-- font attriburtes
+
+xFontAllCharExistsP	:: LispName ("xlib:font-all-chars-exist-p")
+xFontAscent		:: LispName ("xlib:font-ascent")
+xFontDefaultChar	:: LispName ("xlib:font-default-char")
+xFontDescent		:: LispName ("xlib:font-descent")
+xFontDirection		:: LispName ("xlib:font-direction")
+xFontDisplay		:: LispName ("xlib:font-display")
+xFontEqual		:: LispName ("xlib:font-equal")
+xFontId			:: LispName ("xlib:font-id")
+
+xFontMaxByte1		:: LispName ("xlib:font-max-byte1")
+xFontMaxByte2		:: LispName ("xlib:font-max-byte2")
+xFontMaxChar		:: LispName ("xlib:font-max-char")
+xFontMinByte1		:: LispName ("xlib:font-min-byte1")
+xFontMinByte2		:: LispName ("xlib:font-min-byte2")
+xFontMinChar		:: LispName ("xlib:font-min-char")
+
+xFontName		:: LispName ("x-font-name")
+
+xFontMaxCharAscent	:: LispName ("xlib:max-char-ascent")
+xFontMaxCharAttributes	:: LispName ("xlib:max-char-attributes")
+xFontMaxCharDescent	:: LispName ("xlib:max-char-descent")
+xFontMaxCharLeftBearing	:: LispName ("xlib:max-char-left-bearing")
+xFontMaxCharRightBearing	:: LispName ("xlib:max-char-right-bearing")
+xFontMaxCharWidth	:: LispName ("xlib:max-char-width")
+xFontMinCharAscent	:: LispName ("xlib:min-char-ascent")
+xFontMinCharAttributes	:: LispName ("xlib:min-char-attributes")
+xFontMinCharDescent	:: LispName ("xlib:min-char-descent")
+xFontMinCharLeftBearing	:: LispName ("xlib:min-char-left-bearing")
+xFontMinCharRightBearing	:: LispName ("xlib:min-char-right-bearing")
+xFontMinCharWidth	:: LispName ("xlib:min-char-width")
+
+-- char attributes
+
+xCharAscent		:: LispName ("xlib:char-ascent")
+xCharAttributes		:: LispName ("xlib:char-attributes")
+xCharDescent		:: LispName ("xlib:char-descent")
+xCharLeftBearing	:: LispName ("xlib:char-left-bearing")
+xCharRightBearing	:: LispName ("xlib:char-right-bearing")
+xCharWidth		:: LispName ("xlib:char-width")
+
+-- querying text size
+
+xTextWidth		:: LispName ("xlib:text-width")
+
+-- COLORS
+
+-- creating colormaps
+
+xCreateColormap		:: LispName ("xlib:create-colormap")
+xCopyColormapAndFree	:: LispName ("xlib:copy-colormap-and-free")
+xFreeColormap		:: LispName ("xlib:free-colormap")
+
+-- installing colormaps
+
+xInstallColormap	:: LispName ("xlib:install-colormap")
+xInstalledColormaps	:: LispName ("xlib:installed-colormaps")
+xUnInstallColormap	:: LispName ("xlib:uninstall-colormap")
+
+-- allocating colors
+
+xAllocColor		:: LispName ("x-alloc-color")
+xAllocColorCells	:: LispName ("x-alloc-color-cells")
+xAllocColorPlanes	:: LispName ("x-alloc-color-planes")
+
+xFreeColors		:: LispName ("xlib:free-colors")
+
+-- finding colors
+
+xLookupColor		:: LispName ("x-lookup-color")
+xQueryColors		:: LispName ("xlib:query-colors")
+
+-- changing colors
+
+xStoreColor		:: LispName ("xlib:store-color")
+xStoreColors		:: LispName ("x-store-colors")
+
+-- colormap attributes
+
+xColormapDisplay	:: LispName ("xlib:colormap-display")
+xColormapEqual		:: LispName ("xlib:colormap-equal")
+
+-- CURSORS
+
+xCreateCursor		:: LispName ("x-create-cursor")
+xCreateGlyphCursor	:: LispName ("x-create-glyph-cursor")
+xFreeCursor		:: LispName ("xlib:free-cursor")
+
+xQueryBestCursor	:: LispName ("x-query-best-cursor")
+xRecolorCursor		:: LispName ("xlib:recolor-cursor")
+
+xCursorDisplay		:: LispName ("xlib:cursor-display")
+xCursorEqual		:: LispName ("xlib:cursor-equal")
+
+-- ATOMS, PROPERTIES, AND SELECTIONS
+
+-- atoms
+
+xAtomName		:: LispName ("xlib:atom-name")
+xFindAtom		:: LispName ("xlib:find-atom")
+xInternAtom		:: LispName ("xlib:intern-atom")
+
+-- properties
+
+xChangeProperty		:: LispName ("x-change-property")
+xDeleteProperty		:: LispName ("xlib:delete-property")
+xGetProperty		:: LispName ("x-get-property")
+xListProperties		:: LispName ("xlib:list-properties")
+xRotateProperties	:: LispName ("xlib:rotate-properties")
+
+-- selections
+
+xConvertSelection	:: LispName ("x-convert-selection")
+xSelectionOwner		:: LispName ("xlib:selection-owner")
+xSetSelectionOwner	:: LispName ("x-set-selection-owner")
+
+-- EVENT
+
+-- Wait for the next event 
+
+xGetEvent		:: LispName ("x-get-event")
+
+-- managing the event queue 
+
+xQueueEvent		:: LispName ("x-queue-event")
+xEventListen		:: LispName ("x-event-listen")
+
+-- sending events 
+
+xSendEvent		:: LispName ("x-send-event")
+
+-- pointer position
+
+xGlobalPointerPosition	:: LispName ("x-global-pointer-position")
+xPointerPosition	:: LispName ("x-pointer-position")
+xMotionEvents		:: LispName ("x-motion-events")
+xWarpPointer		:: LispName ("x-warp-pointer")
+
+-- keyboard input focus
+
+xSetInputFocus		:: LispName ("x-set-input-focus")
+xInputFucus		:: LispName ("x-input-focus")
+
+-- grabbing the pointer
+
+xGrabPointer		:: LispName ("x-grab-pointer")
+xUngrabPointer		:: LispName ("x-ungrab-pointer")
+xChangeActivePointerGrab :: LispName ("x-change-active-pointer-grab")
+
+-- grabbing a button
+
+xGrabButton		:: LispName ("x-grab-button")
+xUngrabButton		:: LispName ("x-ungrab-button")
+
+-- grabbing the keyboard
+
+xGrabKeyboard		:: LispName ("x-grab-keyboard")
+xUngrabkeyboard		:: LispName ("x-ungrab-keyboard")
+
+-- grabbing a key
+
+xGrabKey		:: LispName ("x-grab-key")
+xUngrabKey		:: LispName ("x-ungrab-key")
+
+-- CONTROL FUNCTIONS
+
+-- grabbing the server
+
+xGrabServer		:: LispName ("xlib:grab-server")
+xUngrabServer		:: LispName ("xlib:ungrab-server")
+
+-- pointer control
+
+xSetPointerAcceleration	:: LispName ("x-set-pointer-acceleration")
+xSetPointerThreshold	:: LispName ("x-set-pointer-threshold")
+xPointerAcceleration	:: LispName ("x-pointer-acceleration")
+xPointerThreshold	:: LispName ("x-pointer-threshold")
+xSetPointerMapping	:: LispName ("x-set-pointer-mapping")
+xPointerMapping		:: LispName ("xlib:pointer-mapping")
+
+-- keyboard control
+
+xBell			:: LispName ("xlib:bell")
+
+xSetKeyboardKeyClickPercent 	:: LispName ("x-set-keyboard-key-click-percent")
+xSetKeyboardBellPercent	    	:: LispName ("x-set-keyboard-bell-percent")
+xSetKeyboardBellPitch	    	:: LispName ("x-set-keyboard-bell-pitch")
+xSetKeyboardBellDuration    	:: LispName ("x-set-keyboard-bell-duration")
+xSetKeyboardLed		    	:: LispName ("x-set-keyboard-led")
+xSetKeyboardAutoRepeatMode  	:: LispName ("x-set-keyboard-auto-repeat-mode")
+
+xKeyboardKeyClickPercent	:: LispName ("x-keyboard-key-click-percent")
+xKeyboardBellPercent		:: LispName ("x-keyboard-bell-percent")
+xKeyboardBellPitch		:: LispName ("x-keyboard-bell-pitch")
+xKeyboardBellDuration		:: LispName ("x-keyboard-bell-duration")
+xKeyboardLed			:: LispName ("x-keyboard-led")
+xKeyboardAutoRepeatMode		:: LispName ("x-keyboard-auto-repeat-mode")
+
+xModifierMapping		:: LispName ("x-modifier-mapping")
+xSetModifierMapping		:: LispName ("x-set-modifier-mapping")
+xQueryKeymap			:: LispName ("xlib:query-keymap")
+
+-- keyboard mapping
+
+xChangeKeyboardMapping 		:: LispName ("xlib:change-keyboard-mapping")
+xKeyboardMapping		:: LispName ("xlib:keyboard-mapping")
+
+xKeycodeKeysym			:: LispName ("xlib:keycode->keysym")
+xKeysymCharacter		:: LispName ("x-keysym-character")
+xKeycodeCharacter		:: LispName ("x-keycode-character")
+
+-- client termination
+
+xAddToSaveSet		:: LispName ("xlib:add-to-save-set")
+xCloseDownMode		:: LispName ("xlib:close-down-mode")
+xSetCloseDownMode	:: LispName ("x-set-close-down-mode")
+xKillClient		:: LispName ("xlib:kill-client")
+xKillTemporaryClients	:: LispName ("xlib:kill-temporary-clients")
+xRemoveFromSaveSet	:: LispName ("xlib:remove-from-save-set")
+
+-- managing host access
+
+xAccessControl		:: LispName ("xlib:access-control")
+xSetAccessControl	:: LispName ("x-set-access-control")
+xAccessHosts		:: LispName ("xlib:access-hosts")
+xAddAccessHost		:: LispName ("xlib:add-access-host")
+xRemoveAccessHost	:: LispName ("xlib:remove-access-host")
+
+-- screen saver
+
+xActivateScreenSaver	:: LispName ("xlib:activate-screen-saver")
+xResetScreenSaver	:: LispName ("xlib:reset-screen-saver")
+xScreenSaver		:: LispName ("x-screen-saver")
+xSetScreenSaver		:: LispName ("x-set-screen-saver")
+
+#-}
+
+data XMArray a
+
+xMArrayCreate     :: [a] -> IO (XMArray a)
+xMArrayLookup     :: XMArray a -> Int -> IO a
+xMArrayUpdate     :: XMArray a -> Int -> a -> IO ()
+xMArrayLength     :: XMArray a -> Int
+
+{-#
+xMArrayCreate     :: LispName("x-mutable-array-create")
+xMArrayLookup     :: LispName("x-mutable-array-lookup")
+xMArrayUpdate     :: LispName("x-mutable-array-update")
+xMArrayLength     :: LispName("x-mutable-array-length")
+#-}
+
+
+xprint			:: a -> IO ()
+{-#
+xprint			:: LispName ("x-print")
+#-}
+
+-- decoded time format:
+-- ([second, minute, hour, date, month, year, day-of-week], 
+--  daylight-saving-time-p)
+-- time format to encode:
+-- [second, minute, hour, date, month, year]
+
+data TimeZone	= WestOfGMT Int {-# STRICT #-}
+		| CurrentZone
+
+getTime		:: IO Integer
+getTimeZone	:: IO Int
+decodeTime	:: Integer -> TimeZone -> ([Int], Bool)
+encodeTime	:: [Int] -> TimeZone -> Integer
+getRunTime	:: IO Float
+getElapsedTime	:: IO Float
+sleep		:: Int -> IO ()
+
+{-#
+ImportLispType (TimeZone (WestOfGMT ("number?", "identity", "identity")))
+ImportLispType (TimeZone (CurrentZone ("null?", "'()")))
+
+getTime		:: LispName("lisp:get-universal-time")
+getTimeZone	:: LispName("get-time-zone")
+decodeTime	:: LispName("decode-time")
+encodeTime	:: LispName("encode-time")
+getRunTime	:: LispName("get-run-time")
+getElapsedTime	:: LispName("get-elapsed-time")
+sleep		:: LispName("lisp:sleep")
+
+#-}
+
+xWmName 		:: XWindow -> IO String
+xSetWmName		:: XWindow -> String -> IO ()
+
+xWmIconName		:: XWindow -> IO String
+xSetWmIconName		:: XWindow -> String -> IO ()
+
+{-#
+xWmName 		:: LispName ("xlib:wm-name")
+xSetWmName		:: LispName ("x-set-wm-name")
+
+xWmIconName		:: LispName ("xlib:wm-icon-name")
+xSetWmIconName		:: LispName ("x-set-wm-icon-name")
+#-}
diff --git a/progs/lib/X11/xlibprims.hu b/progs/lib/X11/xlibprims.hu
new file mode 100644
index 0000000..38138d4
--- /dev/null
+++ b/progs/lib/X11/xlibprims.hu
@@ -0,0 +1,5 @@
+:output $LIBRARYBIN/
+:stable
+:o= all
+xlibclx.scm
+xlibprims.hi
diff --git a/progs/lib/cl/README b/progs/lib/cl/README
new file mode 100644
index 0000000..8164257
--- /dev/null
+++ b/progs/lib/cl/README
@@ -0,0 +1,2 @@
+This directory contains some libraries which allow you to use various
+Common Lisp primitives from Haskell.
diff --git a/progs/lib/cl/logop-prims.hi b/progs/lib/cl/logop-prims.hi
new file mode 100644
index 0000000..2b120bb
--- /dev/null
+++ b/progs/lib/cl/logop-prims.hi
@@ -0,0 +1,78 @@
+-- logop-prims.hi -- interface to logical operations on numbers
+--
+-- author :  Sandra Loosemore
+-- date   :  19 June 1993
+--
+
+interface LogOpPrims where
+
+logiorInteger		:: Integer -> Integer -> Integer
+logxorInteger		:: Integer -> Integer -> Integer
+logandInteger		:: Integer -> Integer -> Integer
+logeqvInteger		:: Integer -> Integer -> Integer
+lognandInteger		:: Integer -> Integer -> Integer
+lognorInteger		:: Integer -> Integer -> Integer
+logandc1Integer		:: Integer -> Integer -> Integer
+logandc2Integer		:: Integer -> Integer -> Integer
+logorc1Integer		:: Integer -> Integer -> Integer
+logorc2Integer		:: Integer -> Integer -> Integer
+lognotInteger		:: Integer -> Integer
+logtestInteger		:: Integer -> Integer -> Integer
+logbitpInteger		:: Int -> Integer -> Integer
+ashInteger		:: Integer -> Int -> Integer
+logcountInteger		:: Integer -> Int
+integerLengthInteger	:: Integer -> Int
+
+logiorInt		:: Int -> Int -> Int
+logxorInt		:: Int -> Int -> Int
+logandInt		:: Int -> Int -> Int
+logeqvInt		:: Int -> Int -> Int
+lognandInt		:: Int -> Int -> Int
+lognorInt		:: Int -> Int -> Int
+logandc1Int		:: Int -> Int -> Int
+logandc2Int		:: Int -> Int -> Int
+logorc1Int		:: Int -> Int -> Int
+logorc2Int		:: Int -> Int -> Int
+lognotInt		:: Int -> Int
+logtestInt		:: Int -> Int -> Int
+logbitpInt		:: Int -> Int -> Int
+ashInt			:: Int -> Int -> Int
+logcountInt		:: Int -> Int
+integerLengthInt	:: Int -> Int
+
+{-#
+logiorInteger		:: LispName("logop.logior-integer"), Complexity(4)
+logxorInteger		:: LispName("logop.logxor-integer"), Complexity(4)
+logandInteger		:: LispName("logop.logand-integer"), Complexity(4)
+logeqvInteger		:: LispName("logop.logeqv-integer"), Complexity(4)
+lognandInteger		:: LispName("logop.lognand-integer"), Complexity(4)
+lognorInteger		:: LispName("logop.lognor-integer"), Complexity(4)
+logandc1Integer		:: LispName("logop.logandc1-integer"), Complexity(4)
+logandc2Integer		:: LispName("logop.logandc2-integer"), Complexity(4)
+logorc1Integer		:: LispName("logop.logorc1-integer"), Complexity(4)
+logorc2Integer		:: LispName("logop.logorc2-integer"), Complexity(4)
+lognotInteger		:: LispName("logop.lognot-integer"), Complexity(4)
+logtestInteger		:: LispName("logop.logtest-integer"), Complexity(4)
+logbitpInteger		:: LispName("logop.logbitp-integer"), Complexity(4)
+ashInteger		:: LispName("logop.ash-integer"), Complexity(4)
+logcountInteger		:: LispName("logop.logcount-integer"), Complexity(4)
+integerLengthInteger	:: LispName("logop.integer-length-integer"), Complexity(4)
+
+logiorInt		:: LispName("logop.logior-int"), Complexity(2)
+logxorInt		:: LispName("logop.logxor-int"), Complexity(2)
+logandInt		:: LispName("logop.logand-int"), Complexity(2)
+logeqvInt		:: LispName("logop.logeqv-int"), Complexity(2)
+lognandInt		:: LispName("logop.lognand-int"), Complexity(2)
+lognorInt		:: LispName("logop.lognor-int"), Complexity(2)
+logandc1Int		:: LispName("logop.logandc1-int"), Complexity(2)
+logandc2Int		:: LispName("logop.logandc2-int"), Complexity(2)
+logorc1Int		:: LispName("logop.logorc1-int"), Complexity(2)
+logorc2Int		:: LispName("logop.logorc2-int"), Complexity(2)
+lognotInt		:: LispName("logop.lognot-int"), Complexity(2)
+logtestInt		:: LispName("logop.logtest-int"), Complexity(2)
+logbitpInt		:: LispName("logop.logbitp-int"), Complexity(2)
+ashInt			:: LispName("logop.ash-int"), Complexity(2)
+logcountInt		:: LispName("logop.logcount-int"), Complexity(2)
+integerLengthInt	:: LispName("logop.integer-length-int"), Complexity(2)
+#-}
+
diff --git a/progs/lib/cl/logop-prims.scm b/progs/lib/cl/logop-prims.scm
new file mode 100644
index 0000000..b846836
--- /dev/null
+++ b/progs/lib/cl/logop-prims.scm
@@ -0,0 +1,81 @@
+;;; logop-prims.scm -- primitives for logical operations on numbers
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  19 Jun 1993
+;;;
+
+
+;;; Integer operations
+;;; Note that bit counts are still guaranteed to be fixnums....
+
+(define-syntax (logop.logior-integer i1 i2)
+  `(the integer (lisp:logior (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logxor-integer i1 i2)
+  `(the integer (lisp:logxor (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logand-integer i1 i2)
+  `(the integer (lisp:logand (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logeqv-integer i1 i2)
+  `(the integer (lisp:logeqv (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.lognand-integer i1 i2)
+  `(the integer (lisp:lognand (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.lognor-integer i1 i2)
+  `(the integer (lisp:lognor (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logandc1-integer i1 i2)
+  `(the integer (lisp:logandc1 (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logandc2-integer i1 i2)
+  `(the integer (lisp:logandc2 (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logorc1-integer i1 i2)
+  `(the integer (lisp:logorc1 (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logorc2-integer i1 i2)
+  `(the integer (lisp:logorc2 (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.lognot-integer i1)
+  `(the integer (lisp:lognot (the integer ,i1))))
+(define-syntax (logop.logtest-integer i1 i2)
+  `(the integer (lisp:logtest (the integer ,i1) (the integer ,i2))))
+(define-syntax (logop.logbitp-integer i1 i2)
+  `(the integer (lisp:logbitp (the fixnum ,i1) (the integer ,i2))))
+(define-syntax (logop.ash-integer i1 i2)
+  `(the integer (lisp:ash (the integer ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logcount-integer i1)
+  `(the fixnum (lisp:logcount (the integer ,i1))))
+(define-syntax (logop.integer-length-integer i1)
+  `(the fixnum (lisp:integer-length (the integer ,i1))))
+
+
+;;; Fixnum operations
+
+(define-syntax (logop.logior-int i1 i2)
+  `(the fixnum (lisp:logior (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logxor-int i1 i2)
+  `(the fixnum (lisp:logxor (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logand-int i1 i2)
+  `(the fixnum (lisp:logand (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logeqv-int i1 i2)
+  `(the fixnum (lisp:logeqv (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.lognand-int i1 i2)
+  `(the fixnum (lisp:lognand (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.lognor-int i1 i2)
+  `(the fixnum (lisp:lognor (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logandc1-int i1 i2)
+  `(the fixnum (lisp:logandc1 (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logandc2-int i1 i2)
+  `(the fixnum (lisp:logandc2 (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logorc1-int i1 i2)
+  `(the fixnum (lisp:logorc1 (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logorc2-int i1 i2)
+  `(the fixnum (lisp:logorc2 (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.lognot-int i1)
+  `(the fixnum (lisp:lognot (the fixnum ,i1))))
+(define-syntax (logop.logtest-int i1 i2)
+  `(the fixnum (lisp:logtest (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logbitp-int i1 i2)
+  `(the fixnum (lisp:logbitp (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.ash-int i1 i2)
+  `(the fixnum (lisp:ash (the fixnum ,i1) (the fixnum ,i2))))
+(define-syntax (logop.logcount-int i1)
+  `(the fixnum (lisp:logcount (the fixnum ,i1))))
+(define-syntax (logop.integer-length-int i1)
+  `(the fixnum (lisp:integer-length (the fixnum ,i1))))
+
+
+
diff --git a/progs/lib/cl/logop.hs b/progs/lib/cl/logop.hs
new file mode 100644
index 0000000..1d0f9ba
--- /dev/null
+++ b/progs/lib/cl/logop.hs
@@ -0,0 +1,63 @@
+-- logop.hs -- logical operations on numbers
+--
+-- author :  Sandra Loosemore
+-- date   :  19 June 1993
+--
+
+module LogOp where
+
+import LogOpPrims  -- from logop-prims.hi
+
+class LogOperand a where
+  logior	:: a -> a -> a
+  logxor	:: a -> a -> a
+  logand	:: a -> a -> a
+  logeqv	:: a -> a -> a
+  lognand	:: a -> a -> a
+  lognor	:: a -> a -> a
+  logandc1	:: a -> a -> a
+  logandc2	:: a -> a -> a
+  logorc1	:: a -> a -> a
+  logorc2	:: a -> a -> a
+  lognot	:: a -> a
+  logtest	:: a -> a -> a
+  logbitp	:: Int -> a -> a
+  ash		:: a -> Int -> a
+  logcount	:: a -> Int
+  integerLength :: a -> Int
+
+instance LogOperand Integer where
+  logior	= logiorInteger
+  logxor	= logxorInteger
+  logand	= logandInteger
+  logeqv	= logeqvInteger
+  lognand	= lognandInteger
+  lognor	= lognorInteger
+  logandc1	= logandc1Integer
+  logandc2	= logandc2Integer
+  logorc1	= logorc1Integer
+  logorc2	= logorc2Integer
+  lognot	= lognotInteger
+  logtest	= logtestInteger
+  logbitp	= logbitpInteger
+  ash		= ashInteger
+  logcount	= logcountInteger
+  integerLength	= integerLengthInteger
+
+instance LogOperand Int where
+  logior	= logiorInt
+  logxor	= logxorInt
+  logand	= logandInt
+  logeqv	= logeqvInt
+  lognand	= lognandInt
+  lognor	= lognorInt
+  logandc1	= logandc1Int
+  logandc2	= logandc2Int
+  logorc1	= logorc1Int
+  logorc2	= logorc2Int
+  lognot	= lognotInt
+  logtest	= logtestInt
+  logbitp	= logbitpInt
+  ash		= ashInt
+  logcount	= logcountInt
+  integerLength	= integerLengthInt
diff --git a/progs/lib/cl/logop.hu b/progs/lib/cl/logop.hu
new file mode 100644
index 0000000..cfe8209
--- /dev/null
+++ b/progs/lib/cl/logop.hu
@@ -0,0 +1,5 @@
+:output $LIBRARYBIN/
+:o= all
+logop.hs
+logop-prims.scm
+logop-prims.hi
diff --git a/progs/lib/cl/maybe.hs b/progs/lib/cl/maybe.hs
new file mode 100644
index 0000000..8ce01e5
--- /dev/null
+++ b/progs/lib/cl/maybe.hs
@@ -0,0 +1,12 @@
+-- maybe.hs -- "maybe" type
+--
+-- author :  Sandra Loosemore
+-- date   :  22 June 1993
+--
+
+module Maybe where
+
+data Maybe a = Some a | Null
+
+{-# ImportLispType (Maybe(Some("identity", "identity", "identity"),
+                          Null("not", "'#f")))  #-}
diff --git a/progs/lib/cl/maybe.hu b/progs/lib/cl/maybe.hu
new file mode 100644
index 0000000..2115c71
--- /dev/null
+++ b/progs/lib/cl/maybe.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+maybe.hs
diff --git a/progs/lib/cl/random-prims.hi b/progs/lib/cl/random-prims.hi
new file mode 100644
index 0000000..e66d802
--- /dev/null
+++ b/progs/lib/cl/random-prims.hi
@@ -0,0 +1,20 @@
+-- random-prims.hi -- interface file to random number primitives
+--
+-- author :  Sandra Loosemore
+-- date   :  22 June 1993
+--
+
+
+interface RandomPrims where
+
+randomInt	:: Int -> IO Int
+randomInteger   :: Integer -> IO Integer
+randomFloat     :: Float -> IO Float
+randomDouble    :: Double -> IO Double
+
+{-#
+randomInt	:: LispName("lisp:random"), Complexity(5)
+randomInteger	:: LispName("lisp:random"), Complexity(5)
+randomFloat	:: LispName("lisp:random"), Complexity(5)
+randomDouble	:: LispName("lisp:random"), Complexity(5)
+#-}
diff --git a/progs/lib/cl/random.hs b/progs/lib/cl/random.hs
new file mode 100644
index 0000000..93d26e4
--- /dev/null
+++ b/progs/lib/cl/random.hs
@@ -0,0 +1,21 @@
+-- random.hs -- random number functions
+--
+-- author :  Sandra Loosemore
+-- date   :  22 June 1993
+--
+
+module Random where
+
+import RandomPrims  -- from random-prims.hi
+
+class RandomOperand a where
+  random	:: a -> IO a
+
+instance RandomOperand Int where
+  random	= randomInt
+instance RandomOperand Integer where
+  random	= randomInteger
+instance RandomOperand Float where
+  random	= randomFloat
+instance RandomOperand Double where
+  random	= randomDouble
diff --git a/progs/lib/cl/random.hu b/progs/lib/cl/random.hu
new file mode 100644
index 0000000..4b8e286
--- /dev/null
+++ b/progs/lib/cl/random.hu
@@ -0,0 +1,4 @@
+:output $LIBRARYBIN/
+:o= all
+random.hs
+random-prims.hi
diff --git a/progs/lib/hbc/Either.hs b/progs/lib/hbc/Either.hs
new file mode 100644
index 0000000..fad5af8
--- /dev/null
+++ b/progs/lib/hbc/Either.hs
@@ -0,0 +1,2 @@
+module Either(Either(..)) where
+data Either a b = Left a | Right b deriving (Eq, Ord, Text, Binary)
diff --git a/progs/lib/hbc/Either.hu b/progs/lib/hbc/Either.hu
new file mode 100644
index 0000000..3313235
--- /dev/null
+++ b/progs/lib/hbc/Either.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Either.hs
diff --git a/progs/lib/hbc/Hash.hs b/progs/lib/hbc/Hash.hs
new file mode 100644
index 0000000..1f14c6f
--- /dev/null
+++ b/progs/lib/hbc/Hash.hs
@@ -0,0 +1,79 @@
+module Hash where
+--
+-- Hash a value.  Hashing produces an Int of
+-- unspecified range.
+--
+
+class Hashable a where
+    hash :: a -> Int
+
+instance Hashable Char where
+    hash x = ord x
+
+instance Hashable Int where
+    hash x = x
+
+instance Hashable Integer where
+    hash x = fromInteger x
+
+instance Hashable Float where
+    hash x = truncate x
+
+instance Hashable Double where
+    hash x = truncate x
+
+instance Hashable Bin where
+    hash x = 0
+
+{-instance Hashable File where
+    hash x = 0 -}
+
+instance Hashable () where
+    hash x = 0
+
+instance Hashable (a -> b) where
+    hash x = 0
+
+instance Hashable a => Hashable [a] where
+    hash x = sum (map hash x)
+
+instance (Hashable a, Hashable b) => Hashable (a,b) where
+    hash (a,b) = hash a + 3 * hash b
+
+instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
+    hash (a,b,c) = hash a + 3 * hash b + 5 * hash c
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
+    hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
+    hash (a,b,c,d,e) = hash a + hash b + hash c + hash d + hash e
+
+instance Hashable Bool where
+    hash False = 0
+    hash True = 1
+
+instance (Integral a, Hashable a) => Hashable (Ratio a) where
+    hash x = hash (denominator x) + hash (numerator x)
+
+instance (RealFloat a, Hashable a) => Hashable (Complex a) where
+    hash (x :+ y) = hash x + hash y
+
+instance (Hashable a, Hashable b) => Hashable (Assoc a b) where
+    hash (x := y) = hash x + hash y
+
+instance (Ix a) => Hashable (Array a b) where
+    hash x = 0 -- !!!
+
+instance Hashable Request where
+    hash x = 0 -- !!
+
+instance Hashable Response where
+    hash x = 0 -- !!
+
+instance Hashable IOError where
+    hash x = 0 -- !!
+
+hashToMax maxhash x =
+    let h = abs (hash x)
+    in  if h < 0 then 0 else h `rem` maxhash
diff --git a/progs/lib/hbc/Hash.hu b/progs/lib/hbc/Hash.hu
new file mode 100644
index 0000000..2c23c72
--- /dev/null
+++ b/progs/lib/hbc/Hash.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Hash.hs
diff --git a/progs/lib/hbc/ListUtil.hs b/progs/lib/hbc/ListUtil.hs
new file mode 100644
index 0000000..560920e
--- /dev/null
+++ b/progs/lib/hbc/ListUtil.hs
@@ -0,0 +1,48 @@
+module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..) where
+import Maybe
+
+-- Lookup an item in an association list.  Apply a function to it if it is found, otherwise return a default value.
+assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
+assoc f d [] x                       = d
+assoc f d ((x',y):xys) x | x' == x   = f y
+                         | otherwise = assoc f d xys x
+
+-- Map and concatename results.
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f []	   = []
+concatMap f (x:xs) =
+	case f x of
+	[] -> concatMap f xs
+	ys -> ys ++ concatMap f xs
+
+-- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.
+unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
+unfoldr f p x | p x       = []
+	      | otherwise = y:unfoldr f p x'
+			      where (y, x') = f x
+
+-- Map, but plumb a state through the map operation.
+mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccuml f s []     = (s, [])
+mapAccuml f s (x:xs) = (s'', y:ys)
+		       where (s',  y)  = f s x
+			     (s'', ys) = mapAccuml f s' xs
+
+-- Union of sets as lists.
+union :: (Eq a) => [a] -> [a] -> [a]
+union xs ys = xs ++ (ys \\ xs)
+
+-- Intersection of sets as lists.
+intersection :: (Eq a) => [a] -> [a] -> [a]
+intersection xs ys = [x | x<-xs, x `elem` ys]
+
+--- Functions derived from those above
+
+chopList :: ([a] -> (b, [a])) -> [a] -> [b]
+chopList f l = unfoldr f null l
+
+assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
+assocDef l d x = assoc id d l x
+
+lookup :: (Eq a) => [(a, b)] -> a -> Maybe b
+lookup l x = assoc Just Nothing l x
diff --git a/progs/lib/hbc/ListUtil.hu b/progs/lib/hbc/ListUtil.hu
new file mode 100644
index 0000000..7402cb7
--- /dev/null
+++ b/progs/lib/hbc/ListUtil.hu
@@ -0,0 +1,4 @@
+:output $LIBRARYBIN/
+:o= all
+ListUtil.hs
+Maybe.hu
diff --git a/progs/lib/hbc/Maybe.hs b/progs/lib/hbc/Maybe.hs
new file mode 100644
index 0000000..f0ada70
--- /dev/null
+++ b/progs/lib/hbc/Maybe.hs
@@ -0,0 +1,6 @@
+module Maybe(Maybe(..), thenM) where
+-- Maybe together with Just and thenM forms a monad, but is more
+-- by accident than by design.
+data Maybe a = Nothing | Just a	deriving (Eq, Ord, Text, Binary)
+Nothing `thenM` _ = Nothing
+Just a  `thenM` f = f a
diff --git a/progs/lib/hbc/Maybe.hu b/progs/lib/hbc/Maybe.hu
new file mode 100644
index 0000000..a55b652
--- /dev/null
+++ b/progs/lib/hbc/Maybe.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Maybe.hs
diff --git a/progs/lib/hbc/Miranda.hs b/progs/lib/hbc/Miranda.hs
new file mode 100644
index 0000000..2d863ce
--- /dev/null
+++ b/progs/lib/hbc/Miranda.hs
@@ -0,0 +1,90 @@
+module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces,
+	       {-force,seq,-}sort) where
+--import UnsafeDirty
+import QSort
+
+cjustify :: Int -> String -> String
+cjustify n s = spaces l ++ s ++ spaces r
+               where
+               m = n - length s
+               l = m `div` 2
+               r = m - l
+
+{-
+index :: [a] -> [Int]
+index xs = f xs 0
+		where f []     n = []
+		      f (_:xs) n = n : f xs (n+1)
+-}
+
+lay :: [String] -> String
+lay = concat . map (++"\n")
+
+layn :: [String] -> String
+layn =  concat . zipWith f [1..]
+           where
+	   f :: Int -> String -> String
+           f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n"
+
+limit :: (Eq a) => [a] -> a
+limit (x:y:ys) | x == y    = x
+               | otherwise = limit (y:ys)
+limit _                    = error "Miranda.limit: bad use"
+
+ljustify :: Int -> String -> String
+ljustify n s = s ++ spaces (n - length s)
+
+merge :: (Ord a) => [a] -> [a] -> [a]
+merge []         ys                     = ys
+merge xs         []                     = xs
+merge xxs@(x:xs) yys@(y:ys) | x <= y    = x : merge xs  yys
+		            | otherwise = y : merge xxs ys
+
+rep :: Int -> b -> [b]
+rep n x = take n (repeat x)
+
+rjustify :: Int -> String -> String
+rjustify n s = spaces (n - length s) ++ s
+
+spaces :: Int -> String
+spaces 0 = ""
+spaces n = ' ' : spaces (n-1)
+
+-------------
+
+arctan x = atan x
+code c = ord c
+converse f a b = flip f a b
+decode n = chr n
+digit c = isDigit c
+e :: (Floating a) => a
+e = exp 1
+entier x = floor x
+filemode f = error "Miranda.filemode"
+--getenv
+hd xs = head xs
+hugenum :: (Floating a) => a
+hugenum = error "hugenum" --!!!
+integer x = x == truncate x
+letter c = isAlpha c
+map2 f xs ys = zipWith f xs ys
+--max
+max2 x y = max x y
+member xs x = x `elem` xs
+--min
+min2 x y = min x y
+mkset xs = nub xs
+neg x = negate x
+numval :: (Num a) => String -> a
+numval cs = read cs
+postfix xs x = xs ++ [x]
+--read
+scan f z l = scanl f z l
+--shownum !!!
+--showfloat !!!
+--showscaled !!!
+tinynum :: (Floating a) => a
+tinynum = error "tinynum"
+undef = error "undefined"
+zip2 xs ys = zip xs ys
+--zip
diff --git a/progs/lib/hbc/Miranda.hu b/progs/lib/hbc/Miranda.hu
new file mode 100644
index 0000000..cfa86ed
--- /dev/null
+++ b/progs/lib/hbc/Miranda.hu
@@ -0,0 +1,4 @@
+:output $LIBRARYBIN/
+:o= all
+Miranda.hs
+QSort.hu
diff --git a/progs/lib/hbc/Option.hs b/progs/lib/hbc/Option.hs
new file mode 100644
index 0000000..a4b2423
--- /dev/null
+++ b/progs/lib/hbc/Option.hs
@@ -0,0 +1,3 @@
+module Option(Option(..), thenO) where
+import Maybe renaming (Maybe to Option, Nothing to None, Just to Some, thenM to thenO)
+
diff --git a/progs/lib/hbc/Option.hu b/progs/lib/hbc/Option.hu
new file mode 100644
index 0000000..592a0cd
--- /dev/null
+++ b/progs/lib/hbc/Option.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Option.hs
diff --git a/progs/lib/hbc/Pretty.hs b/progs/lib/hbc/Pretty.hs
new file mode 100644
index 0000000..ad63dbe
--- /dev/null
+++ b/progs/lib/hbc/Pretty.hs
@@ -0,0 +1,50 @@
+module Pretty(text, separate, nest, pretty, (~.), (^.), IText(..), Context(..)) where
+infixr 8 ~.
+infixr 8 ^.
+
+type IText   = Context -> [String]
+type Context = (Bool,Int,Int,Int)
+
+text :: String -> IText
+text s (v,w,m,m') = [s]
+
+(~.) :: IText -> IText -> IText
+(~.) d1 d2 (v,w,m,m') =
+	let t = d1 (False,w,m,m')
+            tn = last t
+	    indent = length tn
+	    sig = if length t == 1
+		  then m' + indent
+		  else length (dropWhile (==' ') tn)
+	    (l:ls) = d2 (False,w-indent,m,sig)
+	in  init t ++
+	    [tn ++ l] ++
+	    map (space indent++) ls
+
+space :: Int -> String
+space n = [' ' | i<-[1..n]]
+
+(^.) :: IText -> IText -> IText
+(^.) d1 d2 (v,w,m,m') = d1 (True,w,m,m') ++ d2 (True,w,m,0)
+
+separate :: [IText] -> IText
+separate [] _ = [""]
+separate ds (v,w,m,m') = 
+	let hor = foldr1 (\d1 d2 -> d1 ~. text " " ~. d2) ds
+	    ver = foldr1 (^.) ds
+	    t = hor (v,w,m,m')
+	in  if fits 1 t && fits (w `min` m-m') (head t)
+	    then t
+	    else ver (v,w,m,m')
+
+fits n xs = length xs <= n `max` 0 --null (drop n xs)
+
+nest :: Int -> IText -> IText
+nest n d (v,w,m,m') = 
+	if v then
+	    map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n)) 
+	else 
+	    d (v,w,m,m')
+
+pretty :: Int->Int->IText->String
+pretty w m d = concat (map (++"\n") (d (False,w,m,0)))
diff --git a/progs/lib/hbc/Printf.hs b/progs/lib/hbc/Printf.hs
new file mode 100644
index 0000000..c8291bd
--- /dev/null
+++ b/progs/lib/hbc/Printf.hs
@@ -0,0 +1,150 @@
+-- This code used a function in the lml library (fmtf) that I don't have.
+-- If someone makes this work for floats let me know   -- jcp
+--
+-- A C printf like formatter.
+-- Conversion specs:
+--	-	left adjust
+--	num	field width
+--	.	separates width from precision
+-- Formatting characters:
+-- 	c	Char, Int, Integer
+--	d	Char, Int, Integer
+--	o	Char, Int, Integer
+--	x	Char, Int, Integer
+--	u	Char, Int, Integer
+--	f	Float, Double
+--	g	Float, Double
+--	e	Float, Double
+--	s	String
+--
+module Printf(UPrintf(..), printf) where
+
+-- import LMLfmtf
+
+data UPrintf = UChar Char |
+	       UString String |
+               UInt Int |
+	       UInteger Integer |
+               UFloat Float |
+	       UDouble Double
+
+printf :: String -> [UPrintf] -> String
+printf ""       []       = ""
+printf ""       (_:_)    = fmterr
+printf ('%':_)  []       = argerr
+printf ('%':cs) us@(_:_) = fmt cs us
+printf (c:cs)   us       = c:printf cs us
+
+fmt :: String -> [UPrintf] -> String
+fmt cs us =
+	let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
+	    adjust (pre, str) = 
+		let lstr = length str
+		    lpre = length pre
+		    fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
+		in  if ladj then pre ++ str ++ fill else pre ++ fill ++ str
+        in
+	case cs' of
+	[]     -> fmterr
+	c:cs'' ->
+	    case us' of
+	    []     -> argerr
+	    u:us'' ->
+		(case c of
+		'c' -> adjust ("", [chr (toint u)])
+		'd' -> adjust (fmti u)
+		'x' -> adjust ("", fmtu 16 u)
+		'o' -> adjust ("", fmtu 8  u)
+		'u' -> adjust ("", fmtu 10 u)
+		'%' -> "%"
+		'e' -> adjust (dfmt c prec (todbl u))
+		'f' -> adjust (dfmt c prec (todbl u))
+		'g' -> adjust (dfmt c prec (todbl u))
+		's' -> adjust ("", tostr u)
+		c   -> perror ("bad formatting char " ++ [c])
+		) ++ printf cs'' us''
+unimpl = perror "unimplemented"
+
+fmti (UInt i)     = if i < 0 then
+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
+		    else
+			("", itos i)
+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
+fmti (UChar c)    = fmti (UInt (ord c))
+fmti u		  = baderr
+
+fmtu b (UInt i)     = if i < 0 then
+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
+		      else
+			  itosb b (toInteger i)
+fmtu b (UInteger i) = itosb b i
+fmtu b (UChar c)    = itosb b (toInteger (ord c))
+fmtu b u            = baderr
+
+maxi :: Integer
+maxi = (toInteger maxInt + 1) * 2
+
+toint (UInt i)     = i
+toint (UInteger i) = toInt i
+toint (UChar c)    = ord c
+toint u		   = baderr
+
+tostr (UString s) = s
+tostr u		  = baderr
+
+todbl (UDouble d) = d
+todbl (UFloat f)  = fromRational (toRational f)
+todbl u           = baderr
+
+itos n = 
+	if n < 10 then 
+	    [chr (ord '0' + toInt n)]
+	else
+	    let (q, r) = quotRem n 10 in
+	    itos q ++ [chr (ord '0' + toInt r)]
+
+chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
+itosb :: Integer -> Integer -> String
+itosb b n = 
+	if n < b then 
+	    [chars!n]
+	else
+	    let (q, r) = quotRem n b in
+	    itosb b q ++ [chars!r]
+
+stoi :: Int -> String -> (Int, String)
+stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
+stoi a cs                 = (a, cs)
+
+getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
+getSpecs l z ('-':cs) us = getSpecs True z cs us
+getSpecs l z ('0':cs) us = getSpecs l True cs us
+getSpecs l z ('*':cs) us = unimpl
+getSpecs l z cs@(c:_) us | isDigit c =
+	let (n, cs') = stoi 0 cs
+	    (p, cs'') = case cs' of
+			'.':r -> stoi 0 r
+			_     -> (-1, cs')
+	in  (n, p, l, z, cs'', us)
+getSpecs l z cs       us = (0, -1, l, z, cs, us)
+
+-- jcp: I don't know what the lml function fmtf does.  Someone needs to
+-- rewrite this.
+
+{-
+dfmt c p d = 
+	case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
+	'-':cs -> ("-", cs)
+	cs     -> ("" , cs)
+-}
+dfmt = error "fmtf not implemented"
+
+perror s = error ("Printf.printf: "++s)
+fmterr = perror "formatting string ended prematurely"
+argerr = perror "argument list ended prematurely"
+baderr = perror "bad argument"
+
+-- This is needed because standard Haskell does not have toInt
+
+toInt :: Integral a => a -> Int
+toInt x = fromIntegral x
diff --git a/progs/lib/hbc/Printf.hu b/progs/lib/hbc/Printf.hu
new file mode 100644
index 0000000..d94f5b1
--- /dev/null
+++ b/progs/lib/hbc/Printf.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Printf.hs
diff --git a/progs/lib/hbc/QSort.hs b/progs/lib/hbc/QSort.hs
new file mode 100644
index 0000000..f19eb43
--- /dev/null
+++ b/progs/lib/hbc/QSort.hs
@@ -0,0 +1,47 @@
+{-
+   This module implements a sort function using a variation on
+   quicksort.  It is stable, uses no concatenation and compares
+   only with <=.
+  
+   sortLe sorts with a given predicate
+   sort   uses the <= method
+  
+   Author: Lennart Augustsson
+-}
+
+module QSort(sortLe, sort) where
+sortLe :: (a -> a -> Bool) -> [a] -> [a]
+sortLe le l = qsort le   l []
+
+sort :: (Ord a) => [a] -> [a]
+sort      l = qsort (<=) l []
+
+-- qsort is stable and does not concatenate.
+qsort le []     r = r
+qsort le [x]    r = x:r
+qsort le (x:xs) r = qpart le x xs [] [] r
+
+-- qpart partitions and sorts the sublists
+qpart le x [] rlt rge r =
+    -- rlt and rge are in reverse order and must be sorted with an
+    -- anti-stable sorting
+    rqsort le rlt (x:rqsort le rge r)
+qpart le x (y:ys) rlt rge r =
+    if le x y then
+	qpart le x ys rlt (y:rge) r
+    else
+	qpart le x ys (y:rlt) rge r
+
+-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
+rqsort le []     r = r
+rqsort le [x]    r = x:r
+rqsort le (x:xs) r = rqpart le x xs [] [] r
+
+rqpart le x [] rle rgt r =
+    qsort le rle (x:qsort le rgt r)
+rqpart le x (y:ys) rle rgt r =
+    if le y x then
+	rqpart le x ys (y:rle) rgt r
+    else
+	rqpart le x ys rle (y:rgt) r
+
diff --git a/progs/lib/hbc/QSort.hu b/progs/lib/hbc/QSort.hu
new file mode 100644
index 0000000..9a07dd1
--- /dev/null
+++ b/progs/lib/hbc/QSort.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+QSort.hs
diff --git a/progs/lib/hbc/README b/progs/lib/hbc/README
new file mode 100644
index 0000000..c51452a
--- /dev/null
+++ b/progs/lib/hbc/README
@@ -0,0 +1,97 @@
+These libraries are adapted from the lml library.  Also included are a number
+of Common Lisp functions.
+
+The hbc library contains the following modules and functions:
+
+* module Either
+    binary sum data type
+	data Either a b = Left a | Right b
+    constructor Left typically used for errors
+
+* module Option
+    type for success or failure
+	data Option a = None | Some a
+	thenO :: Option a -> (a -> Option b) -> Option b	apply a function that may fail
+
+
+* module ListUtil
+    Various useful functions involving lists that are missing from the Prelude
+	assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
+		assoc f d l k looks for k in the association list l, if it is found f is applied to the value, otherwise d is returned
+	concatMap :: (a -> [b]) -> [a] -> [b]
+		flattening map (LMLs concmap)
+	unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
+		unfoldr f p x repeatedly applies f to x until (p x) holds. (f x) should give a list element and a new x
+	mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+		mapAccuml f s l  maps f over l, but also threads the state s though (LMLs mapstate)
+	union :: (Eq a) => [a] -> [a] -> [a]
+		unions of two lists
+	intersection :: (Eq a) => [a] -> [a] -> [a]
+		intersection of two lists
+	chopList :: ([a] -> (b, [a])) -> [a] -> [b]
+		LMLs choplist
+	assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
+		LMLs assocdef
+	lookup :: (Eq a) => [(a, b)] -> a -> Option b
+		lookup l k looks for the key k in the association list l and returns an optional value
+
+* module Pretty
+    John Hughes pretty printing library.	
+	type Context = (Bool, Int, Int, Int)
+	type IText = Context -> [String]
+	text :: String -> IText				just text
+	(~.) :: IText -> IText -> IText			horizontal composition
+	(^.) :: IText -> IText -> IText			vertical composition
+	separate :: [IText] -> IText			separate by spaces
+	nest :: Int -> IText -> IText			indent
+	pretty :: Int -> Int -> IText -> String		format it
+
+* module QSort
+    Sort function using quicksort.
+	sortLe :: (a -> a -> Bool) -> [a] -> [a]	sort le l  sorts l with le as less than predicate
+	sort :: (Ord a) => [a] -> [a]			sort l  sorts l using the Ord class
+
+* module Random
+    Random numbers.
+	randomInts :: Int -> Int -> [Int]		given two seeds gives a list of random Int
+	randomDoubles :: Int -> Int -> [Double]		given two seeds gives a list of random Double
+
+* module RunDialogue
+    Test run programs of type Dialogue.
+    Only a few Requests are implemented, unfortunately not ReadChannel.
+	run :: Dialogue -> String			just run the program, showing the output
+	runTrace :: Dialogue -> String			run the program, showing each Request and Response
+
+* module Miranda
+    Functions found in the Miranda(tm) library.
+
+* module Printf
+    C printf style formatting.  Handles same types as printf in C, but requires the arguments
+    to be tagged.  Useful for formatting of floating point values.
+	data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
+	printf :: String -> [UPrintf] -> String		convert arguments in the list according to the formatting string
+
+
+* module Time
+    Manipulate time values (a Double with seconds since 1970).
+	--               year mon  day  hour min  sec  dec-sec  weekday
+	data Time = Time Int  Int  Int  Int  Int  Int  Double  Int
+	dblToTime :: Double -> Time			convert a Double to a Time
+	timeToDbl :: Time -> Double			convert a Time to a Double
+	timeToString :: Time -> String			convert a Time to a readable String
+
+-----  To add:
+
+Bytes
+IO Library
+Word oprtations
+Time clock stuff
+Lisp stuff: symbols
+            hashtables
+            strings
+
+
+
+
+
+
diff --git a/progs/lib/hbc/Random.hs b/progs/lib/hbc/Random.hs
new file mode 100644
index 0000000..269d6af
--- /dev/null
+++ b/progs/lib/hbc/Random.hs
@@ -0,0 +1,52 @@
+{-
+   This module implements a (good) random number generator.
+
+   The June 1988 (v31 #6) issue of the Communications of the ACM has an
+   article by Pierre L'Ecuyer called, "Efficient and Portable Combined
+   Random Number Generators".  Here is the Portable Combined Generator of
+   L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
+
+   Transliterator: Lennart Augustsson
+-}
+
+module Random(randomInts, randomDoubles) where
+-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate
+-- an infinite list of random Ints.
+randomInts :: Int -> Int -> [Int]
+randomInts s1 s2 =
+    if 1 <= s1 && s1 <= 2147483562 then
+	if 1 <= s2 && s2 <= 2147483398 then
+	    rands s1 s2
+	else
+	    error "randomInts: Bad second seed."
+    else
+	error "randomInts: Bad first seed."
+
+rands :: Int -> Int -> [Int]
+rands s1 s2 =
+    let
+	k    = s1 `div` 53668
+	s1'  = 40014 * (s1 - k * 53668) - k * 12211
+	s1'' = if s1' < 0 then s1' + 2147483563 else s1'
+    
+	k'   = s2 `div` 52774
+	s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
+	s2'' = if s2' < 0 then s2' + 2147483399 else s2'
+
+	z    = s1'' - s2''
+{-
+	z'   = if z < 1 then z + 2147483562 else z
+
+    in  z' : rands s1'' s2''
+-}
+-- Use this instead; it is a little stricter and generates much better code
+    in  if z < 1 then z + 2147483562 : rands s1'' s2'' 
+                 else z : rands s1'' s2''
+
+-- For those of you who don't have fromInt
+fromInt = fromInteger . toInteger
+
+-- Same values for s1 and s2 as above, generates an infinite
+-- list of Doubles uniformly distibuted in (0,1).
+randomDoubles :: Int -> Int -> [Double]
+randomDoubles s1 s2 = map (\x -> fromInt x * 4.6566130638969828e-10) (randomInts s1 s2)
diff --git a/progs/lib/hbc/Random.hu b/progs/lib/hbc/Random.hu
new file mode 100644
index 0000000..9fff34e
--- /dev/null
+++ b/progs/lib/hbc/Random.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Random.hs
diff --git a/progs/lib/hbc/Time.hs b/progs/lib/hbc/Time.hs
new file mode 100644
index 0000000..29f3441
--- /dev/null
+++ b/progs/lib/hbc/Time.hs
@@ -0,0 +1,51 @@
+module Time(Time(..), dblToTime, timeToDbl, timeToString) where
+--               year mon  day  hour min  sec  ...    wday
+data Time = Time Int  Int  Int  Int  Int  Int  Double Int deriving (Eq, Ord, Text)
+
+isleap :: Int -> Bool
+isleap n = n `rem` 4 == 0			-- good enough for the UNIX time span
+
+daysin :: Int -> Int
+daysin n = if isleap n then 366 else 365
+
+monthlen :: Array (Bool, Int) Int
+monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> (a,b):=c) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++
+					   zipWith3 (\ a b c -> (a,b):=c) (repeat True)  [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31])
+
+-- Time zone offset in minutes
+tzOffset = 120		-- Swedish DST
+
+dblToTime :: Double -> Time
+dblToTime d = 
+	let t = truncate d :: Int
+	    offset       = tzOffset		-- timezone
+	    (days, rem)  = (t+offset*60) `quotRem` (60*60*24)
+	    (hour, rem') = rem `quotRem` (60*60)
+	    (min,  sec)  = rem' `quotRem` 60
+	    wday         = (days+3) `mod` 7
+	    (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days)
+	    (mon, day)   = until (\ (m, d) -> d <= monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days')
+	in  Time year mon (day+1) hour min sec (d - fromInt t) wday
+
+timeToDbl :: Time -> Double
+timeToDbl (Time year mon day hour min sec sdec _) =
+	let year'  = year - 1970
+	    offset = tzOffset		-- timezone
+	    days   = year' * 365 + (year'+1) `div` 4 + 
+		     sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1
+            secs   = ((days*24 + hour) * 60 + min - offset) * 60 + sec
+        in  fromInt secs + sdec
+
+show2 :: Int -> String
+show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')]
+
+weekdays = ["Mon","Tue","Wen","Thu","Fri","Sat","Sun"]
+
+timeToString :: Time -> String
+timeToString (Time year mon day hour min sec sdec wday) =
+	show  year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++
+	show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++ 
+	tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday
+
+-- For those of you who don't have fromInt
+fromInt = fromInteger . toInteger
diff --git a/progs/lib/hbc/Time.hu b/progs/lib/hbc/Time.hu
new file mode 100644
index 0000000..01c8f64
--- /dev/null
+++ b/progs/lib/hbc/Time.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Time.hs
diff --git a/progs/prelude/Prelude.hs b/progs/prelude/Prelude.hs
new file mode 100644
index 0000000..bf20849
--- /dev/null
+++ b/progs/prelude/Prelude.hs
@@ -0,0 +1,187 @@
+-- Standard value bindings
+
+module Prelude (
+    PreludeCore.., PreludeRatio.., PreludeComplex.., PreludeList..,
+    PreludeArray.., PreludeText.., PreludeIO.., 
+    nullBin, isNullBin, appendBin,
+    (&&), (||), not, otherwise,
+    minChar, maxChar, ord, chr, 
+    isAscii, isControl, isPrint, isSpace, 
+    isUpper, isLower, isAlpha, isDigit, isAlphanum,
+    toUpper, toLower,
+    minInt, maxInt, subtract, gcd, lcm, (^), (^^), 
+    fromIntegral, fromRealFrac, atan2,
+    fst, snd, id, const, (.), flip, ($), until, asTypeOf, error ) where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+import PreludePrims
+
+import PreludeCore
+import PreludeList
+import PreludeArray
+import PreludeRatio
+import PreludeComplex
+import PreludeText
+import PreludeIO
+
+infixr 9  .
+infixr 8  ^, ^^
+infixr 3  &&
+infixr 2  ||
+infixr 0  $
+
+
+-- Binary functions
+
+nullBin	    	    	:: Bin
+nullBin	    	    	=  primNullBin
+
+isNullBin    	    	:: Bin -> Bool
+isNullBin    	    	=  primIsNullBin
+
+appendBin		:: Bin -> Bin -> Bin
+appendBin		=  primAppendBin
+
+-- Boolean functions
+
+(&&), (||)		:: Bool -> Bool -> Bool
+True  && x		=  x
+False && _		=  False
+True  || _		=  True
+False || x		=  x
+
+not			:: Bool -> Bool
+not True		=  False
+not False		=  True
+
+{-# (&&)  :: Inline #-}
+{-# (||)  :: Inline #-}
+{-# not  :: Inline #-}
+
+
+otherwise		:: Bool
+otherwise 		=  True
+
+-- Character functions
+
+minChar, maxChar	:: Char
+minChar			= '\0'
+maxChar			= '\255'
+
+ord			:: Char -> Int
+ord 			=  primCharToInt
+
+chr 			:: Int -> Char
+chr 			=  primIntToChar
+
+isAscii, isControl, isPrint, isSpace		:: Char -> Bool
+isUpper, isLower, isAlpha, isDigit, isAlphanum	:: Char -> Bool
+
+isAscii c	 	=  ord c < 128
+isControl c		=  c < ' ' || c == '\DEL'
+isPrint c		=  c >= ' ' && c <= '~'
+isSpace c		=  c == ' ' || c == '\t' || c == '\n' || 
+			   c == '\r' || c == '\f' || c == '\v'
+isUpper c		=  c >= 'A' && c <= 'Z'
+isLower c		=  c >= 'a' && c <= 'z'
+isAlpha c		=  isUpper c || isLower c
+isDigit c		=  c >= '0' && c <= '9'
+isAlphanum c		=  isAlpha c || isDigit c
+
+
+toUpper, toLower	:: Char -> Char
+toUpper c | isLower c	= chr ((ord c - ord 'a') + ord 'A')
+	  | otherwise	= c
+
+toLower c | isUpper c	= chr ((ord c - ord 'A') + ord 'a')
+	  | otherwise	= c
+
+-- Numeric functions
+
+minInt, maxInt	:: Int
+minInt		=  primMinInt
+maxInt		=  primMaxInt
+
+subtract	:: (Num a) => a -> a -> a
+subtract	=  flip (-)
+
+gcd		:: (Integral a) => a -> a -> a
+gcd 0 0		=  error "gcd{Prelude}: gcd 0 0 is undefined"
+gcd x y		=  gcd' (abs x) (abs y)
+		   where gcd' x 0  =  x
+			 gcd' x y  =  gcd' y (x `rem` y)
+
+lcm		:: (Integral a) => a -> a -> a
+lcm _ 0		=  0
+lcm 0 _		=  0
+lcm x y		=  abs ((x `quot` (gcd x y)) * y)
+
+(^)		:: (Num a, Integral b) => a -> b -> a
+x ^ 0		=  1
+x ^ (n+1)	=  f x n x
+		   where f _ 0 y = y
+		         f x n y = g x n  where
+			           g x n | even n  = g (x*x) (n `quot` 2)
+				         | otherwise = f x (n-1) (x*y)
+_ ^ _		= error "(^){Prelude}: negative exponent"
+
+(^^)		:: (Fractional a, Integral b) => a -> b -> a
+x ^^ n		=  if n >= 0 then x^n else recip (x^(-n))
+
+fromIntegral	:: (Integral a, Num b) => a -> b
+fromIntegral	=  fromInteger . toInteger
+
+fromRealFrac	:: (RealFrac a, Fractional b) => a -> b
+fromRealFrac	=  fromRational . toRational
+
+atan2		:: (RealFloat a) => a -> a -> a
+atan2 y x	=  case (signum y, signum x) of
+			( 0, 1) ->  0
+			( 1, 0) ->  pi/2
+			( 0,-1) ->  pi
+			(-1, 0) -> -pi/2
+			( _, 1) ->  atan (y/x)
+			( _,-1) ->  atan (y/x) + pi
+			( 0, 0) ->  error "atan2{Prelude}: atan2 of origin"
+
+
+-- Some standard functions:
+-- component projections for pairs:
+fst			:: (a,b) -> a
+fst (x,y)		=  x
+
+snd			:: (a,b) -> b
+snd (x,y)		=  y
+
+-- identity function
+id			:: a -> a
+id x			=  x
+
+-- constant function
+const			:: a -> b -> a
+const x _		=  x
+
+-- function composition
+(.)			:: (b -> c) -> (a -> b) -> a -> c
+f . g			=  \ x -> f (g x)
+
+-- flip f  takes its (first) two arguments in the reverse order of f.
+flip			:: (a -> b -> c) -> b -> a -> c
+flip f x y		=  f y x
+
+-- right-associating infix application operator (useful in continuation-
+-- passing style)
+($)			:: (a -> b) -> a -> b
+f $ x			=  f x
+
+-- until p f  yields the result of applying f until p holds.
+until			:: (a -> Bool) -> (a -> a) -> a -> a
+until p f x | p x	=  x
+	    | otherwise =  until p f (f x)
+
+-- asTypeOf is a type-restricted version of const.  It is usually used
+-- as an infix operator, and its typing forces its first argument
+-- (which is usually overloaded) to have the same type as the second.
+asTypeOf		:: a -> a -> a
+asTypeOf		=  const
diff --git a/progs/prelude/Prelude.hu b/progs/prelude/Prelude.hu
new file mode 100644
index 0000000..1ee32ca
--- /dev/null
+++ b/progs/prelude/Prelude.hu
@@ -0,0 +1,16 @@
+:output $PRELUDEBIN/Prelude
+:stable
+:prelude
+PreludePrims.hu
+PreludeArrayPrims.hu
+PreludeTuplePrims.hu
+PreludeIOPrims.hu
+Prelude.hs
+PreludeArray.hs
+PreludeComplex.hs
+PreludeCore.hs
+PreludeIO.hs
+PreludeList.hs
+PreludeRatio.hs
+PreludeText.hs
+PreludeTuple.hs
diff --git a/progs/prelude/PreludeArray.hs b/progs/prelude/PreludeArray.hs
new file mode 100644
index 0000000..a501631
--- /dev/null
+++ b/progs/prelude/PreludeArray.hs
@@ -0,0 +1,201 @@
+module  PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds,
+		     indices, elems, assocs, accumArray, (//), accum, amap,
+		     ixmap
+		   ) where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+-- This module uses some simple techniques with updatable vectors to
+-- avoid vector copying in loops where single threading is obvious.
+-- This is rather fragile and depends on the way the compiler handles
+-- strictness.
+
+import PreludeBltinArray
+
+infixl 9  !
+infixl 9  //
+infix  1  :=
+
+data  Assoc a b =  a := b  deriving (Eq, Ord, Ix, Text, Binary)
+data  (Ix a)    => Array a b = MkArray (a,a) {-#STRICT#-}
+                                       (Vector (Box b)) {-#STRICT#-}
+				       deriving ()
+
+array		:: (Ix a) => (a,a) -> [Assoc a b] -> Array a b
+listArray	:: (Ix a) => (a,a) -> [b] -> Array a b
+(!)		:: (Ix a) => Array a b -> a -> b
+bounds		:: (Ix a) => Array a b -> (a,a)
+indices		:: (Ix a) => Array a b -> [a]
+elems		:: (Ix a) => Array a b -> [b]
+assocs		:: (Ix a) => Array a b -> [Assoc a b]
+accumArray	:: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c]
+			     -> Array a b
+(//)		:: (Ix a) => Array a b -> [Assoc a b] -> Array a b
+accum		:: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c]
+			     -> Array a b
+amap		:: (Ix a) => (b -> c) -> Array a b -> Array a c
+ixmap		:: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
+			     -> Array a c
+
+-- Arrays are a datatype containing a bounds pair and a vector of values.
+-- Uninitialized array elements contain an error value.
+
+-- Primitive vectors now contain only unboxed values.  This permits us to
+-- treat array indexing as an atomic operation without forcing the element
+-- being accessed.  The boxing and unboxing of array elements happens
+-- explicitly using these operations:
+
+data Box a = MkBox a
+unBox (MkBox x) = x
+{-# unBox :: Inline #-}
+
+
+-- Array construction and update using index/value associations share
+-- the same helper function.
+
+array b@(bmin, bmax) ivs =
+  let size = (index b bmax) + 1
+      v = primMakeVector size uninitializedArrayError
+  in (MkArray b (updateArrayIvs b v ivs))
+{-# array :: Inline #-}
+
+a@(MkArray b v) // ivs =
+  let v' = primCopyVector v
+  in (MkArray b (updateArrayIvs b v' ivs))
+{-# (//) :: Inline #-}
+
+updateArrayIvs b v ivs = 
+  let g (i := x) next =  strict1 (primVectorUpdate v (index b i) (MkBox x))
+                                 next
+  in foldr g v ivs
+{-# updateArrayIvs :: Inline #-}
+
+uninitializedArrayError = 
+  MkBox (error "(!){PreludeArray}: uninitialized array element.")
+
+
+-- when mapping a list onto an array, be smart and don't do full index 
+-- computation
+
+listArray b@(bmin, bmax) vs =
+  let size = (index b bmax) + 1
+      v = primMakeVector size uninitializedArrayError
+  in (MkArray b (updateArrayVs size v vs))
+{-# listArray :: Inline #-}
+
+updateArrayVs size v vs =
+  let g x next j = if (j == size)
+                     then v
+		     else strict1 (primVectorUpdate v j (MkBox x))
+		                  (next (j + 1))
+  in foldr g (\ _ -> v) vs 0
+{-# updateArrayVs :: Inline #-}
+
+
+-- Array access
+
+a@(MkArray b v) ! i = unBox (primVectorSel v (index b i))
+{-# (!) :: Inline #-}
+
+bounds (MkArray b _)  = b
+
+indices		      = range . bounds
+
+
+-- Again, when mapping array elements into a list, be smart and don't do 
+-- the full index computation for every element.
+
+elems a@(MkArray b@(bmin, bmax) v) =
+  build (\ c n -> 
+          let size = (index b bmax) + 1
+	      g j  = if (j == size)
+	                then n
+			else c (unBox (primVectorSel v j)) (g (j + 1))
+          -- This strict1 is so size doesn't get inlined and recomputed
+	  -- at every iteration.  It should also force the array argument
+	  -- to be strict.
+          in strict1 size (g 0))
+{-# elems :: Inline #-}
+
+assocs a@(MkArray b@(bmin, bmax) v) =
+  build (\ c n ->
+          let g i next j = let y = unBox (primVectorSel v j)
+                           in c (i := y) (next (j + 1))
+	  in foldr g (\ _ -> n) (range b) 0)
+{-# assocs :: Inline #-}
+
+
+-- accum and accumArray share the same helper function.  The difference is
+-- that accum makes a copy of an existing array and accumArray creates
+-- a new one with all elements initialized to the given value.
+
+accum f a@(MkArray b v) ivs =
+  let v' = primCopyVector v
+  in (MkArray b (accumArrayIvs f b v' ivs))
+{-# accum :: Inline #-}
+
+accumArray f z b@(bmin, bmax) ivs =
+  let size = (index b bmax) + 1
+      v = primMakeVector size (MkBox z)
+  in (MkArray b (accumArrayIvs f b v ivs))
+{-# accumArray :: Inline #-}
+
+
+-- This is a bit tricky.  We need to force the access to the array element
+-- before the update, but not force the thunk that is the value of the
+-- array element unless f is strict.
+
+accumArrayIvs f b v ivs =
+  let g (i := x) next = 
+        let j = index b i
+	    y = primVectorSel v j
+	in strict1
+	     y
+	     (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x)))
+	              next)
+  in foldr g v ivs
+{-# accumArrayIvs :: Inline #-}
+
+
+-- again, be smart and bypass full array indexing on array mapping
+
+amap f a@(MkArray b@(bmin, bmax) v) =
+  let size = (index b bmax) + 1
+      v' = primMakeVector size uninitializedArrayError
+      g j = if (j == size)
+              then v'
+	      else let y = primVectorSel v j
+	           in strict1 (primVectorUpdate v' j (MkBox (f (unBox y))))
+	                      (g (j + 1))
+  in (MkArray b (g 0))
+{-# amap :: Inline #-}
+
+
+-- can't bypass the index computation here since f needs it as an argument
+
+ixmap b f a           = array b [i := a ! f i | i <- range b]
+{-# ixmap :: Inline #-}
+
+
+-- random other stuff
+
+instance  (Ix a, Eq b)  => Eq (Array a b)  where
+    a == a'  	        =  assocs a == assocs a'
+
+instance  (Ix a, Ord b) => Ord (Array a b)  where
+    a <=  a'  	    	=  assocs a <=  assocs a'
+
+instance  (Ix a, Text a, Text b) => Text (Array a b)  where
+    showsPrec p a = showParen (p > 9) (
+		    showString "array " .
+		    shows (bounds a) . showChar ' ' .
+		    shows (assocs a)                  )
+
+    readsPrec p = readParen (p > 9)
+	   (\r -> [(array b as, u) | ("array",s) <- lex r,
+				     (b,t)       <- reads s,
+				     (as,u)      <- reads t   ]
+		  ++
+		  [(listArray b xs, u) | ("listArray",s) <- lex r,
+					 (b,t)           <- reads s,
+					 (xs,u)          <- reads t ])
diff --git a/progs/prelude/PreludeArrayPrims.hi b/progs/prelude/PreludeArrayPrims.hi
new file mode 100644
index 0000000..a8529c0
--- /dev/null
+++ b/progs/prelude/PreludeArrayPrims.hi
@@ -0,0 +1,37 @@
+-- These primitives are used to implement arrays with constant time
+-- access.  There are destructive update routines for arrays for use
+-- internally in functions such as array.  These are impure but are
+-- marked as pure to keep them out of the top level monad.  This should
+-- be redone using lambda-var someday.
+
+interface PreludeBltinArray where
+
+
+data Vector a    -- Used to represent vectors with delayed components
+data Delay a     -- An explicit represenation of a delayed object
+
+
+-- Primitive vectors now always have strict components.  This permits us
+-- to treat array indexing as an atomic operation without the explicit
+-- force on access.
+
+primVectorSel :: Vector a -> Int -> a
+primVectorUpdate :: Vector a -> Int -> a -> a
+primMakeVector :: Int -> a -> Vector a
+primCopyVector :: Vector a -> Vector a
+
+-- These functions are used for explicit sequencing of destructive ops
+
+strict1 :: a -> b -> b
+primForce :: Delay a -> a
+
+{-#
+primVectorSel ::  LispName("prim.vector-sel"), Complexity(1)
+primVectorUpdate :: LispName("prim.vector-update"), Complexity(1)
+primMakeVector :: LispName("prim.make-vector"), Complexity(4)
+primCopyVector :: LispName("prim.copy-vector"), Complexity(5)
+strict1 :: Strictness("S,N"),
+	   LispName("prim.strict1")
+primForce :: LispName("prim.force")
+#-}
+
diff --git a/progs/prelude/PreludeArrayPrims.hu b/progs/prelude/PreludeArrayPrims.hu
new file mode 100644
index 0000000..62ea8ac
--- /dev/null
+++ b/progs/prelude/PreludeArrayPrims.hu
@@ -0,0 +1,4 @@
+:output $PRELUDEBIN/PreludeArrayPrims
+:stable
+:prelude
+PreludeArrayPrims.hi
diff --git a/progs/prelude/PreludeComplex.hs b/progs/prelude/PreludeComplex.hs
new file mode 100644
index 0000000..2044129
--- /dev/null
+++ b/progs/prelude/PreludeComplex.hs
@@ -0,0 +1,94 @@
+-- Complex Numbers
+
+module PreludeComplex where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+infixl  6  :+
+
+data  (RealFloat a)     => Complex a = a {-#STRICT#-} :+ a {-#STRICT #-}
+                               deriving (Eq,Binary,Text)
+
+instance  (RealFloat a) => Num (Complex a)  where
+    (x:+y) + (x':+y')	=  (x+x') :+ (y+y')
+    (x:+y) - (x':+y')	=  (x-x') :+ (y-y')
+    (x:+y) * (x':+y')	=  (x*x'-y*y') :+ (x*y'+y*x')
+    negate (x:+y)	=  negate x :+ negate y
+    abs z		=  magnitude z :+ 0
+    signum 0		=  0
+    signum z@(x:+y)	=  x/r :+ y/r  where r = magnitude z
+    fromInteger n	=  fromInteger n :+ 0
+
+instance  (RealFloat a) => Fractional (Complex a)  where
+    (x:+y) / (x':+y')	=  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+			   where x'' = scaleFloat k x'
+				 y'' = scaleFloat k y'
+				 k   = - max (exponent x') (exponent y')
+				 d   = x'*x'' + y'*y''
+
+    fromRational a	=  fromRational a :+ 0
+
+instance  (RealFloat a) => Floating (Complex a)	where
+    pi             =  pi :+ 0
+    exp (x:+y)     =  expx * cos y :+ expx * sin y
+                      where expx = exp x
+    log z          =  log (magnitude z) :+ phase z
+
+    sqrt 0         =  0
+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
+                      where (u,v) = if x < 0 then (v',u') else (u',v')
+                            v'    = abs y / (u'*2)
+                            u'    = sqrt ((magnitude z + abs x) / 2)
+
+    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+                      where sinx  = sin x
+                            cosx  = cos x
+                            sinhy = sinh y
+                            coshy = cosh y
+
+    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+                      where siny  = sin y
+                            cosy  = cos y
+                            sinhx = sinh x
+                            coshx = cosh x
+
+    asin z@(x:+y)  =  y':+(-x')
+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+    acos z@(x:+y)  =  y'':+(-x'')
+                      where (x'':+y'') = log (z + ((-y'):+x'))
+                            (x':+y')   = sqrt (1 - z*z)
+    atan z@(x:+y)  =  y':+(-x')
+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+
+    asinh z        =  log (z + sqrt (1+z*z))
+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
+    atanh z        =  log ((1+z) / sqrt (1-z*z))
+
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x:+y)	 =  x
+imagPart (x:+y)	 =  y
+
+conjugate	 :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) =  x :+ (-y)
+
+mkPolar		 :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta	 =  r * cos theta :+ r * sin theta
+
+cis		 :: (RealFloat a) => a -> Complex a
+cis theta	 =  cos theta :+ sin theta
+
+polar		 :: (RealFloat a) => Complex a -> (a,a)
+polar z		 =  (magnitude z, phase z)
+
+magnitude, phase :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) =  scaleFloat k
+		     (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
+		    where k  = max (exponent x) (exponent y)
+		          mk = - k
+
+phase (x:+y)	 =  atan2 y x
diff --git a/progs/prelude/PreludeCore.hs b/progs/prelude/PreludeCore.hs
new file mode 100644
index 0000000..f8a7be2
--- /dev/null
+++ b/progs/prelude/PreludeCore.hs
@@ -0,0 +1,817 @@
+-- Standard types, classes, and instances
+
+module PreludeCore (
+    Eq((==), (/=)),
+    Ord((<), (<=), (>=), (>), max, min),
+    Num((+), (-), (*), negate, abs, signum, fromInteger),
+    Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger),
+    Fractional((/), recip, fromRational),
+    Floating(pi, exp, log, sqrt, (**), logBase,
+	     sin, cos, tan, asin, acos, atan,
+	     sinh, cosh, tanh, asinh, acosh, atanh),
+    Real(toRational),
+    RealFrac(properFraction, truncate, round, ceiling, floor),
+    RealFloat(floatRadix, floatDigits, floatRange,
+	      encodeFloat, decodeFloat, exponent, significand, scaleFloat),
+    Ix(range, index, inRange),
+    Enum(enumFrom, enumFromThen, enumFromTo, enumFromThenTo),
+    Text(readsPrec, showsPrec, readList, showList), ReadS(..), ShowS(..),
+    Binary(readBin, showBin),
+--  List type: [_]((:), [])
+--  Tuple types: (_,_), (_,_,_), etc.
+--  Trivial type: () 
+    Bool(True, False),
+    Char, Int, Integer, Float, Double, Bin,
+    Ratio, Complex((:+)), Assoc((:=)), Array,
+    String(..), Rational(..) )  where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+import PreludePrims
+import PreludeText
+import PreludeRatio(Ratio, Rational(..))
+import PreludeComplex(Complex((:+)))
+import PreludeArray(Assoc((:=)), Array)
+import PreludeIO({-Request, Response,-} IOError,
+		 Dialogue(..), SuccCont(..), StrCont(..), 
+		 StrListCont(..), BinCont(..), FailCont(..))
+
+infixr 8  **
+infixl 7  *, /, `quot`, `rem`, `div`, `mod`
+infixl 6  +, -
+infix  4  ==, /=, <, <=, >=, >
+
+
+infixr 5 :
+
+data Int = MkInt
+data Integer = MkInteger
+data Float = MkFloat
+data Double   = MkDouble
+data Char = MkChar
+data Bin = MkBin
+data List a = a : (List a) | Nil deriving (Eq, Ord)
+data Arrow a b = MkArrow a b
+data UnitType = UnitConstructor deriving (Eq, Ord, Ix, Enum, Binary)
+
+-- Equality and Ordered classes
+
+class  Eq a  where
+    (==), (/=)		:: a -> a -> Bool
+
+    x /= y		=  not (x == y)
+
+class  (Eq a) => Ord a  where
+    (<), (<=), (>=), (>):: a -> a -> Bool
+    max, min		:: a -> a -> a
+
+    x <	 y		=  x <= y && x /= y
+    x >= y		=  y <= x
+    x >	 y		=  y <	x
+
+    -- The following default methods are appropriate for partial orders.
+    -- Note that the second guards in each function can be replaced
+    -- by "otherwise" and the error cases, eliminated for total orders.
+    max x y | x >= y	=  x
+	    | y >= x	=  y
+	    |otherwise	=  error "max{PreludeCore}: no ordering relation"
+    min x y | x <= y	=  x
+	    | y <= x	=  y
+	    |otherwise	=  error "min{PreludeCore}: no ordering relation"
+
+
+-- Numeric classes
+
+class  (Eq a, Text a) => Num a  where
+    (+), (-), (*)	:: a -> a -> a
+    negate		:: a -> a
+    abs, signum		:: a -> a
+    fromInteger		:: Integer -> a
+
+    x - y		=  x + negate y
+
+class  (Num a, Enum a) => Real a  where
+    toRational		::  a -> Rational
+
+class  (Real a, Ix a) => Integral a  where
+    quot, rem, div, mod	:: a -> a -> a
+    quotRem, divMod	:: a -> a -> (a,a)
+    even, odd		:: a -> Bool
+    toInteger		:: a -> Integer
+
+    n `quot` d		=  q  where (q,r) = quotRem n d
+    n `rem` d		=  r  where (q,r) = quotRem n d
+    n `div` d		=  q  where (q,r) = divMod n d
+    n `mod` d		=  r  where (q,r) = divMod n d
+    divMod n d 		=  if signum r == - signum d then (q-1, r+d) else qr
+			   where qr@(q,r) = quotRem n d
+    even n		=  n `rem` 2 == 0
+    odd			=  not . even
+
+class  (Num a) => Fractional a  where
+    (/)			:: a -> a -> a
+    recip		:: a -> a
+    fromRational	:: Rational -> a
+
+    recip x		=  1 / x
+
+class  (Fractional a) => Floating a  where
+    pi			:: a
+    exp, log, sqrt	:: a -> a
+    (**), logBase	:: a -> a -> a
+    sin, cos, tan	:: a -> a
+    asin, acos, atan	:: a -> a
+    sinh, cosh, tanh	:: a -> a
+    asinh, acosh, atanh :: a -> a
+
+    x ** y		=  exp (log x * y)
+    logBase x y		=  log y / log x
+    sqrt x		=  x ** 0.5
+    tan  x		=  sin  x / cos  x
+    tanh x		=  sinh x / cosh x
+
+class  (Real a, Fractional a) => RealFrac a  where
+    properFraction	:: (Integral b) => a -> (b,a)
+    truncate, round	:: (Integral b) => a -> b
+    ceiling, floor	:: (Integral b) => a -> b
+
+    truncate x		=  m  where (m,_) = properFraction x
+    
+    round x		=  let (n,r) = properFraction x
+    			       m     = if r < 0 then n - 1 else n + 1
+    			   in case signum (abs r - 0.5) of
+    				-1 -> n
+    			 	0  -> if even n then n else m
+    				1  -> m
+    
+    ceiling x		=  if r > 0 then n + 1 else n
+    			   where (n,r) = properFraction x
+    
+    floor x		=  if r < 0 then n - 1 else n
+    			   where (n,r) = properFraction x
+
+class  (RealFrac a, Floating a) => RealFloat a  where
+    floatRadix		:: a -> Integer
+    floatDigits		:: a -> Int
+    floatRange		:: a -> (Int,Int)
+    decodeFloat		:: a -> (Integer,Int)
+    encodeFloat		:: Integer -> Int -> a
+    exponent		:: a -> Int
+    significand		:: a -> a
+    scaleFloat		:: Int -> a -> a
+
+    exponent x		=  if m == 0 then 0 else n + floatDigits x
+			   where (m,n) = decodeFloat x
+
+    significand x	=  encodeFloat m (- floatDigits x)
+			   where (m,_) = decodeFloat x
+
+    scaleFloat k x	=  encodeFloat m (n+k)
+			   where (m,n) = decodeFloat x
+
+
+-- Index and Enumeration classes
+
+class  (Ord a, Text a) => Ix a  where   -- This is a Yale modification
+    range		:: (a,a) -> [a]
+    index		:: (a,a) -> a -> Int
+    inRange		:: (a,a) -> a -> Bool
+
+class  (Ord a) => Enum a	where
+    enumFrom		:: a -> [a]		-- [n..]
+    enumFromThen	:: a -> a -> [a]	-- [n,n'..]
+    enumFromTo		:: a -> a -> [a]	-- [n..m]
+    enumFromThenTo	:: a -> a -> a -> [a]	-- [n,n'..m]
+
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+
+defaultEnumFromTo n m	=  takeWhile (<= m) (enumFrom n)
+defaultEnumFromThenTo n n' m
+			=  takeWhile (if n' >= n then (<= m) else (>= m))
+				     (enumFromThen n n')
+{-# defaultEnumFromTo :: Inline #-}
+{-# defaultEnumFromThenTo :: Inline #-}
+
+-- Text class
+
+type  ReadS a = String -> [(a,String)]
+type  ShowS   = String -> String
+
+class  Text a  where
+    readsPrec :: Int -> ReadS a
+    showsPrec :: Int -> a -> ShowS
+    readList  :: ReadS [a]
+    showList  :: [a] -> ShowS
+
+    readList    = readParen False (\r -> [pr | ("[",s)	<- lex r,
+					       pr	<- readl s])
+	          where readl  s = [([],t)   | ("]",t)  <- lex s] ++
+				   [(x:xs,u) | (x,t)    <- reads s,
+					       (xs,u)   <- readl' t]
+			readl' s = [([],t)   | ("]",t)  <- lex s] ++
+			           [(x:xs,v) | (",",t)  <- lex s,
+					       (x,u)	<- reads t,
+					       (xs,v)   <- readl' u]
+    showList []	= showString "[]"
+    showList (x:xs)
+		= showChar '[' . shows x . showl xs
+		  where showl []     = showChar ']'
+			showl (x:xs) = showString ", " . shows x . showl xs
+
+
+
+-- Binary class
+
+class  Binary a  where
+    readBin		:: Bin -> (a,Bin)
+    showBin		:: a -> Bin -> Bin
+
+
+-- Trivial type
+
+-- data  ()  =  ()  deriving (Eq, Ord, Ix, Enum, Binary)
+
+instance  Text ()  where
+    readsPrec p    = readParen False
+    	    	    	    (\r -> [((),t) | ("(",s) <- lex r,
+					     (")",t) <- lex s ] )
+    showsPrec p () = showString "()"
+
+
+-- Binary type
+
+instance  Text Bin  where
+    readsPrec p s  =  error "readsPrec{PreludeText}: Cannot read Bin."
+    showsPrec p b  =  showString "<<Bin>>"
+
+
+-- Boolean type
+
+data  Bool  =  False | True	deriving (Eq, Ord, Ix, Enum, Text, Binary)
+
+
+-- Character type
+
+instance  Eq Char  where
+    (==)		=  primEqChar
+    (/=)                =  primNeqChar
+
+instance  Ord Char  where
+    (<)                 =  primLsChar
+    (<=)		=  primLeChar
+    (>)                 =  primGtChar
+    (>=)                =  primGeChar
+
+instance  Ix Char  where
+    range (c,c')	=  [c..c']
+    index b@(c,c') ci
+	| inRange b ci	=  ord ci - ord c
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
+    inRange (c,c') ci	=  ord c <= i && i <= ord c'
+			   where i = ord ci
+    {-# range :: Inline #-}
+
+instance  Enum Char  where
+    enumFrom		= charEnumFrom
+    enumFromThen        = charEnumFromThen
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+    {-# enumFrom :: Inline #-}
+    {-# enumFromThen :: Inline #-}
+    {-# enumFromTo :: Inline #-}
+    {-# enumFromThenTo :: Inline #-}
+
+charEnumFrom c		=  map chr [ord c .. ord maxChar]
+charEnumFromThen c c'	=  map chr [ord c, ord c' .. ord lastChar]
+			   where lastChar = if c' < c then minChar else maxChar
+{-# charEnumFrom :: Inline #-}
+{-# charEnumFromThen :: Inline #-}
+
+instance  Text Char  where
+    readsPrec p      = readParen False
+    	    	    	    (\r -> [(c,t) | ('\'':s,t)<- lex r,
+					    (c,_)     <- readLitChar s])
+
+    showsPrec p '\'' = showString "'\\''"
+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
+
+    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+					       (l,_)      <- readl s ])
+	       where readl ('"':s)	= [("",s)]
+		     readl ('\\':'&':s)	= readl s
+		     readl s		= [(c:cs,u) | (c ,t) <- readLitChar s,
+						      (cs,u) <- readl t	      ]
+
+    showList cs = showChar '"' . showl cs
+		 where showl ""       = showChar '"'
+		       showl ('"':cs) = showString "\\\"" . showl cs
+		       showl (c:cs)   = showLitChar c . showl cs
+
+type  String = [Char]
+
+
+-- Standard Integral types
+
+instance  Eq Int  where
+    (==)		=  primEqInt
+    (/=)                =  primNeqInt
+
+instance  Eq Integer  where
+    (==)		=  primEqInteger
+    (/=)                =  primNeqInteger
+
+instance  Ord Int  where
+    (<)                 =  primLsInt
+    (<=)		=  primLeInt
+    (>)                 =  primGtInt
+    (>=)                =  primGeInt
+    max                 =  primIntMax
+    min                 =  primIntMin
+
+instance  Ord Integer  where
+    (<)                 =  primLsInteger
+    (<=)		=  primLeInteger
+    (>)                 =  primGtInteger
+    (>=)                =  primGeInteger
+    max                 =  primIntegerMax
+    min                 =  primIntegerMin
+
+instance  Num Int  where
+    (+)			=  primPlusInt
+    (-)                 =  primMinusInt
+    negate		=  primNegInt
+    (*)			=  primMulInt
+    abs			=  primAbsInt
+    signum		=  signumReal
+    fromInteger		=  primIntegerToInt
+
+instance  Num Integer  where
+    (+)			=  primPlusInteger
+    (-)                 =  primMinusInteger
+    negate		=  primNegInteger
+    (*)			=  primMulInteger
+    abs			=  primAbsInteger
+    signum		=  signumReal
+    fromInteger x	=  x
+    
+signumReal x | x == 0	 =  0
+   	     | x > 0	 =  1
+	     | otherwise = -1
+
+instance  Real Int  where
+    toRational x	=  toInteger x % 1
+
+instance  Real Integer	where
+    toRational x	=  x % 1
+
+instance  Integral Int	where
+    quotRem		=  primQuotRemInt
+    toInteger		=  primIntToInteger
+
+instance  Integral Integer  where
+    quotRem		=  primQuotRemInteger
+    toInteger x		=  x
+
+instance  Ix Int  where
+    range (m,n)		=  [m..n]
+    index b@(m,n) i
+	| inRange b i	=  i - m
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
+    inRange (m,n) i	=  m <= i && i <= n
+    {-# range :: Inline #-}
+
+instance  Ix Integer  where
+    range (m,n)		=  [m..n]
+    index b@(m,n) i
+	| inRange b i	=  fromInteger (i - m)
+	| otherwise	=  error "index{PreludeCore}: Index out of range."
+    inRange (m,n) i	=  m <= i && i <= n
+    {-# range :: Inline #-}
+
+instance  Enum Int  where
+    enumFrom		=  numericEnumFrom
+    enumFromThen	=  numericEnumFromThen
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+    {-# enumFrom :: Inline #-}
+    {-# enumFromThen :: Inline #-}
+    {-# enumFromTo :: Inline #-}
+    {-# enumFromThenTo :: Inline #-}
+
+instance  Enum Integer  where
+    enumFrom		=  numericEnumFrom
+    enumFromThen	=  numericEnumFromThen
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+    {-# enumFrom :: Inline #-}
+    {-# enumFromThen :: Inline #-}
+    {-# enumFromTo :: Inline #-}
+    {-# enumFromThenTo :: Inline #-}
+
+numericEnumFrom		:: (Real a) => a -> [a]
+numericEnumFromThen	:: (Real a) => a -> a -> [a]
+numericEnumFrom		=  iterate (+1)
+numericEnumFromThen n m	=  iterate (+(m-n)) n
+
+{-# numericEnumFrom :: Inline #-}
+{-# numericEnumFromThen :: Inline #-}
+
+
+instance  Text Int  where
+    readsPrec p		= readSigned readDec
+    showsPrec   	= showSigned showInt
+
+instance  Text Integer  where
+    readsPrec p 	= readSigned readDec
+    showsPrec		= showSigned showInt
+
+
+-- Standard Floating types
+
+instance  Eq Float  where
+    (==)		=  primEqFloat
+    (/=)                =  primNeqFloat
+
+instance  Eq Double  where
+    (==)		=  primEqDouble
+    (/=)                =  primNeqDouble
+
+instance  Ord Float  where
+    (<)                 =  primLsFloat
+    (<=)		=  primLeFloat
+    (>)                 =  primGtFloat
+    (>=)                =  primGeFloat
+    max                 =  primFloatMax
+    min                 =  primFloatMin
+
+instance  Ord Double  where
+    (<)                 =  primLsDouble
+    (<=)		=  primLeDouble
+    (>)                 =  primGtDouble
+    (>=)                =  primGeDouble
+    max                 =  primDoubleMax
+    min                 =  primDoubleMax
+
+instance  Num Float  where
+    (+)			=  primPlusFloat
+    (-)                 =  primMinusFloat
+    negate		=  primNegFloat
+    (*)			=  primMulFloat
+    abs			=  primAbsFloat
+    signum		=  signumReal
+    fromInteger n	=  encodeFloat n 0
+
+instance  Num Double  where
+    (+)			=  primPlusDouble
+    (-)                 =  primMinusDouble
+    negate		=  primNegDouble
+    (*)			=  primMulDouble
+    abs			=  primAbsDouble
+    signum		=  signumReal
+    fromInteger n	=  encodeFloat n 0
+
+instance  Real Float  where
+    toRational		=  primFloatToRational
+
+instance  Real Double  where
+    toRational		=  primDoubleToRational
+
+-- realFloatToRational x	=  (m%1)*(b%1)^^n
+--	 		   where (m,n) = decodeFloat x
+-- 				 b     = floatRadix  x
+
+instance  Fractional Float  where
+    (/)			=  primDivFloat
+    fromRational        =  primRationalToFloat
+--    fromRational	=  rationalToRealFloat
+
+instance  Fractional Double  where
+    (/)			=  primDivDouble
+    fromRational        =  primRationalToDouble
+--    fromRational	=  rationalToRealFloat
+
+-- rationalToRealFloat x	= x'
+--         where x'    = f e
+--               f e   = if e' == e then y else f e'
+--                       where y      = encodeFloat (round (x * (1%b)^^e)) e
+--                             (_,e') = decodeFloat y
+--               (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+--                                         / fromInteger (denominator x))
+--               b     = floatRadix x'
+
+instance  Floating Float  where
+    pi			=  primPiFloat
+    exp			=  primExpFloat
+    log			=  primLogFloat
+    sqrt		=  primSqrtFloat
+    sin			=  primSinFloat
+    cos			=  primCosFloat
+    tan			=  primTanFloat
+    asin		=  primAsinFloat
+    acos		=  primAcosFloat
+    atan		=  primAtanFloat
+    sinh		=  primSinhFloat
+    cosh		=  primCoshFloat
+    tanh		=  primTanhFloat
+    asinh		=  primAsinhFloat
+    acosh		=  primAcoshFloat
+    atanh		=  primAtanhFloat
+
+instance  Floating Double  where
+    pi			=  primPiDouble
+    exp			=  primExpDouble
+    log			=  primLogDouble
+    sqrt		=  primSqrtDouble
+    sin			=  primSinDouble
+    cos			=  primCosDouble
+    tan			=  primTanDouble
+    asin		=  primAsinDouble
+    acos		=  primAcosDouble
+    atan		=  primAtanDouble
+    sinh		=  primSinhDouble
+    cosh		=  primCoshDouble
+    tanh		=  primTanhDouble
+    asinh		=  primAsinhDouble
+    acosh		=  primAcoshDouble
+    atanh		=  primAtanhDouble
+
+
+instance  RealFrac Float  where
+    properFraction	=  floatProperFraction
+
+instance  RealFrac Double  where
+    properFraction	=  floatProperFraction
+
+floatProperFraction x
+	| n >= 0	=  (fromInteger m * fromInteger b ^ n, 0)
+	| otherwise	=  (fromInteger w, encodeFloat r n)
+			where (m,n) = decodeFloat x
+			      b     = floatRadix x
+			      (w,r) = quotRem m (b^(-n))
+
+instance  RealFloat Float  where
+    floatRadix _	=  primFloatRadix
+    floatDigits _	=  primFloatDigits
+    floatRange _	=  (primFloatMinExp,primFloatMaxExp)
+    decodeFloat		=  primDecodeFloat
+    encodeFloat		=  primEncodeFloat
+
+instance  RealFloat Double  where
+    floatRadix _	=  primDoubleRadix
+    floatDigits	_	=  primDoubleDigits
+    floatRange _	=  (primDoubleMinExp,primDoubleMaxExp)
+    decodeFloat		=  primDecodeDouble
+    encodeFloat		=  primEncodeDouble
+
+instance  Enum Float  where
+    enumFrom		=  numericEnumFrom
+    enumFromThen	=  numericEnumFromThen
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+    {-# enumFrom :: Inline #-}
+    {-# enumFromThen :: Inline #-}
+    {-# enumFromTo :: Inline #-}
+    {-# enumFromThenTo :: Inline #-}
+
+instance  Enum Double  where
+    enumFrom		=  numericEnumFrom
+    enumFromThen	=  numericEnumFromThen
+    enumFromTo          = defaultEnumFromTo
+    enumFromThenTo      = defaultEnumFromThenTo
+    {-# enumFrom :: Inline #-}
+    {-# enumFromThen :: Inline #-}
+    {-# enumFromTo :: Inline #-}
+    {-# enumFromThenTo :: Inline #-}
+
+instance  Text Float  where
+    readsPrec p		= readSigned readFloat
+    showsPrec   	= showSigned showFloat
+
+instance  Text Double  where
+    readsPrec p		= readSigned readFloat
+    showsPrec   	= showSigned showFloat
+
+
+-- Lists
+
+-- data  [a]  =  [] | a : [a]  deriving (Eq, Ord, Binary)
+
+instance  (Text a) => Text [a]  where
+    readsPrec p		= readList
+    showsPrec p		= showList
+
+
+-- Tuples
+
+-- data  (a,b)  =  (a,b)  deriving (Eq, Ord, Ix, Binary)
+{-
+instance  (Text a, Text b) => Text (a,b)  where
+    readsPrec p = readParen False
+    	    	    	    (\r -> [((x,y), w) | ("(",s) <- lex r,
+						 (x,t)   <- reads s,
+						 (",",u) <- lex t,
+						 (y,v)   <- reads u,
+						 (")",w) <- lex v ] )
+
+    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
+    	    	    	    	       shows y . showChar ')'
+-- et cetera
+-}
+
+-- Functions
+
+instance  Text (a -> b)  where
+    readsPrec p s  =  error "readsPrec{PreludeCore}: Cannot read functions."
+    showsPrec p f  =  showString "<<function>>"
+
+-- Support for class Bin
+
+instance Binary Int where
+  showBin i b = primShowBinInt i b
+  readBin b = primReadBinInt b
+
+instance Binary Integer where
+  showBin i b = primShowBinInteger i b
+  readBin b = primReadBinInteger b
+
+instance Binary Float where
+  showBin f b = primShowBinFloat f b
+  readBin b = primReadBinFloat b
+
+instance Binary Double where
+  showBin d b = primShowBinDouble d b
+  readBin b = primReadBinDouble b
+
+instance Binary Char where
+  showBin c b = primShowBinInt (ord c) b
+  readBin b = (chr i,b') where
+     (i,b') = primReadBinSmallInt b primMaxChar 
+
+instance (Binary a) => Binary [a]  where
+    showBin l b = showBin (length l :: Int) (sb1 l b) where
+      sb1 [] b = b
+      sb1 (h:t) b = showBin h (sb1 t b)
+    readBin bin = rbl len bin' where
+       len :: Int
+       (len,bin') = readBin bin
+       rbl 0 b = ([],b)
+       rbl n b = (h:t,b'') where
+         (h,b') = readBin b
+         (t,b'') = rbl (n-1) b'
+
+instance  (Ix a, Binary a, Binary b) => Binary (Array a b)  where
+    showBin a = showBin (bounds a) . showBin (elems a)
+    readBin bin = (listArray b vs, bin'')
+		 where (b,bin')   = readBin bin
+		       (vs,bin'') = readBin bin'
+
+{-
+instance (Binary a, Binary b) => Binary (a,b) where
+  showBin (x,y) = (showBin x) . (showBin y)
+  readBin b = ((x,y),b'') where
+                (x,b') = readBin b
+                (y,b'') = readBin b'
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+  showBin (x,y,z) = (showBin x) . (showBin y) . (showBin z)
+  readBin b = ((x,y,z),b3) where
+                (x,b1) = readBin b
+                (y,b2) = readBin b1
+	        (z,b3) = readBin b2
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+  showBin (a,b,c,d) = (showBin a) . (showBin b) . (showBin c) . (showBin d)
+  readBin b = ((a1,a2,a3,a4),b4) where
+                (a1,b1) = readBin b
+                (a2,b2) = readBin b1
+	        (a3,b3) = readBin b2
+	        (a4,b4) = readBin b3
+-}
+--   Instances for tuples
+
+-- This whole section should be handled in the support code.  For now,
+-- only tuple instances expliticly provided here are available.
+-- Currently provided:
+
+-- 2,3 tuples: all classes (Eq, Ord, Ix, Bin, Text)
+-- 4 tuples: Eq, Bin, Text
+-- 5, 6 tuples: Text (printing only)
+
+{- 
+rangeSize               :: (Ix a) => (a,a) -> Int
+rangeSize (l,u)         =  index (l,u) u + 1
+
+instance (Eq a1, Eq a2) => Eq (a1,a2) where
+  (a1,a2) == (z1,z2) = a1==z1 && a2==z2
+
+instance (Ord a1, Ord a2) => Ord (a1,a2) where
+  (a1,a2) <= (z1,z2) = a1<=z1 || a1==z1 && a2<=z2 
+  (a1,a2) <  (z1,z2) = a1<z1  || a1==z1 && a2<z2
+
+instance (Ix a1, Ix a2) => Ix (a1,a2) where
+  range ((l1,l2),(u1,u2)) = [(i1,i2) | i1 <- range(l1,u1),
+                                       i2 <- range(l2,u2)]
+  index ((l1,l2),(u1,u2)) (i1,i2) = 
+    index (l1,u1) i1 * rangeSize (l2,u2)
+    + index (l2,u2) i2
+  inRange ((l1,l2),(u1,u2)) (i1,i2) =
+    inRange (l1,u1) i1 && inRange (l2,u2) i2
+
+{-    Apprears in Joe's code.
+instance (Text a1, Text a2) => Text (a1,a2) where
+  readsPrec p = readParen False
+                          (\r0 -> [((a1,a2), w) | ("(",r1) <- lex r0,
+                                                  (a1,r2)  <- reads r1,
+                                                  (",",r3) <- lex r2,
+                                                  (a2,r4)  <- reads r3,
+                                                  (")",w)  <- lex r4 ])
+
+  showsPrec p (a1,a2) = showChar '(' . shows a1 . showChar ',' .
+                                       shows a2 . showChar ')'
+-}
+
+instance (Eq a1, Eq a2, Eq a3) => Eq (a1,a2,a3) where
+  (a1,a2,a3) == (z1,z2,z3) = a1==z1 && a2==z2 && a3==z3
+
+instance (Ord a1, Ord a2, Ord a3) => Ord (a1,a2,a3) where
+  (a1,a2,a3) <= (z1,z2,z3) = a1<=z1 || a1==z1 && 
+			      (a2<=z2 || a2==z2 &&
+				a3<=z3)
+  (a1,a2,a3) <  (z1,z2,z3) = a1<z1  || a1==z1 &&
+   			      (a2<z2 || a2==z2 &&
+           			a3<z3)
+
+
+instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where
+  range ((l1,l2,l3),(u1,u2,u3)) = 
+     [(i1,i2,i3) | i1 <- range(l1,u1),
+                   i2 <- range(l2,u2),
+                   i3 <- range(l3,u3)]
+  index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = 
+    (index (l1,u1) i1 * rangeSize (l2,u2)
+     + index (l2,u2) i2 ) * rangeSize (l3,u3)
+     + index (l3,u3) i3
+  inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) =
+    inRange (l1,u1) i1 && inRange (l2,u2) i2 && inRange (l3,u3) i3
+
+
+instance (Text a1, Text a2, Text a3) => Text (a1,a2,a3) where
+  readsPrec p = readParen False
+                          (\r0 -> [((a1,a2,a3), w) |
+                                                  ("(",r1) <- lex r0,
+                                                  (a1,r2)  <- reads r1,
+                                                  (",",r3) <- lex r2,
+                                                  (a2,r4)  <- reads r3,
+                                                  (",",r5) <- lex r4,
+                                                  (a3,r6)  <- reads r5,
+                                                  (")",w)  <- lex r6 ])
+  showsPrec p (a1,a2,a3) = 
+                        showChar '(' . shows a1 . showChar ',' .
+                                       shows a2 . showChar ',' .
+                                       shows a3 . showChar ')'
+
+instance (Eq a1, Eq a2, Eq a3, Eq a4) => Eq (a1,a2,a3,a4) where
+  (a1,a2,a3,a4) == (z1,z2,z3,z4) = a1==z1 && a2==z2 && a3==z3 && a4 == z4
+
+instance (Text a1, Text a2, Text a3, Text a4) => Text (a1,a2,a3,a4) where
+  readsPrec p = readParen False
+                          (\r0 -> [((a1,a2,a3,a4), w) |
+                                                  ("(",r1) <- lex r0,
+                                                  (a1,r2)  <- reads r1,
+                                                  (",",r3) <- lex r2,
+                                                  (a2,r4)  <- reads r3,
+                                                  (",",r5) <- lex r4,
+                                                  (a3,r6)  <- reads r5,
+	                                          (",",r7) <- lex r6,
+						  (a4,r8)  <- reads r7,
+                                                  (")",w)  <- lex r8 ])
+  showsPrec p (a1,a2,a3,a4) = 
+                        showChar '(' . shows a1 . showChar ',' .
+                                       shows a2 . showChar ',' .
+                                       shows a3 . showChar ',' .
+                                       shows a4 . showChar ')'
+
+instance (Text a1, Text a2, Text a3, Text a4, Text a5) =>
+      Text (a1,a2,a3,a4,a5) where
+  readsPrec p = error "Read of 5 tuples not implemented"
+  showsPrec p (a1,a2,a3,a4,a5) = 
+                        showChar '(' . shows a1 . showChar ',' .
+                                       shows a2 . showChar ',' .
+                                       shows a3 . showChar ',' .
+                                       shows a4 . showChar ',' .
+                                       shows a5 . showChar ')'
+
+instance (Text a1, Text a2, Text a3, Text a4, Text a5, Text a6) =>
+      Text (a1,a2,a3,a4,a5,a6) where
+  readsPrec p = error "Read of 6 tuples not implemented"
+  showsPrec p (a1,a2,a3,a4,a5,a6) = 
+                        showChar '(' . shows a1 . showChar ',' .
+                                       shows a2 . showChar ',' .
+                                       shows a3 . showChar ',' .
+                                       shows a4 . showChar ',' .
+                                       shows a5 . showChar ',' .
+                                       shows a6 . showChar ')'
+
+
+-}
diff --git a/progs/prelude/PreludeIO.hs b/progs/prelude/PreludeIO.hs
new file mode 100644
index 0000000..6173d8c
--- /dev/null
+++ b/progs/prelude/PreludeIO.hs
@@ -0,0 +1,232 @@
+-- I/O functions and definitions
+
+module PreludeIO(stdin,stdout,stderr,stdecho,{-Request(..),Response(..),-}
+                 IOError(..),Dialogue(..),IO(..),SystemState,IOResult,
+                 SuccCont(..),StrCont(..),
+                 StrListCont(..),BinCont(..),FailCont(..),
+                 readFile, writeFile,  appendFile,  readBinFile,
+                 writeBinFile,  appendBinFile,  deleteFile,  statusFile,
+                 readChan,  appendChan,  readBinChan,  appendBinChan,
+                 statusChan,  echo,  getArgs,  getProgName,  getEnv,  setEnv,
+                 done, exit, abort, print, prints, interact,
+		 thenIO,thenIO_,seqIO,returnIO, doneIO)
+   where
+
+import PreludeBltinIO
+import PreludeBltinArray(strict1)
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+-- These datatypes are used by the monad.
+
+type IO a = SystemState -> IOResult a
+
+data SystemState = SystemState
+data IOResult a = IOResult a
+
+-- Operations in the monad
+
+-- This definition is needed to allow proper tail recursion of the Lisp
+-- code.  The use of strict1 forces f1 s (since getState is strict) before
+-- the call to f2.  The optimizer removed getState and getRes from the
+-- generated code.
+
+{-# thenIO :: Inline #-}
+thenIO f1 f2 s =
+  let g = f1 s
+      s' = getState g in
+    strict1 s' (f2 (getRes g) s')
+
+{-# thenIO_ :: Inline #-}
+x `thenIO_` y = x `thenIO` \_ -> y
+x `seqIO` y = x `thenIO` \_ -> y
+
+-- The returnIO function is implemented directly as a primitive.
+doneIO = returnIO ()
+
+
+-- File and channel names:
+
+stdin	    =  "stdin"
+stdout      =  "stdout"
+stderr      =  "stderr"
+stdecho     =  "stdecho"
+
+
+-- Requests and responses:
+
+{-  Not used since streams are no longer supported:
+data Request =	-- file system requests:
+			  ReadFile      String         
+			| WriteFile     String String
+			| AppendFile    String String
+			| ReadBinFile   String 
+			| WriteBinFile  String Bin
+			| AppendBinFile String Bin
+			| DeleteFile    String
+			| StatusFile    String
+		-- channel system requests:
+			| ReadChan	String 
+			| AppendChan    String String
+			| ReadBinChan   String 
+			| AppendBinChan String Bin
+			| StatusChan    String
+		-- environment requests:
+			| Echo          Bool
+			| GetArgs
+			| GetProgName
+			| GetEnv        String
+			| SetEnv        String String
+		deriving Text
+
+data Response =		  Success
+			| Str String 
+			| StrList [String]
+			| Bn  Bin
+			| Failure IOError
+		deriving Text
+
+-}
+
+data IOError =		  WriteError   String
+			| ReadError    String
+			| SearchError  String
+			| FormatError  String
+			| OtherError   String
+		deriving Text
+
+-- Continuation-based I/O:
+
+type Dialogue    =  IO ()
+type SuccCont    =                Dialogue
+type StrCont     =  String     -> Dialogue
+type StrListCont =  [String]   -> Dialogue
+type BinCont     =  Bin        -> Dialogue
+type FailCont    =  IOError    -> Dialogue
+ 
+done	      ::                                                Dialogue
+readFile      :: String ->           FailCont -> StrCont     -> Dialogue
+writeFile     :: String -> String -> FailCont -> SuccCont    -> Dialogue
+appendFile    :: String -> String -> FailCont -> SuccCont    -> Dialogue
+readBinFile   :: String ->           FailCont -> BinCont     -> Dialogue
+writeBinFile  :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
+appendBinFile :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
+deleteFile    :: String ->           FailCont -> SuccCont    -> Dialogue
+statusFile    :: String ->           FailCont -> StrCont     -> Dialogue
+readChan      :: String ->           FailCont -> StrCont     -> Dialogue
+appendChan    :: String -> String -> FailCont -> SuccCont    -> Dialogue
+readBinChan   :: String ->           FailCont -> BinCont     -> Dialogue
+appendBinChan :: String -> Bin    -> FailCont -> SuccCont    -> Dialogue
+statusChan    :: String ->           FailCont -> StrCont     -> Dialogue
+echo          :: Bool ->             FailCont -> SuccCont    -> Dialogue
+getArgs	      ::		     FailCont -> StrListCont -> Dialogue
+getProgName   ::		     FailCont -> StrCont     -> Dialogue
+getEnv	      :: String ->	     FailCont -> StrCont     -> Dialogue
+setEnv	      :: String -> String -> FailCont -> SuccCont    -> Dialogue
+
+done = returnIO ()
+
+readFile name fail succ =
+    primReadStringFile name `thenIO` objDispatch fail succ
+
+writeFile name contents fail succ =
+    primWriteStringFile name contents `thenIO` succDispatch fail succ
+
+appendFile name contents fail succ =
+    primAppendStringFile name contents `thenIO` succDispatch fail succ
+
+readBinFile name fail succ =
+    primReadBinFile name `thenIO` objDispatch fail succ
+
+writeBinFile name contents fail succ =
+    primWriteBinFile name contents `thenIO` succDispatch fail succ
+
+appendBinFile name contents fail succ =
+    primAppendBinFile name contents `thenIO` succDispatch fail succ
+
+deleteFile name fail succ =
+    primDeleteFile name `thenIO` succDispatch fail succ
+
+statusFile name fail succ =
+    primStatusFile name `thenIO`
+      (\status ->  case status of Succ s            -> succ s
+                                  Fail msg          -> fail (SearchError msg))
+
+readChan name fail succ =
+ if name == stdin then
+    primReadStdin `thenIO` succ
+ else
+    badChan fail name
+
+appendChan name contents fail succ =
+ if name == stdout then
+    primWriteStdout contents `thenIO` succDispatch fail succ
+ else
+    badChan fail name
+
+readBinChan name fail succ =
+  if name == stdin then
+    primReadBinStdin `thenIO` objDispatch fail succ
+  else
+    badChan fail name
+
+appendBinChan name contents fail succ =
+  if name == stdout then
+    primWriteBinStdout contents `thenIO` succDispatch fail succ
+  else
+    badChan fail name
+
+statusChan name fail succ =
+  if name == stdin || name == stdout then
+     succ "0 0"
+  else
+     fail (SearchError "Channel not defined")
+
+echo bool fail succ =
+  if bool then
+     succ
+  else
+     fail (OtherError "Echo cannot be turned off")
+
+getArgs fail succ =
+  succ [""]
+
+getProgName fail succ =
+    succ "haskell"
+
+getEnv name fail succ =
+    primGetEnv name `thenIO` objDispatch fail succ
+
+setEnv name val fail succ =
+    fail (OtherError "setEnv not implemented")
+
+objDispatch fail succ r = 
+            case r of Succ s            -> succ s
+                      Fail msg          -> fail (OtherError msg)
+
+succDispatch fail succ r = 
+            case r of Succ _            -> succ
+                      Fail msg          -> fail (OtherError msg)
+
+badChan f name = f (OtherError ("Improper IO Channel: " ++ name))
+
+abort		:: FailCont
+abort err	=  done
+
+exit		:: FailCont
+exit err	= appendChan stderr (msg ++ "\n") abort done
+		  where msg = case err of ReadError s   -> s
+		  			  WriteError s  -> s
+		  			  SearchError s -> s
+		      			  FormatError s -> s
+		      			  OtherError s  -> s
+
+print		:: (Text a) => a -> Dialogue
+print x		=  appendChan stdout (show x) exit done
+prints          :: (Text a) => a -> String -> Dialogue
+prints x s	=  appendChan stdout (shows x s) exit done
+
+interact	:: (String -> String) -> Dialogue
+interact f	=  readChan stdin exit
+			    (\x -> appendChan stdout (f x) exit done)
+
diff --git a/progs/prelude/PreludeIOMonad.hs b/progs/prelude/PreludeIOMonad.hs
new file mode 100644
index 0000000..9a45606
--- /dev/null
+++ b/progs/prelude/PreludeIOMonad.hs
@@ -0,0 +1,60 @@
+module IOMonad (State, IO(..)) where
+
+import IOMonadPrims
+
+{- I use data instead of type so that IO can be abstract. For efficiency,
+   IO can be annotated as a strict constructor.
+-}
+
+type IO a = State -> (State, a)
+
+data State = State
+
+-- The rest of this file is unnecessary at the moment since
+-- unitIO & bindIO are primitives and we're not using the rest of this
+
+{- Implemented as a primitives: 
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) (IO k) = IO (\s0 -> let (s1, a) = m s0 in k a s1) -}
+
+unitIO :: a -> IO a
+unitIO x = IO (\s -> (s, x))
+
+-}
+
+{-  Not currently used:
+pureIO :: IO a -> a
+pureIO (IO m) = let (s, x) = m State in x
+
+-- execIO executes a program of type IO ().
+execIO :: IO () -> State
+execIO (IO m) = let (s, x) = m State in s
+
+infixr  1 =:
+infixr  1 ?
+
+-- assignment
+(=:)      :: a -> Var a -> IO ()
+x =: v  = IO (\s -> (update v x s, ()))
+
+-- reader
+(?)       :: Var a -> (a -> IO b) -> IO b
+v ? k   = IO (\s -> (s, readVar v s)) `bindIO` k
+
+-- new
+newvar    :: IO (Var a)
+newvar = IO allocVar
+
+instance Eq (Var a) where
+   x == y = eqVar x y
+-}
+
+
+
+
+
+
+
+
+
+
diff --git a/progs/prelude/PreludeIOPrims.hi b/progs/prelude/PreludeIOPrims.hi
new file mode 100644
index 0000000..e4c2e74
--- /dev/null
+++ b/progs/prelude/PreludeIOPrims.hi
@@ -0,0 +1,55 @@
+-- These lisp functions implement the standard Haskell requests
+
+interface PreludeBltinIO where
+
+import PreludeCore(String,Bin)
+import PreludeIO(SystemState,IOResult,IO)
+data IOResponse a = Succ a | Fail String
+
+{-# Prelude #-}
+
+primReadStringFile :: String -> IO (IOResponse String)
+primWriteStringFile :: String -> String -> IO (IOResponse ())
+primAppendStringFile :: String -> String -> IO (IOResponse ())
+primReadBinFile :: String -> IO (IOResponse Bin)
+primWriteBinFile :: String -> Bin -> IO (IOResponse ())
+primAppendBinFile :: String -> Bin -> IO (IOResponse ())
+primDeleteFile :: String -> IO (IOResponse ())
+primStatusFile :: String -> IO (IOResponse String)
+primReadStdin :: IO String
+primWriteStdout :: String -> IO (IOResponse ())
+primReadBinStdin :: IO (IOResponse Bin)
+primWriteBinStdout :: Bin -> IO (IOResponse ())
+primGetEnv :: String -> IO (IOResponse String)
+
+{-#
+primReadStringFile ::   LispName("prim.read-string-file")
+primWriteStringFile ::  LispName("prim.write-string-file"), NoConversion
+primAppendStringFile :: LispName("prim.append-string-file"), NoConversion
+primReadBinFile ::      LispName("prim.read-bin-file")
+primWriteBinFile ::     LispName("prim.write-bin-file")
+primAppendBinFile ::    LispName("prim.append-bin-file")
+primDeleteFile ::       LispName("prim.delete-file")
+primStatusFile ::       LispName("prim.status-file")
+primReadStdin ::        LispName("prim.read-string-stdin"), NoConversion
+primWriteStdout ::      LispName("prim.write-string-stdout"), NoConversion
+primReadBinStdin ::     LispName("prim.read-bin-stdin")
+primWriteBinStdout ::   LispName("prim.write-bin-stdout")
+primGetEnv ::           LispName("prim.getenv")
+#-}
+
+--   Monad prims
+
+returnIO :: a -> IO a
+getState :: IOResult a -> SystemState
+getRes :: IOResult a -> a
+
+{-#
+returnIO :: LispName("prim.returnio"), 
+            Strictness("N,S"), NoConversion, Complexity(3)
+getState :: LispName("prim.getstate"), 
+            Strictness("S"), NoConversion, Complexity(3)
+getRes :: LispName("prim.getres"), 
+          Strictness("S"), NoConversion
+#-}
+
diff --git a/progs/prelude/PreludeIOPrims.hu b/progs/prelude/PreludeIOPrims.hu
new file mode 100644
index 0000000..66393c5
--- /dev/null
+++ b/progs/prelude/PreludeIOPrims.hu
@@ -0,0 +1,4 @@
+:output $PRELUDEBIN/PreludeIOPrims
+:stable
+:prelude
+PreludeIOPrims.hi
diff --git a/progs/prelude/PreludeList.hs b/progs/prelude/PreludeList.hs
new file mode 100644
index 0000000..3e445c3
--- /dev/null
+++ b/progs/prelude/PreludeList.hs
@@ -0,0 +1,585 @@
+-- Standard list functions
+
+-- build really shouldn't be exported, but what the heck.
+-- some of the helper functions in this file shouldn't be
+-- exported either!
+
+module PreludeList (PreludeList.., foldr, build) where
+
+import PreludePrims(build, foldr)
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+infixl 9  !!
+infix  5  \\
+infixr 5  ++
+infix  4 `elem`, `notElem`
+
+
+-- These are primitives used by the deforestation stuff in the optimizer.
+-- the optimizer will turn references to foldr and build into
+-- inlineFoldr and inlineBuild, respectively, but doesn't want to
+-- necessarily inline all references immediately.
+
+inlineFoldr :: (a -> b -> b) -> b -> [a] -> b
+inlineFoldr f z l =
+  let foldr' []	 	= z
+      foldr' (x:xs)	= f x (foldr' xs)
+  in foldr' l
+{-# inlineFoldr :: Inline #-}
+
+
+inlineBuild :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c]
+inlineBuild g           = g (:) []
+{-# inlineBuild :: Inline #-}
+
+
+-- head and tail extract the first element and remaining elements,
+-- respectively, of a list, which must be non-empty.  last and init
+-- are the dual functions working from the end of a finite list,
+-- rather than the beginning.
+
+head			:: [a] -> a
+head (x:_)		=  x
+head []			=  error "head{PreludeList}: head []"
+
+last			:: [a] -> a
+last [x]		=  x
+last (_:xs)		=  last xs
+last []			=  error "last{PreludeList}: last []"
+
+tail			:: [a] -> [a]
+tail (_:xs)		=  xs
+tail []			=  error "tail{PreludeList}: tail []"
+
+init			:: [a] -> [a]
+init [x]		=  []
+init (x:xs)		=  x : init xs
+init []			=  error "init{PreludeList}: init []"
+
+-- null determines if a list is empty.
+null			:: [a] -> Bool
+null []			=  True
+null (_:_)		=  False
+
+
+-- list concatenation (right-associative)
+
+(++)			:: [a] -> [a] -> [a]
+xs ++ ys		= build (\ c n -> foldr c (foldr c n ys) xs)
+{-# (++) :: Inline #-}
+
+
+-- the first occurrence of each element of ys in turn (if any)
+-- has been removed from xs.  Thus, (xs ++ ys) \\ xs == ys.
+(\\)			:: (Eq a) => [a] -> [a] -> [a]
+(\\)			=  foldl del
+			   where [] `del` _	    = []
+				 (x:xs) `del` y
+					| x == y    = xs
+					| otherwise = x : xs `del` y
+
+-- length returns the length of a finite list as an Int; it is an instance
+-- of the more general genericLength, the result type of which may be
+-- any kind of number.
+
+genericLength		:: (Num a) => [b] -> a
+genericLength l         = foldr (\ x n -> 1 + n) 0 l
+--genericLength []	=  0
+--genericLength (x:xs)    =  1 + genericLength xs
+{-# genericLength :: Inline #-}
+
+
+length			:: [a] -> Int
+length l		= foldr (\ x n -> 1 + n) 0 l
+--length []               = 0
+--length (x:xs)           = 1 + length xs
+{-# length :: Inline #-}
+
+-- List index (subscript) operator, 0-origin
+(!!)			:: (Integral a) => [b] -> a -> b
+l !! i			=  nth l (fromIntegral i)
+{-# (!!)  :: Inline #-}
+
+nth                     :: [b] -> Int -> b
+nth l m	= let f x g 0 = x
+	      f x g i = g (i - 1)
+	      fail _ = error "(!!){PreludeList}: index too large"
+	  in foldr f fail l m
+{-# nth  :: Inline #-}
+--nth _ n  | n < 0	= error "(!!){PreludeList}: negative index"
+--nth [] n		= error "(!!){PreludeList}: index too large"
+--nth (x:xs) n 
+--	| n == 0	= x
+--	| otherwise     = nth xs (n - 1)
+--{-# nth  :: Strictness("S,S") #-}
+
+-- map f xs applies f to each element of xs; i.e., map f xs == [f x | x <- xs].
+map			:: (a -> b) -> [a] -> [b]
+map f xs		= build (\ c n -> foldr (\ a b -> c (f a) b) n xs)
+--map f []		=  []
+--map f (x:xs)		=  f x : map f xs
+{-# map  :: Inline #-}
+
+
+-- filter, applied to a predicate and a list, returns the list of those
+-- elements that satisfy the predicate; i.e.,
+-- filter p xs == [x | x <- xs, p x].
+filter			:: (a -> Bool) -> [a] -> [a]
+filter f xs		= build (\ c n ->
+                                  foldr (\ a b -> if f a then c a b else b)
+				  n xs)
+--filter p		=  foldr (\x xs -> if p x then x:xs else xs) []
+{-# filter  :: Inline #-}
+
+ 
+-- partition takes a predicate and a list and returns a pair of lists:
+-- those elements of the argument list that do and do not satisfy the
+-- predicate, respectively; i.e.,
+-- partition p xs == (filter p xs, filter (not . p) xs).
+partition		:: (a -> Bool) -> [a] -> ([a],[a])
+partition p		=  foldr select ([],[])
+			   where select x (ts,fs) | p x	      = (x:ts,fs)
+						  | otherwise = (ts,x:fs)
+{-# partition  :: Inline #-}
+
+
+-- foldl, applied to a binary operator, a starting value (typically the
+-- left-identity of the operator), and a list, reduces the list using
+-- the binary operator, from left to right:
+--	foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+-- foldl1 is a variant that has no starting value argument, and  thus must
+-- be applied to non-empty lists.  scanl is similar to foldl, but returns
+-- a list of successive reduced values from the left:
+--	scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+-- Note that  last (scanl f z xs) == foldl f z xs.
+-- scanl1 is similar, again without the starting element:
+--	scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+foldl			:: (a -> b -> a) -> a -> [b] -> a
+foldl f z xs            = foldr (\ b g a -> g (f a b)) id xs z
+--foldl f z []		=  z
+--foldl f z (x:xs)	=  foldl f (f z x) xs
+{-# foldl  :: Inline #-}
+
+foldl1			:: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs)		=  foldl f x xs
+foldl1 _ []		=  error "foldl1{PreludeList}: empty list"
+{-# foldl1  :: Inline #-}
+
+scanl			:: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs		=  q : (case xs of
+				[]   -> []
+				x:xs -> scanl f (f q x) xs)
+{-# scanl  :: Inline #-}
+
+scanl1			:: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs)		=  scanl f x xs
+scanl1 _ []		=  error "scanl1{PreludeList}: empty list"
+{-# scanl1 :: Inline #-}
+
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+--foldr			:: (a -> b -> b) -> b -> [a] -> b
+--foldr f z []		=  z
+--foldr f z (x:xs)	=  f x (foldr f z xs)
+
+
+foldr1			:: (a -> a -> a) -> [a] -> a
+foldr1 f [x]		=  x
+foldr1 f (x:xs)		=  f x (foldr1 f xs)
+foldr1 _ []		=  error "foldr1{PreludeList}: empty list"
+{-# foldr1  :: Inline #-}
+
+
+-- I'm not sure the build/foldr expansion wins.
+
+scanr			:: (a -> b -> b) -> b -> [a] -> [b]
+--scanr f q0 l = build (\ c n ->
+--                        let g x qs@(q:_) = c (f x q) qs
+--			in foldr g (c q0 n) l)
+scanr f q0 []		=  [q0]
+scanr f q0 (x:xs)	=  f x q : qs
+			   where qs@(q:_) = scanr f q0 xs 
+{-# scanr  :: Inline #-}
+
+scanr1			:: (a -> a -> a) -> [a] -> [a]
+scanr1 f  [x]		=  [x]
+scanr1 f  (x:xs)	=  f x q : qs
+			   where qs@(q:_) = scanr1 f xs 
+scanr1 _ []		=  error "scanr1{PreludeList}: empty list"
+{-# scanr1  :: Inline #-}
+
+
+-- iterate f x returns an infinite list of repeated applications of f to x:
+-- iterate f x == [x, f x, f (f x), ...]
+iterate			:: (a -> a) -> a -> [a]
+iterate f x	= build (\ c n ->
+                          let iterate' x' = c x' (iterate' (f x'))
+			  in iterate' x)
+--iterate f x		=  x : iterate f (f x)
+{-# iterate  :: Inline #-}
+
+
+-- repeat x is an infinite list, with x the value of every element.
+repeat			:: a -> [a]
+repeat x		= build (\ c n -> let r = c x r in r)
+--repeat x		=  xs where xs = x:xs
+{-# repeat  :: Inline #-}
+
+-- cycle ties a finite list into a circular one, or equivalently,
+-- the infinite repetition of the original list.  It is the identity
+-- on infinite lists.
+
+cycle			:: [a] -> [a]
+cycle xs		=  xs' where xs' = xs ++ xs'
+
+
+-- take n, applied to a list xs, returns the prefix of xs of length n,
+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs
+-- after the first n elements, or [] if n > length xs.  splitAt n xs
+-- is equivalent to (take n xs, drop n xs).
+
+take			:: (Integral a) => a -> [b] -> [b]
+take n l		= takeInt (fromIntegral n) l
+{-# take  :: Inline #-}
+
+takeInt                 :: Int -> [b] -> [b]
+takeInt m l = 
+  build (\ c n ->
+           let f x g i | i <= 0		= n
+	               | otherwise      = c x (g (i - 1))
+           in foldr f (\ _ -> n) l m)
+--takeInt  0     _	=  []
+--takeInt  _     []	=  []
+--takeInt  n l | n > 0    = primTake n l
+{-# takeInt  :: Inline #-}
+
+
+
+-- Writing drop and friends in terms of build/foldr seems to lose
+-- way big since they cause an extra traversal of the list tail
+-- (except when the calls are being deforested).
+
+drop			:: (Integral a) => a -> [b] -> [b]
+drop n l		= dropInt (fromIntegral n) l
+{-# drop  :: Inline #-}
+{-# drop  :: Strictness("S,S") #-}
+
+
+dropInt                 :: Int -> [b] -> [b]
+dropInt  0     xs	=  xs
+dropInt  _     []	=  []
+dropInt (n+1) (_:xs)	=  dropInt n xs
+{-# dropInt  :: Inline #-}
+
+splitAt			:: (Integral a) => a -> [b] -> ([b],[b])
+splitAt n l		= splitAtInt (fromIntegral n) l
+{-# splitAt  :: Inline #-}
+
+splitAtInt		:: Int -> [b] -> ([b],[b])
+splitAtInt  0     xs	=  ([],xs)
+splitAtInt  _     []	=  ([],[])
+splitAtInt (n+1) (x:xs)	=  (x:xs',xs'') where (xs',xs'') = splitAtInt n xs
+{-# splitAtInt  :: Inline #-}
+
+-- takeWhile, applied to a predicate p and a list xs, returns the longest
+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs
+-- returns the remaining suffix.  Span p xs is equivalent to
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
+
+takeWhile		:: (a -> Bool) -> [a] -> [a]
+takeWhile p l = build (\ c n -> foldr (\ a b -> if p a then c a b else n) n l)
+--takeWhile p []		=  []
+--takeWhile p (x:xs) 
+--            | p x       =  x : takeWhile p xs
+--            | otherwise =  []
+{-# takeWhile  :: Inline #-}
+
+
+dropWhile		:: (a -> Bool) -> [a] -> [a]
+dropWhile p []		=  []
+dropWhile p xs@(x:xs')
+	    | p x       =  dropWhile p xs'
+	    | otherwise =  xs
+{-# dropWhile  :: Inline #-}
+
+span, break		:: (a -> Bool) -> [a] -> ([a],[a])
+span p []		=  ([],[])
+span p xs@(x:xs')
+	   | p x	=  let (ys,zs) = span p xs' in (x:ys,zs)
+	   | otherwise	=  ([],xs)
+break p			=  span (not . p)
+
+{-# span  :: Inline #-}
+{-# break  :: Inline #-}
+
+
+-- lines breaks a string up into a list of strings at newline characters.
+-- The resulting strings do not contain newlines.  Similary, words
+-- breaks a string up into a list of words, which were delimited by
+-- white space.  unlines and unwords are the inverse operations.
+-- unlines joins lines with terminating newlines, and unwords joins
+-- words with separating spaces.
+
+lines			:: String -> [String]
+lines ""		=  []
+lines s			=  let (l, s') = break (== '\n') s
+			   in  l : case s' of
+					[]     	-> []
+					(_:s'') -> lines s''
+
+words			:: String -> [String]
+words s			=  case dropWhile isSpace s of
+				"" -> []
+				s' -> w : words s''
+				      where (w, s'') = break isSpace s'
+
+unlines			:: [String] -> String
+unlines			=  concat . map (++ "\n")
+{-# unlines  :: Inline #-}
+
+
+unwords			:: [String] -> String
+unwords []		=  ""
+unwords ws		=  foldr1 (\w s -> w ++ ' ':s) ws
+
+-- nub (meaning "essence") removes duplicate elements from its list argument.
+nub			:: (Eq a) => [a] -> [a]
+nub l = build (\ c n ->
+                 let f x g [] = c x (g [x])
+		     f x g xs = if elem x xs
+		                   then (g xs)
+				   else c x (g (x:xs))
+                 in foldr f (\ _ -> n) l [])
+{-# nub  :: Inline #-}
+--nub []			=  []
+--nub (x:xs)		=  x : nub (filter (/= x) xs)
+
+-- reverse xs returns the elements of xs in reverse order.  xs must be finite.
+reverse			:: [a] -> [a]
+reverse l = build (\ c n ->
+                     let f x g tail = g (c x tail)
+		     in foldr f id l n)
+{-# reverse  :: Inline #-}
+--reverse x               =  reverse1 x [] where
+--  reverse1 [] a     = a
+--  reverse1 (x:xs) a = reverse1 xs (x:a)
+
+-- and returns the conjunction of a Boolean list.  For the result to be
+-- True, the list must be finite; False, however, results from a False
+-- value at a finite index of a finite or infinite list.  or is the
+-- disjunctive dual of and.
+and, or			:: [Bool] -> Bool
+and			=  foldr (&&) True
+or			=  foldr (||) False
+{-# and :: Inline #-}
+{-# or  :: Inline #-}
+
+-- Applied to a predicate and a list, any determines if any element
+-- of the list satisfies the predicate.  Similarly, for all.
+any, all		:: (a -> Bool) -> [a] -> Bool
+any p			=  or . map p
+all p			=  and . map p
+{-# any :: Inline #-}
+{-# all :: Inline #-}
+
+-- elem is the list membership predicate, usually written in infix form,
+-- e.g., x `elem` xs.  notElem is the negation.
+elem, notElem		:: (Eq a) => a -> [a] -> Bool
+
+elem x ys = foldr (\ y t -> (x == y) || t) False ys
+--x `elem` []		=  False
+--x `elem` (y:ys)         =  x == y || x `elem` ys
+{-# elem :: Inline #-}
+notElem	x y		=  not (x `elem` y)
+
+-- sum and product compute the sum or product of a finite list of numbers.
+sum, product		:: (Num a) => [a] -> a
+sum			=  foldl (+) 0	
+product			=  foldl (*) 1
+{-# sum :: Inline #-}
+{-# product :: Inline #-}
+
+-- sums and products give a list of running sums or products from
+-- a list of numbers.  For example,  sums [1,2,3] == [0,1,3,6].
+sums, products		:: (Num a) => [a] -> [a]
+sums			=  scanl (+) 0
+products		=  scanl (*) 1
+
+-- maximum and minimum return the maximum or minimum value from a list,
+-- which must be non-empty, finite, and of an ordered type.
+maximum, minimum	:: (Ord a) => [a] -> a
+maximum			=  foldl1 max
+minimum			=  foldl1 min
+{-# maximum :: Inline #-}
+{-# minimum :: Inline #-}
+
+-- concat, applied to a list of lists, returns their flattened concatenation.
+concat			:: [[a]] -> [a]
+concat xs	= build (\ c n -> foldr (\ x y -> foldr c y x) n xs)
+--concat []               =  []
+--concat (l:ls)           =  l ++ concat ls
+{-# concat :: Inline #-}
+
+
+-- transpose, applied to a list of lists, returns that list with the
+-- "rows" and "columns" interchanged.  The input need not be rectangular
+-- (a list of equal-length lists) to be completely transposable, but can
+-- be "triangular":  Each successive component list must be not longer
+-- than the previous one; any elements outside of the "triangular"
+-- transposable region are lost.  The input can be infinite in either
+-- dimension or both.
+transpose		:: [[a]] -> [[a]]
+transpose		=  foldr 
+			     (\xs xss -> zipWith (:) xs (xss ++ repeat []))
+			     []
+{-# transpose :: Inline #-}
+
+-- zip takes two lists and returns a list of corresponding pairs.  If one
+-- input list is short, excess elements of the longer list are discarded.
+-- zip3 takes three lists and returns a list of triples, etc.  Versions
+-- of zip producing up to septuplets are defined here.
+
+zip			:: [a] -> [b] -> [(a,b)]
+zip			=  zipWith (\a b -> (a,b))
+{-# zip :: Inline #-}
+
+zip3			:: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3			=  zipWith3 (\a b c -> (a,b,c))
+{-# zip3 :: Inline #-}
+
+zip4			:: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4			=  zipWith4 (\a b c d -> (a,b,c,d))
+{-# zip4 :: Inline #-}
+
+zip5			:: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5			=  zipWith5 (\a b c d e -> (a,b,c,d,e))
+{-# zip5 :: Inline #-}
+
+zip6			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f]
+			   -> [(a,b,c,d,e,f)]
+zip6			=  zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
+{-# zip6 :: Inline #-}
+
+zip7			:: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]
+			   -> [(a,b,c,d,e,f,g)]
+zip7			=  zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
+{-# zip7 :: Inline #-}
+
+-- The zipWith family generalises the zip family by zipping with the
+-- function given as the first argument, instead of a tupling function.
+-- For example, zipWith (+) is applied to two lists to produce the list
+-- of corresponding sums.
+
+zipWith			:: (a->b->c) -> [a]->[b]->[c]
+zipWith z as bs =
+  build (\ c' n' ->
+           let f' a g' (b:bs) = c' (z a b) (g' bs)
+	       f' a g' _ = n'
+           in foldr f' (\ _ -> n') as bs)
+--zipWith z (a:as) (b:bs)	=  z a b : zipWith z as bs
+--zipWith _ _ _		=  []
+{-# zipWith :: Inline #-}
+
+zipWith3		:: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z as bs cs =
+  build (\ c' n' ->
+          let f' a g' (b:bs) (c:cs) = c' (z a b c) (g' bs cs)
+              f' a g' _ _ = n'
+          in foldr f' (\ _ _ -> n') as bs cs)
+{-# zipWith3 :: Inline #-}
+--zipWith3 z (a:as) (b:bs) (c:cs)
+--			=  z a b c : zipWith3 z as bs cs
+--zipWith3 _ _ _ _	=  []
+
+zipWith4		:: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z as bs cs ds =
+  build (\ c' n' ->
+          let f' a g' (b:bs) (c:cs) (d:ds) = c' (z a b c d) (g' bs cs ds)
+              f' a g' _ _ _ = n'
+          in foldr f' (\ _ _ _ -> n') as bs cs ds)
+{-# zipWith4 :: Inline #-}
+--zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+--			=  z a b c d : zipWith4 z as bs cs ds
+--zipWith4 _ _ _ _ _	=  []
+
+zipWith5		:: (a->b->c->d->e->f)
+			   -> [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z as bs cs ds es=
+  build (\ c' n' ->
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) =
+	        c' (z a b c d e) (g' bs cs ds es)
+              f' a g' _ _ _ _ = n'
+          in foldr f' (\ _ _ _ _ -> n') as bs cs ds es)
+{-# zipWith5 :: Inline #-}
+--zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+--			=  z a b c d e : zipWith5 z as bs cs ds es
+--zipWith5 _ _ _ _ _ _	=  []
+
+zipWith6		:: (a->b->c->d->e->f->g)
+			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z as bs cs ds es fs =
+  build (\ c' n' ->
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) =
+	        c' (z a b c d e f) (g' bs cs ds es fs)
+              f' a g' _ _ _ _ _ = n'
+          in foldr f' (\ _ _ _ _ _ -> n') as bs cs ds es fs)
+{-# zipWith6 :: Inline #-}
+--zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+--			=  z a b c d e f : zipWith6 z as bs cs ds es fs
+--zipWith6 _ _ _ _ _ _ _	=  []
+
+zipWith7		:: (a->b->c->d->e->f->g->h)
+			   -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z as bs cs ds es fs gs =
+  build (\ c' n' ->
+          let f' a g' (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) =
+	        c' (z a b c d e f g) (g' bs cs ds es fs gs)
+              f' a g' _ _ _ _ _ _ = n'
+          in foldr f' (\ _ _ _ _ _ _ -> n') as bs cs ds es fs gs)
+{-# zipWith7 :: Inline #-}
+--zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+--		   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+--zipWith7 _ _ _ _ _ _ _ _ =  []
+
+
+-- unzip transforms a list of pairs into a pair of lists.  As with zip,
+-- a family of such functions up to septuplets is provided.
+
+unzip			:: [(a,b)] -> ([a],[b])
+unzip			=  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+{-# unzip :: Inline #-}
+
+
+unzip3			:: [(a,b,c)] -> ([a],[b],[c])
+unzip3			=  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+				 ([],[],[])
+{-# unzip3 :: Inline #-}
+
+unzip4			:: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4			=  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+					(a:as,b:bs,c:cs,d:ds))
+				 ([],[],[],[])
+{-# unzip4 :: Inline #-}
+
+unzip5			:: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5			=  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+					(a:as,b:bs,c:cs,d:ds,e:es))
+				 ([],[],[],[],[])
+{-# unzip5 :: Inline #-}
+
+unzip6			:: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6			=  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+					(a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+				 ([],[],[],[],[],[])
+{-# unzip6 :: Inline #-}
+
+unzip7			:: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7			=  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+					(a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+				 ([],[],[],[],[],[],[])
+{-# unzip7 :: Inline #-}
+
diff --git a/progs/prelude/PreludeLocal.hs b/progs/prelude/PreludeLocal.hs
new file mode 100644
index 0000000..6e52bbf
--- /dev/null
+++ b/progs/prelude/PreludeLocal.hs
@@ -0,0 +1,16 @@
+module PreludeLocal where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+infixr 5 :
+
+data Int = MkInt
+data Integer = MkInteger
+data Float = MkFloat
+data Double   = MkDouble
+data Char = MkChar
+data Bin = MkBin
+data List a = a : (List a) | Nil
+data Arrow a b = MkArrow a b
+
+data Triv = MkTriv
diff --git a/progs/prelude/PreludeLocalIO.hs b/progs/prelude/PreludeLocalIO.hs
new file mode 100644
index 0000000..2753071
--- /dev/null
+++ b/progs/prelude/PreludeLocalIO.hs
@@ -0,0 +1,144 @@
+module PreludeLocalIO where
+
+import PreludeIOPrims
+import PreludeIOMonad
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+data IOResponse a = Succ a | Fail String deriving Text
+
+exec :: ([Response] -> [Request]) -> IO ()
+{-
+-- Sunderesh's original definition
+exec p = case (p bottom) of
+          [] -> unitIO ()
+          (q:qs) -> processRequest q `bindIO` \r ->
+                    exec (\rs -> tail (p (r:rs)))
+
+bottom :: a
+bottom = error "Should never be evaluated"
+-}
+-- modified from the existing compiler. no quadratic behavior
+-- needs
+-- pure :: IO a -> a
+-- other alternatives:
+-- 1. use reference cells
+-- 2. implement exec in Lisp
+
+exec p = os requests `bindIO` \x -> unitIO () where
+    requests = p responses
+    responses = pureIO (os requests)
+
+os :: [Request] -> IO [Response]
+os [] = unitIO []
+os (q:qs) = processRequest q `bindIO` \r ->
+            os qs `bindIO` \rs -> 
+            unitIO (r:rs)
+
+processRequest :: Request -> IO Response
+
+-- This needs to be rewritten in terms of the continuation based defs
+
+processRequest request =
+  case request of
+
+-- File system requests
+   ReadFile name ->
+      primReadStringFile name `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   WriteFile name contents ->
+      primWriteStringFile name contents `bindIO` \a -> 
+        case a of 
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   AppendFile name contents ->
+      primAppendStringFile name contents `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   ReadBinFile name ->
+      primReadBinFile name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Bn s) 
+          Fail e -> unitIO (Failure e)
+   WriteBinFile name bin ->
+      primWriteBinFile name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   AppendBinFile name bin ->
+      primAppendBinFile name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   DeleteFile name ->
+      primDeleteFile name `bindIO` \a ->
+        case a of 
+          MaybeNot -> Success
+          Maybe e  -> unitIO (Failure e)
+   StatusFile name ->
+      primStatusFile name `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+
+-- Channel system requests
+   ReadChan name ->
+      primReadChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   AppendChan name string ->
+      primAppendChan name string `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   ReadBinChan name ->
+      primReadBinChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Bn s)
+          Fail e -> unitIO (Failure e)
+   AppendBinChan name bin ->
+      primAppendBinChan name bin `bindIO` \a ->
+        case a of
+          MaybeNot -> unitIO Success
+          Maybe e  -> unitIO (Failure e)
+   StatusChan name ->
+      primStatusChan name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+
+-- Environment requests
+   Echo status ->
+      primEcho status `bindIO` \a -> 
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetArgs ->
+      primGetArgs `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetProgName ->
+      primProgArgs `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   GetEnv name ->
+      primGetEnv name `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   SetEnv name string ->
+      primGetEnv name string `bindIO` \a ->
+        case a of
+          Succ s -> unitIO (Str s)
+          Fail e -> unitIO (Failure e)
+   _ -> unitIO (Failure (OtherError "Unrecognized IO Feature"))
+
+-- Monadic Style IO
+-- Channel system requests
+
diff --git a/progs/prelude/PreludePrims.hi b/progs/prelude/PreludePrims.hi
new file mode 100644
index 0000000..737a448
--- /dev/null
+++ b/progs/prelude/PreludePrims.hi
@@ -0,0 +1,252 @@
+-- interface.scm -- define interface to primitives
+--
+-- author :  Sandra & John
+-- date   :  24 Apr 1992
+--
+-- This file declares the interface to the runtime system primitives.
+-- The actual definitions for the Lisp functions all appear elsewhere;
+-- they all have names like prim.xxx.  (They can actually be macros
+-- instead of functions since they're never referenced by name.)
+
+interface PreludePrims where
+
+{-# Prelude #-}
+
+import PreludeCore(Int,Integer,Float,Double,Char,Bool)
+import PreludeRational(Rational)
+
+error :: String -> a
+primCharToInt :: Char -> Int
+primIntToChar :: Int -> Char
+primEqChar, primNeqChar, primLeChar, primGtChar, primLsChar, primGeChar
+  :: Char -> Char -> Bool
+primMaxChar :: Int
+primEqFloat, primNeqFloat, primLeFloat, primGtFloat, primLsFloat, primGeFloat
+  :: Float -> Float -> Bool
+primFloatMax, primFloatMin :: Float -> Float -> Float
+primEqDouble, primNeqDouble, primLeDouble, primGtDouble, 
+              primLsDouble, primGeDouble
+  :: Double -> Double -> Bool
+primDoubleMax, primDoubleMin :: Double -> Double -> Double
+primPlusFloat, primMinusFloat, primMulFloat, primDivFloat
+  :: Float -> Float -> Float
+primPlusDouble, primMinusDouble, primMulDouble, primDivDouble
+  :: Double -> Double -> Double
+primNegFloat, primAbsFloat :: Float -> Float
+primNegDouble, primAbsDouble :: Double -> Double
+primExpFloat, primLogFloat, primSqrtFloat, primSinFloat, primCosFloat,
+  primTanFloat, primAsinFloat, primAcosFloat, primAtanFloat, primSinhFloat,
+  primCoshFloat, primTanhFloat, primAsinhFloat, primAcoshFloat, primAtanhFloat
+  :: Float -> Float
+primExpDouble, primLogDouble, primSqrtDouble, primSinDouble, primCosDouble,
+  primTanDouble, primAsinDouble, primAcosDouble, primAtanDouble, primSinhDouble,
+  primCoshDouble, primTanhDouble, primAsinhDouble, primAcoshDouble, primAtanhDouble
+  :: Double -> Double
+primPiFloat :: Float
+primPiDouble :: Double
+primRationalToFloat :: Rational -> Float
+primRationalToDouble :: Rational -> Double
+primFloatToRational :: Float -> Rational
+primDoubleToRational :: Double -> Rational
+primFloatDigits :: Int
+primFloatRadix :: Integer
+primFloatMinExp :: Int
+primFloatMaxExp :: Int
+primFloatRange :: Float -> (Int, Int)
+primDecodeFloat :: Float -> (Integer, Int)
+primEncodeFloat :: Integer -> Int -> Float
+primDoubleDigits :: Int
+primDoubleRadix :: Integer
+primDoubleMinExp :: Int
+primDoubleMaxExp :: Int
+primDoubleRange :: Double -> (Int, Int)
+primDecodeDouble :: Double -> (Integer, Int)
+primEncodeDouble :: Integer -> Int -> Double
+primEqInt, primNeqInt, primLeInt, primGtInt, primLsInt, primGeInt
+  :: Int -> Int -> Bool
+primIntMax, primIntMin :: Int -> Int -> Int
+primEqInteger, primNeqInteger, primLeInteger, primGtInteger,
+  primLsInteger, primGeInteger
+    :: Integer -> Integer -> Bool
+primIntegerMax, primIntegerMin :: Integer -> Integer -> Integer
+primPlusInt, primMinusInt, primMulInt :: Int -> Int -> Int 
+primMinInt,primMaxInt :: Int
+primNegInt, primAbsInt :: Int -> Int
+primPlusInteger, primMinusInteger, primMulInteger :: Integer -> Integer -> Integer 
+primNegInteger, primAbsInteger :: Integer -> Integer
+primQuotRemInt :: Int -> Int -> (Int, Int)
+primQuotRemInteger :: Integer -> Integer -> (Integer, Integer)
+primIntegerToInt :: Integer -> Int
+primIntToInteger :: Int -> Integer
+primNullBin :: Bin
+primIsNullBin :: Bin -> Bool
+primShowBinInt :: Int -> Bin -> Bin
+primShowBinInteger :: Integer -> Bin -> Bin
+primShowBinFloat :: Float -> Bin -> Bin
+primShowBinDouble :: Double -> Bin -> Bin
+primReadBinInt :: Bin -> (Int,Bin)
+primReadBinInteger :: Bin -> (Integer,Bin)
+primReadBinFloat :: Bin -> (Float,Bin)
+primReadBinDouble :: Bin -> (Double,Bin)
+primReadBinSmallInt :: Bin -> Int -> (Int,Bin)
+primAppendBin :: Bin -> Bin -> Bin
+
+primStringEq  :: [Char] -> [Char] -> Bool
+
+primAppend :: [a] -> [a] -> [a]
+primTake :: Int -> [a] -> [a]
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+build :: ((a -> [a] -> [a]) -> [b] -> [c]) -> [c]
+
+
+
+-- I've assigned complexities for arithmetic primitives as follows:
+-- Int and Char comparisons and arithmetic are very cheap (complexity 1).
+-- Double and Float comparsions are also cheap, but most implementations
+--   need to box the results of floating-point arithmetic so I have given
+--   them a complexity of 3.
+-- Integer operations need to do an extra bignum check that has a fixed
+--   overhead.  I assume that actual bignums will be rare and give them
+--   all a complexity of 2.
+
+{-#
+error :: LispName("prim.abort")
+primCharToInt ::    LispName("prim.char-to-int"), Complexity(0),NoConversion
+primIntToChar ::    LispName("prim.int-to-char"), Complexity(0),NoConversion
+primEqChar ::       LispName("prim.eq-char"), Complexity(1), NoConversion
+primNeqChar::       LispName("prim.not-eq-char"), Complexity(1), NoConversion
+primLeChar ::       LispName("prim.le-char"), Complexity(1), NoConversion
+primGtChar ::       LispName("prim.not-le-char"), Complexity(1), NoConversion
+primLsChar ::       LispName("prim.lt-char"), Complexity(1), NoConversion
+primGeChar ::       LispName("prim.not-lt-char"), Complexity(1), NoConversion
+primMaxChar ::      LispName("prim.max-char"), NoConversion
+primEqFloat ::      LispName("prim.eq-float"), Complexity(1)
+primNeqFloat ::     LispName("prim.not-eq-float"), Complexity(1)
+primLeFloat  ::     LispName("prim.le-float"), Complexity(1)
+primGtFloat  ::     LispName("prim.not-le-float"), Complexity(1)
+primLsFloat  ::     LispName("prim.lt-float"), Complexity(1)
+primGeFloat  ::     LispName("prim.not-lt-float"), Complexity(1)
+primFloatMax ::     LispName("prim.float-max"), Complexity(3)
+primFloatMin ::     LispName("prim.float-min"), Complexity(3)
+primEqDouble  ::    LispName("prim.eq-double"), Complexity(1)
+primNeqDouble ::    LispName("prim.not-eq-double"), Complexity(1)
+primLeDouble  ::    LispName("prim.le-double"), Complexity(1)
+primGtDouble  ::    LispName("prim.not-le-double"), Complexity(1)
+primLsDouble  ::    LispName("prim.lt-double"), Complexity(1)
+primGeDouble  ::    LispName("prim.not-lt-double"), Complexity(1)
+primDoubleMax ::    LispName("prim.double-max"), Complexity(3)
+primDoubleMin ::    LispName("prim.double-min"), Complexity(3)
+primPlusFloat  ::   LispName("prim.plus-float"), Complexity(3)
+primMinusFloat ::   LispName("prim.minus-float"), Complexity(3)
+primMulFloat   ::   LispName("prim.mul-float"), Complexity(3)
+primDivFloat   ::   LispName("prim.div-float"), Complexity(3)
+primPlusDouble  ::  LispName("prim.plus-double"), Complexity(3)
+primMinusDouble ::  LispName("prim.minus-double"), Complexity(3)
+primMulDouble   ::  LispName("prim.mul-double"), Complexity(3)
+primDivDouble   ::  LispName("prim.div-double"), Complexity(3)
+primNegFloat ::     LispName("prim.neg-float"), Complexity(3)
+primAbsFloat ::     LispName("prim.abs-float"), Complexity(3)
+primNegDouble ::    LispName("prim.neg-double"), Complexity(3)
+primAbsDouble ::    LispName("prim.abs-double"), Complexity(3)
+primExpFloat   ::   LispName("prim.exp-float")
+primLogFloat   ::   LispName("prim.log-float")
+primSqrtFloat  ::   LispName("prim.sqrt-float")
+primSinFloat   ::   LispName("prim.sin-float")
+primCosFloat   ::   LispName("prim.cos-float")
+primTanFloat   ::   LispName("prim.tan-float")
+primAsinFloat  ::   LispName("prim.asin-float")
+primAcosFloat  ::   LispName("prim.acos-float")
+primAtanFloat  ::   LispName("prim.atan-float")
+primSinhFloat  ::   LispName("prim.sinh-float")
+primCoshFloat  ::   LispName("prim.cosh-float")
+primTanhFloat  ::   LispName("prim.tanh-float")
+primAsinhFloat ::   LispName("prim.asinh-float")
+primAcoshFloat ::   LispName("prim.acosh-float")
+primAtanhFloat ::   LispName("prim.atanh-float")
+primExpDouble   ::  LispName("prim.exp-double")
+primLogDouble   ::  LispName("prim.log-double")
+primSqrtDouble  ::  LispName("prim.sqrt-double")
+primSinDouble   ::  LispName("prim.sin-double")
+primCosDouble   ::  LispName("prim.cos-double")
+primTanDouble   ::  LispName("prim.tan-double")
+primAsinDouble  ::  LispName("prim.asin-double")
+primAcosDouble  ::  LispName("prim.acos-double")
+primAtanDouble  ::  LispName("prim.atan-double")
+primSinhDouble  ::  LispName("prim.sinh-double")
+primCoshDouble  ::  LispName("prim.cosh-double")
+primTanhDouble  ::  LispName("prim.tanh-double")
+primAsinhDouble ::  LispName("prim.asinh-double")
+primAcoshDouble ::  LispName("prim.acosh-double")
+primAtanhDouble ::  LispName("prim.atanh-double")
+primPiFloat ::      LispName("prim.pi-float")
+primPiDouble ::     LispName("prim.pi-double")
+primRationalToFloat  :: LispName("prim.rational-to-float"), Complexity(3)
+primRationalToDouble :: LispName("prim.rational-to-double"), Complexity(3)
+primFloatToRational  :: LispName("prim.float-to-rational"), Complexity(3)
+primDoubleToRational :: LispName("prim.double-to-rational"), Complexity(3)
+primFloatDigits ::  LispName("prim.float-digits")
+primFloatRadix ::   LispName("prim.float-radix")
+primFloatMinExp ::  LispName("prim.float-min-exp")
+primFloatMaxExp ::  LispName("prim.float-max-exp")
+primFloatRange ::   LispName("prim.float-range")
+primDecodeFloat ::  LispName("prim.decode-float")
+primEncodeFloat ::  LispName("prim.encode-float")
+primDoubleDigits :: LispName("prim.double-digits")
+primDoubleRadix ::  LispName("prim.double-radix")
+primDoubleMinExp :: LispName("prim.double-min-exp")
+primDoubleMaxExp :: LispName("prim.double-max-exp")
+primDoubleRange ::  LispName("prim.double-range")
+primDecodeDouble :: LispName("prim.decode-double")
+primEncodeDouble :: LispName("prim.encode-double")
+primEqInt ::        LispName("prim.eq-int"), Complexity(1)
+primNeqInt::        LispName("prim.not-eq-int"), Complexity(1)
+primLeInt ::        LispName("prim.le-int"), Complexity(1)
+primGtInt ::        LispName("prim.not-le-int"), Complexity(1)
+primLsInt ::        LispName("prim.lt-int"), Complexity(1)
+primGeInt ::        LispName("prim.not-lt-int"), Complexity(1)
+primIntMax ::       LispName("prim.int-max"), Complexity(1)
+primIntMin ::       LispName("prim.int-min"), Complexity(1)
+primEqInteger ::    LispName("prim.eq-integer"), Complexity(2)
+primNeqInteger::    LispName("prim.not-eq-integer"), Complexity(2)
+primLeInteger ::    LispName("prim.le-integer"), Complexity(2)
+primGtInteger ::    LispName("prim.not-le-integer"), Complexity(2)
+primLsInteger ::    LispName("prim.lt-integer"), Complexity(2)
+primGeInteger ::    LispName("prim.not-lt-integer"), Complexity(2)
+primIntegerMax ::   LispName("prim.integer-max"), Complexity(2)
+primIntegerMin ::   LispName("prim.integer-min"), Complexity(2)
+primPlusInt  ::     LispName("prim.plus-int"), Complexity(1)
+primMinusInt ::     LispName("prim.minus-int"), Complexity(1)
+primMulInt   ::     LispName("prim.mul-int"), Complexity(1)
+primMinInt ::       LispName("prim.minint")
+primMaxInt ::       LispName("prim.maxint")
+primNegInt ::       LispName("prim.neg-int"), Complexity(1)
+primAbsInt ::       LispName("prim.abs-int"), Complexity(1)
+primPlusInteger  :: LispName("prim.plus-integer"), Complexity(2)
+primMinusInteger :: LispName("prim.minus-integer"), Complexity(2)
+primMulInteger   :: LispName("prim.mul-integer"), Complexity(2)
+primNegInteger ::   LispName("prim.neg-integer"), Complexity(2)
+primAbsInteger ::   LispName("prim.abs-integer"), Complexity(2)
+primQuotRemInt ::   LispName("prim.div-rem-int")
+primQuotRemInteger :: LispName("prim.div-rem-integer")
+primIntegerToInt :: LispName("prim.integer-to-int"), Complexity(1)
+primIntToInteger :: LispName("prim.int-to-integer"), Complexity(0)
+primNullBin ::      LispName("prim.nullbin")
+primIsNullBin ::    LispName("prim.is-null-bin"), Complexity(1)
+primShowBinInt ::   LispName("prim.show-bin-int"), Complexity(2)
+primShowBinInteger :: LispName("prim.show-bin-integer"), Complexity(2)
+primShowBinFloat ::   LispName("prim.show-bin-float"), Complexity(2)
+primShowBinDouble ::  LispName("prim.show-bin-double"), Complexity(2)
+primReadBinInt ::     LispName("prim.read-bin-int")
+primReadBinInteger :: LispName("prim.read-bin-integer")
+primReadBinFloat ::   LispName("prim.read-bin-float")
+primReadBinDouble ::  LispName("prim.read-bin-double")
+primReadBinSmallInt :: LispName("prim.read-bin-small-int")
+primAppendBin ::      LispName("prim.append-bin")
+primStringEq :: LispName("prim.string-eq"), Strictness("S,S"), NoConversion
+primAppend :: LispName("prim.append"), Strictness("S,N"), NoConversion
+primTake   :: LispName("prim.take"), Strictness("S,S"), NoConversion
+foldr   :: LispName("prim.foldr"), Strictness("N,N,S"), NoConversion
+build   :: LispName("prim.build"), Strictness("S"), NoConversion
+
+#-}
diff --git a/progs/prelude/PreludePrims.hu b/progs/prelude/PreludePrims.hu
new file mode 100644
index 0000000..fd2cdcc
--- /dev/null
+++ b/progs/prelude/PreludePrims.hu
@@ -0,0 +1,4 @@
+:output $PRELUDEBIN/PreludePrims
+:stable
+:prelude
+PreludePrims.hi
diff --git a/progs/prelude/PreludeRatio.hs b/progs/prelude/PreludeRatio.hs
new file mode 100644
index 0000000..564558e
--- /dev/null
+++ b/progs/prelude/PreludeRatio.hs
@@ -0,0 +1,98 @@
+-- Standard functions on rational numbers
+
+module	PreludeRatio (
+    Ratio, Rational(..), (%), numerator, denominator, approxRational ) where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+infixl 7  %, :%
+
+prec = 7
+
+data  (Integral a)	=> Ratio a = a {-# STRICT #-} :% a {-# STRICT #-}
+                              deriving (Eq, Binary)
+
+type  Rational		=  Ratio Integer
+
+(%)			:: (Integral a) => a -> a -> Ratio a
+numerator, denominator	:: (Integral a) => Ratio a -> a
+approxRational		:: (RealFrac a) => a -> a -> Rational
+
+
+reduce _ 0		=  error "(%){PreludeRatio}: zero denominator"
+reduce x y		=  (x `quot` d) :% (y `quot` d)
+			   where d = gcd x y
+
+
+x % y			=  reduce (x * signum y) (abs y)
+
+numerator (x:%y)	=  x
+
+denominator (x:%y)	=  y
+
+
+instance  (Integral a)	=> Ord (Ratio a)  where
+    (x:%y) <= (x':%y')	=  x * y' <= x' * y
+    (x:%y) <  (x':%y')	=  x * y' <  x' * y
+
+instance  (Integral a)	=> Num (Ratio a)  where
+    (x:%y) + (x':%y')	=  reduce (x*y' + x'*y) (y*y')
+    (x:%y) * (x':%y')	=  reduce (x * x') (y * y')
+    negate (x:%y)	=  (-x) :% y
+    abs (x:%y)		=  abs x :% y
+    signum (x:%y)	=  signum x :% 1
+    fromInteger x	=  fromInteger x :% 1
+
+instance  (Integral a)	=> Real (Ratio a)  where
+    toRational (x:%y)	=  toInteger x :% toInteger y
+
+instance  (Integral a)	=> Fractional (Ratio a)  where
+    (x:%y) / (x':%y')	=  (x*y') % (y*x')
+    recip (x:%y)	=  if x < 0 then (-y) :% (-x) else y :% x
+    fromRational (x:%y) =  fromInteger x :% fromInteger y
+
+instance  (Integral a)	=> RealFrac (Ratio a)  where
+    properFraction (x:%y) = (fromIntegral q, r:%y)
+			    where (q,r) = quotRem x y
+
+instance  (Integral a)	=> Enum (Ratio a)  where
+    enumFrom		=  iterate ((+)1)
+    enumFromThen n m	=  iterate ((+)(m-n)) n
+
+instance  (Integral a) => Text (Ratio a)  where
+    readsPrec p  =  readParen (p > prec)
+			      (\r -> [(x%y,u) | (x,s)   <- reads r,
+					        ("%",t) <- lex s,
+						(y,u)   <- reads t ])
+
+    showsPrec p (x:%y)	=  showParen (p > prec)
+    	    	    	       (shows x . showString " % " . shows y)
+
+
+-- approxRational, applied to two real fractional numbers x and epsilon,
+-- returns the simplest rational number within epsilon of x.  A rational
+-- number n%d in reduced form is said to be simpler than another n'%d' if
+-- abs n <= abs n' && d <= d'.  Any real interval contains a unique
+-- simplest rational; here, for simplicity, we assume a closed rational
+-- interval.  If such an interval includes at least one whole number, then
+-- the simplest rational is the absolutely least whole number.  Otherwise,
+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+-- the simplest rational between d'%r' and d%r.
+
+approxRational x eps	=  simplest (x-eps) (x+eps)
+	where simplest x y | y < x	=  simplest y x
+			   | x == y	=  xr
+			   | x > 0	=  simplest' n d n' d'
+			   | y < 0	=  - simplest' (-n') d' (-n) d
+			   | otherwise	=  0 :% 1
+					where xr@(n:%d) = toRational x
+					      (n':%d')	= toRational y
+
+	      simplest' n d n' d'	-- assumes 0 < n%d < n'%d'
+			| r == 0     =	q :% 1
+			| q /= q'    =	(q+1) :% 1
+			| otherwise  =	(q*n''+d'') :% n''
+				     where (q,r)      =	 quotRem n d
+					   (q',r')    =	 quotRem n' d'
+					   (n'':%d'') =	 simplest' d' r' d r
diff --git a/progs/prelude/PreludeText.hs b/progs/prelude/PreludeText.hs
new file mode 100644
index 0000000..9e4e353
--- /dev/null
+++ b/progs/prelude/PreludeText.hs
@@ -0,0 +1,260 @@
+module	PreludeText (
+	reads, shows, show, read, lex,
+	showChar, showString, readParen, showParen, readLitChar, showLitChar,
+	readSigned, showSigned, readDec, showInt, readFloat, showFloat ) where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+reads 	        :: (Text a) => ReadS a
+reads		=  readsPrec 0
+
+shows 	    	:: (Text a) => a -> ShowS
+shows		=  showsPrec 0
+
+read 	    	:: (Text a) => String -> a
+read s 	    	=  case [x | (x,t) <- reads s, ("","") <- lex t] of
+			[x] -> x
+			[]  -> error "read{PreludeText}: no parse"
+			_   -> error "read{PreludeText}: ambiguous parse"
+
+show 	    	:: (Text a) => a -> String
+show x 	    	=  shows x ""
+
+showChar    	:: Char -> ShowS
+showChar    	=  (:)
+
+showString  	:: String -> ShowS
+showString  	=  (++)
+
+showParen   	:: Bool -> ShowS -> ShowS
+showParen b p 	=  if b then showChar '(' . p . showChar ')' else p
+
+readParen   	:: Bool -> ReadS a -> ReadS a
+readParen b g	=  if b then mandatory else optional
+		   where optional r  = g r ++ mandatory r
+			 mandatory r = [(x,u) | ("(",s) <- lex r,
+						(x,t)   <- optional s,
+						(")",u) <- lex t    ]
+
+lex 	    		:: ReadS String
+lex ""			= [("","")]
+lex (c:s) | isSpace c	= lex (dropWhile isSpace s)
+lex ('-':'-':s)		= case dropWhile (/= '\n') s of
+				 '\n':t -> lex t
+				 _	-> [] -- unterminated end-of-line
+					      -- comment
+
+lex ('{':'-':s)		= lexNest lex s
+			  where
+			  lexNest f ('-':'}':s) = f s
+			  lexNest f ('{':'-':s) = lexNest (lexNest f) s
+			  lexNest f (c:s)	      = lexNest f s
+			  lexNest _ ""		= [] -- unterminated
+						     -- nested comment
+
+lex ('<':'-':s)		= [("<-",s)]
+lex ('\'':s)		= [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
+					       ch /= "'"		]
+lex ('"':s)		= [('"':str, t)      | (str,t) <- lexString s]
+			  where
+			  lexString ('"':s) = [("\"",s)]
+			  lexString s = [(ch++str, u)
+						| (ch,t)  <- lexStrItem s,
+						  (str,u) <- lexString t  ]
+
+			  lexStrItem ('\\':'&':s) = [("\\&",s)]
+			  lexStrItem ('\\':c:s) | isSpace c
+			      = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
+			  lexStrItem s		  = lexLitChar s
+
+lex (c:s) | isSingle c	= [([c],s)]
+	  | isSym1 c	= [(c:sym,t)	     | (sym,t) <- [span isSym s]]
+	  | isAlpha c	= [(c:nam,t)	     | (nam,t) <- [span isIdChar s]]
+	  | isDigit c	= [(c:ds++fe,t)	     | (ds,s)  <- [span isDigit s],
+					       (fe,t)  <- lexFracExp s	   ]
+	  | otherwise	= []	-- bad character
+		where
+		isSingle c  =  c `elem` ",;()[]{}_"
+		isSym1 c    =  c `elem` "-~" || isSym c
+		isSym c	    =  c `elem` "!@#$%&*+./<=>?\\^|:"
+		isIdChar c  =  isAlphanum c || c `elem` "_'"
+
+		lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
+						      (e,u)  <- lexExp t    ]
+		lexFracExp s	   = [("",s)]
+
+		lexExp (e:s) | e `elem` "eE"
+			 = [(e:c:ds,u) | (c:t)	<- [s], c `elem` "+-",
+						   (ds,u) <- lexDigits t] ++
+			   [(e:ds,t)   | (ds,t)	<- lexDigits s]
+		lexExp s = [("",s)]
+
+lexDigits		:: ReadS String	
+lexDigits		=  nonnull isDigit
+
+nonnull			:: (Char -> Bool) -> ReadS String
+nonnull p s		=  [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+lexLitChar		:: ReadS String
+lexLitChar ('\\':s)	=  [('\\':esc, t) | (esc,t) <- lexEsc s]
+	where
+	lexEsc (c:s)	 | c `elem` "abfnrtv\\\"'" = [([c],s)]
+	lexEsc ('^':c:s) | c >= '@' && c <= '_'  = [(['^',c],s)]
+	lexEsc s@(d:_)	 | isDigit d		 = lexDigits s
+	lexEsc ('o':s)	=  [('o':os, t) | (os,t) <- nonnull isOctDigit s]
+	lexEsc ('x':s)	=  [('x':xs, t) | (xs,t) <- nonnull isHexDigit s]
+	lexEsc s@(c:_)	 | isUpper c
+			=  case [(mne,s') | mne <- "DEL" : elems asciiTab,
+					    ([],s') <- [match mne s]	  ]
+			   of (pr:_) -> [pr]
+			      []     -> []
+	lexEsc _	=  []
+lexLitChar (c:s)	=  [([c],s)]
+lexLitChar ""		=  []
+
+isOctDigit c  =  c >= '0' && c <= '7'
+isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
+			   || c >= 'a' && c <= 'f'
+
+match			:: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y  =  match xs ys
+match xs     ys		      =  (xs,ys)
+
+asciiTab = listArray ('\NUL', ' ')
+	   ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+	    "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", 
+	    "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+	    "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", 
+	    "SP"] 
+
+
+
+readLitChar 		:: ReadS Char
+readLitChar ('\\':s)	=  readEsc s
+	where
+	readEsc ('a':s)	 = [('\a',s)]
+	readEsc ('b':s)	 = [('\b',s)]
+	readEsc ('f':s)	 = [('\f',s)]
+	readEsc ('n':s)	 = [('\n',s)]
+	readEsc ('r':s)	 = [('\r',s)]
+	readEsc ('t':s)	 = [('\t',s)]
+	readEsc ('v':s)	 = [('\v',s)]
+	readEsc ('\\':s) = [('\\',s)]
+	readEsc ('"':s)	 = [('"',s)]
+	readEsc ('\'':s) = [('\'',s)]
+	readEsc ('^':c:s) | c >= '@' && c <= '_'
+			 = [(chr (ord c - ord '@'), s)]
+	readEsc s@(d:_) | isDigit d
+			 = [(chr n, t) | (n,t) <- readDec s]
+	readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
+	readEsc ('x':s)	 = [(chr n, t) | (n,t) <- readHex s]
+	readEsc s@(c:_) | isUpper c
+			 = let table = ('\DEL' := "DEL") : assocs asciiTab
+			   in case [(c,s') | (c := mne) <- table,
+					     ([],s') <- [match mne s]]
+			      of (pr:_) -> [pr]
+				 []	-> []
+	readEsc _	 = []
+readLitChar (c:s)	=  [(c,s)]
+
+showLitChar 		   :: Char -> ShowS
+showLitChar c | c > '\DEL' =  showChar '\\' . protectEsc isDigit (shows (ord c))
+showLitChar '\DEL'	   =  showString "\\DEL"
+showLitChar '\\'	   =  showString "\\\\"
+showLitChar c | c >= ' '   =  showChar c
+showLitChar '\a'	   =  showString "\\a"
+showLitChar '\b'	   =  showString "\\b"
+showLitChar '\f'	   =  showString "\\f"
+showLitChar '\n'	   =  showString "\\n"
+showLitChar '\r'	   =  showString "\\r"
+showLitChar '\t'	   =  showString "\\t"
+showLitChar '\v'	   =  showString "\\v"
+showLitChar '\SO'	   =  protectEsc (== 'H') (showString "\\SO")
+showLitChar c		   =  showString ('\\' : asciiTab!c)
+
+protectEsc p f		   = f . cont
+			     where cont s@(c:_) | p c = "\\&" ++ s
+				   cont s	      = s
+
+readDec, readOct, readHex :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit (\d -> ord d - ord '0')
+readOct = readInt  8 isOctDigit (\d -> ord d - ord '0')
+readHex = readInt 16 isHexDigit hex
+	    where hex d = ord d - (if isDigit d then ord '0'
+				   else ord (if isUpper d then 'A' else 'a')
+					- 10)
+
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+    [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+	| (ds,r) <- nonnull isDig s ]
+
+showInt	:: (Integral a) => a -> ShowS
+showInt n r = let (n',d) = quotRem n 10
+		  r' = chr (ord '0' + fromIntegral d) : r
+	      in if n' == 0 then r' else showInt n' r'
+
+readSigned:: (Real a) => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+		     where read' r  = read'' r ++
+				      [(-x,t) | ("-",s) <- lex r,
+						(x,t)   <- read'' s]
+			   read'' r = [(n,s)  | (str,s) <- lex r,
+		      				(n,"")  <- readPos str]
+
+showSigned:: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+						 (showChar '-' . showPos (-x))
+				  else showPos x
+
+
+-- The functions readFloat and showFloat below use rational arithmetic
+-- to insure correct conversion between the floating-point radix and
+-- decimal.  It is often possible to use a higher-precision floating-
+-- point type to obtain the same results.
+
+readFloat:: (RealFloat a) => ReadS a
+readFloat r = [(fromRational ((n%1)*10^^(k-d)), t) | (n,d,s) <- readFix r,
+						     (k,t)   <- readExp s]
+              where readFix r = [(read (ds++ds'), length ds', t)
+					| (ds,'.':s) <- lexDigits r,
+					  (ds',t)    <- lexDigits s ]
+
+		    readExp (e:s) | e `elem` "eE" = readExp' s
+                    readExp s			  = [(0,s)]
+
+                    readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+                    readExp' ('+':s) = readDec s
+                    readExp' s	     = readDec s
+
+-- The number of decimal digits m below is chosen to guarantee 
+-- read (show x) == x.  See
+--	Matula, D. W.  A formalization of floating-point numeric base
+--	conversion.  IEEE Transactions on Computers C-19, 8 (1970 August),
+--	681-692.
+ 
+showFloat:: (RealFloat a) => a -> ShowS
+showFloat x =
+    if x == 0 then showString ("0." ++ take (m-1) (repeat '0'))
+	      else if e >= m-1 || e < 0 then showSci else showFix
+    where
+    showFix	= showString whole . showChar '.' . showString frac
+		  where (whole,frac) = splitAt (e+1) (show sig)
+    showSci	= showChar d . showChar '.' . showString frac
+		      . showChar 'e' . shows e
+    		  where (d:frac) = show sig
+    (m, sig, e) = if b == 10 then (w,  	s,   n+w-1)
+		  	     else (m', sig', e'   )
+    m'		= ceiling
+		      (fromIntegral w * log (fromInteger b) / log 10 :: Double)
+		  + 1
+    (sig', e')	= if	  sig1 >= 10^m'     then (round (t/10), e1+1)
+		  else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
+		  			    else (sig1,		e1  )
+    sig1 :: Integer
+    sig1	= round t
+    t		= s%1 * (b%1)^^n * 10^^(m'-e1-1)
+    e1		= floor (logBase 10 x)
+    (s, n)	= decodeFloat x
+    b		= floatRadix x
+    w		= floatDigits x
diff --git a/progs/prelude/PreludeTuple.hs b/progs/prelude/PreludeTuple.hs
new file mode 100644
index 0000000..4f2637a
--- /dev/null
+++ b/progs/prelude/PreludeTuple.hs
@@ -0,0 +1,213 @@
+module PreludeTuple where
+
+{-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
+
+import PreludeTuplePrims
+
+-- This module contains support routines which handle tuple instances.
+-- These are based on a implementation level data type which represents
+-- general tuples and a data type to hold the set of dictionaries which
+-- are associated with the tuple.
+
+-- Each of these functions takes the tupledicts as the first argument.
+-- Force all of these functions to take strict arguments because they'll
+-- never be called with 0-length tuples anyway.
+
+-- The following primitives operate on tuples.  
+
+--  tupleSize :: TupleDicts -> Int
+--  tupleSel :: Tuple -> Int -> Int -> a
+--  dictSel :: TupleDicts -> method -> Int -> a
+--  listToTuple :: [a] -> Tuple
+
+-- Eq functions
+
+tupleEq :: TupleDicts -> Tuple -> Tuple -> Bool
+{-#  tupleEq :: Strictness("S,S,S") #-}
+tupleEq dicts x y = tupleEq1 0 where
+  tupleEq1 i | i == size = True
+             | otherwise =
+                  ((dictSel (cmpEq dicts i)) x' y') && tupleEq1 (i+1)
+     where
+        x' = tupleSel x i size
+        y' = tupleSel y i size
+  size = tupleSize dicts
+
+cmpEq x y = x == y
+
+tupleNeq dicts x y = not (tupleEq dicts x y)
+
+-- Ord functions
+
+tupleLe :: TupleDicts -> Tuple -> Tuple -> Bool
+{-#  tupleLe :: Strictness("S,S,S") #-}
+tupleLe dicts x y = tupleLe1 0 where
+  tupleLe1 i | i == size = False
+             | (dictSel (cmpLs dicts i)) x' y' = True
+	     | (dictSel (ordEq dicts i)) x' y' = tupleLe1 (i+1)
+	     | otherwise = False
+      where
+        x' = tupleSel x i size
+        y' = tupleSel y i size
+  size = tupleSize dicts
+
+cmpLs x y = x < y
+
+ordEq :: Ord a => a -> a -> Bool
+ordEq x y = x == y
+
+tupleLeq :: TupleDicts -> Tuple -> Tuple -> Bool
+{-#  tupleLeq :: Strictness("S,S,S") #-}
+tupleLeq dicts x y = tupleLeq1 0 where
+  tupleLeq1 i | i == size = True
+             | (dictSel (cmpLs dicts i)) x' y' = True
+	     | (dictSel (ordEq dicts i)) x' y' = tupleLeq1 (i+1)
+	     | otherwise = False
+      where
+        x' = tupleSel x i size
+        y' = tupleSel y i size
+  size = tupleSize dicts
+
+tupleGe :: TupleDicts -> Tuple -> Tuple -> Bool
+tupleGe d x y = tupleLe d y x
+
+tupleGeq :: TupleDicts -> Tuple -> Tuple -> Bool
+tupleGeq d x y = tupleLeq d y x
+
+tupleMax,tupleMin :: TupleDicts -> Tuple -> Tuple -> Tuple
+tupleMax d x y = if tupleGe d x y then x else y
+tupleMin d x y = if tupleLe d x y then x else y
+
+-- Ix functions
+
+tupleRange :: TupleDicts -> (Tuple,Tuple) -> [Tuple]
+{-#  tupleRange :: Strictness("S,S") #-}
+
+tupleRange dicts (x,y) = map listToTuple (tupleRange' 0) where
+  tupleRange' i | i == size = [[]]
+                | otherwise =
+                   [(i1 : i2) | i1 <- r, i2 <- tupleRange' (i+1)]
+      where
+        x' = tupleSel x i size
+        y' = tupleSel y i size
+        r = (dictSel (range' dicts i)) (x',y')
+  size = tupleSize dicts
+
+range' x = range x
+
+tupleIndex :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Int
+{-#  tupleIndex :: Strictness("S,S,S") #-}
+
+tupleIndex dicts (low,high) n = tupleIndex' (size-1) where
+  size = tupleSize dicts
+  tupleIndex' i | i == 0 = i'
+                | otherwise = i' + r' * (tupleIndex' (i-1))
+   where
+    low' = tupleSel low i size
+    high' = tupleSel high i size
+    n' = tupleSel n i size
+    i' = (dictSel (index' dicts i)) (low',high') n'
+    r' = (dictSel (rangeSize dicts i)) (low',high')
+
+index' x = index x
+
+rangeSize               :: (Ix a) => (a,a) -> Int
+rangeSize (l,u)         =  index (l,u) u + 1
+
+tupleInRange :: TupleDicts -> (Tuple,Tuple) -> Tuple -> Bool
+{-#  tupleInRange :: Strictness("S,S,S") #-}
+tupleInRange dicts (low,high) n = tupleInRange' 0 where
+  size = tupleSize dicts
+  tupleInRange' i | i == size = True
+                  | otherwise = (dictSel (inRange' dicts i)) (low',high') n'
+		                && tupleInRange' (i+1)
+   where
+    low' = tupleSel low i size
+    high' = tupleSel high i size
+    n' = tupleSel n i size
+   
+inRange' x = inRange x
+
+-- Text functions
+
+tupleReadsPrec :: TupleDicts -> Int -> ReadS Tuple
+
+tupleReadsPrec dicts p = readParen False
+                          (\s -> map ( \ (t,w) -> (listToTuple t,w))
+			             (tRP' s 0))
+    where
+      size = tupleSize dicts
+      tRP' s i | i == 0 = [(t':t,w) |
+                             ("(",s1) <- lex s,
+                             (t',s2) <- nextItem s1,
+                             (t,w) <- tRP' s2 (i+1)]
+               | i == size = [([],w) | (")",w) <- lex s]
+               | otherwise =
+                        [(t':t,w) | 
+                             (",",s1) <- lex s,
+                             (t',s2) <- nextItem s1,
+                             (t,w) <- tRP' s2 (i+1)]
+       where
+        nextItem s = (dictSel (reads dicts i)) s
+
+tupleShowsPrec :: TupleDicts -> Int -> Tuple -> ShowS
+
+tupleShowsPrec dicts p tuple =  
+  showChar '(' . tSP' 0
+    where
+      size = tupleSize dicts
+      tSP' i | i == (size-1) =
+                 showTup . showChar ')'
+             | otherwise =
+                 showTup . showChar ',' . tSP' (i+1)
+        where
+          showTup = (dictSel (shows dicts i)) (tupleSel tuple i size)
+                                    
+tupleReadList :: TupleDicts -> ReadS [Tuple]
+
+tupleReadList dicts =
+                  readParen False (\r -> [pr | ("[",s)	<- lex r,
+					       pr	<- readl s])
+	          where readl  s = [([],t)   | ("]",t)  <- lex s] ++
+				   [(x:xs,u) | (x,t)    <- tupleReads s,
+					       (xs,u)   <- readl' t]
+			readl' s = [([],t)   | ("]",t)  <- lex s] ++
+			           [(x:xs,v) | (",",t)  <- lex s,
+					       (x,u)	<- tupleReads t,
+					       (xs,v)   <- readl' u]
+                        tupleReads s = tupleReadsPrec dicts 0 s
+
+tupleShowList :: TupleDicts -> [Tuple] -> ShowS
+
+tupleShowList dicts [] = showString "[]"
+tupleShowList dicts (x:xs)
+		= showChar '[' . showsTuple x . showl xs
+		  where showl []     = showChar ']'
+			showl (x:xs) = showString ", " . showsTuple x
+			                               . showl xs
+                        showsTuple x = tupleShowsPrec dicts 0 x
+
+-- Binary functions
+
+tupleShowBin :: TupleDicts -> Tuple -> Bin -> Bin
+
+tupleShowBin dicts t bin = tSB' 0
+  where
+    size = tupleSize dicts
+    tSB' i | i == size = bin
+    tSB' i | otherwise =
+                  (dictSel (showBin' dicts i)) (tupleSel t i size) (tSB' (i+1))
+
+showBin' x = showBin x
+
+tupleReadBin :: TupleDicts -> Bin -> (Tuple,Bin)
+
+tupleReadBin dicts bin = (listToTuple t,b) where
+  size = tupleSize dicts
+  (t,b) = tRB' bin 0
+  tRB' b i | i == size = ([],b)
+           | otherwise = (t':ts,b') where
+     (t',b'') = (dictSel (readBin' dicts i)) b
+     (ts,b') = tRB' b'' (i+1)
+
+readBin' x = readBin x
diff --git a/progs/prelude/PreludeTuplePrims.hi b/progs/prelude/PreludeTuplePrims.hi
new file mode 100644
index 0000000..6af0dfd
--- /dev/null
+++ b/progs/prelude/PreludeTuplePrims.hi
@@ -0,0 +1,48 @@
+
+-- This is the interface to the primitives used to implement arbitrary
+-- sized tuples.
+
+interface PreludeTuplePrims where
+
+{-# Prelude #-}
+
+-- The type checker fiddles around with the call to dictSel to use the
+-- dictionary to resolve the overloading of a subexpression.  The call
+-- dictSel (exp dict i) will typecheck exp and use the ith component of
+-- the tupleDict dict to resolve the overloading.  No check is made to ensure
+-- that the type of the dictionary matches the overloaded class!  Beware!
+
+import PreludeData(Int)
+
+data Tuple
+data TupleDicts
+
+
+tupleSize :: TupleDicts -> Int
+tupleSel :: Tuple -> Int -> Int -> a
+dictSel :: TupleDicts -> Int -> a
+listToTuple :: [a] -> Tuple
+-- These are not called by haskell code directly; these are introduced
+-- during dictionary conversion by the type checker.
+tupleEqDict :: a
+tupleOrdDict :: a
+tupleIxDict :: a
+tupleTextDict :: a
+tupleBinaryDict :: a
+
+{-#
+tupleSize ::       LispName("prim.tupleSize"), Complexity(1)
+tupleSel ::        LispName("prim.tupleSel")
+dictSel ::         LispName("prim.dict-sel")
+listToTuple ::     LispName("prim.list->tuple"), NoConversion
+tupleEqDict ::     LispName("prim.tupleEqDict")
+tupleOrdDict ::    LispName("prim.tupleOrdDict")
+tupleIxDict ::     LispName("prim.tupleIxDict")
+tupleTextDict ::   LispName("prim.tupleTextDict")
+tupleBinaryDict :: LispName("prim.tupleBinaryDict")
+
+#-}
+
+
+
+
diff --git a/progs/prelude/PreludeTuplePrims.hu b/progs/prelude/PreludeTuplePrims.hu
new file mode 100644
index 0000000..eaa0385
--- /dev/null
+++ b/progs/prelude/PreludeTuplePrims.hu
@@ -0,0 +1,4 @@
+:output $PRELUDEBIN/PreludeTuplePrims
+:stable
+:prelude
+PreludeTuplePrims.hi
diff --git a/progs/prelude/README b/progs/prelude/README
new file mode 100644
index 0000000..2decc21
--- /dev/null
+++ b/progs/prelude/README
@@ -0,0 +1,12 @@
+
+This is the actual prelude used by the Yale system.  This contains a many
+small changes to the standard prelude, mostly optimizer annotations.
+PreludeIO is totally different since we have flushed streams in favor
+of the monad.  Primitives are defined using the Haskell to Lisp interface.
+
+Arrays are implemented internally using destructive updates - no array
+primitive involves more than one copy operation and lookup is constant
+time.
+
+The data constructors for Complex and Rational are strict.
+
diff --git a/progs/tutorial/README b/progs/tutorial/README
new file mode 100644
index 0000000..defe248
--- /dev/null
+++ b/progs/tutorial/README
@@ -0,0 +1,12 @@
+
+This is the text of the online version of the tutorial.  It is set up to
+run under Emacs only.  Form feeds divide the pages of the tutorial.  Emacs
+has a special mode just for the tutorial which makes a local copy of each
+page for the user to scribble on without disturbing this source.
+
+It is possible that this could be adapted to the command interface by
+breaking it up into one file per page.
+
+This is still preliminary - we need to work on the text and examples.
+Please send comments to haskell-request@cs.yale.edu.
+
diff --git a/progs/tutorial/tutorial.hs b/progs/tutorial/tutorial.hs
new file mode 100644
index 0000000..eb6a78d
--- /dev/null
+++ b/progs/tutorial/tutorial.hs
@@ -0,0 +1,2143 @@
+-- Page 0    Introduction
+
+This is a programming supplement to `A Gentle Introduction to Haskell'
+by Hudak and Fasel.  This supplement augments the tutorial by
+providing executable Haskell programs which you can run and
+experiment with.  All program fragments in the tutorial are
+found here, as well as other examples not included in the tutorial.
+
+
+Using This Tutorial
+
+You should have a copy of both the `Gentle Introduction' and the
+report itself to make full use of this tutorial.  Although the
+`Gentle Introduction' is meant to stand by itself, it is often easier
+to learn a language through actual use and experimentation than by
+reading alone.  Once you finish this introduction, we recommend that
+you proceed section by section through the `Gentle Introduction' and
+after having read each section go back to this online tutorial.  You
+should wait until you have finished the tutorial before attempting to
+read the report.  We assume that you are familiar with the basics of
+Emacs and that Haskell has been installed at your site.
+
+This tutorial does not assume any familiarity with Haskell or other
+functional languages.  However, knowledge of almost-functional
+languages such as ML or Scheme is very useful.  Throughout the
+online component of this tutorial, we try to relate Haskell to
+other programming languages and clarify the written tutorial through
+additional examples and text.
+
+
+Organization of the Online Tutorial
+
+This online tutorial is divided into a series of pages.  Each page
+covers one or more sections in the written tutorial.  You can use
+special Emacs commands to move back and forth through the pages of the
+online tutorial.  Each page is a single Haskell program.  Comments in
+the program contain the text of the online tutorial.  You can modify
+the program freely (this will not change the underlying tutorial
+file!) and ask the system to print the value of expressions defined in
+the program.
+
+At the beginning of each page, the sections covered by the page are
+listed.  In addition, the start of each individual section is
+marked within each page.  Emacs commands can take you directly to a
+specific page or section in the tutorial.
+
+To create useful, executable examples of Haskell code, some language
+constructs need to be revealed well before they are explained in the
+tutorial.  We attempt to point these out when they occur.  Some
+small changes have been made to the examples in the written tutorial;
+these are usually cosmetic and should be ignored.  Don't feel you have
+to understand everything on a page before you move on -- many times
+concepts become clearer as you move on and can relate them to other
+aspect of the language.
+
+Each page of the tutorial defines a set of variables.  Some of
+these are named e1, e2, and so on.  These `e' variables are the ones
+which are meant for you to evaluate as you go through the tutorial.
+Of course you may evaluate any other expressions or variables you wish.
+
+
+The Haskell Report
+
+While the report is not itself a tutorial on the Haskell language, it
+can be an invaluable reference to even a novice user.  A very
+important feature of Haskell is the prelude.  The prelude is a
+rather large chunk of Haskell code which is implicitly a part of every
+Haskell program.  Whenever you see functions used which are not
+defined in the current page, these come from the Prelude.  Appendix A
+of the report lists the entire Prelude; the index has an entry for
+every function in the Prelude.  Looking at the definitions in the
+Prelude is sometimes necessary to fully understand the programs in
+this tutorial.
+
+Another reason to look at the report is to understand the syntax of
+Haskell.  Appendix B contains the complete syntax for Haskell.  The
+tutorial treats the syntax very informally; the precise details are
+found only in the report.
+
+
+The Yale Haskell System
+
+This version of the tutorial runs under version Y2.0 of Yale Haskell.
+The Yale Haskell system is an interactive programming environment for
+the Haskell language.  The system is best used in conjunction with the
+Emacs editor.  Yale Haskell is available free of change via ftp.
+
+
+Using the Compiler
+
+Yale Haskell runs as a subprocess under Emacs.  While many commands
+are available to the Yale Haskell user, a single command is the
+primary means of communicating with the compiler: C-c e.  This command
+evaluates and prints an expression in the context of the program on
+the screen.  Here is what this command does:
+
+a) You are prompted for an expression in the minibuffer.  You can
+use M-p or M-n to move through a ring of previous inputs.
+
+b) If an inferior Haskell process is not running, a buffer named *haskell*
+is created and the Haskell compiler is started up.  The *haskell* buffer
+pops onto your screen.
+
+c) If the program in the current page of the tutorial has not yet been
+compiled or the page has been modified after its most recent
+compilation, the entire page is compiled.  This may result in a short delay.
+
+d) If there are no errors in the program, the expression entered in
+step a) is compiled in the context of the program.  Any value defined
+in the current page can be referenced.
+
+e) If there are no errors in the expression, its value is printed in
+the *haskell* buffer.
+
+There are also a few other commands you can use.  C-c i interrupts
+the Haskell program.  Some tight loops cannot be interrupted; in this
+case you will have to kill the Haskell process.    C-c q exits the Haskell
+process.
+
+
+Emacs Commands Used by the Tutorial
+
+These commands are specific to the tutorial.  The tutorial is entered
+using M-x haskell-tutorial and is exited with C-c q.  To move among
+the pages of the tutorial, use
+
+C-c C-f  -- go forward 1 page
+C-c C-b  -- go back 1 page
+M-x ht-goto-page    - goto a specific page of the tutorial
+M-x ht-goto-section - goto a specific section of the tutorial
+
+Each page of the tutorial can be modified without changing the
+underlying text of the tutorial.  Changes are not saved as you go
+between pages.  To revert a page to its original form use C-c C-l.
+
+You can get help regarding the Emacs commands with C-c ?.
+
+Summary of Emacs commands used by the tutorial:
+  M-x haskell-tutorial  - start the tutorial
+  C-c C-f  - Go to the next page of the tutorial program
+  C-c C-b  - Go back to the previous page of the tutorial program
+  C-c C-l  - Restore the current page to its original form
+  C-c e    - Evaluate a Haskell expression
+  C-c i    - Interrupt a running Haskell program
+  C-c ?    - Shows a help message
+  M-x ht-goto-page    - goto a specific page of the tutorial
+  M-x ht-goto-section - goto a specific section of the tutorial
+
+
+You are now ready to start the tutorial.  Start by reading the `Gentle
+Introduction' section 1 then proceed through the online tutorial using
+C-c C-f to advance to the next page.  You should read about each topic
+first before turning to the associated programming example in the
+online tutorial.
+
+
+-- Page 1   Section 2
+
+-- Section 2   Values, Types, and Other Goodies
+
+-- Haskell uses `--' to designate end of line comments.  We use these
+-- throughout the tutorial to place explanatory text in the program.
+
+-- Remember to use C-c e to evaluate expressions, C-c ? for help.
+
+-- All Haskell programs must start with a module declaration.  Ignore this
+-- for now.
+
+module Test(Bool) where
+
+-- We will start by defining some identifiers (variables) using equations.
+-- You can print out the value of an identifier by typing C-c e and
+-- typing the name of the identifier you wish to evaluate.  This will
+-- compile the entire program, not just the line with the definition
+-- you want to see.  Not all definitions are very interesting to print out -
+-- by convention, we will use variables e1, e2, ... to denote values that
+-- are `interesting' to print.
+
+-- We'll start with some constants as well as their associated type.
+-- There are two ways to associate a type with a value: a type declaration
+-- and an expression type signature.  Here is an equation and a type
+-- declaration:
+
+e1 :: Int     -- This is a type declaration for the identifier e1
+e1 = 5        -- This is an equation defining e1
+
+-- You can evaluate the expression e1 and watch the system print `5'!  Wow!
+
+-- Remember that C-c e is prompting for an expression.  Expressions like
+-- e1 or 5 or 1+1 are all valid.  However, `e1 = 5' is a definition,
+-- not an expression.  Trying to evaluate it will result in a syntax error.
+
+-- The type declaration for e1 is not really necessary but we will try to
+-- always provide type declarations for values to help document the program
+-- and to ensure that the system infers the same type we do for an expression.
+-- If you change the value for e1 to `True', the program will no longer
+-- compile due to the type mismatch.
+
+-- We will briefly mention expression type signatures: these are attached to 
+-- expressions instead of identifiers.  Here are equivalent ways to do
+-- the previous definition:
+
+e2 = 5 :: Int
+e3 = (2 :: Int) + (3 :: Int)
+
+-- The :: has very low precedence in expressions and should usually be placed
+-- in parenthesis.
+
+-- Note that there are two completely separate languages: an expression
+-- language for values and a type language for type signatures.  The type
+-- language is used only in the type declarations previously described and
+-- declarations of new types, described later.  Haskell uses a
+-- uniform syntax so that values resemble their type signature as much as
+-- possible.  However, you must always be aware of the difference between
+-- type expressions and value expressions.
+
+-- Here are some of the predefined types Haskell provides:
+--    type           Value Syntax                Type Syntax
+-- Small integers    <digits>                    Int
+e4 :: Int
+e4 = 12345
+-- Characters        '<character>'               Char
+e5 :: Char
+e5 = 'a'
+-- Boolean           True, False                 Bool
+e6 :: Bool
+e6 = True
+-- Floating point    <digits.digits>             Float
+e7 :: Float
+e7 = 123.456
+-- We will introduce these types now; there will be much more to say later.
+-- Homogenous List   [<exp1>,<exp2>,...]         [<constituant type>]
+e8 :: [Int]
+e8 = [1,2,3]
+-- Tuple             (<exp1>,<exp2>,...)         (<exp1-type>,<exp2-type>,...)
+e9 :: (Char,Int)
+e9 = ('b',4)
+-- Functional        described later             domain type -> range type
+succ :: Int -> Int  -- a function which takes an Int argument and returns Int
+succ x = x + 1      -- test this by evaluating `succ 4'
+
+-- Here's a few leftover examples from section 2:
+
+e10 = succ (succ 3)  -- you could also evaluate `succ (succ 3)' directly
+                     -- by entering the entire expression to the C-c e
+ 
+-- If you want to evaluate something more complex than the `e' variables
+-- defined here, it is better to enter a complex expression, such as
+-- succ (succ 3), directly than to edit a new definition like e10 into
+-- the program.  This is because any change to the program will require
+-- recompilation of the entire page.  The expressions entered to C-c e are
+-- compiled separately (and very quickly!).
+
+-- Uncomment this next line to see a compile time type error.
+-- e11 = 'a'+'b'
+-- Don't worry about the error message - it will make more sense later.
+
+-- Proceed to the next page using C-c C-f
+
+-- Page 2   Section 2.1
+
+-- Section 2.1   Polymorphic Types
+
+module Test(Bool) where
+
+-- The following line allows us to redefine functions in the standard
+-- prelude.  Ignore this for now.
+
+import Prelude hiding (length,head,tail,null)
+
+-- start with some sample lists to use in test cases
+
+list1 :: [Int]
+list1 = [1,2,3]
+list2 :: [Char]         -- This is the really a string
+list2 = ['a','b','c']   -- This is the same as "abc"; evaluate list2 and see.
+list3 :: [[a]]          -- The element type of the inner list is unknown
+list3 = [[],[],[],[]]   -- so this list can't be printed
+list4 :: [Int]
+list4 = 1:2:3:4:[]      -- Exactly the same as [1,2,3,4]; print it and see.
+
+-- This is the length function.  You can test it by evaluating expressions
+-- such as `length list1'.  Function application is written by
+-- simple juxtaposition: `f(x)' in other languages would be `f x' in Haskell.
+
+length :: [a] -> Int
+length [] = 0
+length (x:xs) = 1 + length xs
+
+-- Function application has the highest precedence, so 1 + length xs is
+-- parsed as 1 + (length xs).  In general, you have to surround
+-- non-atomic arguments to a function with parens.  This includes
+-- arguments which are also function applications.  For example,
+-- f g x is the function f applied to arguments g and x, similar to
+-- f(g,x) in other languages.  However, f (g x) is f applied to (g x), or
+-- f(g(x)), which means something quite different!  Be especially
+-- careful with infix operators: f x+1 y-2 would be parsed as (f x)+(1 y)-2.
+-- This is also true on the left of the `=': the parens around (x:xs) are
+-- absolutely necessary.  length x:xs would be parsed as (length x):xs.
+
+-- Also be careful with prefix negation, -.  The application `f -1' is
+-- f-1, not f(-1).  Add parens around negative numbers to avoid this
+-- problem.
+
+-- Here are some other list functions:
+
+head :: [a] -> a   -- returns the first element in a list (same as car in lisp)
+head (x:xs) = x
+
+tail :: [a] -> [a] -- removes the first element from a list (same as cdr)
+tail (x:xs) = xs
+
+null :: [a] -> Bool
+null [] = True
+null (x:xs) = False
+
+cons :: a -> [a] -> [a]
+cons x xs = x:xs
+
+nil :: [a]
+nil = []
+
+-- Length could be defined using these functions too.  This is
+-- not good Haskell style but does illustrate these other list functions.
+-- The if - then - else will be discussed later.  Haskell programmers feel
+-- that the pattern matching style, as used in the previous version of
+-- length, is more natural and readable.
+
+length' :: [a] -> Int   -- Note that ' can be part of a name
+length' x = if null x then 0 else 1 + length' (tail x)
+
+-- A test case for length', cons, and nil
+
+e1 = length' (cons 1 (cons 2 nil))
+
+-- We haven't said anything about errors yet.  Each of the following
+-- examples illustrates a potential runtime or compile time error.  The
+-- compile time error is commented out so that other examples will compile;
+-- you can uncomment them and see what happens.
+
+-- e2 = cons True False   -- Why is this not possible in Haskell?
+e3 = tail (tail ['a'])  -- What happens if you evaluate this?
+e4 = []       -- This is especially mysterious!
+
+-- This last example, e4, is something hard to explain but is often
+-- encountered early by novices.  We haven't explained yet how the system
+-- prints out the expressions you type in - this will wait until later.
+-- However, the problem here is that e4 has the type [a].  The printer for
+-- the list datatype is complaining that it needs to know a specific type
+-- for the list elements even though the list has no elements!  This can
+-- be avoided by giving e4 a type such as [Int].  (To further confuse you,
+-- try giving e4 the type [Char] and see what happens.)
+
+-- Page 3   Section 2.2
+
+-- Section 2.2  User-Defined Types
+
+module Test(Bool) where
+
+-- The type Bool is already defined in the Prelude so there is no
+-- need to define it here.
+
+data Color = Red | Green | Blue | Indigo | Violet deriving Text
+-- The `deriving Text' is necessary if you want to print a Color value.
+
+-- You can now evaluate these expressions.
+e1 :: Color
+e1 = Red
+e2 :: [Color]
+e2 = [Red,Blue]
+
+-- It is very important to keep the expression language and the type
+-- language in Haskell separated.  The data declaration above defines
+-- the type constructor Color.  This is a nullary constructor: it takes no
+-- arguments.  Color is found ONLY in the type language - it can not be
+-- part of an expression.  e1 = Color is meaningless.  (Actually, Color could
+-- be both a data constructor and a type constructor but we'll ignore this
+-- possibility for now).  On the other hand, Red, Blue, and so on are
+-- (nullary) data constructors.  They can appear in expressions and
+-- in patterns (described later).  The declaration e1 :: Blue would also
+-- be meaningless.  Data constructors can be defined ONLY in a data
+-- declaration.
+
+-- In the next example, Point is a type constructor and Pt is a data
+-- constructor.  Point takes one argument and Pt takes two.  A data constructor
+-- like Pt is really just an ordinary function except that it can be used in
+-- a pattern.  Type signatures can not be supplied directly for data
+-- constructors; their typing is completely defined by the data declaration.
+-- However, data constructors have a signature just like any variable:
+-- Pt :: a -> a -> Point a   -- Not valid Haskell syntax
+-- That is, Pt is a function which takes two arguments with the same
+-- arbitrary type and returns a value containing the two argument values.
+
+data Point a = Pt a a   deriving Text
+
+e3 :: Point Float
+e3 = Pt 2.0 3.0
+e4 :: Point Char
+e4 = Pt 'a' 'b'
+e5 :: Point (Point Int)
+e5 = Pt (Pt 1 2) (Pt 3 4)
+-- e6 = Pt 'a' True         -- This is a typing error
+
+-- The individual components of a point do not have names.
+-- Let's jump ahead a little so that we can write functions using these
+-- data types.  Data constructors (Red, Blue, ..., and Pt) can be used in
+-- patterns.  When more than one equation is used to define a function,
+-- pattern matching occurs top down.
+
+-- A function to remove red from a list of colors.
+
+removeRed :: [Color] -> [Color]
+removeRed [] = []
+removeRed (Red:cs) = removeRed cs
+removeRed (c:cs) = c : removeRed cs  -- c cannot be Red at this point
+
+e7 :: [Color]
+e7 = removeRed [Blue,Red,Green,Red]
+
+-- Pattern matching is capable of testing equality with a specific color.
+
+-- All equations defining a function must share a common type.  A
+-- definition such as:
+-- foo Red = 1
+-- foo (Pt x y) = x
+-- would result in a type error since the argument to foo cannot be both a
+-- Color and a Point.  Similarly, the right hand sides must also share a
+-- common type; a definition such as
+-- foo Red = Blue
+-- foo Blue = Pt Red Red
+-- would also result in a type error.
+
+-- Here's a couple of functions defined on points.
+
+dist :: Point Float -> Point Float -> Float
+dist (Pt x1 y1) (Pt x2 y2) = sqrt ((x1-x2)^2 + (y1-y2)^2)
+
+midpoint :: Point Float -> Point Float -> Point Float
+midpoint (Pt x1 y1) (Pt x2 y2) = Pt ((x1+x2)/2) ((y1+y2)/2)
+
+p1 :: Point Float
+p1 = Pt 1.0 1.0
+p2 :: Point Float
+p2 = Pt 2.0 2.0
+
+e8 :: Float
+e8 = dist p1 p2
+e9 :: Point Float
+e9 = midpoint p1 p2
+
+-- The only way to take apart a point is to pattern match.
+-- That is, the two values which constitute a point must be extracted
+-- by matching a pattern containing the Pt data constructor.  Much
+-- more will be said about pattern matching later.
+
+-- Haskell prints values in the same syntax used in expressions.  Thus
+-- Pt 1 2 would print as Pt 1 2 (of course, Pt 1 (1+1) would also print
+-- as Pt 1 2).
+
+-- Page 4  Section 2.3
+
+-- Section 2.3  Recursive Types
+
+module Test where
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)    deriving Text
+
+-- The following typings are implied by this declaration.  As before,
+-- this is not valid Haskell syntax.
+-- Leaf :: a -> Tree a
+-- Branch :: Tree a -> Tree a -> Tree a
+
+fringe :: Tree a -> [a]
+fringe (Leaf x) = [x]
+fringe (Branch left right) = fringe left ++ fringe right
+
+-- The following trees can be used to test functions:
+
+tree1 :: Tree Int
+tree1 = Branch (Leaf 1) (Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 4))
+tree2 :: Tree Int
+tree2 = Branch (Branch (Leaf 3) (Leaf 1)) (Branch (Leaf 4) (Leaf 1))
+tree3 :: Tree Int
+tree3 = Branch tree1 tree2
+
+-- Try evaluating `fringe tree1' and others.
+
+-- Here's another tree function:
+
+twist :: Tree a -> Tree a
+twist (Branch left right) = Branch right left
+twist x = x        -- This equation only applies to leaves
+
+-- Here's a function which compares two trees to see if they have the
+-- same shape.  Note the signature: the two trees need not contain the
+-- same type of values.
+
+sameShape :: Tree a -> Tree b -> Bool
+sameShape (Leaf x) (Leaf y) = True
+sameShape (Branch l1 r1) (Branch l2 r2) = sameShape l1 l2 && sameShape r1 r2
+sameShape x y = False  -- One is a branch, the other is a leaf
+
+-- The && function is a boolean AND function.
+
+-- The entire pattern on the left hand side must match in order for the 
+-- right hand side to be evaluated.  The first clause requires both 
+-- arguments to be a leaf' otherwise the next equation is tested.  
+-- The last clause will always match: the final x and y match both 
+-- leaves and branches.
+
+-- This compares a tree of integers to a tree of booleans.
+e1 = sameShape tree1 (Branch (Leaf True) (Leaf False))
+
+-- Page 5  Sections 2.4, 2.5, 2.6
+
+-- Section 2.4  Type Synonyms
+
+module Test(Bool) where
+
+-- Since type synonyms are part of the type language only, it's hard to
+-- write a program which shows what they do.  Essentially, they are like
+-- macros for the type language.  They can be used interchangably with their
+-- definition:
+
+e1 :: String
+e1 = "abc"
+e2 :: [Char]   -- No different than String
+e2 = e1
+
+-- In the written tutorial the declaration of `Addr' is a data type
+-- declaration, not a synonym declaration.  This shows that the data
+-- type declaration as well as a signature can reference a synonym.
+
+-- Section 2.5  Built-in Types
+
+-- Tuples are an easy way of grouping a set of data values.  Here are
+-- a few tuples.  Note the consistancy in notation between the values and
+-- types.
+
+e3 :: (Bool,Int)
+e3 = (True,4)
+e4 :: (Char,[Int],Char)
+e4 = ('a',[1,2,3],'b')
+
+-- Here's a function which returns the second component of a 3 tuple.
+second :: (a,b,c) -> b
+second (a,b,c) = b
+
+-- Try out `second e3' and `second e4' - what happens?
+-- Each different size of tuple is a completely distinct type.  There is
+-- no general way to append two arbitrary tuples or randomly select the
+-- i'th component of an arbitrary tuple.  Here's a function built using
+-- 2-tuples to represent intervals.
+
+-- Use a type synonym to represent homogenous 2 tuples
+type Interval a = (a,a)
+
+containsInterval :: Interval Int -> Interval Int -> Bool
+containsInterval (xmin,xmax) (ymin,ymax) = xmin <= ymin && xmax >= ymax
+
+p1 :: Interval Int
+p1 = (2,3)
+p2 :: Interval Int
+p2 = (1,4)
+
+e5 = containsInterval p1 p2
+e6 = containsInterval p2 p1
+
+-- Here's a type declaration for a type isomorphic to lists:
+
+data List a = Nil | Cons a (List a) deriving Text
+
+-- Except for the notation, this is completely equivalent to ordinary lists
+-- in Haskell.
+
+length' :: List a -> Int
+length' Nil = 0
+length' (Cons x y) = 1 + length' y
+
+e7 = length' (Cons 'a' (Cons 'b' (Cons 'c' Nil)))
+
+-- It's hard to demonstrate much about the `non-specialness' of built-in
+-- types.  However, here is a brief summary:
+
+-- Numbers and characters, such as 1, 2.2, or 'a', are the same as nullary
+-- type constructors.
+
+-- Lists have a special type constructor, [a] instead of List a, and
+-- an odd looking data constructor, [].  The other data constructor, :, is
+-- not `unusual', syntactically speaking.  The notation [x,y] is just
+-- syntax for x:y:[] and "abc" for 'a' : 'b' : 'c' : [].
+
+-- Tuples use a special syntax.  In a type expression, a 2 tuple containing
+-- types a and be would be written (a,b) instead of using a prefix type
+-- constructor such as Tuple2 a b.  This same notation is used to build
+-- tuple values: (1,2) would construct a 2 tuple containing the values 1 and 2.
+
+
+-- Page 6   Sections 2.5.1, 2.5.2
+
+module Test(Bool) where
+
+-- Section 2.5.1  List Comprehensions and Arithmetic Sequences
+
+-- Warning: brackets in Haskell are used in three different types
+-- of expressions: lists, as in [a,b,c], sequences (distinguished by
+-- the ..), as in [1..2], and list comprehensions (distinguished by the
+-- bar: |), as in [x+1 | x <- xs, x > 1].
+
+-- Before list comprehensions, let's start out with sequences:
+
+e1 :: [Int]
+e1 = [1..10]   -- Step is 1
+e2 :: [Int]
+e2 = [1,3..10] -- Step is 3 - 1
+e3 :: [Int]
+e3 = [1,-1..-10]
+e4 :: [Char]
+e4 = ['a'..'z']   -- This works on chars too
+
+-- We'll avoid infinite sequences like [1..] for now.  If you print one,
+-- use C-c i to interrupt the Haskell program.
+
+-- List comprehensions are very similar to nested loops.  They return a
+-- list of values generated by the expression inside the loop.  The filter
+-- expressions are similar to conditionals in the loop.
+
+-- This function does nothing at all!  It just scans through a list and
+-- copies it into a new one.
+
+doNothing :: [a] -> [a]
+doNothing l = [x | x <- l]
+
+-- Adding a filter to the previous function allows only selected elements to
+-- be generated.  This is similar to what is done in quicksort.
+
+positives :: [Int] -> [Int]
+positives l = [x | x <- l, x > 0]
+
+e5 = positives [2,-4,5,6,-5,3]
+
+-- Now the full quicksort function.
+
+quicksort :: [Char] -> [Char]  -- Use Char just to be different!
+quicksort [] = []
+quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++
+                   [x] ++
+                   quicksort [y | y <- xs, y > x]
+
+e6 = quicksort "Why use Haskell?"
+
+-- Now for some nested loops.  Each generator, <-, adds another level of
+-- nesting to the loop.  Note that the variable introduced by each generator
+-- can be used in each following generator; all variables can be used in the
+-- generated expression:
+
+e7 :: [(Int,Int)]
+e7 = [(x,y) | x <- [1..5], y <- [x..5]]
+
+-- Now let's add some guards: (the /= function is `not equal')
+
+e8 :: [(Int,Int)]
+e8 = [(x,y) | x <- [1..7], x /= 5, y <- [x..8] , x*y /= 12]
+
+-- This is the same as the loop: (going to a psuedo Algol notation)
+-- for x := 1 to 7 do
+--  if x <> 5 then
+--   for y := x to 8 do
+--    if x*y <> 12
+--     generate (x,y)
+
+-- Section 2.5.2  Strings
+
+e9 = "hello" ++ " world"
+
+-- Page 7    Sections 3, 3.1
+
+module Test(Bool) where
+import Prelude hiding (map)
+
+-- Section 3   Functions
+
+add :: Int -> Int -> Int
+add x y = x+y
+
+e1 :: Int
+e1 = add 1 2
+
+-- This Int -> Int is the latter part of the signature of add:
+-- add :: Int -> (Int -> Int)
+
+succ :: Int -> Int
+succ = add 1
+
+e2 :: Int
+e2 = succ 3
+
+map :: (a->b) -> [a] -> [b]
+map f [] = []
+map f (x:xs) = f x : (map f xs)
+
+e3 :: [Int]
+e3 = map (add 1) [1,2,3]
+-- This next definition is the equivalent to e3
+e4 :: [Int]
+e4 = map succ [1,2,3]
+
+-- Heres a more complex example.  Define flist to be a list of functions:
+flist :: [Int -> Int]
+flist = map add [1,2,3]
+-- This returns a list of functions which add 1, 2, or 3 to their input.
+-- Warning: Haskell should print flist as something like
+--  [<<function>>,<<function>>,<<function>>]
+
+
+-- Now, define a function which takes a function and returns its value
+-- when applied to the constant 1:
+applyTo1 :: (Int -> a) -> a
+applyTo1 f = f 1
+
+e5 :: [Int]
+e5 = map applyTo1 flist  -- Apply each function in flist to 1
+
+-- If you want to look at how the type inference works, figure out how
+-- the signatures of map, applyTo1, and flist combine to yield [Int].
+
+-- Section 3.1  Lambda Abstractions
+
+-- The symbol \ is like `lambda' in lisp or scheme.
+
+-- Anonymous functions are written as \ arg1 arg2 ... argn -> body
+-- Instead of naming every function, you can code it inline with this
+-- notation:
+
+e6 = map (\f -> f 1) flist
+
+-- Be careful with the syntax here.  \x->\y->x+y parses as
+--  \ x ->\ y -> x + y.  The ->\ is all one token.  Use spaces!!
+
+-- This is identical to e5 except that the applyTo1 function has no name.
+
+-- Function arguments on the left of an = are the same as lambda on the
+-- right:
+
+add' = \x y -> x+y    -- identical to add
+succ' = \x -> x+1     -- identical to succ
+
+-- As with ordinary function, the parameters to anonymous functions
+-- can be patterns:
+
+e7 :: [Int]
+e7 = map (\(x,y) -> x+y) [(1,2),(3,4),(5,6)]
+
+-- Functions defined by more than one equation, like map, cannot
+-- be converted to anonymous lambda functions quite as easily - a case
+-- statement is also required.  This is discussed later.
+
+-- Page 8   Sections 3.2, 3.2.1, 3.2.2
+
+module Test(Bool) where
+
+import Prelude hiding ((++),(.))
+
+-- Section 3.2  Infix operators
+
+-- Haskell has both identifiers, like x, and operators, like +.
+-- These are just two different types of syntax for variables.
+-- However, operators are by default used in infix notation.
+
+-- Briefly, identifiers begin with a letter and may have numbers, _, and '
+-- in them:  x, xyz123, x'', xYz'_12a.  The case of the first letter
+-- distinguishes variables from data constructors (or type variables from
+-- type constructors).  An operator is a string of symbols, where
+-- :!#$%&*+./<=>?@\^| are all symbols.  If the first character is : then
+-- the operator is a data constructor; otherwise it is an ordinary
+-- variable operator.  The - and ~ characters may start a symbol but cannot
+-- be used after the first character.  This allows a*-b to parse as
+-- a * - b instead of a *- b.
+
+-- Operators can be converted to identifiers by enclosing them in parens.
+-- This is required in signature declarations.  Operators can be defined
+-- as well as used in the infix style:
+
+(++) :: [a] -> [a] -> [a]
+[] ++ y = y
+(x:xs) ++ y = x : (xs ++ y)
+
+-- Table 2 (Page 54) of the report is invaluable for sorting out the
+-- precedences of the many predefined infix operators.
+
+e1 = "Foo" ++ "Bar"
+
+-- This is the same function without operator syntax
+appendList :: [a] -> [a] -> [a]
+appendList [] y = y
+appendList (x:xs) y = x : appendList xs y
+
+(.) :: (b -> c) -> (a -> b) -> (a -> c)
+f . g = \x -> f (g x)
+
+add1 :: Int -> Int
+add1 x = x+1
+
+e2 = (add1 . add1) 3
+
+-- Section 3.2.1  Sections
+
+-- Sections are a way of creating unary functions from infix binary
+-- functions.  When a parenthesized expression starts or ends in an
+-- operator, it is a section.  Another definition of add1:
+
+add1' :: Int -> Int
+add1' = (+ 1)
+
+e3 = add1' 4
+
+-- Here are a few section examples:
+
+e4 = map (++ "abc") ["x","y","z"]
+
+e5 = map ("abc" ++) ["x","y","z"]
+
+
+-- Section 3.2.2  Fixity Declarations
+
+-- We'll avoid any demonstration of fixity declarations.  The Prelude
+-- contains numerous examples.
+
+-- Page 9  Sections 3.3, 3.4, 3.5
+module Test(Bool) where
+
+import Prelude hiding (take,zip)
+
+-- Section 3.3  Functions are Non-strict
+
+-- Observing lazy evaluation can present difficulties.  The essential
+-- question is `does an expression get evaluated?'.  While in theory using a
+-- non-terminating computation is the way evaluation issues are examined,
+-- we need a more practical approach.  The `error' function serves as
+-- a bottom value.  Evaluating this function prints an error message and
+-- halts execution.
+
+bot = error "Evaluating Bottom"
+
+e1 :: Bool    -- This can be any type at all!
+e1 = bot      -- evaluate this and see what happens.
+
+const1 :: a -> Int
+const1 x = 1
+
+e2 :: Int
+e2 = const1 bot  -- The bottom is not needed and will thus not be evaluated.
+
+-- Section 3.4  "Infinite" Data Structures
+
+-- Data structures are constructed lazily.  A constructor like : will not
+-- evaluate its arguments until they are demanded.  All demands arise from
+-- the need to print the result of the computation -- components not needed
+-- to compute the printed result will not be evaluated.
+
+list1 :: [Int]
+list1 = (1:bot)
+
+e3 = head list1    -- doesnt evaluate bot
+e4 = tail list1    -- does evaluate bot
+
+-- Some infinite data structures.  Don't print these!  If you do, you will
+-- need to interrupt the system (C-c i) or kill the Haskell process.
+
+ones :: [Int]
+ones = 1 : ones
+
+numsFrom :: Int -> [Int]
+numsFrom n = n : numsFrom (n+1)
+
+-- An alternate numsFrom using series notation:
+
+numsFrom' :: Int -> [Int]
+numsFrom' n = [n..]
+
+squares :: [Int]
+squares = map (^2) (numsFrom 0)
+
+-- Before we start printing anything, we need a function to truncate these
+-- infinite lists down to a more manageable size.  The `take' function
+-- extracts the first k elements of a list:
+
+take :: Int -> [a] -> [a]
+take 0 x      = []                 -- two base cases: k = 0
+take k []     = []                 -- or the list is empty
+take k (x:xs) = x : take (k-1) xs
+
+-- now some printable lists:
+
+e5 :: [Int]
+e5 = take 5 ones
+
+e6 :: [Int]
+e6 = take 5 (numsFrom 10)
+
+e7 :: [Int]
+e7 = take 5 (numsFrom' 0)
+
+e8 :: [Int]
+e8 = take 5 squares
+
+-- zip is a function which turns two lists into a list of 2 tuples.  If
+-- the lists are of differing sizes, the result is as long as the
+-- shortest list.
+
+zip (x:xs) (y:ys) = (x,y) : zip xs ys
+zip xs ys = []   -- one of the lists is []
+
+e9 :: [(Int,Int)]
+e9 = zip [1,2,3] [4,5,6]
+
+e10 :: [(Int,Int)]
+e10 = zip [1,2,3] ones
+
+fib :: [Int]
+fib = 1 : 1 : [x+y | (x,y) <- zip fib (tail fib)]
+
+e11 = take 5 fib
+
+-- Let's do this without the list comprehension:
+
+fib' :: [Int]
+fib' = 1 : 1 : map (\(x,y) -> x+y) (zip fib (tail fib))
+
+-- This could be written even more cleanly using a map function which
+-- maps a binary function over two lists at once.  This is in the
+-- Prelude and is called zipWith.
+
+fib'' :: [Int]
+fib'' = 1 : 1 : zipWith (+) fib (tail fib)
+
+-- For more examples using infinite structures look in the demo files
+-- that come with Yale Haskell.  Both the pascal program and the
+-- primes program use infinite lists.
+
+-- Section 3.5  The Error Function
+
+-- Too late - we already used it!
+
+
+-- Page 10   Sections 4, 4.1, 4.2
+
+module Test(Bool) where
+
+import Prelude hiding (take,(^))
+
+-- Section 4  Case Expressions and Pattern Matching
+
+-- Now for details of pattern matching.  We use [Int] instead of [a]
+-- since the only value of type [a] is [].
+
+contrived :: ([Int], Char, (Int, Float), String, Bool) -> Bool
+contrived ([], 'b', (1, 2.0), "hi", True) = False
+contrived x = True   -- add a second equation to avoid runtime errors
+
+e1 :: Bool
+e1 = contrived ([], 'b', (1, 2.0), "hi", True)
+e2 :: Bool
+e2 = contrived ([1], 'b', (1, 2.0), "hi", True)
+
+-- Contrived just tests its input against a big constant.
+
+-- Linearity in pattern matching implies that patterns can only compare
+-- values with constants.  The following is not valid Haskell:
+
+-- member x [] = False
+-- member x (x:ys) = True      -- Invalid since x appears twice
+-- member x (y:ys) = member x ys
+
+f :: [a] -> [a]
+f s@(x:xs) = x:s
+f _ = []
+
+e3 = f "abc"
+
+-- Another use of _:
+
+middle :: (a,b,c) -> b
+middle (_,x,_) = x
+
+e4 :: Char
+e4 = middle (True, 'a', "123")
+
+(^) :: Int -> Int -> Int
+x ^ 0 = 1
+x ^ (n+1) = x*(x^n)
+
+e5 :: Int
+e5 = 3^3
+e6 :: Int
+e6 = 4^(-2)  -- Notice the behavior of the + pattern on this one
+
+-- Section 4.1  Pattern Matching Semantics
+
+-- Here's an extended example to illustrate the left -> right, top -> bottom
+-- semantics of pattern matching.
+
+foo :: (Int,[Int],Int) -> Int
+foo (1,[2],3)   = 1
+foo (2,(3:_),3) = 2
+foo (1,_,3)     = 3
+foo _           = 4
+
+bot = error "Bottom Evaluated"
+
+e7 = foo (1,[],3)
+e8 = foo (1,bot,3)
+e9 = foo (1,1:bot,3)
+e10 = foo (2,bot,2)
+e11 = foo (3,bot,bot)
+
+-- Now add some guards:
+
+sign :: Int -> Int
+sign x | x > 0  = 1
+       | x == 0 = 0
+       | x < 0  = -1
+
+e12 = sign 3
+
+-- The last guard is often `True' to catch all other cases.  The identifier
+-- `otherwise' is defined as True for use in guards:
+
+max' :: Int -> Int -> Int
+max' x y | x > y      = x
+         | otherwise  = y
+
+-- Guards can refer to any variables bound by pattern matching.  When
+-- no guard is true, pattern matching resumes at the next equation.  Guards
+-- may also refer to values bound in an associated where declaration.
+
+
+inOrder :: [Int] -> Bool
+inOrder (x1:x2:xs) | x1 <= x2 = True
+inOrder _                     = False
+
+e13 = inOrder [1,2,3]
+e14 = inOrder [2,1]
+
+-- Section 4.2  An Example
+
+take :: Int -> [a] -> [a]
+take 0     _      = []
+take _     []     = []
+take (n+1) (x:xs) = x:take n xs
+
+take' :: Int -> [a] -> [a]
+take' _     []     = []
+take' 0     _      = []
+take' (n+1) (x:xs) = x:take' n xs
+
+e15, e16, e17, e18 :: [Int]
+e15 = take 0 bot
+e16 = take' 0 bot
+e17 = take bot []
+e18 = take' bot []
+
+-- Page 11    Sections 4.3, 4.4, 4.5, 4.6
+
+module Test(Bool) where
+
+-- import Prelude hiding (take,Request(..),Response(..)) -- Standard Haskell
+import Prelude hiding (take)    -- Y2.0-b4 only
+
+-- Section 4.3 Case Expressions
+
+-- The function take using a case statement instead of multiple equations
+
+take :: Int -> [a] -> [a]
+take m ys = case (m,ys) of
+             (0  ,_)    -> []
+             (_  ,[])   -> []
+             (n+1,x:xs) -> x : take n xs
+
+-- The function take using if then else.  We can also eliminate the n+k
+-- pattern just for fun.  The original version of take is much easier to read!
+
+take' :: Int -> [a] -> [a]
+take' m ys = if m == 0 then [] else
+              if null ys then [] else
+               if m > 0 then head ys : take (m-1) (tail ys)
+                else error "m < 0"
+
+-- Section 4.4  Lazy Patterns
+
+-- Before the client-server example, here is a contrived example of lazy
+-- patterns.  The first version will fail to pattern match whenever the
+-- the first argument is [].  The second version will always pattern
+-- match initially but x will fail if used when the list is [].
+
+nonlazy :: [Int] -> Bool -> [Int]
+nonlazy (x:xs) isNull  = if isNull then [] else [x]
+
+e1 = nonlazy [1,2] False
+e2 = nonlazy [] True
+e3 = nonlazy [] False
+
+-- This version will never fail the initial pattern match
+lazy :: [Int] -> Bool -> [Int]
+lazy ~(x:xs) isNull  = if isNull then [] else [x]
+
+e4 = lazy [1,2] False
+e5 = lazy [] True
+e6 = lazy [] False
+
+-- The server - client example is a little hard to demonstrate.  We'll avoid
+-- the initial version which loops.  Here is the version with irrefutable
+-- patterns.
+
+type Response = Int
+type Request = Int
+
+client :: Request -> [Response] -> [Request]
+client init ~(resp:resps) = init : client (next resp) resps
+
+server :: [Request] -> [Response]
+server (req : reqs) = process req : server reqs
+
+-- Next maps the response from the previous request onto the next request
+next :: Response -> Request 
+next resp = resp
+
+-- Process maps a request to a response
+process :: Request -> Response
+process req = req+1
+
+requests :: [Request]
+requests = client 0 responses
+
+responses :: [Response]
+responses = server requests
+
+e7 = take 5 responses
+
+-- The lists of requests and responses are infinite - there is no need to
+-- check for [] in this program.  These lists correspond to streams in other
+-- languages.
+
+-- Here is fib again:
+
+fib :: [Int]
+fib@(1:tfib) = 1 : 1 : [ a+b | (a,b) <- zip fib tfib]
+
+e8 = take 10 fib
+
+-- Section 4.5  Lexical Scoping and Nested Forms
+
+-- One thing that is important to note is that the order of the
+-- definitions in a program, let expression, or where clauses is
+-- completely arbitrary.  Definitions can be arranged 'top down'
+-- or `bottom up' without changing the program.
+
+e9 = let y = 2 :: Float
+         f x = (x+y)/y
+     in f 1 + f 2
+
+f :: Int -> Int -> String
+f x y | y > z  = "y > x^2"
+      | y == z = "y = x^2"
+      | y < z  = "y < x^2"
+  where
+    z = x*x
+
+e10 = f 2 5
+e11 = f 2 4
+
+-- Section 4.6  Layout
+
+-- There's nothing much to demonstrate here.  We have been using layout all
+-- through the tutorial.  The main thing is to be careful line up the
+-- first character of each definition.  For example, if you
+-- change the indentation of the definition of f in e9 you will get a
+-- parse error.
+
+-- Page 12  Section 5
+module Test(Bool) where
+
+import Prelude hiding (elem)
+
+-- Section 5  Type Classes
+
+-- Names in the basic class structure of Haskell cannot be hidden (they are
+-- in PreludeCore) so we have to modify the names used in the tutorial.
+
+-- Here is a new Eq class:
+
+class Eq' a where
+  eq :: a -> a -> Bool
+
+-- Now we can define elem using eq from above:
+
+elem :: (Eq' a) => a -> [a] -> Bool
+x `elem` [] = False
+x `elem` (y:ys) = x `eq` y || x `elem` ys
+
+-- Before this is of any use, we need to admit some types to Eq'
+
+instance Eq' Int where
+ x `eq` y = abs (x-y) < 3  -- Let's make this `nearly equal' just for fun
+
+instance Eq' Float where
+ x `eq` y = abs (x-y) < 0.1
+
+list1 :: [Int]
+list1 = [1,5,9,23]
+
+list2 :: [Float]
+list2 = [0.2,5.6,33,12.34]
+
+e1 = 2 `elem` list1
+e2 = 100 `elem` list1
+e3 = 0.22 `elem` list2
+
+-- Watch out!  Integers in Haskell are overloaded - without a type signature
+-- to designate an integer as an Int, expressions like 3 `eq` 3 will be
+-- ambiguous.  See 5.5.4 about this problem.
+
+-- Now to add the tree type:
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)   deriving Text
+
+instance (Eq' a) => Eq' (Tree a) where
+  (Leaf a)       `eq` (Leaf b)       = a `eq` b
+  (Branch l1 r1) `eq` (Branch l2 r2) =  (l1 `eq` l2) && (r1 `eq` r2)
+  _              `eq` _              = False
+
+tree1,tree2 :: Tree Int
+tree1 = Branch (Leaf 1) (Leaf 2)
+tree2 = Branch (Leaf 2) (Leaf 1)
+
+e4 = tree1 `eq` tree2
+
+-- Now make a new class with Eq' as a super class:
+
+class (Eq' a) => Ord' a where
+ lt,le :: a -> a -> Bool          -- lt and le are operators in Ord'
+ x `le` y = x `eq` y || x `lt` y  -- This is a default for le
+
+-- The typing of lt & le is 
+--  le,lt :: (Ord' a) => a -> a -> Bool
+-- This is identical to
+--  le,lt :: (Eq' a,Ord' a) => a -> a -> Bool
+
+-- Make Int an instance of Ord
+instance Ord' Int where
+ x `lt` y = x < y+1
+
+i :: Int  -- Avoid ambiguity
+i = 3
+e5 :: Bool
+e5 = i `lt` i
+
+-- Some constraints on instance declarations:
+--   A program can never have more than one instance declaration for
+--     a given combination of data type and class.
+--   If a type is declared to be a member of a class, it must also be
+--     declared in all superclasses of that class.
+--   An instance declaration does not need to supply a method for every
+--     operator in the class.  When a method is not supplied in an
+--     instance declaration and no default is present in the class
+--     declaration, a runtime error occurs if the method is invoked.
+--   You must supply the correct context for an instance declaration --
+--     this context is not inferred automatically.
+
+-- Section 5.1  Equality and Ordered Classes
+-- Section 5.2  Enumeration and Index Classes
+
+-- No examples are provided for 5.1 or 5.2.  The standard Prelude contains
+-- many instance declarations which illustrate the Eq, Ord, and Enum classes.
+
+-- Page 13    Section 5.3
+
+module Test(Bool) where
+
+-- Section 5.3   Text and Binary Classes
+
+-- This is the slow showTree.  The `show' function is part of the
+-- Text class and works with all the built-in types.  The context `Text a'
+-- arises from the call to show for leaf values.
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text
+
+showTree :: (Text a) => Tree a -> String
+showTree (Leaf x)    = show x
+showTree (Branch l r) = "<" ++ showTree l ++ "|" ++ showTree r ++ ">"
+
+tree1 :: Tree Int
+tree1 = Branch (Leaf 1) (Branch (Leaf 3) (Leaf 6))
+
+e1 = showTree tree1
+
+-- Now the improved showTree; shows is already defined for all
+-- built in types.
+
+showsTree  :: Text a => Tree a -> String -> String
+showsTree (Leaf x) s = shows x s
+showsTree (Branch l r) s = '<' : showsTree l ('|' : showsTree r ('>' : s))
+
+e2 = showsTree tree1 ""
+
+-- The final polished version.  ShowS is predefined in the Prelude so we
+-- don't need it here. 
+
+
+showsTree'  :: Text a => Tree a -> ShowS
+showsTree' (Leaf x) = shows x
+showsTree' (Branch l r) = ('<' :) . showsTree' l . ('|' :) .
+                          showsTree' r . ('>' :)
+
+e3 = showsTree' tree1 ""
+
+
+-- Page 14    This page break is just to keep recompilation from getting too
+--            long.  The compiler takes a little longer to compile this
+--            page than other pages.
+
+module Test(Bool) where
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving Text
+
+-- Now for the reading function.  Again, ReadS is predefined and reads works
+-- for all built-in types.  The generators in the list comprehensions are
+-- patterns: p <- l binds pattern p to successive elements of l which match
+-- p.  Elements not matching p are skipped.
+
+readsTree :: (Text a) => ReadS (Tree a)
+readsTree ('<':s)  = [(Branch l r, u) | (l, '|':t) <- readsTree s,
+                                        (r, '>':u) <- readsTree t ]
+readsTree s        = [(Leaf x,t)      | (x,t) <- reads s]
+
+e4 :: [(Int,String)]
+e4 = reads "5 golden rings"
+
+e5 :: [(Tree Int,String)]
+e5 = readsTree "<1|<2|3>>"
+e6 :: [(Tree Int,String)]
+e6 = readsTree "<1|2"
+e7 :: [(Tree Int,String)]
+e7 = readsTree "<1|<<2|3>|<4|5>>> junk at end"
+
+-- Before we do the next readTree, let's play with the lex function.
+
+e8 :: [(String,String)]
+e8 = lex "foo bar bletch"
+
+-- Here's a function to completely lex a string.  This does not handle
+-- lexical ambiguity - lex would return more than one possible lexeme
+-- when an ambiguity is encountered and the patterns used here would not
+-- match.
+
+lexAll :: String -> [String]
+lexAll s = case lex s of
+            [("",_)] -> []  -- lex returns an empty token if none is found
+            [(token,rest)] -> token : lexAll rest
+
+e9 = lexAll "lexAll :: String -> [String]"
+e10 = lexAll "<1|<a|3>>"
+
+-- Finally, the `hard core' reader.  This is not sensitive to
+-- white space as were the previous versions.
+
+
+readsTree' :: (Text a) => ReadS (Tree a)
+readsTree' s = [(Branch l r, x) | ("<", t) <- lex s,
+				  (l, u)   <- readsTree' t,
+                                  ("|", v) <- lex u,
+                                  (r, w)   <- readsTree' v,
+				  (">", x) <- lex w ]
+                ++
+                [(Leaf x, t)    | (x, t) <- reads s]
+
+-- When testing this program, you must make sure the input conforms to
+-- Haskell lexical syntax.  If you remove spaces between | and < or
+-- > and > they will lex as a single token.
+
+e11 :: [(Tree Int,String)]
+e11 = readsTree' "<1 | <2 | 3> >"
+e12 :: [(Tree Bool,String)]
+e12 = readsTree' "<True|False>"
+
+-- Finally, here is a simple version of read for trees only:
+
+read' :: (Text a) => String -> (Tree a)
+read' s = case (readsTree' s) of
+           [(tree,"")] -> tree   -- Only one parse, no junk at end
+           []          -> error "Couldn't parse tree"
+           [_]         -> error "Crud after the tree"  -- unread chars at end
+           _           -> error "Ambiguous parse of tree"
+
+e13 :: Tree Int
+e13 = read' "foo"
+e14 :: Tree Int
+e14 = read' "< 1 | < 2 | 3 > >"
+e15 :: Tree Int
+e15 = read' "3 xxx"
+
+-- Page 15  Section 5.4
+
+module Test(Bool) where
+
+-- Section 5.4  Derived Instances
+
+-- We have actually been using the derived Text instances all along for
+-- printing out trees and other structures we have defined.  The code
+-- in the tutorial for the Eq and Ord instance of Tree is created
+-- implicitly by the deriving clause so there is no need to write it
+-- here.
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Eq,Ord,Text)
+
+-- Now we can fire up both Eq and Ord functions for trees:
+
+tree1, tree2, tree3, tree4 :: Tree Int
+tree1 = Branch (Leaf 1) (Leaf 3)
+tree2 = Branch (Leaf 1) (Leaf 5)
+tree3 = Leaf 4
+tree4 = Branch (Branch (Leaf 4) (Leaf 3)) (Leaf 5)
+
+e1 = tree1 == tree1
+e2 = tree1 == tree2
+e3 = tree1 < tree2
+
+quicksort :: Ord a => [a] -> [a]
+quicksort [] = []
+quicksort (x:xs) = quicksort [y | y <- xs, y <= x] ++
+                   [x] ++
+                   quicksort [y | y <- xs, y > x]
+
+e4 = quicksort [tree1,tree2,tree3,tree4]
+
+-- Now for Enum: 
+
+data Day = Sunday | Monday | Tuesday | Wednesday | Thursday |
+           Friday | Saturday     deriving (Text,Eq,Ord,Enum)
+
+e5 = quicksort [Monday,Saturday,Friday,Sunday]
+e6 = [Wednesday .. Friday]
+e7 = [Monday, Wednesday ..]
+e8 = [Saturday, Friday ..]
+
+
+-- Page 16  Sections 5.5, 5.5.1, 5.5.2, 5.5.3
+
+module Test(Bool) where
+
+-- Section 5.5  Numbers
+-- Section 5.5.1  Numeric Class Structure
+-- Section 5.5.2  Constructed Numbers
+
+-- Here's a brief summary of Haskell numeric classes.
+
+-- Class Num
+--   Most general numeric class.  Has addition, subtraction, multiplication.
+--   Integers can be coerced to any instance of Num with fromInteger.
+--   All integer constants are in this class.
+-- Instances: Int, Integer, Float, Double, Ratio a, Complex a
+
+-- Class Real
+--   This class contains ordered numbers which can be converted to
+--   rationals.
+-- Instances: Int, Integer, Float, Double, Ratio a
+
+-- Class Integral
+--   This class deals with integer division.  All values in Integral can
+--   be mapped onto Integer.
+-- Instances: Int, Integer
+
+-- Class Fractional
+--   These are numbers which can be divided.  Any rational number can
+--   be converted to a fractional.  Floating point constants are in
+--   this class: 1.2 would be 12/10.
+-- Instances: Float, Double, Ratio a
+
+-- Class Floating
+--   This class contains all the standard floating point functions such
+--   as sqrt and sin.
+-- Instances: Float, Double, Complex a
+
+-- Class RealFrac
+--   These values can be rounded to integers and approximated by rationals.
+-- Instances: Float, Double, Ratio a
+
+-- Class RealFloat
+--   These are floating point numbers constructed from a fixed precision
+--   mantissa and exponent.
+-- Instances: Float, Double
+
+-- There are only a few sensible combinations of the constructed numerics
+-- with built-in types:
+--  Ratio Integer (same as Rational): arbitrary precision rationals
+--  Ratio Int: limited precision rationals
+--  Complex Float: complex numbers with standard precision components
+--  Complex Double: complex numbers with double precision components
+
+
+-- The following function works for arbitrary numerics:
+
+fact :: (Num a) => a -> a
+fact 0 = 1
+fact n = n*(fact (n-1))
+
+-- Note the behavior when applied to different types of numbers:
+
+e1 :: Int
+e1 = fact 6
+e2 :: Int
+e2 = fact 20   -- Yale Haskell may not handle overflow gracefully!
+e3 :: Integer
+e3 = fact 20
+e4 :: Rational
+e4 = fact 6
+e5 :: Float
+e5 = fact 6
+e6 :: Complex Float
+e6 = fact 6
+
+-- Be careful: values like `fact 1.5' will loop!
+
+-- As a practical matter, Int operations are much faster than Integer
+-- operations.  Also, overloaded functions can be much slower than non-
+-- overloaded functions.  Giving a function like fact a precise typing:
+
+-- fact :: Int -> Int
+
+-- will yield much faster code.
+
+-- In general, numeric expressions work as expected.  Literals are
+-- a little tricky - they are coerced to the appropriate value.  A
+-- constant like 1 can be used as ANY numeric type.
+
+e7 :: Float
+e7 = sqrt 2
+e8 :: Rational
+e8 = ((4%5) * (1%2)) / (3%4)
+e9 :: Rational
+e9 = 2.2 * (3%11) - 1
+e10 :: Complex Float
+e10 = (2 * (3:+3)) / (1.1:+2.0 - 1)
+e11 :: Complex Float
+e11 = sqrt (-1)
+e12 :: Integer
+e12 = numerator (4%2)
+e13 :: Complex Float
+e13 = conjugate (4:+5.2)
+
+-- A function using pattern matching on complex numbers:
+
+mag :: (RealFloat a) => Complex a -> a
+mag (a:+b) = sqrt (a^2 + b^2)
+
+e14 :: Float
+e14 = mag (1:+1)
+
+-- Section 5.5.3  Numeric Coercions and Overloaded Literals
+
+-- The Haskell type system does NOT implicitly coerce values between
+-- the different numeric types!  Although overloaded constants are 
+-- coerced when the overloading is resolved, no implicit coercion goes
+-- on when values of different types are mixed.  For example:
+
+f :: Float
+f = 1.1
+i1 :: Int
+i1 = 1
+i2 :: Integer
+i2 = 2
+
+-- All of these expressions would result in a type error (try them!):
+
+-- g = i1 + f
+-- h = i1 + i2
+-- i3 :: Int
+-- i3 = i2
+
+-- Appropriate coercions must be introduced by the user to allow
+-- the mixing of types in arithmetic expressions.
+
+e15 :: Float
+e15 = f + fromIntegral i1
+e16 :: Integer
+e16 = fromIntegral i1 + i2
+e17 :: Int
+e17 = i1 + fromInteger i2  -- fromIntegral would have worked too.
+
+-- Page 17  Section 5.5.4
+module Test(Bool) where
+
+-- Section 5.5.4  Default Numeric Types
+
+-- Ambiguous contexts arise frequently in numeric expressions.  When an
+-- expression which produces a value with a general type, such as
+-- `1' (same as `fromInteger 1'; the type is (Num a) => a), with
+-- another expression which `consumes' the type, such as `show' or
+-- `toInteger', ambiguity arises.  This ambiguity can be resolved
+-- using expression type signatures, but this gets tedious fast!  
+-- Assigning a type to the top level of an ambiguous expression does
+-- not help: the ambiguity does not propagate to the top level.
+
+e1 :: String -- This type does not influence the type of the argument to show
+e1 = show 1  -- Does this mean to show an Int or a Float or ...
+e2 :: String
+e2 = show (1 :: Float)
+e3 :: String
+e3 = show (1 :: Complex Float)
+
+-- The reason the first example works is that ambiguous numeric types are
+-- resolved using defaults.  The defaults in effect here are Int and
+-- Double.  Since Int `fits' in the expression for e1, Int is used.
+-- When Int is not valid (due to other context constraints), Double
+-- will be tried.
+
+-- This function defaults the type of the 2's to be Int
+
+rms :: (Floating a) => a -> a -> a
+rms x y = sqrt ((x^2 + y^2) * 0.5)
+
+-- The C-c e evaluation used to the Haskell system also makes use of
+-- defaulting.  When you type an expression, the system creates a
+-- simple program to print the value of the expression using a function
+-- like show.  If no type signature for the printed expression is given,
+-- defaulting may occur.
+
+-- One of the reasons for adding type signatures throughout these examples
+-- is to avoid unexpected defaulting.  Many of the top level signatures are
+-- required to avoid ambiguity.
+
+-- Defaulting can lead to overflow problems when values exceed Int limits.
+-- Evaluate a very large integer without a type signature to observe this
+-- (unfortunately this may cause a core dump or other unpleasantness).
+
+-- Notice that defaulting applies only to numeric classes.  The
+--   show (read "xyz")                       -- Try this if you want!
+-- example uses only class Text so no defaulting occurs.
+
+-- Ambiguity also arises with polymorphic types.  As discussed previously,
+-- expressions like [] have a similar problem.
+
+-- e4 = []   -- Won't work since [] has type [a] and `a' is not known.
+
+-- Note the difference: even though the lists have no components, the type
+-- of component makes a difference in printing.
+
+e5 = ([] :: [Int]) 
+e6 = ([] :: [Char])
+
+-- Page 18   Sections 6, 6.1, 6.2
+
+-- Section 6  Modules
+
+module Tree ( Tree(Leaf,Branch), fringe ) where
+--            Tree(..) would work also
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)   deriving Text
+
+fringe :: Tree a -> [a]
+fringe (Leaf x)             = [x]
+fringe (Branch left right)  = fringe left ++ fringe right
+
+-- The Emacs interface to Haskell performs evaluation within the
+-- module containing the cursor.  To evaluate e1 you must place the
+-- cursor in module Main.
+
+module Main (Tree) where
+import Tree ( Tree(Leaf, Branch), fringe)
+-- import Tree      -- this would be the same thing
+e1 :: [Int]
+e1 = fringe (Branch (Leaf 1) (Leaf 2))
+
+-- This interactive Haskell environment can evaluate expressions in
+-- any module.  The use of module Main is optional.
+
+-- Section 6.1  Original Names and Renaming
+
+module Renamed where
+import Tree ( Tree(Leaf,Branch), fringe)
+    renaming (Leaf to Root, Branch to Twig)
+
+e2 :: Tree Int
+e2 = Twig (Root 1) (Root 2)  -- Printing always uses the original names
+
+-- Section 6.2  Interfaces and Implementations
+
+-- Yale Haskell allows separate compilation of modules using
+-- unit files.  These are described in the user's guide.
+
+
+-- Page 19  Sections 6.3, 6.4
+
+-- Section 6.3  Abstract Data Types
+
+-- Since TreeADT does not import Tree it can use the name Tree without
+-- any conflict.  Each module has its own separate namespace.
+
+module TreeADT (Tree, leaf, branch, cell, left,
+               right, isLeaf) where
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)    deriving Text
+
+leaf = Leaf
+branch = Branch
+cell (Leaf a) = a
+left (Branch l r) = l
+right (Branch l r) = r
+isLeaf (Leaf _) = True
+isLeaf _        = False
+
+module Test where
+import TreeADT
+
+-- Since the constructors for type Tree are hidden, pattern matching
+-- cannot be used.
+
+fringe :: Tree a -> [a]
+fringe x = if isLeaf x then [cell x]
+                       else fringe (left x) ++ fringe (right x)
+
+e1 :: [Int]
+e1 = fringe (branch (branch (leaf 3) (leaf 2)) (leaf 1))
+
+-- Section 6.4
+
+
+-- Page 20  Sections 7, 7.1, 7.2, 7.3
+
+-- Section 7  Typing Pitfalls
+
+-- Section 7.1  Let-Bound Polymorphism
+
+module Test(e2) where
+
+-- f g = (g 'a',g [])    -- This won't typecheck.
+
+-- Section 7.2  Overloaded Numerals
+
+-- Overloaded numerics were covered previously - here is one more example.
+-- sum is a prelude function which sums the elements of a list.
+
+average :: (Fractional a) => [a] -> a
+average xs   = sum xs / fromIntegral (length xs)
+
+e1 :: Float   -- Note that e1 would default to Double instead of Int - 
+              -- this is due to the Fractional context.
+e1 = average [1,2,3]
+
+-- Section 7.3  The Monomorphism Restriction
+
+-- The monomorphism restriction is usually encountered when functions
+-- are defined without parameters.  If you remove the signature for sum'
+-- the monomorphism restriction will apply.
+-- This will generate an error if either:
+--   sum' is added to the module export list at the start of this section
+--   both sumInt and sumFloat remain in the program.
+-- If sum' is not exported and all uses of sum' have the same overloading,
+-- there is no type error.
+
+sum' :: (Num a) => [a] -> a
+sum' = foldl (+) 0         -- foldl reduces a list with a binary function
+                           -- 0 is the initial value.
+
+sumInt :: Int
+sumInt = sum' [1,2,3]
+
+sumFloat :: Float
+sumFloat = sum' [1,2,3]
+
+-- If you use overloaded constants you also may encounter monomorphism:
+
+x :: Num a => a
+x = 1    -- The type of x is Num a => a
+y :: Int
+y = x            -- Uses x as an Int
+z :: Integer
+z = x          -- Uses x as an Integer.  A monomorphism will occur of the
+               -- signature for x is removed.
+                 -- comments to see an error.
+
+-- Finally, if a value is exported it must not be overloaded unless bound
+-- by a function binding.  e2 is the only value exported.
+
+e2 :: Int  -- Remove this to get an error.  Without this line e1 will
+           -- be overloaded.
+e2 = 1
+
+-- To prevent annoying error messages about exported monomorphic variables,
+-- most modules in this tutorial do not implicitly export everything - they
+-- only export a single value, Bool, which was chosen to keep the export
+-- list non-empty (a syntactic restriction!).  In Haskell systems without
+-- the evaluator used here, a module which does not export any names would
+-- be useless.
+
+-- module Test where  -- this would export everything in the module
+-- module Test(Bool)  -- exports only Bool
+-- module Test()      -- this is what we really want to do but is not valid.
+
+-- Page 21  Sections 8, 8.1
+
+module Test(Bool) where
+
+-- Section 8  Input/Output
+-- Section 8.1  Introduction to Continuations
+
+-- Simplify f here to be 1/x.
+
+data Maybe a  = Ok a | Oops String deriving Text
+
+f :: Float -> Maybe Float
+f x = if x == 0 then Oops "Divide by 0" else Ok (1/x)
+
+-- g is a `safe' call to x.  The call to error could be replaced by
+-- some explicit value like Oops msg -> 0.
+
+g x = case f x of
+        Ok y -> y
+        Oops msg -> error msg
+   
+e1 = f 0
+e2 = g 0
+e3 = g 1
+
+-- Here is the same example using continuations:
+
+f' :: Float -> (String -> Float) -> Float
+f' x c = if x == 0 then c "Divide by 0"
+                   else 1/x
+
+g' x = f' x error   -- calls error on divide by 0
+g'' x = f' x (\s -> 0) -- returns 0 on divide by 0
+
+e4 = g' 0
+e5 = g'' 0
+
+-- Page 22  Sections 8.2, 8.3
+
+module Test where
+
+-- Section 8.2  Continuation Based I/O
+
+-- We will skip the program fragments at the start of this section and
+-- move directly to the writeFile / readFile example.
+
+-- Before we can use Haskell I/O, we need to introduce a new Emacs command:
+-- C-c r.  This command runs a dialogue instead of printing a value.
+-- (Actually C-c e creates a dialogue on the fly and runs it in the same
+-- manner as C-c r).  As with C-c e you are prompted for an expression.
+-- In this case, the expression must be of type Dialogue and it is
+-- executed by the I/O system.  We use d1,d2,... for dialogues to be
+-- executed by C-c r.
+
+-- We make the file name a parameter to allow for easier testing.
+-- Don't expect much error handling in exit.
+
+s1 = "This is a test of Haskell"
+
+main file = writeFile file s1 exit (
+            readFile  file    exit (\s2 ->
+            appendChan stdout (if s1==s2 then "contents match"
+                                         else "something intervened!") exit
+            done))	
+
+d1,d2 :: Dialogue
+d1 = main "/tmp/ReadMe"
+d2 = main "/dev/null" -- this will read back as the empty string
+
+-- A simple IO program using $ for readability: ($ is defined in the Prelude)
+
+d3 = appendChan "stdout" "Type something: " exit $
+     readChan "stdin" exit $ \s2 ->
+     appendChan "stdout" ("You typed " ++ head (lines s2)) exit $
+     done
+
+-- This program suffers from a strictness problem.  Strictness deals
+-- with when things get evaluated.  In this program, the input is not
+-- needed until after the "You typed " is printed.  Fixing this would
+-- require some operation to look at the string before the final 
+-- appendChan.  Here is one possible fix:
+ 
+d4 = appendChan "stdout" "Type something: " exit $
+     readChan "stdin" exit $ \s2 ->
+     let str = head (lines s2) in
+      if str == str then  -- This evaluates str
+       appendChan "stdout" ("You typed " ++ head (lines s2)) exit $
+       done
+      else done
+
+
+-- Section 8.3  Terminal I/O
+
+-- Since this programming environment runs under Emacs, the issue of
+-- echoing does not really apply.  However, the synchronization between
+-- input and output can be seen in the following example.  Since the input
+-- comes a line at a time, the X's come in groups between input lines.
+-- The cursor will move into the haskell dialogue buffer when the program
+-- requests input.  Use a ^D to stop the program (^Q^D actually).  [Warning:
+-- some brain damaged lisps stop not only the Haskell program but also
+-- the entire compiler on ^D]
+
+d5 = readChan stdin exit processInput where
+      processInput s = loop 1 s
+      loop n [] = done
+      loop n (x:xs) | n == 10  = appendChan stdout "X" exit (loop 1 xs)
+                    | True     = loop (n+1) xs
+ 
+-- For more examples using the I/O system look in the demo programs
+-- that come with haskell (in $HASKELL/progs/demo) and the report.
+
+-- Page 23  Sections 9, 9.1, 9.2
+
+module Test(Bool) where
+
+-- Section 9  Arrays
+-- Section 9.1  Index Types
+
+-- Arrays are built on the class Ix.  Here are some quick examples of Ix:
+
+e1 :: [Int]
+e1 = range (0,4)
+e2 :: Int
+e2 = index (0,4) 2
+low,high :: (Int,Int)
+low = (1,1)
+high = (3,4)
+e3 = range (low,high)
+e4 = index (low,high) (3,2)
+e5 = inRange (low,high) (4,3)
+
+-- Section 9.2  Array Creation
+
+squares :: Array Int Int
+squares = array (1,100) [i := i*i | i <- [1..100]]
+
+-- We can also parameterize this a little:
+
+squares' :: Int -> Array Int Int
+squares' n = array (1,n) [i := i*i | i <- [1..n]]
+
+e6 :: Int
+e6 = squares!6
+e7 :: (Int,Int)
+e7 = bounds squares
+e8 :: Array Int Int
+e8 = squares' 10
+
+-- Here is a function which corresponds to `take' for lists.  It takes
+-- an arbitrary slice out of an array.
+
+atake :: (Ix a) => Array a b -> (a,a) -> Array a b
+atake a (l,u) | inRange (bounds a) l && inRange (bounds a) u =
+                   array (l,u) [i := a!i | i <- range (l,u)]
+              | otherwise = error "Subarray out of range"
+
+e9 = atake squares (4,8)
+
+mkArray :: Ix a => (a -> b) -> (a,a) -> Array a b
+mkArray f bnds = array bnds [i := f i | i <- range bnds]
+
+e10 :: Array Int Int
+e10 = mkArray (\i -> i*i) (1,10)
+
+fibs :: Int -> Array Int Int
+fibs n = a where
+            a = array (0,n) ([0 := 1, 1 := 1] ++
+                             [i := a!(i-1) + a!(i-2) | i <- [2..n]])
+
+e11 = atake (fibs 50) (3,10)
+
+wavefront :: Int -> Array (Int,Int) Int
+wavefront n = a where
+                a = array ((1,1),(n,n))
+                     ([(1,j) := 1 | j <- [1..n]] ++
+                      [(i,1) := 1 | i <- [2..n]] ++
+                      [(i,j) := a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j)
+                                  | i <- [2..n], j <- [2..n]])
+
+wave = wavefront 20
+e12 = atake wave ((1,1),(3,3))
+e13 = atake wave ((3,3),(5,5))
+
+-- Here are some errors in array operations:
+
+e14 :: Int
+e14 = wave ! (0,0)  -- Out of bounds
+arr1 :: Array Int Int
+arr1 = array (1,10) [1 := 1] -- No value provided for 2..10
+e15,e16 :: Int
+e15 = arr1 ! 1  -- works OK
+e16 = arr1 ! 2  -- undefined by array
+
+-- Page 24  Sections 9.3, 9.4
+
+module Test(Bool) where
+
+-- Section 9.3  Accumulation
+
+hist :: (Ix a, Integral b) => (a,a) -> [a] -> Array a b
+hist bnds is = accumArray (+) 0 bnds [i := 1 | i <- is, inRange bnds i]
+
+e1 :: Array Char Int
+e1 = hist ('a','z') "This counts the frequencies of each lowercase letter"
+
+decades :: (RealFrac a) => a -> a -> [a] -> Array Int Int
+decades a b = hist (0,9) . map decade
+                where
+                  decade x = floor ((x-a) * s)
+                  s = 10 / (b - a)
+
+test1 :: [Float]
+test1 = map sin [0..100]  -- take the sine of the 0 - 100
+e2 = decades 0 1 test1
+
+-- Section 9.4  Incremental Updates
+
+swapRows :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c
+swapRows i i' a = a // ([(i,j) := a!(i',j) | j <- [jLo..jHi]] ++
+			[(i',j) := a!(i,j) | j <- [jLo..jHi]])
+               where ((iLo,jLo),(iHi,jHi)) = bounds a
+
+arr1 :: Array (Int,Int) (Int,Int)
+arr1 = array ((1,1),(5,5)) [(i,j) := (i,j) | (i,j) <- range ((1,1),(5,5))]
+
+e3 = swapRows 2 3 arr1
+
+-- Printing the arrays in more readable form makes the results easier
+-- to view.
+
+-- This is a printer for 2d arrays
+
+aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where
+  showRows r c | r > ux = showChar '\n'
+  showRows r c | c > uy = showChar '\n' . showRows (r+1) ly
+  showRows r c = showElt (a!(r,c)) . showRows r (c+1)
+  showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' '
+  ((lx,ly),(ux,uy)) = bounds a
+
+showArray a w = appendChan stdout (aprint a w "") abort done
+
+d1 = showArray e3 6
+
+swapRows' :: (Ix a, Ix b, Enum b) => a -> a -> Array (a,b) c -> Array (a,b) c
+swapRows' i i' a = a // [assoc | j <- [jLo..jHi],
+                                 assoc <- [(i,j) := a!(i',j),
+	  				   (i',j) := a!(i,j)]]
+               where ((iLo,jLo),(iHi,jHi)) = bounds a
+
+d2 = showArray (swapRows' 1 5 arr1) 6
+
+-- Page 25  Section 9.5
+
+module Test(Bool) where
+
+-- Section 9.5  An example: Matrix Multiplication
+
+aprint a width = shows (bounds a) . showChar '\n' . showRows lx ly where
+  showRows r c | r > ux = showChar '\n'
+  showRows r c | c > uy = showChar '\n' . showRows (r+1) ly
+  showRows r c = showElt (a!(r,c)) . showRows r (c+1)
+  showElt e = showString (take width (show e ++ repeat ' ')) . showChar ' '
+  ((lx,ly),(ux,uy)) = bounds a
+
+showArray a w = appendChan stdout (aprint a w "") abort done
+
+matMult :: (Ix a, Ix b, Ix c, Num d) =>
+              Array (a,b) d -> Array (b,c) d -> Array (a,c) d
+matMult x y =
+  array resultBounds
+        [(i,j) := sum [x!(i,k) * y!(k,j) | k <- range (lj,uj)]
+                  | i <- range (li,ui),
+                    j <- range (lj',uj')]
+ where
+    ((li,lj),(ui,uj)) = bounds x
+    ((li',lj'),(ui',uj')) = bounds y
+    resultBounds
+      | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
+      | otherwise             = error "matMult: incompatible bounds"
+
+mat1,mat2,mat3,mat4 :: Array (Int,Int) Int
+mat1 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 0,(1,0) := 0,(1,1) := 1]
+mat2 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 1,(1,0) := 1,(1,1) := 1]
+mat3 = array ((0,0),(1,1)) [(0,0) := 1,(0,1) := 2,(1,0) := 3,(1,1) := 4]
+mat4 = array ((0,0),(1,2)) [(0,0) := 1,(0,1) := 2,(0,2) := 3,
+			    (1,0) := 4,(1,1) := 5,(1,2) := 6]
+
+d1 = showArray (matMult mat1 mat2) 4
+d2 = showArray (matMult mat2 mat3) 4
+d3 = showArray (matMult mat1 mat4) 4
+d4 = showArray (matMult mat4 mat1) 4
+
+matMult' :: (Ix a, Ix b, Ix c, Num d) =>
+              Array (a,b) d -> Array (b,c) d -> Array (a,c) d
+matMult' x y =
+  accumArray (+) 0 ((li,lj'),(ui,uj'))
+        [(i,j) := x!(i,k) * y!(k,j)
+                  | i <- range (li,ui),
+                    j <- range (lj',uj'),
+                    k <- range (lj,uj)]
+
+ where
+    ((li,lj),(ui,uj)) = bounds x
+    ((li',lj'),(ui',uj')) = bounds y
+    resultBounds
+       | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
+       | otherwise             = error "matMult: incompatible bounds"
+
+d5 = showArray (matMult mat1 mat2) 4
+d6 = showArray (matMult mat2 mat3) 4
+
+genMatMul :: (Ix a, Ix b, Ix c) =>
+              ([f] -> g) -> (d -> e -> f) ->
+              Array (a,b) d -> Array (b,c) e -> Array (a,c) g
+genMatMul f g x y =
+  array ((li,lj'),(ui,uj'))
+        [(i,j) := f [(x!(i,k)) `g` (y!(k,j)) | k <- range (lj,uj)]
+                  | i <- range (li,ui),
+                    j <- range (lj',uj')]
+ where
+    ((li,lj),(ui,uj)) = bounds x
+    ((li',lj'),(ui',uj')) = bounds y
+    resultBounds
+         | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
+         | otherwise             = error "matMult: incompatible bounds"
+
+d7 = showArray (genMatMul maximum (-) mat2 mat1) 4
+d8 = showArray (genMatMul and (==) mat1 mat2) 6
+d9 = showArray (genMatMul and (==) mat1 mat1) 6
+
+-- Page 26     More about Haskell
+
+This is the end of the tutorial.  If you wish to see more examples of
+Haskell programming, Yale Haskell comes with a set of demo programs.
+These can be found in $HASKELL/progs/demo.  Once you have mastered the
+tutorial, both the report and the user manual for Yale Haskell should
+be understandable.  Many examples of Haskell programming can be found in
+the Prelude.  The directory $HASKELL/progs/prelude contains the sources
+for the Prelude.
+
+We appreciate any comments you have on this tutorial.  Send any comments
+to haskell-requests@cs.yale.edu.
+
+   The Yale Haskell Group