diff --git a/COPYRIGHT b/COPYRIGHT
new file mode 100644
--- /dev/null
+++ b/COPYRIGHT
@@ -0,0 +1,12 @@
+The authors have the copyright to all files distributed as part of the
+fudget library, except where an explicit copyright notice states
+otherwise.
+
+The files may be distributed and used free of charge for
+non-commercial purposes only. Commercial use of the fudget library
+requires an agreement with the authors.
+
+This file should be included unchanged in all copies.
+
+
+Magnus Carlsson & Thomas Hallgren
diff --git a/Contrib/AuxShellF.hs b/Contrib/AuxShellF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/AuxShellF.hs
@@ -0,0 +1,31 @@
+module AuxShellF where
+import Fudgets
+import TitleShellF(wmShellF')
+
+auxShellF = auxShellF' standard
+delayedAuxShellF = delayedAuxShellF' standard
+
+delayedAuxShellF' pm title fud =
+    auxShellF' pm title fud >=^^< emptyDownSP
+  where
+    -- 3x3 state transition table:
+    emptyDownSP = getPopSP emptyDownSP upSP      downSP
+    downSP    x = getPopSP (downSP x)  (msgSP x) downSP
+    upSP        = getPopSP emptyDownSP upSP      msgSP
+
+    msgSP x = putSP (Right x) upSP
+
+    getPopSP downSP upSP msgSP = getSP $ either popSP msgSP
+      where popSP b = putSP (Left b) $ if b then upSP else downSP
+
+auxShellF' pm title fud =
+  mapEither (const False) id >^=<
+  wmShellF' (pm . setVisible False) title fud
+  >=^< mapEither Right id
+
+{-
+auxShellF lbl title fud =
+  loopThroughRightF
+    (wmShellF' (setVisible False) title fud)
+    (Right>^=<toggleButtonF lbl>=^<const False)
+-}
diff --git a/Contrib/BitmapF.hs b/Contrib/BitmapF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/BitmapF.hs
@@ -0,0 +1,52 @@
+module BitmapF (bitmapButtonF, bitmapDispF, bitmapDispBorderF) where
+import AllFudgets
+
+windowKernel filename =
+  allocNamedColorPixel defaultColormap "black" $ \fg ->
+  allocNamedColorPixel defaultColormap "white" $ \bg ->
+  changeBackPixel "white" $
+  wCreateGC rootGC [GCFunction GXcopy,
+                    GCForeground fg,
+                    GCBackground bg,
+                    GCGraphicsExposures False] $ \drawGC ->
+  let displayImage size bitmapid =
+        createPixmap size copyFromParent (\pixmapid ->
+          putsK [Low (pmCopyPlane pixmapid drawGC (Pixmap bitmapid) 
+                    (Rect (Point 0 0) size) (Point 0 0) 0),
+                lxcmd (ChangeWindowAttributes [CWBackPixmap pixmapid]),
+                lxcmd (FreePixmap bitmapid),
+                lxcmd (FreePixmap pixmapid),
+                Low (layoutRequestCmd (plainLayout size True True)),
+                lxcmd ClearWindow] 
+               displayproc)
+      lxcmd = Low . XCmd
+      displayproc =
+        getK (\msg ->
+          case msg of
+            Low (XEvt (Expose _ 0)) -> xcommandK ClearWindow displayproc 
+            High BitmapBad -> error ("Invalid bitmap file")
+            High (BitmapReturn size _ bitmapid) -> displayImage size bitmapid
+            _ -> displayproc)
+  in readBitmapFile filename (\bmr ->
+       case bmr of
+         BitmapBad -> error ("Invalid bitmap file " ++ filename)
+         BitmapReturn size _ bitmapid -> displayImage size bitmapid)
+
+bitmapDispF :: FilePath -> F BitmapReturn a
+bitmapDispF filename =
+  let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]
+      kernelF =  windowF ([XCmd $ ChangeWindowAttributes wattrs])
+                         (windowKernel filename)
+  in marginHVAlignF 0 aCenter aCenter kernelF
+
+bitmapDispBorderF :: Int -> FilePath -> F BitmapReturn a
+bitmapDispBorderF width filename =
+  let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]
+      kernelF = windowF [XCmd (ChangeWindowAttributes wattrs),
+                         XCmd (ConfigureWindow [CWBorderWidth width])]
+                         (windowKernel filename)
+  in marginHVAlignF 0 aCenter aCenter kernelF
+
+bitmapButtonF keys filename =
+  let kernelF = bitmapDispBorderF 0 filename 
+  in fromRight >^=< (pushButtonF keys kernelF)
diff --git a/Contrib/CompletionStringF.hs b/Contrib/CompletionStringF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/CompletionStringF.hs
@@ -0,0 +1,104 @@
+module CompletionStringF
+    (stdcc,completeFromList,
+     completionStringF,completionStringF',completionStringF'')
+  where
+import Fudgets
+import Data.List(isPrefixOf) 
+import HbcUtils(mapSnd)
+
+completionStringF = completionStringF' stdcc standard
+
+stdcc = argReadKey "stdcc" ' ' -- standard completion char
+
+completionStringF' cc cust = completionStringF'' cc cust >=^< mapEither id Right
+
+completionStringF'' cc cust =  -- cc = completion character
+    loopThroughRightF (absF completeSP0) (stringF'' cust)
+  where
+    completeSP0 = completeSP (const []) ([],[]) ""
+
+    completeSP listfun updownlist current =
+        getSP $ either fromStringF fromOutside
+      where
+        list = listfun current
+
+        same = completeSP listfun updownlist current
+	newList listfun' = completeSP listfun' ([],[]) current
+	newString' p s = putSP (toOutput (InputChange s)) $
+			 completeSP listfun p s
+	newString = newString' ([],[])
+
+
+        toStringF'' = Left
+        toString = toStringF'' . Right
+	toCustomiser = toStringF'' . Left
+	toOutput = Right . Right
+	toCompletionList = Right . Left
+
+	fromOutside = either newList inputToStringF''
+	inputToStringF'' msg = putSP (toStringF'' msg) same
+
+        fromStringF msg = 
+	  case msg of
+	    InputDone "Up"   _ -> goto above
+	    InputDone "Down" _ -> goto below
+	    InputDone "Tab"  _ -> doCompletion
+	    InputDone _ _ -> putSP (toOutput msg) same
+	    InputChange s ->
+	      if s==current++[cc]
+	      then doCompletion
+	      else if fromupdownlist s
+	           then same
+		   else newString s -- erase completion list?
+
+        fromupdownlist s =
+ 	    case updownlist of
+	      (_,(_,s'):_) -> s==s'
+	      _ -> False
+
+        goto (_,[]) = same
+        goto l@(_,item@(_,s):_) =
+	    putSP (toString s) $
+	    putSP (toCompletionList [item]) $
+	    putSP (toOutput (InputChange s)) $
+	    newString' l current
+
+	above = case updownlist of
+		  ([],[]) -> case reverse updownlist' of
+			       x:xs -> (xs,[x])
+			       _ -> ([],[])
+		  (x:xs,ys) -> (xs,x:ys)
+		  _ -> updownlist
+
+        below = case updownlist of
+		  ([],[]) -> ([],updownlist')
+		  (xs,x1:x2:ys) -> (x1:xs,x2:ys)
+		  _ -> updownlist
+
+        updownlist' = mapSnd (current++) list
+
+        doCompletion =
+	    putSP (toCompletionList list) $
+	    putNewString (current++commonPrefix (map snd list))
+
+        putNewString new =
+	  putSP (toString new) $
+	  putSP (toCustomiser (setCursorPos (length new))) $
+	  newString new
+
+commonPrefix ((c:s):ss) =
+  case filter ((/=[c]).take 1) ss of
+    [] -> c:commonPrefix (s:map tail ss)
+    _ -> []
+commonPrefix _ = []
+
+pos y xs =
+  case [ix|ix@(i,x)<-number 0 xs,y `isPrefixOf` x] of
+    []      -> (0,False)
+    (i,x):_ -> (i,x==y)
+
+completeFromList list current =
+    [(current,compl)|(pre,compl)<-splits,pre==current]
+  where
+    splits = map (splitAt n) list
+    n = length current
diff --git a/Contrib/ConnectF.hs b/Contrib/ConnectF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/ConnectF.hs
@@ -0,0 +1,58 @@
+module ConnectF where
+import Fudgets(F,(>+<))
+
+infixl :&:,>&<
+
+
+--leaf :: (o->h)->F i o->(F i o,o->h,i->i)
+tagF handler fud = TagF fud handler id
+
+--data TagF a b c = TagF a b c
+data TagF i o h t = TagF (F i o) (o->h) (t i)
+-- TagF makes the type more readable but also more restrictive...
+
+tf1 >&< tf2 = compTagF (>+<) tf1 tf2
+
+compTagF compF (TagF fud1 get1 tag1) (TagF fud2 get2 tag2) =
+    TagF (compF fud1 fud2) (either get1 get2) (etag1 :&: etag2)
+  where
+    etag1 = extend Left tag1
+    etag2 = extend Right tag2
+
+mapTF f (TagF fud get tag) = TagF (f fud) get tag
+
+ltr ih (TagF fud get tag) =
+  (fud,either get ih,Right :&: extend Left tag)
+
+class Tag f where
+  extend :: (b->c) -> f b -> f c
+
+data Tags f1 f2 a = (f1 a) :&: (f2 a)
+
+instance Tag ((->) a) where
+  extend = (.)
+
+instance (Tag f1,Tag f2) => Tag (Tags f1 f2) where
+  extend f (g1:&:g2) = extend f g1:&:extend f g2
+
+{-
+newtype Selector d a = S (d a->Maybe a)
+
+instance Tag (Selector d) where
+  extend f 
+
+
+f d1 d2 = (either d1 no,either no d2)
+ :: (d1 a -> Maybe a) ->
+    (d2 b -> Maybe b) ->
+    (Either (d1 a) (d2 b)->Maybe a,Either (d1 a) (d2 b)->Maybe b)
+
+a->Maybe b -> Either a c -> Maybe b
+-}
+
+no _ = Nothing
+yes s = Just s
+left f = either f no
+right = either no
+leftleft = left . left
+leftyes = left yes
diff --git a/Contrib/ContribFudgets.hs b/Contrib/ContribFudgets.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/ContribFudgets.hs
@@ -0,0 +1,51 @@
+-- | Contributed add-ons to the Fudget Library
+module ContribFudgets(
+  -- * Contributed add-ons to the Fudget Library
+--  module SuperMenuF,
+  module BitmapF,
+  module ShapedButtonsF,
+--  module MenuBar,
+  module TitleShellF,
+  module AuxShellF,
+  module SmileyF,
+  module MenuBarF,
+  module HelpBubbleF,
+  module FileShellF,
+  module FilePickPopupF,
+  module CompletionStringF,
+  module EndButtonsF,
+  module MeterF,
+  --module HandleF,
+  --module LinearSplitP,
+  module SplitF,
+  module SocketServer,
+  module TypedSockets,
+  module HyperGraphicsF2,
+  module ConnectF,
+  module ReactiveF,
+  module TreeBrowser
+  ) where
+
+import BitmapF
+--import MenuBar
+import ShapedButtonsF
+import SuperMenuF() -- not exported because of name clashes, import SuperMenuF.
+import TitleShellF
+import AuxShellF
+import SmileyF
+import MenuBarF
+import HelpBubbleF
+import FileShellF
+import FilePickPopupF
+import CompletionStringF
+import EndButtonsF
+import MeterF
+--import HandleF
+--import LinearSplitP
+import SplitF
+import SocketServer
+import TypedSockets
+import HyperGraphicsF2
+import ConnectF
+import ReactiveF
+import TreeBrowser
diff --git a/Contrib/DynRadioGroupF.hs b/Contrib/DynRadioGroupF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/DynRadioGroupF.hs
@@ -0,0 +1,19 @@
+module DynRadioGroupF where
+import Fudgets
+
+dynRadioGroupF alts startalt = dynRadioGroupF' standard alts startalt
+
+dynRadioGroupF' pm alts startalt =
+    loopThroughRightF (mapstateF ctrl (alts,startalt))
+                      (dynF (rgF alts startalt))
+  where
+    rgF = radioGroupF' pm
+
+    ctrl (alts,current) = either fromRadioGroupF fromOutside
+      where
+        fromRadioGroupF choice = ((alts,choice),[Right (alts,choice)])
+	fromOutside (alts',current') =
+	  ((alts',current'),
+	   if map fst alts' == map fst alts
+	   then [Left (Right current')]
+	   else [Left (Left (rgF alts' current'))])
diff --git a/Contrib/EndButtonsF.hs b/Contrib/EndButtonsF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/EndButtonsF.hs
@@ -0,0 +1,19 @@
+module EndButtonsF where
+import AllFudgets
+
+endButtonsF =
+    noStretchF False True $ matrixF 2 (ok >+< cancel)
+  where
+    ok = buttonF "OK"
+    cancel = buttonF' pm "Cancel"
+      where
+        pm = setKeys [([],"Escape")]
+
+
+endButtonsF' =
+    noStretchF False True $ matrixF 2 (ok >+< cancel) >=^< Left
+  where
+    ok = buttonF'' standard "OK" >=^< Left . setLabel >=^^< idempotSP
+    cancel = buttonF' pm "Cancel"
+      where
+        pm = setKeys [([],"Escape")]
diff --git a/Contrib/FilePickPopupF.hs b/Contrib/FilePickPopupF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/FilePickPopupF.hs
@@ -0,0 +1,239 @@
+module FilePickPopupF(filePickF,filePickF',filePickPopupF,filePickPopupF',filePickPopupOptF,filePickPopupOptF',startDir,aFilePath,popup) where
+import AllFudgets
+import EndButtonsF
+--import Files
+import Data.List(sort,partition)
+import HbcUtils(uncurry3)
+import DialogueIO hiding (IOError)
+import CompletionStringF
+import UnsafePerformIO(unsafePerformIO)
+import System.Directory(getCurrentDirectory)
+
+popup = ("OK",Nothing)
+
+filePickPopupF = filePickPopupF' noextrabuttons
+filePickPopupOptF = filePickPopupOptF' noextrabuttons
+filePickF = filePickF' noextrabuttons
+
+noextrabuttons = [] :: ([(AFilePath->AFilePath,KeySym,String)])
+
+filePickPopupF' btns = mapFilterSP ok >^^=< filePickPopupOptF' btns
+  where
+    ok (x,Nothing) = Nothing
+    ok (x,Just y) = Just (x,y)
+
+
+filePickPopupOptF' btns =
+  --delayF $ -- commented out to avoid a layout problem under XQuartz
+  popupShellF "File Selection" Nothing (filePickF' btns >=^< snd)
+
+
+filePickF' btns =
+    loopThroughRightF (ctrlF (aFilePath startDir,"")) (partsF btns)
+  where
+    ctrlF st@(dir,file) = getF $ either internal external
+      where
+        same = ctrlF st
+
+        internal = either (either dirDisp goto) (either fileInput done)
+
+	external (lbl,optpath) = putF (toButtons lbl) (external2 optpath)
+          where
+	    external2 Nothing = putF (toDirDispDir dir) same
+	    external2 (Just s) = newpath (aFilePath s)
+
+        dirDisp = either pick dirList
+        dirList list = putF (toFileCompletion (completeFromList (map fst list))) same
+
+        pick inp =
+	    pathPartsF (compactPath path) $ \ st'@(dir',file') ->
+	    if file'==""
+	    then change (dir',file) -- keep previous file name
+	    else case inputDone inp of
+	           Nothing -> change st'
+		   Just _ -> if file'==file -- Hmm. Check dir too.
+		             then output path
+			     else same -- false double click
+	  where
+	    path = stripInputMsg inp
+
+	goto f = change (f dir,file)
+
+        fileInput = either completionList filename
+
+        completionList = flip putF same . toDirDispCompletions
+
+	filename inp =
+	    case inputDone inp of
+	      Nothing -> ctrlF (dir,stripInputMsg inp)
+	      Just "" -> same
+	      --Just name@('/':_) -> newname (aFilePath name)
+	      --Just name -> newname (extendPath dir name)
+	      Just path' -> newname (joinPaths dir (aFilePath path'))
+	  where
+	     newname path =
+	       pathPartsF (compactPath path) $ \ st'@(dir',file') ->
+	       if file'==""
+	       then change st'
+	       else output (extendPath dir' file')
+
+	done = either ok cancel
+	  where
+	    ok _ = putF (out (Just (filePath (extendPath dir file)))) same
+	    cancel _ = putF (out Nothing) same
+
+        newpath path = pathPartsF (compactPath path) change
+
+	change st@(dir',file') =
+	   putsF ([toFileInput file']++
+	          (if dir'/=dir then [toDirDispDir dir'] else [])) $
+	   ctrlF st
+
+        output path =
+	    putF (out (Just (filePath path'))) (newpath path')
+	  where
+	    path' = compactPath path
+
+        out = Right
+	toDirDisp = Left. Left. Left
+	toDirDispDir = toDirDisp. Right
+	toDirDispCompletions = toDirDisp. Left
+	toFileInput= Left. Right. Left. Right
+	toFileCompletion=Left. Right. Left. Left
+	toButtons=Left. Right. Right
+
+partsF btns =
+  vBoxF ((dirDispF>+<gotoButtonsF btns)>+<(fileInputF>+<endButtonsF'))
+
+dirDispF =
+    stripEither >^=< vBoxF (pathDispF >+< dirListF) >=^^< concatMapSP pre
+  where
+    pre (Left completions) = [Right (Left completions)]
+    pre (Right path) = [Left newdir,Right (Right newdir)]
+      where newdir = filePath path
+
+    pathDispF = displayF' pm
+      where pm = setAlign aCenter.
+                 setBgColor bgColor.
+		 setBorderWidth 0.
+		 setFont labelFont
+
+    dirListF = loopThroughRightF (mapstateF ctrl []) (pickListF fst >+< lsF)
+      where
+        ctrl list = either (either fromPickListF fromLsF) fromInput
+	  where
+	    fromInput = either completions newDir
+	    completions cs = put (toPickListF hilite)
+	      where
+	        hilite = highlightItems
+	                       [i|(i,(n,_))<-zip [0..] list,n `elem` ns]
+		ns = [pre++compl|(pre,compl)<-cs]
+	    newDir = put . toLsF
+	    fromPickListF msg =
+	      put2 (outPick . mapInp (snd.snd) $ msg)
+	           (toPickListF.highlightItems.(:[]).fst.stripInputMsg $ msg)
+	    fromLsF list' = (list',[outDir list',toPickListF (replaceAll list')])
+
+	    put x = (list,[x])
+	    put2 x y = (list,[x,y])
+
+	    out = Right
+	    outDir = out . Right
+	    outPick = out . Left
+	    loop = Left
+	    toPickListF = loop . Left
+	    toLsF = loop . Right
+
+    lsF = showFilesF>==<paths>^=<readDirF
+      where
+	paths (dir,resp) =
+	    case resp of
+	      Right files -> (map (extendPath sdir) . sortFiles) files
+	      Left err   -> [extendPath sdir (show err)]
+	  where sdir = aFilePath dir
+	        sortFiles files =
+		  case partition isDotFile files of
+		    (dfs,fs) -> sort fs ++
+		                sort [ f | f<-dfs, f `notElem` [".",".."]]
+		isDotFile ('.':_) = True
+		isDotFile _ = False
+
+	showFilesF = contMapF showFiles
+	showFiles = conts showFile
+        showFile = if argFlag "slowshowfile" True
+	           then slowShowFile
+		   else fastShowFile
+
+	slowShowFile path c =
+	  isDirF (filePath path)
+		 (c (file++"/",path))
+		 (c (file,path))
+	  where file = pathTail path
+
+        fastShowFile path c = c (pathTail path,path)
+
+gotoButtonsF btns =
+   haskellIOF (GetEnv "HOME") $ \ homeresp ->
+   noStretchF False True $
+   matrixF 4 (untaggedListF ([rootF,parentF]++homeF homeresp++extra btns))
+  where
+    rootF = fButtonF (const rootPath) "r" "/ Root"
+    parentF = fButtonF (compactPath.flip extendPath "..") "p" ".. Parent"
+
+    homeF resp=
+      case resp of
+        Str d@(_:_) -> [fButtonF (const (aFilePath d)) "h" "Home"]
+	_ -> []
+
+    fButtonF f k lbl = const f >^=< buttonF' (setKeys [([metaKey],k)]) lbl
+
+    extra = map (uncurry3 fButtonF)
+
+fileInputF = "File" `labLeftOfF` completionStringF
+
+pathPartsF path cont =
+    isDirF (filePath path) yes no
+  where
+    yes = cont (path,"")
+    no = cont (pathHead path,pathTail path)
+    {-
+    no  = case path of
+            [] -> cont ([],[]) -- not likely to happen, since the root is a dir
+	    file:dir -> cont (dir,file)
+    -}
+
+
+--- Candidates for inclusion in the Fudget library:
+
+isDirF file yes no =
+  haskellIOF (StatusFile file) $ \ resp ->
+  case resp of
+    Str ('d':_) -> yes
+    _ -> no
+
+contMapF f =
+  getF $ \ x ->
+  f x $ \ y ->
+  putF y $
+  contMapF f
+
+----
+
+-- #ifdef __NHC__
+--startDir = argKey "startdir" "/"  -- hmm. should retreive current directory.
+-- #else
+startDir = unsafePerformIO getCurrentDirectory
+-- #endif
+
+{-
+ - reloadknapp?
+ - alltid absolut path
+ - meddelande för att
+     välja kataloger
+     spara
+
+ - completion och uppnerpilar
+ -
+
+ - pixlar kvar i picklistan
+-}
diff --git a/Contrib/FileShellF.hs b/Contrib/FileShellF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/FileShellF.hs
@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP #-}
+module FileShellF(
+#ifndef __NHC__
+  fileShellF,fileShellF',
+   textFileShellF,textFileShellF',
+   showReadFileShellF,showReadFileShellF'
+#endif
+ ) where
+import Fudgets
+import FilePickPopupF
+import TitleShellF(titleShellF')
+import MenuBarF
+#ifndef __NHC__
+          (menuBarF,menu,idT,item,cmdItem,key)
+#endif
+import DialogueIO
+import Prelude hiding (IOError)
+import Data.Maybe(isJust,fromJust,fromMaybe)
+import Data.Char(isSpace)
+
+#ifndef __NHC__
+
+textFileShellF = textFileShellF' standard
+textFileShellF' customiser = fileShellF' customiser textConv
+  where textConv = (id,Right,Just "")
+
+showReadFileShellF empty = showReadFileShellF' standard empty
+showReadFileShellF' customiser empty =
+    fileShellF' customiser (show,parse,empty)
+  where
+    parse contents =
+      case reads contents of
+        [(x,cs)] | all isSpace cs -> Right x
+	_ -> Left "Syntax error in input"
+
+
+
+fileShellF = fileShellF' standard
+
+fileShellF' customiser conv title0 appF =
+    stubF $ loopOnlyF $ titleShellF' customiser title0 mainF
+  where
+    mainF = ctrlF title0 conv >==<
+            (popupsF>+<vBoxF (fileShellMenuBarF hasNew>+<appF))
+      where hasNew = case conv of (_,_,e) -> isJust e
+
+    popupsF = filePickPopupF' >+<(messagePopupF>+<nullF{-confirmPopupF-})
+      where
+        filePickPopupF' = putsF (map f (take 1 args)) filePickPopupF
+	f x = ((Open,popup),x)
+
+
+messageF = putF . toMessage
+toFilePick = Right . Left . Left
+toMessage = Right . Left . Right . Left
+--toConfirm = Right . Left . Right . Left
+toApp = Right . Right . Right
+toTitle = Left
+
+ctrlF title0 (show,parse,optEmpty) = start
+ where
+  start = loop Nothing Nothing
+  changeTitle name = putF (toTitle (title0++": "++name))
+  loop filename document =
+    getF $ {-either quitMsg-} (either fromPopups (either fromMenu fromApp))
+   where
+    same = loop filename document
+    newName name document' = changeTitle name $ loop (Just name) document'
+    errMsg err = messageF err same
+
+    quitMsg () = terminateProgram
+
+    fromPopups = either fromFilePick (either fromMessage fromConfirm)
+    fromMessage _ = same
+    fromConfirm _ = same -- !!
+
+    fromMenu filecmd =
+      case filecmd of
+	Open -> putF (toFilePick (Open,("Open",Nothing))) same
+        Save -> flip (maybe same) document $ \ doc ->
+	        flip (maybe (fromMenu SaveAs)) filename $ \ name ->
+		saveF show name doc errMsg $
+	        same
+	SaveAs -> flip (maybe same) document $ \ _ ->
+	          putF (toFilePick (SaveAs,("Save",Just (fromMaybe "" filename)))) same
+	Quit -> terminateProgram
+	New  -> flip (maybe $ errMsg "New not implemented") optEmpty $ \empty ->
+	        changeTitle "Empty file" $
+	        putF (toApp empty) $
+		start
+	_ -> same
+
+    terminateProgram = hIOSuccF (Exit 0) same
+
+    fromFilePick ((action,_),filename) =
+      case action of
+        Open -> openF parse filename errMsg
+		      (\ contents ->
+	               putF (toApp contents) $
+	               newName filename (Just contents))
+        SaveAs -> saveF show filename (fromJust document) errMsg $
+                  newName filename document
+	_ -> undefined -- shouldn't happen
+
+    fromApp inpmsg =
+      case inputDone inpmsg of
+	Just doc ->
+	  case filename of
+	    Just name -> saveF show name doc errMsg $
+	                 loop filename (Just doc)
+            Nothing   -> putF (toFilePick (SaveAs,("Save",filename))) $
+	                 loop filename (Just doc)
+	Nothing -> loop filename (Just (stripInputMsg inpmsg))
+
+
+data FileMenuItem = New | Open | Save | SaveAs | Quit deriving (Eq)
+
+
+fileShellMenuBarF hasNew =
+    fromLeft >^=< hBoxF (fileMenuF hasNew >+< gcWarnF) >=^< Left
+  where gcWarnF = spacer1F (hvAlignS aRight aCenter) gcWarningF
+
+fileMenuF hasNew =
+    spacer1F (noStretchS True True `compS` leftS) (menuBarF menuBar)
+  where
+    menuBar = [item fileMenu "File"] -- more?
+    fileMenu = menu idT $
+               (if hasNew then (cmdItem New    "New":) else id)
+	       [cmdItem Open   "Open..."     `key` "o",
+		cmdItem Save   "Save"        `key` "s",
+		cmdItem SaveAs "Save As..."  `key` "a",
+		cmdItem Quit   "Quit"        `key` "q" ]
+
+saveF showdoc filename doc errcont cont =
+  hIOerrF (WriteFile filename (showdoc doc))
+	  (errcont.show)
+	  (const cont)
+
+openF parse filename errcont cont =
+  hIOerrF (ReadFile filename) (errcont.show) $ \ (Str contents) ->
+  either errcont cont (parse contents)
+
+--messageF msg = contDynF $ (startupF [msg] messagePopupF>=^^<nullSP)
+-- contDynF doesn't seem to work properly
+
+#endif
diff --git a/Contrib/HandleF.hs b/Contrib/HandleF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/HandleF.hs
@@ -0,0 +1,92 @@
+module HandleF(hHandleF,vHandleF) where
+import AllFudgets
+
+hHandleF = handleF' Horizontal 108
+vHandleF = handleF' Vertical 116
+
+sepSize = max 2 defaultSep -- !! see note about layoutreq below
+sepD dir =
+    -- the size of the drawing must be sepSize (in the dir direction)
+    placedD (margS d (d2-d) `spacerP` linearP dir 0) $
+    boxD [fgD [shadowColor,"black"] l,fgD [shineColor,"white"] l]
+  where l = g line
+        d2 = sepSize-2
+	d = d2 `div` 2
+
+	margS = colinear dir hMarginS vMarginS
+	line = colinear dir vFiller hFiller 1
+
+handleF' dir cur alignment =
+    --showCommandF "handleF" $
+    nullSP >^^=<
+    postMapLow post (groupF startcmds handleK0 (labelF (sepD dir)))
+    >=^< Left
+    --windowF startcmds handleK0
+  where
+    -- Hack: all layout requests must come from the same address, otherwise
+    -- two boxes will be placed instead of one...
+    post ([L],cmd@(LCmd _)) = ([R,R],cmd)
+    post tcmd = tcmd
+
+    startcmds =
+      [--layoutRequestCmd layoutreq,
+       XCmd $ ChangeWindowAttributes [CWEventMask eventmask,
+                                      CWBackPixmap parentRelative]]
+
+    eventmask = [ButtonPressMask,ButtonReleaseMask,ButtonMotionMask]
+
+    -- It's important that the size of sepD and this request agree!!
+    layoutreq = plainLayout (diag sepSize) isHoriz (not isHoriz)
+    isHoriz = dir==Horizontal
+    wantposreq size p = layoutreq{wantedPos=Just(p,size,alignment)}
+
+    handleK0 = 
+      setFontCursor cur $
+      handleK
+
+    handleK = idleK 0 0
+      where
+        idleK parentp size = getK $ message low high
+	  where
+	    same = idleK parentp size
+	    high size' = idleK parentp size'
+	    low event =
+	      case event of
+		XEvt ButtonEvent {type'=Pressed,rootPos=pabs} ->
+		  dragK parentp size (pabs-parentp) pabs
+		LEvt (LayoutPos parentp') -> idleK parentp' size
+		_ -> same
+
+	dragK parentp size refp curp = getK $ message low high
+	  where
+	    moveto = dragK parentp size refp
+	    same = moveto curp
+	    putpos = putK . Low . layoutRequestCmd . wantposreq size
+
+            high size' = dragK parentp size' refp curp
+
+	    low event =
+	      case event of
+		LEvt (LayoutPos parentp') -> dragK parentp' size refp curp
+		XEvt ButtonEvent {type'=Released,rootPos=curp0'} ->
+		    (if curp'==curp
+		    then id
+		    else putpos (curp'-refp)) $
+		    idleK parentp size
+		  where curp' = constrain size (curp0'-refp)+refp
+		XEvt MotionNotify {rootPos=curp0',state=mods} ->
+		    if curp'==curp || Shift `elem` mods
+		    then same
+		    else putpos (curp'-refp) $
+		         moveto curp'
+		  where curp' = constrain size (curp0'-refp)+refp
+		_ -> same
+
+--constrain _ = id
+--{-
+-- Try to limit split position to reasonable values:
+constrain size =
+  if size>defaultSep
+  then pmin (size-defaultSep) . pmax defaultSep
+  else id
+--}
diff --git a/Contrib/HelpBubbleF.hs b/Contrib/HelpBubbleF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/HelpBubbleF.hs
@@ -0,0 +1,56 @@
+module HelpBubbleF(helpBubbleF) where
+import AllFudgets
+
+data BubbleState = Idle | Armed | Up
+
+helpBubbleF help fud =
+    if useBubbles
+    then loopCompThroughLeftF $
+         groupF startcmds ctrlK0 ((timerF>+<bubbleF) >+< fud)
+    else fud
+ where
+   bubbleF = bubbleRootPopupF (labelF' lblpm help)
+   lblpm = setBgColor "white" . setFont helpFont
+   eventmask = [EnterWindowMask,LeaveWindowMask]
+   startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask],
+                XCmd $ ConfigureWindow [CWBorderWidth 0]]
+
+   ctrlK0 = ctrlK 0 0 Idle
+
+   toTimer = High . Left
+   toBubble = High . Right
+
+   ctrlK size pos bubbleState =
+      getK $ message event (either fromTimer fromBubble)
+     where
+       same = ctrlK size pos bubbleState
+       idle = ctrlK size pos Idle
+       newSize size' = ctrlK size' pos bubbleState
+       timerOff s = putK (toTimer Nothing) $ ctrlK size pos s
+       timerOn pos' = putK (toTimer (Just (0,500))) $ ctrlK size pos' Armed
+
+       fromBubble _ = same
+
+       fromTimer Tick =
+         case bubbleState of
+	   Armed ->
+	       putK (toBubble (Popup (pos+offset) ())) $
+	       timerOff Up
+	     where offset = pP (xcoord size `div` 2) 3
+	   _ -> same
+       event e =
+         --echoK (show e) $
+         case e of
+	   XEvt EnterNotify { pos=pos,rootPos=rootPos } -> timerOn (rootPos-pos)
+
+	   XEvt LeaveNotify { } ->
+	     case bubbleState of
+	       Idle -> same
+	       Armed -> timerOff Idle
+	       Up -> putK (toBubble Popdown) $ idle
+
+	   LEvt (LayoutSize size') -> newSize size'
+	   _ -> same
+
+useBubbles = argFlag "helpbubbles" True
+helpFont = argKey "helpfont" "-*-new century schoolbook-medium-r-*-*-12-*-*-*-*-*-iso8859-1"
diff --git a/Contrib/HyperGraphicsF2.hs b/Contrib/HyperGraphicsF2.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/HyperGraphicsF2.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP #-}
+module HyperGraphicsF2(
+  module HyperGraphicsF2,
+  GfxCommand(..),GfxChange(..),GfxEvent(..),replaceGfx,highlightGfx
+ ) where
+import AllFudgets
+import Data.Maybe(fromJust,mapMaybe)
+import HbcUtils(mapFst)
+import qualified Data.Map as Map
+--import Fudget
+--import Defaults(paperColor)
+--import InputMsg(inputDone)
+--import Utils(swap)
+--import Xtypes(ColorName)
+--import Loops(loopThroughRightF)
+--import SerCompF(mapstateF)
+--import Graphic
+--import Drawing
+--import DrawingOps
+--import GraphicsF
+--import FDefaults
+--import ListUtil(assoc)
+--import Sizing(Sizing(..))
+--import GCAttrs() -- instances
+--import Event(Pressed(..))
+--import Maptrace(ctrace) -- debugging
+--import SpyF(teeF) -- debugging
+--import CompOps((>==<)) -- debugging
+
+#include "../hsrc/exists.h"
+
+hyperGraphicsF2 x = hyperGraphicsF2' standard x
+
+hyperGraphicsF2' custom init =
+    loopThroughRightF
+	(mapstateF ctrl state0)
+	({-teeF show "\n" >==<-} graphicsDispF' (custom . params))
+  where
+    --tr x = ctrace "hyper" (show x) x -- debugging
+    params = setInitDisp init .
+	     setGfxEventMask [GfxButtonMask] .
+	     setSizing Dynamic
+    state0 = (annotPaths init,init)
+
+    ctrl state@(paths,drawing) = either gfxEvent gfxCommand
+      where
+        same = (state,[])
+	lbl2path lbl = fromJust (Map.lookup lbl paths)
+
+        gfxCommand lcmd =
+	    case mapGfxCommandPath lbl2path lcmd of
+	      cmd@(ChangeGfx changes) -> (changeState changes,[Left cmd])
+	      cmd -> (state,[Left cmd])
+	  where
+	    changeState changes = (paths',drawing')
+	      where
+	        drawing' = foldr replace drawing changes
+
+		replace (path,GfxReplace (_,Just d)) drawing =
+                    replacePart drawing path d
+                replace (path,GfxReplace _) drawing = drawing
+                replace (path,GfxGroup from count) drawing =
+                    updatePart drawing path (groupParts from count)
+                replace (path,GfxUngroup pos) drawing =
+                    updatePart drawing path (ungroupParts pos)
+
+		paths' = annotPaths drawing'
+			-- Space leak: drawing' isn't used until user clicks
+			-- in the window, so the old drawing is retained in
+			-- the closure for drawing'
+
+        gfxEvent msg = (state,[Right msg'])
+	  where
+	    msg' = mapGfxEventPath path2lbl msg
+
+        path2lbl path = do let part = drawingAnnotPart drawing path
+			   LabelD a _ <- maybeDrawingPart drawing part
+			   return a
+
+    annotPaths = Map.fromList . map swap . drawingAnnots
+
+mouseClicksSP = mapFilterSP isMouseClick
+
+isMouseClick msg =
+    case msg of
+      GfxButtonEvent { gfxType=Pressed, gfxPaths=(path,_):_ } -> Just path
+      _ -> Nothing
+
+---
+
+mapGfxCommandPath f cmd =
+    case cmd of
+      ChangeGfx changes -> ChangeGfx (mapFst f changes)
+      ShowGfx path a -> ShowGfx (f path) a
+      GetGfxPlaces paths -> GetGfxPlaces (map f paths)
+      -- _ -> cmd -- Operationally, the rest is the same as this line.
+      ChangeGfxBg c -> ChangeGfxBg c
+      ChangeGfxBgPixmap pm b -> ChangeGfxBgPixmap pm b
+#ifdef USE_EXIST_Q
+      ChangeGfxBgGfx gfx -> ChangeGfxBgGfx gfx
+#endif
+      ChangeGfxCursor cursor -> ChangeGfxCursor cursor
+      ChangeGfxFontCursor shape -> ChangeGfxFontCursor shape
+      BellGfx n -> BellGfx n
+
+
+mapGfxEventPath f event =
+  case event of
+    GfxButtonEvent t s ty b ps -> GfxButtonEvent t s ty b (mapPaths ps)
+    GfxMotionEvent t s ps   -> GfxMotionEvent t s (mapPaths ps)
+    GfxKeyEvent t m k l     -> GfxKeyEvent t m k l
+    GfxFocusEvent b         -> GfxFocusEvent b
+    GfxPlaces rs            -> GfxPlaces rs
+    GfxResized s            -> GfxResized s
+  where
+    -- mapPats :: [(a,(Point,Rect))] -> [(b,(Point,Rect))]
+    mapPaths = mapMaybe f'
+    -- f' :: (a,(Point,Rect)) -> Maybe (b,(Point,Rect))
+    f' (path,place) = fmap (\p->(p,place)) (f path)
+
+-- nullPath = null . gfxPaths -- would be ok if gfxPaths was a total function
+nullPath = maybe False null . gfxEventPaths
+
+gfxEventPaths event =
+  case event of
+    -- enumerate all constructors that have a path argument:
+    GfxButtonEvent {gfxPaths=ps} -> Just ps
+    GfxMotionEvent {gfxPaths=ps}  -> Just ps
+    _ -> Nothing
+
+isGfxButtonEvent (GfxButtonEvent {gfxType=Pressed,gfxButton=b}) = Just b
+isGfxButtonEvent _ = Nothing
diff --git a/Contrib/KeyGfx.hs b/Contrib/KeyGfx.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/KeyGfx.hs
@@ -0,0 +1,34 @@
+module KeyGfx(keyGfx) where
+import Fudgets
+import Data.Char(toUpper)
+
+keyGfx gfx k = hboxD' 12 [g gfx,keyD (keyCap k)]
+  where
+    keyD c = spacedD (hAlignS aRight `compS` hMarginS 0 3) $
+	     hboxD' 0 [diamondD,spacedD alignKeysS $ g c]
+    diamondD = spacedD vCenterS $ g $ FlexD 10 False False d
+    d (Rect p (Point w h)) = [FillPolygon Convex CoordModeOrigin
+		      [p+pP w2 0,p+pP w h2,p+pP w2 h,p+pP 0 h2]]
+      where w2 = w `div` 2
+	    h2 = h `div` 2
+
+alignKeysS = minSizeS (pP 12 10) `compS` hCenterS
+  -- This is a hack to make the keybord shortcuts align nicely in a column.
+  -- It assumes that no character is wider than 12 pixels.
+
+--ctrlkey = argFlag "menuctrlkey" False
+
+keyCap k =
+  case k of
+    [c] -> [toUpper c]
+    "period" -> "."
+    "comma" -> ","
+    "plus" -> "+"
+    "minus" -> "-"
+    "slash" -> "/"
+    "asterisk" -> "*"
+    "apostrophe" -> "'"
+    "question" -> "?"
+    "less" -> "<"
+    "greater" -> ">"
+    _ -> k -- ??
diff --git a/Contrib/LinearSplitP.hs b/Contrib/LinearSplitP.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/LinearSplitP.hs
@@ -0,0 +1,64 @@
+module LinearSplitP where
+import AllFudgets
+--import ListUtil(chopList)
+import HbcUtils(apFst,chopList)
+import Data.Maybe(isJust,listToMaybe)
+
+horizontalSplitP = horizontalSplitP' defaultSep
+verticalSplitP = verticalSplitP' defaultSep
+
+horizontalSplitP' = linearSplitP Horizontal
+verticalSplitP' = linearSplitP Vertical
+
+linearSplitP dir sep = P linearSplitP'
+  where
+    linearSplitP' [] = linearP' []
+    linearSplitP' [r] = linearP' [r]
+    linearSplitP' reqs0 = (req,placer2)
+      where
+        reqss = chopReqs reqs0
+        (reqs1,placers2) = unzip (fmap linearP' reqss)
+	--reqs2 = zipWith adjSize (sizes reqss) reqs1
+	(req,placer2a) = linearP' reqs1
+	positions = fmap ( \ r->listToMaybe r >>= wantedPos) reqss
+	placer2 r@(Rect _ s) =
+ 	  concat . zipWith id placers2 . adjPlaces s positions . placer2a $ r
+
+    adjPlaces asize (_:ps) (r:rs) = adjPlaces' ps r rs
+      where
+	adjPlaces' (optp:ps) r1@(Rect p1 s1) (r2@(Rect p2 s2):rs) =
+	  case optp of
+	    Nothing -> r1:adjPlaces' ps r2 rs -- shouldn't happen
+	    Just (p0,s,a) -> r1' : adjPlaces' ps r2' rs
+	      where v = mkp dir d 0
+	             where
+		       d = max 1 (d0+d1)-d1 -- try to avoid sizes <= 0
+		       d0 = xc dir p-xc dir (rectpos r2)
+		       d1 = xc dir s1
+		    p = p0 + scalePoint a (asize-s)
+		    r1' = Rect p1 (s1+v)
+		    r2' = Rect (p2+v) (s2-v)
+	adjPlaces' [] r [] = [r]
+
+
+    chopReqs = chopList splitReqs
+
+    splitReqs (r:rs) = apFst (r:) (break wantPos rs)
+    splitReqs [] = ([],[])
+
+    wantPos = isJust . wantedPos
+
+    linearP' = unP (linearP dir sep)
+
+    {-
+    adjSize Nothing req = req
+    adjSize (Just s1) req@(Layout{minsize=s2}) =
+        req{minsize=size, wAdj=const size, hAdj=const size}
+      where size = mkp dir (xc dir s1) (yc dir s2)
+
+    sizes = sizes' . (Just 0:) . tail . positions
+    sizes' ps = zipWith size ps (tail ps++[Nothing])
+      where size optp1 optp2 = do p1 <- optp1
+                                  p2 <- optp2
+				  return (p2-p1-mkp dir sep 0)
+    -}
diff --git a/Contrib/MenuBarF.hs b/Contrib/MenuBarF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/MenuBarF.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE CPP #-}
+module MenuBarF(
+#ifndef __NHC__
+	menuF,menuBarF,MenuBar(..),Menu(..),MenuItem'(..),
+	Item,item,item',key,itemValue,
+	cmdItem,subMenuItem,toggleItem,sepItem,
+	radioGroupItem,dynRadioGroupItem,
+	delayedSubMenuItem,
+	MenuItem(..),menu,Transl(..),idT,compT,
+	menuIcon
+#endif
+  ) where
+import Control.Monad((<=<))
+import AllFudgets hiding (menuF)
+import HbcUtils(mapFst)
+--import MonadUtil((@@))
+import DynRadioGroupF
+import KeyGfx
+
+#ifndef __NHC__
+#include "../hsrc/exists.h"
+
+tr x = ctrace "menubar" x x
+
+--- Top level calls, eta expanded because of the monomorphism restriction
+menuBarF menu = menuListF Horizontal menu
+menuF menu =  menuListF Vertical menu
+
+type MenuBar a = Menu a
+type Menu a = [MenuItem' a]
+type Keys = [(ModState,KeySym)]
+
+type MenuItem' a = Item (MenuItem a)
+
+data Item a = Item a Gfx Keys
+item i = item' [] i -- eta expanded because of the monomorphism restriction
+item' k i g = Item i (G g) k
+itemValue  (Item a _ _) = a
+
+key (Item a g _) k = Item a (G (keyGfx g k)) [([metaKey],k)]
+			-- this creates some unnecessary nested G (G ..)
+
+instance Graphic (Item a) where
+  measureGraphicK (Item _ gfx _) = measureGraphicK gfx
+
+instance Eq a => Eq (Item a) where
+  Item x _ _ == Item y _ _ = x==y
+
+cmdItem x = item . MenuCommand $ x -- eta expanded because of the monomorphism restriction
+toggleItem tr = item . MenuToggle tr
+subMenuItem tr = item . SubMenu False tr
+delayedSubMenuItem tr = item . SubMenu True tr
+radioGroupItem tr items = item . MenuRadioGroup tr items
+dynRadioGroupItem tr items = item . MenuDynRadioGroup tr items
+sepItem = item MenuLabel (padD 3 $ g $ hFiller 1)
+
+data MenuItem a
+  = MenuCommand a
+  | MenuToggle (Transl Bool a) Bool
+  | EXISTS(b) (Eq EQV(b)) => MenuRadioGroup (Transl EQV(b) a) [Item EQV(b)] EQV(b)
+  | EXISTS(b) (Eq EQV(b)) => MenuDynRadioGroup (Transl ([Item EQV(b)],EQV(b)) a) [Item EQV(b)] EQV(b)
+  | EXISTS(b) (Eq EQV(b)) => SubMenu Bool (Transl EQV(b) a) (Menu EQV(b))
+  | MenuLabel
+
+-- eta expanded because of the monomorphism restriction:
+menu t = SubMenu False t
+
+type MMsg a = Either MenuState a
+type MF a b = F (MMsg a) (MMsg b)
+
+data Transl l g = Transl (l->g) (g->Maybe l)
+
+--- 
+menuItemF :: Eq a => LayoutDir -> MenuItem' a -> MF a a
+menuItemF dir (Item item gfx keys) =
+  case item of
+    MenuCommand a -> translF (click a) (buttonF' (setAlign aLeft . pm) gfx)
+    MenuToggle tr init ->
+	translF tr (delayItF>==<startupF [init] (toggleButtonF' pm gfx))
+    MenuRadioGroup tr items init ->
+	translF tr (delayItF>==<gfx `labAboveF` radioGroupF' pm alts init)
+      where alts = [(a,g)|Item a g _<-items]
+	    pm = setFont menuFont .
+		 setPlacer (verticalP' 0) -- (the default is verticalLeftP' 0)
+    MenuDynRadioGroup tr items init ->
+	translF tr' (delayItF>==<gfx `labAboveF` dynRadioGroupF' pm alts init)
+      where alts = [(a,g)|Item a g _<-items]
+	    pm = setFont menuFont .
+		 setPlacer (verticalP' 0) -- (the default is verticalLeftP' 0)
+	    tr' = compT tr dynRadioT
+	    dynRadioT = Transl f g
+	      where
+	        f (alts,alt) = ([Item i g []|(i,g)<-alts],alt)
+		g (items,alt) = Just ([(a,g)|Item a g _<-items],alt)
+
+    SubMenu d tr m  -> translMenuF tr (btnMenuF d dir gfx ({-delayF' d $-} subMenuF m))
+    MenuLabel     -> graphicsLabelF gfx
+--    MenuDelayed item' -> delayF' $ menuItemF dir (Item item' gfx keys)
+  where
+    --pm = setKeys keys . setFont menuFont
+    -- becuase of the mononorphism restriction:
+    pm x = setKeys keys . setFont menuFont $ x
+
+{-
+    delayF' delayed =
+      if delayed
+      then delayF''
+      else id
+
+    delayF'' fud =
+      if argFlag "teemenu" False
+      then delayF fud >==< idRightF (teeF show "menuItemF: ")
+      else delayF fud
+-}
+
+btnMenuF :: Bool -> LayoutDir -> Gfx -> F (MMsg a) a -> MF a a
+btnMenuF delayed dir gfx mF =
+    buttonMenuF' delayed dir menuFont agfx [] mF >=^< mapEither id Right
+  where
+    agfx = hboxcD' 3 [g gfx,g menuIcon]
+
+translF (Transl f g) fud =
+  Right . f >^=< fud >=^^< mapFilterSP (either (const Nothing) g)
+
+translMenuF (Transl f g) fud =
+  mapEither id f >^=< fud >=^^< idLeftSP (mapFilterSP g)
+
+click a = Transl (const a) (\b->if a==b then Just Click else Nothing)
+idT = Transl id (const Nothing)
+--idT = Transl id Just -- why not this?
+compT (Transl f1 g1) (Transl f2 g2) = Transl (f1 . f2) (g2 <=< g1)
+
+-- There should be only one grabberF outside the top level menu.
+menuListF :: Eq a => LayoutDir -> Menu a -> F a a
+menuListF dir menu = grabberF (menuKeys menu) $ menuListF' dir menu
+  where
+    menuKeys :: Menu a -> [(a,Keys)]
+    menuKeys = concatMap itemKeys
+    itemKeys (Item m _ keys) =
+	case m of
+	  SubMenu _ (Transl f _) menu -> mapFst f (menuKeys menu)
+	  MenuRadioGroup (Transl f _) items init ->
+	    [(f a,ks)|Item a _ ks<-items]
+	  --MenuCommand cmd -> [(cmd,keys)]
+	  --MenuToggle (Transl f _) init -> [(f init,keys)] -- hmm
+	  _ -> []
+
+subMenuF :: Eq a => Menu a -> F (MMsg a) a
+subMenuF menu = filterRightSP >^^=< menuListF' Vertical menu
+
+menuListF' :: Eq a => LayoutDir -> Menu a -> MF a a
+menuListF' dir m =
+    loopLeftF $
+    concatMapSP post >^^=< placerF (linearP dir 0) (listF nms)
+    >=^^< concatMapSP pre
+  where
+    nms = [(i,menuItemF dir e) | (i,e) <- number 0 m]
+    ns = map fst nms
+    post (i,Right x) = [Right $ Right x]
+    post (i,Left b) = [Right $ Left b,Left (i,b)]
+    pre (Right (Right x)) = ctrace "menubar" "got input" [(i,Right x) | i<-ns]
+    pre (Right (Left b)) =  [(i,Left b) | i<-ns]
+    pre (Left (j,b)) = [(i,Left b) | i<-ns, i/=j]
+
+delayItF = idF
+{-
+delayItF = loopThroughRightF (absF idleSP) timerF
+  where
+    idleSP = getSP $ either (const idleSP) delaySP
+    delaySP x = putSP (Left (Just (0,delay))) $ waitSP x
+    waitSP x = getSP $ either doneSP waitSP
+      where doneSP _ = putSP (Left Nothing) $ putSP (Right x) idleSP
+
+    delay = argReadKey "delay" 200
+-}
+
+--- temporary hack:
+{-
+--subMenuF gfx mF = menuPopupF mF >==< throughF (buttonF agfx>=^^<nullSP)
+menuPopupF mF =
+    post >^=<
+    inputPopupF "Menu" (inputMsg>^=<mF>=^^<filterRightSP) Nothing
+     >=^< pre
+  where
+    pre cmd = (Nothing,Just cmd)
+    post = snd
+-}
+
+menuIcon =
+  FixD 12 [
+    DrawRectangle (rR 1 0 8 10),
+    DrawLine (lL 4 3 6 3),
+    DrawLine (lL 4 5 6 5),
+    DrawLine (lL 4 7 6 7),
+    DrawLine (lL 3 11 10 11),
+    DrawLine (lL 10 2 10 11)]
+    
+
+#endif
diff --git a/Contrib/MeterF.hs b/Contrib/MeterF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/MeterF.hs
@@ -0,0 +1,33 @@
+module MeterF where
+import AllFudgets
+import Data.Ratio
+
+meterF :: RealFrac v => InF v (Ratio Int) -- because of the monomorphism restr
+meterF = meterF' standard
+
+meterF' pm =
+   post >^^=< border3dF True 1 (graphicsDispF' params) >=^< pre
+ where
+   params = pm .
+	    --setSizing Static .
+	    --setGfxEventMask [GfxButtonMask,GfxDragMask] .
+	    setBgColor meterBg .
+	    setFgColorSpec meterFg .
+	    setBorderWidth 0
+   pre = Right . replaceAllGfx . meterD
+   post = mapFilterSP pick
+   pick (GfxButtonEvent {gfxType=Pressed,gfxPaths=p:_}) = change p
+   pick (GfxButtonEvent {gfxType=Released,gfxPaths=p:_}) = done p
+   pick (GfxMotionEvent {gfxPaths=p:_}) = change p
+   pick _ = Nothing
+   change = Just . inputChange . extr
+   done = Just . inputMsg . extr
+   extr (_,(p,Rect p0 s)) = xcoord (p-p0) % xcoord s
+
+meterD r = FlexD (Point 50 5) False True drawfun
+  where
+    drawfun (Rect p (Point w h)) = [FillRectangle (Rect p (Point w' h))]
+      where w' = scale r w
+
+meterFg = colorSpec $ argKeyList "meterfg" ["blue2",fgColor,"black"]
+meterBg = colorSpec $ argKeyList "meterbg" [bgColor,"white"]
diff --git a/Contrib/ReactionM.hs b/Contrib/ReactionM.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/ReactionM.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE CPP #-}
+module ReactionM where
+import Data.Maybe(isJust)
+import Control.Applicative
+import Control.Monad(ap)
+#if MIN_VERSION_base(4,12,0)
+#if MIN_VERSION_base(4,13,0)
+#else
+import Control.Monad.Fail
+#endif
+#endif
+
+-- | Writer & State & Exception monad
+newtype ReactionM s o a = M (s -> [o] -> Maybe (s,[o],a))
+
+instance Functor (ReactionM s o) where
+  fmap f m = do x <- m; return (f x)
+
+instance Applicative (ReactionM s o) where
+  pure = return
+  (<*>) = ap
+
+instance Monad (ReactionM s o) where
+  return x = M (\s o->Just (s,o,x))
+  (M f1) >>= xm2 =
+    M $ \ s0 o0 ->
+      let r1 = f1 s0 o2
+          Just (s1,o1,x1) = r1
+          M f2 = xm2 x1
+	  r2 = f2 s1 o0
+	  Just (s2,o2,x2) = r2
+      in if isJust r1 && isJust r2
+         then Just (s2,o1,x2)
+	 else Nothing
+#if MIN_VERSION_base(4,12,0)
+instance MonadFail (ReactionM s o) where
+#endif
+  fail _ = rfail
+
+react (M f) s0 = case f s0 [] of Just (s,o,_) -> (s,o); _ -> (s0,[])
+put o = M $ \ s os -> Just (s,o:os,())
+set s = M $ \ _ os -> Just (s,os,())
+get = M $ \ s os -> Just (s,os,s)
+field f = f <$> get
+update f = M $ \ s os -> Just (f s,os,())
+
+rfail = M $ \ _ _ -> Nothing
+
+lift m = maybe rfail return m
+nop = return ()
+nop :: Monad m => m ()
diff --git a/Contrib/ReactiveF.hs b/Contrib/ReactiveF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/ReactiveF.hs
@@ -0,0 +1,9 @@
+-- | Program stateful abstract fudgets in a monadic style
+module ReactiveF(reactiveF,reactiveSP,module ReactionM) where
+import Fudgets
+import ReactionM
+
+reactiveF  = mapstateF  . mf
+reactiveSP = mapstateSP . mf
+
+mf rM s m = react (rM m) s
diff --git a/Contrib/ShapedButtonsF.hs b/Contrib/ShapedButtonsF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/ShapedButtonsF.hs
@@ -0,0 +1,298 @@
+module ShapedButtonsF (radioF1, radioGroupF1, toggleF1, toggleButtonF1, RBBT (..)) where
+import AllFudgets
+import HbcUtils(lookupWithDefault)
+
+data RBBT = Circle | Square | Triangle
+type RadioButtonBorderType = RBBT
+
+radioF1 bbt fname alts startalt =
+    radioGroupF1 bbt fname (map fst alts) startalt 
+      (lookupWithDefault alts (error "radioF"))
+
+radioGroupF1 :: Eq a => RadioButtonBorderType -> FontName -> [a] -> a -> 
+                        (a -> String) -> F a a
+radioGroupF1 bbt fname alts startalt show_alt =
+    let radioAlts = radioButtonsF1 bbt fname alts show_alt
+        buttons = radioAlts >=^< stripEither
+    in  loopLeftF (excludeF1 startalt >==< buttons) >=^<
+        (\x -> pair x True)
+
+radioButtonsF1 bbt fname alts show_alt =
+    let radiobutton alt =
+            (
+             alt,
+             noStretchF False True 
+               (toggleButtonF1 bbt fname [] (show_alt alt))
+            )
+    in  listLF (verticalP' 0) (map radiobutton alts)
+
+excludeF1 start =
+    let excl last' =
+            let same = excl last'
+                cont last'' = excl last''
+            in  getSP (\msg ->
+                       case msg of
+                         (new, False) -> if new == last' then
+                                             putsSP [Left (new, True)] (cont new)
+                                         else
+                                             same
+                         (new, True) -> if new == last' then
+                                            putsSP [Right new] (cont new)
+                                        else
+                                            putsSP [Left (last', False), Right new]
+                                                  (cont new))
+    in  absF (putsSP [Left (start, True)] (excl start))
+
+toggleF1 bbt keys f =
+  case bbt of
+    Square ->
+      let edgew = 3
+          dsize = Point 10 10
+          innersep = 3
+          fudgetsep = 5
+          toggleK =
+              let cid False = 0
+                  cid True = 1
+              in  allocNamedColorPixel defaultColormap
+                                  onColor1
+                                  (\onC ->
+                                   allocNamedColorPixel defaultColormap
+                                                   offColor1
+                                                   (\offC ->
+                                                    let toggle s =
+                                                            map (Low . XCmd)
+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],
+                                                                 ClearWindow]
+                                                        k (High s) = toggle s
+                                                        k _ = []
+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :
+                                                              toggle False)
+                                                             (K $ concmapSP k)))
+          toggleb =
+                buttonBorderF1 bbt edgew
+                              (marginF innersep
+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}] toggleK))
+          togglebd =
+              let post (Left a) = Left a
+                  post (Right b) = stripEither b
+              in  stripEither >^=<
+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<
+                   (fudgetsep, LeftOf, f))
+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)
+    Triangle ->
+      let edgew = 3
+          dsize = Point 12 12
+          innersep = 6
+          fudgetsep = 5
+          toggleK =
+              let cid False = 0
+                  cid True = 1
+              in  allocNamedColorPixel defaultColormap
+                                  onColor1
+                                  (\onC ->
+                                   allocNamedColorPixel defaultColormap
+                                                   offColor1
+                                                   (\offC ->
+                                                    let toggle s =
+                                                            map (Low . XCmd)
+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],
+                                                                 ClearWindow]
+                                                        k (High s) = toggle s
+                                                        k _ = []
+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :
+                                                              toggle False)
+                                                             (K $ concmapSP k)))
+          vormT punt = [FillPolygon Nonconvex CoordModeOrigin [origin, padd origin (Point 0 ((ycoord punt)-1)),
+                        padd origin (Point ((xcoord punt)-1) (((ycoord punt)`div`2)-1))]]
+          toggleb =
+                buttonBorderF1 bbt edgew
+                              (marginF innersep
+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}]
+                                              (shapeK vormT toggleK)))
+          togglebd =
+              let post (Left a) = Left a
+                  post (Right b) = stripEither b
+              in  stripEither >^=<
+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<
+                   (fudgetsep, LeftOf, f))
+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)
+    Circle ->
+      let edgew = 3
+          dsize = Point 16 16
+          innersep = 2
+          fudgetsep = 5
+          toggleK =
+              let cid False = 0
+                  cid True = 1
+              in  allocNamedColorPixel defaultColormap
+                                  onColor1
+                                  (\onC ->
+                                   allocNamedColorPixel defaultColormap
+                                                   offColor1
+                                                   (\offC ->
+                                                    let toggle s =
+                                                            map (Low . XCmd)
+                                                                [ChangeWindowAttributes [CWBackPixel (if s then onC else offC)],
+                                                                 ClearWindow]
+                                                        k (High s) = toggle s
+                                                        k _ = []
+                                                    in  putsK (Low (layoutRequestCmd (plainLayout dsize True True)) :
+                                                              toggle False)
+                                                             (K $ concmapSP k)))
+          vormC punt = [FillArc (Rect origin (Point ((xcoord punt)-1) ((ycoord punt)-1))) (0*64) (360*64)]
+          toggleb =
+                buttonBorderF1 bbt edgew
+                              (marginF innersep
+                                    (windowF [{-ConfigureWindow [CWBorderWidth 0]-}]
+                                             (shapeK vormC toggleK)))
+          togglebd =
+              let post (Left a) = Left a
+                  post (Right b) = stripEither b
+              in  stripEither >^=<
+                  (marginHVAlignF 0 aCenter aCenter toggleb >+#<
+                   (fudgetsep, LeftOf, f))
+      in  toggleGroupF keys (marginHVAlignF 0 aLeft aCenter togglebd)
+
+toggleButtonF1 :: RadioButtonBorderType -> String -> [(ModState, KeySym)] -> String -> F Bool Bool
+toggleButtonF1 bbt fname keys text =
+  stripEither >^=<
+  toggleF1 bbt keys (noStretchF True True (labelF' (setFont fname) text))
+  >=^< Left
+
+offColor1 = argKey "toggleoff" bgColor
+
+onColor1 = argKey "toggleon" fgColor
+
+buttonBorderF1 :: RadioButtonBorderType -> Int -> (F a b) -> F (Either Bool a) b
+buttonBorderF1 = stdButtonBorderF1
+
+stdButtonBorderF1 bbt edgew f =
+    let kernel =
+          allocNamedColorDefPixel defaultColormap shineColor "white" $ \shine ->
+          allocNamedColorDefPixel defaultColormap shadowColor "black" $ \shadow ->
+          wCreateGC rootGC [GCFunction GXcopy, GCForeground shadow,
+                            GCBackground shine] $ \drawGC ->
+          wCreateGC rootGC [GCFunction GXcopy, GCForeground shine, GCBackground shine] $ \extraGC ->
+          wCreateGC rootGC (invertColorGCattrs shine shadow) $ \invertGC ->
+          let
+              dRAWS s =
+                    let bpx = edgew
+                        bpy = edgew
+                        upperLeftCorner = Point bpx bpy
+                        size@(Point sx sy) = psub s (Point 1 1)
+                        rect = Rect origin size
+                        upperRightCorner = Point (sx - bpx) bpy
+                        lowerLeftCorner = Point bpx (sy - bpy)
+                        lowerRightCorner = psub size upperLeftCorner
+                        leftBorder = Line upperLeftCorner lowerLeftCorner
+                        upperBorder = Line upperLeftCorner upperRightCorner
+                        upperLeftLine = Line origin upperLeftCorner
+                        lowerRightLine = Line lowerRightCorner size
+                        incx = padd (Point 1 0)
+                        incy = padd (Point 0 1)
+                        decx = padd (Point (-1) 0)
+                        decy = padd (Point 0 (-1))
+                        lowerBorderPoints = [lowerLeftCorner, lowerRightCorner,
+                                             upperRightCorner, Point sx 0, size, Point 0 sy]
+                        borderPoints =
+                          [pP 1 1, pP 1 sy, size, pP sx 1, origin, upperLeftCorner,
+                           incy lowerLeftCorner, (incx . incy) lowerRightCorner,
+                           incx upperRightCorner, upperLeftCorner]
+                        rectPoints = [origin, padd origin (Point (sx-1) 0), size, padd origin (Point 0 (sy-1))]
+                    in  (map Low [
+                                  wFillPolygon extraGC Convex CoordModeOrigin rectPoints,
+                                  wFillPolygon drawGC Nonconvex CoordModeOrigin lowerBorderPoints,
+                                  wDrawLine drawGC leftBorder,
+                                  wDrawLine drawGC upperBorder,
+                                  wDrawLine drawGC upperLeftLine,
+                                  wDrawLine invertGC lowerRightLine,
+                                  wDrawRectangle drawGC rect
+                                 ],
+                                 [Low (wFillPolygon invertGC Nonconvex CoordModeOrigin borderPoints)])
+              dRAWT s =
+                    let bpx = edgew
+                        bpy = edgew+2
+                        upperLeftCorner = Point bpx bpy
+                        size@(Point sx sy) = psub s (Point 1 1)
+                        ap = padd origin (Point 5 2)
+                        bp = padd origin (Point 5 (sy-3))
+                        cp = Point (sx) (((sy - bpy)`div`2)+2)
+                        dp = padd ap (Point bpx bpy)
+                        ep = padd bp (Point bpx (-bpy))
+                        fp = psub cp (Point (bpx+4) 0)
+                        l1 = Line ap bp
+                        l2 = Line bp cp
+                        l3 = Line cp ap
+                        l4 = Line dp ep
+                        l5 = Line ep fp
+                        l6 = Line fp dp
+                        l7 = Line ap dp
+                        l8 = Line bp ep
+                        l9 = Line cp fp
+                        incx = padd (Point 1 0)
+                        incy = padd (Point 0 1)
+                        decx = padd (Point (-1) 0)
+                        decy = padd (Point 0 (-1))
+                        tBorderPoints = [(incx . incy) ap, decy bp, decx cp, (incx . incy) ap, dp, fp, ep, dp]
+                        tLowerBorderPoints = [ep,bp,cp,fp]
+                        trianglePoints = [ap,bp,cp]
+                    in  (map Low [
+                                  wFillPolygon extraGC Nonconvex CoordModeOrigin trianglePoints,
+                                  wFillPolygon drawGC Nonconvex CoordModeOrigin tLowerBorderPoints,
+                                  wDrawLine drawGC l1,
+                                  wDrawLine drawGC l2,
+                                  wDrawLine drawGC l3,
+                                  wDrawLine drawGC l4,
+                                  wDrawLine drawGC l5,
+                                  wDrawLine drawGC l6,
+                                  wDrawLine drawGC l7,
+                                  wDrawLine drawGC l8,
+                                  wDrawLine drawGC l9
+                                 ],
+                                 [
+                                  Low (wFillPolygon invertGC Nonconvex
+                                  CoordModeOrigin tBorderPoints)
+                                 ])
+              dRAWC s =
+                    let bpx = edgew
+                        bpy = edgew
+                        upperLeftCorner = Point bpx bpy
+                        size@(Point sx sy) = psub s (Point 1 1)
+                        groteRechthoek = Rect origin size
+                        groteRechthoek2 = Rect (psub origin (Point 1 1)) size
+                        kleineRechthoek = Rect (padd origin (Point edgew edgew)) (Point (sx-(2*edgew)) (sy-(2*edgew)))
+                    in  (map Low [
+                                  wFillArc extraGC groteRechthoek (0*64) (360*64),
+                                  wFillArc drawGC groteRechthoek (-135*64) (180*64),
+                                  wDrawArc drawGC groteRechthoek (0*64) (360*64),
+                                  wFillArc extraGC kleineRechthoek (0*64) (360*64),
+                                  wDrawArc drawGC kleineRechthoek (0*64) (360*64)
+                                 ],
+                                 [Low (wFillArc invertGC groteRechthoek2 (0*64) (360*64))])
+              proc pressed size =
+                  getK $ \bmsg ->
+                  let same = proc pressed size
+                      (drawit_size, pressit_size) = case bbt of
+                                                      Square -> dRAWS size
+                                                      Triangle -> dRAWT size
+                                                      Circle -> dRAWC size
+                      redraw b = if (b == pressed) then [] else pressit_size
+                  in  case bmsg of
+                        Low (XEvt (Expose _ 0)) -> putsK (drawit_size ++
+                            (if pressed then pressit_size else [])) same
+                        Low (LEvt (LayoutSize newsize)) -> proc pressed newsize
+                        High change -> putsK (redraw change) (proc change size)
+                        _ -> same
+              proc0 pressed =
+                  getK $ \msg ->
+                  case msg of
+                    Low (LEvt (LayoutSize size)) -> proc pressed size
+                    High change -> proc0 change
+                    _ -> proc0 pressed
+          in  proc0 False
+
+        startcmds =
+          [XCmd $ ConfigureWindow [CWBorderWidth 0],
+           XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]]]
+    in  stripEither >^=< (((groupF startcmds (changeBg bgColor kernel)) . marginF (edgew + 1)) f)
+
diff --git a/Contrib/SmileyF.hs b/Contrib/SmileyF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/SmileyF.hs
@@ -0,0 +1,28 @@
+module SmileyF where
+import Fudgets
+
+data SmileyMode = Sad | Indifferent | Happy deriving (Eq,Ord,Enum,Show)
+
+smileyF = smileyF' standard
+
+smileyF' :: Customiser (DisplayF SmileyMode) -> F SmileyMode void
+smileyF' pm = displayF' pm'
+  where pm' = pm .
+	      setInitDisp Indifferent .
+	      setInitSize Indifferent .
+	      setStretchable (False,False) .
+	      (setMargin 1 :: (Customiser (DisplayF SmileyMode)))
+
+smileyD mode =
+  FixD (Point 15 15) [
+    drawCircle (Point 2 2) 2,	-- eye
+    drawCircle (Point 10 2) 2,	-- eye
+    DrawLine (lL 7 5 7 9),	-- nose
+    case mode of
+      Sad -> DrawArc (rR 3 11 8 4) 0 (64*180)		-- mouth
+      Indifferent -> DrawLine (lL 3 12 11 12)		-- mouth
+      Happy -> DrawArc (rR 3 9 8 4) (64*180) (64*180)	-- mouth
+  ]
+
+instance Graphic SmileyMode where
+  measureGraphicK = measureGraphicK . smileyD
diff --git a/Contrib/SocketServer.hs b/Contrib/SocketServer.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/SocketServer.hs
@@ -0,0 +1,41 @@
+module SocketServer(ClientMsg(..),SocketMsg(..),mapSocketMsg,socketServerF) where
+import AllFudgets
+import DialogueIO hiding (IOError)
+
+data ClientMsg a = ClientMsg a | ClientEOS | ClientNew deriving (Show)
+data SocketMsg a = SocketMsg a | SocketEOS deriving (Show)
+
+mapSocketMsg f (SocketMsg a) = SocketMsg (f a)
+mapSocketMsg f SocketEOS = SocketEOS
+
+instance Functor SocketMsg where fmap = mapSocketMsg
+
+socketServerF port f = 
+    loopThroughRightF (concatMapF router) (listenerF >+< dynListF)
+  where
+    router = either (either fromListener fromDynList) fromOutside
+      where
+	fromListener (i,f) = [todyn (i,DynCreate f), out (i,ClientNew)]
+
+	fromDynList (i,m) =
+	  case m of
+	    SocketMsg m' -> [out (i,ClientMsg m')]
+	    SocketEOS    -> [out (i,ClientEOS), todyn (i,DynDestroy)]
+
+	fromOutside (i,m) = [todyn (i,DynMsg m)]
+
+        todyn = Left . Right
+	out = Right
+
+    listenerF =
+        openLSocketF port $ \lsocket ->
+	select [LSocketDe lsocket] $
+	accepter 0
+      where
+	accepter i = 
+	  getMessageFu $ \e ->
+	  case e of
+	    Low (DResp (AsyncInput (_,SocketAccepted socket peer))) ->
+		  putF (i,f socket peer) $
+		  accepter (i+1)
+	    _ -> accepter i
diff --git a/Contrib/SplitF.hs b/Contrib/SplitF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/SplitF.hs
@@ -0,0 +1,39 @@
+module SplitF where
+import AllFudgets
+import HandleF(vHandleF,hHandleF)
+import LinearSplitP(linearSplitP)
+
+hSplitF = hSplitF' aCenter
+vSplitF = vSplitF' aCenter
+
+hSplitF' = splitF' Horizontal
+vSplitF' = splitF' Vertical
+
+splitF' dir alignment fud1 fud2 =
+    loopCompThroughRightF $
+    groupF startcmds sizeK $
+    placerF (linearSplitP dir defaultSep) $
+    fud1>+<hF>+<fud2
+  where
+    startcmds = [XCmd $ ChangeWindowAttributes [CWBackPixmap parentRelative]]
+
+    hF = colinear dir hHandleF vHandleF alignment
+
+    toLoop = Just . High . Left
+    out = Just . High . Right
+    toHandle = toLoop . Left . Right
+    toFud1 = toLoop . Left . Left
+    toFud2 = toLoop . Right
+
+    sizeK = K (mapFilterSP route)
+    route = message low high
+
+    low (LEvt (LayoutSize size)) = toHandle size
+    low event = ignore event
+    
+    high = either fromLoop (either toFud1 toFud2)
+    fromLoop = either (either fromFud1 ignore) fromFud2
+    fromFud1 = out . Left
+    fromFud2 = out . Right
+
+    ignore _ = Nothing
diff --git a/Contrib/SuperMenuF.hs b/Contrib/SuperMenuF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/SuperMenuF.hs
@@ -0,0 +1,239 @@
+module SuperMenuF (superMenuF, MenuItem (..)) where
+--module SuperMenuF where
+import AllFudgets
+import Data.Maybe(fromJust) --,fromMaybe
+import HbcUtils(breakAt)
+
+data MenuItem a =
+       Item a
+       | Submenu (String, [MenuItem a])
+       deriving (Eq, Ord, Show)
+
+data MenuTag a =
+       ItemTag a
+       | SubTag String
+       deriving (Eq, Ord)
+
+data PopupSubMenu =
+       PopupSub Point
+       | PopdownSub
+          
+mainTag = SubTag "Joost Bossuyt"
+
+modstate = []
+
+mousebutton = Button 1
+
+menuButtonF1 gcs optrect text =
+  let mask =
+        [EnterWindowMask, LeaveWindowMask, ButtonPressMask, ButtonReleaseMask,
+         ExposureMask]
+      startcmds =
+        [XCmd $ ChangeWindowAttributes [CWEventMask mask, CWBackingStore Always]]
+      optsize = fmap rectsize optrect
+  in swindowF startcmds
+             optrect
+             (buttonDisplayK gcs optsize text)
+
+lxcmd = Low . XCmd
+
+buttonDisplayK (drawGC,invertGC,fs) opsize text =
+    let Rect spos ssize = string_rect fs text
+        margin = Point 3 1
+        size =case opsize of
+                Just s -> s
+                Nothing -> padd ssize (padd margin margin)
+        invertitif b size' =
+          if b then [Low (wFillRectangle invertGC (Rect origin size'))]
+               else []
+        drawit state size' =
+          let textpos = psub margin spos
+          in [lxcmd ClearWindow, Low (wDrawImageString drawGC textpos text)]
+                ++ invertitif (state == BMInverted) size'
+        buttonproc bstate size' =
+          let same = buttonproc bstate size'
+              cont b = buttonproc b size'
+              redraw b s = putsK (drawit b s) (buttonproc b s)
+          in getK $ \bmsg ->
+               case bmsg of
+                 Low (XEvt (Expose _ 0)) -> redraw bstate size'
+                 Low (LEvt (LayoutSize size'')) -> redraw bstate size''
+                 Low (XEvt (ButtonEvent _ _ _ _ Released _)) ->
+                   putsK (invertitif (bstate == BMInverted) size'
+                           ++ [High (BMClick, Nothing)])
+                        (cont BMNormal)
+                 Low (XEvt (EnterNotify {pos=winpos,rootPos=rootpos})) ->
+                   let width = Point (xcoord size') (-1) 
+                       pos = padd (psub rootpos winpos) width
+                   in putsK (invertitif (bstate /= BMInverted) size'
+                              ++ [High (BMInverted, Just pos)])
+                        (cont BMInverted)
+                 Low (XEvt (LeaveNotify {})) ->
+                   putsK (invertitif (bstate /= BMNormal) size') (cont BMNormal)
+                 _ -> same
+    in putsK [Low (layoutRequestCmd (plainLayout size True True))]
+            (buttonproc BMNormal size)
+
+menuListF gcs alts show_alt =
+  let --show_MenuTag :: MenuTag a -> String
+      show_MenuTag x =
+        case x of
+          ItemTag a -> show_alt a
+          SubTag s -> s
+      altButton alt = (alt, menuButtonF1 gcs Nothing (show_MenuTag alt))
+  in listLF (verticalP' 0) (map altButton alts)
+
+subMenuF gcs optrect alts show_alt =
+    let wattrs = [CWEventMask [], CWSaveUnder True, CWOverrideRedirect True]
+        startcmds = [lxcmd $ ChangeWindowAttributes wattrs,
+	             lxcmd $ ConfigureWindow [CWBorderWidth 1]]
+        fudget = menuListF gcs alts show_alt 
+    in delayF $
+       loopCompThroughRightF $
+       shellKF' (setMargin 0.setVisible False) (putsK startcmds subMenuK) fudget
+
+subMenuK =
+  let popdown = map lxcmd [UnmapWindow]
+      popup p = map lxcmd [moveWindow p, MapRaised]
+      downK =
+        getK (\msg ->
+          case msg of
+            High (Right (PopupSub p )) -> putsK (popup p) upK
+            _ -> downK)
+      upK =
+        getK (\msg ->
+          case msg of
+            High (Right PopdownSub) -> putsK popdown downK
+            High (Left (alt, (bm, pos))) ->
+              putsK [High (Right (alt, (bm, pos)))] upK
+            _ -> upK)
+  in setFontCursor 110 downK
+
+controlF list = loopCompThroughRightF (kernelF controlK >+< listF list)
+
+controlK ::
+  (Eq a) =>K (Either (MenuTag a,(MenuTag a,(BMevents,Maybe Point))) PopupSubMenu)
+             (Either (MenuTag a,PopupSubMenu) a)
+controlK =
+  let proc active =
+        getK (\msg ->
+          case msg of
+            High (Left (tag, (SubTag s, (bm, opoint)))) ->
+              (case bm of
+                 BMClick ->
+                   let oldlist = map (\x -> High (Left (x, PopdownSub))) active
+                   in putsK oldlist (proc [])
+                 BMInverted ->
+                   let (olist, nlist) = breakAt tag active
+                       newlist = [SubTag s, tag] ++ nlist
+                       oldlist = map (\x -> High (Left (x, PopdownSub))) olist
+                       pos = fromJust opoint
+                   in putsK (oldlist ++ [High(Left(SubTag s, PopupSub pos))])
+                           (proc newlist)
+                 _ -> proc active)
+            High (Left (tag, (ItemTag a, (bm, opoint)))) ->
+              (case bm of
+                 BMClick ->
+                   let oldlist = map (\x -> High (Left (x, PopdownSub))) active
+                   in putsK (oldlist ++ [High (Right a)]) (proc [])
+                 BMInverted ->
+                   let (olist, nlist) = breakAt tag active
+                       newlist = [tag] ++ nlist
+                       oldlist = map (\x -> High (Left (x, PopdownSub))) olist
+                   in putsK oldlist (proc newlist)
+                 _ -> proc active)
+            High (Right (PopupSub pos)) ->
+              putsK [High (Left (mainTag, PopupSub pos))] (proc [mainTag])
+            High (Right PopdownSub) ->
+              let oldlist = map (\x -> High (Left (x, PopdownSub))) active
+              in putsK oldlist (proc [])
+            _ -> proc active)
+  in proc []
+
+clickF1 gcs optrect name =
+  let topopup = High . Left
+      routeClick = Left
+      optsize = fmap rectsize optrect
+      proc (Low (XEvt (ButtonEvent _ winpos rootpos [] Pressed (Button 1)))) =
+          topopup (True, PopupSub (psub rootpos winpos))
+      proc (Low (XEvt (ButtonEvent _ _ _ _ Released (Button 1)))) =
+          topopup (False, PopdownSub)
+      proc (Low (XEvt (LeaveNotify {mode=NotifyUngrab}))) =
+          topopup (False, PopdownSub)
+      proc (Low msg) = Low msg
+      proc (High hi) = High (Right hi)
+      wattrs =
+        [CWEventMask [ExposureMask, ButtonPressMask, ButtonReleaseMask,
+         OwnerGrabButtonMask, LeaveWindowMask, EnterWindowMask]]
+      startcmds = [XCmd $ ChangeWindowAttributes wattrs,
+                   XCmd $ ConfigureWindow [CWBorderWidth 1]]
+      K cdisp = clickDisplayK gcs optsize name
+  in swindowF startcmds
+             optrect
+             (K $ preMapSP cdisp  proc)
+
+clickDisplayK (drawGC,invertGC,fs) optsize name0 =
+  let Rect spos ssize = string_rect fs name0
+      strsize = string_box_size fs
+      margin = Point 3 1
+      size = fromMaybe (padd ssize (padd margin margin)) optsize
+      invertitif b size' =
+        if b
+          then [Low (wFillRectangle invertGC (Rect origin size'))]
+          else []
+      drawname name hi size =
+        let textpos = scalePoint 0.5 (size `psub` strsize name) `psub` spos
+        in [lxcmd ClearWindow, Low (wDrawImageString drawGC textpos name)]
+               ++ invertitif hi size
+      buttonproc highlighted size' name =
+        let fixpos (PopupSub p) =
+              PopupSub (p `padd` pP (-1) (ycoord size'))
+            fixpos msg = msg
+            same = buttonproc highlighted size' name
+            cont b = buttonproc b size' name
+            contn n = buttonproc highlighted size' n
+            redraw b s = putsK (drawname name b s) (buttonproc b s name)
+            newname name' = putsK (drawname name' highlighted size')
+                                 (contn name')
+        in getK $ \bmsg ->
+             case bmsg of
+               Low (XEvt (Expose _ 0)) -> redraw highlighted size'
+               Low (LEvt (LayoutSize size'')) -> redraw highlighted size''
+               Low (XEvt (LeaveNotify {})) ->
+                 putsK (invertitif highlighted size') (cont False)
+               Low (XEvt (EnterNotify {})) ->
+                 putsK (invertitif (not highlighted) size') (cont True)
+               High (Left (hi, msg)) ->
+                  putsK (invertitif (hi /= highlighted) size' ++
+                        [High (fixpos msg)])
+                       (cont hi)
+               High (Right name') -> newname name'
+               _ -> same
+  in putsK [Low (layoutRequestCmd (plainLayout size True True))]
+          (buttonproc False size name0)
+
+superMenuF :: (Eq a) => (Maybe Rect) -> FontName -> String -> [MenuItem a]
+                        -> (a -> String) -> F String a
+superMenuF oplace fname text alts show_alt =
+   safeLoadQueryFont fname $ \fs ->
+   allocNamedColorPixel defaultColormap "black" $ \ black ->
+   allocNamedColorPixel defaultColormap "white" $ \ white ->
+   wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id fs)] $ \drawGC ->
+   wCreateGC drawGC (invertColorGCattrs black white) $ \invertGC ->
+   let gcs = (drawGC,invertGC,fs)
+       parse tag source current done =
+        if source == []
+          then if current == []
+                 then done
+                 else done ++ [(tag, subMenuF gcs Nothing current show_alt)]
+          else let (x : xs) = source
+               in case x of
+                    Item y -> parse tag
+                                    xs 
+                                    (current ++ [ItemTag y])
+                                    done
+                    Submenu (s, z) -> parse tag
+                                             xs
+                                            (current ++ [SubTag s])
+                                            (parse (SubTag s) z [] done)
+   in controlF (parse mainTag alts [] []) >==< clickF1 gcs oplace text
diff --git a/Contrib/TitleShellF.hs b/Contrib/TitleShellF.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/TitleShellF.hs
@@ -0,0 +1,26 @@
+module TitleShellF where
+import AllFudgets
+
+titleShellF = titleShellF' standard
+
+--titleShellF' :: Customiser ShellF -> String -> F (Either () i) (Either String o) -> F i o
+
+titleShellF' pm title fud =
+    filterRightSP >^^=< wmShellF' pm' title fud >=^< mapEither Left id
+  where
+    pm' = pm . setDeleteWindowAction (Just DeleteQuit)
+
+wmShellF = wmShellF' standard
+
+wmShellF' pm0 title fud =
+    shellKF' pm titleK0 fud
+  where pm = setDeleteWindowAction Nothing . pm0
+	action = maybe (Just reportK)
+	               (fmap action')
+		       (getDeleteWindowActionMaybe' pm0)
+	  where
+	    action' DeleteQuit = exitK
+	    action' DeleteUnmap = unmapWindowK
+
+        titleK0 = startupK [High (Left title)] titleK
+        titleK = wmK action
diff --git a/Contrib/TreeBrowser.hs b/Contrib/TreeBrowser.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/TreeBrowser.hs
@@ -0,0 +1,144 @@
+module TreeBrowser(Tree(..),treeBrowserF',treeDisplayF') where
+import AllFudgets hiding (Tree(..))
+import qualified ReactiveF as R
+
+data Tree leaf node
+  = Leaf leaf
+  | Node node [Tree leaf node]
+  deriving (Show)
+
+
+--treeBrowserF = treeBrowserF standard
+
+treeDisplayF' t = treeBrowserF'' drawStaticTree t
+treeBrowserF' t = treeBrowserF'' drawTree t
+
+--treeBrowserF' ::Tree n l -> F (Tree n l) ([n],Maybe l)
+treeBrowserF'' drawTree t =
+    wCreateGCtx rootGCtx (gcFgA linecolor) $ \ lgc ->
+    wCreateGCtx rootGCtx (gcFgA paperColor) $ \ bggc ->
+    treeBrowserF''' drawTree (bggc,lgc) t
+
+
+treeBrowserF''' drawTree gcs@(bggc,lgc) t =
+   loopThroughRightF (R.reactiveF ctrl d0) (graphicsDispF' pm)
+  where
+    pm1 :: Graphic a => Customiser (GraphicsF a)
+    pm1 = setBgColor bgColor . setSizing Dynamic
+    pm = pm1 . setInitDisp d0
+    d0 = drawTree gs t
+    ctrl = either fromLoop fromOutside
+      where
+	fromOutside t = do let d = drawTree gs t 
+			   R.set d
+			   R.put (toLoop $ replaceAllGfx d)
+
+	fromLoop gfxevent =
+	  do (path,lbl) <- clickedpart gfxevent
+	     case lbl of
+	       Left vis -> toggle path (not vis)
+	       Right part -> R.put (toOutside part)
+
+	toggle path vis =
+	  do (ppath,LabelD rt@(Right (Node n _))
+	                   (ComposedD _ (_:ds))) <- parentpathpart path
+	     let td' = LabelD rt (nodeD gs vis n ds)
+	     R.update $ \ d -> replacePart d ppath td'
+	     R.put (toLoop $ replaceGfx ppath td')
+
+    toLoop = Left
+    toOutside = Right
+
+    --gd = softAttribD [GCLineStyle LineOnOffDash] . g
+    --gd x = g x
+    gl = hardAttribD lgc . g
+    gbg = hardAttribD bggc . g
+    gs = (gbg,gl)
+
+clickedpart gfxevent =
+  case gfxevent of
+    GfxButtonEvent{gfxType=Pressed, gfxPaths=(path,_):_} -> pathlbl path
+    _ -> R.rfail
+
+pathlbl path =
+  do (lpath,LabelD lbl _) <- pathpart path
+     return (lpath,lbl)
+
+pathpart path =
+  do drawing <- R.get
+     let lpath = drawingAnnotPart drawing path
+     part <- R.lift $ maybeDrawingPart drawing lpath
+     return (lpath,part)
+
+parentpathpart = pathpart . up
+
+drawStaticTree gs t = placedD (verticalLeftP' 0) $ drawTree' gs Nothing t
+drawTree gs t = placedD (verticalLeftP' 0) $ drawTree' gs opendepthlimit t
+
+staticNodeD gs n ds = boxD (hboxD' 0 [sframeD 3 gs (g n)]:ds)
+
+nodeD gs@(gbg,gl) vis n ds =
+    boxVisibleD vcnt (hboxD' 0 [sframeD 3 gs (g n),gl hLineFD,markD]:ds)
+  where
+    vcnt = 1+(if vis then length ds else 0)
+    markD = labelD (Left vis) $ circleD (if vis then g "-" else g "+")
+
+    circleD d =
+        spacedD centerS $
+	stackD [gbg filledEllipse,gl ellipse,spacedD sqpadS d]
+      where sqpadS  = resizeS sq `compS` centerS
+	    sq (Point w h) = Point m m where m = max w h
+
+sframeD sep gs d = spacedD (vMarginS sep 0) $ frameD gs d
+
+frameD (gbg,gl) d =
+   stackD [gbg $ filler False False 1,gl frame,padD 2 d]
+
+
+nodeD' gs Nothing = staticNodeD gs
+nodeD' gs (Just d) = nodeD gs (d>0)
+
+drawTree' gs@(_,gl) depth t =
+    spacedD leftS $
+    labelD (Right t) $
+    case t of
+      Leaf l -> --hboxD' 0 [gl hLineFD,frameD gs $ g l]
+		sframeD 1 gs $ g l
+      Node n ts -> nodeD' gs depth n [drawTrees gs (fmap (+(-1)) depth) ts]
+
+drawTrees gs@(_,gl) depth ts = vboxlD' 0 $ zipWith drawSubTree [n-1,n-2..0] ts
+  where
+    n = length ts
+    drawSubTree i t = placedD (tableP' 2 Vertical 0) $
+		      boxD [fork i,line i,drawTree' gs depth t]
+    --drawSubTree i t = hboxD' 0 [fork i,drawTree' gs depth t]
+    fork 0 = gl lowerRightFD
+    fork _ = gl forkRightFD
+    line 0 = blankD 0
+    line _ = gl vLineFD
+
+
+---
+
+lowerRightFD = flex' (pP 14 10) f
+  where f (Rect p s) =
+	    [DrawLines CoordModePrevious [p+pP mw 0,pP 0 mh,pP mw 0]]
+	  where Point mw mh = rectMiddle (Rect 0 s)
+
+forkRightFD = flex' (pP 14 10) f
+  where f (Rect p s@(Point w h)) =
+	    [DrawLine (Line (p+pP mw 0) (p+pP mw h)),
+	     DrawLine (Line (p+m) (p+pP w mh))]
+	  where m@(Point mw mh) = rectMiddle (Rect 0 s)
+
+vLineFD = flex' (pP 10 1) f
+  where f (Rect p s@(Point _ h)) = [DrawLine (Line (p+pP mw 0) (p+pP mw h))]
+	  where Point mw _ = rectMiddle (Rect 0 s)
+
+hLineFD = flex' 10 f
+  where f (Rect p s@(Point w _)) = [DrawLine (Line (p+pP 0 mh) (p+pP w mh))]
+	  where Point _ mh = rectMiddle (Rect 0 s)
+
+linecolor = argKey "linecolor" "blue"
+opendepthlimit = argReadKey "opendepthlimit" (Just opendepth) -- not a good name
+opendepth = argReadKey "opendepth" 1::Int
diff --git a/Contrib/TypedSockets.hs b/Contrib/TypedSockets.hs
new file mode 100644
--- /dev/null
+++ b/Contrib/TypedSockets.hs
@@ -0,0 +1,44 @@
+-- | Type-safe network sockets, as described in
+-- [Client/Server Applications with Fudgets](http://www.altocumulus.org/Fudgets/ftp/client-server.pdf).
+module TypedSockets(TPort,tPort,tSocketServerF,TServerAddress,tServerAddress,tTransceiverF,ClientMsg(..),SocketMsg(..)) where
+
+import Fudgets
+import SocketServer
+import Debug.Trace
+--import DialogueIO hiding (IOError)
+
+newtype TPort a b = TPort Port
+
+tPort :: (Show a, Read a,Show b,Read b) => Port -> TPort a b
+tPort p = TPort p
+
+newtype TSocket t r = TSocket Socket
+newtype TLSocket t r = TLSocket LSocket
+data TServerAddress c s = TServerAddress Host (TPort c s)
+
+tServerAddress host port = TServerAddress host port
+
+tSocketServerF ::
+  (Read c, Show s) => 
+  TPort c s -> (Peer -> F s (SocketMsg c) -> F a (SocketMsg b)) ->
+  F (Int, a) (Int, ClientMsg b)
+tSocketServerF (TPort p) f = socketServerF p (\ s p -> f p (textTransceiver s))
+
+--texttransceiver :: (Show t,Read r) => Socket -> F t (SocketMsg r)
+textTransceiver s = postSP >^^=< transceiverF s >=^< pre
+  where
+    pre s = shows s "\n"
+
+    postSP = prepostMapSP eos stripEither $
+             idLeftSP (mapFilterSP reader -==- inputLinesSP)
+
+    eos "" = Left SocketEOS
+    eos s = Right s
+
+    reader s = case reads s of 
+      [(a,"")] -> Just (SocketMsg a)
+      _ -> trace ("No parse from socket: "++s) Nothing
+
+tTransceiverF :: (Show c, Read s) => TServerAddress c s -> F c (SocketMsg s)
+tTransceiverF (TServerAddress host (TPort port)) = 
+   openSocketF host port textTransceiver
diff --git a/Demos/Mandelbrot/Explore.hs b/Demos/Mandelbrot/Explore.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Mandelbrot/Explore.hs
@@ -0,0 +1,82 @@
+import AllFudgets
+import Data.Array
+import Mandelbrot
+import ZoomF
+import UserCoords
+import Control.Parallel
+--import Trace
+
+main = fudlogue $ shellF "Mandelbrot Explorer" mainF
+
+mainF =
+    allocColorScale $ \ colors ->
+    loopCompThroughLeftF (zoomF (dispF colors >=^^< preSP)) >==< resetF
+  where
+    dispF colors = nullSP>^^=<graphicsDispF >=^< replaceAllGfx . image colors
+    resetF = const area0>^=<buttonF "Reset"
+    preSP = putSP area0 $ mapstateSP zoom area0
+    zoom area = either zoom reset
+      where
+        reset area' = new area'
+	zoom msg =
+	  case msg of
+	    ZoomIn s p  -> new (zoomin s p area)
+	    ZoomOut s p -> new (zoomout s p area)
+	    ZoomRect size (Rect p s) ->
+	      if s =.> 2
+	      then new (zoomrect (size,area) p (p+s))
+	      else same
+	    _ -> same
+	same = (area,[])
+	new area' = (area',[area'])
+
+--sizeF = "Size:" `labLeftOfF` startupF [100] intInputF
+
+image :: Array Int Pixel -> Area -> Drawing nothing FlexibleDrawing
+image grays area = atomicD (FlexD 700 False False drawfunc)
+  where
+    drawfunc (Rect p size0@(Point w0 h0)) =
+        stripes 5 (CreatePutImage (Rect p size) zPixmap pixels)
+      where
+	w = min w0 h0
+	size = diag w -- keep it square
+	pixels = {-parallel-} [grays!g (Point ix iy) | iy <- [0..w-1], ix<-[0..w-1]]
+	g = pickColor . mandelbrot . userp (size,area)
+	pickColor z = z `mod` colorCount
+	rw = real w
+
+-- Color department
+
+-- We interpolate a scale of colors from two specified end colors
+allocColorScale return =
+    allocNamedColor defaultColormap color1 $ \ (Color _ rgb1) ->
+    allocNamedColor defaultColormap color2 $ \ (Color _ rgb2) ->
+    conts (allocColorPixelF defaultColormap) (rgbs rgb1 rgb2) $
+    return . listArray (0,high)
+  where
+    rgbs rgb1 rgb2 = [mixRGB rgb1 rgb2 i | i<-[0..high]]
+    high = colorCount-1
+    mixRGB (RGB r1 g1 b1) (RGB r2 g2 b2) k = RGB (m r1 r2) (m g1 g2) (m b1 b2)
+      where m i1 i2 = (i1*(high-k) + i2*k) `div` high
+
+colorCount = argReadKey "colorcount" 16 :: Int
+color1 = argKey "color1" "navyblue"
+color2 = argKey "color2" "white"
+
+-- Extra
+
+-- stripes splits one big CreatePutImage command into a number of smaller
+-- so you don't have wait for the entire image to be computed before you
+-- can see anything.
+stripes sh dcmd@(CreatePutImage (Rect p (Point w h)) fmt pxls) =
+  if h<=sh
+  then [dcmd]
+  else let rect' = Rect (p+(Point 0 sh)) (Point w (h-sh))
+	   (pxls1,pxls2) = splitAt (w*sh) pxls
+           ss = stripes sh (CreatePutImage rect' fmt pxls2)
+       in par ss $ par (pxls1==pxls1) $
+          CreatePutImage (Rect p (Point w sh)) fmt pxls1 :
+          ss
+
+parallel [] = []
+parallel xxs@(x:xs) = seq (parallel xs) $ par x xxs
diff --git a/Demos/Mandelbrot/Mandelbrot.hs b/Demos/Mandelbrot/Mandelbrot.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Mandelbrot/Mandelbrot.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE CPP #-}
+module Mandelbrot where
+--import UnsafePerformIO(unsafePerformIO)
+
+area0 = ((-2.0,2.0),(-2.0,2.0))
+
+#if 0
+-- The code generated by GHC is about as fast as this:
+mandelbrot :: (Double,Double) -> Int
+mandelbrot (x0,y0) =
+  unsafePerformIO $
+  _casm_ ``
+    {int n=0;
+    double x0=%0,y0=%1,x=0,y=0;
+    while(n<200 && x*x+y*y<=4) n++,x=x*x-y*y+x0,y=2*x*y+y0;
+    %r=n;
+    };'' x0 y0
+#else
+
+mandelbrot :: (Double,Double) -> Int
+mandelbrot (x0,y0) = m 0 0 0
+  where m :: Int -> Double -> Double -> Int
+        m n x y = if sqabs x y<= 4 && n< 1024
+		  then m (n+1) (x*x-y*y+x0) (2*x*y+y0)
+		  else n
+
+	sqabs :: Double -> Double -> Double
+	sqabs x y = x*x+y*y
+
+#endif
diff --git a/Demos/SpaceInvaders/BitmapOps.hs b/Demos/SpaceInvaders/BitmapOps.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/BitmapOps.hs
@@ -0,0 +1,44 @@
+module BitmapOps(doubleBM,explodeBM,bm,Bitmap(..),E(..),Size,Byte) where
+--import AllFudgets(BitmapData(..),Point(..),Size)
+--import Data.List.Split(chunksOf)
+
+data Bitmap = Bitmap Size [Byte]
+data E = E Size [[Bit]] deriving Eq
+type Bit = Bool
+type Byte = Int
+type Size = (Int,Int)
+
+doubleBM = implodeE . doubleE . explodeBM
+
+doubleE (E (w,h) rows) = E (2*w,2*h) (double (map double rows))
+
+double = foldr (\x r->x:x:r) []
+
+{-
+instance Show E where
+  show (E _ rows) = unlines [[".*"!!fromEnum b|b<-row]|row<-rows]
+  showList = (++) . unlines . map show
+-}
+
+explodeBM (Bitmap s@(w,h) bytes) = E s rows
+  where
+    b = (w+7) `div` 8
+    rows = map (take w . concatMap explode) (chunksOf b bytes)
+
+implodeE (E s@(w,h) rows) = Bitmap s bytes
+   where
+     bytes = concatMap (map implode . chunksOf 8) rows
+
+implode = foldr (\b r->fromEnum (b::Bit)+2*r) 0
+
+explode = take 8.expl
+  where
+    expl n = (n `mod` 2 /= 0):expl (n `div` 2)
+
+bm w h = Bitmap (w,h)
+
+---
+
+chunksOf n [] = []
+chunksOf n xs = xs1:chunksOf n xs2
+  where (xs1,xs2) = splitAt n xs
diff --git a/Demos/SpaceInvaders/GUI.hs b/Demos/SpaceInvaders/GUI.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/GUI.hs
@@ -0,0 +1,184 @@
+module GUI(Draw(..),HasSize(..),PlacedPict,pp,clear,clearpm,clearRect,wDraw,
+           Pict,GCId,objGC,readPict,rectangles,text,
+           overlaps,diffRect,message,Move(..),Rect(..),Point(..),pP,lL,Drawing,
+           line2rect,inRect,rR,hboxD,atomicD,Click,Tick,
+           argReadKey,reactiveSP,
+           putLivesMkc,G,putGUI,putsGUI,putLives,putScore,getG,
+	   spaceF,spaceF',--nullG,
+           shotColor, shelterColor, ufoColor, readObjPict,readObjPicts,
+           bmScale,spaceSize,spaceWidth,spaceHeight
+           ) where
+import Control.Applicative
+import AllFudgets hiding (draw,wDraw,size,state,rect,put)
+import ReactiveF
+import ReadPic
+import InvaderTypes
+import Metrics
+
+{-
+type G i o = K i o
+
+nullG = nullK
+putLives l = putK (High (Left l))
+putScore s = putK (High (Right s))
+putGUI gfx = putK (Low gfx)
+putsGUI gfx = putsK (map Low gfx)
+-}
+type G i o = KSP i o
+
+--nullG = nullSP
+putLivesMkc _ l = toMkc $ putSP (High (Left l))
+putLives _ l = put (High (Left l))
+putScore s = put (High (Right s))
+putGUI gfx = put (Low gfx)
+putsGUI gfx = mapM_ (put . Low) gfx
+
+spaceF' = spaceF
+
+m = if argFlag "1x" False then metrics1 else metrics2
+
+spaceF initK playK =
+    windowF startcmds (changeBg "black" (K playKSP)) >==<idRightF tickF
+  where
+    playKSP = unMk (initK m) (\ w0 ->playK m w0 `serCompSP` getGSP)
+    
+    startcmds = [layoutRequestCmd (plainLayout (spaceSize m) True True),
+                 XCmd $ ChangeWindowAttributes [CWEventMask eventmask]]
+    eventmask = [KeyPressMask,KeyReleaseMask,
+                 ButtonPressMask,ButtonReleaseMask,
+		 LeaveWindowMask,EnterWindowMask,ExposureMask]
+
+    tickF = startupF [False] (timerF>=^<pre)
+      where
+        pre True = Nothing
+	pre False = Just (dt,dt)
+
+dt = argReadKey "dt" 20::Int
+
+--------------------------------------------------------------------------------
+
+getGSP = getG $ flip putSP getGSP
+
+getG return = loop
+  where
+    loop = getSP (message low high)
+
+    high = return . High
+
+    retLow = return . Low
+
+    low (XEvt ev) = event ev
+    low _ = loop
+
+    event ev =
+      case ev of
+        Expose r 0     -> retLow Redraw
+        ButtonEvent {} -> btn (type' ev) (button ev)
+        KeyEvent    {} -> key (type' ev) (keySym ev)
+        _              -> loop
+
+    btn Pressed (Button 2) = retLow (Key Fire Down)
+    btn pressed (Button 1) = updown pressed MoveLeft
+    btn pressed (Button 3) = updown pressed MoveRight
+    btn _       _          = loop
+
+    key Pressed "space"   = retLow (Key Fire Down)
+    key pressed "Shift_L" = updown pressed MoveLeft
+    key pressed "Shift_R" = updown pressed MoveRight
+    key pressed "Left"    = updown pressed MoveLeft
+    key pressed "Right"   = updown pressed MoveRight
+    key pressed "comma"   = updown pressed MoveLeft
+    key pressed "period"  = updown pressed MoveRight
+--  key Pressed _         = putGUI bell loop
+    key _ _               = loop
+
+    updown Pressed  a = retLow (Key a Down)
+    updown Released a = retLow (Key a Up)
+    updown _        _ = loop
+
+--------------------------------------------------------------------------------
+
+data PlacedPict = PP Pict Point
+type Pict = FixedColorDrawing
+
+pp = PP
+drawPP (PP (FixCD s gcdcmds) p) = [(gc,move p dcmds)|(gc,dcmds)<-gcdcmds]
+drawIt obj = concatMap drawPP (drawing obj)
+wDraw obj = wDrawMany (drawIt obj)
+
+class Draw obj where drawing :: obj -> [PlacedPict]
+
+instance Draw obj => Draw [obj] where drawing = concatMap drawing
+
+instance (Draw o1,Draw o2) => Draw (o1,o2) where
+  drawing (o1,o2) = drawing o1++drawing o2
+
+instance (Draw o1,Draw o2,Draw o3) => Draw (o1,o2,o3) where
+  drawing (o1,o2,o3) = drawing o1++drawing o2++drawing o3
+
+--------------------------------------------------------------------------------
+unMkc op ksp = ksp'
+  where K ksp' = unMk op (\c->K (ksp c))
+
+objGC fg = Mk $ unMkc (objGC' fg)
+
+objGC' fg =
+  do ~(Just bgpixel) <- Mk (tryConvColorK "black")
+     ~(Just fgpixel) <- Mk (tryConvColorK [fg,"white"])
+     let attrs = [GCBackground bgpixel,GCForeground fgpixel]
+     Mk (wCreateGC rootGC (GCGraphicsExposures False:attrs))
+
+
+readObjPicts m (obj1,obj2)  = (,) <$> readObjPict m obj1 <*> readObjPict m obj2
+
+readObjPict m obj = flip (readPict m) obj =<< objGC (objectColor obj)
+
+readPict m gc path = pmPict gc <$> readPic' m path
+
+readPic' m path = Mk $ unMkc (readPic m path)
+
+pmPict gc pm@(PixmapImage size _) = FixCD size (copy gc pm 0)
+
+rectangles gc s rs = FixCD s [(gc,map FillRectangle rs)]
+
+text gc s = FixCD (pP (6*length s) 13) [(gc,[DrawString 0 s])] -- !!
+
+clearpm p pict = clear p (size pict)
+
+clear p size = clearRect (Rect p size) False
+
+clearRect r e = XCmd $ ClearArea r e
+
+copy gc pm p = [(gc,[copy' pm p])]
+copy' (PixmapImage size pm) p = CopyPlane (Pixmap pm) (Rect origin size) p 0
+
+bell = XCmd (Bell 0)
+
+--------------------------------------------------------------------------------
+
+class HasSize a where size :: a -> Size
+
+instance HasSize PixmapImage where size (PixmapImage s pm) = s
+instance HasSize FixedColorDrawing where size (FixCD s _) = s
+instance HasSize FixedDrawing where size (FixD s _) = s
+
+--------------------------------------------------------------------------------
+
+objectColor obj =
+  case obj of
+    Vader r    _ -> vaderColor r
+    VExplode r   -> vaderColor r
+    VShot      _ -> vshotColor
+    Base         -> baseColor
+    Explode      -> baseColor
+    Ufo          -> ufoColor
+
+baseColor    = argKey "baseColor"    "cyan"
+shotColor    = argKey "shotColor"    "lavender"
+vshotColor   = argKey "vshotColor"   "orange"
+shelterColor = argKey "shelterColor" "yellow"
+ufoColor     = argKey "ufoColor"     "grey"
+
+vaderColor r = argKey ("vader"++show (rowNum r)++"Color")  (rowColor r)
+
+rowColor r = case r of R1-> "blue"; R2 -> "green"; R3 -> "red"
diff --git a/Demos/SpaceInvaders/InvaderTypes.hs b/Demos/SpaceInvaders/InvaderTypes.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/InvaderTypes.hs
@@ -0,0 +1,18 @@
+module InvaderTypes where
+
+data GEvent = Redraw | Key Action UpDown
+data Action = MoveLeft | MoveRight | Fire
+data UpDown = Up | Down
+
+data Phase = A | B  deriving (Eq,Show)
+data Row = R1 | R2 | R3 deriving (Eq,Enum,Show)
+
+rows = [R1,R2,R3]
+phases f = (f A,f B)
+
+rowNum :: Row -> Int
+rowNum = succ . fromEnum
+
+data Object = Vader Row Phase | VExplode Row | VShot Phase
+            | Base | Explode | Ufo
+            deriving (Eq,Show)
diff --git a/Demos/SpaceInvaders/MainF.hs b/Demos/SpaceInvaders/MainF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/MainF.hs
@@ -0,0 +1,34 @@
+module MainF where
+import Fudgets
+import AllFudgets(toggleButtonF')
+import ScoreF
+
+--{- 
+mainF worldF = nameLayoutF layout spaceInvadersF
+  where
+    layout = vBoxNL' 2 [a s,w,hBoxNL [l,n,p]]
+      where
+        [w,n,p,l,s] = map leafNL ["w","n","p","l","s"]
+	a = marginHVAlignNL 0 aRight aTop
+
+    spaceInvadersF = outF>==<nameF "w" worldF>==<inF
+
+    inF = nameF "p" pauseF>+<nameF "n" (buttonF "New")
+    pauseF = toggleButtonF' (setKeys [([Control],"p")]) "Pause"
+
+    outF = nameF "l" livesF >+< nameF "s" scoreF
+
+    livesF = displayF' (setBgColor "black" . setFgColor "white")
+--}
+{-
+mainF worldF = spaceInvadersF
+  where
+    spaceInvadersF = vBoxF (outF>==<worldF (Point 480 390)>==<inF)
+
+    inF = swapEither >^=< hBoxF (buttonF "New" >+< pauseF)
+    pauseF = toggleButtonF' (setKeys [([Control],"p")]) "Pause"
+
+    outF = hBoxF (livesF >+< scoreF)
+
+    livesF = displayF' (setBgColor "black" . setFgColor "white")
+--}
diff --git a/Demos/SpaceInvaders/Metrics.hs b/Demos/SpaceInvaders/Metrics.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/Metrics.hs
@@ -0,0 +1,16 @@
+module Metrics where
+import Pics as P2
+import Pics1 as P1
+import BitmapOps(Bitmap)
+import InvaderTypes(Object)
+import AllFudgets
+
+metrics1 = M 1 (pP 240 195) P1.pics
+metrics2 = M 2 (scaleP 2 (spaceSize metrics1)) P2.pics
+
+data Metrics = M { bmScale::Int, spaceSize::Size, pics::Object->Bitmap }
+
+spaceWidth = xcoord . spaceSize
+spaceHeight = ycoord . spaceSize
+
+scaleP k (Point x y) = Point (k*x) (k*y)
diff --git a/Demos/SpaceInvaders/Pics.hs b/Demos/SpaceInvaders/Pics.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/Pics.hs
@@ -0,0 +1,39 @@
+module Pics where
+import BitmapOps(doubleBM,bm)
+import Pics1
+import InvaderTypes
+
+bmScale = 2 :: Int
+
+pics obj =
+  case obj of
+    Base       -> doubleBM base1
+    Explode    -> explode2
+    Ufo        -> spacer2
+    VExplode _ -> vexplode2
+    _          -> doubleBM (Pics1.pics obj)
+
+explode2 = bm 30 20 explode2_bits
+explode2_bits = [
+ 0x00,0xc0,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0xf0,0x03,0x00,0x00,0xf0,0x03,
+ 0x00,0x00,0xf0,0x03,0x00,0x00,0xf0,0x03,0x00,0x00,0xfc,0x0f,0x00,0x00,0xfc,
+ 0x0f,0x00,0xfc,0xff,0xff,0x0f,0xfc,0xff,0xff,0x0f,0x07,0x00,0x00,0x38,0xf3,
+ 0x00,0x00,0x33,0x33,0x01,0x80,0x33,0x33,0x01,0xc0,0x30,0x33,0x39,0xce,0x30,
+ 0xf3,0x6c,0xdb,0x31,0x33,0x6c,0xdb,0x30,0x33,0x38,0xce,0x30,0xff,0xff,0xff,
+ 0x3f,0xff,0xff,0xff,0x3f]
+
+spacer2 = bm 32 16 spacer2_bits
+spacer2_bits = [
+ 0x00,0xf0,0x0f,0x00,0x00,0xf0,0x0f,0x00,0x00,0xff,0xff,0x00,0x00,0xff,0xff,
+ 0x00,0xc0,0xff,0xff,0x03,0xc0,0xff,0xff,0x03,0xf0,0xff,0xff,0x0f,0xf0,0xff,
+ 0xff,0x0f,0x38,0xcf,0xf3,0x1c,0x38,0xcf,0xf3,0x1c,0xfc,0xff,0xff,0x3f,0xfc,
+ 0xff,0xff,0x3f,0xf0,0x03,0xc0,0x0f,0xf0,0x03,0xc0,0x0f,0xc0,0x00,0x00,0x03,
+ 0xc0,0x00,0x00,0x03]
+ 
+vexplode2 = bm 28 16 vexplode2_bits
+vexplode2_bits = [
+ 0x00,0x20,0x00,0x00,0x00,0x24,0x01,0x00,0x00,0xa8,0x10,0x00,0xc0,0xa8,0x0c,
+ 0x00,0x00,0x03,0x02,0x00,0x60,0x00,0x60,0x00,0x00,0x00,0x00,0x00,0xf0,0x00,
+ 0xf0,0x00,0x00,0x00,0x00,0x00,0x80,0x00,0x10,0x00,0x60,0x04,0x64,0x00,0x00,
+ 0x53,0x09,0x00,0xc0,0x50,0x11,0x00,0x00,0x48,0x02,0x00,0x00,0x40,0x00,0x00,
+ 0x00,0x00,0x00,0x00]
diff --git a/Demos/SpaceInvaders/Pics1.hs b/Demos/SpaceInvaders/Pics1.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/Pics1.hs
@@ -0,0 +1,93 @@
+module Pics1 where
+import BitmapOps(bm)
+import InvaderTypes
+
+bmScale = 1 :: Int
+
+pics obj =
+  case obj of
+    Base       -> base1
+    Explode    -> explode1
+    Ufo        -> spacer1
+    VShot A    -> sperma1
+    VShot B    -> spermb1
+    Vader R1 A -> vader1a1
+    Vader R1 B -> vader1b1
+    Vader R2 A -> vader2a1
+    Vader R2 B -> vader2b1
+    Vader R3 A -> vader3a1
+    Vader R3 B -> vader3b1
+    VExplode _ -> vexplode1
+
+{-
+Copyright notice:
+
+This is mine.  I'm only letting you use it.  Period.  Feel free to rip off
+any of the code you see fit, but have the courtesy to give me credit.
+Otherwise great hairy beasties will rip your eyes out and eat your flesh
+when you least expect it.
+
+Jonny Goldman <jonathan@think.com>
+
+Wed May  8 1991
+-}
+
+--pics1 = [base1,explode1,spacer1,sperma1,spermb1,
+--         vader1a1,vader1b1,vader2a1,vader2b1,vader3a1,vader3b1,vexplode1]
+
+base1 = bm 15 10 base1_bits
+base1_bits = [
+   0x80, 0x00, 0xc0, 0x01, 0xc0, 0x01, 0xe0, 0x03, 0xfe, 0x3f, 0xff, 0x7f,
+   0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f]
+
+explode1 = bm 15 10 explode1_bits
+explode1_bits = [
+   0x80, 0x00, 0xc0, 0x01, 0xc0, 0x01, 0x20, 0x02, 0x3e, 0x3e, 0x0d, 0x50,
+   0x15, 0x48, 0x6d, 0x5b, 0x65, 0x4b, 0xff, 0x7f]
+
+spacer1 = bm 16 8 spacer1_bits
+spacer1_bits = [
+   0xc0, 0x03, 0xf0, 0x0f, 0xf8, 0x1f, 0xfc, 0x3f, 0xb6, 0x6d, 0xff, 0xff,
+   0x1c, 0x38, 0x08, 0x10]
+
+sperma1 = bm 3 7 sperma1_bits
+sperma1_bits = [0x02, 0x01, 0x02, 0x04, 0x02, 0x01, 0x02]
+
+spermb1 = bm 3 7 spermb1_bits
+spermb1_bits = [0x02, 0x04, 0x02, 0x01, 0x02, 0x04, 0x02]
+
+vader1a1 = bm 10 8 vader1a1_bits
+vader1a1_bits = [
+   0x30, 0x00, 0x78, 0x00, 0xfc, 0x00, 0xb6, 0x01, 0xfe, 0x01, 0xb4, 0x00,
+   0x02, 0x01, 0x84, 0x00]
+
+vader1b1 = bm 10 8 vader1b1_bits
+vader1b1_bits = [
+   0x30, 0x00, 0x78, 0x00, 0xfc, 0x00, 0xb6, 0x01, 0xfe, 0x01, 0xb4, 0x00,
+   0x48, 0x00, 0x84, 0x00]
+
+vader2a1 = bm 12 8 vader2a1_bits
+vader2a1_bits = [
+   0x08, 0x01, 0x90, 0x00, 0xf8, 0x01, 0x6c, 0x03, 0xfe, 0x07, 0xfa, 0x05,
+   0x0a, 0x05, 0x90, 0x00]
+
+vader2b1 = bm 12 8 vader2b1_bits
+vader2b1_bits = [
+   0x08, 0x01, 0x92, 0x04, 0xfa, 0x05, 0x6e, 0x07, 0xfc, 0x03, 0xf8, 0x01,
+   0x08, 0x01, 0x04, 0x02]
+
+vader3a1 = bm 14 8 vader3a1_bits
+vader3a1_bits = [
+   0xe0, 0x01, 0xfc, 0x0f, 0xfe, 0x1f, 0xce, 0x1c, 0xfe, 0x1f, 0x38, 0x07,
+   0xcc, 0x0c, 0x18, 0x06]
+
+vader3b1 = bm 14 8 vader3b1_bits
+vader3b1_bits = [
+   0xe0, 0x01, 0xfc, 0x0f, 0xfe, 0x1f, 0xce, 0x1c, 0xfe, 0x1f, 0x38, 0x07,
+   0xcc, 0x0c, 0x06, 0x18]
+
+vexplode1 = bm 14 8 vexplode1_bits
+vexplode1_bits = [
+   0x48, 0x04, 0x50, 0x02, 0x00, 0x00, 0x06, 0x18, 0x10, 0x02, 0x88, 0x04,
+   0x80, 0x00, 0x00, 0x00]
+
diff --git a/Demos/SpaceInvaders/ReadPic.hs b/Demos/SpaceInvaders/ReadPic.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/ReadPic.hs
@@ -0,0 +1,16 @@
+module ReadPic(readPic,readPics,bmScale) where
+import Control.Applicative
+import AllFudgets
+--import Pics
+import BitmapOps
+import Metrics
+
+readPics m (file1,file2) = (,) <$> readPic m file1 <*> readPic m file2
+
+readPic m name =
+  case pics m name of
+    Bitmap (w,h) bytes ->
+      do bmr <- Mk (bitmapFromData (BitmapData (Point w h) Nothing bytes))
+         case bmr of
+           BitmapReturn size _ pm -> return (PixmapImage size pm)
+           BitmapBad -> error ("Can't read bitmap "++show name)
diff --git a/Demos/SpaceInvaders/ScoreF.hs b/Demos/SpaceInvaders/ScoreF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/ScoreF.hs
@@ -0,0 +1,20 @@
+module ScoreF where
+import Fudgets
+import AllFudgets(appStorageF)
+
+scoreF = placerF autoP (currentF>*<highF)>=^^<sumSP
+
+highF = dispF "High:" >==<
+        loopThroughRightF (toBothF >=^^< maxSP >=^< stripEither) storageF
+  where
+    storageF = appStorageF "SpaceInvaders.highscore" 0
+
+currentF = dispF "Score:"
+
+sumSP = accSP (\s->maybe 0 (s+)) 0
+maxSP = accSP max 0
+
+accSP f = mapstateSP (\s x->let x'=f s x in (x',[x']))
+
+dispF lbl = lbl `labLeftOfF` intDispF' custom
+  where custom = setFgColor "white" . setBgColor "black" . setInitSize 999999
diff --git a/Demos/SpaceInvaders/SpaceInvaders2.hs b/Demos/SpaceInvaders/SpaceInvaders2.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/SpaceInvaders2.hs
@@ -0,0 +1,8 @@
+
+import System.Random(newStdGen)
+import Fudgets
+import WorldF
+import MainF
+
+main = do g <- newStdGen
+          fudlogue (shellF "Space Invaders" (mainF (worldF g)))
diff --git a/Demos/SpaceInvaders/WorldF.hs b/Demos/SpaceInvaders/WorldF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/SpaceInvaders/WorldF.hs
@@ -0,0 +1,490 @@
+-- | The entire world, implemented as a single fudget, instead of one fudget
+-- per object in the world.
+module WorldF(worldF,worldF') where
+import System.Random
+import Control.Applicative
+import Control.Monad(when)
+import Data.List(nub)
+import ReactionM
+import GUI
+import InvaderTypes hiding (Phase(..))
+
+data World    = W {rnd::StdGen, shelters::Shelters, base::Base, ufo::Ufo,
+                   torpedo::Torpedo, vshots::VShots, invaders::Invaders}
+data Base     = B {bPict,exbPict::Pict, bPos::Point, lives::Int, bSpeed::Speed}
+              | ExB {bPict,exbPict::Pict, bPos::Point, lives::Int, exbAge::Int}
+--data Shelters = Sh [PlacedPict] -- hmm
+type Shelters = [Shelter]
+data Shelter  = Sh {shGC::GCId,shBR::Rect,shRs::[Rect]}
+data Torpedo  = T Pict (Maybe Point)
+data Ufo      = U Pict GCId UfoState
+data UfoState = Wait Ticks | Moving Score Speed Point | Hit Ticks Score Point
+data VShots   = V Speed (Pict,Pict) [Point]
+data VShot    = V1 Speed (Pict,Pict) Point
+data Invaders = Invs {invs::[Invader], level::Int, step::Speed, delay::Ticks}
+data Invader  = Inv {invPict::(Pict,Pict),exvPict::Pict,
+                     invScore::Int,invPos::Point}
+              | Exv {exvPict::Pict, invPos::Point} -- exploded
+type ExVader  = Pict
+type Speed = Int
+type Ticks = Int
+type Score = Int
+
+modBase = update . updateBase
+updateBase f w@W{base=b} = w{base=f b}
+--updateTorpedo f =w@W{torpedo=t} = w{torpedo=f b}
+
+exBase (B pm ex p l v) = ExB pm ex p l 0
+exBase base = base
+
+alive w = case base w of B {} -> True; _-> False
+
+spare pm n = if n>=0
+             then hboxD (replicate n (atomicD (Right pm)))
+             else atomicD (Left "Game over!")
+
+--------------------------------------------------------------------------------
+
+worldF g = spaceF (initWorldK g) objectsK
+worldF' g = spaceF' (initWorldK g) objectsK
+
+--------------------------------------------------------------------------------
+
+initWorldK g m =
+  W g <$> initSheltersK m <*> initBaseK m <*> initUfoK m
+      <*> initTorpedoK m <*> initVShotsK m <*> initInvadersK m
+
+initSheltersK metrics =
+    do gc <- objGC shelterColor
+       let sh p = Sh gc (Rect p s) (move p shape)
+       return $ map sh ps
+  where
+    s@(Point w h) = shelterSize metrics
+    m = (spaceWidth metrics -3*3-7*w) `div` 2
+    y = spaceHeight metrics-margin metrics-3*h
+    xs = [m+2*(w+3)*i|i<-[0..3]]
+    ps = [Point x y|x<-xs]
+
+    shape = [v x roofy h|x<-[0..roofx-1]]++
+            [v x 0     h|x<-[roofx..legx-1]]++
+            [v x 0 (h-legy)|x<-[legx..w-legx-1]]++
+            [v x 0     h|x<-[w-legx..w-roofx-1]]++
+            [v x roofy h|x<-[w-roofx..w-1]]
+    v x y1 y2 = rR x y1 1 (y2-y1)
+    legx = w `div` 3 - 1
+    legy = h `div` 4
+    roofy = legy
+    roofx = w `div` 10
+
+initBaseK m =
+  do pict <- readObjPict m Base
+     ex   <- readObjPict m Explode
+     let startpos = (baseStartPos m pict){xcoord= -width pict}
+         lives = 3
+     putLivesMkc m (spare pict lives)
+     return (ExB pict ex startpos (lives+1) 50)
+
+baseStartPos m pict = Point (margin m) (spaceHeight m-height pict-margin m)
+
+initUfoK m =
+  do gc <- objGC ufoColor
+     pict <- readPict m gc Ufo
+     return $ U pict gc (Wait ufoDelay)
+  
+initTorpedoK m =
+  do gc <- objGC shotColor
+     let s = torpedoSize m
+         pict = rectangles gc s [Rect 0 s]
+     return (T pict Nothing)
+
+initVShotsK m = flip (V (vshotDy m)) [] <$> readObjPicts m (phases VShot)
+
+initInvadersK m =
+    invaders <$> mapM (readObjPicts m . phases . Vader) rows
+             <*> mapM (readObjPict m . VExplode) rows
+  where
+    invaders is es = Invs invs startLevel dx0 16
+      where
+        invs = zipWith centerI (concatMap row [i3,i3,i2,i2,i1]) places 
+        [i1,i2,i3] = zip3 is es [30,20,10]
+    row = replicate hcount
+    places = [Point (margin m+hsep*x) (margin m+vsep*y+offset)|
+                 y<-[5,4..1],x<-[0..hcount-1]]
+    offset = invHeight m * min 8 startLevel
+
+    centerI (pm@(pm1,_),ex,score) p =
+        Inv pm ex score (p + pP ((invWidth m-width pm1) `div` 2) 0)
+    hsep = invWidth m+2*bmScale m
+    vsep = invHeight m+4*bmScale m
+    dx0 = invDx m
+
+--------------------------------------------------------------------------------
+
+type Output = Either Bases (Maybe Score)
+type Input = Either Tick Click
+type Bases = Drawing () Pict
+
+--getGs = toMs getG
+--putLivesMs l = toMsc (putLives l)
+--putScoreMs s = toMsc (putScore s)
+--putGUIMs g = toMsc (putGUI g)
+--puatsGUIMs gs = toMsc (putsGUI gs)
+
+--objectsK :: Size -> World -> Mk (G Input Output) ()
+objectsK m world0 = reactiveSP (objectsKs m world0) world0
+
+--objectsKs :: Size -> World -> Ms (G Input Output) World noreturn
+objectsKs m world0 = playK
+  where
+    playK = message low high
+      where
+        high = either (const tickK) (const newK)
+
+        newK = do set world1
+                  putGUI (clearRect (Rect 0 (spaceSize m)) True)
+                  putScore Nothing
+                  b <- field base
+                  putLives m (spare (bPict b) (lives b-1))
+          where
+            world1 = world0{invaders=invs1}
+            invs1 = invs0{invs=[],delay=100}
+            invs0 = invaders world0
+
+        low ev =
+          case ev of
+	    Redraw        -> draw =<< get
+            Key Fire Down -> fireTorpedo
+            Key a    p    -> modBase (accelerate p a)
+
+    accelerate pressed button b@ExB{} = b
+    accelerate pressed button b@B{bSpeed=v} = b{bSpeed=v'}
+      where
+	v'   = case pressed of Down -> bdir ; _ -> 0
+	bdir = case button of
+                  MoveLeft -> -baseDx m
+                  MoveRight -> baseDx m
+                  _ -> 0
+      
+
+    tickK =
+      do tickInvadersK
+         tickUfoK
+         W g shelters base ufo torpedo vshots invaders <- get
+         base' <- tickBaseK base
+         (torpedo',invaders',shelters',ufo')<-
+                tickTorpedoK torpedo invaders shelters ufo
+         set (W g shelters' base' ufo' torpedo' vshots invaders')
+         tickVShotsK vshots base'
+
+    tickInvadersK =
+      do state@W{invaders=inv} <- get
+         let t = delay inv-1
+         case t of
+           0 -> do let invcnt = length (invs inv)
+                       l = level inv+1
+                       offset = pP 0 (invHeight m*(min 8 l-startLevel))
+                       inv' = if invcnt==0
+                              then move offset (invaders world0){level=l}
+                              else inv{delay=(invcnt+6) `div` 4}
+                   set state{invaders=inv'}
+                   moveInvadersK
+                   update fireVShot
+           _ -> do let inv' = inv{delay=t}
+                   set state{invaders=inv'}
+
+    --tickBaseK :: Base -> Ms (G hi (Either Bases x)) s Base
+    tickBaseK b@(ExB pm ex p@(Point x y) l t) =
+        case t of
+          50 -> putGUI (clearpm p pm) >> return b'{bPos=Point (-width pm) y}
+          95  | l>0 -> putLives m (spare pm (l-2)) >> return b'
+          100 | l>1 -> do let b' = B pm ex (baseStartPos m pm) (l-1) 0
+                          draw b'
+                          return b'
+          _ -> return b'
+      where
+        b' = b{exbAge=t+1}
+        new = B pm ex
+    tickBaseK b@(B pm ex p@(Point x y) l v) =
+      case v of
+        0 -> return b
+	_ -> putGUI (clearpm p pm) >> draw b' >> return b'
+	  where b' = B pm ex p' l v
+	        p' = Point x' y
+                x' = min (spaceWidth m-margin m-width pm) (max (margin m) (x+v))
+
+    tickUfoK =
+      do state@W{rnd=g,ufo=u@(U pm gc s)} <- get
+         let ufoWidth = xcoord (size pm)
+         case s of
+           Wait 0 -> do let u'=U pm gc (Moving score dx (pP x0 (margin m)))
+                            score = 50*n
+                            (x0,dx) = if rev
+                                      then (spaceWidth m,-ufoDx m)
+                                      else (-ufoWidth,ufoDx m)
+                            (n,g') = randomR (1,6) g
+                            (rev,g'') = random g'
+                        draw u'
+                        set state{rnd=g'',ufo=u'}
+           Wait t -> set state{ufo=U pm gc (Wait (t-1))}
+           Hit 0 s p -> do putGUI (clearpm p pm)
+                           set state{ufo=U pm gc (Wait ufoDelay)}
+           Hit t s p -> set state{ufo=U pm gc (Hit (t-1) s p)}
+           Moving s dx p ->
+             if dx>0 && xcoord p>=spaceWidth m ||
+                dx<0 && xcoord p< -ufoWidth
+             then do putGUI (clearpm p pm)
+                     set state{ufo=U pm gc (Wait ufoDelay)}
+             else do let p' = p + pP dx 0
+                         u' = U pm gc (Moving s dx p')
+                     putGUI (clearpm p pm)
+                     draw u'
+                     set state{ufo=u'}
+
+    tickTorpedoK t@(T pm optp) inv sh ufo = 
+      case optp of
+        Nothing -> return (t,inv,sh,ufo)
+	Just p@(Point x y) ->
+	  if y<torpedoDy m
+	  then putGUI (clearpm p pm) >> return (T pm Nothing,inv,sh,ufo)
+	  else case p `invHit` inv of
+	         (inv1,Inv (p1,_) ex score ip:inv2) ->
+		     do putsGUI [clear p (torpedoSize m), clearpm ip p1]
+                        draw exv
+                        putScore (Just score)
+		        return (T pm Nothing,inv{invs=inv'},sh,ufo)
+                   where
+                     inv' = inv1++exv:inv2
+                     exv = Exv ex ip
+		 _ -> case shelterHit' sh r d of
+                        Just sh' -> do putGUI (clearRect d False)
+                                       return (T pm Nothing,inv,sh',ufo)
+                        _ -> case Rect p (size pm) `ufoHit` ufo of
+                               Just ufo'@(U upm _ (Hit _ score up)) ->
+                                 do putGUI (clearpm p pm)
+                                    putGUI (clearpm up upm)
+                                    draw ufo'
+                                    putScore (Just score)
+                                    return (T pm Nothing,inv,sh,ufo')
+                               _ -> do let t' = move (pP 0 (-torpedoDy m)) t
+                                       putGUI (clearpm p pm)
+                                       draw t'
+                                       return (t',inv,sh,ufo)
+                    where s = size pm
+                          r = Rect (p+pP 0 (torpedoDy m `div` 2)) s
+                          d = Rect (p-pP 1 0) (s+pP 2 0)
+
+    r `ufoHit` U pm gc (Moving s dx p)
+               | overlaps r (Rect p (size pm)) = Just (U pm gc (Hit 100 s p))
+    r `ufoHit` _  = Nothing
+
+    p `invHit` Invs{invs=is} = break isHit is
+      where
+        isHit Exv{} = False
+        isHit (Inv (p1,_) _ _ ip) = p `inRect` r
+	  where r = Rect (ip + Point 2 0) (size p1 - Point 4 0)
+
+    fireTorpedo = do a <- field alive
+                     when a $ do update fire; draw =<< field torpedo
+    
+    fire w@W{torpedo=T gc t} =
+      case t of
+        Nothing -> w{torpedo=T gc (Just (firePos m (base w)))}
+	_ -> w
+
+    fireVShot w@W{vshots=V dy pm@(p1,_) ps,invaders=Invs{invs=is},rnd=g0} =
+        if null is || length ps>5 
+        then w
+        else if r<9
+             then w{rnd=g1}
+             else w{vshots=V dy pm (p:ps),rnd=g'}
+      where
+        p = Point (x+(invWidth m-width p1) `div` 2) (y+invHeight m-3*bmScale m)
+        y = maximum [ycoord p|Inv{invPos=p}<-is,abs (xcoord p-x)<h]
+        h = invWidth m `div` 2
+        x = xs !! ix
+        xs = nub [xcoord p|Inv{invPos=p}<-is]
+        
+        (ix,g') = randomR (0,length xs-1) g1
+        (r,g1) = randomR (0,9::Int) g0
+      
+    tickVShotsK (V dy pm@(p1,_) ps) base =
+        do ps0' <- mapM moveVShot ps
+           w <- get
+           set w{vshots=V dy pm [p|Just p<-ps0']}
+      where
+        br = Rect (bPos base) (size base)
+
+        v = pP 0 dy
+        ss@(Point w h) = size p1
+
+        moveVShot p =
+            if hitBase
+            then do putGUI (clearpm p p1)
+                    let base' = exBase base
+                    draw base'
+                    modBase (const base')
+                    return Nothing
+            else do sh <- field shelters
+                    case shelterHit' sh hr dr of
+                      Just sh' -> do w<-get
+                                     set w{shelters=sh'}
+                                     putGUI (clearRect dr False)
+                                   --draw sh'
+                                     return Nothing
+                      _ -> if ycoord p' < spaceHeight m
+                           then do putsGUI [clearpm p p1,wDraw (V1 dy pm p')]
+                                   return (Just p')
+                           else do putGUI (clearpm p p1)
+                                   return Nothing
+          where
+            p' = p+v
+            sr = Rect p ss
+            hr = move (pP 0 (dy-h)) sr
+            dr = sr
+            hitBase = overlaps br sr
+
+    moveInvadersK =
+        do w@W{invaders=invs0,shelters=ss} <- get
+           let (movecmds,br',invs') = moveInvaders invs0
+           putsGUI (concat movecmds)
+           ss' <- if any (overlaps br' . shBR) ss
+                  then let shHit ss i@Inv{} = maybe ss id.shelterHit ss $ rect i
+                           shHit ss _       = ss
+                       in return $ foldl shHit ss (invs invs')
+                  else return ss
+           set w{invaders=invs',shelters=ss'}
+
+    moveInvaders (Invs is l dx dt) = (movecmds,br,Invs is' l dx' dt')
+      where
+        dt' = if null is' then 200 else if off_bottom then -1 else dt
+        (dx',d) = if dx>0 && off_right || dx<0 && off_left
+	          then (-dx,pP 0 (invDy m))
+		  else (dx,pP dx 0)
+	(xs,ys) = unzip [(x,y)|Inv{invPos=Point x y}<-is]
+	off_left = min_x < margin m
+	off_right = max_x > spaceWidth m-margin m
+        off_bottom = max_y > spaceHeight m-margin m
+        min_x = minimum xs
+        min_y = minimum ys
+        max_x = maximum xs + invWidth m
+        max_y = maximum ys + invHeight m
+        br = if null xs
+             then Rect 0 0
+             else move d $ line2rect (lL min_x min_y max_x max_y)
+
+	(movecmds,is0') = unzip (map moveInvader is)
+        is' = [i|Just i<-is0']
+
+        moveInvader (Exv p1 p) = ([clearpm p p1],Nothing)
+	moveInvader (Inv (p1,p2) ex s p) =
+	    case ycoord d of
+	      0 -> ([wDraw i'],Just i')
+	      _ -> ([clearpm p p1,wDraw i'],Just i')
+	  where
+	    i' = Inv (p2,p1) ex s (p+d)
+
+shelterHit ss r = shelterHit' ss r r
+
+shelterHit' ss r d =
+  case break (hitSh r) ss of
+    (pps1,Sh gc br rs:pps2) ->
+        if any (overlaps r) rs && rs' /= rs
+        then if null rs'
+             then Just (pps1++pps2)
+             else Just (pps1++Sh gc br rs':pps2)
+        else Nothing
+      where
+        rs' = concat [diffRect sr d|sr<-rs]
+    _ -> Nothing
+
+hitSh r (Sh _ br _) = overlaps r br
+
+--------------------------------------------------------------------------------
+
+draw obj = putGUI (wDraw obj)
+
+instance Draw World where
+  drawing w =drawing (ufo w,(shelters w,base w,torpedo w),(vshots w,invaders w))
+
+--instance Draw Shelters where
+--  drawing (Sh pps) = pps
+
+instance Draw Shelter where
+  drawing (Sh gc (Rect p s) rs) = [pp (rectangles gc s rs) 0]
+
+instance Draw Base where
+  drawing (B pm ex p _ _) = [pp pm p]
+  drawing (ExB pm ex p _ _) = [pp ex p]
+
+instance Draw Torpedo where
+  drawing (T _ Nothing) = []
+  drawing (T pm (Just p)) = [pp pm p]
+
+instance Draw Ufo where
+  drawing (U pm _  (Moving s dx p)) = [pp pm p]
+  drawing (U pm gc (Hit t s p)) = [pp (text gc (show s)) (p+pP 0 (height pm))]
+  drawing _ = []
+
+instance Draw Invaders where
+  drawing = drawing . invs
+
+instance Draw Invader where
+  drawing (Inv (pm,_) _ _ p) = [pp pm p]
+  drawing (Exv pm p) = [pp pm p]
+
+instance Draw VShots where
+  drawing (V dy pm ps) = drawing [V1 dy pm p|p<-ps]
+
+instance Draw VShot where
+  drawing (V1 dy (pm1,pm2) p) =  [pp pm p]
+    where
+      pm = if even (ycoord p `div` dy) then pm1 else pm2
+
+--------------------------------------------------------------------------------
+class HasSize a => HasRect a where rect :: a -> Rect
+
+width obj = xcoord (size obj)
+height obj = ycoord (size obj)
+
+instance HasSize Base where size = size . bPict
+instance HasRect Base where rect (B pm _ p _ _) = Rect p (size pm)
+
+--instance HasSize Torpedo where size _ = torpedoSize
+
+instance HasSize Invader where
+  size inv@Inv{invPict=(p1,_)} = size p1
+  size inv@Exv{exvPict=p1} = size p1
+
+instance HasRect Invader where
+  rect inv = Rect (invPos inv) (size inv)
+
+instance Move Base     where move v (B pm ex p l dx) = B pm ex (p+v) l dx
+instance Move Torpedo  where move v (T pm op) = T pm (move v op)
+instance Move Invaders where move v (Invs is l dx dt) = Invs (move v is) l dx dt
+instance Move Invader  where move v inv@Inv{invPos=p} = inv{invPos=move v p}
+instance Move VShots   where move v (V dy pm ps) = V dy pm (move v ps)
+
+--------------------------------------------------------------------------------
+firePos m base = bPos base + pP (width base `div` 2) (-torpedoHeight m)
+
+shelterSize m = pP (20*bmScale m) (16*bmScale m)
+
+torpedoSize m = pP 1 (torpedoHeight m)
+torpedoHeight m = 8*bmScale m
+torpedoDy m = 6*bmScale m
+
+ufoDelay = argReadKey "ufodelay" 2500
+ufoDx = bmScale
+
+vshotDy m = 2*bmScale m
+
+invHeight m = 8*bmScale m
+invWidth m = 12*bmScale m
+invDy m = 3*invHeight m `div` 4
+invDx = bmScale
+
+margin m = 5*bmScale m
+baseDx m = argReadKey "dx" (2*bmScale m-1)::Int -- base speed
+
+hcount = argReadKey "hcount" 11::Int
+startLevel = argReadKey "level" 0::Int
diff --git a/Demos/Tiles/BoardF.hs b/Demos/Tiles/BoardF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/BoardF.hs
@@ -0,0 +1,53 @@
+module BoardF(boardF) where
+
+import AllFudgets
+import DrawingF
+import Tiles
+import MyUtils
+
+boardF :: F (Either ChangeTileNo [Tile]) a
+boardF = marginHVAlignF 0 aCenter aCenter (noStretchF True True (loopLeftF ((Left >^=< gridUF) >==< gridControlF)))
+
+--left :: a -> Either a b
+--left x = Left x
+
+gridUF = (gridF,Above) >#+< updateF
+
+updateF = buttonF "update with new current tile"
+
+gridControlF :: F (Either (Either (Int, Event) Click) (Either ChangeTileNo [Tile])) 
+			(Either (Int, ChangeTile) a)
+gridControlF =
+	let startState = (sameTN, [[]|x<-[0..7]], [NoTile|x<-[0..24]])
+	    step (cn, ts, ns) m = 
+		-- cn = function to change a tile number
+		-- ts = set of rotations/reflections of current tile
+		-- ns = tile numbers associated with each grid position
+		let toGrid = Left
+		in case m of
+		-- looped back from Grid
+		    (Left (Left (n, _))) -> ((cn, ts, nns), ct nn)
+			where nn = cn (ns!!n)
+			      nns = (take n ns) ++ [nn] ++ (drop (n+1) ns)
+			      ct bt = case bt of
+				NoTile   -> []
+				TileNo t -> [toGrid (n,changeToT (ts!!t))]
+		-- looped back from Update button
+		    (Left (Right Click)) -> ((cn, ts, ns), changeAll)
+			where changeAll = [ct n | n <- [0..24]]
+			      ct n = case (ns!!n) of
+				NoTile -> toGrid (n, sameT)
+				TileNo t -> toGrid (n, changeToT (ts!!t))
+		-- from Tools
+		    (Right (Left ncn)) -> ((ncn, ts, ns), [])
+		-- from Choice
+		    (Right (Right nts)) -> ((cn, nts, ns), [])
+	in absF (mapstateSP step startState)
+
+gridF :: F (Int, ChangeTile) (Int, Event)
+gridF = 
+	let b v = drawDisplayCF (Point 50 50) v
+	    tiles = [ (x, b []) | x <- [0..24] ]
+	    layout = matrixP' 5 Horizontal 0
+	in listLF layout tiles
+
diff --git a/Demos/Tiles/ChoiceF.hs b/Demos/Tiles/ChoiceF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/ChoiceF.hs
@@ -0,0 +1,31 @@
+module ChoiceF(choiceF) where
+
+import Fudgets
+import RadioDrawF
+import Tiles
+import MyUtils
+
+choiceF = marginHVAlignF 0 aCenter aCenter (noStretchF True True choice')
+choice' = loopLeftF (throRight (radioDrawDF layout choices) >==< choiceControlF)
+
+layout = verticalP
+
+choices = [tile n | n <- [0..3]]
+
+choiceControlF :: F (Either (Int, Tile) Tile) 
+			(Either (Int, Tile) (Either Tile (Either [Tile] [Tile])))
+choiceControlF =
+	let startstate = 0
+	    step c m = 
+		let toButtons = Left
+		    toDesign = Right. Left
+		    toTools = Right. Right. Left
+		    toBoard = Right. Right. Right
+		in case m of
+			-- from Buttons
+			(Left (n, t)) -> (n, [toDesign t, toTools (setT t), 
+							toBoard (setT t)])
+			-- from Design
+			(Right t) -> (c, [toButtons (c, t), toTools (setT t),
+							toBoard (setT t)])
+	in absF (mapstateSP step startstate)
diff --git a/Demos/Tiles/DesignF.hs b/Demos/Tiles/DesignF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/DesignF.hs
@@ -0,0 +1,74 @@
+module DesignF(designF) where
+
+import AllFudgets
+import DrawingF
+import MyUtils
+import Tiles
+
+data DesignState = Init | Start Point
+
+designSize = 250
+gridNo = 10
+
+designF :: F Tile Tile
+designF = marginHVAlignF 0 aCenter aCenter (loopLeftF ((throRight padF) >==< designControlF))
+
+padF = (drawDisplayCKF (Point designSize designSize) gridlines,Above)
+		>#+< updateBF
+
+updateBF = buttonF "finished design -> current tile"
+
+designControlF :: F (Either (Either Event Click) Tile) (Either (Either ChangeTile a) Tile)
+designControlF = 
+	let startstate = ([], Init)
+	    step (c, s) m = 
+		let grid = gridlines 
+		    grow = magT dtRatio
+		    toDesign = Left. Left. changeToT
+		    toChoice = Right
+		in case m of
+			-- from the grid
+			(Left (Left (ButtonEvent _ ap _ _ Pressed (Button b)))) -> (
+				let p = snap ap 
+				in case s of
+					Init    -> ((c, Start p), [toDesign ((mark p)++(grow c))])
+					Start f -> ((newDraw, Init), [toDesign (grow newDraw)])
+						where newDraw = case b of
+							3         -> delLine x1 y1 x2 y2 c
+							otherwise -> (line x1 y1 x2 y2) ++ c
+						      Point x1 y1 = scalePoint tdRatio f
+						      Point x2 y2 = scalePoint tdRatio p )
+			-- from the update button
+			(Left (Right Click)) -> ((c, s), [toChoice c])
+			-- from Choice
+			(Right t) -> ((t, Init), [toDesign (grow t)])
+	in absF (mapstateSP step startstate)
+
+snap :: Point -> Point
+snap p = sp
+	where sp = Point sx sy
+	      sx = ((px+halfGridSize) `div` gridSize) * gridSize
+	      sy = ((py+halfGridSize) `div` gridSize) * gridSize
+	      Point px py = p 
+
+delLine _ _ _ _ [] = [] 
+delLine x1 y1 x2 y2 (c:cs) = 
+	let rest = delLine x1 y1 x2 y2 cs
+	in case c of
+		DrawLine (Line (Point x3 y3) (Point x4 y4)) -> 
+			if ((x1==x3) && (y1==y3) && (x2==x4) && (y2==y4)) ||
+			   ((x1==x4) && (y1==y4) && (x2==x3) && (y2==y3))
+				then rest else c:rest
+		otherwise -> c:rest
+
+mark p = circle x y (designSize `div` 50)
+	where Point x y = p
+
+gridlines = concat [(line (l*gridSize) 0 (l*gridSize) designSize) ++
+	       (line 0 (l*gridSize) designSize (l*gridSize)) | 
+			l <- [1..(gridNo-1)]]
+
+gridSize = designSize `div` gridNo
+halfGridSize = gridSize `div` 2
+tdRatio = (fromIntegral tileSize) / (fromIntegral designSize)
+dtRatio = designSize `div` tileSize
diff --git a/Demos/Tiles/DrawingF.hs b/Demos/Tiles/DrawingF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/DrawingF.hs
@@ -0,0 +1,107 @@
+module DrawingF where
+
+import AllFudgets
+import MyUtils
+
+{-
+drawDisplayF size drawing =
+  let startcmds = [ ConfigureWindow [CWBorderWidth 0],
+		    layoutRequestCmd (plainLayout size True True),
+		    ChangeWindowAttributes [ CWEventMask [ExposureMask]
+					     --,CWBackingStore WhenMapped
+					   ]
+		  ]
+  in windowF startcmds (drawDisplayK drawing)
+
+drawDisplayK drawing =
+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayP gc drawing)
+
+drawDisplayP gc drawing0 =
+  let draw drawing = map (Low . Draw MyWindow gc) drawing
+  in let step drawing msg =
+	   case msg of
+		Low (Expose _ 0) -> (drawing, draw drawing)
+		High drawing'   -> (drawing',Low ClearWindow:(draw drawing'))
+		_		 -> (drawing,[])
+  in putsK (draw drawing0) $ mapstateSP step drawing0
+-}
+------
+
+drawDisplayCF size drawing =
+  let startcmds =  [ XCmd $ ConfigureWindow [CWBorderWidth 0],
+		    layoutRequestCmd (plainLayout size True True),
+		     XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask
+							,ButtonPressMask]
+					     --,CWBackingStore WhenMapped
+					   ]
+		  ]
+  in windowF startcmds (drawDisplayCK drawing)
+
+drawDisplayCK drawing =
+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayCP gc drawing)
+
+drawDisplayCP gc drawing0 =
+  let draw drawing = map (Low . wDraw gc) drawing
+  in let step drawing msg =
+	   case msg of
+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)
+		High drawingf'   -> let drawing' = drawingf' drawing
+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))
+		Low (XEvt (ButtonEvent t x y m Pressed b)) -> 
+		    (drawing,High (ButtonEvent t x y m Pressed b):(draw drawing))
+		_		 -> (drawing,[])
+  in putsK (draw drawing0) $ K $ mapstateSP step drawing0
+
+------
+
+drawDisplayCKF size drawing =
+  let startcmds = [ XCmd $ ConfigureWindow [CWBorderWidth 0],
+		    layoutRequestCmd (plainLayout size True True),
+		    XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask
+							,ButtonPressMask]
+					     --,CWBackingStore WhenMapped
+					   ]
+		  ]
+  in windowF startcmds (drawDisplayCKK drawing)
+
+drawDisplayCKK drawing =
+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayCKP gc drawing)
+
+drawDisplayCKP gc drawing0 =
+  let draw drawing = map (Low . wDraw gc) (drawing0++drawing)
+  in let step drawing msg =
+	   case msg of
+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)
+		High drawingf'   -> let drawing' = drawingf' drawing
+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))
+		Low (XEvt (ButtonEvent t x y m Pressed b)) -> 
+		    (drawing,High (ButtonEvent t x y m Pressed b):(draw drawing))
+		_		 -> (drawing,[])
+  in putsK (draw []) $ K $ mapstateSP step drawing0
+
+------
+
+drawDisplayDF size drawing =
+  let startcmds = [ XCmd $ ConfigureWindow [CWBorderWidth 0],
+		    layoutRequestCmd (plainLayout size True True),
+		    XCmd $ ChangeWindowAttributes [ CWEventMask [ExposureMask
+							,ButtonPressMask]
+					     --,CWBackingStore WhenMapped
+					   ]
+		  ]
+  in windowF startcmds (drawDisplayDK drawing)
+
+drawDisplayDK drawing =
+  wCreateGC rootGC [GCFunction GXcopy] (\gc -> drawDisplayDP gc drawing)
+
+drawDisplayDP gc drawing0 =
+  let draw drawing = map (Low . wDraw gc) drawing
+  in let step drawing msg =
+	   case msg of
+		Low (XEvt (Expose _ 0)) -> (drawing, draw drawing)
+		High drawingf'   -> let drawing' = drawingf' drawing
+				    in (drawing',Low (XCmd ClearWindow):(draw drawing'))
+		Low (XEvt (ButtonEvent _ _ _ _ Pressed _)) -> 
+		    (drawing,High (drawing):(draw drawing))
+		_		 -> (drawing,[])
+  in putsK (draw drawing0) $ K $ mapstateSP step drawing0
diff --git a/Demos/Tiles/Main.hs b/Demos/Tiles/Main.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/Main.hs
@@ -0,0 +1,38 @@
+module Main(main) where
+
+import Fudgets
+import BoardF
+import ToolsF
+import ChoiceF
+import Tiles
+import DesignF
+import MyUtils
+
+main = fudlogue (shellF "Escher" escherF)
+
+escherF = placerF (revP (horizontalP' 10)) (playF >==< workF)
+
+playF :: F (Either [Tile] [Tile]) c
+playF = vBoxF (boardF >==< throRight toolsF)
+
+workF :: F b (Either [Tile] [Tile])
+workF = loopLeftF (hBoxF (worka >==< workb))
+
+workb :: F (Either Tile c) (Either Tile (Either [Tile] [Tile]))
+workb = choiceF >=^< fromLeft
+
+worka :: F (Either Tile a) (Either Tile a)
+worka = throRight (designF)
+
+{--- older versions: ---
+
+escherF = (playF >==#< (10, LRightOf, workF)) >==#< (10, LRightOf, quitButtonF)
+
+playF = (boardF,Above) >#==< throRight toolsF
+
+workF = loopLeftF ((worka,LeftOf) >#==< workb)
+
+fromLeft :: Either a b -> a
+fromLeft (Left x) = x
+
+--}
diff --git a/Demos/Tiles/MyUtils.hs b/Demos/Tiles/MyUtils.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/MyUtils.hs
@@ -0,0 +1,11 @@
+module MyUtils where
+
+import Fudgets
+
+throRight :: F a b -> F (Either a c) (Either b c)
+throRight = idRightF
+
+line x1 y1 x2 y2 = [DrawLine (Line (Point x1 y1) (Point x2 y2))]
+
+circle x y r =
+	[FillArc (Rect (psub (Point x y) (Point r r)) (Point (2*r) (2*r))) 0 (64*360)]
diff --git a/Demos/Tiles/RadioDrawF.hs b/Demos/Tiles/RadioDrawF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/RadioDrawF.hs
@@ -0,0 +1,44 @@
+module RadioDrawF(radioDrawCF, radioDrawDF) where
+
+import AllFudgets
+import ToggleDrawGroupF
+import Tiles
+import MyUtils
+
+radioDrawCF l c = loopLeftF (throRight (toggleDrawGroupCF l c) 
+				>==< radioControlCF)
+
+radioControlCF :: F (Either (Int, Event) (Int, Tile)) 
+			(Either (Int, (Either Bool ChangeTile)) (Int, Event))
+radioControlCF = 
+	let outsideC n e = High (Right (n, e))
+	    toggleButC n b = High (Left (n, Left b))
+	    changeButC n d = High (Left (n, Right (changeToT d)))
+	    startStateC = 0
+	    press = ButtonEvent 0 (Point 0 0) (Point 0 0) [] Pressed (Button 1)
+	    firstMsgC = [toggleButC 0 True, outsideC 0 press]
+	    stepC c m = case m of
+		High (Left (n, b)) -> (n, [toggleButC c False, 
+						toggleButC n True, 
+						outsideC n b])
+		High (Right (n, t)) -> (c, [changeButC n t, outsideC c press])
+	in putMessagesF firstMsgC $ F $ mapstateSP stepC startStateC
+
+
+radioDrawDF l c = loopLeftF (throRight (toggleDrawGroupDF l c) 
+				>==< radioControlDF (head c))
+
+radioControlDF :: Tile -> F (Either (Int, Tile) (Int, Tile)) 
+			(Either (Int, (Either Bool ChangeTile)) (Int, Tile))
+radioControlDF t0 = 
+	let outsideD n t = High (Right (n, t))
+	    toggleButD n b = High (Left (n, Left b))
+	    changeButD n d = High (Left (n, Right (changeToT d)))
+	    startStateD = 0
+	    firstMsgD = [toggleButD startStateD True,
+			 outsideD startStateD t0]
+	    stepD c m = case m of
+		High (Left (n, t)) -> (n, [toggleButD c False, 
+					toggleButD n True, outsideD n t])
+		High (Right (n, t)) -> (c, [changeButD n t])
+	in putMessagesF (firstMsgD) $ F $ mapstateSP stepD startStateD
diff --git a/Demos/Tiles/Tiles.hs b/Demos/Tiles/Tiles.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/Tiles.hs
@@ -0,0 +1,83 @@
+module Tiles where
+
+import AllFudgets
+import MyUtils
+
+type Tile = [DrawCommand]
+type ChangeTile = (Tile -> Tile)
+type ChangeTileNo = (BoardTileNo -> BoardTileNo)
+data BoardTileNo = NoTile | TileNo Int
+
+tileSize :: Int
+tileSize = 50
+
+-- functions ending in 'T' manipulate tiles
+-- functions ending in 'TN' manipulate tile numbers
+-- (setT defines the relationship between tiles and tile numbers)
+
+changeToT t = (\x -> t)
+changeToTN :: BoardTileNo -> (BoardTileNo -> BoardTileNo)
+changeToTN t = (\x -> t)
+
+sameT = (\t -> t)
+sameTN :: BoardTileNo -> BoardTileNo
+sameTN = (\t -> t)
+
+rotateT :: Tile -> Tile
+rotateT [] = []
+rotateT (t:ts) = let rest = rotateT ts
+		 in case t of
+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> 
+		DrawLine (Line (Point (tileSize-y1) x1) (Point (tileSize-y2) x2)):rest
+rotateTN tn = case tn of
+		NoTile    -> NoTile
+		otherwise -> let TileNo n = tn
+				 d = n `div` 4 in
+			     TileNo (((n+1) `mod` 4) + (d*4))
+
+mirrorVT [] = []
+mirrorVT (t:ts) = let rest = mirrorVT ts
+		 in case t of
+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> 
+		DrawLine (Line (Point (tileSize-x1) y1) (Point (tileSize-x2) y2)):rest
+mirrorVTN tn = 
+	      case tn of
+		NoTile    -> NoTile
+		otherwise -> let TileNo n = tn
+				 d = n `div` 4
+		 		 m = n `mod` 4 in 
+			     TileNo (((d+1) `mod` 2)*4 + m)
+
+mirrorHT [] = []
+mirrorHT (t:ts) = let rest = mirrorHT ts
+		 in case t of
+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> 
+		DrawLine (Line (Point x1 (tileSize-y1)) (Point x2 (tileSize-y2))):rest
+mirrorHTN tn = case tn of
+		NoTile    -> NoTile
+		otherwise -> let TileNo n = tn
+				 d = n `div` 4 in
+			     TileNo (((d+1) `mod` 2)*4 + ((n+2) `mod` 4))
+
+magT m [] = []
+magT m (t:ts) = let rest = magT m ts
+		 in case t of
+	DrawLine (Line (Point x1 y1) (Point x2 y2)) -> 
+		DrawLine (Line (Point (x1*m) (y1*m)) (Point (x2*m) (y2*m))):rest
+
+setT :: Tile -> [Tile]
+setT t = [t, rotateT t, (rotateT.rotateT) t, (rotateT.rotateT.rotateT) t,
+	  mirrorVT t, (rotateT.mirrorVT) t, (rotateT.rotateT.mirrorVT) t,
+	  (rotateT.rotateT.rotateT.mirrorVT) t]
+
+tile 0 = (line 0 25 25 0) ++ (line 25 50 50 25)
+tile 1 = (line 25 0 25 50) ++ (line 0 25 50 25)
+tile 2 = (line 0 25 25 0) ++ (line 25 0 25 50) ++ (line 25 50 50 25)
+tile 3 = (line 0 25 25 0) ++ (line 25 0 50 25) ++ (line 50 25 25 50) ++
+                (line 25 50 0 25)
+tileRotL = (line 10 25 10 10) ++ (line 10 10 40 10) ++ (line 40 10 40 25) ++
+                (line 40 25 35 20) ++ (line 40 25 45 20)
+tileRotR = mirrorVT tileRotL
+tileMirH = (line 25 5 25 45) ++ (line 20 10 25 5) ++ (line 25 5 30 10) ++
+                (line 20 40 25 45) ++ (line 25 45 30 40)
+tileMirV = rotateT tileMirH
diff --git a/Demos/Tiles/ToggleDrawGroupF.hs b/Demos/Tiles/ToggleDrawGroupF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/ToggleDrawGroupF.hs
@@ -0,0 +1,24 @@
+module ToggleDrawGroupF(toggleDrawGroupCF, toggleDrawGroupDF) where
+
+import Fudgets
+import DrawingF
+
+--toggleDrawCF :: size -> drawing -> F (Either Bool ChangeTile) Event
+toggleDrawCF size init = buttonBorderF 5 (drawDisplayCF size init)
+
+--toggleDrawGroupCF :: layout -> choices 
+--	-> F (Int, (Either Bool ChangeTile)) (Int, Event)
+toggleDrawGroupCF layout choices = 
+	let t v = toggleDrawCF (Point 50 50) v
+	    toggles = zip [0..((length choices) - 1)] (map t choices)
+	in listLF layout toggles
+
+--toggleDrawDF :: size -> drawing -> F (Either Bool ChangeTile) Tile
+toggleDrawDF size init = buttonBorderF 5 (drawDisplayDF size init)
+
+--toggleDrawGroupDF :: layout choices 
+--	-> F (Int, (Either Bool ChangeTile)) (Int, Tile)
+toggleDrawGroupDF layout choices = 
+	let t v = toggleDrawDF (Point 50 50) v
+	    toggles = zip [0..((length choices) - 1)] (map t choices)
+	in listLF layout toggles
diff --git a/Demos/Tiles/ToolsF.hs b/Demos/Tiles/ToolsF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/Tiles/ToolsF.hs
@@ -0,0 +1,46 @@
+module ToolsF(toolsF) where
+
+import Fudgets
+import DrawingF
+import RadioDrawF
+import Tiles
+import MyUtils
+
+toolsF = loopLeftF ((throRight (radioDrawCF layout choices)) >==< toolControlF)
+
+layout = matrixP 6 --matrixL 6 Horizontal 5
+
+choices = [[], [], [], []] ++ [tileRotL] ++ [tileRotR] ++
+	[[], [], [], []] ++ [tileMirH] ++ [tileMirV]
+
+--toolControlF :: F (Either (Int, XEvent) [Tile]) (Either (Int, Tile) ChangeTileNo)
+toolControlF = 
+	let toButtons = Left
+	    toBoard = Right
+	    startstate = 0
+	    step c m = case m of
+		-- from Buttons
+		(Left (n, _)) -> (n, [toBoard (t n)])
+		-- from Choice
+		(Right nt) -> (c, [toButtons (0, nt!!0),
+					toButtons (1, nt!!1),
+					toButtons (2, nt!!2),
+					toButtons (3, nt!!3),
+					toButtons (6, nt!!4),
+					toButtons (7, nt!!5),
+					toButtons (8, nt!!6),
+					toButtons (9, nt!!7)])
+	in absF (mapstateSP step startstate)
+
+t 0  = changeToTN (TileNo 0)
+t 1  = changeToTN (TileNo 1)
+t 2  = changeToTN (TileNo 2)
+t 3  = changeToTN (TileNo 3)
+t 4  = rotateTN
+t 5  = rotateTN . rotateTN . rotateTN
+t 6  = changeToTN (TileNo 4)
+t 7  = changeToTN (TileNo 5)
+t 8  = changeToTN (TileNo 6)
+t 9  = changeToTN (TileNo 7)
+t 10 = mirrorHTN
+t 11 = mirrorVTN
diff --git a/Demos/clock/ClockF.hs b/Demos/clock/ClockF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/clock/ClockF.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE CPP #-}
+module ClockF(clockShellF) where
+import AllFudgets
+--import DialogueIO hiding (IOError)
+import Data.Maybe(fromMaybe)
+#ifdef VERSION_old_time
+import System.Time(CalendarTime(..))
+#else
+import Data.Time(TimeOfDay(..),localTimeOfDay,zonedTimeToLocalTime)
+#endif
+
+--default(Int)
+
+trace x y = y
+--ctr s x = ctrace s (show x) x
+
+data ClockMode = Analog | Digital deriving (Show,Eq)
+
+clockShellF =
+  let size = fsize
+      gcattrs = [GCFont digFont,
+		 GCLineWidth width,
+		 GCCapStyle CapRound]
+      clockShellK = safeLoadQueryFont digFont (\font ->
+		       dynShapeK gcattrs (const [])
+				 (clockK startMode (digsize font)
+			                 (Point 0 (font_ascent font))
+			                 size))
+      menuF = menuAltsF menuFont [Analog,Digital] show -- >=^<Left
+      tickF = (Left. Right. Right)>^=<startupF [Just (update,1000)] timerF
+      startcmds = map (Low . XCmd) [StoreName "ClockFudget"
+                   --,ConfigureWindow [CWBorderWidth 5] -- testing
+		  ]
+      route msg =
+	 case msg of
+	   Left (Right (Left shape)) -> Left (Left shape)
+	   Left (Right (Right pop)) -> Right pop
+	   Right mode -> Left (Right (Left mode))
+  in loopOnlyF (route>^=<shellKF (putsK startcmds clockShellK) menuF)>==<tickF
+
+clockK :: ClockMode -> Size -> Point -> Size -> K (Either ClockMode Tick) (Either (Point->[DrawCommand]) PopupMenu)
+clockK dig digsize bp size =
+  let clockP dig size =
+        let redraw s t = putsK [--Low (ConfigureWindow [CWBorderWidth 5]), -- testing
+	                       High (Left (clockface dig bp t))] (clockP dig s)
+            --gettime dig s = putLow (DReq GetLocalTime) (clockP dig s)
+#ifdef VERSION_old_time
+            gettime dig s = getLocalTime (redraw s)
+#else
+            gettime dig s = getZonedTime (redraw s)
+#endif
+            same = clockP dig size
+        in getK $ \msg ->
+	   case msg of
+	     --Low (Expose _ 0)-> gettime dig size -- ??
+	     --Low (DResp (Dbl t))-> redraw size t
+	     Low (XEvt ev@(ButtonEvent _ _ rootpos _ Pressed _)) ->
+	       putK (High (Right (PopupMenu rootpos ev))) same
+	     Low (XEvt (ButtonEvent _ _ _ _ Released _))->
+	       putK (High (Right PopdownMenu)) same
+	     High (Right _) -> gettime dig size
+	     High (Left mode) -> if mode==dig
+			        then same
+				else putK (layout mode) (gettime mode size)
+	     _-> same
+
+      layout mode =
+        let s = case mode of
+	          Digital-> digsize
+		  Analog-> size
+	in Low (layoutRequestCmd (plainLayout s False False))
+      layout0 = layout dig
+      startcmds =
+        [ layout0,
+          Low (XCmd $ GrabButton True AnyButton [] [ButtonPressMask,ButtonReleaseMask])
+	]
+  in changeBg color (putsK startcmds (clockP dig size))
+
+#ifdef VERSION_old_time
+timeofday CalendarTime{ctHour=h,ctMin=min,ctSec=s} =
+  let t = s+60*(min+60*h)
+      m = itof t / 60.0
+  in (fmod (m/60.0) 24.0 ,fmod m 60.0)
+#else
+timeofday zt = (fmod (m/60.0) 24.0 ,fmod m 60.0)
+  where
+    t = round s+60*(min+60*h)
+    m = itof t / 60
+    TimeOfDay h min s = localTimeOfDay (zonedTimeToLocalTime zt)
+#endif
+
+clockface mode bp t size =
+    case mode of
+      Digital-> [DrawString bp (digits t)]
+      Analog-> hands t size ++ scalemarks size
+
+digits t =
+  let (h,m) = aboth floor' (timeofday t)
+  in show h ++ ":" ++ drop 1 (show (100+m))
+
+hands t size =
+  let (h,m) = timeofday t
+  in hand h 12 0.6 size ++ hand m 60 0.95 size
+
+hand v d r size =
+  let a = v / itof d * 2.0 * pi
+      h = scalePoint 0.5 size
+  in [DrawLine (Line h (toRect r h a))]
+
+scalemarks size =
+  let r = scalePoint 0.5 size
+      w2 = width*2
+  in let mark n =
+	  let a = itof n*pi/6.0
+	  in Rect (psub (toRect 0.9 r a) (Point width width)) (Point w2 w2)
+  in [FillArc (mark n) 0 (64*360) | n<-[0..11]]
+
+toRect k (Point w h) r = Point (w+floor' (k*itof w*sin r)) (h+floor' (k*itof (-h)*cos r))
+
+fmod :: Double -> Double -> Double
+fmod a b =
+  let y = a - b * fromIntegral (floor' (a/b))
+  in {-if y<0.0 && argFlag "floor" False 
+     then trace (show (a,b,y)) y
+     else -}y
+
+digsize font = string_box_size font "88:88"
+
+width = argReadKey "width" 10
+fsize = fromMaybe (diag (argReadKey "size" 200)) defaultSize
+color = argKey "color" "gold"
+update = (argReadKey "update" 20) * 1000
+startMode = if argKey "mode" "analog" == "digital" then Digital else Analog
+digFont = defaultFont
+
+itof=fromIntegral
+
+rightadj s n pad = [pad|i<-[length s+1..n]]++s
+
+floor' x = floor x
+-- Solves a problem on slip-02 with direct calls to PfloorDouble2Int. TH 970314.
diff --git a/Demos/clock/fudgetclock.hs b/Demos/clock/fudgetclock.hs
new file mode 100644
--- /dev/null
+++ b/Demos/clock/fudgetclock.hs
@@ -0,0 +1,5 @@
+module Main where
+import Fudgets
+import ClockF
+
+main = fudlogue clockShellF
diff --git a/Demos/graph/Compat.hs b/Demos/graph/Compat.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Compat.hs
@@ -0,0 +1,18 @@
+--
+-- Library with LML compatible functions.
+--
+module Compat where
+import Data.Char(isAlpha,isDigit)
+
+mix :: [[a]] -> [a] -> [a]
+mix [] d = []
+mix (x:xs) d = x++case xs of [] -> []; _ -> d ++ mix xs d
+
+takeWord :: String -> (String, String)
+takeWord [] = ([],[])
+takeWord (' ':cs) = takeWord cs
+takeWord ('\n':cs) = takeWord cs
+takeWord ('\t':cs) = takeWord cs
+takeWord (c:cs) | isAlpha c = let (w,cs') = span (\c->isAlpha c || isDigit c || c=='_') cs in (c:w,cs')
+		| isDigit c = let (w,cs') = span isDigit cs in (c:w, cs')
+		| otherwise = ([c], cs)
diff --git a/Demos/graph/Diff.hs b/Demos/graph/Diff.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Diff.hs
@@ -0,0 +1,42 @@
+module Diff(diff,diffCmd) where
+import Exp
+import Ops
+import Simp
+
+diffCmd cmd =
+  case cmd of
+    Fun e -> Fun (diff e)
+    Approx a n e -> Approx a n (diff e)
+
+diff e =
+  case e of
+     Var -> one
+     Const _ -> zero'
+     Pow b e -> ce e `mul` diff b `mul` pow b (e-1)
+     Binop bop e1 e2 -> diffbinop bop e1 e2
+     Unop uop e -> mul (diff e) (uopdiff uop e)
+
+
+diffbinop bop e1 e2 =
+  case bop of
+     Badd -> add (diff e1) (diff e2)
+     Bsub -> sub (diff e1) (diff e2)
+     Bmul -> add (mul e1 (diff e2)) (mul (diff e1) e2)
+     Bdiv -> div' (sub (mul (diff e1) e2) (mul e1 (diff e2))) (mul e2 e2)
+     _ -> unimpl
+
+
+uopdiff unop e =
+  case unop of
+     Uneg -> neg one
+     Usin -> Unop Ucos e
+     Ucos -> neg (Unop Usin e)
+     Uexp -> Unop Uexp e
+     Utan -> add one (mul (Unop Utan e) (Unop Utan e))
+     Uln -> inv e
+     Uabs -> Unop Usgn e
+     _ -> unimpl
+
+
+unimpl = error "Unimplemented diff\n"
+
diff --git a/Demos/graph/Eval.hs b/Demos/graph/Eval.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Eval.hs
@@ -0,0 +1,28 @@
+module Eval where
+import Exp
+import Ops
+--import List(union)
+
+eval e =
+  case e of
+     Var ->  id
+     Const k -> const k
+     Pow b e -> let bv = eval b
+                in \ x -> bv x ^^ e
+     Binop bop e1 e2 ->
+       let f = binopfun bop
+           v1 = eval e1
+           v2 = eval e2
+       in \x -> f (v1 x) (v2 x)
+     Unop unop e ->
+       let f = unopfun unop
+       in f . eval e
+
+{-
+freevars e =
+  case e of
+     Var x -> [x]
+     Const _ -> []
+     Binop _ e1 e2 -> union (freevars e1) (freevars e2)
+     Unop _ e -> freevars e
+-}
diff --git a/Demos/graph/Exp.hs b/Demos/graph/Exp.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Exp.hs
@@ -0,0 +1,29 @@
+module Exp where
+import Ops
+
+data Cmd
+  = Fun Exp
+  | Approx Approx Int Exp
+
+data Approx = Trapets | RectU | RectO
+
+--type Id = (Char, Int)
+
+type Value = Double
+
+data Exp
+  = Var
+  | Const Value
+  | Pow Exp Int
+  | Binop Bop Exp Exp
+  | Unop Uop Exp
+  deriving (Eq)
+
+{-
+stoid :: String -> Id
+stoid (a:ds) = (a,read ds)
+
+idtos :: Id -> String
+idtos (c,n) = c:show n
+
+-}
diff --git a/Demos/graph/ExpF.hs b/Demos/graph/ExpF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/ExpF.hs
@@ -0,0 +1,42 @@
+module ExpF(expF) where
+import Fudgets
+import Show
+import Parser
+import Lex
+import Diff
+import Exp(Exp)
+
+expF =
+    noStretchF False True $
+    loopLeftF (toBothF>==<((throughExpInputF,LeftOf)>#==<diffF))
+    --loopLeftF (toBothF>==<(throughExpInputF>==<diffF))
+
+throughExpInputF = stripEither >^=< throughF expInputF
+
+expInputF =
+	concatMapF parse>==<
+	(inputDoneSP>^^=<spacerF vCenterS (labLeftOfF "f(x)=" stringF))>=^<
+	show_Cmds
+
+parse s =
+	case (cmds . lex') s of
+	   Right (e,[])-> [e]
+	   _ -> []	-- should generate error message
+
+diffF =	map diffCmd>^=<
+		(bufSP>^^=<
+		(idF>+<buttonF "Derivate"))
+
+bufSP =
+  let buf b =
+        getSP $ \x->
+	case x of
+         Left d -> buf (Just d)
+         Right _ -> case b of
+		    Nothing -> buf b
+		    Just d -> putSP d $ buf b
+  in buf Nothing
+
+
+
+
diff --git a/Demos/graph/Graph.hs b/Demos/graph/Graph.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Graph.hs
@@ -0,0 +1,46 @@
+import Fudgets
+import PlotF
+import ExpF
+import Exp(Cmd(..))
+import Eval
+import Root
+import Show(showf,showp)
+
+main = fudlogue $ shellF' (setSizing Static) "Graph" $
+       if argFlag "namel" True
+       then nameLayoutF layout mainF
+       else mainF
+
+layout = v [l f,
+	    l gr,
+	    h [v [--l p,
+		  l a]{-,l q-}]]
+  where --al = alignSepNL 0 aCenter aCenter
+	h = hBoxNL
+	v = vBoxNL
+	l = leafNL
+
+f:gr:a:p:q:_ = map show [(1::Int)..]
+        
+mainF = --nameF q (stubF quitButtonF)>==<
+        (nameF a showareaF>+<nullF{-nameF p showpointF-})>==<
+	nameF gr grF>==<
+	nameF f funcF
+
+funcF =(Left . map evalr)>^=<expF
+  where
+    evalr cmd =
+      case cmd of
+        Fun e -> RFunc (eval e,root e)
+	Approx a n e -> RLines a n (eval e)
+
+grF = plotF Nothing
+
+showareaF = displayF >=^<showarea
+--showpointF = displayF >=^<showp
+
+showarea (xa,(y1,y2)) =
+	"x: " ++ showinterval xa ++ ", y: " ++ showinterval (y2,y1)
+
+showinterval (a,b) = "[" ++ showf a ++ ", " ++ showf b ++ "]"
+
diff --git a/Demos/graph/Lex.hs b/Demos/graph/Lex.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Lex.hs
@@ -0,0 +1,23 @@
+module Lex where
+import HbcUtils(chopList,breakAt)
+import Compat(takeWord)
+import Data.Char
+
+lex' = lexfix . filter (/=[]) . chopList taketoken
+
+lexfix [] = []
+lexfix (a:".":b:xs) = if isDigit (head a) && isDigit (head b)
+ 			  then (a++"."++b):lexfix xs
+			  else a:".":lexfix (b:xs)
+lexfix (x:xs) = x:lexfix xs
+
+-- taketoken = takeword
+
+taketoken [] = ([],[])
+taketoken ccs@(c:cs) =
+	case c of
+	  '\"' -> let (s,rest) = breakAt '"' cs
+		  in (c:s,rest)
+	  _ -> takeWord ccs
+
+
diff --git a/Demos/graph/Ops.hs b/Demos/graph/Ops.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Ops.hs
@@ -0,0 +1,87 @@
+module Ops(Bop(..),Uop(..),unops,addops,mulops,binoplex,binopfun,unoplex,unopfun,
+	show_Bop,show_Uop,addopt,mulopt{-,powopt-})
+where
+
+data Bop = Badd | Bsub | Bmul | Bdiv | Bmin -- | Bpow
+           deriving (Eq)
+
+data Uop = Uneg | Usin | Ucos | Utan | Uexp | Ulog | Uln | Usqrt |
+	   Uabs | Ufloor | Uceil | Uround | Utanh | Ucosh | Usinh | Ugamma |
+	   Uatan | Uacos | Uasin | Usgn | Utheta
+		deriving (Eq)
+
+assocdef x xs e = maybe e id $ lookup x xs
+
+binoplex binop = fst (assocdef binop binoptab (error "undefined binop"))
+binopfun binop = assocdef binop (map snd binoptab) (error "undefined binop")
+
+binoptab = addopfuncs ++ mulopfuncs -- ++ powopfuncs
+
+addopfuncs =
+  [("+",(Badd,(+))),
+   ("-",(Bsub,(-)))
+  ]
+
+mulopfuncs =
+  [("*",(Bmul,(*))),
+   ("/",(Bdiv,(/))),
+   ("!",(Bmin,min))
+  ]
+
+{-
+powopfuncs =
+  [("^",(Bpow,pow))
+  ]
+-}
+
+addops = map fst addopfuncs
+mulops = map fst mulopfuncs
+--powops = map fst powopfuncs
+
+addopt = map (fst . snd) addopfuncs
+mulopt = map (fst . snd) mulopfuncs
+--powopt = map (fst . snd) powopfuncs
+
+unoplex unop = fst (assocdef unop unoptab (error "undefined unop"))
+unopfun unop = assocdef unop (map snd unoptab) (error "undefined unop")
+
+unoptab =
+  [("-",(Uneg,negate)),
+   ("sin",(Usin,sin)),
+   ("cos",(Ucos,cos)),
+   ("tan",(Utan,tan)),
+   ("exp",(Uexp,exp)),
+   ("log",(Ulog,log)),
+   ("ln",(Uln,log)),
+   ("log",(Uln,log)),
+   ("sqrt",(Usqrt,sqrt)),
+   ("fabs",(Uabs,abs)),
+   ("abs",(Uabs,abs)),
+   ("floor",(Ufloor,fromIntegral.floor)),
+   ("round",(Uround,fromIntegral.round)),
+   --("ceil",(Uceil,ceil)),
+   ("tanh",(Utanh,tanh)),
+   ("cosh",(Ucosh,cosh)),
+   ("sinh",(Usinh,sinh)),
+   --("gamma",(Ugamma,gamma)),
+   ("atan",(Uatan,atan)),
+   ("acos",(Uacos,acos)),
+   ("asin",(Uasin,asin)),
+   ("sgn",(Usgn,sgn)),
+   ("theta",(Utheta,theta))
+  ]
+
+theta :: Double->Double
+theta x = if x<0.0 then 0.0 else 1.0
+sgn x = theta x - theta (0.0-x)
+
+--pow x y = exp (y * log x)
+--pow x y = x**y
+--pow x y = x^^y
+
+unops = map fst unoptab
+
+show' tab x = assocdef x (map (\(x,(y,_))->(y,x)) tab) (error "show' in Ops.hs")
+
+show_Uop = show' unoptab
+show_Bop = show' binoptab
diff --git a/Demos/graph/Parser.hs b/Demos/graph/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Parser.hs
@@ -0,0 +1,64 @@
+module Parser(parse_Exp,expr,cmds,complete) where
+import Parsop
+import Exp
+import Ops
+import Compat(mix)
+import Data.Char
+
+cmds = seq' cmd (lit ",")
+
+cmd
+    = (lit "A" +<+ approx +++ int +++ expr ==> approxcmd)
+  ||| (expr ==> Fun)
+  where
+    approxcmd ((a,n),e) = Approx a n e
+
+approx
+    = (lit "t" ==> const Trapets)
+  ||| (lit "u" ==> const RectU)
+  ||| (lit "o" ==> const RectO)
+
+parse_Exp = complete . expr
+
+--exprs = seq' expr (lit ",")
+expr = leftAssoc term addop
+
+term = leftAssoc factor mulop
+
+factor = (aexp +++ optexponent) ==> (%%) (flip id)
+
+aexp
+    = num
+  ||| var 
+  ||| ((unop +++ factor) ==> (%%) Unop)
+  ||| (lit "(" +<+ expr +>+ lit ")")
+
+mulop = is (\t->elem t mulops) ==> binoplex
+addop = is (\t->elem t addops) ==> binoplex
+unop = is (\t->elem t unops) ==> unoplex
+--ident = is iscellid ==> stoid
+var = lit "x" ==> const Var
+num = is (isDigit . head) ==> (Const . readf)
+
+optexponent = cond exponent id
+  where
+     exponent = (lit "^" +<+ int) ==> (flip Pow)
+
+int = is (all isDigit) ==> read
+
+leftAssoc item op = item +++ (***) (op +++ item) ==> (%%) tree
+
+tree e1 [] = e1
+tree e1 ((op,e2):oes) = tree (Binop op e1 e2) oes
+
+iscellid (c1:cs) = cs/=[] && isAlpha c1 && all isDigit cs
+
+readf :: String -> Double
+readf s = if '.' `elem` s then read s else read (s++".0")
+
+complete ts =
+  case ts of
+     Right(e,[])->Right e
+     Left ts-> Left ("Syntax error before: " ++ mix (take 10 ts) " ")
+     Right(_,ts)-> Left ("Trailing garbage: " ++ mix (take 10 ts) " ")
+
diff --git a/Demos/graph/Parsop.hs b/Demos/graph/Parsop.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Parsop.hs
@@ -0,0 +1,83 @@
+module	Parsop where
+infixl |||, +++, +>+, +<+
+{-
+infix "==>";
+prefix "***";
+infix "+<+";
+infix "+>+";
+infix "iff";
+prefix "%%";
+-}
+{-
+export	empty,
+-- matches the empty string
+	+++,
+-- sequence, returns a pair
+	|||,
+-- alternative
+	is,
+-- terminal tested with a predicate
+	`,
+-- terminal tested with equality
+	***,
+-- 0 or many (transitive closure)
+	+<+,
+-- sequence, throw away first part
+	+>+,
+-- sequence, throw away second part
+	==>,
+-- transform
+	cond,
+-- 0 or one
+	seq',
+-- sequence of 0 or many with a separator
+	seq1,
+-- sequence of 1 or many with a separator
+	iff,
+-- conditional
+	%%;
+-- uncurry
+-}
+trycase pf fail succeed ws=
+  case pf ws of
+     Left _ -> fail ws
+     Right(x,ws) -> succeed x ws
+
+
+failure ws= Left ws
+success x ws = Right(x,ws)
+
+try pf cont = trycase pf failure cont
+
+is p [] = Left []
+is p (w:ws) = if p w
+		  then Right(w,ws)
+		  else Left (w:ws)
+
+lit w = is (==w)
+
+pf1 +++ pf2 = try pf1 (\x ->try pf2 (\y -> success(x,y)))
+
+pf1 ||| pf2 = trycase pf1 pf2 success
+
+pf ==> f = try pf (success . f)
+
+(***) pf = ((pf +++ (***) pf) ==> (%%) (:)) ||| success []
+
+sep +<+ pf1 = (sep +++ pf1) ==> snd
+pf1 +>+ sep = (pf1 +++ sep) ==> fst
+
+--seq1 pf sep = ((pf +++ (sep +<+ seq1 pf sep)) ==> %% (.)) ||| (pf ==> (:[]))
+seq1 pf sep = (pf +++ ((sep +<+ seq1 pf sep) ||| empty [])) ==> (%%) (:)
+
+seq' pf sep = seq1 pf sep ||| empty []
+
+empty = success
+
+cond pf x = pf ||| empty x
+
+pf `iff` p = try pf (\x -> if p x
+			  then success x
+			  else failure)
+
+(%%) = uncurry
diff --git a/Demos/graph/PlotF.hs b/Demos/graph/PlotF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/PlotF.hs
@@ -0,0 +1,201 @@
+module PlotF
+    (plotF,ToPlot(..),Area(..),Interval(..),Func(..))
+  where
+import AllFudgets
+import Data.List(sortBy)
+import Data.Maybe(fromMaybe)
+import ZoomF
+import HbcUtils(apSnd)
+import UserCoords
+import Exp(Approx(..))
+
+data Plot = Grid | Axes | Functions [Double->Double] | Lines [(Double,Double)]
+
+plotReal size0 area plot = FlexD size0 False False draw
+  where
+    draw (Rect p size) = move p (drawgraph size area plot)
+
+gridstep w xa h ya = max (gridstep' w xa) (gridstep' h (swap ya))
+  where
+    gridstep' w (x0,x1) =
+       if mag>=minstep
+       then mag
+       else if mag2>=minstep
+            then mag2
+	    else if mag5>=minstep
+	         then mag5
+		 else mag10
+      where
+        maxcnt = w `div` 8
+	minstep = d / fromIntegral maxcnt
+	mag = 10^^floor (log10 minstep)
+	mag2 = 2*mag
+	mag5 = 5*mag
+	mag10 = 10*mag
+        d = x1-x0
+
+
+drawgraph (Point w h) (xa,ya) plot =
+    case plot of
+      Grid -> drawgrid
+        where
+	  drawgrid = hlines++vlines
+	  d = gridstep w xa h ya
+	  hlines = [DrawLine (lL 0 y xh y) |
+	            let lo=ceiling' d (snd ya),
+		    yu<-[lo,lo+d .. floor' d (fst ya)],
+		    let y=wdw h ya yu]
+	  vlines = [DrawLine (lL x 0 x yh) |
+	            let lo=ceiling' d (fst xa),
+		    xu<-[lo,lo+d .. floor' d (snd xa)],
+		    let x=wdw w xa xu]
+      Axes -> drawaxes
+        where
+	  drawaxes =
+	     [DrawLine (lL 0 y0 xh y0),
+	      drawLines [pP (xh-d) (y0-d),pP xh y0,pP (xh-d) (y0+d)],
+	      DrawLine (lL x1 (y0-d) x1 (y0+d)),
+	      DrawLine (lL x0 0 x0 yh),
+	      drawLines [pP (x0-d) d,pP x0 0,pP (x0+d) d],
+	      DrawLine (lL (x0-d) y1 (x0+d) y1)]
+      Functions fs -> map drawfunc fs 
+	where
+	  drawfunc f =
+	    drawLines [Point wx ((wdw h ya . f . user w xa) wx) | wx<-[0,2..w]]
+      Lines ps -> [drawLines [Point (wdw w xa x) (wdw h ya y)|(x,y)<-ps]]
+  where
+    drawLines = DrawLines CoordModeOrigin
+    y0 = wdw h ya 0.0
+    y1 = wdw h ya 1.0
+    x0 = wdw w xa 0.0
+    x1 = wdw w xa 1.0
+    yh = h-1
+    xh = w-1
+    d = 4
+
+ceiling' d x = fromIntegral (ceiling (x/d)) * d
+floor' d x = fromIntegral (floor (x/d)) * d
+log10 x = log x / log 10
+
+showroot (Point w h) ((xa@(x1,x2)),ya) roots p@(Point wx wy)=
+    case sortroots [x | root<-roots, Just x<-[root (user w xa wx) eps]] of
+      x:_ -> Popup (pP (wdw w xa x) (wdw h ya 0.0)) ("x=" ++ show x)
+      [] -> Popup p "No root?"
+  where
+    sortroots = sortBy cmpdist
+    cmpdist x1 x2 = compare (dist x1) (dist x2)
+    dist x = abs (x-x0)
+    x0 = user w xa wx
+    eps = abs (x0/1.0e10)
+    rnd x = real (round (x * r)) / r  -- keep approx 5 significant digits
+      where r = scaleFloat (17+exponent x) 0.5
+
+rmroot = Popdown
+
+data ToPlot
+  = RFunc Func
+  | RLines Approx Int (Double->Double)
+
+type Func = (Double->Double,Double->Double->Maybe Double)
+
+zoomDispF size = zoomF dispF
+  where
+    dispF = graphicsDispGroupF' custom rootDispF
+    custom = setInitDisp initD . setSizing Static .
+             (setBgColor paper :: (Customiser (GraphicsF a)))
+    initD = plotD size startarea []
+
+plotD size area@(xa,_) fs =
+    stackD (fgD grid (g gr):
+            softAttribD (gcattrs fgColor) (g axes):
+            ps)
+  where
+    ps = zipWith p1 (cycle pens) fs
+    p1 pen f = softAttribD (gcattrs pen) (g (p f))
+    p :: ToPlot -> FlexibleDrawing
+    p (RFunc (f,_)) = plotReal size area (Functions [f])
+    p (RLines Trapets n f) = plotReal size area (Lines (trapets xa n f))
+    p (RLines RectO n f) = plotReal size area (Lines (rect max xa n f))
+    p (RLines RectU n f) = plotReal size area (Lines (rect min xa n f))
+    gr = plotReal size area Grid
+    axes = plotReal size area Axes
+    gcattrs fg = [GCForeground (colorSpec fg), GCLineWidth lw,
+		  GCCapStyle CapProjecting
+		  ]
+
+    rect :: (Double->Double->Double)->(Double,Double) -> Int -> (Double->Double) -> [(Double,Double)]
+    rect est xa n = vlines . hlines . trapets xa n
+     where
+      hlines ((x1,y1):ps@((x2,y2):_)) = (x1,x2,est y1 y2):hlines ps
+      hlines _ = []
+
+      vlines [] = []
+      vlines ((x1,x2,y):hs) = (x1,y):(x2,y):vlines' y hs
+
+      vlines' y [] = []
+      vlines' y ((x1,x2,y2):hs) =
+        if y==y2
+	then (x2,y2):vlines' y2 hs
+	else (x1,y2):(x2,y2):vlines' y2 hs
+
+    trapets :: (Double,Double) -> Int -> (Double->Double) -> [(Double,Double)]
+    trapets (x1,x2) n f = [pairwith f (x i)|i<-[0..n]]
+      where
+	x i = x1+dx*fromIntegral i
+	dx = (x2-x1)/fromIntegral n
+
+startarea = ((-6.5,6.5),(6.5,-6.5))
+
+--plotF :: Maybe Size -> F (Either [Func] Area) (Either Area (Double,Double))
+plotF optsize =
+    loopThroughRightF ctrlF (zoomDispF size)
+  where
+    size = fromMaybe (Point 400 400) optsize
+
+    --f0 x = 0.0 -- dummy
+    --r0 x dx = Just x -- dummy
+    state0 = (startarea,[])
+
+    plot area funcs = replaceAllGfx $ plotD size area funcs
+
+    toGfx = Left . Right
+    toDisp = toGfx . Left
+    toRootDisp = toGfx . Right
+
+    ctrlF = putF (Right (Left startarea)) $ mapstateF ctrl state0
+
+    ctrl state@(area,func) = either fromLoop fromOutsize
+      where
+        output x  = apSnd (Right x:)
+        same = (state,[])
+	redraw area' func' =
+	  ((area',func'),[toRootDisp rmroot,toDisp (plot area' func')])
+	zoom area' = output (Left area') $ redraw area' func
+	newfunc f = redraw area f
+
+	fromOutsize = either newfunc zoom
+        fromLoop = either fromZoom fromGfx
+	fromGfx _ = same
+
+	fromZoom zoomMsg =
+	  case zoomMsg of
+	    ZoomIn s p  -> zoom (zoomin s p area)
+	    ZoomOut s p -> zoom (zoomout s p area)
+	    ZoomRect size (Rect p s) ->
+	      if s =.> 2
+	      then zoom (zoomrect (size,area) p (p+s))
+	      else same
+	    ZoomPick s p ->
+	      (state,[toRootDisp (showroot s area [r|RFunc (_,r)<-func] p)])
+	    ZoomResize _ -> (state,[toRootDisp rmroot])
+
+rootDispF =
+    --delayF $
+    bubblePopupF (displayF' pm)
+  where
+    pm = setBorderWidth 0.setMargin 0.setSizing Dynamic. setBgColor "white"
+
+pens = argKeyList "pens" ["blue3","red3","green4","orange"]
+grid = argKey "grid" "grey"
+paper = argKey "plotpaper" "grey90"
+lw = argReadKey "linewidth" 2 -- 0 looks better than 1.
diff --git a/Demos/graph/Root.hs b/Demos/graph/Root.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Root.hs
@@ -0,0 +1,23 @@
+module Root where
+import Eval
+import Diff
+import Exp
+import Ops(Bop,Uop)
+
+root e x0 dx =
+  let f = eval e
+      f' = eval (diff e)
+      step x =  let y'=f' x
+		in if y'==0.0
+		   then Nothing
+		   else Just (x - f x / y')
+      infapproxs x = x:(case step x of
+		          Nothing -> []
+		          Just x2 -> infapproxs x2)
+      approxs = take 20 (infapproxs x0)
+      root (x1:x2:xs) = if abs (x1-x2)<dx
+			then Just x2
+			else root (x2:xs)
+      root _ = Nothing
+
+  in root approxs
diff --git a/Demos/graph/Show.hs b/Demos/graph/Show.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Show.hs
@@ -0,0 +1,57 @@
+module Show(show_Exp,show_Cmds,show_Cmd,showf,showp) where
+import Exp
+import Ops
+import Numeric(showGFloat)
+import Compat(mix)
+--import Printf -- From hbc_library, comment out if not compiling with hbc.
+
+--- hbc version:
+--showf x = printf "%.5g" [UDouble x]
+--showp (x,y) = printf "(%.5g,%.5g)" [UDouble x,UDouble y]
+--- standard version:
+--showf = show
+showf x = showGFloat (Just 5) x ""
+showp (x,y) = "("++show x++","++show y++")"
+---
+
+show_Cmds cmds = mix (map show_Cmd cmds) ", "
+
+show_Cmd cmd =
+  case cmd of
+    Fun e -> show_Exp e
+    Approx a n e -> "A "++show_Approx a++" "++show n++" "++show_Exp e
+
+show_Approx Trapets = "t"
+show_Approx RectO = "o"
+show_Approx RectU = "u"
+
+--show_Exps es = mix (map show_Exp es) ", "
+show_Exp e =
+  case e of
+     Binop Badd e1 e2 -> show_Exp e1 ++ show_Bop Badd ++ show_Exp e2
+     Binop bop e1 e2 | bop `elem` addopt -> show_Exp e1 ++ show_Bop bop ++ show_term e2
+     Unop uop e | uop==Uneg -> show_Uop Uneg ++ show_term e
+     _ -> show_term e
+
+show_term e =
+  case e of
+     Binop bop e1 e2 | bop `elem` mulopt -> show_term e1 ++ show_Bop bop ++ show_power e2
+     _ -> show_power e
+
+show_power e =
+  case e of
+    Pow b n -> show_aexp b ++ "^" ++ show n
+    _ -> show_aexp e
+
+show_aexp e =
+  case e of
+     Var -> "x"
+     Const x -> show x
+     Unop uop e | uop/=Uneg -> show_Uop uop ++ show_argexp e
+     e -> "(" ++ show_Exp e ++ ")"
+
+
+show_argexp e =
+  case show_aexp e of
+     s@('(' : _) -> s
+     s -> " " ++ s
diff --git a/Demos/graph/Simp.hs b/Demos/graph/Simp.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/Simp.hs
@@ -0,0 +1,61 @@
+module Simp where
+import Exp
+import Ops
+
+default(Int)
+
+add (Const x) (Const y) = Const (x + y)
+add (Const x) e = add e (Const x)
+ -- || add (Unop Uneg e) e2 = sub e2 e -- changes the order of terms, confusing
+add e (Unop Uneg e2) = sub e e2
+add (Binop Badd e1 e2) e3 = add e1 (add e2 e3)
+add e (Binop Bmul (k@(Const _)) e2) | e==e2 = mul (add k one) e
+add (Binop Bmul (k1@(Const _)) e1) (Binop Bmul (k2@(Const _)) e2) | e1==e2 = mul (add k1 k2) e1
+add e1 e2 = if e2==zero' then e1
+		else if e1==e2 then mul two e1
+		else Binop Badd e1 e2
+
+sub (Const x) (Const y) = Const (x - y)
+sub e1 (Unop Uneg e2) = add e1 e2
+sub e1 e2 = if e2==zero' then e1
+		else if e1==zero' then Unop Uneg e2
+		else if e1==e2 then zero'
+		else Binop Bsub e1 e2
+
+mul (Const x) (Const y) = Const (x * y)
+mul Var Var = pow Var 2
+mul Var (Pow Var n) = Pow Var (n+1)
+mul (Pow Var n) Var = Pow Var (n+1)
+mul (Pow Var n) (Pow Var m) = Pow Var (n+m)
+mul e (Const y) = mul (Const y) e
+mul e1 (Unop Uneg e2) = neg (mul e1 e2)
+mul (Unop Uneg e1) e2 = neg (mul e1 e2)
+mul e1 (Binop Bmul e2 e3) = mul (mul e1 e2) e3
+ -- || mul (k1 @ (Const _)) (Binop Bmul (k2 @ (Const _)) e) = mul (mul k1 k2) e
+mul e1 e2 = if e1==one then e2
+		else if e1==zero' then zero'
+		else if e1==minusone then neg e2
+		else Binop Bmul e1 e2
+
+div' (Const x) (Const y) = Const (x / y)
+div' e1 (Unop Uneg e2) = neg (div' e1 e2)
+div' (Unop Uneg e1) e2 = neg (div' e1 e2)
+div' (Binop Bmul (Const x) e) (Const y) = mul (Const (x/y)) e
+div' e1 e2 = if e2==one then e1
+		else Binop Bdiv e1 e2
+
+pow b 0 | b/=zero'= one
+pow b 1 = b
+pow b e = if b==one then one else Pow b e
+
+neg (Const x) = (Const (0.0 - x))
+neg (Unop Uneg e) = e
+neg e = Unop Uneg e
+
+inv e = div' one e
+
+zero' = Const 0.0
+one = Const 1.0
+two = Const 2.0
+minusone = neg one
+ce = Const . fromIntegral
diff --git a/Demos/graph/UserCoords.hs b/Demos/graph/UserCoords.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/UserCoords.hs
@@ -0,0 +1,41 @@
+module UserCoords where
+import Fudgets(Point(..))
+
+type Interval =(Double,Double)
+type Area = (Interval,Interval)
+
+wdw h (u1,u2) u = ftoi' (0.5+(u-u1)/(u2-u1)*real h)
+user w (u1,u2) u = (real u-0.5)/real w*(u2-u1)+u1
+
+userp ((Point w h),(xa,ya)) (Point x y) = (user w xa x,user h ya y)
+wdwp ((Point w h),(xa,ya)) (x,y) = Point (wdw w xa x) (wdw h ya y)
+
+zoom k (Point w h) (Point x y) (xa,ya) = (zoom2 k w x xa,zoom2 k h y ya)
+  where
+    zoom2 k tot rel ua@(u1,u2) = (zoom1 k u1 u0,zoom1 k u2 u0)
+      where
+        u0 = user tot ua rel
+	zoom1 k u u0 = k*(u-u0)+u0
+
+zoomin = zoom 0.5
+zoomout = zoom 2.0
+
+zoomrect sa p1 p2 =
+  let (nx1,ny1) = userp sa p1
+      (nx2,ny2) = userp sa p2
+  in ((nx1,nx2),(ny1,ny2))
+
+--
+
+real :: Int->Double
+real = fromIntegral
+
+ftoi :: Double->Int
+ftoi = floor
+
+ftoi' x =     let maxint = 32767 -- Xlib limitation
+	          max = real maxint
+	          negmax = 0.0-max
+	      in if x>max then maxint
+		 else if x<negmax then -maxint
+		 else ftoi x
diff --git a/Demos/graph/ZoomF.hs b/Demos/graph/ZoomF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/graph/ZoomF.hs
@@ -0,0 +1,84 @@
+module ZoomF(ZoomOutput(..),zoomF) where
+import AllFudgets
+
+data ZoomOutput
+  = ZoomIn Size Point
+  | ZoomOut Size Point
+  | ZoomRect Size Rect
+  | ZoomPick Size Point 
+  | ZoomResize Size
+  deriving (Eq,Show)
+
+zoomF fud = groupF startcmds zoomK0 fud
+  where
+    startcmds = map XCmd $ 
+                 [ConfigureWindow [CWBorderWidth 0],
+                 ChangeWindowAttributes [CWEventMask eventmask],
+		 clickGrab 1,
+		 clickGrab 3,
+		 GrabButton False (Button 2) []
+				 [ButtonPressMask,
+				 PointerMotionMask,
+				 ButtonReleaseMask]]
+    clickGrab n = GrabButton False (Button n) [] []
+    eventmask = [ButtonPressMask]
+
+    zoomK0 =
+	setFontCursor 130 $
+        allocNamedColorPixel defaultColormap bgColor $ \ bg ->
+        allocNamedColorPixel defaultColormap fgColor $ \ fg ->
+        wCreateGC rootGC (GCSubwindowMode IncludeInferiors:
+	                  GCFunction GXxor:
+			  invertColorGCattrs fg bg) $ \ gcinv ->
+        waitForMsg layoutsize $ \ size ->
+        zoomK gcinv size
+      where
+        layoutsize (Low (LEvt (LayoutSize size))) = Just size
+	layoutsize _ = Nothing
+
+    zoomK gcinv size =
+        getK $ message low high
+      where
+        same = zoomK gcinv size
+	high _ = same
+	low event =
+	  case event of
+	    XEvt ButtonEvent {pos=p,state=mods} | Shift `elem` mods ->
+		  put (ZoomPick size p) same
+	    XEvt ButtonEvent {pos=p,button=Button 1} -> put (ZoomIn size p) same
+	    XEvt ButtonEvent {pos=p,button=Button 3} -> put (ZoomOut size p) same
+	    XEvt ButtonEvent {pos=p,button=Button 2,type'=Pressed} ->
+	      putLow (wDrawRectangle gcinv (Rect p (Point 1 1))) $
+	      rubberBandK gcinv size p p $ \ size' ->
+	      zoomK gcinv size'
+	    --XEvt MotionNotify {} ->
+	    LEvt (LayoutSize size') ->
+	      put (ZoomResize size') $
+	      zoomK gcinv size'
+	    _ -> same
+
+rubberBandK gcinv size p0 p1 return =
+     getK $ message low high
+  where
+    cont p = rubberBandK gcinv size p0 p return
+    resize size' = rubberBandK gcinv size' p0 p1 return
+    same = cont p1
+    toggle p0 p1 = putLow $ wDrawRectangle gcinv (rect' p0 p1)
+    high _ = same
+    low event =
+      case event of
+        XEvt MotionNotify {pos=p} ->
+	  toggle p0 p1 $
+	  toggle p0 p $
+	  cont p
+	XEvt ButtonEvent {pos=p,type'=Released,button=Button 2} ->
+	  toggle p0 p1 $
+	  put (ZoomRect size (rect' p0 p1)) $
+	  return size
+        LEvt (LayoutSize size') -> resize size'
+	_ -> same
+
+rect' p1 p2 =
+  let p0 = pmin p1 p2
+      p = pmax p1 p2
+  in Rect p0 (p-p0+1)
diff --git a/Demos/life/Generate.hs b/Demos/life/Generate.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Generate.hs
@@ -0,0 +1,17 @@
+module Generate where
+
+import Utils2
+
+generate (bounds,g) = (bounds,newg)
+    where (xm,ym) = bounds
+	  wrap u m = (u+m) `mod` m
+	  newg = (cond g . foldl insert [] . reverse) [(wrap u xm, wrap v ym) | (x,y) <- g, u <- [x-1..x+1], v <- [y-1..y+1]]
+	  insert (pn@(p1,n):l) p | p == p1 = (p1,n+1):l
+				 | p > p1  = pn : insert l p
+	  insert l p = (p,1) : l
+	  cond l ((p,n):nbs) = if not lived && n == 3 || lived && (n == 3 || n == 4) then p : rest else rest
+			       where (l',lived) = mapgen (\l->(l,True)) (flip const) (\l->(l,False)) p l
+				     rest = cond l' nbs 
+	  cond _ [] = []
+
+	
diff --git a/Demos/life/Life.hs b/Demos/life/Life.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Life.hs
@@ -0,0 +1,40 @@
+module Life{-(life)-} where
+import AllFudgets
+import Utils2
+
+life :: Int -> Generation -> F LifeCmds LifeEvts
+--life cellsize (bnds,gen) = simpleF "Life" lifeK (topoint s0 bnds) s0
+life cellsize (bnds,gen) = simpleWindowF lifeK (topoint s0 bnds) False False s0
+			      where s0 = (cellsize,bnds,gen)
+
+pointPair (x,y) = Point x y
+pairPoint (Point x y) = (x,y)
+
+--fillCircle pos d = let s = Point d d in FillArc (Rect pos s) 0 (64 * 360)
+
+lifeK draw clear s event = 
+    case event of
+       High (NewCell (pos,l))      -> (s1, pattern s1 pos l) where s1 = sGen (setgen l pos (gen s)) s
+       High (NewGen (nb,ng))       -> (s1, redrawgen s1) where s1 = sGen ng (sBnds nb s)
+       High (NewCellSize ncs)      -> (s1,[(High . NewBounds . topos s1 . topoint s . bnds) s]) where s1 = sCellsize ncs s
+       Low (XEvt (Expose _ 0))     -> (s,redrawgen s)
+       Low (XEvt (ButtonEvent _ p _ _ Pressed _)) -> (s,[(High . MouseClick . topos s) p])
+       Low (LEvt (LayoutSize nsize)) -> (s, [(High . NewBounds . topos s) nsize])
+       _ -> (s,[])
+
+    where
+	pattern s p l = map (Low . (if l then draw else clear)) [fillCircle (topoint s p) (truncate (cellsize s))]
+	redrawgen s = Low (XCmd ClearWindow) : concat [pattern s p True | p <- gen s] ++ [Low $ XCmd Flush]
+
+topoint s = scalePoint (cellsize s) . pointPair
+topos s = pairPoint . scalePoint (1 / (cellsize s))
+
+cellsize (cs,b,g) = (fromIntegral cs)
+bnds     (cs,b,g) = b
+gen      (cs,b,g) = g
+xm = fst . bnds
+ym = snd . bnds
+
+sCellsize cs1 (cs,b,g) = (cs1,b,g)
+sBnds     b1  (cs,b,g) = (cs,b1,g)
+sGen      g1  (cs,b,g) = (cs,b,g1)
diff --git a/Demos/life/Main.hs b/Demos/life/Main.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Main.hs
@@ -0,0 +1,31 @@
+module Main(main,control) where
+
+import Fudgets
+import Life
+import Utils2
+import Panel
+import Generate
+
+--import NonStdTrace
+
+main = fudlogue $ shellF "Life" (hBoxF control)
+
+control = loopLeftF ((Left >^=< life defaultcellsize s0) >==< absF (mapstateSP c s0)) >==< panel
+    where c state@(bounds@(xm,ym), gen) msg = 
+	      case msg of
+	          Left fromMatrix ->
+                     case fromMatrix of
+			 MouseClick p -> ((bounds,newgen), [NewCell (p,newcell)])
+			     where (newgen,newcell) = togglegen p gen
+
+			 NewBounds (b@(xm,ym)) -> redraw (b,[(x,y) | (x,y) <- gen, x < xm, y < ym])
+		  Right fromPanel ->
+		      case fromPanel of
+			  Right newSize -> (state, [NewCellSize newSize])
+			  Left tick -> redraw (generate state)
+		  _ -> (state,[])
+	  redraw ns = (ns,[NewGen ns])
+	    
+bounds0 = (20,20)
+
+s0 = (bounds0,[])
diff --git a/Demos/life/Panel.hs b/Demos/life/Panel.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Panel.hs
@@ -0,0 +1,20 @@
+module Panel  where -- (panel,defaultcellsize) where
+
+import Fudgets
+import Timer
+{-
+quitShell title f = shellF title 
+	  (stripEither >^=< (f >+< quitButtonF) >=^< Left)
+-}
+panel = {-shellF "Panel"-}
+        (noStretchF True True $ vBoxF $ runButton >+< sizegroup)
+
+runButton = timer interval >==< toggleButtonF "Run" 
+
+interval = argReadKey "interval" 200 -- milliseconds
+
+sizegroup = radioGroupF sizes defaultcellsize
+
+sizes = [(3::Int,"Tiny"), (5,"Small"),(10,"Medium"),(25,"Huge")]
+
+defaultcellsize = fst (sizes !! 2)
diff --git a/Demos/life/Timer.hs b/Demos/life/Timer.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Timer.hs
@@ -0,0 +1,6 @@
+module Timer(timer) where
+
+import Fudgets
+
+timer :: Int -> F Bool Tick
+timer t = timerF >=^< \b -> if b then Just (t,0) else Nothing
diff --git a/Demos/life/Utils2.hs b/Demos/life/Utils2.hs
new file mode 100644
--- /dev/null
+++ b/Demos/life/Utils2.hs
@@ -0,0 +1,20 @@
+module Utils2 where
+
+import HbcUtils(apFst)
+
+type Life = Bool
+type Pos = (Int, Int)
+type Bounds = Pos
+type Generation = (Bounds,[Pos])
+
+data LifeCmds = NewCell (Pos, Life) | NewGen Generation | NewCellSize Int
+data LifeEvts = NewBounds Bounds | MouseClick Pos
+
+mapgen found more notfound p l = mg l
+    where mg (p1:l) | (p == p1) = found l
+	            | (p >  p1) = more p1 (mg l)
+	  mg l = notfound l
+
+togglegen p = mapgen (\l->(l,False)) (apFst . (:)) (\l->(p:l,True)) p
+setgen t p = mapgen c (:) c p where c = if t then (p:) else id
+
diff --git a/Demos/mines/Box.hs b/Demos/mines/Box.hs
new file mode 100644
--- /dev/null
+++ b/Demos/mines/Box.hs
@@ -0,0 +1,59 @@
+module Box(boxF,readAllBitmaps) where
+import AllFudgets
+import HbcUtils(lookupWithDefault)
+import MineField
+import Pics
+
+pictSize :: Size
+pictSize = Point 32 32
+
+initcmds = [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]], but 1, but 2, but 3] 
+           where but t = XCmd $ GrabButton True (Button t) [] [ButtonPressMask, ButtonReleaseMask]
+
+boxF :: [(Symbol,PixmapId)] -> F Symbol (Coord -> MInput)
+boxF sps = windowF initcmds (simpleK (boxK sps) pictSize SBlank)
+
+boxK :: [(Symbol,PixmapId)] -> Drawer -> Drawer -> Fms' Symbol Symbol (Coord -> MInput)
+boxK ps draw _clear s event =
+    case event of
+      High s'                                              -> (s', redraw ps s')
+      Low (XEvt (Expose _ 0))                              -> (s, redraw ps s)
+      Low (XEvt (ButtonEvent _ _ _ ms Pressed (Button b))) ->
+          (s, case (ms,b) of
+                ([]       ,1) -> [High Move]
+                ([Control],1) -> [High Bomb]
+                ([Shift]  ,1) -> [High Free]
+                (_        ,2) -> [High Bomb]
+                (_        ,3) -> [High Free]
+                _             -> [])
+--    Low (LayoutSize nsize)                     -> (s, ??)
+      _ -> (s,[])
+    where redraw ps SBlank = [Low $ XCmd ClearWindow]
+          redraw ps s = 
+		let p = lookupWithDefault ps (error ("No bitmap for "++show s)) s
+		in  [Low $ XCmd ClearWindow, Low (draw (CopyPlane (Pixmap p) (Rect 0 pictSize) 0 0))]
+{-
+          redraw ps (SNumber 0) = [Low ClearWindow, Low (draw (CopyPlane (Pixmap ps) (Rect (Point 0 0) (Point 32 32)) (Point 0 0) 0))]
+          redraw ps (SNumber n) = [Low ClearWindow, Low (draw (DrawImageString tp (show n)))]
+          redraw ps (SCurrent n) = [Low ClearWindow, Low (draw (DrawImageString tp ("X"++show n)))]
+	  redraw ps SBombX = [Low ClearWindow, Low (draw (DrawImageString tp "BX"))]
+	  redraw ps SBombDone = [Low ClearWindow, Low (draw (DrawImageString tp "BD"))]
+	  redraw ps SBomb = [Low ClearWindow, Low (draw (DrawImageString tp "B"))]
+	  redraw ps SFree = [Low ClearWindow, Low (draw (DrawImageString tp "F"))]
+tp = Point 10 18
+-}
+
+bitmaps = 
+    [(SNumber n,num!!n) | n<-[0..5]] ++
+    [(SCurrent n,cur!!n) | n<-[0..5]] ++
+    [(SBombX, bombx), (SBombDone, bombdone), (SBomb, bomb), (SFree, free)]
+
+readAllBitmaps f = readBitmaps bitmaps f
+
+--readBitmaps :: [(Symbol,String)] -> ([PixmapId] -> K a b) -> K a b
+readBitmaps ns f = readb [] ns f
+	where readb ps [] f = f ps
+              readb ps ((n,bm):ns) f = bitmapFromData bm $ \r ->
+	                          case r of
+				    BitmapBad -> error ("Cannot read bitmap "++show n)
+				    BitmapReturn _ _ p -> readb (ps++[(n,p)]) ns f
diff --git a/Demos/mines/FUtil.hs b/Demos/mines/FUtil.hs
new file mode 100644
--- /dev/null
+++ b/Demos/mines/FUtil.hs
@@ -0,0 +1,35 @@
+module FUtil(module FUtil,F) where
+import Fudgets
+
+ignoreI :: F a b -> F aa b
+ignoreI f = f >=^< (\x->error "ignoreI") 
+ignoreO :: F a b -> F a bb
+ignoreO f = (\x->error "ignoreO") >^=< f
+
+stripLeftF = concatMapF g where g (Left x) = [x]; g _ = []
+stripRightF = concatMapF g where g (Right x) = [x]; g _ = []
+
+{-
+debugF :: (a ->String) -> (b->String) -> String -> F a b -> F a b
+debugF iShow oShow title f =
+	let disp s = labLeftOfF s displayF
+	    it = disp "Input: "
+	    im = disp "                              "
+	    ot = disp "Output:"
+	    om = im
+	    ts = ignoreI (untaggedListLF verticalP [it, ot])
+	    ms = untaggedListLF verticalP [im, om] >=^< (\x->case x of { Right x -> (0,iShow x); Left y -> (1,oShow y)})
+	    box = untaggedListLF horizontalP [ts, ms] >=^< (\x->(1,x))
+	    shell = shellF ("Debug - "++title) box
+	    tb :: F a b -> F a (Either b a)
+	    tb f = idRightF f >==< toBothF
+--	    g (Right (Left x)) = [x]
+--	    g _             = []
+	in  stripLeftF >==< stripRightF >==< tb shell >==< tb f
+
+debugShowF t f = debugF show show t f
+-}
+
+intWF :: Int -> Int -> F Int (InputMsg Int)
+intWF s n = startupF [n] intF
+
diff --git a/Demos/mines/MineField.hs b/Demos/mines/MineField.hs
new file mode 100644
--- /dev/null
+++ b/Demos/mines/MineField.hs
@@ -0,0 +1,186 @@
+module MineField(MInput(..),MOutput(..),Symbol(..),Coord(..),play,playSP,initMineCount,mineFieldSize) where
+--import RandomHBC(randomInts)
+import System.Random(StdGen,randomRs,split)
+import Data.List(union, intersect)
+import Fudgets(getSP,putsSP) -- SP operations
+import Data.Array
+import Data.List((\\),nub)
+
+type Coord = (Int,Int)			-- mine field coordinate
+type RandInt = Int
+type MineCount = Int
+type MineField = Array (Int,Int) Bool 	-- number of mines and the array representing the mine field
+data Moves = Moves Coord [Coord] [Coord] -- current pos, places, border
+	     deriving (Eq, Ord{-, Text-})
+
+mineFieldSizeX, mineFieldSizeY :: Int
+mineFieldSizeX = 12
+mineFieldSizeY = 12
+mineFieldSize :: Coord
+mineFieldSize = (mineFieldSizeX, mineFieldSizeY)
+
+newField :: StdGen -> MineCount -> MineField			-- random numbers gives a new field
+newField g n =
+  let (nx, ny) = mineFieldSize
+    --rs = newRands r
+    --xs = map (`rem` nx) (everyOther rs)
+    --ys = map (`rem` ny) (everyOther (tail rs))
+      (g1,g2) = split g
+      ps = randomRs (1,nx) g1 `zip` randomRs (1,ny) g2
+      xys = take ((n `min` (nx * ny)) `max` 0) $
+            nub (ps \\ [(1,1),mineFieldSize])
+      b = ((0,0),(nx+1,ny+1))
+  in  array b [(p, p `elem` xys) | p<-range b]
+
+
+
+--newRands r = randomInts ((r `max` 1) `min` 2147483562) (((r+123457) `max` 1) `min` 2147483398)
+--everyOther (x:_:xs) = x:everyOther xs
+
+initMoves = Moves (1,1) [(1,1)] [(1,2), (2,1), (2,2)]
+
+moveTo :: Moves -> Coord -> Maybe Moves
+moveTo (Moves _ visited border) xy | xy `elem` border =
+        let visited' = xy:visited
+	in  Just (Moves xy visited' (union border (neighbours xy) \\ visited'))
+moveTo (Moves _ visited border) xy | xy `elem` visited =
+	Just (Moves xy visited border)
+moveTo _ _ = Nothing
+	
+neighbours :: Coord -> [Coord]
+neighbours (x,y) = 
+	let (xm,ym) = mineFieldSize
+	in  [(xi,yi) | xi<-[x-1..x+1], xi>0 && xi<=xm, yi<-[y-1..y+1], yi>0 && yi<=ym]
+
+data Symbol = SBlank | SNumber Int | SCurrent Int | SFree | SBomb | SBombX | SBombDone deriving (Eq, Ord, Show)
+data MInput = Move Coord | Bomb Coord | Free Coord | Hint | New | SetSize Int | Noop deriving (Eq, Ord{-, Text-})
+data MOutput = Repaint [(Coord, Symbol)] | Msg String | Status String deriving (Eq, Ord{-, Text-})
+type Counters = (Int,Int) -- moves, hints
+type Bombs = [Coord]
+data State = Go StdGen MineCount MineField Moves Counters Bombs Bombs
+           | Stop StdGen MineCount
+           --deriving (Eq, Ord{-, Text-})
+
+initMineCount :: MineCount
+initMineCount = 26
+newState :: StdGen -> MineCount -> State
+newState g n = Go g1 n (newField g2 n) initMoves (0, 0) [] []
+  where (g1,g2) = split g
+doMove :: State -> MInput -> (State, [MOutput])
+doMove s@(Go rs n mf ms c@(i,j) bs fs) (Move xy) =
+    if xy `elem` bs then
+	(s, [])
+    else
+	case moveTo ms xy of
+	   Nothing -> (s, [])
+	   Just ms' -> 
+	        let c' = (i+1,j) in
+		if mf ! xy then
+		    let as = allBombs mf in
+		    (Stop rs n, [Msg "You just exploded!", stat c' bs fs, Repaint [paintBomb bs a | a<-as], Repaint [(xy,SBombX) | xy<-bs, xy `notElem` as]])
+		else 
+		    if xy == mineFieldSize then
+		        (Stop rs n, [Msg "You honestly made it!", stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])
+		    else
+		        (Go rs n mf ms' c' bs fs, [Msg (mineMsg mf xy), stat c' bs fs, Repaint (map (paint mf ms' bs) (changes ms ms'))])
+doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Bomb xy) =
+        if xy `elem` vis then
+	    (s, [])
+	else if xy `elem` bs then
+	    let bs' = bs \\ [xy] in (Go rs n mf ms c bs' fs,          [stat c bs' fs, Repaint [(xy, SBlank)]])
+	else
+	    let bs' = xy:bs
+                fs' = fs \\ [xy]
+            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SBomb)]])
+doMove s@(Go rs n mf ms@(Moves _ vis _) c bs fs) (Free xy) =
+        if xy `elem` vis then
+	    (s, [])
+	else if xy `elem` fs then
+	    let fs' = fs \\ [xy] in (Go rs n mf ms c bs fs',          [stat c bs fs', Repaint [(xy, SBlank)]])
+	else
+	    let fs' = xy:fs
+                bs' = bs \\ [xy]
+            in  (Go rs n mf ms c bs' fs', [stat c bs' fs', Repaint [(xy, SFree)]])
+doMove (Go rs n _ _ _ _ _) New = doMove (Stop rs n) New
+doMove (Stop rs n) New =
+	let (s@(Go _ _ a _ _ _ _), os) = doMove (newState rs n) (Move (1,1))
+	in  (s, Repaint [((x,y), SBlank) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY]] : Repaint [((1,1), SCurrent (countBombs a (1,1)))] : stat (0,0) [] []:os)
+doMove (Go rs _ mf ms c bs fs) (SetSize n) = (Go rs n mf ms c bs fs, [])
+doMove (Go rs n mf ms@(Moves _ _ ps) (i,j) bs fs) Hint = 
+        let m = case filter (\xy->not (mf ! xy)) ps of
+                  [] -> Msg "Impossible"
+		  xy:_ -> Repaint [(xy, SFree)]
+            c' = (i,j+1)
+        in  (Go rs n mf ms c' bs fs, [stat c' bs fs, m])
+doMove (Stop rs _) (SetSize n) = (Stop rs n, [])
+doMove s _ = (s, [])
+
+stat :: Counters -> Bombs -> Bombs -> MOutput
+stat (i, j) bs fs = Status ("Moves: "++show i++"   Hints: "++show j++"   Safes: "++show (length fs)++"   Mines: "++show (length bs))
+
+mineMsg a xy =
+	case countBombs a xy of
+	   0 -> "No mines nearby."
+	   1 -> "1 mine nearby."
+	   n -> shows n " mines nearby."
+
+changes :: Moves -> Moves -> [Coord]
+changes (Moves cur vis bor) (Moves cur' vis' bor') =
+	let chg l l' = union l l' \\ intersect l l'
+	in  nub (chg [cur] [cur'] ++ chg vis vis' ++ chg bor bor')
+
+paint :: MineField -> Moves -> Bombs -> Coord -> (Coord, Symbol)
+paint a (Moves cur vis _) bs xy =
+	(xy, 
+	if xy == cur then
+	    SCurrent (countBombs a xy)
+	else if xy `elem` vis then
+	    SNumber (countBombs a xy)
+	else if xy `elem` bs then
+	    SBomb
+	else
+	    SBlank)
+
+countBombs a = length . filter id . map (a!) . neighbours
+
+allBombs a = [(x,y) | x<-[1..mineFieldSizeX], y<-[1..mineFieldSizeY], a!(x,y)]
+
+paintBomb bs xy =
+	(xy,
+	if xy `elem` bs then
+		SBomb
+	else
+		SBombDone)
+
+firstState :: StdGen -> (State, [MOutput])
+firstState g =
+	{-let r = truncate d
+	in-}  doMove (newState g initMineCount) New
+
+stripR = filter f where f (Repaint []) = False
+                        f _ = True
+
+doMoves :: State -> [MInput] -> [[MOutput]]
+doMoves s [] = []
+doMoves s (i:is) =
+	let (s', os) = doMove s i
+	in  stripR os : doMoves s' is
+
+play :: StdGen -> [MInput] -> [[MOutput]]
+play d is =
+	let (s, os) = firstState d
+	in  stripR os : doMoves s is
+
+
+-- Stream Processor version of play & doMoves (hallgren 930525):
+
+--doMovesSP :: State -> SP MInput MOutput
+doMovesSP s =
+	getSP $ \i ->
+	let (s', os) = doMove s i
+	in  putsSP (stripR os) $ doMovesSP s'
+
+--playSP :: Double -> SP MInput MOutput
+playSP d =
+	let (s, os) = firstState d
+	in  putsSP (stripR os) $ doMovesSP s
diff --git a/Demos/mines/Pics.hs b/Demos/mines/Pics.hs
new file mode 100644
--- /dev/null
+++ b/Demos/mines/Pics.hs
@@ -0,0 +1,200 @@
+module Pics where
+import AllFudgets(BitmapData(..),pP)
+
+bm w h = BitmapData (pP w h) Nothing
+
+cur = [cur_0,cur_1,cur_2,cur_3,cur_4,cur_5]
+num = [num_0,num_1,num_2,num_3,num_4,num_5]
+
+bomb = bm 32 32 bomb_bits
+bomb_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x81, 0x01, 0x00, 0x80, 0xa1, 0x02, 0x00, 0x80,
+   0x21, 0x30, 0x00, 0x80, 0x05, 0x24, 0x00, 0x80, 0x39, 0x09, 0x00, 0x80,
+   0xa1, 0x00, 0x00, 0x80, 0x81, 0x00, 0x00, 0x80, 0x81, 0x00, 0x00, 0x80,
+   0x05, 0xc7, 0x07, 0x80, 0x39, 0xef, 0x1f, 0x80, 0x01, 0xdf, 0x3f, 0x80,
+   0x01, 0xde, 0x7f, 0x80, 0x01, 0xdc, 0xff, 0x80, 0x01, 0xe2, 0xff, 0x80,
+   0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81,
+   0x01, 0xff, 0xff, 0x81, 0x01, 0xff, 0xff, 0x81, 0x01, 0xfe, 0xff, 0x80,
+   0x01, 0xfe, 0xff, 0x80, 0x01, 0xfc, 0x7f, 0x80, 0x01, 0xf8, 0x3f, 0x80,
+   0x01, 0xf0, 0x1f, 0x80, 0x01, 0xc0, 0x07, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+bombdone = bm 32 32 bombdone_bits
+bombdone_bits = [
+ 0xff,0xff,0xff,0xff,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,0xc0,0x00,0x00,0x00,
+ 0xc0,0xc0,0x00,0x00,0xc0,0x50,0x01,0x00,0xc0,0x10,0x18,0x00,0xc0,0x02,0x12,
+ 0x00,0xc0,0x9c,0x04,0x00,0xc0,0x50,0x00,0x00,0xc0,0x40,0x00,0x00,0xc0,0x40,
+ 0x00,0x00,0xc0,0x82,0xe3,0x03,0xc0,0x9c,0xf7,0x0f,0xc0,0x80,0xef,0x1f,0xc0,
+ 0x00,0xef,0x3f,0xc0,0x00,0xee,0x7f,0xc0,0x00,0x31,0x7e,0xc0,0x80,0x1f,0xfc,
+ 0xc0,0x80,0x0f,0xf8,0xc0,0x80,0x07,0xf0,0xc0,0x80,0x07,0xf0,0xc0,0x80,0x07,
+ 0xf0,0xc0,0x00,0x0f,0x78,0xc0,0x00,0x1f,0x7c,0xc0,0x00,0x3e,0x3e,0xc0,0x00,
+ 0xfc,0x1f,0xc0,0x00,0xf8,0x0f,0xc0,0x00,0xe0,0x03,0xc0,0x00,0x00,0x00,0xc0,
+ 0x00,0x00,0x00,0xc0,0xff,0xff,0xff,0xff]
+bombx = bm 32 32 bombx_bits
+bombx_bits = [
+ 0x00,0x00,0x00,0x80,0xfc,0xff,0xff,0x8f,0xf8,0xff,0xff,0x87,0xf1,0xff,0xff,
+ 0xa3,0x23,0xff,0xff,0xb1,0x87,0xfe,0xff,0xb8,0x8f,0xe7,0x7f,0xbc,0x1d,0xed,
+ 0x3f,0xbe,0x23,0xfa,0x1f,0xbf,0x2f,0xfc,0x8f,0xbf,0xbf,0xfc,0xc7,0xbf,0xbf,
+ 0xff,0xe7,0xbf,0x7d,0x1c,0xfc,0xbf,0x63,0x08,0xf0,0xbf,0x7f,0x10,0xe0,0xbf,
+ 0xff,0x10,0xc0,0xbf,0xff,0x11,0x80,0xbf,0xff,0x0e,0x80,0xbf,0x7f,0x00,0x00,
+ 0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,0x00,0xbf,0x7f,0x00,
+ 0x00,0xbf,0xff,0x00,0x80,0xbf,0x9f,0x00,0x80,0xbf,0x8f,0x01,0xc0,0xbc,0xc7,
+ 0x03,0xe0,0xb8,0xe3,0x07,0xf0,0xb1,0xf1,0x1f,0xfc,0xa3,0xf8,0xff,0xff,0x87,
+ 0xfc,0xff,0xff,0x8f,0x00,0x00,0x00,0x80]
+cur_0 = bm 32 32 cur_0_bits
+cur_0_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,
+ 0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x0e,
+ 0x00,0x80,0x01,0x11,0x00,0x80,0x01,0x11,0x00,0x80,0x01,0x11,0x00,0x80,0x01,
+ 0x0e,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0x00,0x80,
+ 0x81,0x3f,0x00,0x80,0x01,0x04,0x00,0x80,0x01,0x04,0xe0,0x80,0x01,0x04,0x10,
+ 0x81,0x01,0x04,0x10,0x81,0x01,0x04,0x90,0x81,0x01,0x04,0x50,0x81,0x01,0x04,
+ 0x30,0x81,0x01,0x0a,0x10,0x81,0x01,0x11,0x10,0x81,0x01,0x11,0xe0,0x80,0x81,
+ 0x20,0x00,0x80,0x41,0x40,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+cur_1 = bm 32 32 cur_1_bits
+cur_1_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,
+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,
+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,
+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x60, 0x80,
+   0x01, 0x04, 0x50, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80,
+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x0a, 0x40, 0x80,
+   0x01, 0x11, 0x40, 0x80, 0x01, 0x11, 0xf0, 0x81, 0x81, 0x20, 0x00, 0x80,
+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+cur_2 = bm 32 32 cur_2_bits
+cur_2_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,
+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,
+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,
+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xe0, 0x80,
+   0x01, 0x04, 0x10, 0x81, 0x01, 0x04, 0x00, 0x81, 0x01, 0x04, 0x80, 0x80,
+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x20, 0x80, 0x01, 0x0a, 0x10, 0x80,
+   0x01, 0x11, 0x10, 0x80, 0x01, 0x11, 0xf0, 0x81, 0x81, 0x20, 0x00, 0x80,
+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+cur_3 = bm 32 32 cur_3_bits
+cur_3_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,
+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,
+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,
+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xe0, 0x80,
+   0x01, 0x04, 0x10, 0x81, 0x01, 0x04, 0x00, 0x81, 0x01, 0x04, 0x00, 0x81,
+   0x01, 0x04, 0xc0, 0x80, 0x01, 0x04, 0x00, 0x81, 0x01, 0x0a, 0x00, 0x81,
+   0x01, 0x11, 0x10, 0x81, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,
+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+cur_4 = bm 32 32 cur_4_bits
+cur_4_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,
+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,
+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,
+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x60, 0x80,
+   0x01, 0x04, 0x50, 0x80, 0x01, 0x04, 0x48, 0x80, 0x01, 0x04, 0xfc, 0x80,
+   0x01, 0x04, 0x40, 0x80, 0x01, 0x04, 0x40, 0x80, 0x01, 0x0a, 0x40, 0x80,
+   0x01, 0x11, 0x40, 0x80, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,
+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+cur_5 = bm 32 32 cur_5_bits
+cur_5_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80,
+   0x01, 0x11, 0x00, 0x80, 0x01, 0x11, 0x00, 0x80, 0x01, 0x0e, 0x00, 0x80,
+   0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80,
+   0x81, 0x3f, 0x00, 0x80, 0x01, 0x04, 0x00, 0x80, 0x01, 0x04, 0xf0, 0x81,
+   0x01, 0x04, 0x10, 0x80, 0x01, 0x04, 0x10, 0x80, 0x01, 0x04, 0x20, 0x80,
+   0x01, 0x04, 0xc0, 0x80, 0x01, 0x04, 0x00, 0x81, 0x01, 0x0a, 0x00, 0x81,
+   0x01, 0x11, 0x10, 0x81, 0x01, 0x11, 0xe0, 0x80, 0x81, 0x20, 0x00, 0x80,
+   0x41, 0x40, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+free = bm 32 32 free_bits
+free_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,
+ 0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,
+ 0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,
+ 0x00,0x02,0x80,0x01,0x00,0x02,0x80,0x01,0x38,0x12,0x80,0x01,0x44,0x0a,0x80,
+ 0x01,0x44,0x06,0x80,0x01,0x44,0x06,0x80,0x01,0x44,0x0a,0x80,0x01,0x44,0x12,
+ 0x80,0x01,0x38,0x22,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,
+ 0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,
+ 0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,0x01,0x00,0x00,0x80,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+num_0 = bm 32 32 num_0_bits
+num_0_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,
+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,
+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,
+ 0x82,0x83,0xaa,0x55,0x41,0x44,0x95,0xa9,0x42,0x84,0xaa,0x55,0x41,0x46,0x95,
+ 0xa9,0x42,0x85,0xaa,0x55,0xc1,0x44,0x95,0xa9,0x42,0x84,0xaa,0x55,0x41,0x44,
+ 0x95,0xa9,0x82,0x83,0xaa,0x55,0x01,0x40,0x95,0xa9,0x02,0x80,0xaa,0x55,0x55,
+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,
+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+num_1 = bm 32 32 num_1_bits
+num_1_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,
+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,
+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,
+ 0x82,0xa0,0xaa,0x55,0xc1,0x40,0x95,0xa9,0xa2,0xa0,0xaa,0x55,0x81,0x40,0x95,
+ 0xa9,0x82,0xa0,0xaa,0x55,0x81,0x40,0x95,0xa9,0x82,0xa0,0xaa,0x55,0x81,0x40,
+ 0x95,0xa9,0xe2,0xa3,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,
+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,
+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+num_2 = bm 32 32 num_2_bits
+num_2_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,
+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,
+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,
+ 0xc2,0xa1,0xaa,0x55,0x21,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x01,0x42,0x95,
+ 0xa9,0x02,0xa1,0xaa,0x55,0x81,0x40,0x95,0xa9,0x42,0xa0,0xaa,0x55,0x21,0x40,
+ 0x95,0xa9,0xe2,0xa3,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,
+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,
+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+num_3 = bm 32 32 num_3_bits
+num_3_bits = [
+ 0xff,0xff,0xff,0xff,0x01,0x00,0x00,0x80,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,
+ 0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,
+ 0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x01,0x40,0x95,0xa9,
+ 0xc2,0xa1,0xaa,0x55,0x21,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x01,0x42,0x95,
+ 0xa9,0x82,0xa1,0xaa,0x55,0x01,0x42,0x95,0xa9,0x02,0xa2,0xaa,0x55,0x21,0x42,
+ 0x95,0xa9,0xc2,0xa1,0xaa,0x55,0x01,0x40,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,
+ 0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,
+ 0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,0x55,0x55,0x55,0x95,0xa9,0xaa,0xaa,0xaa,
+ 0x01,0x00,0x00,0x80,0xff,0xff,0xff,0xff]
+num_4 = bm 32 32 num_4_bits
+num_4_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x01, 0x40, 0x95, 0xa9, 0x82, 0xa1, 0xaa,
+   0x55, 0x41, 0x41, 0x95, 0xa9, 0x22, 0xa1, 0xaa, 0x55, 0x11, 0x41, 0x95,
+   0xa9, 0xf2, 0xa3, 0xaa, 0x55, 0x01, 0x41, 0x95, 0xa9, 0x02, 0xa1, 0xaa,
+   0x55, 0x01, 0x41, 0x95, 0xa9, 0x82, 0xa3, 0xaa, 0x55, 0x01, 0x40, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
+num_5 = bm 32 32 num_5_bits
+num_5_bits = [
+   0xff, 0xff, 0xff, 0xff, 0x01, 0x00, 0x00, 0x80, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x01, 0x40, 0x95, 0xa9, 0xe2, 0xa3, 0xaa,
+   0x55, 0x21, 0x40, 0x95, 0xa9, 0x22, 0xa0, 0xaa, 0x55, 0x41, 0x40, 0x95,
+   0xa9, 0x82, 0xa1, 0xaa, 0x55, 0x01, 0x42, 0x95, 0xa9, 0x02, 0xa2, 0xaa,
+   0x55, 0x21, 0x42, 0x95, 0xa9, 0xc2, 0xa1, 0xaa, 0x55, 0x01, 0x40, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95,
+   0xa9, 0xaa, 0xaa, 0xaa, 0x55, 0x55, 0x55, 0x95, 0xa9, 0xaa, 0xaa, 0xaa,
+   0x01, 0x00, 0x00, 0x80, 0xff, 0xff, 0xff, 0xff]
diff --git a/Demos/mines/XMine.hs b/Demos/mines/XMine.hs
new file mode 100644
--- /dev/null
+++ b/Demos/mines/XMine.hs
@@ -0,0 +1,60 @@
+module Main where
+--import Trace
+--import Word
+import Fudgets
+import FUtil
+import MineField
+--import BitMaps
+--import Time
+import System.Random(newStdGen)
+import Box
+
+main = newStdGen >>= fudlogue . shellF "FXMines v1.2" . xmines
+
+--getTimeDouble = randomRIO (0,2e9)
+                  
+
+--myFont = defaultFont
+--separation = 5::Int
+
+xmines d =
+  let title = nullF -- untaggedListLF horizontalP [labelF "FXMines v1.2"]
+      controls = untaggedListLF horizontalP [labelF "Mine count", inp initMineCount, bf "Hint" Hint, bf "Restart" New{-, bq "Quit"-}]
+      msg1 = disp ""
+      msg2 = disp ""
+      panel = untaggedListLF verticalP [ignoreI title,  		-- 0
+                                        ignoreI controls, 		-- 1
+                                        msg1 >=^< (\(Status s)->s),	-- 2
+                                        msg2 >=^< (\(Msg s)->s), 	-- 3
+                                        boxes' >=^< (\(Repaint l)->l)] >=^< directMsg -- 4
+                             where directMsg m@(Repaint l) = (4, m)
+                                   directMsg m@(Msg s)     = (3, m)
+                                   directMsg m@(Status s)  = (2, m)
+      but s = buttonF s
+      bf s f = (\_ -> f) >^=< but s
+      bq s = quitF >==< but s
+      disp s = displayF
+      inp n = (\x->case x of { InputChange n -> SetSize n; _ -> Noop} ) >^=< ignoreI (intWF 8 n)
+      (xn, yn) = mineFieldSize
+      boxes = mapstateSP action Move >^^=< vBoxF (actionF >+< boxes1) >=^< Right
+        where
+          action _ (Left (Fun f)  ) = (f,[])
+          action f (Right (Move p)) = (f,[f p])
+          action f (Right m       ) = (f,[m])
+
+      actionF =
+        radioGroupF' (setPlacer (spacerP centerS horizontalP) .
+                      setLabelInside True)
+                     [(Fun Move,"Move"),(Fun Free,"ok"),(Fun Bomb,"Bomb")]
+                     (Fun Move)
+
+      boxes1 :: F [(Coord, Symbol)] MInput
+      boxes1 = readAllBitmaps $ \ ps ->
+              (\(a,f)->f a) >^=< listLF (matrixP xn) [((x,y), boxF ps) | x<-[1..xn], y<-[1..yn]] >=^^< concatSP
+      boxes' = --allcacheF
+               boxes
+  in  loopF ({-debugF show show-} panel >==< absF (playSP d))
+
+data Fun = Fun (Coord->MInput)
+instance Eq Fun where
+  Fun f1 == Fun f2 = f1 (0,0) == f2 (0,0)
diff --git a/Demos/paint/GraphF.hs b/Demos/paint/GraphF.hs
new file mode 100644
--- /dev/null
+++ b/Demos/paint/GraphF.hs
@@ -0,0 +1,84 @@
+module GraphF(graphF,PaintCommand(..),ToolFunc(..)) where
+import AllFudgets
+--import Word()
+
+data PaintCommand
+	= ChangeTool ToolFunc
+	| ChangeColor ColorName
+
+type ToolFunc = Point->Point->DrawCommand
+
+graphK size func bgcol gc gcinv =
+	let same = graphK size func bgcol gc gcinv
+	    newf f = graphK size f bgcol gc gcinv
+	    resize s = graphK s func bgcol gc gcinv
+	    newgc = graphK size func bgcol
+	in getK $ \msg ->
+	     case msg of
+	        High (ChangeTool func) -> newf func
+	        High (ChangeColor color) -> changeColorK bgcol color newgc
+	        Low (LEvt (LayoutSize newsize)) -> resize newsize
+	        Low (XEvt (Expose _ 0)) -> same -- !!!
+	        Low (XEvt (ButtonEvent _ p _ _ Pressed (Button _))) ->
+		       rubberBandK size func bgcol gc gcinv p p
+	        _  -> same
+
+rubberBandK s f bgcol gc gcinv p0 p1 =
+	let cont p = rubberBandK s f bgcol gc gcinv p0 p
+	in let same = cont p1
+               draw gc p0 p1 = Low (wDraw gc (f p0 p1))
+        in let toggle = draw gcinv
+	in putK (toggle p0 p1) $
+	   getK $ \msg ->
+	     case msg of
+	        Low (XEvt (MotionNotify _ p _ _)) -> putK (toggle p0 p1) (cont p)
+	        Low (XEvt (ButtonEvent _ p _ _ Released _)) ->
+		  putsK [toggle p0 p1, draw gc p0 p] (graphK s f bgcol gc gcinv)
+	        _ -> same
+
+idleGraphK size bgcol gc gcinv =
+	let same = idleGraphK size bgcol gc gcinv
+	    resize size' = idleGraphK size' bgcol gc gcinv 
+	in getK $ \msg ->
+	     case msg of
+	        High (ChangeTool func) -> graphK size func bgcol gc gcinv
+	        Low (LEvt (LayoutSize size')) -> resize size'
+	        _ -> same
+
+changeColorK bgcol fg k =
+  let gcattr fgcol = [GCForeground fgcol, GCLineWidth 3]
+      invattrs bg fg = if bg==fg
+	               then invertColorGCattrs (Pixel 0) (Pixel 170) -- hmm
+		       else invertColorGCattrs bg fg
+  in allocNamedColorPixel defaultColormap fg  $ \fgcol ->
+     wCreateGC rootGC (gcattr fgcol) $ \gc ->
+     wCreateGC gc (invattrs bgcol fgcol) $ \gcinv ->
+     k gc gcinv
+
+graphF =
+  let evmask =[ExposureMask{-,ButtonReleaseMask-}]
+  in let wattrs = [CWBackingStore WhenMapped,
+		CWEventMask evmask,
+		CWBitGravity NorthWestGravity
+		]
+  in let startcmds = map XCmd 
+                      [ ChangeWindowAttributes wattrs,
+			--ConfigureWindow [CWBorderWidth 0],
+			GrabButton True (Button 1) []
+				[ButtonPressMask,
+				PointerMotionMask,
+				ButtonReleaseMask]
+			{-,
+			GrabButton True (Button 1) []
+				[ButtonReleaseMask],
+			GrabButton True (Button 3) []
+				[ButtonReleaseMask]
+			-}
+		     ]
+         size = Point 300 300
+  in windowF startcmds $
+	setFontCursor 130 $
+	changeGetBackPixel "white" $ \bgcol ->
+	changeColorK bgcol "black" $ \gc gcinv ->
+	putK (Low (layoutRequestCmd (plainLayout size False False))) $
+	idleGraphK size bgcol gc gcinv
diff --git a/Demos/paint/Paint.hs b/Demos/paint/Paint.hs
new file mode 100644
--- /dev/null
+++ b/Demos/paint/Paint.hs
@@ -0,0 +1,63 @@
+module Main where
+import Fudgets
+import GraphF
+
+main = fudlogue $ shellF "FudPaint" mainF
+
+mainF = hBoxF (graphF >==< vBoxF toolscolorsF)
+
+toolscolorsF =
+    noStretchF True True $ spacerF centerS $ vBoxF $
+    stripEither >^=< (toolsF >+< colorsF)
+
+toolsF =
+    "Tools" `labAboveF`
+    ((ChangeTool. tool)>^=< radioGroupF' pm (map (pairwith pict) tools) LineTool)
+  where pm = setLabelInside True
+
+colorsF =
+    "Colors" `labAboveF`
+    (ChangeColor >^=< radioGroupF' pm (map col colors) "Black")
+  where col c = (c,stackD [fgD c (g (cpict BlockTool)),
+                           g (cpict RectTool)])
+        pm = setLabelInside True . setPlacer (matrixP' 3 Horizontal 0)
+
+tools = [LineTool, RectTool, BlockTool, OvalTool, FilledOvalTool]
+
+colors = [ "Black", "Grey", "White",
+           "Blue", "Blue3", "Blue4",
+           "Green", "Green3", "Green4",
+           "Yellow","Orange", "Brown",
+ 	   "Red", "Red3", "Red4" ]
+
+data Tool = LineTool | RectTool | BlockTool | OvalTool | FilledOvalTool
+            deriving (Eq)
+
+tool LineTool = drawline
+tool RectTool = drawrect
+tool BlockTool = fillrect
+tool OvalTool = drawoval
+tool FilledOvalTool = filloval
+
+pict = pict' (Point 30 15)
+cpict = pict' (Point 15 15)
+pict' s t = FixD (s+1) [tool t 0 (s-1)]
+
+{-
+pict LineTool = "Line"
+pict RectTool = "Rect"
+pict BlockTool = "Block"
+pict OvalTool = "Oval"
+pict FilledOvalTool = "Blob"
+-}
+
+drawline p0 p1 = DrawLine (Line p0 p1)
+drawrect p0 p1 = DrawRectangle (rect' p0 p1)
+fillrect p0 p1 = FillRectangle (rect' p0 p1)
+drawoval p0 p1 = DrawArc (rect' p0 p1) 0 (64*360)
+filloval p0 p1 = FillArc (rect' p0 p1) 0 (64*360)
+
+rect' p1 p2 =
+  let p0 = pmin p1 p2
+      p = pmax p1 p2
+  in Rect p0 (padd (psub p p0) (Point 1 1))
diff --git a/Examples/FancyHello.hs b/Examples/FancyHello.hs
new file mode 100644
--- /dev/null
+++ b/Examples/FancyHello.hs
@@ -0,0 +1,26 @@
+-- Fancy version of the "Hello, world!" program
+import Fudgets
+
+main = fudlogue (shellF "Hello" helloF)
+
+helloF = labelF (fancyTextD greeting)
+
+fancyTextD text =
+    stackD [bgD,
+	    spacedD (hvMarginS (5+dist) 5) shadowTxtD,
+	    spacedD (hvMarginS 5 (5+dist)) fgTxtD]
+  where
+    shadowTxtD = fgD shadow txtD
+    fgTxtD = fgD color txtD
+    txtD = spacedD centerS $ fontD font (g text)
+    bgD = vboxD' 0 [fgD sky fillD,fgD ground fillD]
+    fillD = g (filler False False 10)
+
+-- Everything can be changed with command line switches:
+color = argKey "color" "red"
+shadow = argKey "shadow" "black"
+sky = argKey "sky" "skyblue"
+ground = argKey "ground" "blue"
+greeting = argKey "greeting" "Hello, world!"
+dist = diag (argReadKey "dist" 2)
+font = argKey "font" "-*-helvetica-bold-r-*-*-24-*-*-*-*-*-iso8859-1"
diff --git a/Examples/StopWatch.hs b/Examples/StopWatch.hs
new file mode 100644
--- /dev/null
+++ b/Examples/StopWatch.hs
@@ -0,0 +1,23 @@
+module Main where
+-- A simple stop watch with a run/stop button and a reset button.
+import Fudgets
+
+main = fudlogue (shellF "Stop Watch" stopWatchF)
+
+stopWatchF = 
+  timeDispF >==< (counterSP 0 >^^=< idRightF (timerF >=^< timeprep))
+   >==< (runF >+< resetF)
+  -- >+<quitButtonF
+
+timeprep True = Just (100,100)
+timeprep False = Nothing
+
+runF = toggleButtonF "Run"
+resetF = buttonF "Reset"
+
+timeDispF = intDispF  -- to be improved
+
+counterSP no = getSP $ \msg -> let out n = putSP n $ counterSP n 
+			       in case msg of
+				    Left _ -> out (no+1)
+				    Right _ -> out 0
diff --git a/Examples/texteditor.hs b/Examples/texteditor.hs
new file mode 100644
--- /dev/null
+++ b/Examples/texteditor.hs
@@ -0,0 +1,6 @@
+import Fudgets
+import ContribFudgets(textFileShellF)
+
+main = fudlogue $ textFileShellF "Text Editor" edF
+
+edF = spacer1F (minSizeS (Point 500 400)) (scrollF inputEditorF)
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,71 @@
+
+# ¤ Fudgets ¤
+
+[Fudgets](https://www.altocumulus.org/Fudgets/)
+is primarily a Graphical User Interface Toolkit implemented in Haskell
+on top of its own binding to the
+[Xlib library](https://tronche.com/gui/x/xlib/) of the
+[X Windows system](https://www.x.org/).
+Fudgets also makes it easy to create client/server applications that
+communicate via the Internet.
+[The Hello world program](https://www.altocumulus.org/Fudgets/Intro/ex1.html)
+fits on a single line:
+
+```haskell
+main = fudlogue (shellF "Hello" (labelF "Hello world!"))
+```
+
+The key abstraction is
+[*the fudget*](https://www.altocumulus.org/Fudgets/Intro/concept.html).
+A fudget is a *stream processor* with
+high-level and low-level streams. The high level streams are used for
+communication between fudgets within a program.
+The low level streams are for communication with the I/O system.
+
+> ![](https://www.altocumulus.org/~hallgren/WebFudgets/doc/P/the_fudget2.jpg)
+
+Fudgets are combined using various combinators for parallel composition,
+serial composition and loops.
+
+> ![](https://www.altocumulus.org/~hallgren/WebFudgets/doc/P/fudget_plumbing2.jpg)
+
+Fudgets was originally implemented in Lazy ML in the early 1990s,
+then converted to Haskell. It was thus designed before monadic IO was
+introduced in Haskell and early versions did not make use of Haskell's
+type classes at all.
+
+## Documentation
+
+- [Your first 8 Fudgets program](https://www.altocumulus.org/Fudgets/Intro/).
+  Gentle Introduction.
+- [Fudgets User's Guide](https://www.altocumulus.org/Fudgets/userguide.html).
+  Naming conventions and some other practical things.
+- [Fudget Library Reference Manual](https://www.altocumulus.org/Fudgets/Manual/). (Haddock did not exist back when Fudgets were created.)
+- [The FPCA-93 paper about Fudgets](https://www.altocumulus.org/Fudgets/fpca93-abstract.html),
+  the first publication describing Fudgets.
+- See the [Fudgets home page](https://www.altocumulus.org/Fudgets/) for more info.
+
+## Installing Fudgets from Hackage
+
+### On Linux systems
+
+- `sudo apt install libxext-dev` (installs Xlib etc on Debian-based
+  distributions, the command will be different on other Linux distributions.)
+- `cabal install fudgets`
+
+### On macOS
+
+- Install [XQuartz](https://www.xquartz.org/).
+- `brew install gcc` (need the version of `cpp` included with gcc, since there
+  are some issues with cpp from clang.
+  Note: `fudgets.cabal` refers to `cpp-11`, you might need to change this
+  if you install a different version of gcc.)
+
+- If you are using ghc>=8.10.3: unfortunately it seems that the
+  `-pgmP` option no longer works, so you need to
+  change a line in `$PREFIX/lib/ghc-*/lib/settings` instead:
+
+    ```  ,("Haskell CPP command", "gcc-11")```
+
+- `cabal install fudgets`
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/fudgets.cabal b/fudgets.cabal
new file mode 100644
--- /dev/null
+++ b/fudgets.cabal
@@ -0,0 +1,539 @@
+Name: fudgets
+-- The version number also appears in hsrc/utils/FudVersion.hs
+Version: 0.18.3
+Cabal-Version: >=1.10
+Synopsis: The Fudgets Library
+Homepage: https://www.altocumulus.org/Fudgets/
+Category: GUI, Network, Concurrency
+          -- Graphics?, User Interfaces?
+
+Description: <https://www.altocumulus.org/Fudgets/ Fudgets> is a Graphical
+             User Interface Toolkit built in Haskell on top of the X11
+             Windows system in the early 1990s. There is an
+             <https://www.altocumulus.org/Fudgets/fpca93-abstract.html FPCA-93 paper>
+             about it. Fudgets also makes it easy to create
+             client/server applications that communicate via the Internet.
+             .
+             This package includes the Fudgets library and a few small
+             examples and demo applications.
+
+Author: Thomas Hallgren and Magnus Carlsson
+Maintainer: Thomas Hallgren
+Build-Type: Simple
+License: OtherLicense
+License-File: COPYRIGHT
+Tested-With: GHC==7.4.1, GHC==7.6.3, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3, GHC==8.8.2, GHC==8.10.2, GHC==8.10.7, GHC==9.0.2, GHC==9.2.2
+
+Extra-Source-Files: README.md
+                    hsrc/exists.h
+                    hsrc/defaults/defaults.h
+                    hsrc/ghc-dialogue/asyncinput.h
+                    hsrc/ghc-dialogue/ccalls.h
+                    hsrc/ghc-dialogue/cfuns.h
+                    hsrc/ghc-dialogue/cfundefs.h
+                    hsrc/ghc-dialogue/cimports.h
+                    hsrc/ghc-dialogue/csizes.h
+                    hsrc/ghc-dialogue/newstructfuns.h
+                    hsrc/ghc-dialogue/structs.h
+                    xlib/socketlib/defs.h
+
+Flag developer
+  Description: Enable options useful for developers of this library
+  Manual:      True
+  Default:     False
+
+Flag old-time
+  Description: Use the old-time package
+  Default:     True
+
+Library
+  --Exposed: False
+  Exposed-modules: AllFudgets Fudgets ContribFudgets
+    TreeBrowser HyperGraphicsF2 SuperMenuF ConnectF TypedSockets
+    ReactiveF ReactionM DialogueIO DoRequest
+    IOUtil
+    --NonStdTrace
+    HbcUtils
+    -- GhcFudgets
+
+  Build-Depends: base>=4 && <5, process, directory>=1.2.3,
+               --packedstring,
+                 containers, array, time,
+                 unix
+
+  if flag(old-time)
+    Build-Depends: old-time
+
+  Hs-source-dirs: Contrib hsrc
+    hsrc/utils hsrc/sp hsrc/types hsrc/xtypes hsrc/combinators hsrc/containers
+    hsrc/drawing hsrc/filters hsrc/fudgets hsrc/defaults hsrc/internals
+    hsrc/kernelutils hsrc/layout hsrc/infix hsrc/lowlevel hsrc/io hsrc/debug
+    hsrc/ghc-dialogue hsrc/ghc
+    -- The only module used from hbc_library is FudUTF8
+    hsrc/hbc_library
+
+  Default-language: Haskell98
+  Default-extensions: ForeignFunctionInterface Rank2Types
+                      ExistentialQuantification
+                      MultiParamTypeClasses FunctionalDependencies
+                      FlexibleInstances FlexibleContexts TypeSynonymInstances
+
+--if impl(ghc>=8.6) && impl(ghc<8.8)
+--  Default-extensions: NoMonadFailDesugaring
+
+  Include-dirs: hsrc hsrc/ghc-dialogue hsrc/defaults
+
+  if os(darwin)
+    Extra-lib-dirs: /opt/X11/lib 
+    Include-dirs: /opt/X11/include
+    -- Run 'brew install gcc', then you should have gcc-11 and cpp-11, or
+    -- possibly another version, in which case you need to adapt the line below:
+    if impl(ghc<8.10.3)
+      -- Use the -pgmP in ghc<8.10.3
+      ghc-options: -pgmP cpp-11 -optP -traditional
+    --else
+      -- Unfortunately -pgmP doesn't work in ghc>=8.10.3, so you need to
+      -- change a line in $PREFIX/lib/ghc-*/lib/settings insead:
+      -- ,("Haskell CPP command", "gcc-11")
+
+  Extra-Libraries: X11 Xext
+
+  ghc-options: -fno-warn-tabs
+  
+  if flag(developer)
+    ghc-options: -fwarn-unused-imports
+    ghc-prof-options: -fprof-auto
+
+  if impl(ghc>=8.6)
+    ghc-options: -haddock
+
+  c-sources: hsrc/ghc-dialogue/cfuns.c xlib/fdzero.c xlib/socketlib/inet.c
+  cc-options: "-DVERSION=\"SOCKET Version 1.3\"" -DHAS_H_ERRNO
+
+  -- Sigh. Why can't Cabal fill this in?
+  -- ghc --make has no problem finding all the reqired modules.
+  Other-Modules:
+    AlignP
+    Alignment
+--  Ap
+    AppStorage
+    AsyncInput
+    AsyncTransmitter
+    AutoLayout
+    AutoPlacer
+    AuxShellF
+    AuxTypes
+    BellF
+    BgF
+    BitmapDrawing
+    BitmapF
+    Border3dF
+    BranchF
+    BubbleF
+    ButtonBorderF
+    ButtonF
+    ButtonGroupF
+    CSizes
+    CString16
+    CmdLineEnv
+    Color
+    Combinators
+    Command
+    CompF
+    CompFfun
+    CompOps
+    CompSP
+    CompiledGraphics
+    CompletionStringF
+    CondLayout
+    Cont
+    ContDynF
+    Containers
+    ContinuationIO
+    Convgc
+    Cursor
+    DButtonF
+    DDisplayF
+    DFudIO
+    DLValue
+    DRadioF
+    DShellF
+    DStringF
+    DToggleButtonF
+    Debug
+    DefaultParams
+    Defaults
+    DialogF
+    DialogueSpIO
+    Direction
+    Display
+    Dlayout
+    DoXCommand
+    DoXRequest
+    DoubleClickF
+    DragF
+    DrawCompiledGraphics
+    DrawCompiledGraphics1
+    DrawInPixmap
+    DrawInWindow
+    DrawTypes
+    Drawcmd
+    Drawing
+    DrawingModules
+    DrawingOps
+    DrawingUtils
+    DynListF
+    DynListLF
+    DynRadioGroupF
+    DynSpacerF
+    Dynforkmerge
+    Edit
+    Editfield
+    Editor
+    Edtypes
+    EitherUtils
+    EncodeEvent
+    EndButtonsF
+    Event
+    EventMask
+    Expose
+    FDefaults
+    FRequest
+    FilePaths
+    FilePickF
+    FilePickPopupF
+    FileShellF
+    Filters
+    FixedDrawing
+    FlexibleDrawing
+    FocusMgr
+    Font
+    FontProperty
+    FreeGroupF
+    FudIO
+    FudUTF8
+    FudUtilities
+    FudVersion
+    Fudget
+    FudgetIO
+    GCAttrs
+    GCtx
+    Gc
+    GcWarningF
+    Geometry
+    GetModificationTime
+    GetTime
+    GetVisual
+    GetWindowProperty
+    Graphic
+    Graphic2Pixmap
+    GraphicsF
+    GreyBgF
+    GuiElems
+    HandleF
+    HaskellIO
+--  HbcLibrary
+    HbcWord
+    HelpBubbleF
+    HorizontalAlignP
+    HyperGraphicsF
+    IdempotSP
+    Image
+    InOut
+    InfixOps
+    InputEditorF
+    InputF
+    InputMsg
+    InputSP
+    IntMemo
+    InternAtom
+    IoF
+    IsRequest
+    KernelUtils
+    KeyGfx
+--  LA
+    LabelF
+    Layout
+    LayoutDir
+    LayoutDoNow
+    LayoutF
+    LayoutHints
+    LayoutOps
+    LayoutRequest
+    LayoutSP
+    Layoutspec
+    LinearSplitP
+    List2
+    ListF
+    ListRequest
+    LoadFont
+    Loop
+    LoopCompF
+    LoopLow
+    Loops
+    Loopthrough
+    LowLevel
+    MGOps
+    MapstateK
+    MapstateMsg
+    Maptrace
+    Marshall
+    MatrixP
+    MeasuredGraphics
+    MenuBarF
+    MenuButtonF
+    MenuF
+    MenuPopupF
+    Message
+    MeterF
+    MoreF
+    MoreFileF
+    MyForeign
+    NameLayout
+    NewCache
+    NullF
+    OldLayoutOps
+    OnOffDispF
+    OpenSocket
+    PQueue
+    P_IO_data
+    PackedString
+    ParF
+    ParK
+    ParSP
+    ParagraphP
+    Path
+    PathTree
+    Pixmap
+    PixmapGen
+    Placer
+    Placers
+    Placers2
+    PopupF
+    PopupGroupF
+    PopupMenuF
+    Popupmsg
+    PosPopupShellF
+    Process
+    ProdF
+    PushButtonF
+    QueryPointer
+    QueryTree
+    Queue
+    QuitButtonF
+    QuitF
+    QuitK
+    RadioF
+    ReadFileF
+    Rects
+    ResourceIds
+    RootWindowF
+    Route
+    SP
+    SPmonad
+    SPstateMonad
+    ScrollF
+    SelectionF
+    SerCompF
+    ShapeGroupMgr
+    ShapeK
+    ShapedButtonsF
+    Shells
+    ShowCommandF
+    ShowFailure
+    ShowFun
+    SimpleF
+    Sizing
+    SizingF
+    SmileyF
+    SocketServer
+    Socketio
+    Sockets
+    SpEither
+    SpIO
+    Spacer
+    Spacers
+    Spinterp
+    SplitF
+    Spops
+    SpyF
+    Srequest
+    StateMonads
+    StdIoUtil
+    StreamProc
+    StreamProcIO
+    StringEdit
+    StringF
+    StringUtils
+    StructFuns
+    Table
+    TableP
+    Tables
+    Tables2
+    TagEvents
+    TerminalF
+    TextExtents
+    TextF
+    TimerF
+    TitleShellF
+    ToggleButtonF
+    ToggleGroupF
+    TransCoord
+    Transceivers
+    Tree234
+    TreeF
+    TryLayout
+    Types
+    UndoStack
+    UnsafeGetDLValue
+    UnsafePerformIO
+    UserLayoutF
+    Utils
+    Visual
+    WindowF
+    WriteFile
+    XCallTypes
+    XDraw
+    XStuff
+    XTypesModules
+    Xcommand
+    Xlib
+    Xrequest
+    Xtypes
+
+Executable Graph
+  hs-source-dirs: Demos/graph
+  main-is: Graph.hs
+  Other-modules: Compat Diff Eval Exp ExpF Lex Ops Parser Parsop PlotF Root
+                 Show Simp UserCoords ZoomF
+  build-depends: base, fudgets
+  Default-language: Haskell98
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable fudgetclock
+  hs-source-dirs: Demos/clock
+  main-is: fudgetclock.hs
+  Other-modules: ClockF
+  Default-language: Haskell98
+  build-depends: base, fudgets
+  if flag(old-time)
+    Build-Depends: old-time
+  else
+    Build-Depends: time
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable StopWatch
+  hs-source-dirs: Examples
+  main-is: StopWatch.hs
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable texteditor
+  hs-source-dirs: Examples
+  main-is: texteditor.hs
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable FancyHello
+  hs-source-dirs: Examples
+  main-is: FancyHello.hs
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable SpaceInvaders2
+  hs-source-dirs: Demos/SpaceInvaders
+  main-is: SpaceInvaders2.hs
+  Other-modules: BitmapOps GUI InvaderTypes MainF Pics Pics1 ReadPic ScoreF WorldF Metrics
+  Default-language: Haskell98
+  build-depends: base, fudgets, random
+--, split>=0.2
+
+  ghc-options: -fno-warn-tabs
+--if impl(ghc>=8.6)
+--  Default-extensions: NoMonadFailDesugaring
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable Explore
+  hs-source-dirs: Demos/Mandelbrot Demos/graph
+  main-is: Explore.hs
+  Other-modules: Mandelbrot UserCoords ZoomF
+  Default-language: Haskell98
+  ghc-options: -threaded
+  build-depends: base, fudgets, array, parallel
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts -with-rtsopts=-N
+
+Executable FudPaint
+  hs-source-dirs: Demos/paint
+  main-is: Paint.hs
+  Other-modules: GraphF
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable Life
+  hs-source-dirs: Demos/life
+  main-is: Main.hs
+  other-modules: Generate Life Panel Timer Utils2
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable Tiles
+  hs-source-dirs: Demos/Tiles
+  main-is: Main.hs
+  Other-modules: BoardF ChoiceF DesignF DrawingF MyUtils RadioDrawF Tiles
+                 ToggleDrawGroupF ToolsF
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable XMine
+  hs-source-dirs: Demos/mines
+  main-is: XMine.hs
+  Other-modules: Box FUtil MineField Pics
+  Default-language: Haskell98
+  build-depends: base, fudgets, array, random
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
+
+Executable doRequest
+  main-is: hsrc/doRequest.hs
+  Default-language: Haskell98
+  build-depends: base, fudgets
+
+  ghc-options: -fno-warn-tabs
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
diff --git a/hsrc/AllFudgets.hs b/hsrc/AllFudgets.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/AllFudgets.hs
@@ -0,0 +1,33 @@
+-- | This module exposes everything, but there is very little documentation
+-- here. See the
+-- <http://www.altocumulus.org/Fudgets/Manual/ Fudget Library Reference Manual>
+-- instead.
+module AllFudgets 
+ (module Combinators, module Containers,module Debug,module DrawingModules,
+  module Filters,module GuiElems,module InfixOps,module KernelUtils,
+  module Layout,module LowLevel,module Types,module XTypesModules,
+  module FudUtilities,module StreamProc,module InOut,module DefaultParams) where
+import GuiElems
+import Combinators
+import InfixOps
+import Layout
+import Containers
+import Filters
+import DrawingModules
+import KernelUtils
+import StreamProc
+import InOut
+import LowLevel
+import XTypesModules
+import Types
+import FudUtilities
+import Debug
+import DefaultParams
+
+{-
+#ifdef __NHC_HASKELL__
+-- nhc bug workaround
+blaha1=Pixel 1
+blaha2=Width 1
+#endif
+-}
diff --git a/hsrc/Fudgets.hs b/hsrc/Fudgets.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/Fudgets.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE CPP #-}
+#include "exists.h"
+-- | Programmers' index. There is very little documentation here. See the
+-- <http://www.altocumulus.org/Fudgets/Manual/ Fudget Library Reference Manual>
+-- instead.
+module Fudgets(
+ -- * GUI
+ buttonF, border3dF, buttonBorderF, pushButtonF,
+ BMevents(..),
+ popupMenuF, Click(..),
+ radioGroupF, radioGroupF', intF, passwdF, stringF,
+ intInputF, stringInputF, passwdInputF,
+ intInputF', stringInputF', passwdInputF',
+ toggleButtonF,
+ -- ** Popups
+ inputPopupOptF, inputPopupF,
+ passwdPopupOptF, passwdPopupF, stringPopupOptF, stringPopupF,
+ confirmPopupF, ConfirmMsg(..), oldConfirmPopupF, oldMessagePopupF,
+ messagePopupF, intDispF, displayF, labelF,
+ -- ** Text editor
+ EditStop(..), editF,
+ EditEvt(..), EditCmd(..), editorF, editorF', selectall, loadEditor,
+ newline, EDirection(..), inputEditorF, inputEditorF', EditorF,
+ EditStopFn(..), EditStopChoice(..), IsSelect(..),setEditorCursorPos,
+ -- ** List and text
+ oldFilePickF, PickListRequest(..),
+ textF, textF',-- textF'',
+ TextRequest(..), TextF, HasInitText(..), HasSizing(..),Sizing(..),
+ ListRequest(..),
+ replaceAll, replaceAllFrom, deleteItems, insertItems, appendItems,
+ changeItems, replaceItems, highlightItems, pickItem, applyListRequest, 
+ smallPickListF, labRightOfF, labLeftOfF, labBelowF, labAboveF,
+ tieLabelF, menuF, PopupMenu(..), menuPopupF,
+ pickListF, moreShellF,pickListF', moreShellF',
+ moreFileShellF, moreFileF, moreF, moreF',
+ terminalF, cmdTerminalF, TerminalCmd(..),
+ -- ** Graphics
+ hyperGraphicsF, hyperGraphicsF',GraphicsF,setAdjustSize,
+ -- * Fudgets and combinators
+ contDynF,
+ Fudget(..), F, --F(..),
+ listF,
+ untaggedListF, loopCompF, loopCompSP, loopF, loopLeftF, loopRightF, loopOnlyF,
+ loopThroughRightF, loopCompThroughLeftF, loopCompThroughRightF,
+ loopThroughBothF,
+ --Message,
+ delayF, getF, putF, putsF, startupF, appendStartF, 
+
+ nullF, parF, prodF, absF, bypassF, concatMapF, idF, idLeftF,
+ idRightF, mapF, mapstateF, serCompLeftToRightF, serCompRightToLeftF, stubF,
+ throughF, toBothF, (>*<), (>+<), (>=^<), (>=^^<),
+ (>#+<), (>#==<), (>==<), (>^=<), (>^^=<),
+ prepostMapHigh,
+
+ quitIdF, quitF,
+
+ DynFMsg(..), dynF, dynListF, DynMsg(..), --Either(..),
+ FudgetIO(..),
+ --Fa(..),Direction, TCommand(..),TEvent(..),
+
+ {- FCommand(..), FEvent(..), K(..), KCommand(..), KEvent(..),
+ TCommand(..), TEvent(..), -}
+ -- ** Input
+ InF(..), InputMsg(..), inputDoneSP, inputLeaveDoneSP,
+ inputListSP, inputPairSP, inputThroughF, inputPairF, inputListF, inputChange,
+ inputListLF, inputPairLF, -- obsolete
+ stripInputSP,
+ inputButtonKey, inputLeaveKey, inputMsg, mapInp, stripInputMsg,
+ inputDone, inputLeaveDone,
+ tstInp,
+
+ -- * Layout
+ Orientation(..),
+ alignF, marginHVAlignF, layoutModifierF, noStretchF,
+ marginF, sepF,
+ autoP, flipP, permuteP, revP, idP,
+ Alignment(..), aBottom, aCenter, aLeft, aRight, aTop,
+ -- barP, rightBelowP,
+ dynListLF, LayoutDir(..),
+ listLF, nullLF, holeF,
+ --rbLayoutF,
+ untaggedListLF, LayoutRequest,
+ Placer, center, center', fixedh, fixedv, flipPoint,
+ flipRect, flipReq,
+
+ NameLayout, LName(..),hvAlignNL, marginHVAlignNL, hBoxNL, hBoxNL',
+ nullNL, leafNL, spaceNL, placeNL, 
+ listNF, modNL, nameF, nameLayoutF, sepNL, marginNL, vBoxNL, vBoxNL',
+
+ hBoxF, matrixF, placerF, spacerF, spacer1F, revHBoxF, revVBoxF, spacerP,
+ tableF, vBoxF, horizontalP, horizontalP', matrixP, matrixP',
+ verticalP, verticalP',paragraphP,paragraphP',paragraphP'',
+ dynPlacerF, dynSpacerF, -- There are pitfalls with using these...
+
+ Distance(..), Spacer, bottomS, centerS, compS, flipS,
+ hAlignS, sizeS, maxSizeS, minSizeS, hCenterS, hMarginS, marginHVAlignS,
+ hvAlignS, hvMarginS, idS, leftS, marginS, sepS, noStretchS,
+ rightS, topS, vAlignS, vCenterS, vMarginS, tableP, tableP', bubbleF,
+ bubblePopupF, bubbleRootPopupF, shellF, PotRequest(..), PotState(..),
+ containerGroupF, hPotF, vPotF, popupShellF, popupShellF', PopupMsg(..),
+ posPopupShellF, hScrollF, scrollF, scrollShellF, vScrollF,
+ ESelCmd(..), ESelEvt(..), SelCmd(..), SelEvt(..), eselectionF,
+ selectionF, allcacheF,
+ {-
+ bitmapdatacacheF, bitmapfilecacheF,
+ colorcacheF, fontcacheF, fontcursorcacheF, fstructcacheF, gCcacheF,
+ -}
+ doubleClickF, Time(..),
+ -- * Stream processors
+ -- ** Combining stream processors
+ (-+-),(-*-),(-==-),
+ compEitherSP, idLeftSP, idRightSP, postMapSP, preMapSP,
+ prepostMapSP, serCompSP, loopLeftSP, loopSP, loopOnlySP, loopThroughRightSP,
+ loopThroughBothSP,
+ parSP, seqSP,
+ -- ** Stream processor primitives
+ SP,nullSP,putSP,putsSP,getSP,
+ StreamProcIO(..),runSP, walkSP, pullSP,
+
+ {-SPm(..), bindSPm, getSPm, monadSP, nullSPm, putsSPm, thenSPm, toSPm, unitSPm,-}
+
+ -- ** Convenient stream processors
+ idSP, filterSP, filterJustSP, filterLeftSP, filterRightSP, mapFilterSP,
+ splitSP, toBothSP,
+ concatSP, concSP,
+ mapSP, concatMapSP, concmapSP,
+ concatMapAccumlSP, mapstateSP, mapAccumlSP,
+ zipSP,
+ -- ** Stream processor behaviour
+ Cont(..),
+ appendStartSP, chopSP, delaySP, feedSP,
+ splitAtElemSP, startupSP, stepSP,
+ cmdContSP, conts, getLeftSP, getRightSP, waitForSP, waitForF, dropSP, contMap,
+ -- * System (stdio, files, network, subprocesses)
+ -- ** Dialogue IO
+ hIOF,
+ hIOSuccF, hIOerrF, haskellIOF,
+ inputLinesSP, linesSP,
+ -- ** Stdio
+ outputF, stderrF, stdinF,
+ stdioF, stdoutF,
+ -- ** Subprocesses
+ subProcessF,
+ -- ** Files and directories
+ appStorageF,
+ readDirF, readFileF, writeFileF,
+ -- ** Sockets
+ Host(..), LSocket(..), Peer(..), Port(..), Socket(..),
+ openLSocketF,
+ openSocketF, receiverF, transceiverF, transmitterF, asyncTransmitterF,
+ asyncTransceiverF,
+ -- ** Timer
+ Tick(..), timerF,
+ --dropF,
+ -- ** Running a fudget
+ fudlogue, fudlogue', Fudlogue,
+ -- * Command line, environment and defaults
+ argFlag, argKey, argReadKey, argKeyList, args, progName,
+ bgColor, buttonFont, defaultFont, defaultSize,
+ defaultPosition, defaultSep, edgeWidth, fgColor, labelFont, look3d,
+ menuFont, options, paperColor, shadowColor, shineColor,
+ -- * Utilities for the Either type
+ filterLeft, filterRight, isLeft, isRight, mapEither,
+ fromLeft, fromRight, plookup, splitEitherList, stripEither, stripLeft,
+ --  mapfilter, isM, stripMaybe, stripMaybeDef,
+     -- use Maybe.mapMaybe,isJust,fromJust,fromMaybe!
+ stripRight, swapEither,
+ -- * Geometry
+ (=.>),
+ Line(..), Point(..), Rect(..), Size(..), Move(..), confine, diag, freedom,
+ growrect, inRect, lL, line2rect, moveline, moverect, origin, pMax,
+ pMin, pP, padd, plim, pmax, pmin, posrect, psub, rR, rect2line,
+ rectMiddle,
+ rmax, rsub, scale, scalePoint, sizerect,
+ --xcoord, ycoord, rectpos, rectsize,
+ -- * Utilities
+ aboth, anth, gmap, -- afst, asnd, dropto, 
+ issubset, lhead, loop, lsplit, ltail, mapPair, number, oo, pair,
+ pairwith, part, remove, replace, swap, unionmap, module FudVersion,
+
+ -- * Xlib types
+ XCommand, XEvent, Path(..),
+ Button(..), ColorName(..), FontName(..), KeySym(..), FontStruct, RGB(..),
+ WindowAttributes, 
+ ModState(..), Modifiers(..), 
+  -- * Graphics and drawings
+ CoordMode(..),Shape(..),
+ DrawCommand(..),fillCircle,drawCircle,
+ Graphic(..),
+ Drawing(..),atomicD,labelD,up,boxD,hboxD,hboxD',vboxD,vboxD',tableD,tableD',
+ hboxcD,hboxcD',vboxlD,vboxlD',matrixD,matrixD',
+ attribD,softAttribD,hardAttribD,fontD,fgD,stackD,spacedD,placedD,
+ blankD,filledRectD,rectD,
+ DPath(..),
+#ifdef USE_EXIST_Q
+ Gfx,
+#endif
+ g,
+ FixedDrawing(..),FixedColorDrawing(..),gctx2gc,
+ FlexibleDrawing(..),flex,flex',
+ filler,hFiller,vFiller,frame,frame',ellipse,ellipse',arc,arc',
+ filledEllipse,filledEllipse',filledarc,filledarc',
+ lpar,rpar,lbrack,rbrack,lbrace,rbrace,
+ triangleUp,triangleDown,filledTriangleUp,filledTriangleDown,
+ BitmapFile(..),
+ ColorGen(..),FontGen(..),FontSpec,ColorSpec,--Name(..),--ColorFallback(..),
+#ifdef USE_EXIST_Q
+ colorSpec,fontSpec,
+#endif
+ GCtx,rootGCtx,wCreateGCtx,createGCtx,gcFgA,gcBgA,gcFontA,
+ GCAttributes(..),GCFillStyle(..),GCCapStyle(..),GCLineStyle(..),GCFunction(..),
+ Width(..),
+
+ -- * Customisation
+ Customiser(..), PF(..), standard,
+
+ HasClickToType(..), HasVisible(..), HasFontSpec(..), setFont,
+ HasKeys(..), HasWinAttr(..), --HasTitle(..),
+ HasBorderWidth(..), HasBgColorSpec(..), HasFgColorSpec(..), HasMargin(..),
+ setBgColor,setFgColor,
+ HasAlign(..),
+ {- HasAllowedChar(..), HasShowString(..), -}
+ setAllowedChar, setShowString, setCursorPos,
+ HasCache(..),
+ setDeleteQuit,setDeleteWindowAction,DeleteWindowAction(..),--HasDeleteQuit(..),
+ HasInitSize(..),
+ HasInitDisp(..),
+ --setInitDisp, getInitDisp,
+ setSpacer,
+ HasStretchable(..),
+ HasLabelInside(..),setPlacer,
+
+ ShellF, shellF', setInitPos,
+ unmappedSimpleShellF, unmappedSimpleShellF',
+ ButtonF, buttonF', buttonF'', setLabel,
+ DisplayF, displayF',-- displayF'',
+ labelF', --labelF'',
+ StringF, stringF', stringF'', setInitString, setInitStringSize,
+ passwdF', passwdF'',
+ intF', intF'',
+ intDispF', --intDispF'',
+ -- * Miscellaneous
+ gcWarningF,bellF,
+ --D_IOError,
+ -- * Time
+#ifdef VERSION_old_time
+ getTime,getLocalTime,
+#endif
+#ifdef VERSION_time
+ getCurrentTime,getZonedTime,
+#endif
+ -- * Debugging
+ spyF,teeF, ctrace,showCommandF) where
+
+import AllFudgets -- hiding (Cont,PCont,Fa)
+import FudVersion
+
+-- I hate this file /TH
+-- I still hate this file /TH
diff --git a/hsrc/combinators/BranchF.hs b/hsrc/combinators/BranchF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/BranchF.hs
@@ -0,0 +1,70 @@
+module BranchF(branchF,branchFSP) where
+import Direction
+import Fudget
+--import Path(Path(..))
+import Route
+import SP
+--import Message(Message(..))
+
+branchF :: (F (Path, a) b) -> (F (Path, a) b) -> F (Path, a) b
+branchF (F f1) (F f2) = F{-ff-} (branchFSP f1 f2)
+
+branchFSP :: (FSP (Path, a) b) -> (FSP (Path, a) b) -> FSP (Path, a) b
+branchFSP f1 f2 =
+    case f1 of
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (branchFSP f1' f2)
+      PutSP msg f1' -> PutSP msg (branchFSP f1' f2)
+      GetSP xf1 -> branchF1 xf1 f2
+      NullSP -> restF2 f2
+
+--and branchF1:: (FEvent *a->F *a *b) -> F *c *d -> F (Either *a *c) (Either *b *d)
+branchF1 xf1 f2 =
+    case f2 of
+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (branchF1 xf1 f2')
+      PutSP msg f2' -> PutSP msg (branchF1 xf1 f2')
+      GetSP xf2 -> GetSP (branchF12 xf1 xf2)
+      NullSP -> GetSP (restF1x xf1)
+
+--and branchF2:: F *a *b -> (FEvent *c->F *c *d) -> F (Either *a *c) (Either *b *d)
+branchF2 f1 xf2 =
+    case f1 of
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (branchF2 f1' xf2)
+      PutSP msg f1' -> PutSP msg (branchF2 f1' xf2)
+      GetSP xf1 -> GetSP (branchF12 xf1 xf2)
+      NullSP -> GetSP (restF2x xf2)
+
+--and branchF12:: (FEvent *a->F *a *b) -> (FEvent *c->F *c *d) -> FEvent (Either *a *c) -> F (Either *a *c) (Either *b *d)
+branchF12 xf1 xf2 msg =
+    case msg of
+      High (L : path', x) -> branchF2 (xf1 (High (path', x))) xf2
+      High (R : path', y) -> branchF1 xf1 (xf2 (High (path', y)))
+      Low (L : path', x) -> branchF2 (xf1 (Low (path', x))) xf2
+      Low (R : path', y) -> branchF1 xf1 (xf2 (Low (path', y)))
+      _ -> GetSP (branchF12 xf1 xf2)
+
+restF2 f2 =
+    case f2 of
+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (restF2 f2')
+      PutSP msg f2' -> PutSP msg (restF2 f2')
+      GetSP xf2 -> GetSP (restF2x xf2)
+      NullSP -> NullSP
+
+restF2x xf2 msg =
+    case msg of
+      High (R : path', y) -> restF2 (xf2 (High (path', y)))
+      Low (R : path', ev) -> restF2 (xf2 (Low (path', ev)))
+      _ -> GetSP (restF2x xf2)
+
+restF1 f1 =
+    case f1 of
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (restF1 f1')
+      PutSP msg f1' -> PutSP msg (restF1 f1')
+      GetSP xf1 -> GetSP (restF1x xf1)
+      NullSP -> NullSP
+
+restF1x xf1 msg =
+    case msg of
+      High (L : path', x) -> restF1 (xf1 (High (path', x)))
+      Low (L : path', ev) -> restF1 (xf1 (Low (path', ev)))
+      _ -> GetSP (restF1x xf1)
+
diff --git a/hsrc/combinators/Combinators.hs b/hsrc/combinators/Combinators.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/Combinators.hs
@@ -0,0 +1,19 @@
+module Combinators (-- * Combinators
+  module BranchF,module CompF,module ParF,module CompFfun,module DynListF,module ListF,module LoopLow,module Loops,module LoopCompF,module NullF,module ProdF,module Route,module SerCompF,module StateMonads,module TreeF,module InputF,module ContDynF) where
+import BranchF
+import CompF
+import ParF
+import CompFfun
+import DynListF
+import ListF
+import LoopLow
+import Loops
+import LoopCompF
+import NullF
+import ProdF
+import Route
+import SerCompF
+import StateMonads
+import TreeF
+import InputF
+import ContDynF
diff --git a/hsrc/combinators/CompF.hs b/hsrc/combinators/CompF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/CompF.hs
@@ -0,0 +1,72 @@
+module CompF(compF) where
+import Fudget
+--import Message(Message(..))
+import Route
+import SP
+import Direction
+import LayoutHints
+
+--import Maptrace(ctrace) -- debugging
+
+compF (F f1) (F f2) = layoutHintF parHint (F{-ff-} (compF' f1 f2))
+
+compF' :: FSP a b -> FSP c d -> FSP (Either a c) (Either b d)
+compF' f1 f2 =
+    case f1 of
+      PutSP (High x) f1' -> PutSP (High (Left x)) (compF' f1' f2)
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (compF' f1' f2)
+      GetSP xf1 -> compF1 xf1 f2
+      NullSP -> restF2 f2
+
+compF1 :: (FEvent a -> FSP a b) -> FSP c d -> FSP (Either a c) (Either b d)
+compF1 xf1 f2 =
+    case f2 of
+      PutSP (High y) f2' -> PutSP (High (Right y)) (compF1 xf1 f2')
+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (compF1 xf1 f2')
+      GetSP xf2 -> GetSP (compF12 xf1 xf2)
+      NullSP -> GetSP (restF1x xf1)
+
+compF2 :: FSP a b -> (FEvent c -> FSP c d) -> FSP (Either a c) (Either b d)
+compF2 f1 xf2 =
+    case f1 of
+      PutSP (High x) f1' -> PutSP (High (Left x)) (compF2 f1' xf2)
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (compF2 f1' xf2)
+      GetSP xf1 -> GetSP (compF12 xf1 xf2)
+      NullSP -> GetSP (restF2x xf2)
+
+compF12 :: (FEvent a -> FSP a b) -> (FEvent c -> FSP c d) -> (FEvent (Either a c)) -> FSP (Either a c) (Either b d)
+compF12 xf1 xf2 msg =
+    case msg of
+      High (Left x) -> compF2 (xf1 (High x)) xf2
+      High (Right y) -> compF1 xf1 (xf2 (High y))
+      Low (tag, ev) -> case tag of
+                         L : tag' -> compF2 (xf1 (Low (tag', ev))) xf2
+                         R : tag' -> compF1 xf1 (xf2 (Low (tag', ev)))
+                         _ -> {-ctrace "drop" (tag,ev) $-} GetSP (compF12 xf1 xf2)
+
+restF2 f2 =
+    case f2 of
+      PutSP (High y) f2' -> PutSP (High (Right y)) (restF2 f2')
+      PutSP (Low tcmd) f2' -> PutSP (compTurnRight tcmd) (restF2 f2')
+      GetSP xf2 -> GetSP (restF2x xf2)
+      NullSP -> NullSP
+
+restF2x xf2 msg =
+    case msg of
+      High (Right y) -> restF2 (xf2 (High y))
+      Low (R : tag, ev) -> restF2 (xf2 (Low (tag, ev)))
+      _ -> GetSP (restF2x xf2)
+
+restF1 f1 =
+    case f1 of
+      PutSP (High y) f1' -> PutSP (High (Left y)) (restF1 f1')
+      PutSP (Low tcmd) f1' -> PutSP (compTurnLeft tcmd) (restF1 f1')
+      GetSP xf1 -> GetSP (restF1x xf1)
+      NullSP -> NullSP
+
+restF1x xf1 msg =
+    case msg of
+      High (Left x) -> restF1 (xf1 (High x))
+      Low (L : tag, ev) -> restF1 (xf1 (Low (tag, ev)))
+      _ -> GetSP (restF1x xf1)
+
diff --git a/hsrc/combinators/CompFfun.hs b/hsrc/combinators/CompFfun.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/CompFfun.hs
@@ -0,0 +1,61 @@
+module CompFfun where
+import CompSP
+import Fudget
+import Message
+--import Path(Path(..))
+--import SP
+
+postProcessHigh postsp (F sp) = F{-ff-} (postProcessHigh' postsp sp)
+postProcessLow postsp (F sp) = F{-ff-} (postProcessLow' postsp sp)
+preProcessHigh (F sp) presp = F{-ff-} (preProcessHigh' sp presp)
+preProcessLow (F sp) presp = F{-ff-} (preProcessLow' sp presp)
+preMapHigh (F sp) pre = F{-ff-} (preMapHigh' sp pre)
+postMapHigh post (F sp) = F{-ff-} (postMapHigh' post sp)
+preMapLow (F sp) pre = F{-ff-} (preMapLow' sp pre)
+postMapLow post (F sp) = F{-ff-} (postMapLow' post sp)
+
+postProcessHighK postsp (K sp) = K{-kk-} (postProcessHigh' postsp sp)
+postProcessLowK postsp (K sp) = K{-kk-} (postProcessLow' postsp sp)
+preProcessHighK (K sp) presp = K{-kk-} (preProcessHigh' sp presp)
+preProcessLowK (K sp) presp = K{-kk-} (preProcessLow' sp presp)
+preMapHighK (K sp) pre = K{-kk-} (preMapHigh' sp pre)
+postMapHighK post (K sp) = K{-kk-} (postMapHigh' post sp)
+preMapLowK (K sp) pre = K{-kk-} (preMapLow' sp pre)
+postMapLowK post (K sp) = K{-kk-} (postMapLow' post sp)
+
+postProcessHigh' :: (SP a b) -> (Fa c d e a) -> Fa c d e b
+postProcessHigh' p f = serCompSP (idLowSP p) f
+
+postProcessLow' :: (SP a b) -> (Fa c a d e) -> Fa c b d e
+postProcessLow' p f = serCompSP (idHighSP p) f
+
+preProcessHigh' :: (Fa a b c d) -> (SP e c) -> Fa a b e d
+preProcessHigh' f p = serCompSP f (idLowSP p)
+
+preProcessLow' :: (Fa a b c d) -> (SP e a) -> Fa e b c d
+preProcessLow' f p = serCompSP f (idHighSP p)
+
+preMapHigh' :: (Fa a b c d) -> (e -> c) -> Fa a b e d
+preMapHigh' f pre = preMapSP f (aHigh pre)
+
+preMapLow' :: (Fa a b c d) -> (e -> a) -> Fa e b c d
+preMapLow' f pre = preMapSP f (aLow pre)
+
+postMapHigh' :: (a -> b) -> (Fa c d e a) -> Fa c d e b
+postMapHigh' post f = postMapSP (aHigh post) f
+
+postMapLow' :: (a -> b) -> (Fa c a d e) -> Fa c b d e
+postMapLow' post f = postMapSP (aLow post) f
+
+prepostMapHigh' :: (a -> b) -> (c -> d) -> (Fa e f b c) -> Fa e f a d
+prepostMapHigh' pre post f = prepostMapSP (aHigh pre) (aHigh post) f
+
+
+prepostMapHigh pre post (F sp) = F{-ff-} (prepostMapHigh' pre post sp)
+prepostMapHighK pre post (K sp) = K{-kk-} (prepostMapHigh' pre post sp)
+
+prepostMapLow' :: (a -> b) -> (c -> d) -> (Fa b c e f) -> Fa a d e f
+prepostMapLow' pre post f = prepostMapSP (aLow pre) (aLow post) f
+
+prepostMapLow pre post (F sp) = F (prepostMapLow' pre post sp)
+prepostMapLowK pre post (K sp) = K (prepostMapLow' pre post sp)
diff --git a/hsrc/combinators/ContDynF.hs b/hsrc/combinators/ContDynF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/ContDynF.hs
@@ -0,0 +1,27 @@
+module ContDynF where
+
+import Fudget
+--import Xtypes
+import Command
+import FRequest
+--import LayoutRequest(LayoutRequest)
+--import Geometry
+--import Message
+import Spops(getSP,putSP,walkSP,pullSP)
+import Path(here)
+--import Direction
+import Cont
+--import Dynforkmerge
+--import NullF(getMessageF,putMessageF)
+--import LayoutDir
+
+contDynF :: F a b -> Cont (F a d) b
+contDynF (F sp) = fContWrap (contDynFSP sp)
+
+contDynFSP :: FSP a b -> Cont (FSP a d) b
+contDynFSP f c = cdf (pullSP f)
+  where cdf (outf,f') = out f' outf 
+        out f' [] = getSP $ \msg -> cdf (walkSP f' msg)
+        out f' (x:xs) = case x of
+	   High msg -> putSP (Low (here,XCmd DestroyWindow)) $ c msg
+	   Low cmd -> putSP (Low cmd) $ out f' xs
diff --git a/hsrc/combinators/DynListF.hs b/hsrc/combinators/DynListF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/DynListF.hs
@@ -0,0 +1,40 @@
+module DynListF(dynF, DynFMsg(..), dynListF) where
+import Command
+import FRequest
+--import Xtypes
+import CompOps((>^=<),(>=^^<))
+import CompSP
+import Dynforkmerge
+import Fudget
+--import Message(Message(..))
+import NullF
+import Spops
+import Direction
+import Path
+import LayoutRequest
+
+type DynFMsg a b = DynMsg a (F a b)
+
+dynListF :: F (Int, DynFMsg a b) (Int, b)
+dynListF =
+    let prep (High (t, DynMsg m)) = [High (t, DynMsg (High m))]
+        prep (High (t, DynDestroy)) = 
+	    map tag [XCmd DestroyWindow,LCmd LayoutDestroy] 
+		++ [High (t, DynDestroy)] 
+	    where tag m = Low (turn (Dno t) here, m)
+        prep (High (t, DynCreate (F f))) = [High (t, DynCreate f)]
+        prep (Low ([], ev)) = []
+        prep (Low (tag, ev)) =
+            case path tag of
+              (Dno i, tag') -> [High (i, DynMsg (Low (tag', ev)))]
+	      _ -> [] -- wrong address!
+        post (High (t, High m)) = High (t, m)
+        post (High (i, Low (tag, cmd))) = Low (turn (Dno i) tag, cmd)
+        post (Low c) = Low c
+    in F{-ff-} $ serCompSP (postMapSP post (idLowSP dynforkmerge)) (concmapSP prep)
+
+dynF :: (F a b) -> F (Either (F a b) a) b
+dynF f0 =
+    let prep (Left f) = [(0, DynDestroy), (0, DynCreate f)]
+        prep (Right m) = [(0, DynMsg m)]
+    in (snd >^=< startupF [(0, DynCreate f0)] dynListF) >=^^< concmapSP prep
diff --git a/hsrc/combinators/InputF.hs b/hsrc/combinators/InputF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/InputF.hs
@@ -0,0 +1,29 @@
+module InputF(module InputF) where
+import Fudget
+import InputMsg
+import CompOps
+import ListF(listF)
+import Placer(placerF)
+import LayoutF(orientP)
+import EitherUtils(stripEither)
+import Spops
+import InputSP
+import AuxTypes() -- synonym KeySym, for hbc
+import SpEither(splitSP)
+import SerCompF(mapF,toBothF)
+
+type InF a b = F a (InputMsg b)
+
+inputPairLF orient f1 f2 = placerF (orientP orient) $ inputPairF f1 f2
+inputListLF placer tfs = placerF placer $ inputListF tfs
+
+inputPairF :: InF a1 b1 -> InF a2 b2 -> InF (a1,a2) (b1,b2)
+inputPairF f1 f2 = inputPairSP >^^=< (f1>+<f2) >=^^< splitSP
+
+inputListF :: (Eq a) => [(a, InF b c)] -> InF [(a, b)] [(a, c)] 
+inputListF tfs =
+  inputListSP (map fst tfs) >^^=< listF [(t,f)|(t,f)<-tfs] >=^^< concatSP
+
+inputThroughF :: InF a a -> InF a a
+inputThroughF f = stripEither>^=<(f>+<mapF InputChange)>==<toBothF
+
diff --git a/hsrc/combinators/ListF.hs b/hsrc/combinators/ListF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/ListF.hs
@@ -0,0 +1,74 @@
+module ListF(listF,untaggedListF) where
+import CompF
+import CompSP(prepostMapSP)
+import CompSP(preMapSP)
+import CompOps((>^=<),(>=^^<))
+import Direction
+import Fudget
+--import ListMap(lookupWithDefault)
+--import Message(Message(..))
+--import NullF
+--import Path(Path(..))
+import Spops
+import TreeF
+import Utils(number,pair)
+import HbcUtils(apSnd,lookupWithDefault)
+import LayoutHints
+
+untaggedListF :: [F a b] -> F a b
+untaggedListF fs = snd >^=< listF tfs >=^^< concatMapSP broadcast
+  where
+    tfs = number 0 fs
+    ns = map fst tfs
+    broadcast x = map (`pair` x) ns
+
+listF :: {-Prelude.-}Eq a => [(a, F b c)] -> F (a, b) (a, c)
+listF = layoutHintF listHint . F{-ff-} . listF'
+
+listF' :: Eq a => [(a, F b c)] -> FSP (a, b) (a, c)
+listF' [(tag, F w)] =
+    let prepinp (High (t, a)) =
+            if t == tag then High a else error "Unknown tag in listF"
+        prepinp (Low tev) = Low tev
+        prepout (High b) = High (tag, b)
+        prepout (Low cmd) = Low cmd
+    in  prepostMapSP prepinp prepout w
+listF' [(ltag, lw), (rtag, rw)] =
+    let prepinp (High (tag, a)) =
+            if tag == ltag then
+                High (Left a)
+            else
+                if tag == rtag then
+                    High (Right a)
+                else
+                    error "Unknown tag in listF"
+        prepinp (Low tev) = Low tev
+        prepout (High (Left b)) = High (ltag, b)
+        prepout (High (Right b)) = High (rtag, b)
+        prepout (Low cmd) = Low cmd
+        F lwrw = compF lw rw
+    in  prepostMapSP prepinp prepout lwrw
+listF' [] = nullSP
+listF' wtab =
+    let tree = balancedTree wtab
+        paths = pathtab tree
+        prepinp (High (tag, a)) =
+            let path' = lookupWithDefault paths (error "Unknown tag in listF") tag
+            in  High (path', a)
+        prepinp (Low tev) = Low tev
+    in  preMapSP (treeF' tree) prepinp
+
+pathtab (Leaf (t, _)) = [(t, [])]
+pathtab (Branch l r) =
+    map (apSnd (L :)) (pathtab l) ++ map (apSnd (R :)) (pathtab r)
+
+balancedTree xs =
+    case xs of
+      [x] -> Leaf x
+      _ -> let (l, r) = split2 xs
+           in  Branch (balancedTree l) (balancedTree r)
+
+split2 l =
+    let sp = length l `quot` 2
+    in  (take sp l, drop sp l)
+
diff --git a/hsrc/combinators/LoopCompF.hs b/hsrc/combinators/LoopCompF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/LoopCompF.hs
@@ -0,0 +1,30 @@
+module LoopCompF(loopCompF,loopCompSP,loopThroughBothF,loopThroughBothSP) where
+import Fudget        
+import CompFfun(prepostMapHigh)
+import CompF(compF)
+import CompSP(compSP,prepostMapSP)
+import Loop(loopLeftSP)
+import Loops(loopLeftF)
+
+-- loopComp = symmetric version of loopThroughRight
+
+loopCompF :: F (Either (Either r2l inl) (Either l2r inr))
+               (Either (Either l2r outl) (Either r2l outr)) ->
+	     F (Either inl inr) (Either outl outr)
+loopCompF = loopLeftF . prepostMapHigh pre post
+
+loopThroughBothF fud1 fud2 = loopCompF (fud1 `compF` fud2)
+loopThroughBothSP sp1 sp2 = loopCompSP (sp1 `compSP` sp2)
+
+loopCompSP = loopLeftSP . prepostMapSP pre post
+
+post (Left  (Left  x)) = Left (Left x)
+post (Left  (Right x)) = Right (Left x)
+post (Right (Left x)) = Left (Right x)
+post (Right (Right x)) = Right (Right x)
+-- post = either (either (Left.Left) (Right.Left))  (either (Left.Right) (Right.Right))
+
+pre (Right (Left x)) = Left (Right x)
+pre (Right (Right x)) = Right (Right x)
+pre (Left (Left x)) = Right (Left x)
+pre (Left (Right x)) = Left (Left x)
diff --git a/hsrc/combinators/LoopLow.hs b/hsrc/combinators/LoopLow.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/LoopLow.hs
@@ -0,0 +1,46 @@
+module LoopLow(loopLow,loopThroughLowSP,loopThroughLowF) where
+--import Command(Command(..))
+import CompSP
+--import Event(Event(..))
+import Fudget
+import Loop
+--import Message(Message(..))
+--import Path(Path(..))
+--import SP
+import Loopthrough(loopThroughRightSP)
+
+loopLow :: (SP TCommand (FCommand a)) -> (SP (FEvent a) TEvent) -> (F b c) -> F b c
+loopLow ch eh (F f) =
+    let prep (Left msg) = Low (High msg)
+        prep (Right (High msg)) = High msg
+        prep (Right (Low msg)) = Low (Low msg)
+        post (High msg) = Right (High msg)
+        post (Low (High msg)) = Left msg
+        post (Low (Low msg)) = Right (Low msg)
+    in F{-ff-} $
+	loopLeftSP
+	  (prepostMapSP prep post	
+		        (idHighSP ch `serCompSP` f `serCompSP` idHighSP eh))
+
+loopThroughLowSP :: SP (Either c e) (Either c e) -> 
+		    SP (Message e a) (Message c b) ->
+ 	            SP (Message e a) (Message c b)
+
+loopThroughLowSP ctrl f =
+    loopThroughRightSP (prepostMapSP prep post (idHighSP ctrl)) f
+  where
+    prep msg = case msg of
+		 Right (High a) -> High (Left a)
+		 Left (High a) -> High (Right a)
+		 Right (Low e) -> Low (Right e)
+		 Left (Low c) -> Low (Left c)
+
+    post msg = case msg of
+		 High (Left msg) -> Left (High msg)
+		 High (Right msg) -> Right (High msg)
+		 Low (Left c) -> Right (Low c)
+		 Low (Right e) -> Left (Low e)
+
+loopThroughLowF
+  :: SP (Either TCommand TEvent) (Either TCommand TEvent) -> F i o -> F i o
+loopThroughLowF ctrlSP (F fudSP) = F $ loopThroughLowSP ctrlSP fudSP
diff --git a/hsrc/combinators/Loops.hs b/hsrc/combinators/Loops.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/Loops.hs
@@ -0,0 +1,76 @@
+module Loops(loopF, loopThroughRightF, loopCompThroughRightF, loopCompThroughLeftF, loopRightF, loopLeftF, loopOnlyF) where
+import Maptrace(ctrace) -- debugging -- syntax error if you put this is last in the import list. TH 960428
+--import Command(Command(..))
+import CompFfun(prepostMapHigh)
+--import CompSP(prepostMapSP)
+import CompOps
+--import Event(Event(..))
+import Fudget
+import Loop
+--import Message(Message(..))
+--import Path(Path(..))
+--import SP
+import SpEither(toBothSP,mapFilterSP)
+import EitherUtils(stripEither, swapEither)
+import LayoutHints
+import Route
+import Direction
+import Loopthrough
+import CompSP
+
+
+loopLeftF :: (F (Either a b) (Either a c)) -> F b c
+loopLeftF (F sp) =
+    let post (Low x) = Right (Low x)
+        post (High (Right x)) = Right (High x)
+        post (High (Left x)) = Left x
+        pre (Right (Low x)) = Low x
+        pre (Right (High x)) = High (Right x)
+        pre (Left xs) = High (Left xs)
+    in {-layoutHintF loopHint-} (F{-ff-} $ loopLeftSP (prepostMapSP pre post sp))
+
+loopRightF :: (F (Either a b) (Either c b)) -> F a c
+loopRightF f = loopLeftF (prepostMapHigh swapEither swapEither f)
+
+loopThroughRightF :: F (Either a b) (Either c d) -> F c a -> F b d
+loopThroughRightF (F m) (F s) = 
+   --loopThroughRightSP (prepostMapSP pre post (idRightSP m)) s where
+   layoutHintF loopHint $
+   F{-ff-} $
+   loopThroughRightSP
+      (post `postMapSP` (idRightSP m) `serCompSP` mapFilterSP pre) s where
+
+   post (Left (Low c)) = Right (compTurnLeft c)
+   post (Right (Left c)) = Right (compTurnRight c)
+   post (Right (Right e)) = Left (Low e)
+   post (Left (High (Left m))) = Left (High m)
+   post (Left (High (Right m))) = Right (High m)
+
+   pre (Right (Low (p,e))) =
+     case p of
+       L:p -> Just $ Left (Low (p,e))
+       R:p -> Just $ Right (Right (p,e))
+       _   -> ctrace "drop" (p,e) $ Nothing --error "Dno in loopThroughRightF"
+   pre (Left (Low c)) = Just $ Right (Left c)
+   pre (Right (High m)) = Just $ Left (High (Right m))
+   pre (Left (High m)) = Just $ Left (High (Left m))
+
+loopCompThroughRightF :: (F (Either (Either a b) c) (Either (Either c d) a)) -> F b d
+loopCompThroughRightF w =
+    let post (Left (Left x)) = Left (Right x)
+        post (Left (Right x)) = Right x
+        post (Right x) = Left (Left (Left x))
+        pre (Left x) = x
+        pre (Right x) = Left (Right x)
+    in  loopLeftF (prepostMapHigh pre post w)
+
+
+loopCompThroughLeftF :: (F (Either a (Either b c)) (Either b (Either a d))) -> F c d
+loopCompThroughLeftF f =
+    loopCompThroughRightF (prepostMapHigh swapEither swapEither f)
+
+loopOnlyF :: F a a -> F a b
+loopOnlyF f = loopLeftF (prepostMapHigh stripEither Left f)
+
+loopF :: F a a -> F a a
+loopF f = loopLeftF (toBothSP>^^=<f>=^<stripEither)
diff --git a/hsrc/combinators/NullF.hs b/hsrc/combinators/NullF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/NullF.hs
@@ -0,0 +1,87 @@
+module NullF(module NullF, Cont(..),K,F,StreamProcIO(..),FudgetIO(..)) where
+import Utils(pair)
+import Fudget
+import Message(aLow,stripHigh) --Message(..),
+import Path(here)
+import Spops
+import Cont(dropSP,kContWrap,fContWrap,waitForK,waitForFu)
+import StreamProcIO
+import FudgetIO
+
+--{- -}
+instance StreamProcIO F where
+  put = putF
+  get = getF -- Discards low level input! Leave undefined?
+  end = nullF
+
+instance StreamProcIO K where
+  put = putHigh
+  get = getHigh
+  end = nullK
+
+instance FudgetIO F where
+  waitForMsg = waitForFu
+  putMsg = putMessageFu
+  --nullMsg = nullF
+  --getMsg = getMessageFu
+
+
+instance FudgetIO K where
+  putMsg = putK
+  waitForMsg = waitForK
+  --nullMsg = nullK
+  --getMsg = getK
+
+---}
+
+----
+
+nullK = K{-kk-} nullSP
+nullF = F{-ff-} nullSP
+
+--putK :: KCommand ho -> K hi ho -> K hi ho
+putK o (K sp) = kk (putSP o sp)
+
+putF = putMessageF . High
+
+putsF = puts :: ([b] -> F a b -> F a b)
+--putsF his f = foldr putF f his
+putsK = putMsgs :: ([KCommand b] -> K a b -> K a b)
+--putsK msgs k = foldr putK k msgs
+
+putMessageF msg (F sp) = F{-ff-} (putSP msg sp)
+putMessageFu = putMessageF . aLow (pair here)
+
+putMessagesF hos (F sp) = F{-ff-} (putsSP hos sp)
+putMessagesFu = putMsgs :: ([KCommand b] -> F a b -> F a b)
+--putMessagesFu msgs f = foldr putMessageFu f msgs
+
+--appendStartK :: [KCommand b] -> K a b -> K a b
+appendStartK kcmds (K sp) = kk (appendStartSP kcmds sp)
+
+--appendStartMessageF :: [FCommand b] -> F a b -> F a b
+appendStartMessageF fcmds (F sp) = F{-ff-} (appendStartSP fcmds sp)
+
+--appendStartF :: [b] -> F a b -> F a b
+appendStartF = appendStartMessageF . map High
+
+getK = kContWrap getSP -- :: (Cont (K a b) (KEvent a))
+
+getMessageF = fContWrap getSP -- :: (Cont (F a b) (FEvent a))
+getMessageFu = fContWrap (getSP . (. aLow snd)) :: (Cont (F a b) (KEvent a))
+
+--getF :: Cont (F a b) a
+getF = fContWrap (dropSP stripHigh)
+
+--startupK :: ([KEvent a] -> K a b -> K a b)
+startupK kevs (K sp) = kk (startupSP kevs sp)
+--startupMessageF :: ([FEvent a] -> F a b -> F a b)
+startupMessageF fevs (F sp) = F{-ff-} (startupSP fevs sp)
+
+--startupMessageFu = startupMessageF . map (aLow (pair here)) -- error prone
+
+--startupF :: [a] -> F a b -> F a b
+startupF = startupMessageF . map High
+
+--delayF :: (F a b -> F a b)
+delayF (F sp) = F{-ff-} (delaySP sp)
diff --git a/hsrc/combinators/ParF.hs b/hsrc/combinators/ParF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/ParF.hs
@@ -0,0 +1,10 @@
+module ParF(parF) where
+--import Fudget
+import EitherUtils(stripEither)
+import CompF(compF)
+--import SerCompF(serCompF)
+import CompFfun(postMapHigh,preProcessHigh)
+import SpEither(toBothSP)
+
+-- Quick (i.e. slow) implementation
+parF f1 f2 = stripEither `postMapHigh` compF f1 f2 `preProcessHigh` toBothSP
diff --git a/hsrc/combinators/ProdF.hs b/hsrc/combinators/ProdF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/ProdF.hs
@@ -0,0 +1,8 @@
+module ProdF where
+import CompOps((>+<), (>=^^<))
+import Fudget
+import SpEither(splitSP)
+
+prodF :: (F a b) -> (F c d) -> F (a, c) (Either b d)
+prodF leftw rightw = (leftw >+< rightw) >=^^< splitSP
+
diff --git a/hsrc/combinators/Route.hs b/hsrc/combinators/Route.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/Route.hs
@@ -0,0 +1,13 @@
+module Route(compTurnRight, compTurnLeft, compPath) where
+import Direction
+import Message(Message(..))
+import Path({-Path(..),-}path, turn)
+
+compPath (tag, ev) wrongaddr c =
+    case path tag of
+      (L, tag') -> c $ Left (Low (tag', ev))
+      (R, tag') -> c $ Right (Low (tag', ev))
+      _ -> wrongaddr
+
+compTurnLeft  (tag, cmd) = Low (turn L tag, cmd)
+compTurnRight (tag, cmd) = Low (turn R tag, cmd)
diff --git a/hsrc/combinators/SerCompF.hs b/hsrc/combinators/SerCompF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/SerCompF.hs
@@ -0,0 +1,87 @@
+module SerCompF(stubF, bypassF, throughF, toBothF,
+                idF, concatMapF, mapF, mapstateF, absF, idLeftF,
+                idRightF, serCompLeftToRightF, serCompRightToLeftF,
+		serCompF) where
+--import Command(Command(..))
+import CompF
+import CompFfun(postMapHigh)
+import CompSP
+--import Direction
+--import Event(Event(..))
+import Fudget
+import Loop
+--import Message(Message(..))
+import NullF
+--import Path(Path(..))
+import Route
+import Spops
+import EitherUtils(stripEither)
+import LayoutHints
+
+serCompF (F f1) (F f2) = layoutHintF serHint (F{-ff-} $ serCompF' f1 f2)
+
+serCompF' :: FSP a b -> FSP c a -> FSP c b
+serCompF' f1 f2 =
+    let post (Left (High x)) = High x
+        post (Left (Low tcmd)) = compTurnLeft tcmd
+        post (Right tcmd) = compTurnRight tcmd
+        mid (Left ltev) = Left ltev
+        mid (Right (Low tcmd)) = Right tcmd
+        mid (Right (High x)) = Left (High x)
+        pre (High x) = [Right (High x)]
+        pre (Low ([], _)) = []
+        pre (Low tev) = compPath tev [] (:[])
+    in  serCompSP (postMapSP post
+                             (serCompSP (idRightSP f1)
+                                        (postMapSP mid (idLeftSP f2))))
+                  (concmapSP pre)
+
+serCompRightToLeftF :: (F (Either a b) (Either c a)) -> F b c
+serCompRightToLeftF (F sp) =
+    let post (Low x) = Right (Low x)
+        post (High (Left x)) = Right (High x)
+        post (High (Right x)) = Left x
+        pre (Right (Low x)) = Low x
+        pre (Right (High x)) = High (Right x)
+        pre (Left xs) = High (Left xs)
+    in F{-ff-} $ loopLeftSP (prepostMapSP pre post sp)
+
+serCompLeftToRightF :: (F (Either a b) (Either b c)) -> F a c
+serCompLeftToRightF (F sp) =
+    let post (Low x) = Right (Low x)
+        post (High (Right x)) = Right (High x)
+        post (High (Left x)) = Left x
+        pre (Right (Low x)) = Low x
+        pre (Right (High x)) = High (Left x)
+        pre (Left xs) = High (Right xs)
+    in F{-ff-} $ loopLeftSP (prepostMapSP pre post sp)
+
+idRightF :: (F a b) -> F (Either a c) (Either b c)
+--and idRightF w = w:+:idF
+idRightF w = compF w idF
+
+idLeftF w = compF idF w
+
+absF :: (SP a b) -> F a b
+absF sp =
+    let pre (High x) = [x]
+        pre (Low y) = []
+    in F{-ff-} $ serCompSP (postMapSP High sp) (concmapSP pre)
+
+concatMapF = absF . concatMapSP
+mapF = absF . mapSP
+mapstateF f x = absF (mapstateSP f x)
+
+idF = mapF id
+
+toBothF = concatMapF (\x -> [Left x, Right x])
+
+throughF w = serCompF (idRightF w) toBothF
+
+--and throughF w = idRightF w:==:toBothF
+bypassF :: (F a a) -> F a a
+bypassF f = postMapHigh stripEither (throughF f)
+
+stubF :: F a b -> F c d
+stubF f = serCompF (serCompF nullF f) nullF
+
diff --git a/hsrc/combinators/StateMonads.hs b/hsrc/combinators/StateMonads.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/StateMonads.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP #-}
+module StateMonads where
+import Control.Applicative
+import Control.Monad(ap)
+import Fudget(K) --,KEvent
+import FudgetIO
+import StreamProcIO
+import EitherUtils(Cont(..))
+import NullF(getK)
+
+--------------------------------------------------------------------------------
+
+-- | The continuation monad
+#ifdef __HBC__
+newtype Mk k r = Mk (Cont k r)
+unMk (Mk mk) = mk
+#else
+newtype Mk k r = Mk {unMk::Cont k r}
+#endif
+-- | Continuation monad with unit result
+type Mkc k = Mk k ()
+
+instance Functor (Mk k) where
+  fmap f (Mk m) = Mk (\k -> m (k.f))
+
+instance Applicative (Mk k) where
+  pure = return
+  (<*>) = ap
+  
+instance Monad (Mk k) where
+  return r =  Mk ($ r)
+  Mk m1 >>= xm2 = Mk (m1 . flip (unMk . xm2))
+
+--------------------------------------------------------------------------------
+
+-- | Continuation monad with state (just an instance of the continuation monad)
+type Ms k s r = Mk (s -> k) r
+type Msc k s = Ms k s ()
+
+loadMs  :: Ms k s s
+storeMs :: s -> Msc k s
+modMs   :: (s -> s) -> Msc k s
+fieldMs :: (s -> f) -> Ms k s f
+
+loadMs    = Mk (\ k s -> k s s)
+storeMs s = Mk (\ k _ -> k () s)
+modMs   f = Mk (\ k s -> k () (f s))
+fieldMs r = Mk (\ k s -> k (r s) s)
+
+nopMs :: Msc k s
+nopMs = return ()
+
+--------------------------------------------------------------------------------
+
+toMkc :: (k -> k) -> Mkc k
+toMkc k = Mk (\f -> k (f ()))
+
+toMs :: Cont k r -> Ms k s r
+toMs f = Mk (bmk f)
+bmk f = (f .) . flip
+
+toMsc :: (k -> k) -> Msc k r
+toMsc k = Mk (\f -> k . f ())
+
+--------------------------------------------------------------------------------
+-- | Fudget Kernel Monad with State (just an instance...)
+type Ks i o s ans = Ms (K i o) s ans
+--type Ksc i o s = Ks i o s ()
+
+{-
+putsKs :: [KCommand a] -> Ksc b a c
+putKs  :: KCommand a -> Ksc b a c
+getKs  :: Ks a b c (KEvent a)
+nullKs :: Ks i o s ()
+loadKs :: Ks i o s s
+storeKs :: s -> Ks i o s ()
+-}
+putHighsMs c = toMsc (puts c)
+putHighMs  c = toMsc (put c)
+putLowsMs  c = toMsc (putLows c)
+putLowMs   c = toMsc (putLow c)
+getKs        = toMs getK
+
+
+-- Some synonyms, kept mostly for backwards compatibility
+nullKs   =  nopMs
+storeKs  = storeMs
+loadKs   = loadMs
+unitKs x = return x
+bindKs m1 xm2 = m1>>=xm2
+thenKs m1 m2 = m1>>m2
+mapKs f = fmap f
+
+-- Running a kernel monad
+
+--stateMonadK :: s -> Ks i o s ans -> (ans -> K i o) -> K i o
+stateMonadK s0 (Mk ks) k = ks (\ans state->k ans) s0
+
+--stateK :: a -> (Ksc b c a) -> (K b c) -> K b c
+stateK s (Mk ksc) k = ksc (const (const k)) s
diff --git a/hsrc/combinators/TreeF.hs b/hsrc/combinators/TreeF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/combinators/TreeF.hs
@@ -0,0 +1,19 @@
+module TreeF where
+import BranchF
+import CompFfun(prepostMapHigh')
+import Utils(pair)
+import Fudget
+
+data Tree a = Leaf a | Branch (Tree a) (Tree a)  deriving (Eq, Ord)
+
+treeF :: Tree (a, F b c) -> F (Path, b) (a, c)
+treeF = F{-ff-} . treeF'
+
+treeF' :: Tree (a, F b c) -> FSP (Path, b) (a, c)
+treeF' (Leaf (t, f)) = leafF t f
+treeF' (Branch l r) = branchFSP (treeF' l) (treeF' r)
+
+leafF t (F sp) =
+    let pre ([], x) = x
+        pre _ = error "unknown path in treeF"
+    in  prepostMapHigh' pre (pair t) sp
diff --git a/hsrc/containers/BubbleF.hs b/hsrc/containers/BubbleF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/BubbleF.hs
@@ -0,0 +1,86 @@
+module BubbleF(bubbleF, bubblePopupF, bubbleRootPopupF) where
+--import Alignment(Alignment(..))
+import Command
+import XDraw
+import CompOps((>=^<), (>^=<))
+import Dlayout(groupF)
+import Event
+import Fudget(F)
+--import FudgetIO
+import FRequest
+import NullF()
+import Gc
+import Geometry(origin,pP,Point(..),psub,padd)
+import LayoutRequest(LayoutResponse(..))
+import Message(Message(..))
+import PopupGroupF
+--import Popupmsg
+import Spacer(sepF)
+import ShapeK
+import MapstateK
+import EitherUtils(stripEither)
+import Xtypes
+
+default(Int) -- mostly for Hugs
+
+bubblePopupF f =
+    popupGroupF (bubbleOffset, wattrs, bubbleShapeK) (bubbleF f)
+
+bubbleRootPopupF f =
+    rootPopupF (bubbleOffset, rwattrs, bubbleShapeK) (bubbleF f)
+
+bubbleF :: (F a b) -> F a b
+bubbleF f =
+  let startcmds = [XCmd $ ChangeWindowAttributes wattrs]
+  in stripEither >^=<
+     groupF startcmds bubbleShapeK (sepF sep f) >=^< Right
+
+wattrs = [CWEventMask [ExposureMask]]
+rwattrs = CWOverrideRedirect True:wattrs
+
+bubbleShapeK =
+  wCreateGC rootGC [GCLineWidth 2] $
+  shapeK fillBubble . bubbleK
+
+bubbleK gc =
+  let bubbleT state@size msg =
+	case msg of
+	  Low (LEvt (LayoutSize size')) -> (size', [])
+	  Low (XEvt (Expose _ 0)) ->
+	    (state, if size == origin
+	            then []
+		    else [Low $ wDraw gc (drawBubble (size-1))])
+	  _ -> (state, [])
+  in mapstateK bubbleT origin
+
+drawBubble size = DrawLines CoordModeOrigin (bubblePoints size)
+fillBubble size = [FillPolygon Convex CoordModeOrigin (bubblePoints size)]
+
+c = 4
+ah = 12
+ax = 12
+aw = 6
+atx = 6
+bubbleBorder = ah + c
+sep = pP (2 * c) (2 * c + bubbleBorder)
+bubbleOffset (Point _ h) = Point atx (h - c)
+
+bubblePoints size =
+    let Point w h = psub size (pP 0 (2 * bubbleBorder))
+    in  map (padd (pP 0 bubbleBorder))
+            [pP c 0,
+             pP (w - c) 0,
+             pP w c,
+             pP w (h - c),
+             pP (w - c) h,
+             pP (ax + aw) h,
+             pP atx (h + ah),
+             pP ax h,
+             pP c h,
+             pP 0 (h - c),
+             pP 0 c,
+             pP c 0]
+
+--drawlines (p1 : p2 : ps) = DrawLine (Line p1 p2) : drawlines (p2 : ps)
+--drawlines _ = []
+
diff --git a/hsrc/containers/Containers.hs b/hsrc/containers/Containers.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/Containers.hs
@@ -0,0 +1,21 @@
+module Containers ( -- * Containers
+  module BubbleF,module Dlayout,module DragF,module PopupF,module PopupGroupF,module PosPopupShellF,module ScrollF,module SelectionF,module DShellF,module Shells,module RootWindowF) where
+import BubbleF
+import Dlayout
+import DragF
+import PopupF
+import PopupGroupF
+import PosPopupShellF
+import ScrollF
+import SelectionF
+import DShellF
+import Shells
+import RootWindowF
+
+{-
+import Fudget
+import Geometry(Rect,Size(..),Point)
+import Popupmsg(PopupMsg)
+import Xtypes(Button,ModState(..),Modifiers,WindowAttributes,KeySym(..),ColorName(..),FontName(..))
+import FDefaults
+-}
diff --git a/hsrc/containers/DShellF.hs b/hsrc/containers/DShellF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/DShellF.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE CPP #-}
+module DShellF(ShellF,shellF, shellF', shellKF, shellKF',
+       setDeleteWindowAction,
+       getDeleteWindowActionMaybe', -- for use in titleShellF
+       DeleteWindowAction(..),setDeleteQuit,
+       HasClickToType(..),setInitPos,setFocusMgr,
+       HasVisible(..)) where
+
+import FDefaults
+import Dlayout(sF)
+import AutoLayout(autoLayoutF',nowait)
+import QuitK
+import Fudget
+import EitherUtils
+import CompOps
+import Geometry(Point(..))
+import Command
+import Xcommand
+import Xtypes
+import Defaults(defaultSep,defaultPosition)
+import CmdLineEnv(argFlag)
+import FocusMgr(focusMgr)
+--import Placer
+--import Spacers
+import Spacer(marginF)
+--import LayoutRequest
+import Sizing(Sizing(..))
+import NullF
+import ParK
+--import Maptrace(ctrace) -- debugging
+#include "defaults.h"
+
+newtype ShellF = Pars [Pars]
+data Pars
+  = WinAttr [WindowAttributes]
+  | DeleteWindowAction (Maybe DeleteWindowAction)
+  | ClickToType Bool
+  | FocusMgr Bool -- mainly for internal use
+  | Visible Bool
+  | Margin Int
+  | Sizing Sizing
+  | InitPos (Maybe Point)
+
+data DeleteWindowAction = DeleteQuit | DeleteUnmap deriving (Eq,Show)
+
+parameter(InitPos)
+parameter(FocusMgr)
+
+parameter_instance(WinAttr,ShellF)
+
+parameter(DeleteWindowAction)
+getDeleteWindowActionMaybe' pm =
+  getDeleteWindowActionMaybe (pm (Pars []))
+
+-- Backwards compatibility:
+setDeleteQuit b = setDeleteWindowAction (if b then Just DeleteQuit else Nothing)
+
+parameter_class(ClickToType,Bool)
+parameter_instance(ClickToType,ShellF)
+
+
+parameter_class(Visible,Bool)
+parameter_instance(Visible,ShellF)
+
+parameter_instance(Margin,ShellF)
+parameter_instance(Sizing,ShellF)
+
+shellF = shellF' standard
+shellF' pmod s f = stripEither >^=< shellKF' pmod k f >=^< Right where
+	k = xcommandK (StoreName s) nullK
+
+shellKF = shellKF' standard
+
+shellKF' :: (Customiser ShellF)->K a b -> F c d -> F (Either a c) (Either b d)
+shellKF' pmod k f = genShellF siz clicktt focusmgr vis pos sep [] kernel f
+ where
+   ps = pmod (Pars [WinAttr [],DeleteWindowAction (Just DeleteQuit),
+                    ClickToType ctt, FocusMgr defFocusMgr,
+                    InitPos defaultPosition, -- hmm
+		    Visible True,Margin defaultSep,Sizing Dynamic])
+						-- !! Change default Sizing?
+   d_action = getDeleteWindowAction ps
+   clicktt = getClickToType ps
+   focusmgr = getFocusMgr ps
+   sep = getMargin ps
+   vis = getVisible ps
+   wa = getWinAttr ps
+   siz = getSizing ps
+   pos = getInitPos ps
+   kernel = xcommandK (ChangeWindowAttributes wa) $
+	    maybe (wmDeleteWindowK (const k)) -- see (*) in QuitK.hs
+		  (\ a -> quitK (action a) `parK` k)
+		  d_action
+
+   action DeleteQuit = exitK
+   action DeleteUnmap = unmapWindowK
+
+genShellF sizing ctt focusmgr map pos sep cmds k f = 
+       sF (not map) pos cmds k (filter (sepf f)) where
+   filter = if focusmgr
+            then focusMgr sizing ctt
+            else autoLayoutF' nowait sizing -- usually sits inside a groupF in focusMgr
+   sepf = if sep == 0 then id else marginF sep
+
+ctt = argFlag "ctt" True
+defFocusMgr = argFlag "focusmgr" True
diff --git a/hsrc/containers/Dlayout.hs b/hsrc/containers/Dlayout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/Dlayout.hs
@@ -0,0 +1,142 @@
+module Dlayout(invisibleGroupF,
+               simpleGroupF, unmappedGroupF, groupF, groupF',
+	       sgroupF, swindowF,
+               windowF,sF) where
+--import Alignment(Alignment(..))
+import Command
+import CompFfun(prepostMapHigh)
+--import CompOps((>=^^<), (>^=<),(>..=<))
+import Defaults(bgColor)
+import CmdLineEnv(resourceName)
+import Event
+import Fudget
+import FRequest
+import Geometry(Point(..), Rect(..), origin, pmax)
+import GreyBgF(changeBg)
+import LayoutRequest
+import LoopLow
+--import Message(Message(..))
+import NullF
+import Spops
+--import SpEither(mapFilterSP)
+import AutoLayout(autoLayoutF',nowait)
+import Sizing(Sizing(..))
+import EitherUtils(stripEither)
+--import Utils(oo)
+import WindowF
+import Xtypes
+--import Placer(placerF,spacerF)
+--import Spacers
+--import AutoPlacer(autoP)
+import ParSP
+--import CompSP
+import Path(turn,here)
+import Direction(Direction(..))
+
+addEventMask addmask =
+    let addem [] = []
+        addem (CWEventMask mask : wattrs) =
+            CWEventMask (addmask ++ mask) : wattrs
+        addem (wattr : wattrs) = wattr : addem wattrs
+    in  addem
+
+shell :: Bool -> (F a b) -> F a b
+shell nomap f =
+    let eventmask = [StructureNotifyMask,KeyPressMask,KeyReleaseMask,FocusChangeMask]
+
+        prep ss@(osize,sizeq, Just ltag) (Low (tag, XEvt (ConfigureNotify (Rect _ nsize) _)))
+           | tag == kernelTag = case sizeq of 
+	     (size:sizeq') | size == nsize -> ((nsize,sizeq',Just ltag),[])
+	     _ -> if nsize == osize then (ss,[]) else
+	        ((nsize,sizeq,Just ltag),[(ltag,LEvt $ LayoutPlace (Rect origin nsize))])
+        prep s (Low (t,e@(XEvt (FocusIn  {})))) | t == kernelTag = (s,[(focusMgrTag, e)])
+        prep s (Low (t,e@(XEvt (FocusOut {})))) | t == kernelTag = (s,[(focusMgrTag, e)])
+        prep s (Low (t,e@(XEvt (KeyEvent {})))) | t == kernelTag = (s,[(focusMgrTag, e)])
+        prep s (Low msg) = (s, [msg])
+        prep (osize,sizeq, _) (High (tag, nsize)) = 
+	  ((osize,sizeq++ (if null sizeq || last sizeq /= nsize then [nsize] else []), Just tag),
+	   [(tag, LEvt $ LayoutPlace (Rect origin nsize))])
+
+        focusMgrTag = turn R $ turn L here -- hardwired assumption
+        minSize = Point 1 1
+
+        post nomap' (tag, LCmd lreq) = case lreq of
+	  LayoutRequest (Layout {minsize=size}) ->
+            (True,
+             High (tag, size) :
+             toKernel ([XCmd $ resizeWindow (pmax minSize size)] ++
+                       (if nomap' then [] else [XCmd $ MapRaised])))
+            -- we should actually wait with MapRaised until f reports OK somehow...
+          _ -> (nomap',[]) {- filter all other layout msgs -}
+        post nomap' (tag, XCmd (ChangeWindowAttributes wattrs)) | tag == kernelTag =
+            (nomap',
+             [Low (tag, XCmd $ ChangeWindowAttributes (addEventMask eventmask wattrs))])
+        post nomap' (_,XCmd MeButtonMachine) = (nomap', [])
+        post nomap' cmd@(tag, XCmd (ChangeWindowAttributes wattrs)) = (nomap',[Low cmd])
+        post nomap' cmd = (nomap', [Low cmd])
+        startcmds = toKernel [XCmd $ ChangeWindowAttributes [CWEventMask []],
+                              XCmd $ SetWMHints True]
+    in  loopLow (mapstateSP' post nomap)
+                (mapstateSP prep ((Point 10 10),[], Nothing)) {- 10 10 from windowKF... -}
+                (myAppendStartF startcmds f)
+
+mapstateSP' f s0 =
+    getSP (\x ->
+           case f s0 x of
+             (s, y) -> putsSP y (mapstateSP' f s))
+{-
+-- causes a space leak with nhc13 and ghc-7.6
+mapstateSP' f s0 =
+    getSP (\x ->
+           let (s, y) = f s0 x
+           in putsSP y (mapstateSP' f s))
+-}
+-- myAppendStart will let f speak all its initial msgs, not just the first one.
+myAppendStartF cmds (F f) = {-F-}ff $ parSP f (putsSP cmds nullSP)
+
+windowF :: [FRequest] -> (K a b) -> F a b
+windowF cmds = swindowF cmds Nothing
+
+swindowF cmd oplace k = 
+    prepostMapHigh Left stripEither (group0F sizing False cmd oplace k Nothing)
+  where sizing = if oplace==Nothing then Static else Dynamic
+
+sF nomap pos lc k f =
+    let r = Nothing -- temporary
+        p =
+            case r of
+              Just (Rect p _) -> Just p
+              Nothing -> pos
+        lc' =
+            case p of
+              Just p' -> XCmd (SetNormalHints p') : XCmd (moveWindow p') : lc
+              Nothing -> lc
+    in shell nomap
+          (windowKF (XReq . flip CreateRootWindow resourceName) True nomap lc' r (bgK k) f)
+
+group0F sizing nomap cmds r k mf =
+    case mf of
+      Nothing -> w nullF
+      Just f -> w $ autoLayoutF' nowait sizing f
+  where w = windowKF (XReq . CreateMyWindow) False nomap cmds r k 
+
+sgroupF sizing cmds r k = group0F sizing False cmds r k . Just
+groupF' sizing cmds = sgroupF sizing cmds Nothing
+groupF = groupF' Dynamic
+
+unmappedGroupF sizing cmds k = group0F sizing True cmds Nothing k . Just
+
+
+simple sf sizing startcmds k w =
+    prepostMapHigh Right stripEither (sf sizing startcmds k w)
+
+bgK = changeBg bgColor
+
+--sGF :: (K a b) -> [WindowAttributes] -> (F a b) -> F a b
+sGF sizing k wattrs =
+  simple groupF' sizing [XCmd $ ChangeWindowAttributes wattrs] k
+
+simpleGroupF = sGF Dynamic (bgK nullK)
+invisibleGroupF sizing cmds = 
+     sGF sizing (bgK (putsK (map Low cmds) nullK))
+
diff --git a/hsrc/containers/DragF.hs b/hsrc/containers/DragF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/DragF.hs
@@ -0,0 +1,250 @@
+module DragF(containerGroupF,hPotF,hPotF',vPotF,vPotF',PotRequest(..),PotState(..)) where
+import Command
+import CompOps((>=^<), (>^=<))
+import CompFfun(prepostMapHigh)
+import Cursor
+import Dlayout(groupF,groupF')
+import Sizing(Sizing(..))
+import Event
+--import Color
+import Fudget
+--import FudgetIO
+import FRequest
+import NullF
+import Geometry
+import GreyBgF
+import Border3dF(border3dF)
+import LayoutRequest(LayoutResponse(..))
+import LayoutF(holeF')
+import Spacers(hvMarginS)
+import DynSpacerF(dynSpacerF)
+import Spacer(noStretchF)
+import Alignment
+import Loops(loopCompThroughRightF,loopLeftF)
+--import Message(Message(..))
+import EitherUtils(stripEither)
+import Data.Maybe(fromMaybe)
+import CmdLineEnv(argReadKey)
+import Xtypes
+--import Maptrace(ctrace)
+
+data PotRequest = ResizePot Int Int -- frame size, total size
+                | MovePot   Int     -- new position
+		| PotMkVisible Int Int (Maybe Alignment) -- pos, length, alignm
+		| PotInput (ModState, KeySym) -- remote control
+
+type PotState = (Int,Int,Int)  -- position, frame size, total size
+
+knobS knob@(Rect kp ks) box@(Rect bp bs) =
+  --ctrace "knobS" (knob,box) $
+  hvMarginS (kp+margin) (bs+margin-kp-ks)
+
+knobK box knob pabs =
+    let cont knob' pabs' = knobK box knob' pabs'
+        newbox box' knob' = knobK box' knob' pabs
+        same = cont knob pabs
+	output knob = putK (High (Right knob))
+	repos knob box = putK (High (Left (knobS knob box)))
+    in  getK $ \msg ->
+        case msg of
+          Low (XEvt (MotionNotify {rootPos=pabs',state=mods})) ->
+	    let knob' = moverect knob (psub pabs' pabs)
+	        knob'' = confine box knob'
+		pabs'' = padd pabs' (rsub knob'' knob')
+            in  repos knob'' box $
+                (if Shift `elem` mods then id else output knob'') $
+	        cont knob'' pabs''
+          Low (XEvt (ButtonEvent {rootPos=pabs',type'=Pressed})) -> cont knob pabs'
+          Low (XEvt (ButtonEvent {type'=Released})) -> output knob $ same
+          High (newknob, box') ->
+	    let knob' = confine box' newknob
+                msgs = (if knob'/=knob || box'/=box
+                        then repos knob' box'
+			else id) .
+		       (if knob'/=knob -- was: knob/=newknob
+		        then output knob'
+			else id)
+            in msgs $
+               newbox box' knob'
+          _ -> same
+
+-- New version, using new more general containterGroupF
+-- containterGroupF should be replaced.
+containerGroupF knob box cursorshape buttons modifiers fudget =
+    loopLeftF $
+    prepostMapHigh pre post $
+    dynSpacerF $
+    groupF initcmds
+           (setFontCursor cursorshape (knobK box knob origin))
+           fudget
+  where attrs = [CWEventMask []]
+        initcmds = map XCmd 
+	           [ChangeWindowAttributes attrs,
+		    GrabButton False buttons modifiers
+                        [PointerMotionMask, ButtonReleaseMask]]
+		    --MapRaised]
+        pre = id
+	post = either (either Left (Right. Left)) (Right. Right)
+
+knobF cursor box knob =
+    (stripEither >^=< containerGroupF knob box cursor (Button 1) [] vF ) >=^<
+    Left
+  where vF = raisedF (holeF' s)
+	s = rectsize knob
+
+staticBorder3dF down fud = border3dF down 2 fud >=^< Right
+raisedF = staticBorder3dF False
+loweredF = staticBorder3dF True
+
+--topleft = diag 2
+--margin = diag 6
+topleft = diag 0
+margin = diag (argReadKey "potmargin" 0)
+
+absknobpos size (pos, frame, tot) =
+    if tot == 0
+    then (0, max 1 size)
+    else ((pos * size + tot `div` 2) `quot` tot, max 1 (frame * size `quot` tot))
+
+newkpos :: PotState -> (Int,Int) -> PotState
+newkpos (_, frame, tot) (pos, size) = (pos * tot `quot` size, frame, tot)
+
+knobup d (pos, frame, tot) = (0 `max` (pos - d), frame, tot)
+knobdown d (pos, frame, tot) = ((tot - frame) `min` (pos + d), frame, tot)
+pageup knob@(_, frame, _) = knobup frame knob
+pagedown knob@(_, frame, _) = knobdown frame knob
+
+stepup len knob = knobup (stepsize len knob) knob
+stepdown len knob = knobdown (stepsize len knob) knob
+stepsize size (_,_,tot) = (tot+size-1) `quot` size
+
+knobhome (_, frame, tot) = (0, frame, tot)
+knobend (_, frame, tot) = (tot - frame, frame, tot)
+
+resizePot (pos,_,_) frame tot = (pos,frame,tot) -- !! should adjust pos if necessary
+movePot (_,frame,tot) pos = (pos,frame,tot) -- !! should keep pos within boundaries
+
+--and adjkpos (pos,frame,tot) frame' tot' = (min (tot'-frame') (pos*tot'/tot),frame',tot')
+
+keyAction mods s len =
+    case s of
+      s | s == "space"  || s == "Next"  -> Just (shift knobend pagedown)
+      s | s `elem` pageupKeys           -> Just (shift knobhome pageup)
+      s | s == "Home"                   -> Just knobhome
+      s | s == "End"                    -> Just knobend
+      s | s == "Down"   || s == "Right" -> Just (stepdown len)
+      s | s == "Up"     || s == "Left"  -> Just (stepup len)
+      _ -> Nothing
+  where
+    shift = if Shift `elem` mods then const else const id
+    pageupKeys = ["Delete","BackSpace","Prior"]
+
+mkVisible (pos,frame,tot) first last optAlign =
+  case optAlign of
+    Just a -> Just (max 0 (min (tot-frame) pos'),frame,tot)
+      where pos' = first+truncate (a*fromIntegral (last-first-frame))
+    _ ->
+      if first<pos || last-first>frame
+      then Just (first,frame,tot)
+      else if last>pos+frame
+	   then Just (last-frame,frame,tot)
+	   else Nothing
+
+potF hori par ort vect shape grav acceptFocus optsize =
+    loopCompThroughRightF potGroupF
+  where
+    potGroupF =
+	noStretchF (not hori) hori $
+	loweredF $ 
+	groupF' Static startcmds 
+	       (darkGreyBgK potK0)
+	       (knobF shape box0 (knob length0 kpos0))
+      where wattrs = [CWEventMask eventmask]
+	    alwayseventmask = [ButtonPressMask,Button2MotionMask]
+	    focuseventmask = [EnterWindowMask, LeaveWindowMask, KeyPressMask]
+	    eventmask = alwayseventmask ++ 
+	                if acceptFocus then focuseventmask else []
+	    startcmds = [--XCmd $ LayoutMsg (Layout wsize (not hori) hori),
+			 XCmd $ ChangeWindowAttributes wattrs]
+    wsize    = fromMaybe (vect 50 11) optsize
+    boxsize0 = psub wsize margin
+    length0  = par boxsize0
+    boxwidth = ort boxsize0
+    knob length' kpos' =
+	let (pos, size) = absknobpos length' kpos'
+	in  Rect (padd topleft (vect pos 0)) (vect size boxwidth)
+    box0 = Rect topleft boxsize0
+    potK0 = potK1 --allocNamedColorPixel defaultColormap "white" potK1
+    potK1 = potK kpos0 length0 where
+      potK kpos len =
+	  let cont kpos' = potK kpos' len
+	      newlen kpos' len' = potK kpos' len'
+	      same = cont kpos
+	      report kpos' = --ctrace "report" kpos' $
+	                     High (Right kpos')
+	      changeknob len' kpos' =
+		  High (Left (knob len' kpos',
+			     Rect topleft (vect len' boxwidth)))
+	      moveknob kpos' = --ctrace "moveknob" kpos' $
+			       putsK [changeknob len kpos'{-,report kpos'-}] $
+			       -- Rely on the knob to report the new position,
+			       -- after it has been confined to the box. This
+			       -- is a fix for button2Action that result in
+			       -- positions outside the box...
+			       same -- cont kpos'
+	      keyInput mods key = maybe same act (keyAction mods key len)
+		where act action = moveknob (action kpos)
+
+	      button2Action p = newkpos kpos (par p, len)
+
+	      buttonAction (Button 2) mods p = button2Action p
+	      buttonAction b mods p =
+		case (par p < par (rectpos (knob len kpos)),
+		      Shift `elem` mods || Control `elem` mods) of
+	          (True, False) -> pageup   kpos
+	    	  (True, True ) -> knobhome kpos
+		  (False,False) -> pagedown kpos
+		  (False,True ) -> knobend  kpos
+
+	  in getK $ \msg ->
+	     case msg of
+	       Low (XEvt (ButtonEvent {button=b,pos=p,state=mods,type'=Pressed})) ->
+	         moveknob (buttonAction b mods p)
+	       Low (XEvt (MotionNotify {pos=p,state=mods})) | Button2 `elem` mods ->
+	         moveknob (button2Action p)
+	       Low (LEvt (LayoutSize size')) ->
+		 let len' = par size' - par margin
+		 in if len'/=len
+	            then putsK [changeknob len' kpos] (newlen kpos len')
+		    else same
+	       Low (XEvt (KeyEvent _ _ _ mods Pressed _ key _)) ->
+	          keyInput mods key
+	       Low (XEvt (FocusIn {detail=d})) | d /= NotifyInferior -> 
+		  lightGreyBgK same
+	       Low (XEvt (FocusOut {detail=d})) | d /= NotifyInferior -> 
+		  darkGreyBgK same
+	       High (Right (PotInput (mods,key))) -> keyInput mods key
+	       High (Right (ResizePot frame tot)) ->
+		 let kpos' = resizePot kpos frame tot
+		 in putK (changeknob len kpos') (cont kpos')
+	       High (Right (MovePot pos)) ->
+		 let kpos' = movePot kpos pos
+		 in putK (changeknob len kpos') (cont kpos')
+	       High (Right (PotMkVisible pos size optAlign)) ->
+		 case mkVisible kpos pos (pos+size) optAlign of
+		   Just kpos' -> moveknob kpos'
+		   Nothing    -> same
+	       High (Left newknob) ->
+                 --ctrace "newknob" newknob $	       
+		 let kpos' = newkpos kpos (par (rsub newknob box0), len)
+		 in  if kpos'==kpos -- False
+		     then same
+		     else putK (report kpos') (cont kpos')
+	       _ -> same
+    kpos0 = (0,1,1)
+
+vPotF' = potF False ycoord xcoord (\x -> \y -> Point y x) 116 NorthEastGravity
+hPotF' = potF True xcoord ycoord Point 108 SouthWestGravity
+
+vPotF = vPotF' True Nothing
+hPotF = hPotF' True Nothing
diff --git a/hsrc/containers/FreeGroupF.hs b/hsrc/containers/FreeGroupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/FreeGroupF.hs
@@ -0,0 +1,56 @@
+module FreeGroupF(freeGroupF) where
+--import Fudget
+import EitherUtils
+import Path(here)
+import LayoutRequest
+import Geometry
+--import Command
+--import Event
+--import Xtypes
+
+import Dlayout(groupF)
+import UserLayoutF(userLayoutF)
+import Spops
+--import SpEither(mapFilterSP)
+import NullF(nullK)
+import SerCompF(absF)
+import LoopCompF(loopCompF)
+import CompOps
+import Defaults(bgColor)
+import GreyBgF(changeBg)
+
+freeGroupF f =
+    loopCompF (absF placeSP0>+<innerF)
+  where
+    innerF = userLayoutF $
+             stripEither >^=< groupF [] (bgK nullK) f >=^< Right
+
+    placeSP0 = placeSP False here (rR 0 0 0 0) {- dummy initial path & place -}
+
+    placeSP placed path place =
+      let same = placeSP placed path place
+      in 
+      getSP $ \ msg ->
+      case msg of
+        Left (path',layoutmsg) ->
+	  case layoutmsg of
+	    LayoutRequest req ->
+	      let place' = sizerect place (minsize req)
+	      in putSP (Right layoutmsg) $ placeSP False path' place'
+	    LayoutMakeVisible _ _ -> putSP (Right layoutmsg) same
+	    LayoutScrollStep _ -> putSP (Right layoutmsg) same
+            _ -> same -- ignore other msgs for now
+	Right (Right pos) ->
+	  let place' = posrect place pos
+	  in putSP (Left (path,place')) $
+	     placeSP True path place'
+	Right (Left newtotsize) ->
+	  let place' = sizerect place newtotsize
+	  in ifSP (not placed || place'/=place)
+                  (putSP (Left (path,place'))) $
+	    --  ^^ dangerous optimization?
+	     placeSP True path place'
+
+ifSP b th = if b then th else id
+
+bgK = changeBg bgColor
diff --git a/hsrc/containers/PopupF.hs b/hsrc/containers/PopupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/PopupF.hs
@@ -0,0 +1,53 @@
+module PopupF(popupShellF,popupShellF') where
+import Command
+import DShellF
+import FDefaults
+import Fudget
+import FRequest
+import Xcommand
+import Geometry(Point(..), pP)
+--import LayoutRequest(LayoutRequest)
+import Loops(loopCompThroughRightF)
+--import Message(Message(..))
+--import Spops
+import MapstateK
+import Xtypes
+--import NullF(putsK)
+import CompSP
+import Path(here)
+
+popupShellF = popupShellF' standard
+
+popupShellF' :: Customiser ShellF -> String -> Maybe Point -> F a b -> F a (a,b)
+popupShellF' pm title optpos (F f) =
+  let pos = case optpos of
+              Just pos -> pos
+              Nothing -> pP 300 300
+      params = pm . setVisible False . setDeleteQuit False
+  in loopCompThroughRightF (shellKF' params (popupK title pos) 
+			   (F{-ff-} $ prepostMapSP pre post (idRightSP f)))
+
+pre (Low m) = Left (Low m)
+pre (High (Left a)) = Left (High a)
+pre (High (Right a)) = Right a
+post (Right a) = Low (here,a)
+post (Left (Low m)) = Low m
+post (Left (High a)) = High a
+
+popupK title pos =
+  let kf s@(mapped,trig) msg =
+	  case msg of
+	    High (Right trig') -> ((True,trig'), 
+	      [High (Left (Left trig')),lowfromf (GrabEvents True)] ++
+	       if not mapped then [Low $ XCmd MapRaised] else [])
+	    High (Left x) -> ((False,trig),
+			      (if mapped then unmapcmds else []) ++ 
+			      [lowfromf UngrabEvents,High (Right (trig, x))])
+	    Low _ -> (s, [])
+      lowfromf = High . Left . Right . XCmd
+      unmapcmds = [Low $ XCmd UnmapWindow,Low $ XCmd Flush]
+      startcmds =
+	  [StoreName title, SetNormalHints pos, moveWindow pos,
+	   ChangeWindowAttributes [CWSaveUnder True]]
+  in xcommandsK startcmds $
+     mapstateK kf (False,error "premature output from fudget inside popupShellF")
diff --git a/hsrc/containers/PopupGroupF.hs b/hsrc/containers/PopupGroupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/PopupGroupF.hs
@@ -0,0 +1,66 @@
+module PopupGroupF(popupGroupF,rootPopupF) where
+import Command
+import CompOps((>=^^<), (>^^=<))
+--import Direction
+import Dlayout(unmappedGroupF)
+import Sizing(Sizing(..))
+import Shells(unmappedShellF)
+--import Event
+import Fudget
+import FRequest
+import Geometry(psub,pP)
+import LayoutRequest
+import LoopLow
+--import Message(Message(..))
+import ParK
+--import Path(Path(..))
+import Popupmsg
+--import Spops
+import MapstateK
+import SpEither(filterRightSP)
+--import SerCompF(concatMapF)
+import Spops
+--import Xtypes
+
+popupGroupF = popupF (unmappedGroupF Dynamic)
+rootPopupF  = popupF unmappedShellF
+
+popupF grF (offset, wattrs, k) f =
+    let post (tag, cmd) =
+            case cmd of
+              LCmd req ->
+	        case req of
+--		  Layout size fh' fv -> [High (tag, LEvt $ LayoutPlace (Rect origin size))]
+		  LayoutRequest (Layout {minsize=size}) ->
+		    [High (tag, LEvt $ LayoutSize size)]
+		    -- treated specially in windowKF.
+		  _ -> []
+              cmd' -> [Low (tag, cmd')]
+        pre ev =
+            case ev of
+              High ev' -> [ev']
+              Low (_, LEvt (LayoutPlace _)) -> [] -- shouldn't happen?
+              Low tev -> [tev]
+        distr (Popup p x) = [Right x, Left (Left (Just p))]
+        distr Popdown = [Left (Left Nothing)]
+        startcmds = [XCmd $ ChangeWindowAttributes wattrs]
+    in  (filterRightSP >^^=<
+         loopLow (concmapSP post)
+                 (concmapSP pre)
+                 (grF startcmds (compK (placeK offset) k) f)) >=^^<
+        concatMapSP distr
+
+placeK offset = mapstateK sizeT (False,pP 0 0)
+  where
+    sizeT s@(mapped,size) msg =
+      case msg of
+        High (Just p) ->
+	  ((True,size),
+	   [Low $ XCmd (moveWindow (psub p (offset size)))] ++
+	   if not mapped then [Low $ XCmd MapRaised] else [])
+	High Nothing ->
+	  ((False,size),if mapped then [Low $ XCmd UnmapWindow] else [])
+	Low (LEvt (LayoutSize size')) ->
+	  ((mapped,size'), [])
+	_ -> (s, [])
+
diff --git a/hsrc/containers/PosPopupShellF.hs b/hsrc/containers/PosPopupShellF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/PosPopupShellF.hs
@@ -0,0 +1,45 @@
+module PosPopupShellF(posPopupShellF) where
+import Command
+import Shells(unmappedShellF)
+--import Event(Event(..))
+import Fudget
+import FRequest
+import Geometry(origin, pP, psub)
+--import LayoutRequest(LayoutRequest)
+import Loops(loopCompThroughRightF)
+--import Message(Message(..))
+import NullF
+--import Path(Path(..))
+import QueryPointer
+--import SP
+--import Xtypes
+
+posPopupShellF title wattrs f =
+    loopCompThroughRightF (unmappedShellF startcmds popupK f)
+  where
+    startcmds =
+        [XCmd $ StoreName title,
+	 XCmd $ SetNormalHints origin,
+	 XCmd $ ChangeWindowAttributes wattrs]
+
+popupK = kf (error "premature output from fudget inside posPopupShellF")
+  where
+    pickPos p cont =
+      case p of
+        Just pos -> cont pos
+	Nothing -> queryPointerK (\(_, r, _, _) -> cont (psub r (pP 5 5)))
+
+    kf s@(mapped,trig) =
+        getK $ \msg ->
+        case msg of
+          High (Right (trig', optpos)) ->
+	    pickPos optpos $ \pos ->
+            putsK ([Low $ XCmd $ moveWindow pos,
+                    High (Left trig')] ++
+                   if not mapped then [Low $ XCmd MapRaised] else []) $
+            kf (True,trig')
+          High (Left y) ->
+	    putsK ((if mapped then [Low $ XCmd UnmapWindow] else []) ++
+		   [High (Right (trig, y))]) $
+            kf (False,trig)
+          _ -> kf s
diff --git a/hsrc/containers/RootWindowF.hs b/hsrc/containers/RootWindowF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/RootWindowF.hs
@@ -0,0 +1,50 @@
+module RootWindowF where
+import Command
+--import Event
+--import Font(FontStruct)
+--import Fudget
+--import Message(Message(..))
+import Geometry(Rect(..),origin,pP)
+--import Path
+import WindowF(kernelF)
+--import NullF(putK)
+--import Xrequest(xrequestF)
+import Xcommand(xcommandK)
+import QueryTree
+import UserLayoutF(userLayoutF)
+import CompOps
+import SerCompF(absF)
+import Loops(loopThroughRightF)
+import Spops(mapSP)
+import AutoLayout(autoLayoutF)
+--import CmdLineEnv(argReadKey)
+--import NullF(nullF)
+import WindowF(kernelTag)
+
+{-
+rootWindowF k =
+    defaultRootWindowF $ \ root ->
+    kernelF (putK (Low (ReparentToMe kernelTag root)) k) >*< nullF
+-}
+  
+rootWindowF k =
+    defaultRootWindowF $ \ root ->
+    kernelF (xcommandK (SelectWindow root) k)
+  
+rootGroupF k f =
+    k' >+< f'
+  where
+    k' = kernelF (
+            defaultRootWindowK $ \ root ->
+            xcommandK (ReparentToMe kernelTag root) k)
+    f' = loopThroughRightF (absF ctrlSP) (userLayoutF (autoLayoutF f))
+    ctrlSP = mapSP ctrl
+    ctrl msg =
+      case msg of
+        Left (Left (path,req)) -> Left (Left (path,screenrect))
+	Left (Right x) -> Right x
+	Right x -> Left (Right x)
+	
+    screenrect = Rect origin (pP 1152 900)
+    -- !!! no Read instance...
+    --screenrect = Rect origin (argReadKey "screensize" (pP 1152 900)) -- !!!
diff --git a/hsrc/containers/ScrollF.hs b/hsrc/containers/ScrollF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/ScrollF.hs
@@ -0,0 +1,181 @@
+module ScrollF(scrollShellF,
+               scrollF,oldScrollF,
+               vScrollF,oldVscrollF,
+	       hScrollF,oldHscrollF,
+	       grabScrollKeys) where
+import Fudget
+import EitherUtils
+import CmdLineEnv(argFlag)
+import Utils(remove)
+import LayoutRequest
+import Geometry
+import Command
+import FRequest
+import Event
+import Xtypes
+
+import FreeGroupF
+import Dlayout(groupF)
+import DShellF(shellF)
+import Spops
+import NullF(nullF)
+import Cont(waitForSP)
+import SpEither(mapFilterSP)
+import DragF(hPotF',vPotF',PotRequest(..))
+import Placer(tableF,hBoxF,vBoxF)
+import SerCompF(absF)
+import Loops(loopThroughRightF)
+import CompOps
+--import Maptrace(ctrace)
+
+scrollShellF name initlimits = shellF name . oldScrollF True initlimits
+
+grabScrollKeys = argFlag "grabscrollkeys" False
+ -- True is not good if there are two or more scrollFs in the same shell window.
+
+-- Std versions with arbirarily chosen limits...
+scrollF = oldScrollF grabScrollKeys (pP 50 30,pP 550 700)
+vScrollF = oldVscrollF grabScrollKeys (pP 50 30,pP 550 700)
+hScrollF = oldHscrollF grabScrollKeys (pP 50 10,pP 550 700)
+
+scroll foc = (const,plainAdjLayout,tableF 2,vPotF' foc Nothing >+< hPotF' foc Nothing)
+vscroll foc = (const,wAdjLayout,hBoxF,vPotF' foc Nothing >+< nullF)
+hscroll foc = (const,hAdjLayout,vBoxF,nullF>+<hPotF' foc Nothing)
+
+oldScrollF grabKeys  = gScrollF (scroll  (not grabKeys)) grabKeys
+oldVscrollF grabKeys = gScrollF (vscroll (not grabKeys)) grabKeys
+oldHscrollF grabKeys = gScrollF (hscroll (not grabKeys)) grabKeys
+
+gScrollF (outCoupling,inCoupling,placer,scrollbarsF) grabKeys initlimits fud =
+    loopThroughRightF (placer mainF) (absF (initSP ctrlSP))
+  where
+    mainF =
+        post>^=<
+	(groupF start visibleK (freeGroupF fud)>+<scrollbarsF)
+	>=^<pre
+      where
+        post = swapRight.mapEither assocLeft id -- (KV+(T+a))+S -> ((KV+T)+S)+a
+	pre = mapEither assocRight id.swapRight -- converse
+
+        start = map XCmd $
+	        transinit++
+	        [ChangeWindowAttributes [CWBackPixmap parentRelative],
+		 ConfigureWindow [CWBorderWidth 1]]
+
+	transinit =
+	    if grabKeys
+	    then [TranslateEvent tobutton [KeyPressMask]]
+	    else []
+
+      --tobutton k@(KeyEvent t p1 p2 s Pressed _ ks _) | (s, ks) `elem` keys =
+	tobutton e@(KeyEvent {state=s,type'=Pressed,keySym=ks})
+	           | (s, ks) `elem` keys =
+	    Just e
+        -- Mouse Wheel support:
+	tobutton e@(ButtonEvent {button=Button 4,type'=Pressed}) = Just e
+	tobutton e@(ButtonEvent {button=Button 5,type'=Pressed}) = Just e
+	tobutton _ = Nothing
+
+        keys = map ((,) []) keys' ++ map ((,) [Shift]) keys'
+	  where keys' = ["Prior","Next","Home","End"]
+
+    -- visibleK reports the current visible size and grabbed keys
+    visibleK = K{-kk-} $ mapFilterSP visible
+      where
+	visible (Low (LEvt (LayoutSize vissize))) = Just (High (Right vissize))
+	visible (Low (XEvt (KeyEvent{state=mods,type'=Pressed,keySym=key}))) =
+	    Just (High (Left (mods,key)))
+	visible (Low (XEvt (ButtonEvent{button=Button 4,type'=Pressed,state=mods}))) =
+	    Just (High (Left (mods,"Prior")))
+	visible (Low (XEvt (ButtonEvent{button=Button 5,type'=Pressed,state=mods}))) =
+	    Just (High (Left (mods,"Next")))
+	visible (High vissize) =
+	    Just (Low (layoutRequestCmd (plainLayout vissize False False)))
+	visible _ = Nothing
+
+    initSP cont =
+        waitForSP initreq $ \ req ->
+	let vissize = limit initlimits rtotsize
+            rtotsize = minsize req
+	    adj = inCoupling req
+	in putSP (Left (Left vissize)) $
+	   cont vissize rtotsize adj
+      where initreq (Left (Right (LayoutRequest req))) = Just req
+            initreq _ = Nothing
+
+    -- ctrlSP :: SP ((KV+T)+S) ((V+T)+S)
+    -- cltrSP implements the scrolling
+    -- Input : KV = grabbed keys or visible size (from visibleK)
+    --       : T = total size (from freeGroupF)
+    --       : S = scroll bar positions
+    -- Output: V = requested visible size (to visibleK)
+    --         S = scroll bar adjustments on size changes
+    --         T = position adjustments on scroll bar changes,
+    --             notification of current visible size
+    ctrlSP visible total adj =
+        concatMapAccumlSP ctrlT (visible, total, pP 0 0,adj) -- limits??
+      where
+        ctrlT s@(visible, total, pos, adj) msg =
+	    case msg of
+	      Left (Left (Left key)) -> (s,potKeyInput key)
+	      Left (Left (Right visible')) -> adjustVisible visible' adj
+	      Left (Right req) ->
+	        case req of
+		  LayoutRequest req -> adjustVisible visible adj'
+		     where adj' = inCoupling req
+		  LayoutMakeVisible rect align ->
+		    (s, mkvisible rect align)
+		  --LayoutScrollStep step -> ...
+		  _ -> (s, [])
+	      Right (Left (y,_,_)) -> vmove pos (-y)
+	      Right (Right (x,_,_)) -> hmove pos (-x)
+	  where
+	    potKeyInput key@(mods,k) =
+	      if Shift `elem` mods
+	      then [Right (Right (PotInput (remove Shift mods,k)))]
+	      else [Right (Left  (PotInput key))]
+	    adjustVisible visible' adj' =
+		((visible', total', pos, adj'),
+		 Left (Right (Left total')):
+		 adjustPots visible' total')
+	      where total' = adj' visible'
+	    adjustPots (Point visw vish) size@(Point totw toth) =
+		    [Right (Right (ResizePot visw totw)),
+		     Right (Left (ResizePot vish toth))]
+	    mkvisible r@(Rect (Point x y) (Point w h)) (halign,valign) =
+	      --ctrace "mkvisible" r $
+		    [Right (Right (PotMkVisible x w halign)),
+		     Right (Left (PotMkVisible y h valign))]
+	    vmove pos@(Point x _) y =
+	        --ctrace "vmove" (pos,pos') $
+	        ((visible,total,pos',adj),[Left (Right (Right pos'))])
+	      where pos' = Point x y
+	    hmove pos@(Point _ y) x =
+	        --ctrace "hmove" (pos,pos')
+	        ((visible,total,pos',adj),[Left (Right (Right pos'))])
+	      where pos' = Point x y
+
+
+limit (min', max') size = pmax min' (pmin max' size)
+
+
+type SizeCoupling = Size    -> Size      -> Size
+--                  my size    other size   my new size
+
+stdCoupling = pmax
+vCoupling (Point tw th) (Point vw vh) = Point vw (max th vh)
+hCoupling (Point tw th) (Point vw vh) = Point (max tw vw) vh
+
+plainAdjLayout (Layout {minsize=total'}) = stdCoupling total'
+wAdjLayout (Layout {wAdj=wa}) = s (flip vCoupling) (wa . xcoord)
+hAdjLayout (Layout {hAdj=ha}) = s (flip hCoupling) (ha . ycoord)
+
+s f g x = f x (g x)
+
+-- assocLeft :: a+(b+c) -> (a+b)+c
+-- assocRight :: (a+b)+c -> a+(b+c)
+assocLeft = either (Left. Left) (either (Left. Right) Right)
+assocRight = either (either Left (Right. Left)) (Right. Right)
+
+--swapRight :: (a+b)+c -> (a+c)+b
+swapRight = either (either (Left. Left) Right) (Left. Right)
diff --git a/hsrc/containers/SelectionF.hs b/hsrc/containers/SelectionF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/SelectionF.hs
@@ -0,0 +1,109 @@
+module SelectionF where 
+import FudUTF8(decodeUTF8,encodeUTF8)
+import Command
+import CompOps((>=^<), (>^=<))
+import Cont(conts,cmdContK')
+import Shells(unmappedShellF)
+import Event
+import Fudget
+import FRequest
+import Xcommand
+import GetWindowProperty
+import InternAtom
+--import Message(Message(..))
+import NullF
+import LayoutF(nullLF)
+import Spops(putSP,getSP)
+import Loops(loopThroughRightF)
+import EitherUtils(stripEither)
+import SerCompF(absF)
+import Xtypes
+
+{- 
+Supports cut/paste of UTF-8 encoded Unicode Strings.
+Cut/paste of Unicode strings between two fudgets program works.
+Cut/paste between a fudget program and xterm -u8 from XFree86 4.0 works.
+/TH 2000-04-02
+-}
+
+data SelCmd a = Sel a | ClearSel | PasteSel  deriving (Eq, Ord)
+data SelEvt a = LostSel | SelNotify a  deriving (Eq, Ord)
+
+data ESelCmd a = OwnSel | SelCmd (SelCmd a) deriving (Eq, Ord)
+data ESelEvt a =  WantSel | SelEvt (SelEvt a) deriving (Eq, Ord)
+
+eselectionF :: F (ESelCmd String) (ESelEvt String)
+eselectionF =
+    (stripEither >^=< unmappedShellF [] selK nullLF) >=^<
+    Left where
+ selK =
+    conts (flip internAtomK True) 
+      ["PRIMARY", "STRING", "NONE", "ATOM"] $ 
+      \ [primaryA, stringA, noneA, atomA] ->
+    conts (flip internAtomK False) ["FUDGETS_UTF8","UTF8_STRING"] $
+      \ [fudgetsA, utf8A] -> let
+      sevt = High. SelEvt
+      l =
+	  getK $ \ev ->
+	  case ev of
+	    High esc -> case esc of
+	      SelCmd sc -> case sc of
+		 Sel t -> l -- select t
+		 ClearSel -> deselect
+		 PasteSel -> paste_utf8string -- try UTF-8 first...
+	      OwnSel -> select
+	    Low (XEvt ev) -> case ev of
+	      SelectionClear s | s == primaryA -> putK (sevt LostSel) l
+	      SelectionRequest t w s -> selectionrequest t w s
+	      SelectionNotify t s -> selectionnotify s
+	      _ -> l
+	    Low _ -> l
+      selectionrequest time w sel@(Selection s t p) =
+	if t `notElem` [stringA,utf8A]
+	then notify time w (Selection s noneA p) l
+	else
+	  let p' = if p == noneA then t else p
+	      wait (High (SelCmd (Sel t))) = Just t
+	      wait _ = Nothing
+	  in cmdContK' (High WantSel) wait $ \rawtext ->
+	     let text = if t==utf8A
+	                then encodeUTF8 rawtext
+			else rawtext in
+	     xcommandK (ChangeProperty w p' t 8 propModeReplace text) $
+	     notify time w (Selection s t p') l
+      notify t w sel = xcommandK (SendEvent w False [] (SelectionNotify t sel))
+      paste_string = paste' stringA
+      paste_utf8string = paste' utf8A
+      paste' typ =
+	  xcommandK (ConvertSelection (Selection primaryA typ fudgetsA)) l
+      paste_failed = putK (sevt (SelNotify "")) l
+      selectionnotify sel@(Selection s t p) =
+          if p==noneA
+	  then if t==utf8A  -- UTF8_STRING wasn't supported, try STRING
+	       then paste_string
+	       else paste_failed
+	  else if t `notElem` [stringA,utf8A]
+	       then paste_failed
+	       else getWindowPropertyK 0 p True t $ 
+			  \(typ, format, nitems, after,seltext) ->
+		    let s' = if t==utf8A then decodeUTF8 seltext else seltext in
+		    putK (sevt (SelNotify s')) l
+      select = select' True
+      deselect = select' False
+      -- should check that setselectionowner succeeded.
+      select' b = xcommandK (SetSelectionOwner b primaryA) l
+    in l
+
+selectionF :: F (SelCmd String) (SelEvt String)
+selectionF = loopThroughRightF (absF (selSP "")) (eselectionF) where
+  selSP text = 
+    let same = selSP text 
+	toesel = Left
+	toout = Right in
+    getSP $ \msg -> case msg of
+	Right ocmd -> case ocmd of
+	   Sel t -> putSP (toesel OwnSel) $ selSP t
+	   _ -> putSP (toesel (SelCmd ocmd)) same
+	Left esevt -> case esevt of
+	   WantSel -> putSP (toesel (SelCmd (Sel text))) same
+	   SelEvt se -> putSP (toout se) same
diff --git a/hsrc/containers/Shells.hs b/hsrc/containers/Shells.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/containers/Shells.hs
@@ -0,0 +1,42 @@
+module Shells where
+
+import FDefaults
+import Fudget
+import FRequest
+import Xcommand
+import DShellF
+import EitherUtils
+--import NullF
+import CompOps
+import Command
+import FudgetIO
+import Event
+import Spops(concatMapSP)
+import MapstateK
+
+unmappedShellF cmds = unmappedShellF' standard cmds
+
+unmappedShellF' pm cmds k =
+    shellKF' (pm. setVisible False. setMargin 0)
+	     (putLows cmds k)
+   
+unmappedSimpleShellF = unmappedSimpleShellF' standard
+
+unmappedSimpleShellF' :: Customiser ShellF -> String -> F i o -> F i o
+unmappedSimpleShellF' pm name f = 
+   stripEither >^=< shellKF' params k f  >=^^< mapraiseSP where
+     params = setVisible False . pm
+     startcmds = [StoreName name]
+     mapraiseSP = concatMapSP ( \msg -> [Right msg, Left True])
+     k = xcommandsK startcmds mapWindowK
+
+mapWindowK = mapstateK k1 False
+  where
+    k1 False  (High True)                  = (True,   [Low $ XCmd $ MapRaised])
+    k1 True   (High False)               = (False,  [Low $ XCmd $ UnmapWindow])
+    k1 _      (Low (XEvt (UnmapNotify _))) = (False,  [])
+    k1 _      (Low (XEvt (MapNotify _)))   = (True,   [])
+    k1 mapped _                            = (mapped, [])
+
+-- Retained for backwards compatibility:
+simpleShellF name wattrs = shellF' (setWinAttr wattrs) name
diff --git a/hsrc/debug/Debug.hs b/hsrc/debug/Debug.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/debug/Debug.hs
@@ -0,0 +1,5 @@
+module Debug (-- * Debug
+  module Maptrace,module ShowCommandF,module SpyF) where
+import Maptrace
+import ShowCommandF
+import SpyF
diff --git a/hsrc/debug/Maptrace.hs b/hsrc/debug/Maptrace.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/debug/Maptrace.hs
@@ -0,0 +1,10 @@
+module Maptrace(maptrace,ctrace) where
+import Debug.Trace(trace)
+import CmdLineEnv(argFlag)
+
+maptrace s = map (\x -> if x == x then trace s x else error "?")
+
+ctrace flag =
+       if argFlag flag False
+       then \e -> trace (flag++": "++show e)
+       else const id
diff --git a/hsrc/debug/ShowCommandF.hs b/hsrc/debug/ShowCommandF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/debug/ShowCommandF.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP #-}
+module ShowCommandF(showCommandF) where
+import CompOps((>.=<), (>=.<))
+import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+--import Message(Message)
+import Path(showPath)
+import Debug.Trace(trace)
+import Xtypes
+import Command
+import Event
+--import ResourceIds
+import Sockets
+import CmdLineEnv(argFlag)
+--import DialogueIO hiding (IOError)
+
+showCommandF :: String -> (F a b) -> F a b
+showCommandF s f = const (if not (argFlag s False) then f else
+    let showit show' d (t, c) =
+            trace (s ++ " " ++ d ++ ": " ++ showPath t ++ ": " ++ show' c
+#ifdef __NHC__
+		   ++ "\n"
+#endif
+		   )
+                  (t, c)
+    in  (showit show "out" >.=< f) >=.< showit show "in") x
+
+{-
+showEv e = case e of
+       IOResponse (XResponse x) -> "IOResponse (XResponse ..."++show x++")"
+       _ -> show e
+-}
+
+-- Hack: The following is to avoid show methods from hlib
+
+x = [show (m :: Display),
+     show (m :: Command),
+     show (m :: Event),
+     show (m :: WindowId),
+     show (m :: Descriptor)]
+
+m = error "module ShowCommandF"
diff --git a/hsrc/debug/ShowFailure.hs b/hsrc/debug/ShowFailure.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/debug/ShowFailure.hs
@@ -0,0 +1,6 @@
+module ShowFailure where
+
+import qualified DialogueIO
+
+showFailure :: DialogueIO.IOError -> String
+showFailure = show
diff --git a/hsrc/debug/SpyF.hs b/hsrc/debug/SpyF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/debug/SpyF.hs
@@ -0,0 +1,22 @@
+module SpyF where
+import Fudget
+import CompOps
+import IoF(ioF)
+import StdIoUtil(echoStderrK)
+--import EitherUtils
+import NullF(getK,putK{-,F,K-})
+--import FudgetIO
+--import ContinuationIO(stderr)
+
+spyF f = teeF show "OUT: " >==< f >==< teeF show "IN: "
+
+teeF show prefix = ioF teeK
+  where
+    teeK =
+      getK $ \msg ->
+      case msg of
+	Low _ -> teeK
+	High msg -> echoStderrK (prefix++show msg) $
+		    putK (High msg) $
+		    teeK
+
diff --git a/hsrc/defaults/DefaultParams.hs b/hsrc/defaults/DefaultParams.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/defaults/DefaultParams.hs
@@ -0,0 +1,8 @@
+module DefaultParams(-- * Default parameters
+  module FDefaults) where
+import FDefaults
+
+{-
+import Fudget
+import Xtypes(ColorName(..),FontName(..),KeySym(..),ModState(..),Modifiers,WindowAttributes)
+-}
diff --git a/hsrc/defaults/FDefaults.hs b/hsrc/defaults/FDefaults.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/defaults/FDefaults.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE CPP #-}
+module FDefaults(module FDefaults,module Alignment,fromMaybe) where
+
+import Fudget
+import CompOps
+import Xtypes
+import Alignment(Alignment(..))
+--import Geometry(pmax)
+import Data.Maybe(fromMaybe)
+import Sizing(Sizing)
+import GCAttrs --(ColorSpec,colorSpec)
+#include "defaults.h"
+
+type Customiser a = a ->  a
+cust :: (a->a) -> Customiser a -- to obtain better type signatures
+cust = id
+
+type PF p a b = F (Either (Customiser p) a) b
+type PK p a b = K (Either (Customiser p) a) b
+
+getpar pp = fromMaybe (error "getpar:: missing default") . getparMaybe pp
+
+getparMaybe pp [] = Nothing
+getparMaybe pp (p:ps) =
+     case pp p of
+       Just a -> Just a
+       Nothing -> getparMaybe pp ps
+
+noPF :: PF p a b -> F a b
+noPF f = f >=^< Right
+
+standard :: Customiser a
+standard = id
+
+parameter_class(FontSpec,FontSpec)
+setFont f = setFontSpec (fontSpec f)
+
+--parameter_class(Title,String)
+parameter_class(Keys,[(ModState,KeySym)])
+parameter_class(WinAttr,[WindowAttributes])
+parameter_class(BorderWidth,Int)
+
+parameter_class(BgColorSpec,ColorSpec)
+parameter_class(FgColorSpec,ColorSpec)
+-- eta expanded because of the stupid monomorphism restriction
+setBgColor c = setBgColorSpec . colorSpec $ c
+setFgColor c = setFgColorSpec . colorSpec $ c
+--getBgColor c = getBgColorSpec $ c
+--getFgColor c = getFgColorSpec $ c
+
+parameter_class(Margin,Int)
+parameter_class(Align,Alignment)
+parameter_class1(InitSize)
+parameter_class1(InitDisp)
+parameter_class(Stretchable,(Bool,Bool))
+parameter_class(InitText,[String])
+parameter_class(Sizing,Sizing)
diff --git a/hsrc/defaults/defaults.h b/hsrc/defaults/defaults.h
new file mode 100644
--- /dev/null
+++ b/hsrc/defaults/defaults.h
@@ -0,0 +1,33 @@
+{-
+HBC uses "cpp -C -traditional" which causes all the /**/ to be left behind
+when the macro definitions are processed. That is why the definitions
+are inside a comment.
+
+#define parameter_class(name,type) parameter_class_gen(name,name,type)
+
+#define parameter_class_gen(classname,par,type) \
+class Has/**/classname xxx where {\
+    set/**/par :: (type) -> Customiser xxx; \
+    get/**/par :: xxx -> (type); \
+    get/**/par/**/Maybe :: xxx -> Maybe (type); \
+    get/**/par = fromMaybe (error "get par: missing default") . get/**/par/**/Maybe }
+
+#define parameter_class1(par) class Has/**/par xxx where {\
+   set/**/par :: a -> Customiser (xxx a); \
+   get/**/par/**/Maybe :: xxx a -> Maybe a; \
+   get/**/par :: xxx a -> a; \
+   get/**/par = fromMaybe (error "get par: missing default") . get/**/par/**/Maybe }
+
+#define parameter_instance1(par,type) parameter_instance(par,type a)
+
+#define parameter_instance(par,type) instance Has/**/par (type) where {\
+  set/**/par p (Pars ps) = Pars (par p:ps); \
+  get/**/par/**/Maybe (Pars ps) = getparMaybe (\x->case x of par p -> Just p; _-> Nothing) ps }
+
+/* non-overloaded parameters: */
+#define parameter(par) \
+set/**/par p = cust (\ (Pars ps) -> Pars (par p:ps)); \
+get/**/par (Pars ps) = getpar (\x->case x of par p -> Just p; _-> Nothing) ps; \
+get/**/par/**/Maybe (Pars ps) = getparMaybe (\x->case x of par p -> Just p; _-> Nothing) ps
+  
+-}
diff --git a/hsrc/doRequest.hs b/hsrc/doRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/doRequest.hs
@@ -0,0 +1,17 @@
+import Control.Monad(forever)
+import System.IO
+import DoRequest
+
+main =
+  do state <- initXCall
+     forever (print' =<< doRequest state =<< readLn')
+
+print' x = do --hPutStr stderr "OR: "
+            --hPrint stderr x
+              print x
+              hFlush stdout
+
+readLn' = do r <- readLn
+           --hPutStr stderr "IR: "
+           --hPrint stderr r
+             return r
diff --git a/hsrc/drawing/BitmapDrawing.hs b/hsrc/drawing/BitmapDrawing.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/BitmapDrawing.hs
@@ -0,0 +1,35 @@
+module BitmapDrawing where
+import Graphic
+import MeasuredGraphics(MeasuredGraphics(..))
+import GCtx(GCtx(..))
+--import Command
+import Event(BitmapReturn(..))
+import DrawTypes
+import Geometry(Rect(..),origin)
+import Xtypes
+--import FudgetIO
+import NullF() -- instances, for hbc
+import LayoutRequest(refpLayout,plainLayout)
+import Gc
+import StdIoUtil(echoStderrK)
+import Pixmap(readBitmapFile)
+import Data.Maybe(maybeToList)
+--import ContinuationIO(stderr)
+
+data BitmapFile = BitmapFile String
+
+instance Graphic BitmapFile where
+  measureGraphicK (BitmapFile filename) (GC gc _) k =
+    readBitmapFile filename $ \ bmret ->
+    case bmret of
+      BitmapReturn size optrefp pixmap ->
+          wCreateGC gc [GCGraphicsExposures False] $ \ gc' ->
+          k (LeafM ll (drawit gc'))
+	where r = Rect origin size
+              ll = refpLayout size True True (maybeToList optrefp)
+	      drawit gc (Rect p _) = [(gc,[CopyPlane (Pixmap pixmap) r p 0])]
+      _ ->
+          echoStderrK ("Failed to load bitmap "++filename) $
+          k (LeafM ll drawit)
+	where ll = plainLayout 20 False False
+	      drawit r = [(gc,[FillRectangle r])]
diff --git a/hsrc/drawing/Color.hs b/hsrc/drawing/Color.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Color.hs
@@ -0,0 +1,71 @@
+module Color(tryAllocColor,tryAllocColorF,
+	     allocColor,allocColorF,
+	     allocColorPixel,allocColorPixelF,
+             tryAllocNamedColor,tryAllocNamedColorF,
+	     allocNamedColor,allocNamedColorF,
+	     allocNamedColorPixel,allocNamedColorPixelF,
+	     allocNamedColorDef,
+	     allocNamedColorDefPixel,
+	     queryColor,queryColorF
+             ) where
+import Command
+import Event
+--import Fudget
+import Xrequest
+import Xtypes
+import Cont
+--import NullF(F,K)
+import StdIoUtil(echoStderrK)
+--import ContinuationIO(stderr)
+
+genTryAlloc cmd xr =
+    let expected (ColorAllocated color) = Just color
+        expected _ = Nothing
+    in xr cmd expected
+
+genTryAllocColor xr cmap rgb = genTryAlloc (AllocColor cmap rgb) xr
+genTryAllocNamedColor xr cmap cname = genTryAlloc (AllocNamedColor cmap cname) xr
+
+tryAllocColor x = genTryAllocColor xrequest x
+tryAllocColorF = genTryAllocColor xrequestF
+
+tryAllocNamedColor x = genTryAllocNamedColor xrequest x
+tryAllocNamedColorF = genTryAllocNamedColor xrequestF
+
+--allocNamedColorDef :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Color
+allocNamedColorDef cmap cname fallback = 
+    tryGet (tryAllocNamedColor cmap cname)
+	   (echoStderrK
+		      ("Warning, cannot allocate background color \""++cname++
+		      -- backround ??
+		       "\", using \""++fallback++"\" instead.") .
+	    allocNamedColor cmap fallback)
+
+--allocNamedColorDefPixel :: ColormapId -> ColorName -> ColorName -> Cont (K a b) Pixel
+allocNamedColorDefPixel cmap cname fallback = allocNamedColorDef cmap cname fallback
+  . (.colorPixel)
+
+safe req cmap c = tryM (req cmap c) (error ("Cannot allocate color: "++show c))
+
+pixel :: (a->b->Cont c Color) -> a->b->Cont c Pixel
+pixel req cmap c = req cmap c . (.colorPixel)
+
+allocNamedColor x = safe tryAllocNamedColor x
+allocNamedColorF = safe tryAllocNamedColorF
+
+allocNamedColorPixel x = pixel allocNamedColor x
+allocNamedColorPixelF = pixel allocNamedColorF
+
+allocColor x = safe tryAllocColor x
+allocColorF = safe tryAllocColorF
+
+allocColorPixel x = pixel allocColor x
+allocColorPixelF = pixel allocColorF
+
+querycolor xr cmap pixel =
+    let expected (ColorQueried c) = Just c
+        expected _ = Nothing
+    in xr (QueryColor cmap pixel) expected
+
+queryColorF = querycolor xrequestF
+queryColor x = querycolor xrequest x
diff --git a/hsrc/drawing/Convgc.hs b/hsrc/drawing/Convgc.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Convgc.hs
@@ -0,0 +1,32 @@
+module Convgc(convGCattrsK) where
+import Color
+--import Font(FontStruct)
+--import Fudget
+import LoadFont
+--import Spops
+import Xtypes
+import EitherUtils() -- synonym Cont, for hbc
+
+convGCattrsK attrs = gcattrsK attrs []
+
+gcattrsK [] outattrs dr = dr (reverse outattrs)
+gcattrsK (attr : attrs) outattrs dr =
+  let cp attr' = gcattrsK attrs (attr' : outattrs) dr
+  in case attr of
+       GCForeground colname ->
+         allocNamedColorPixel defaultColormap colname $ \fg ->
+	 gcattrsK attrs (GCForeground fg : outattrs) dr
+       GCBackground colname ->
+         allocNamedColorPixel defaultColormap colname $ \fg ->
+	 gcattrsK attrs (GCBackground fg : outattrs) dr
+       GCFont fname ->
+         loadFont fname $ \font ->
+	 gcattrsK attrs (GCFont font : outattrs) dr
+       GCFunction f -> cp (GCFunction f)
+       GCLineWidth w -> cp (GCLineWidth w)
+       GCLineStyle s -> cp (GCLineStyle s)
+       GCCapStyle s -> cp (GCCapStyle s)
+       GCJoinStyle s -> cp (GCJoinStyle s)
+       GCSubwindowMode m -> cp (GCSubwindowMode m)
+       GCGraphicsExposures b -> cp (GCGraphicsExposures b)
+
diff --git a/hsrc/drawing/Cursor.hs b/hsrc/drawing/Cursor.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Cursor.hs
@@ -0,0 +1,22 @@
+module Cursor where
+import Command
+import Event
+import Fudget
+import Xrequest
+import Xcommand
+import Xtypes
+
+createFontCursor shape =
+    let cmd = CreateFontCursor shape
+        expected (CursorCreated cursor) = Just cursor
+        expected _ = Nothing
+    in  xrequestK cmd expected
+
+setFontCursor :: Int -> K a b -> K a b
+setFontCursor shape process =
+    createFontCursor shape $ \ cursor ->
+    xcommandK (ChangeWindowAttributes [CWCursor cursor]) $
+    process
+
+defineCursor cursor = xcommandK (ChangeWindowAttributes [CWCursor cursor])
+undefineCusror = xcommandK (ChangeWindowAttributes [CWCursor cursorNone])
diff --git a/hsrc/drawing/Drawing.hs b/hsrc/drawing/Drawing.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Drawing.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Drawing(Drawing(..),labelD,placedD,atomicD,DPath(..),up,GCSpec) where
+import Graphic
+import MeasuredGraphics(MeasuredGraphics(..),DPath(..),up)
+--import FudgetIO
+import NullF() -- instances, for hbc
+import GCtx(GCSpec(..),wCreateGCtx)
+import Placers2(overlayP)
+import LayoutRequest
+--import EitherUtils(Cont(..))
+import GCAttrs(ColorSpec,FontSpec)
+import Xtypes(GCAttributes)
+--import Geometry() -- Show instances
+
+data Drawing lbl leaf
+  = AtomicD   leaf
+  | LabelD    lbl  (Drawing lbl leaf)
+  | AttribD   GCSpec (Drawing lbl leaf)
+  | SpacedD   Spacer (Drawing lbl leaf)
+  | PlacedD   Placer (Drawing lbl leaf)
+  | ComposedD Int    [Drawing lbl leaf]   -- ^ Int=how many visible components
+  | CreateHardAttribD GCtx [GCAttributes ColorSpec FontSpec] (GCtx -> 
+                      Drawing lbl leaf)
+  deriving (Show,Functor)
+
+labelD = LabelD
+placedD = PlacedD
+atomicD = AtomicD
+
+instance Graphic leaf => Graphic (Drawing annot leaf) where
+  measureGraphicK = drawK
+  measureGraphicListK = drawListK overlayP  -- or autoP ??
+
+
+drawK d gctx{-@(GC gc fs)-} k =
+  case d of
+    AtomicD x -> measureGraphicK x gctx k
+    LabelD _ d -> drawK d gctx (k . MarkM gctx)
+    AttribD gcspec d ->
+      wCreateGCtx' gctx gcspec $ \ gctx' ->
+      drawK d gctx' (k . MarkM gctx')
+    SpacedD spacer d ->
+      drawK d gctx $ \ g ->
+      k (SpacedM spacer g)
+    PlacedD placer d ->
+      drawK d gctx $ \ g ->
+      k (PlacedM placer g)
+    ComposedD n ds ->
+      -- take the n visible components, remaining parts are invisible.
+      drawsK gctx (take n ds) $ \ gs ->
+      k (ComposedM gs)
+    CreateHardAttribD templ attrs d ->
+      wCreateGCtx templ attrs $ \tx ->
+      drawK (d tx) gctx k
+{-
+  where
+    replaceFontK fs gcattrs k = font gcattrs (k fs) (\fid -> queryFont fid k)
+    font [] kdef _ = kdef
+    font (GCFont fid:gcattrs) _ kfont = kfont fid
+    font (_:gcattrs) kdef kfont = font gcattrs kdef kfont
+-}
+
+drawListK placer ds gctx k =
+  drawsK gctx ds $ \ gs ->
+  k (PlacedM placer $ ComposedM gs)
+
+drawsK gctx [] k = k []
+drawsK gctx (d:ds) k =
+  drawK d gctx $ \ g ->
+  drawsK gctx ds $ \ gs ->
+  k (g:gs)
+
+wCreateGCtx' gctx gcspec k =
+  case gcspec of
+    HardGC gctx' -> k gctx'
+    SoftGC gcattrs -> wCreateGCtx gctx gcattrs k
diff --git a/hsrc/drawing/DrawingModules.hs b/hsrc/drawing/DrawingModules.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/DrawingModules.hs
@@ -0,0 +1,42 @@
+module DrawingModules(-- * Drawing
+  -- ** Colors
+  module Color,
+  -- ** Cursors
+  module Cursor,
+  -- ** Fonts
+  module Font,module LoadFont,
+  -- ** Graphics Contexts
+  module Gc,module Convgc,module GCAttrs,module GCtx,
+  -- ** class Graphic
+  module Graphic,
+  -- ** Atomic Drawings
+  module FixedDrawing,module FlexibleDrawing,
+  module BitmapDrawing,module Pixmap,module PixmapGen,
+  -- ** Composed drawings
+  module Drawing,module DrawingUtils,module DrawingOps,
+  module Graphic2Pixmap,
+  -- ** Misc
+  module TransCoord,
+  module MeasuredGraphics, module CompiledGraphics
+) where
+import Color
+import Convgc
+import Cursor
+import Font
+import Gc
+import LoadFont
+import Pixmap
+import TransCoord
+import DrawingUtils
+import FixedDrawing
+import FlexibleDrawing
+import BitmapDrawing
+import PixmapGen
+import GCAttrs
+import GCtx
+import Graphic
+import Drawing
+import DrawingOps
+import Graphic2Pixmap
+import MeasuredGraphics
+import CompiledGraphics
diff --git a/hsrc/drawing/DrawingOps.hs b/hsrc/drawing/DrawingOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/DrawingOps.hs
@@ -0,0 +1,226 @@
+module DrawingOps where
+import Drawing(Drawing(..),DPath(..),up)
+import Utils(number)
+
+drawingPart drawing path =
+  case maybeDrawingPart drawing path of
+    Just part -> part
+    Nothing -> error ("bad path in drawingPart "++show path)
+
+maybeDrawingPart drawing path =
+  case (path::DPath) of
+    [] -> Just drawing
+    p:ps -> part drawing
+      where
+        part0 d = if p==0
+	          then maybeDrawingPart d ps
+		  else Nothing
+        part drawing =
+	  case drawing of
+	    AtomicD           _  -> Nothing
+	    LabelD    _       d  -> part0 d
+	    AttribD   gcattrs d  -> part0 d
+	    SpacedD   spacer  d  -> part0 d
+	    PlacedD   placer  d  -> part0 d
+	    ComposedD _       ds ->
+	      if 1<=p && p<=length ds
+	      then maybeDrawingPart (ds !! (p-1)) ps
+	      else Nothing
+
+drawingAnnotPart = drawingAnnotPart' (const True)
+
+drawingAnnotPart' p drawing path =
+      case path of
+        [] -> []
+	_ -> case maybeDrawingPart drawing path of
+	       Just (LabelD a _) | p a -> path
+	       _ -> drawingAnnotPart' p drawing (up path)
+
+isVisibleDrawingPart drawing path =
+  case (path::DPath) of
+    [] -> True
+    p:ps -> visible drawing
+      where
+        visible0 d = p==0 && isVisibleDrawingPart d ps -- ??
+        visible drawing =
+	  case drawing of
+	    AtomicD           _  -> True -- ??
+	    LabelD    _       d  -> visible0 d
+	    AttribD   gcattrs d  -> visible0 d
+	    SpacedD   spacer  d  -> visible0 d
+	    PlacedD   placer  d  -> visible0 d
+	    ComposedD n       ds ->
+	      1<=p && p<=n && isVisibleDrawingPart (ds !! (p-1)) ps
+
+visibleAncestor drawing path =
+  case path::DPath of
+    [] -> path
+    p:ps ->
+      case drawing of
+        AtomicD           _  -> path
+	LabelD    _       d  -> skip d
+	AttribD   gcattrs d  -> skip d
+	SpacedD   spacer  d  -> skip d
+	PlacedD   placer  d  -> skip d
+	ComposedD n       ds ->
+	  if 1<=p && p<=n
+	  then p:visibleAncestor (ds!!(p-1)) ps
+	  else []
+      where skip d = 0:visibleAncestor d ps
+
+replacePart drawing path new = updatePart drawing path (const new)
+
+updatePart drawing path new =
+  case (path::DPath) of
+    [] -> new drawing
+    p:ps  -> repl drawing
+      where
+        err = error "bad path in updatePart"
+        repl0 d = if p==0 then updatePart d ps new else err
+        repl drawing =
+	  case drawing of
+	    AtomicD           _  -> err
+	    AttribD   gcattrs d  -> AttribD gcattrs (repl0 d)
+	    LabelD    label   d  -> LabelD label (repl0 d)
+	    SpacedD   spacer  d  -> SpacedD spacer (repl0 d)
+	    PlacedD   placer  d  -> PlacedD placer (repl0 d)
+	    ComposedD n       ds ->
+	      let (pre,d:post) = splitAt (p-1) ds
+              in ComposedD n (pre++updatePart d ps new:post)
+
+mapLabelDrawing f = ma
+  where
+    ma d =
+      case d of
+	AtomicD           x  -> AtomicD x
+	AttribD   gcattrs d  -> AttribD gcattrs (ma d)
+	LabelD    label   d  -> LabelD (f label) (ma d)
+	SpacedD   spacer  d  -> SpacedD spacer (ma d)
+	PlacedD   placer  d  -> PlacedD placer (ma d)
+	ComposedD n       ds -> ComposedD n (map ma ds)
+
+mapLeafDrawing f = ma
+  where
+    ma d =
+      case d of
+	AtomicD           x  -> AtomicD (f x)
+	AttribD   gcattrs d  -> AttribD gcattrs (ma d)
+	LabelD    label   d  -> LabelD label (ma d)
+	SpacedD   spacer  d  -> SpacedD spacer (ma d)
+	PlacedD   placer  d  -> PlacedD placer (ma d)
+	ComposedD n       ds -> ComposedD n (map ma ds)
+
+{-
+drawingArity drawing =
+  case drawing of
+    AtomicD     _  -> 0
+    LabelD    _ d  -> drawingArity d
+    AttribD   _ d  -> drawingArity d
+    SpacedD   _ d  -> drawingArity d
+    PlacedD   _ d  -> drawingArity d
+    ComposedD _ ds -> length ds
+-}
+
+annotChildren = annotChildren' (const True)
+
+annotChildren' :: (a -> Bool) -> (Drawing a d) -> [(DPath, Drawing a d)]   
+annotChildren' p drawing =
+    case drawing of
+      LabelD _ d -> ac0 d
+      d -> ac d
+  where 
+    ac0 d0 = [(0:p,d)| (p,d)<-ac d0]
+    ac d =
+      case d of
+        AtomicD     _  -> []
+        LabelD    a d' -> if p a then [([],d)] else ac0 d'
+	AttribD   _ d  -> ac0 d
+	SpacedD   _ d  -> ac0 d
+	PlacedD   _ d  -> ac0 d
+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map ac ds), (p,d)<-cs]
+
+{-
+drawingAnnots :: Drawing a d -> [(DPath,a)]   
+drawingAnnots drawing = da drawing
+  where 
+    da d =
+      case d of
+        AtomicD     _  -> []
+        LabelD    a d' -> ([],a):da d'
+	AttribD   _ d  -> da d
+	SpacedD   _ d  -> da d
+	PlacedD   _ d  -> da d
+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map da ds), (p,d)<-cs]
+-}
+
+drawingAnnots drawing = extractParts drawing sel
+  where sel (LabelD a d) = Just a
+	sel _ = Nothing
+
+extractParts :: Drawing lbl leaf -> (Drawing lbl leaf -> Maybe a) -> [(DPath,a)]
+extractParts drawing sel = extr drawing
+  where
+    extr0 d = [(0:p,d') | (p,d') <- extr d]
+    extr d =
+      (case sel d of
+	 Just x -> (([],x):)
+	 _ -> id) $
+      case d of
+        AtomicD     _  -> []
+        LabelD    a d' -> extr0 d'
+	AttribD   _ d  -> extr0 d
+	SpacedD   _ d  -> extr0 d
+	PlacedD   _ d  -> extr0 d
+	ComposedD _ ds -> [(i:p,d) | (i,cs) <- number 1 (map extr ds), (p,d)<-cs]
+
+deletePart drawing [] = drawing -- !! error report?
+deletePart drawing path =
+    updatePart drawing (init path) (deleteElem (last path))
+  where
+    deleteElem i = di
+      where di d =
+              case d of
+		ComposedD n       ds ->
+		  case splitAt (i-1) ds of
+		    (ds1,_:ds2) -> ComposedD n' (ds1++ds2)
+		    _ -> d -- !! error report?
+		  where n' = if i<=n
+		             then n-1
+			     else n
+		_                    -> d   -- !! error report?
+{-
+		AtomicD           x  -> d   -- !! error report?
+		AttribD   gcattrs d  -> AttribD gcattrs (di d)
+		LabelD    label   d  -> LabelD  label   (di d)
+		SpacedD   spacer  d  -> SpacedD spacer  (di d)
+		PlacedD   placer  d  -> PlacedD placer  (di d)
+-}
+
+groupParts pos0 len0 drawing =
+  case drawing of
+    ComposedD n ds -> ComposedD n1 (ds1++ComposedD n2 ds2:ds3)
+      where
+        (ds1,ds2a) = splitAt (pos0-1) ds
+        (ds2,ds3) = splitAt len0 ds2a
+        pos = length ds1
+        len = length ds2
+        -- keep the same parts visible
+        (n1,n2) = if n<=pos then (n,0)
+                  else if n<=pos+len
+                       then (pos+1,n-pos)
+                       else (n-len+1,len)
+
+ungroupParts pos drawing =
+  case drawing of
+    ComposedD n1 ds ->
+      case splitAt (pos-1) ds of
+        (ds1,ComposedD n2 ds2:ds3) -> ComposedD n (ds1++ds2++ds3)
+          where
+            -- Can't preserve visibility when some of ds3 was visible
+            -- but some of ds2 was hidden
+            n = if n1<=pos then n1
+                else if n1==pos+1
+                     then pos+n2
+                     else n1-1+length ds2 -- all of ds2 becomes visible!!
+        _ -> drawing -- hmm!!
+    _ -> drawing -- hmm!!
diff --git a/hsrc/drawing/DrawingUtils.hs b/hsrc/drawing/DrawingUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/DrawingUtils.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE CPP #-}
+module DrawingUtils where
+import Xtypes
+import Drawing
+import Graphic
+import FixedDrawing
+import FlexibleDrawing(blank')
+import GCAttrs
+import GCtx
+import Placers
+import MatrixP(matrixP,matrixP')
+import Spacers
+import Placers2
+import TableP(tableP,tableP')
+import Geometry
+import DrawTypes(DrawCommand(..))
+import Alignment(aLeft,aCenter,aTop)
+import LayoutDir(LayoutDir(..))
+--import EitherUtils(Cont(..))
+--import Fudget(K)
+
+#include "exists.h"
+
+boxVisibleD = ComposedD
+boxD ds = ComposedD (length ds) ds
+stackD = PlacedD overlayP . boxD
+vertD = PlacedD verticalP
+vertD' = PlacedD . verticalP'
+horizD = PlacedD horizontalP
+horizD' = PlacedD . horizontalP'
+vboxD = vertD . boxD
+hboxD = horizD . boxD
+vboxD' sep = vertD' sep . boxD
+hboxD' sep = horizD' sep . boxD
+
+vertlD = PlacedD verticalLeftP
+vertlD' = PlacedD . verticalLeftP'
+vboxlD = vertlD . boxD
+vboxlD' sep = vertlD' sep . boxD
+horizcD = PlacedD horizontalCenterP
+horizcD' = PlacedD . horizontalCenterP'
+hboxcD = horizcD . boxD
+hboxcD' sep = horizcD' sep . boxD
+
+tableD n = PlacedD (tableP n) . boxD
+tableD' sep n = PlacedD (tableP' n Horizontal sep) . boxD
+
+matrixD n = PlacedD (matrixP n) . boxD
+matrixD' sep n = PlacedD (matrixP' n Horizontal sep) . boxD
+
+westD = spacedD $ hvAlignS aLeft aCenter
+northwestD = spacedD $ hvAlignS aLeft aTop
+
+padD = spacedD.marginS
+
+fontD fn = softAttribD [GCFont (fontSpec fn)]
+
+--fgnD :: ColorName -> Drawing lbl leaf -> Drawing lbl leaf
+--fgnD = fgD.Name
+
+--fontnD :: FontName -> Drawing lbl leaf -> Drawing lbl leaf
+--fontnD = fontD.Name
+
+fgD color = softAttribD [GCForeground (colorSpec color)]
+bgD color = softAttribD [GCBackground (colorSpec color)]
+fatD = softAttribD [GCLineWidth 5,GCCapStyle CapRound]
+--attribD = belowAnnotD.AttribD --hmm
+attribD = AttribD 
+softAttribD = attribD.SoftGC
+hardAttribD = attribD.HardGC
+--spacedD = belowAnnotD.SpacedD  --hmm
+spacedD = SpacedD
+
+--belowAnnotD f (LabelD a d) = LabelD a (belowAnnotD f d)
+--belowAnnotD f d = f d
+
+#ifdef USE_EXIST_Q
+data Gfx = EXISTS(a) TSTHACK((Graphic EQV(a)) =>) G EQV(a)
+-- deriving Show -- doesn't work because of a HBC bug
+
+instance Show Gfx where showsPrec n (G x) s = "G "++{-showsPrec 10 x-} s
+
+instance Graphic Gfx where
+  measureGraphicK (G x) = measureGraphicK x
+
+g x = atomicD (G x)
+
+#else
+
+g = atomicD
+
+#endif
+
+filledRectD size = g (FixD (size) [FillRectangle (Rect origin size)])
+rectD size = g (FixD (size+1) [DrawRectangle (Rect origin size)])
+                   -- size+1 assumes that the line width is 1
+blankD = g . blank' 
+
+holeD =
+    fgD "blue3" $ rectD size
+    --stack [fgD "white" (filledRectD size),rectD size]
+  where
+    size = pP 15 13
diff --git a/hsrc/drawing/Expose.hs b/hsrc/drawing/Expose.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Expose.hs
@@ -0,0 +1,27 @@
+module Expose where
+
+import Message
+import Cont
+--import Command
+--import LayoutRequest
+import Fudget
+--import Xtypes
+import Geometry(Rect,rmax)
+import FRequest
+import Event
+--import Font
+
+collectExposeK :: Bool -> Rect -> Int -> ([Rect] -> K a b) -> K a b
+collectExposeK grX r aft c = collect [r] aft
+   where collect rs aft = 
+	   if aft == 0 then c rs
+	   else waitForK (\r ->
+			case r of
+			 Low (XEvt (Expose r aft')) | not grX -> Just (r,aft')
+			 Low (XEvt (GraphicsExpose r aft' _ _)) | grX -> Just (r,aft')
+			 _ -> Nothing) $ \(r,aft')->
+			collect (r:rs) aft'
+
+
+maxExposeK grX r aft c = collectExposeK grX r aft $ \rs ->
+		     c (foldl1 rmax rs)
diff --git a/hsrc/drawing/FixedDrawing.hs b/hsrc/drawing/FixedDrawing.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/FixedDrawing.hs
@@ -0,0 +1,35 @@
+module FixedDrawing where
+import Graphic
+import MeasuredGraphics(MeasuredGraphics(..),measureImageString)
+import GCtx(GCtx(..))
+import ResourceIds(GCId)
+import LayoutRequest
+import Geometry(Rect(..),Size(..))
+import Command(DrawCommand)
+import Drawcmd(move)
+--import EitherUtils(Cont(..))
+
+data FixedDrawing = FixD Size [DrawCommand] deriving Show
+
+instance Graphic FixedDrawing where
+  measureGraphicK (FixD s dcmds) (GC gc _) k =
+      k (LeafM (plainLayout s True True) drawit)
+    where
+      drawit (Rect p _) = [(gc,move p dcmds)]
+
+data FixedColorDrawing = FixCD Size [(GCId,[DrawCommand])] deriving Show
+
+instance Graphic FixedColorDrawing where
+  measureGraphicK (FixCD s gcdcmds) _ k =
+      k (LeafM (plainLayout s True True) drawit)
+    where
+      drawit (Rect p _) =
+        if p==0
+	then gcdcmds
+	else [(gc,move p dcmds)|(gc,dcmds)<-gcdcmds]
+
+
+newtype ImageString = ImageString String
+
+instance Graphic ImageString where
+  measureGraphicK (ImageString s) = measureImageString s
diff --git a/hsrc/drawing/FlexibleDrawing.hs b/hsrc/drawing/FlexibleDrawing.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/FlexibleDrawing.hs
@@ -0,0 +1,141 @@
+module FlexibleDrawing where
+import Geometry
+import DrawTypes
+--import Xtypes(CoordMode(..),Shape(..))
+import LayoutRequest
+--import EitherUtils(Cont(..))
+import Utils(aboth)
+import Graphic
+import MeasuredGraphics(MeasuredGraphics(..))
+import GCtx(GCtx(..))
+
+data FlexibleDrawing = FlexD Size Bool Bool (Rect->[DrawCommand]) deriving Show
+
+instance Graphic FlexibleDrawing where
+  measureGraphicK (FlexD s fh fv drawf) (GC gc _) k =
+      k (LeafM (plainLayout s fh fv) drawf')
+    where drawf' r = [(gc,drawf r)]
+
+filler fh fv d = FlexD (diag d) fh fv (\r->[FillRectangle r])
+
+--filledRect = filler False False
+hFiller = filler False True
+vFiller = filler True False
+
+flex' s = FlexD s False False
+flex = flex' 5
+
+blank' s = flex' s (const [])
+blank = blank' 5
+
+frame' s  = flex' s (\r->[DrawRectangle (r `growrect` (-1))])
+frame     = frame' 5
+
+ellipse = ellipse' 5
+ellipse' s = arc' s 0 (360*64)
+arc = arc' 5
+arc' s a1 a2 = flex' s (drawarc a1 a2)
+
+filledEllipse = filledEllipse' 5
+filledEllipse' s = filledarc' s 0 (360*64)
+filledarc = filledarc' 5
+filledarc' s a1 a2 = flex' s (fillarc a1 a2)
+
+drawarc a1 a2 r = [DrawArc (r `growrect` (-1)) a1 a2]
+fillarc a1 a2 r = [FillArc (r `growrect` (-1)) a1 a2]
+
+rpar = bFlex (drawarc (-60*64) (120*64).doubleleft)
+lpar = bFlex (drawarc (120*64) (120*64).doubleright)
+
+doubleleft (Rect p s@(Point w _)) = Rect (p-d) (s+d) where d=Point w 0
+doubleright (Rect p s@(Point w _)) = Rect p (s+d) where d=Point w 0
+
+-- top level pattern bindings (with pbu) can't be trusted...
+lbrack = fst bracks
+rbrack = snd bracks
+
+bracks = aboth bFlex (draw False, draw True)
+  where
+    draw right r = [DrawLine (Line p1 p2) | (p1,p2) <- ls ]
+      where (p1,p2,p3,p4) = corners (r `moverect` 1 `growrect` (-2))
+            ls = if right
+	         then [(p1,p2),(p2,p4),(p3,p4)]
+		 else [(p1,p2),(p1,p3),(p3,p4)]
+
+corners (Rect p s@(Point w h)) = (p,p+pP w 0,p+pP 0 h,p+s)
+
+lbrace = fst braces
+rbrace = snd braces
+
+braces = aboth bFlex2 (draw False, draw True)
+  where
+    draw right r = [DrawLines CoordModePrevious ls]
+      where (tl,tr,bl,br) = corners (r `moverect` 1 `growrect` (-2))
+            h = ycoord (bl-tl)
+	    d = h `div` 2 - 4
+            ls = if right
+	         then [tl,east 1,se 2,south d,se 2,sw 2,south d,sw 2,west 1]
+	         else [tr,west 1,sw 2,south d,sw 2,se 2,south d,se 2,east 1]
+
+            west n = pP (-n) 0
+	    east n = pP n 0
+	    sw n = pP (-n) n
+	    se n = pP n n
+	    south n = pP 0 n
+
+{-
+polyLine p [] = []
+polyLine p (v:vs) = (p,p'):polyLine p' vs
+  where p' = p+v
+-}
+
+bFlex2 = bFlex' (pP 8 12)
+bFlex = bFlex' (pP 5 10)
+bFlex' size = FlexD size True False
+
+rAngleBracket = bFlex2 (drawpoly . hMirror abPoints)
+lAngleBracket = bFlex2 (drawpoly . abPoints)
+
+abPoints = abPoints'
+abPoints' r = [ur,ml,lr]
+  where
+    (ul@(Point lx ty),ur,_,lr@(Point rx by)) =
+      corners (r `moverect` 1 `growrect` (-2))
+    ml = Point (rx-d) my
+    my = ty+h2
+    h2 = (by-ty) `div` 2
+    d = (h2 `div` 2) `min` (rx-lx)
+
+triangleUp = flex' size (drawpoly . trianglePoints')
+filledTriangleUp = flex' size (fillpoly . trianglePoints')
+triangleDown = flex' size (drawpoly . vMirror trianglePoints')
+filledTriangleDown = flex' size (fillpoly . vMirror trianglePoints')
+
+size = Point 18 14
+
+drawpoly ps = [DrawLines CoordModeOrigin ps]
+fillpoly ps = [FillPolygon Convex CoordModeOrigin ps]
+shrink = flip growrect (-1)
+
+trianglePoints' = trianglePoints . shrink
+
+trianglePoints (Rect p s@(Point w h)) = [p1,p2,p3,p1]
+  where m = w `div` 2
+	p1 = p+pP m 0
+	p2 = p+s
+	p3 = p+pP 0 h
+
+
+vMirror f r@(Rect (Point x0 y0) s@(Point _ h)) =
+    [ m p | p <- f (Rect (Point x0 0) s)]
+  where m (Point x y) = Point x (y1-y)
+        y1 = y0+h-1
+
+
+hMirror f r@(Rect (Point x0 y0) s@(Point w _)) =
+    [ m p | p <- f (Rect (Point 0 y0) s)]
+  where m (Point x y) = Point (x1-x) y
+        x1 = x0+w-1
+
+padFD d (FlexD s fh fv f) = FlexD (s+diag (2*d)) fh fv f'
+  where f' (Rect p s) = f (Rect (p+diag d) (s-diag d))
diff --git a/hsrc/drawing/Font.hs b/hsrc/drawing/Font.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Font.hs
@@ -0,0 +1,194 @@
+module Font(CharStruct(CharStruct,char_width,char_rbearing),
+            FontStruct(..),FontStructList(..),
+            FontStructF(FontStruct,font_id,font_ascent,font_descent,font_prop),
+            FontDirection(..), FontProp(..), update_font_id, font_range,
+            split_string, string_len, -- string_rect_mono,
+            string_rect, string_box_size, string_bounds,
+            next_pos, poslist, linespace,fsl2fs) where
+import Geometry(Point(..), Rect(..), Size, pP, rR, rectsize, xcoord)
+import Xtypes(Atom,FontId)
+--import Utils(aboth)
+--import HbcUtils(mapFst)
+import Data.List(mapAccumL)
+import Maptrace(ctrace) -- debugging
+import Data.Array
+--import qualified Data.Array as LA
+--import qualified LA -- GHC bug workaround, can't use LA.!
+
+default(Int)
+
+data CharStruct = CharStruct {char_lbearing, char_rbearing,
+                              char_width, char_ascent, char_descent :: Int}
+		  deriving (Eq, Ord, Show, Read)
+
+data FontDirection = FontLeftToRight | FontRightToLeft 
+                     deriving (Eq, Ord, Show, Read, Enum)
+
+data FontProp = FontProp Atom Int deriving (Eq, Ord, Show, Read)
+
+-- Only 8-bit characters and 2-byte matrixes. See fsl2fs too!
+type FontStruct = FontStructF (Array Char CharStruct)
+data FontStructF per_char =
+    FontStruct {font_id :: FontId,
+                font_dir :: FontDirection,
+                first_char, last_char :: Char,
+                font_complete :: Bool, -- all chars exist
+                default_char :: Char,
+                font_prop :: [FontProp],
+                max_bounds, min_bounds :: CharStruct,
+                per_char :: Maybe per_char,
+                font_ascent, font_descent :: Int
+                  -- ^ logical extent above/below baseline for spacing
+               }
+    deriving (Eq, Ord, Show, Read)
+{-
+font_id      (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fid
+font_ascent  (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = asc
+font_descent (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = de
+per_char     (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = ca
+max_bounds   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = maxb
+min_bounds   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = minb
+font_range   (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = (fc,lc)
+default_char (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = dc
+font_prop    (FontStruct fid fd fc lc all' dc fps minb maxb ca asc de) = fps
+-}
+font_range fs = (first_char fs,last_char fs)
+
+--update_font_id (FontStruct _ fd fc lc all' dc fps minb maxb ca asc de) fid = 
+--  FontStruct fid fd fc lc all' dc fps minb maxb ca asc de
+update_font_id fs fid = fs{font_id=fid}
+
+linespace fs = font_ascent fs + font_descent fs
+
+char_struct default' fs c =
+    case per_char fs of
+      Nothing -> default' fs
+      Just ca -> --ca ! c
+                 ca ! (if inRange (font_range fs) c   -- or: bounds ca
+                       then -- debugging
+		            if inRange (bounds ca) c
+			    then c
+			    else ctrace "fontrange" (font_range fs,bounds ca,c) (default_char fs)
+		       else let c' = default_char fs
+		            in if inRange (bounds ca) c'
+			       then c'
+			       else ctrace "fontrange" (font_range fs,"default char",c') ' ')
+
+lbearing fs = char_lbearing . char_struct min_bounds fs
+rbearing fs = char_rbearing . char_struct max_bounds fs
+
+poslist :: FontStruct -> String -> [Int]
+poslist fs = map (char_width . char_struct max_bounds fs)
+
+next_pos :: FontStruct -> String -> Int
+next_pos fs = sum . poslist fs
+
+-- string_bounds gives enclosing rect with respect to first character's origin
+string_bounds :: FontStruct -> String -> Rect
+string_bounds fs [] = Rect (Point 0 0) (Point 0 0)
+string_bounds fs s =
+    let cs = char_struct max_bounds fs
+        x = lbearing fs (head s)
+        y = -(maximum . map (char_ascent . cs)) s
+        width = next_pos fs (take (length s - 1) s) + rbearing fs (last s)
+        height = (maximum . map (char_descent . cs)) s - y
+    in  Rect (Point x y) (Point width height)
+
+string_len :: FontStruct -> String -> Int
+string_len fs s = (xcoord . rectsize . string_bounds fs) s
+
+string_rect :: FontStruct -> String -> Rect
+string_rect fs s =
+    rR 0 (-font_ascent fs) (string_len fs s) (linespace fs)
+
+string_box_size :: FontStruct -> String -> Size
+string_box_size fs s = pP (next_pos fs s) (linespace fs)
+
+split_string:: FontStruct -> String -> Int -> (String,String,Int)
+split_string fs s x =
+   -- find the first char that ends to the right of the wanted x position
+   case dropWhile (\(_,_,xr)->xr<x) nxs of
+     (n,xl,xr):_ ->
+	-- xl<=x<=xr, wanted x position is inside the nth character
+	if x-xl<xr-x
+	then split n -- left edge of nth char is closer
+	else split (n+1) -- right edge of nth char is closer
+     [] -> (s,[],n) -- x position is after the last char of the string
+  where
+    split n = case splitAt n s of (s1,s2) -> (s1,s2,n)
+
+    --n=length s, nxs= string & screen positions of all characters in the string
+    ((n,_),nxs) = mapAccumL (\(n,x) w -> ((n+1,x+w),(n,x,x+w))) ((0,0)::(Int,Int)) ws
+
+    -- Width of all characters:
+    ws = poslist fs s
+    
+
+{- old:
+    let dist s' = abs (next_pos font s' - x)
+        nearer (pre1, _, _) (pre2, _, _) = dist pre1 <= dist pre2
+	better x y = if nearer x y then x else y
+    in foldr1 better (allsplits s)
+
+--allsplits s = [(take n s, drop n s, n) | n <- [0 .. length s]])
+allsplits [] = [([],[],0)]
+allsplits xxs@(x:xs) = ([],xxs,0): map (\(xs,ys,n)->(x:xs,ys,n+1)) (allsplits xs)
+-}
+
+--------
+
+-- This is a temporary fix until we know how to construct Haskell arrays from C
+type FontStructList = FontStructF [CharStruct]
+{-
+data FontStructList = FontStructList
+                             FontId
+                             FontDirection
+			     Char -- first character
+			     Char -- last character
+			     Bool -- all chars exist
+			     Char -- default char
+			     [FontProp]
+			     CharStruct -- min bounds
+			     CharStruct -- max bounds
+			     (Maybe [CharStruct])
+			     Int -- logical extent above baseline for spacing
+			     Int -- logical extent below baseline for spacing 
+                  deriving (Eq, Ord, Show, Read)
+-}
+
+--fontl_prop (FontStructList fid fd fc lc all' dc fps minb maxb ca asc de) = fps
+fontl_prop = font_prop
+
+fsl2fs (FontStruct fid fd fc lc all' dc fps minb maxb optclist asc de) =
+    FontStruct fid fd fc lc all' dc fps minb maxb optca asc de
+  where optca = fmap l2a optclist
+        l2a clist = array (fc, lc) (zip ixs clist)
+	-- !! This assumes single byte font, or 2 byte matrix font.
+	-- !! Linear 16-bit fonts will not work.
+	-- ! Using a linear array for a 2 byte matrix font wastes space!
+	ixs = [toEnum (256*byte1+byte2) | byte1<-range (min_byte1,max_byte1),
+	                         byte2<-range (min_byte2,max_byte2)]
+	(min_byte1,min_byte2) = fromEnum fc `divMod` 256
+	(max_byte1,max_byte2) = fromEnum lc `divMod` 256
+{-
+-- hack to circumvent limitation in generational garbage collector
+
+data Array a b = Arr (a,a) (LA.Array Int (LA.Array Int b))
+	deriving (Eq,Ord,Show,Read)
+
+array :: (Ix a, Enum a) => (a,a) -> [(a,b)] -> Array a b
+array bds l = Arr bds (LA.listArray (0,dix b2i-dix b1i)
+                       [LA.array rng (filter (inRange rng.fst) (mapFst fromEnum l))
+                        | offs <- [b1i,b1i+maxsize..b2i],
+			  rng <- [(offs,(offs+maxsize-1) `min` b2i)]])
+  where (b1i,b2i) = aboth fromEnum bds
+
+(!) :: (Ix a, Enum a) => Array a b -> a -> b
+(!) (Arr (b1,b2) a) i = (a `LA.sub` dix (ii-fromEnum b1)) `LA.sub` ii where ii = fromEnum i
+
+bounds :: (Ix a, Enum a) => Array a b -> (a,a)
+bounds (Arr bds a) = bds
+
+maxsize = 255
+dix i = i `div` maxsize
+-}
diff --git a/hsrc/drawing/FontProperty.hs b/hsrc/drawing/FontProperty.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/FontProperty.hs
@@ -0,0 +1,27 @@
+module FontProperty (fontProperty) where
+
+import Font(FontProp(..))
+import InternAtom(internAtom,atomName)
+import Xtypes(Atom(..))
+
+-- The font_prop element of the FontStruct contains a list of FontProp,
+-- each containing a pair of Int's: the first is the property name atom number,
+-- the secind is the property value atom number. To get a property of a font
+-- (which may or may not exist) it is necessary to try to get the atom
+-- number for the property name, and, if successful, find out the element
+-- of the list containing that number. Then, using the second number 
+-- in the element found, retrieve the value. If more than one property 
+-- with the same name is found, only the first will be returned.
+
+fontProperty fsprops propn cont = 
+  let match an' (FontProp an vn) = an' == an
+      valatom (FontProp an vn) = vn
+  in  internAtom propn True $ \pna ->
+      case pna of
+        Atom 0 -> cont Nothing
+        a ->
+          case (map valatom (filter (match a) fsprops)) of
+            [] ->   cont Nothing
+            vn:_ -> atomName (Atom (fromIntegral vn)) $ \vna -> cont vna
+
+
diff --git a/hsrc/drawing/GCAttrs.hs b/hsrc/drawing/GCAttrs.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/GCAttrs.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE CPP #-}
+module GCAttrs(module GCAttrs,Cont(..)) where
+--import Fudget
+--import NullF(F,K)
+import FudgetIO
+import Xtypes
+import EitherUtils(Cont(..))
+import Font(FontStruct,font_id,font_range, font_prop, update_font_id)
+import Color(tryAllocNamedColor,tryAllocColor)
+import LoadFont(listFontsWithInfo,loadFont,loadQueryFont)
+import FontProperty(fontProperty)
+import CmdLineEnv(argKey)
+import Utils(aboth,segments)
+--import ListUtil(chopList,breakAt)
+
+#include "exists.h"
+
+data FontData
+   = FID FontStruct
+   | FS FontStruct
+
+fdFontId (FID fs) = font_id fs
+fdFontId (FS fs) = font_id fs
+
+fontdata2struct (FS fs) k = k fs
+fontdata2struct (FID fs) k = k fs
+
+--newtype Name = Name String deriving (Eq,Show)
+  -- The type Name is used instead of String since String is a type synonym
+  -- and therefore can't be made an instance of a class.
+
+#ifdef USE_EXIST_Q
+data ColorSpec = EXISTS(a) TSTHACK((Show EQV(a),ColorGen EQV(a)) =>) ColorSpec EQV(a)
+ -- deriving Show -- doesn't work because of a HBC bug
+instance Show ColorSpec where showsPrec n (ColorSpec c) = showsPrec n c
+
+data FontSpec = EXISTS(a) TSTHACK((Show EQV(a),FontGen EQV(a)) =>) FontSpeci EQV(a)
+ -- deriving Show -- doesn't work because of a HBC bug
+instance Show FontSpec where showsPrec n (FontSpeci f) = showsPrec n f
+
+colorSpec x = ColorSpec x
+fontSpec x = FontSpeci x
+#else
+data ColorSpec = StringCS ColorName | RGBCS RGB | PixelCS Pixel | ListCS [ColorSpec] deriving (Show)
+data FontSpec = StringFS FontName | FontIdFS FontId | FontStructFS FontStruct | ListFS [FontSpec] deriving (Show)
+#endif
+
+--data ColorFallback = CF ColorName ColorName
+
+--type GCAttrsSpec = GCAttributes ColorSpec FontSpec
+
+class ColorGen a where
+  IFNOEXIST(colorSpec :: a -> ColorSpec)
+  tryConvColorK :: FudgetIO f => a -> Cont (f i o) (Maybe Pixel)
+
+  -- Methods with defaults, to be overidden only in the Char instance:
+  IFNOEXIST(colorSpecList :: [a] -> ColorSpec)
+  convColorListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe Pixel)
+
+  convColorListK = convList tryConvColorK
+  IFNOEXIST(colorSpecList = ListCS . map colorSpec)
+
+convColorK c = tryConvColorK c . maybe err
+  where err = error ("Can't allocate color: "++show c)
+
+class FontGen a where
+  IFNOEXIST(fontSpec :: a -> FontSpec)
+  tryConvFontK :: FudgetIO f => a -> Cont (f i o) (Maybe FontData)
+
+  -- Methods with defaults, to be overidden only in the Char instance:
+  IFNOEXIST(fontSpecList :: [a] -> FontSpec)
+  convFontListK :: FudgetIO f => [a] -> Cont (f i o) (Maybe FontData)
+
+  IFNOEXIST(fontSpecList = ListFS . map fontSpec)
+  convFontListK  = convList tryConvFontK
+
+convFontK f k = tryConvFontK f $ maybe (tryConvFontK "fixed" $ maybe err k) k
+  where err = error ("Can't load font: "++show f)
+
+convList try xs cont = conv xs
+  where conv [] = cont Nothing
+        conv (x:xs) = try x $ maybe (conv xs) (cont . Just)
+
+
+#ifdef USE_EXIST_Q
+instance ColorGen ColorSpec where tryConvColorK (ColorSpec c) = tryConvColorK c
+instance FontGen FontSpec where tryConvFontK (FontSpeci c) = tryConvFontK c
+#else
+instance ColorGen ColorSpec where
+  colorSpec = id
+  tryConvColorK cs =
+    case cs of
+      StringCS s -> tryConvColorK s
+--      NameCS name -> tryConvColorK name
+      PixelCS pixel -> tryConvColorK pixel
+      RGBCS rgb -> tryConvColorK rgb
+--      FallbackCS fb -> tryColorColorK fb
+      ListCS cs -> tryConvColorK cs
+
+instance FontGen FontSpec where
+  fontSpec = id
+  tryConvFontK fs =
+    case fs of
+--      NameFS (Name name) -> tryConvFontK name k
+      StringFS name -> tryConvFontK name
+      FontStructFS fstr -> tryConvFontK fstr
+      ListFS fs -> tryConvFontK fs
+#endif
+
+--instance ColorGen ColorFallback where
+--  IFNOEXIST(colorSpec = FallbackCS)
+--  convColorK = convColorFallbackK
+
+--convColorFallbackK (CF c1 c2) = allocNamedColorDefPixel defaultColormap c1 c2
+
+instance ColorGen c => ColorGen [c] where
+  IFNOEXIST(colorSpec = colorSpecList)
+  tryConvColorK = convColorListK
+
+instance FontGen a => FontGen [a] where
+  IFNOEXIST(fontSpec = fontSpecList)
+  tryConvFontK = convFontListK
+
+-- To be able to allow Strings as color names, we have to make an instance for
+-- Char. We actually don't want single Chars to be allowed as color names, but
+-- to avoid run-time errors they are allowed (and treated as one-char Strings).
+instance ColorGen Char where
+  IFNOEXIST(colorSpec c = StringCS [c])
+  IFNOEXIST(colorSpecList s = StringCS s)
+  tryConvColorK c = convColorListK [c]
+  convColorListK s k = tryAllocNamedColor defaultColormap s (k . fmap colorPixel)
+
+-- In the "auto mode":
+
+-- if a font is less than 256 chars, load it as is
+-- if a font is monospaced, reuse the FontStruct, inserting
+--   a font ID obtained for the font via loadFont (as the font name was returned
+--   by listFontsWithInfo, we are safe assuming that it exists)
+-- if a font is proportional and large then keep its FID in order
+--   to query the server for characters metrics.
+
+getFontData :: FudgetIO f => [Char] -> Cont (f i o) (Maybe FontData)
+getFontData =
+    case usefontstructs of
+      "yes" -> qf
+      "no" -> lf
+      _ -> autof
+  where
+    qf fname k = loadQueryFont fname (k . fmap FS)
+    lf fname k = 
+      listFontsWithInfo fname 1 $ \ fis ->
+      case fis of
+        [] -> k Nothing
+        (fn,fs):_ -> loadFont fname $ \fid -> k $ Just $ FID $ update_font_id fs fid
+    autof fname k =
+      listFontsWithInfo fname 1 $ \ fis ->
+      case fis of
+        [] -> k Nothing
+	(fn,fs):_ -> let fprops = font_prop fs
+                     in  fontProperty fprops "SPACING" $ \spacing ->
+                         fontProperty fprops "FONT" $ \font ->
+                         if char_count<=256
+	                   then qf fn k
+                           else let fscons = if (fixed_width font spacing)
+                                               then FS
+                                               else FID
+                                in  loadFont fname $ \fid ->
+                                    k $ Just $ fscons $ update_font_id fs fid
+	   where
+	     char_count = hi-lo
+	     (lo,hi) = aboth fromEnum (font_range fs)
+
+             fixed_width fnt spcng = 
+               let spc = segments (/='-') fn
+                   spct = segments (/= '-') fnt'
+                   monosp = ["m", "c", "M", "C"]
+                   [fnt', spcng'] = map (\s -> case s of
+                                                 Just c -> c
+                                                 _      -> "\xFF") [fnt, spcng]
+                   lspc = length spc
+                   lspct = length spct
+               in  spcng' `elem` monosp ||                     -- font property tells "monospaced"
+                   lspct > 11 && (spct !! 11) `elem` monosp || -- from font property if XLFD
+                   lspc > 11 && (spc !! 11) `elem` monosp ||   -- from font name if XLFD
+                   lspc == 1 && (head spc) == "fixed"          -- no XLFD, guess by font alias
+
+{--
+	     fixed_width = spc !! 11 `elem` ["m","c"]
+--}
+{--
+	     fixed_width
+               | (spacing == (Just c)) = c `elem` monosp
+               | ((length spct) > 11) = (spct !! 11) `elem` monosp
+               | ((length spc) > 11) = (spc !! 11) `elem` monosp
+               | ((length spc) == 1) && ((head spc) == "fixed") = True
+               | otherwise = False
+
+	     fixed_width = if length spc>11
+			   then spc !! 11 `elem` ["m","c"]
+			   else --XFLD is missing, assume proportional, unless
+			        --the name of the font is "fixed"
+                                fn=="fixed"
+
+	     spc = chopList (breakAt '-') fn
+             spct = chopList (breakAt '-') font
+             monosp = ["m", "c", "M", "C"]
+--}
+
+instance FontGen Char where
+  IFNOEXIST(fontSpec c = StringFS [c])
+  IFNOEXIST(fontSpecList s = StringFS s)
+  tryConvFontK f = convFontListK [f]
+  convFontListK = getFontData
+
+--instance ColorGen Name where
+--  IFNOEXIST(colorSpec = NameCS)
+--  tryConvColorK (Name s) = tryConvColorK s
+
+tryConvColorRGBK rgb k = tryAllocColor defaultColormap rgb (k . fmap colorPixel)
+
+instance ColorGen RGB where
+  IFNOEXIST(colorSpec = RGBCS)
+  tryConvColorK = tryConvColorRGBK
+
+--instance FontGen Name where
+--  IFNOEXIST(fontSpec = NameFS)
+--  convFontK (Name s) = safeLoadQueryFont s
+  
+instance ColorGen Pixel where
+  IFNOEXIST(colorSpec = PixelCS)
+  tryConvColorK p k = k (Just p)
+
+instance FontGen FontStruct where
+  IFNOEXIST(fontSpec = FontStructFS)
+  tryConvFontK fs k = k (Just (FS fs))
+
+{--
+
+instance FontGen FontId where
+  IFNOEXIST(fontSpec = FontIdFS)
+  tryConvFontK fs k = k (Just (FID fs))
+
+--}
+
+--convGCSpecK :: GCSpec -> (GCAttributeList->FontStruct->K i o) -> K i o
+convGCSpecK fs attrs = gcattrsK fs attrs []
+  where
+    gcattrsK fs [] outattrs dr = dr (reverse outattrs) fs
+    gcattrsK fs (attr : attrs) outattrs dr =
+      let cp attr' = gcattrsK fs attrs (attr' : outattrs) dr
+      in case attr of
+	   GCForeground colspec ->
+	     convColorK colspec $ \fg ->
+	     gcattrsK fs attrs (GCForeground fg : outattrs) dr
+	   GCBackground colspec ->
+	     convColorK colspec $ \fg ->
+	     gcattrsK fs attrs (GCBackground fg : outattrs) dr
+	   GCFont fspec ->
+	     convFontK fspec $ \fs' ->
+	     gcattrsK fs' attrs (GCFont (fdFontId fs') : outattrs) dr
+	   GCFunction f -> cp (GCFunction f)
+	   GCLineWidth w -> cp (GCLineWidth w)
+	   GCLineStyle s -> cp (GCLineStyle s)
+	   GCCapStyle s -> cp (GCCapStyle s)
+	   GCJoinStyle s -> cp (GCJoinStyle s)
+	   GCSubwindowMode m -> cp (GCSubwindowMode m)
+	   GCGraphicsExposures b -> cp (GCGraphicsExposures b)
+
+gcFgA,gcBgA :: c -> [GCAttributes c FontSpec]
+gcBgA c = [GCBackground c]
+gcFgA c = [GCForeground c]
+
+gcFontA :: f -> [GCAttributes ColorSpec f]
+gcFontA f = [GCFont f]
+
+
+usefontstructs = argKey "fontstructs" "auto"
diff --git a/hsrc/drawing/GCtx.hs b/hsrc/drawing/GCtx.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/GCtx.hs
@@ -0,0 +1,38 @@
+module GCtx where
+import GCAttrs
+import Xtypes
+import Gc(createGC)
+import Command(Drawable(..))
+--import Font(FontStruct)
+--import FudgetIO
+--import NullF(F,K)
+--import Maptrace(ctrace)
+
+data GCtx = GC GCId FontData
+ --deriving (Show) -- don't want to see FontStruct
+instance Show GCtx where
+  showsPrec d (GC gc fs) = ("GC "++) . showsPrec 10 gc . ("<<FontStruct>>"++)
+
+gctx2gc (GC gc _) = gc
+
+rootGCtx = GC rootGC (error "GCtx.rootGCtx0")
+--  if usefontstructs then rootGCtx2 else rootGCtx0
+
+--rootGCtx0 = GC rootGC (FID (error "GCtx.rootGCtx0"))
+--rootGCtx1 = ...
+--rootGCtx2 = GC rootGC (FS (error "GCtx.rootGCtx2"))
+
+data GCSpec -- move to module Drawing?
+  = SoftGC [GCAttributes ColorSpec FontSpec]
+  | HardGC GCtx
+  deriving (Show)
+
+createGCtx drawable gctx@(GC gc fd) gcattrs k =
+  --ctrace "gctrace" gc $
+  convGCSpecK fd gcattrs $ \ gcattrs' fd' ->
+  createGC drawable gc gcattrs' $ \ gc' ->
+  --ctrace "gctrace" gc' $
+  k (GC gc' fd')
+
+wCreateGCtx x = createGCtx MyWindow $ x
+pmCreateGCtx x = createGCtx . Pixmap $ x
diff --git a/hsrc/drawing/Gc.hs b/hsrc/drawing/Gc.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Gc.hs
@@ -0,0 +1,26 @@
+module Gc(pmCreateGC, wCreateGC, createGC, createGCF, wCreateGCF, pmCreateGCF) where
+import Command
+import Event
+--import FudgetIO
+import NullF(F{-,K-})
+import Xrequest
+import Xtypes
+--import Maptrace(ctrace)
+
+createGC drawable template attr =
+    let cmd = CreateGC drawable template attr
+        expected (GCCreated gc) = {-ctrace "gctrace" gc $-} Just gc
+        expected _ = Nothing
+    in xrequest cmd expected
+
+--createGCK :: Drawable -> GCId -> GCAttributeList -> (GCId -> K a b) -> K a b
+--createGCK = createGC
+
+createGCF :: Drawable -> GCId -> GCAttributeList -> (GCId -> F a b) -> F a b
+createGCF = createGC
+
+wCreateGC x = createGC MyWindow x
+pmCreateGC x = (createGC . Pixmap) x
+
+wCreateGCF = createGCF MyWindow
+pmCreateGCF = createGCF . Pixmap
diff --git a/hsrc/drawing/Graphic.hs b/hsrc/drawing/Graphic.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Graphic.hs
@@ -0,0 +1,51 @@
+module Graphic(module Graphic,MeasuredGraphics,emptyMG,emptyMG',GCtx,Cont(..)) where
+import Fudget
+import FudgetIO
+import EitherUtils(Cont(..))
+import Cont(conts)
+import MeasuredGraphics(MeasuredGraphics(..),measureString,measurePackedString,emptyMG,emptyMG')
+import GCtx(GCtx)
+import PackedString(PackedString)
+import Geometry() -- instance Num Point
+
+class Graphic a where
+  measureGraphicK :: FudgetIO k => a -> GCtx -> Cont (k i o) MeasuredGraphics
+  measureGraphicListK :: FudgetIO k => [a] -> GCtx -> Cont (k i o) MeasuredGraphics
+  -- Default method for lists:
+  measureGraphicListK xs gctx cont =
+	conts (`measureGraphicK` gctx) xs $ \ mgs ->
+	cont (ComposedM mgs)
+
+instance Graphic MeasuredGraphics where
+  measureGraphicK cgfx gctx c = c cgfx
+
+instance Graphic Char where
+  measureGraphicK c = measureString [c]
+  measureGraphicListK = measureString
+
+instance Graphic a => Graphic [a] where
+  measureGraphicK = measureGraphicListK
+
+instance (Graphic a,Graphic b) => Graphic (a,b) where
+  measureGraphicK (x,y) gctx cont =
+    measureGraphicK x gctx $ \ mx ->
+    measureGraphicK y gctx $ \ my ->
+    cont (ComposedM [mx,my])
+
+measureText x = (measureString.show) x
+
+-- instance Text a => Graphics a where measureGraphicK = measureText
+instance Graphic Int          where measureGraphicK = measureText
+instance Graphic Integer      where measureGraphicK = measureText
+instance Graphic Bool         where measureGraphicK = measureText
+instance Graphic Float        where measureGraphicK = measureText
+instance Graphic Double       where measureGraphicK = measureText
+instance Graphic PackedString where measureGraphicK = measurePackedString
+
+instance (Graphic a,Graphic b) => Graphic (Either a b) where
+  measureGraphicK = either measureGraphicK measureGraphicK
+
+instance Graphic a => Graphic (Maybe a) where
+  measureGraphicK = maybe (measureGraphicK (emptyMG 5)) measureGraphicK
+
+--instance Graphic Void
diff --git a/hsrc/drawing/Graphic2Pixmap.hs b/hsrc/drawing/Graphic2Pixmap.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Graphic2Pixmap.hs
@@ -0,0 +1,31 @@
+module Graphic2Pixmap(graphic2PixmapImage,PixmapImage(..)) where
+import DrawCompiledGraphics(drawK')
+import MeasuredGraphics(compileMG)
+import Graphic
+import PixmapGen
+import Pixmap(createPixmap)
+import LayoutRequest(minsize)
+import XDraw
+import ResourceIds(copyFromParent)
+import FixedDrawing
+import FudgetIO
+import NullF() -- instance FudgetIO K
+
+graphic2PixmapImage g gctx cont =
+  measureGraphicK g gctx $ \ mg -> convToPixmapK mg cont
+
+measuredGraphics2Pixmap mg cont =
+  let (cg,req) = compileMG id mg
+      size = minsize req
+  in createPixmap size copyFromParent $ \ pm ->
+     drawK' (Pixmap pm) (undefined,const []) (const []) cg $
+     cont (PixmapImage size pm)
+
+instance PixmapGen MeasuredGraphics where
+  convToPixmapK = measuredGraphics2Pixmap
+
+instance PixmapGen FixedColorDrawing where
+  convToPixmapK (FixCD size gcdcmds) cont =
+    createPixmap size copyFromParent $ \ pm ->
+    putLow (pmDrawMany pm gcdcmds) $
+    cont (PixmapImage size pm)
diff --git a/hsrc/drawing/LoadFont.hs b/hsrc/drawing/LoadFont.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/LoadFont.hs
@@ -0,0 +1,72 @@
+module LoadFont(loadQueryFont, queryFont, loadFont, loadQueryFontF, 
+                queryFontF, loadFontF,safeLoadQueryFont, safeLoadQueryFontF,
+                listFonts,listFontsF,listFontsWithInfo,tryLoadFont) where
+import Command(XRequest(..))
+import Event
+import Font(fsl2fs) --FontStruct,FontStructList,
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import EitherUtils(stripMaybe,mapMaybe)
+import Data.Maybe(fromJust)
+import HbcUtils(mapSnd)
+import Cont(tryM)
+import Xrequest
+import Xtypes
+
+lf k fontname =
+    let cmd = LoadFont fontname
+        expected (FontLoaded fid) = Just fid
+        expected _ = Nothing
+    in k cmd expected
+
+loadFont x = lf xrequest x
+loadFontF = lf xrequestF
+
+qf k fid =
+    let cmd = QueryFont fid
+        expected (FontQueried fs) = Just (fsl2fs (fromJust fs))
+        expected _ = Nothing
+    in  k cmd expected
+
+queryFont x = qf xrequest x
+queryFontF = qf xrequestF
+
+lqf k fontname =
+    let cmd = LoadQueryFont fontname
+        expected (FontQueried optfs) = Just (fmap fsl2fs optfs)
+        expected _ = Nothing
+    in  k cmd expected
+
+loadQueryFont x = lqf xrequest x
+loadQueryFontF = lqf xrequestF
+
+safeLqf lqf fn k =
+  tryM (lqf fn)
+       (lqf ("fixed"::FontName) $ \ (Just fs) -> k fs)
+       k
+
+safeLoadQueryFont x = safeLqf loadQueryFont x
+safeLoadQueryFontF = safeLqf loadQueryFontF
+
+lif k pattern maxnames =
+    let cmd = ListFonts pattern maxnames
+        expected (GotFontList fns) = Just fns
+	expected _ = Nothing
+    in k cmd expected
+
+listFonts x = lif xrequest x
+listFontsF = lif xrequestF
+
+listFontsWithInfo pattern maxnames =
+    let cmd = ListFontsWithInfo pattern maxnames
+        expected (GotFontListWithInfo fis) = Just (mapSnd fsl2fs fis)
+--      expected (GotFontListWithInfo fis) = Just (map ((,) pattern . fsl2fs) fis)
+	expected _ = Nothing
+    in xrequest cmd expected
+
+-- Since loadFont succeeds and returns a FontId even if the font doesn't exist:
+tryLoadFont fn k =
+  listFonts fn 1 $ \ fns ->
+  case fns of
+    fn:_ -> loadFont fn (k . Just)
+    _ -> k Nothing
diff --git a/hsrc/drawing/Pixmap.hs b/hsrc/drawing/Pixmap.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/Pixmap.hs
@@ -0,0 +1,30 @@
+module Pixmap(bitmapFromData, readBitmapFile, createPixmap) where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+--import Message(Message(..))
+--import Path(Path(..))
+import Xrequest
+--import Xtypes
+
+createPixmap size depth =
+    let cmd = CreatePixmap size depth
+        expected (PixmapCreated pixmap) = Just pixmap
+        expected _ = Nothing
+    in  xrequest cmd expected
+
+readBitmapFile name =
+    let cmd = ReadBitmapFile name
+        expected (BitmapRead b) = Just b
+        expected _ = Nothing
+    in  xrequest cmd expected
+
+bitmapFromData bd =
+    let cmd = CreateBitmapFromData bd
+        expected (BitmapRead b) = Just b
+        expected _ = Nothing
+    in  xrequest cmd expected
+
diff --git a/hsrc/drawing/PixmapGen.hs b/hsrc/drawing/PixmapGen.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/PixmapGen.hs
@@ -0,0 +1,43 @@
+module PixmapGen where
+import Graphic
+import MeasuredGraphics(MeasuredGraphics(..))
+import GCtx(GCtx(..))
+--import Command
+--import Event
+import DrawTypes
+import Geometry(Rect(..),Size,origin)
+import Xtypes
+import FudgetIO
+import NullF() -- instances, for hbc
+import LayoutRequest(plainLayout)
+import Gc
+--import EitherUtils(Cont(..))
+--import Io(appendChanK)
+--import Pixmap(readBitmapFile)
+--import Maybe(maybeToList)
+--import ContinuationIO(stderr)
+
+data PixmapImage = PixmapImage Size PixmapId
+
+instance Graphic PixmapImage where
+    measureGraphicK (PixmapImage size pixmap) (GC gc _) k =
+      wCreateGC gc [GCGraphicsExposures False] $ \ gc' ->
+      let r = Rect origin size
+	  ll = plainLayout size True True
+	  drawit (Rect p _) = [(gc,[CopyArea (Pixmap pixmap) r p])]
+      in k (LeafM ll drawit)
+
+---
+
+class PixmapGen a where
+  convToPixmapK :: FudgetIO c => a -> Cont (c i o) PixmapImage
+
+measureImageK a gctx k =
+  convToPixmapK a $ \ pmi ->
+  measureGraphicK pmi gctx k
+
+--This is not allowed in Haskell...
+--instance PixmapGen a => Graphic a where  measureGraphicsK = measureImageK
+
+instance PixmapGen PixmapImage where
+  convToPixmapK pmi k = k pmi
diff --git a/hsrc/drawing/TextExtents.hs b/hsrc/drawing/TextExtents.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/TextExtents.hs
@@ -0,0 +1,12 @@
+module TextExtents where
+import Xrequest(xrequest)
+import Command
+import Event
+
+queryTextExtents16K fid str k =
+    xrequest cmd expected $ \ (a,d,cs) -> k a d cs
+  where
+    cmd = QueryTextExtents16 fid str
+
+    expected (TextExtents16Queried a d cs) = Just (a,d,cs)
+    expected _ = Nothing
diff --git a/hsrc/drawing/TransCoord.hs b/hsrc/drawing/TransCoord.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/drawing/TransCoord.hs
@@ -0,0 +1,23 @@
+module TransCoord where
+import Command
+import Event
+import Fudget
+import FRequest
+import Geometry(Point)
+import Xrequest
+import Cont(cmdContK)
+import Xtypes
+
+getWindowRootPoint :: Cont (K a b) Point
+getWindowRootPoint =
+    let cmd = TranslateCoordinates
+        expected (CoordinatesTranslated p) = Just p
+        expected _ = Nothing
+    in  xrequestK cmd expected
+
+
+getWindowId :: Cont (K a b) Window
+getWindowId = cmdContK (XCmd GetWindowId)
+	      (\r->case r of XEvt (YourWindowId w) -> Just w; _ -> Nothing)
+
+-- Why is GetWindowId an XCommand?
diff --git a/hsrc/exists.h b/hsrc/exists.h
new file mode 100644
--- /dev/null
+++ b/hsrc/exists.h
@@ -0,0 +1,33 @@
+#if defined(__HBC__) || defined(__GLASGOW_HASKELL__) || defined(__NHC__) || defined(__PFE__)
+#define USE_EXIST_Q
+#else
+#warning No existential types! The type Gfx will be omitted and the function g will be less general.
+#endif
+
+#ifdef USE_EXIST_Q
+#define IFNOEXIST(e)
+#define IFEXIST(e) e
+#else
+#define IFNOEXIST(e) e
+#define IFEXIST(e)
+#endif
+
+-- Syntax for existential quantification varies:
+#if defined(__HBC__)
+#define EQV(x) ?x
+#define EXISTS(x) 
+#elif defined(__GLASGOW_HASKELL__) || defined(__PFE__)
+#define EQV(x) x
+#define EXISTS(x) forall x .
+#else
+-- assume any free type variable is existential (like in NHC and old HBC)
+#define EQV(x) x
+#define EXISTS(x) 
+#endif
+
+
+#ifdef __PFE__
+#define TSTHACK(e) e
+#else
+#define TSTHACK(e) e
+#endif
diff --git a/hsrc/filters/DoubleClickF.hs b/hsrc/filters/DoubleClickF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/filters/DoubleClickF.hs
@@ -0,0 +1,27 @@
+module DoubleClickF where
+import Fudget
+import FRequest
+import Xtypes
+import Event
+--import Font(FontStruct)
+import Spops
+--import Geometry(Point,Rect,Size(..))
+import CompOps((>=..<))
+
+doubleClickF :: Time -> F a b -> F a b
+doubleClickF timeout fudget = fudget >=..< doubleClickSP 0 dummy
+  where
+    dummy = error "bug in DoubleClickF.hs"
+    doubleClickSP n last =
+      getSP $ \ tev@(path,ev) ->
+      case ev of
+        XEvt (ButtonEvent t wp rp mods press btn) ->
+	    if n==0 || press/=Pressed || t>lasttime+timeout ||
+	       btn/=lastbtn || mods/=lastmods || path/=lastpath
+	    then putSP tev $ doubleClickSP 1 tev
+	    else let n' = n+1
+		     tev' = (path,XEvt (ButtonEvent t wp rp mods (MultiClick n') btn))
+	         in putSP tev' $ doubleClickSP n' tev'
+	  where
+	    (lastpath,XEvt (ButtonEvent lasttime _ _ lastmods _ lastbtn)) = last
+	_ -> putSP tev $ doubleClickSP n last
diff --git a/hsrc/filters/Filters.hs b/hsrc/filters/Filters.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/filters/Filters.hs
@@ -0,0 +1,15 @@
+module Filters (
+  -- * Filters
+  --module Cache,
+  module NewCache,
+  module ShapeGroupMgr,module DoubleClickF) where
+--import Cache
+import NewCache
+import ShapeGroupMgr
+import DoubleClickF
+
+{-
+import Fudget
+import Geometry(Rect)
+import Xtypes(WindowAttributes,Time(..))
+-}
diff --git a/hsrc/filters/FocusMgr.hs b/hsrc/filters/FocusMgr.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/filters/FocusMgr.hs
@@ -0,0 +1,179 @@
+module FocusMgr(focusMgr) where
+import Data.List((\\),sortBy)
+import Data.Maybe(listToMaybe)
+import Command
+--import Direction
+import Dlayout(invisibleGroupF)
+import Event
+--import Font(FontStruct)
+import Fudget
+import FRequest
+--import Geometry(origin) --Line(..), Point(..), Rect(..), Size(..), origin)
+--import LayoutRequest(LayoutRequest)
+import LoopLow
+import HbcUtils(union)
+--import Message(Message(..))
+import Path
+import PathTree hiding (pos)
+--import SP
+import Spops
+import CompSP
+import Utils
+import CmdLineEnv(argKey,argReadKey)
+import WindowF(kernelTag,autumnize)
+import Xtypes
+--import List2(sort)
+
+import Maptrace
+
+getEventMask [] = Nothing
+getEventMask (CWEventMask m : _) = Just m
+getEventMask (_ : l) = getEventMask l
+
+setEventMask em [] = [CWEventMask em]
+setEventMask em (CWEventMask m : l) = CWEventMask em : l
+setEventMask em (wa : l) = wa : setEventMask em l
+
+focusBtn = Button 1
+focusMods = [] --rotMods
+rotMods = argReadKey "rotmods" [] :: ModState
+rotKs = argKey "rotkey" "Tab" :: KeySym
+
+entrymask = [KeyPressMask, EnterWindowMask, LeaveWindowMask]
+mask = [KeyPressMask, KeyReleaseMask, EnterWindowMask, LeaveWindowMask]
+
+mkFocusEvent io = io NotifyNonlinearVirtual NotifyNormal
+
+focusMgr sizing ctt f = loopThroughLowF focusK0 igF
+  where
+  igF = invisibleGroupF sizing [] [CWEventMask mask] f
+  focusK0 = prepostMapSP pre post 
+	       (focusK' False emptyPathTree False [] mask [] [] []) where
+      pre (Left (t,m)) = (t,Left m)
+      pre (Right (t,m)) = (t,Right m)
+      post (t,Left m) = Left (t,m)
+      post (t,Right m) = Right (t,m)
+
+  --focusK' :: PathTree Bool ->  Bool ->  [(Bool,Path)] -> [EventMask] -> [(Path,(XEvent -> Maybe XEvent))] -> [Path] -> [(Bool,Path)] -> SP (Path,Either Command Event) (Path,Either Command Event) 
+  focusK' focusin mapped inw grab mask tt shellTags etags = same where
+   focusK = focusK' focusin mapped
+   focusm = focusK inw grab mask tt
+   modMapped tag raised = changeFocusc' mapped' id 
+         [(and (spineVals mapped' t),t) | (_,t) <- etags]
+      where mapped' = updateNode id True mapped (autumnize tag) (const raised)
+   changeFocusc' mapped' c netags = 
+       inw && listToMaybe (mappedtags etags) /= listToMaybe (mappedtags netags)
+         `thenC` (leaveFocus etags . enterFocus netags) $ 
+       c $
+       focusK' focusin mapped' inw grab mask tt shellTags netags 
+   changeFocusc = changeFocusc' mapped
+   changeFocus = changeFocusc id
+   rotate ts = case break fst ts of
+       (unmapped,[]) -> ts
+       (unmapped,t:mapped) -> mapped ++ unmapped ++ [t]
+   nexttag = rotate etags
+   prevtag = reverse (rotate (reverse etags))
+   enterFocus et = putFocus et FocusIn `ifC` inw
+   leaveFocus et = putFocus et FocusOut `ifC` inw
+   putFocus et f = putFocus' et (mkFocusEvent f)
+   mappedtags et = [t |(True,t)<- et]
+   putFocus' et ev = case mappedtags et of 
+	 [] -> id
+	 (t:_) -> putSP (t, Right (XEvt ev))
+   same = getSP focushandle
+   focushandle tmsg@(tag,msg) = case msg of 
+      Left cmd ->
+        case cmd of 
+	  XCmd xcmd -> case xcmd of
+	    GrabEvents t -> putSP (tag, Left (XCmd $ GrabEvents (t || stag))) $
+			    stag `thenC` (leaveFocus etags .
+					  enterFocus [(True,tag)]) $
+			    focusK inw ((not stag,tag):grab) 
+					   mask tt shellTags etags
+	    UngrabEvents -> null grab' && inw `thenC` enterFocus etags $
+			    pass $ focusK inw grab' mask tt shellTags etags
+			  where grab' = drop 1 grab
+	    TranslateEvent t tmask ->  putSP (kernelTag, 
+	       Left (XCmd $ ChangeWindowAttributes [CWEventMask umask])) $
+		  focusK inw grab umask ((tag,t):tt) shellTags etags 
+	      where umask = union mask tmask
+	    ChangeWindowAttributes cwa | ctt && not ktag && not stag ->
+	       case getEventMask cwa of
+		  Just em -> if issubset entrymask em then
+				putSP (tag, Left (XCmd $ ChangeWindowAttributes 
+				       (setEventMask ((ButtonPressMask:
+					      em) \\ entrymask) cwa))) $
+				null etags `thenC` enterFocus etags' $
+				focusm shellTags etags'
+			     else passame
+			where etags' = sortBy (\(_,x) (_,y)-> compare x y)
+					      ((False,tag):etags)
+		  Nothing -> passame
+	    DestroyWindow -> pass $ 
+		 -- not (null etags) && not (keep (head etags)) `thenC`
+	       enterFocus etags' $
+	       focusK inw grab mask tt' shellTags' (etags' :: [(Bool,Path)])
+	      where keep = not . subPath tag
+		    etags' = filter (keep.snd) etags
+		    shellTags' = filter keep shellTags
+		    tt' = filter (keep.fst) tt
+	    MapRaised   -> changeMapping tag True
+	    UnmapWindow -> changeMapping tag False
+	    _ -> passame
+	  XReq (CreateMyWindow _) -> changeMapping tag False
+	  XReq (CreateRootWindow _ _) {-  | not ktag -} ->
+	     pass $ focusm (autumnize tag: shellTags) etags
+	  XReq (CreateSimpleWindow rchild _) -> 
+	      changeMapping (absPath (autumnize tag) rchild) False
+	  _ -> passame
+       where changeMapping tag raised = ctrace "focus1" (raised,tag) $ pass $ modMapped tag raised
+      Right (XEvt ev) ->
+        if stag then passame
+	else case ev of
+	   ButtonEvent {state=mods,type'=Pressed,button=bno} | ctt && mods == focusMods 
+	      && bno == focusBtn && etag -> changeFocusc pass (aft++bef)
+ 	      where (bef,aft) = break (flip subPath tag.autumnize.snd) etags
+	   _ -> case flookup ev tt of
+	       Just (t,e) -> putSP (t,Right (XEvt e)) same
+	       Nothing -> if not ctt then passame else 
+	         case ev of
+		  KeyEvent {state=mods,type'=Pressed,keySym=ks} | ks == rotKs && ktag ->
+		    if (Shift:rotMods) `issubset` mods then changeFocus prevtag
+		    else if rotMods    `issubset` mods then changeFocus nexttag
+		    else passame
+		  KeyEvent {} |tag==kernelTag || gtag' -> toFocus same
+		  EnterNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d True
+		  LeaveNotify {detail=d,focus=True} | tag==kernelTag -> handleEL False d False
+		  FocusIn  {detail=d} | tag==kernelTag || gtag' -> handleEL True d True
+		  FocusOut {detail=d} | tag==kernelTag || gtag' -> handleEL True d False
+		  _ -> passame
+	where toFocus = putFocus' etags ev 
+	      handleEL isFocusEv d e = if d == NotifyInferior 
+                                       || (not isFocusEv && focusin) -- focus events have priority over crossing events
+                       then passame else
+		       (case grab of
+			  (my,t):_ -> if my then if ktag then focusEvToFocus
+						 else pass
+				      else if ktag then 
+					     putSP (t,Right (XEvt ev))
+					    else pass
+			  [] -> if ktag then focusEvToFocus else pass ) $ 
+		       focusK' focusin' mapped inw' grab mask tt shellTags etags
+		  where inw' = if ktag then e else inw
+                        focusin' = if ktag && isFocusEv then e else focusin
+                        focusEvToFocus = putFocus etags (if e then FocusIn else FocusOut)
+      Right _ -> passame
+    where pass = putSP tmsg
+	  passame = pass same
+	  ktag = tag == kernelTag || gtag
+	  stag = inGroup shellTags
+	  etag = inGroup (map (autumnize.snd) etags)
+	  gtag = case grab of (_,t):_ -> t == tag; [] -> False
+	  gtag' = case grab of (True,t):_ -> t == tag; [] -> False -- event grabbed by something in my shell
+          inGroup tags = any (flip subPath tag) tags
+
+flookup index' [] = Nothing
+flookup index' ((t, p) : table') =
+    case p index' of
+      Nothing -> flookup index' table'
+      Just e -> Just (t, e)
diff --git a/hsrc/filters/NewCache.hs b/hsrc/filters/NewCache.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/filters/NewCache.hs
@@ -0,0 +1,64 @@
+module NewCache(allcacheF) where
+import Command
+--import Event
+import FRequest
+--import Fudget
+--import Loopthrough
+import Spops
+import LoopLow
+import Cont
+import IsRequest
+--import DialogueIO hiding (IOError)
+import qualified Data.Map as OM
+
+--import Maptrace(ctrace) -- debug
+--import NonStdTrace(trace)
+
+-- A new implementation of the X resource cache.
+-- TODO: reference counters and the ability to free unused resources.
+
+allcacheable xreq =
+  case xreq of
+    LoadFont fn -> True
+    QueryFont f -> True
+    LoadQueryFont s -> True
+    ListFonts pat max -> True
+    ListFontsWithInfo pat max -> True
+    CreateGC d t as -> True
+    -- FreeGC gcid 
+    AllocNamedColor cm cn -> True
+    AllocColor cm rgb -> True
+    -- FreeColors cm [pixel] (Pixel 0)
+    CreateFontCursor shape -> True
+    ReadBitmapFile name -> True
+    CreateBitmapFromData bdata -> True -- hmm, big request, small result...
+    _ -> False
+
+allcacheF = cacheF allcacheable
+
+cacheF cacheable fud = loopThroughLowF (cc OM.empty) fud where
+  cc table = same where
+     same = getSP cachehandle
+     cachehandle msg = case msg of 
+       Left tc@(tag,c) ->
+	   case c of
+	     XReq xreq ->
+	       if cacheable xreq
+	       then case OM.lookup xreq table of
+		      Just r -> putSP (Right (tag,r)) $
+				cc table
+		      Nothing -> waitresp $ \r ->
+				 --ctrace "trcache" ("alloc",c,d,r) $
+				 cc (OM.insert xreq r table)
+	       else waitresp $ \r -> same
+	     _ -> if isRequest c
+		  then waitresp $ \r -> same
+		  else psame
+         where waitresp c = cmdContSP (Left tc)
+		 (\msg->case msg of Right te@(_,e) | isResponse e -> Just te
+				    _ -> Nothing) $ \tr@(_,r) ->
+		 putSP (Right tr) $ c r
+       Right _ -> psame
+      where
+       pass = putSP msg
+       psame = pass same
diff --git a/hsrc/filters/ShapeGroupMgr.hs b/hsrc/filters/ShapeGroupMgr.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/filters/ShapeGroupMgr.hs
@@ -0,0 +1,75 @@
+module ShapeGroupMgr(shapeGroupMgr) where
+
+--import Path
+import LoopLow
+import Command
+--import Event
+import Fudget
+import FRequest
+import Geometry
+--import Message(Message(..))
+--import NullF
+--import Spacers
+--import Alignment
+import Spops
+--import EitherUtils
+import Data.Maybe(fromMaybe,mapMaybe)
+import Utils
+import Xtypes
+import WindowF(kernelTag,getBWidth,adjustBorderWidth,border_width)
+--import AuxTypes(Ordering(..)) -- HBC bug workaround 960405 TH.
+--import Prelude hiding (Ordering)
+
+doConfigure tag wins cws = lookup tag wins >>= \br ->
+    let br' = upd br cws 
+        upd br [] = br
+	upd br@(bw,r@(Rect (Point x y) (Point w h))) (c:cs) = 
+	   upd (case c of
+		 CWX x' -> (bw,Rect (Point x' y) (Point w h))
+		 CWY y' -> (bw,Rect (Point x y') (Point w h))
+		 CWWidth w' -> (bw,Rect (Point x y) (Point w' h))
+		 CWHeight h' -> (bw,Rect (Point x y) (Point w h'))
+		 CWBorderWidth bw' -> (bw',r)
+		 _ -> br) cs
+    in if br  == br' then Nothing else Just $ replace (tag,br') wins
+
+filterBorderwidth = mapMaybe (\c->case c of CWBorderWidth _ -> Nothing
+					    _-> Just c)
+shapeGroupMgr :: F a b -> F a b
+shapeGroupMgr f  = loopThroughLowF (sg (border_width,[])) f where
+   sg state@(bw,wins) =
+      getSP $ \msg -> 
+      let same = sg state
+          pass = putSP msg
+	  passame = pass same 
+          reshape bw wins = shape ShapeBounding bw $
+			    shape ShapeClip 0 $ sg (bw,wins) where
+	     shape kind bw =
+	       putSP (Left (kernelTag,
+	                      XCmd $
+	                      ShapeCombineRectangles 
+			        kind
+				origin
+				(map (adj bw.snd) wins) ShapeSet Unsorted))
+	  adj bw (lbw,Rect p s) = Rect (p `psub` (Point bw bw))
+			               (adjustBorderWidth (lbw+bw) s)
+      in case msg of
+        Left (tag,cmd) -> 
+            case cmd of
+	      XReq (CreateSimpleWindow stag r) | tag == kernelTag ->
+	         pass $ sg (bw,(stag,(border_width,r)):wins)
+	      XCmd (ConfigureWindow cws) | tag == kernelTag ->
+	         let bw' = fromMaybe bw (getBWidth cws) 
+		     cws'= filterBorderwidth cws
+		 in
+		 putSP (Left (tag,XCmd (ConfigureWindow cws'))) $
+		 if bw == bw' then same else reshape bw' wins
+	      XCmd (ConfigureWindow cws) -> 
+	         case doConfigure tag wins cws of
+		    Nothing -> passame
+		    Just wins' -> pass $ reshape bw wins'
+	      XCmd DestroyWindow ->
+		 pass $ sg (bw,filter ((/=tag).fst) wins)
+	      _ -> passame
+        _ -> passame
+
diff --git a/hsrc/fudgets/BellF.hs b/hsrc/fudgets/BellF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/BellF.hs
@@ -0,0 +1,9 @@
+module BellF where
+import NullF(getF,putF)
+import Command
+import Xcommand
+
+bellF = getF $ \ x ->
+ 	xcommandF (Bell 0) $
+	putF x $
+ 	bellF
diff --git a/hsrc/fudgets/Border3dF.hs b/hsrc/fudgets/Border3dF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/Border3dF.hs
@@ -0,0 +1,146 @@
+module Border3dF(border3dF) where
+--import ButtonGroupF
+import Color
+import Command
+import XDraw
+import CompOps((>^=<))
+import Defaults(bgColor, shadowColor, shineColor,new3d)
+--import CmdLineEnv(argFlag)
+import Dlayout(groupF)
+import Event
+import Fudget
+--import FudgetIO
+import FRequest
+import Xcommand
+import Gc
+import Geometry(Point(..), origin, pP)
+import GreyBgF(changeBg)
+import LayoutRequest
+--import Message(Message(..))
+import NullF
+import Spacer(marginF)
+import EitherUtils(stripEither)
+import Utils(swap)
+import Xtypes
+import GCtx(wCreateGCtx,GCtx(..))
+import GCAttrs(gcFgA)
+
+border3dF =
+  if new3d
+  then newBorder3dF
+  else oldBorder3dF
+ 
+newBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
+newBorder3dF down edgew f =
+    stripEither >^=< ((groupF startcmds kernel . marginF edgew) f)
+  where
+    startcmds =
+      [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask],
+	                              CWBitGravity NorthWestGravity]]
+				      -- bit gravity reduces flicker on resize
+
+    wCreateGC gc0 gcas cont =
+       wCreateGCtx (GC gc0 undefined) gcas $ \ (GC gc _) -> cont gc
+    gcFg x = wCreateGC rootGC $ gcFgA x
+    kernel =
+      changeBg bgColor $
+      gcFg shineColor $ \ whiteGC ->
+      gcFg "black" $ \ blackGC ->
+      gcFg [shadowColor,"black"] $ \ shadowGC ->
+      let dRAW s pressed =
+	    let lrc@(Point w h) = s-1
+		ulc = 0; llc = pP 0 h; urc = pP w 0
+		uli = 1; lli = llc+nw; lri = lrc-1; uri = urc-nw
+		nw = pP 1 (-1)
+		upper1 = [llc,ulc,urc]
+		upper2 = [lli,uli,uri]
+		lower1 = [llc,lrc,urc]
+		lower2 = [lli,lri,uri]
+	    in if pressed
+	       then draw lower1 upper1 upper2
+	       else draw upper1 lower1 lower2
+	  drawlines gc ls = (gc,[DrawLines CoordModeOrigin ls])
+	  draw wls bls dls =
+	       [ClearWindow,
+		DrawMany MyWindow [
+		 drawlines shadowGC dls,
+		 drawlines whiteGC wls,
+		 drawlines blackGC bls]]
+	  proc pressed size =
+	      getK $ \bmsg ->
+	      let same = proc pressed size
+		  draw = dRAW size
+		  redraw = draw pressed
+	      in case bmsg of
+		   Low (XEvt (Expose _ 0)) -> xcommandsK redraw same
+		   Low (LEvt (LayoutSize newsize)) | newsize/=size ->
+		     xcommandsK (dRAW newsize pressed) $ 
+		     -- redraw needed here because of bit gravity
+		     proc pressed newsize
+		   High change | change/=pressed ->
+		     xcommandsK (draw change) (proc change size)
+		   _ -> same
+	  proc0 pressed =
+	      getK $ \msg ->
+	      case msg of
+		Low (LEvt (LayoutSize size)) -> proc pressed size
+		High change -> proc0 change
+		_ -> proc0 pressed
+      in proc0 down
+
+oldBorder3dF :: Bool -> Int -> F a b -> F (Either Bool a) b
+oldBorder3dF down edgew f =
+    stripEither >^=< ((groupF startcmds kernel . marginF edgew) f)
+  where
+    startcmds =
+      [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask],
+	                              CWBitGravity NorthWestGravity]]
+				      -- bitgravity reduces flicker on resize
+    kernel =
+      changeBg bgColor $
+      allocNamedColorPixel defaultColormap shineColor $ \shine ->
+      allocNamedColorPixel defaultColormap shadowColor $ \shadow ->
+      wCreateGC rootGC [GCFunction GXcopy,
+			GCForeground shadow] $ \shadowGC ->
+      wCreateGC shadowGC [GCForeground shine] $ \shineGC ->
+      let dRAW s pressed =
+	    let lrc@(Point w h) = s
+		e = edgew
+		ulc = origin
+		urc = pP w 0	-- pP (w - 1) 0
+		llc = pP 0 h	-- pP 0 (h - 1)
+		uli = pP e e
+		lli = pP e (h - edgew)
+		lri = pP (w - edgew) (h - edgew)
+		uri = pP (w - edgew) e
+		upper = [ulc, urc, uri, uli, lli, llc]
+		lower = [llc, lrc, urc, uri, lri, lli]
+		(upperGC, lowerGC) = (if pressed
+				      then swap
+				      else id) (shineGC, shadowGC)
+	    in [ClearWindow,
+		DrawMany MyWindow [
+		  (lowerGC,[FillPolygon Nonconvex CoordModeOrigin lower]),
+		  (upperGC,[FillPolygon Nonconvex CoordModeOrigin upper])]]
+	  proc pressed size =
+	      getK $ \bmsg ->
+	      let same = proc pressed size
+		  draw = dRAW size
+		  redraw = draw pressed
+	      in case bmsg of
+		   Low (XEvt (Expose _ 0)) -> xcommandsK redraw same
+		   Low (LEvt (LayoutSize newsize)) ->
+		     if newsize==size
+		     then same
+		     else xcommandsK (dRAW newsize pressed) $ 
+			  -- redraw needed here because of bit gravity
+			  proc pressed newsize
+		   High change -> xcommandsK (draw change) (proc change size)
+		   _ -> same
+	  proc0 pressed =
+	      getK $ \msg ->
+	      case msg of
+		Low (LEvt (LayoutSize size)) -> proc pressed size
+		High change -> proc0 change
+		_ -> proc0 pressed
+      in proc0 down
diff --git a/hsrc/fudgets/ButtonBorderF.hs b/hsrc/fudgets/ButtonBorderF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/ButtonBorderF.hs
@@ -0,0 +1,95 @@
+module ButtonBorderF(buttonBorderF) where
+--import BgF
+import Border3dF
+--import ButtonGroupF
+import Color
+import Command(XCommand(ChangeWindowAttributes,ClearArea,DrawMany,Draw))
+import XDraw
+import CompOps((>^=<))
+import Defaults(look3d, shadowColor, shineColor,bgColor)
+import Dlayout(groupF)
+import Event
+import Fudget
+--import FudgetIO
+import FRequest
+import Xcommand
+import Gc
+import Geometry(Line(..), Point(..), Rect(..), origin, pP, padd, psub)
+import LayoutRequest
+--import Message(Message(..))
+import NullF
+import Spacer(marginF)
+import EitherUtils(stripEither)
+import Xtypes
+import GreyBgF(changeBg)
+
+buttonBorderF :: Int -> F a b -> F (Either Bool a) b
+buttonBorderF = if look3d then border3dF False else stdButtonBorderF
+
+stdButtonBorderF edgew f =
+    let kernel =
+          changeBg bgColor $
+	  allocNamedColorDefPixel defaultColormap shineColor "white" $ \shine->
+	  allocNamedColorDefPixel defaultColormap shadowColor "black" $ \shadow ->
+	  wCreateGC rootGC [GCFunction GXcopy, GCForeground shadow,
+			    GCBackground shine] $ \drawGC ->
+	  wCreateGC drawGC [GCForeground shine] $ \shineGC ->
+	  wCreateGC rootGC (invertColorGCattrs shine shadow) $ \invertGC ->
+	  let bpx = edgew
+	      bpy = edgew
+	      upperLeftCorner = Point bpx bpy
+	      dRAW s = 
+		 let size@(Point sx sy) = psub s (Point 1 1)
+		     rect = Rect origin size
+		     upperRightCorner = Point (sx - bpx) bpy
+		     lowerLeftCorner = Point bpx (sy - bpy)
+		     lowerRightCorner = psub size upperLeftCorner
+		     leftBorder = Line upperLeftCorner lowerLeftCorner
+		     upperBorder = Line upperLeftCorner upperRightCorner
+		     upperLeftLine = Line origin upperLeftCorner
+		     lowerRightLine = Line lowerRightCorner size
+		     incx = padd (Point 1 0)
+		     incy = padd (Point 0 1)
+		     decx = padd (Point (-1) 0)
+		     decy = padd (Point 0 (-1))
+		     lowerBorderPoints = [lowerLeftCorner, lowerRightCorner, 
+					  upperRightCorner, Point sx 0, size, Point 0 sy]
+		     borderPoints =
+		       [pP 1 1, pP 1 sy, size, pP sx 1, origin, upperLeftCorner, 
+		        incy lowerLeftCorner, (incx . incy) lowerRightCorner, 
+			incx upperRightCorner, upperLeftCorner]
+		 in  ( [ClearArea rect False, 
+		        DrawMany MyWindow [
+			  (shineGC,[FillPolygon Nonconvex CoordModeOrigin
+			            borderPoints]),
+			  (drawGC,[FillPolygon Nonconvex CoordModeOrigin 
+			           lowerBorderPoints, 
+			           DrawLine leftBorder, 
+			           DrawLine upperBorder, 
+			           DrawLine upperLeftLine]), 
+			  (invertGC,[DrawLine lowerRightLine]), 
+			  (drawGC,[DrawRectangle rect])]], 
+			 [Draw MyWindow invertGC $ FillPolygon Nonconvex 
+				  CoordModeOrigin borderPoints])
+	      proc pressed size =
+		  getK $ \bmsg ->
+		  let same = proc pressed size
+		      (drawit_size, pressit_size) = dRAW size
+		      redraw b = if b == pressed then [] else pressit_size
+		  in  case bmsg of
+			Low (XEvt (Expose _ 0)) -> xcommandsK (drawit_size ++ 
+			    (if pressed then pressit_size else [])) same
+			Low (LEvt (LayoutSize newsize)) -> proc pressed newsize
+			High change -> xcommandsK (redraw change) (proc change size)
+			_ -> same
+	      proc0 pressed =
+		  getK $ \msg ->
+		  case msg of
+		    Low (LEvt (LayoutSize size)) -> proc pressed size
+		    High change -> proc0 change
+		    _ -> proc0 pressed
+	  in  proc0 False
+
+        startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask [ExposureMask]]]
+    in  stripEither >^=< ((groupF startcmds kernel . marginF (edgew + 1)) f)
+
diff --git a/hsrc/fudgets/ButtonF.hs b/hsrc/fudgets/ButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/ButtonF.hs
@@ -0,0 +1,40 @@
+module ButtonF(oldButtonF) where
+import CompOps((>^^=<),(>=^<))
+--import Defaults(argKey, bgColor, fgColor)
+import GraphicsF(graphicsDispF',replaceAllGfx,setGfxEventMask)
+import FDefaults
+import Sizing(Sizing(..))
+import Drawing() -- instance, for hbc
+import Graphic()
+--import GCAttrs
+--import GCtx(wCreateGCtx,rootGCtx)
+import DrawingUtils
+--import FDefaults
+import PushButtonF
+--import Placer(spacerF)
+import Spacers(marginS,compS)
+import Alignment(aCenter)
+import CondLayout(alignFixedS')
+import SpEither(filterRightSP)
+--import Xtypes
+--import NullF()
+--import FudgetIO()
+
+-- All this just because of the !@?! monomorphism restriction
+--import Fudget(F)
+--import GraphicsF(GfxEvent)
+--import MeasuredGraphics(DPath)
+--import DrawingUtils --(Gfx)
+
+oldButtonF halign margin fname bg fg keys lbl =
+    filterRightSP >^^=< pushButtonF keys lblF
+ where
+   --lblF :: Graphic lbl => F lbl (GfxEvent DPath) -- the monorestr
+   lblF = let --lblD :: Graphic lbl => lbl -> Drawing a Gfx -- the monorestr
+	      lblD = spacedD spacer . g
+	      custom x = setInitDisp (lblD lbl) .
+	               setGfxEventMask [] . setSizing Static .
+		       setBorderWidth 0 . setBgColorSpec bg .
+		       setFont fname . setFgColor fg $ x
+              spacer = marginS margin `compS` alignFixedS' halign aCenter
+	  in graphicsDispF' custom >=^< replaceAllGfx . lblD
diff --git a/hsrc/fudgets/ButtonGroupF.hs b/hsrc/fudgets/ButtonGroupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/ButtonGroupF.hs
@@ -0,0 +1,121 @@
+module ButtonGroupF(
+	buttonGroupF, menuButtonGroupF,
+	--buttonMachineF,
+	BMevents(..))
+where
+import Command
+import CompOps((>=^<))
+import Defaults(bgColor)
+import Dlayout(groupF)
+import Event
+import Fudget
+import FRequest
+import Xcommand
+--import Geometry(Line, Point, Rect, Size(..))
+import GreyBgF(changeBg)
+--import LayoutRequest(LayoutRequest)
+import Loops(loopLeftF)
+import Message(message) --Message(..),
+import NullF
+--import SpEither(mapFilterSP)
+import Xtypes
+import Utils
+
+data BMevents = BMNormal | BMInverted | BMClick  deriving (Eq, Ord, Show)
+
+buttonGroupF     = buttonGroupF' cmdButton
+menuButtonGroupF = buttonGroupF' menuButton []
+
+buttonGroupF' bp keys f = loopLeftF (buttonMachineF' bp keys f >=^< Right)
+
+--buttonMachineF = buttonMachineF' cmdButton
+
+buttonMachineF' bp keys = groupF [] (changeBg bgColor (buttonK bp keys))
+
+data ButtonParams =
+  BP { modstate :: ModState,
+       mbutton :: Button,
+       bmachine :: Button -> ModState -> K Bool BMevents }
+
+elbMask = [EnterWindowMask, LeaveWindowMask, ButtonPressMask, ButtonReleaseMask]
+
+cmdButton =
+  BP { modstate = [],
+       mbutton = Button 1,
+       bmachine = buttonMachine }
+
+menuButton =
+  BP { modstate = [],
+       mbutton = Button 1, -- not used
+       bmachine = mbuttonMachine }
+
+buttonMachine mousebutton modstate =
+    setEventMask [] $
+    xcommandK (GrabButton False mousebutton modstate grabbedMask) $
+    bm BMNormal
+  where
+    grabbedMask = elbMask
+    switch newme = putK (High newme) (bm newme)
+    pressed = switch BMInverted
+    normal = switch BMNormal
+    clicked = putsK [High BMNormal, High BMClick] (bm BMNormal)
+    changeMode =
+	-- switch to menu button mode
+	xcommandK (UngrabButton mousebutton modstate) $
+	mbuttonMachine mousebutton modstate
+    bm me =
+      let nochange = bm me
+      in getK $ \msg ->
+	 case msg of
+	   Low (XEvt event) ->
+	     case event of
+	       (EnterNotify {detail=d}) | d /= NotifyInferior -> pressed
+	       (LeaveNotify {detail=d}) | d /= NotifyInferior -> normal
+	       (ButtonEvent {state=s,type'=Pressed,button=b})
+	         | b == mousebutton && modstate `issubset` s -> pressed
+	       (ButtonEvent {type'=Released,button=b})
+	         | b == mousebutton -> if me == BMInverted
+	                               then clicked
+				       else nochange
+	       (MenuPopupMode True) -> changeMode
+	       _ -> nochange
+	   High True -> changeMode
+	   _ -> nochange
+
+mbuttonMachine mousebutton modstate =
+    setEventMask elbMask $
+    loop
+  where
+    loop = getK $ message low high
+    out e = putK (High e) loop
+    normal = out BMNormal
+    pressed = out BMInverted
+    clicked = out BMClick
+
+    low (XEvt ev) = event ev
+    low _ = loop
+    event (ButtonEvent {type'=Released}) = clicked
+    event (EnterNotify {}) = pressed
+    event (LeaveNotify {}) = normal
+    event (MenuPopupMode False) = buttonMachine mousebutton modstate
+    event _ = loop
+
+    high False = buttonMachine mousebutton modstate
+    high _ = loop
+
+buttonK :: ButtonParams -> [(ModState, KeySym)] -> K Bool BMevents
+buttonK (BP {mbutton=mbutton, modstate=modstate, bmachine=bmachine }) keys =
+    xcommandsK initcmds $ bmachine mbutton modstate
+  where
+    initcmds = transinit ++ [MeButtonMachine]
+
+    transinit =
+	if null keys
+	then []
+	else [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]
+
+    tobutton (KeyEvent t p1 p2 s pressed _ ks _) | (s, ks) `elem` keys =
+	Just (ButtonEvent t p1 p2 modstate pressed mbutton)
+    tobutton _ = Nothing
+
+setEventMask mask = xcommandK (ChangeWindowAttributes [CWEventMask mask])
diff --git a/hsrc/fudgets/DButtonF.hs b/hsrc/fudgets/DButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DButtonF.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE CPP #-}
+module DButtonF(
+  ButtonF,buttonF,buttonF',buttonF'',setLabel
+  ) where
+import FDefaults
+import ButtonF(oldButtonF)
+--import Fudget
+--import Geometry(Rect)
+import PushButtonF(Click)
+import Xtypes
+import Defaults(buttonFont,fgColor,bgColor)
+import CmdLineEnv(argKeyList)
+import CompOps((>^=<),(>=^^<))
+--import Spops(concmapSP)
+import SpEither(mapFilterSP)--filterRightSP
+import EitherUtils(stripEither)
+import SerCompF(idRightF)
+import Spacers(Distance(..))
+import Alignment(aCenter) --,Alignment(..)
+import Graphic
+import GCAttrs --(ColorSpec,colorSpec) -- + instances
+
+#include "defaults.h"
+
+newtype ButtonF lbl = Pars [Pars lbl]
+data Pars lbl
+  = FontSpec FontSpec
+  | Keys [(ModState, KeySym)]
+  | FgColorSpec ColorSpec
+  | BgColorSpec ColorSpec
+  | Margin Distance
+  | Align Alignment
+  | Label lbl
+
+parameter_instance1(FontSpec,ButtonF)
+parameter_instance1(Keys,ButtonF)
+parameter_instance1(FgColorSpec,ButtonF)
+parameter_instance1(BgColorSpec,ButtonF)
+parameter_instance1(Margin,ButtonF)
+parameter_instance1(Align,ButtonF)
+parameter(Label)
+
+buttonF s = buttonF' standard s
+buttonF' pm s = noPF $ buttonF'' pm s
+
+buttonF'' ::
+  Graphic lbl => Customiser (ButtonF lbl) -> lbl -> PF (ButtonF lbl) Click Click
+buttonF'' pmod s =
+    stripEither >^=<
+    idRightF (oldButtonF align marg font bg fg keys lbl >=^^< mapFilterSP relbl)
+  where
+    lbl  = getLabel ps
+    font = getFontSpec ps
+    keys = getKeys ps
+    ps   = pmod ps0
+    bg   = getBgColorSpec ps
+    fg   = getFgColorSpec ps
+    marg = getMargin ps
+    align = getAlign ps
+    ps0  = Pars [FontSpec (fontSpec buttonFont), Keys [],Margin 2,Align aCenter,
+		 FgColorSpec buttonfg, BgColorSpec buttonbg, Label s]
+    --relbl pmod' = [lbl | let Pars ps'=pmod' (Pars []), Label lbl<-ps']
+    relbl pmod' = getLabelMaybe (pmod' (Pars []))
+
+buttonbg = colorSpec (argKeyList "buttonbg" [bgColor,"white"])
+buttonfg = colorSpec (argKeyList "buttonfg" [fgColor,"black"])
diff --git a/hsrc/fudgets/DDisplayF.hs b/hsrc/fudgets/DDisplayF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DDisplayF.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE CPP #-}
+module DDisplayF(--HasInitDisp(..),
+		 setSpacer,
+		 DisplayF,
+                 displayF,displayF',--displayF'',
+                 intDispF,intDispF',--intDispF'',
+                 labelF,labelF' --,labelF''
+		) where
+import FDefaults
+import GraphicsF(graphicsDispF',replaceAllGfx,setGfxEventMask)--GfxCommand
+import Graphic
+import Drawing() -- instances
+import DrawingUtils(spacedD,g)--vboxD,blankD,hardAttribD,
+import GCAttrs --(ColorSpec,colorSpec) -- + instances
+--import GCtx(GCtx(..),wCreateGCtx,rootGCtx)
+--import EitherUtils(mapEither)
+--import FudgetIO
+--import Fudget
+import NullF(F)
+--import Xtypes
+import ResourceIds() -- synonym ColorName, for hbc
+import Defaults(defaultFont,labelFont,paperColor,fgColor,bgColor)
+import CmdLineEnv(argKeyList)
+import CompOps((>=^^<),(>=^<),(>^^=<))
+import CompSP(idLeftSP)
+import Spops(nullSP)
+import SpEither(filterRightSP)
+import Alignment(aRight,aLeft,aCenter)
+--import AlignF(noStretchF)
+--import LoadFont(safeLoadQueryFont)
+--import Font(string_box_size)
+import Spacers(marginS,compS,hAlignS)--minSizeS,noStretchS,
+import LayoutRequest(Spacer)
+import Sizing(Sizing(..))
+import CondLayout(alignFixedS')
+--import Maybe(fromMaybe)
+
+#include "defaults.h"
+
+newtype DisplayF a = Pars [Pars a]
+
+data Pars a
+  = BorderWidth Int
+  | FgColorSpec ColorSpec
+  | BgColorSpec ColorSpec
+  | FontSpec FontSpec
+--  | Align Alignment
+  | Spacer Spacer
+  | Margin Int
+  | InitDisp a
+  | InitSize a
+  | Sizing Sizing
+  | Stretchable (Bool,Bool)
+-- Don't forget to adjust instance Functor DisplayF above if you add stuff here!
+
+type StringDisplayF = DisplayF String
+
+parameter_instance1(BorderWidth,DisplayF)
+parameter_instance1(FgColorSpec,DisplayF)
+parameter_instance1(BgColorSpec,DisplayF)
+parameter_instance1(FontSpec,DisplayF)
+--parameter_instance1(Align,DisplayF)
+parameter_instance1(Margin,DisplayF)
+
+parameter_instance(InitDisp,DisplayF)
+parameter(Spacer)
+parameter_instance(InitSize,DisplayF)
+parameter_instance1(Stretchable,DisplayF)
+parameter_instance1(Sizing,DisplayF)
+
+-- For backwards compatibility:
+instance HasAlign (DisplayF a) where
+  setAlign align (Pars ps) = Pars (Spacer (alignFixedS' align aCenter):ps)
+
+labelDisplayF :: Graphic g => F g void -- because of monomorphism restriction
+labelDisplayF = labelDisplayF' standard
+labelDisplayF' pm = noPF $ labelDisplayF'' pm
+
+labelDisplayF''
+  :: Graphic g => Customiser (DisplayF g) -> PF (DisplayF g) g void
+labelDisplayF'' pmod = 
+    nullSP >^^=<
+    graphicsDispF' custom >=^<
+    pre >=^^<
+    filterRightSP
+  where
+    custom =
+     	maybe id (setInitDisp . draw) initDisp .
+	maybe id (setInitSize . draw) initSize .
+	setGfxEventMask [] . setSizing sizing .
+	setBorderWidth borderWidth . setBgColorSpec bgColor .
+	setFont font . setFgColorSpec fgColor .
+	setStretchable stretch
+    pre = replaceAllGfx . draw 
+    draw = marginD . g
+    marginD = spacedD (marginS margin `compS` spacer)
+
+    margin = getMargin ps
+    borderWidth = getBorderWidth ps
+    bgColor = getBgColorSpec ps
+    fgColor = getFgColorSpec ps
+    font = getFontSpec ps
+    spacer = getSpacer ps
+    stretch = getStretchable ps
+    sizing = getSizing ps
+    initSize = getInitSizeMaybe ps
+    initDisp = getInitDispMaybe ps
+    ps = pmod (Pars [Margin 4,BorderWidth 0,
+                     FgColorSpec dispfg, BgColorSpec dispbg,
+		     FontSpec (fontSpec defaultFont),
+		     Spacer (alignFixedS' aLeft aCenter),
+		     Stretchable (False,False),
+		     Sizing Dynamic{-,InitSize "",InitDisp ""-}])
+
+displayF :: Graphic g => F g void -- because of monomorphism restriction
+displayF = displayF' standard
+displayF' custom = noPF $ displayF'' custom
+
+displayF'' :: Graphic g => Customiser (DisplayF g) -> PF (DisplayF g) g void
+displayF'' pmod = labelDisplayF'' pmod'
+  where
+    pmod' = pmod .
+            --setInitSize "XXXXX" .
+	    setBorderWidth 1 .
+	    setStretchable (True,False) .
+	    setSpacer (hAlignS aLeft) .
+	    setSizing Growing
+
+
+labelF lbl = labelF' standard lbl
+labelF' pm = noPF . labelF'' pm
+
+labelF'' :: Graphic g => Customiser (DisplayF g) -> g -> PF (DisplayF g) a b
+labelF'' pmod lbl = labelDisplayF'' pmod' >=^^< idLeftSP nullSP
+  where
+   pmod' = pmod.
+	   setInitDisp lbl.
+           (setFgColor lblfg::(Customiser (DisplayF g))).
+	   setBgColor lblbg.
+	   setFont labelFont.
+	   setMargin 0 .
+	   setSizing Static
+
+-- cu works around a deficiency in the type inference algorithm.
+-- cu x y = id x y :: (Customiser (DisplayF a))
+
+intDispF = intDispF' standard
+intDispF' = noPF . intDispF''
+intDispF'' :: Customiser (DisplayF Int) -> PF (DisplayF Int) Int a
+intDispF'' pm = displayF'' (pm' 0) -- >=^< mapEither id show
+  where pm' x = pm.setAlign aRight
+                  .setInitDisp x
+		  .setInitSize ((-maxBound) `asTypeOf` x)
+--	 	  .forgetInitDisp -- should be built into setInitDisp
+                  .(setSizing Static::(Customiser (DisplayF Int)))
+		  .setStretchable (False,False)
+
+dispbg = colorSpec (argKeyList "dispbg" [paperColor,"white"])
+dispfg = colorSpec (argKeyList "dispfg" [fgColor,"black"])
+
+lblbg = colorSpec (argKeyList "lblbg" [bgColor,"white"])
+lblfg = colorSpec (argKeyList "lblfg" [fgColor,"black"])
+
+{-
+forgetInitDisp :: DisplayF a -> DisplayF b
+forgetInitDisp (Pars ps) = Pars (forget ps)
+  where
+    forget ps =
+      case ps of
+	[] -> []
+	BorderWidth i:ps -> BorderWidth i:forget ps
+	FgColor c:ps -> FgColor c:forget ps
+	BgColor c:ps -> BgColor c:forget ps
+	Font f:ps -> Font f:forget ps
+	Align a:ps -> Align a:forget ps
+	Margin i:ps -> Margin i:forget ps
+	InitDisp x:ps -> forget ps
+	InitSize s:ps -> InitSize s:forget ps
+	Sizing s:ps -> Sizing s:forget ps
+	Stretchable bb:ps -> Stretchable bb:forget ps
+    
+-}
+
+{-
+instance Functor DisplayF where
+  map f (Pars ps) = Pars (map (mapPars f) ps)
+    where
+      mapPars f p =
+	case p of
+	  BorderWidth i -> BorderWidth i
+	  FgColor c -> FgColor c
+	  BgColor c -> BgColor c
+	  Font f -> Font f
+	  Align a -> Align a
+	  Margin i -> Margin i
+	  InitDisp x -> InitDisp (f x)
+	  InitSize s -> InitSize s
+	  Sizing s -> Sizing s
+	  Stretchable bb -> Stretchable bb
+-}
diff --git a/hsrc/fudgets/DRadioF.hs b/hsrc/fudgets/DRadioF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DRadioF.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE CPP #-}
+module DRadioF(
+  RadioGroupF,radioGroupF,radioGroupF',
+  setPlacer
+  ) where
+import FDefaults
+import RadioF(radioF)
+import DToggleButtonF(HasLabelInside(..))
+import NullF(F)
+import LayoutRequest(Placer)
+import Spacers() -- synonym Distance, for hbc
+import Placers2(verticalLeftP')
+--import Xtypes
+import ResourceIds() -- synonym FontName, for hbc
+import Defaults(buttonFont)
+import Graphic
+import GCAttrs --(FontSpec,fontSpec)
+
+#include "defaults.h"
+
+newtype RadioGroupF = Pars [Pars]
+data Pars = LabelInside Bool | FontSpec FontSpec | Placer Placer
+
+parameter(Placer)
+parameter_instance(LabelInside,RadioGroupF)
+parameter_instance(FontSpec,RadioGroupF)
+
+radioGroupF lbl = radioGroupF' standard lbl
+
+radioGroupF' :: (Graphic lbl,Eq alt )=> Customiser RadioGroupF -> [(alt,lbl)] -> alt -> F alt alt
+radioGroupF' pmod alts startalt = 
+    radioF placer inside font alts startalt
+  where
+    placer  = getPlacer ps
+    inside  = getLabelInside ps
+    font    = getFontSpec ps
+    ps      = pmod ps0
+    ps0     = Pars [LabelInside False,FontSpec (fontSpec buttonFont),Placer placer0]
+    placer0 = verticalLeftP' 0
diff --git a/hsrc/fudgets/DStringF.hs b/hsrc/fudgets/DStringF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DStringF.hs
@@ -0,0 +1,44 @@
+module DStringF(
+  stringF,stringF',--stringF'',
+  passwdF,passwdF',passwdF'',
+  intF,intF',intF''
+  ,stringInputF,intInputF,passwdInputF
+  ,stringInputF',intInputF',passwdInputF'
+  ) where
+import FDefaults
+import StringF
+--import Fudget
+import CompOps
+--import Geometry(Rect)
+--import Xtypes
+--import SpEither(filterRightSP)
+import InputMsg(InputMsg,mapInp)
+import InputSP(inputDoneSP)--InF(..),
+import EitherUtils(mapEither)
+import Data.Char(isDigit)
+
+stringInputF = stringInputF' standard
+intInputF = intInputF' standard
+passwdInputF = passwdInputF' standard
+stringInputF' pmod = inputDoneSP >^^=< stringF' pmod
+intInputF' pmod = inputDoneSP >^^=< intF' pmod
+passwdInputF' pmod = inputDoneSP >^^=< passwdF' pmod
+
+stringF = stringF' standard
+stringF' = noPF . stringF''
+
+passwdF = passwdF' standard
+passwdF' = noPF . passwdF''
+passwdF'' = stringF'' . (.setShowString (map (const '*')))
+
+intF = intF' standard
+intF' = noPF . intF''
+
+intF'' :: (Customiser StringF) -> PF StringF Int (InputMsg Int)
+intF'' pmod = mapInp read' >^=<
+              stringF'' (pmod.pm) >=^<
+	      mapEither id show
+  where
+    pm = setAllowedChar isDigit -- . setInitSize "1999999999"
+    read' "" = 0
+    read' s = read s
diff --git a/hsrc/fudgets/DToggleButtonF.hs b/hsrc/fudgets/DToggleButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DToggleButtonF.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+module DToggleButtonF(
+  HasLabelInside(..),ToggleButtonF,
+  toggleButtonF,toggleButtonF' --,toggleButtonF''
+  ) where
+import FDefaults
+import ToggleButtonF(oldToggleButtonF')
+import NullF(F)
+import Xtypes
+import Defaults(buttonFont)
+import Graphic
+import GCAttrs --(FontSpec,fontSpec) -- + instances
+
+#include "defaults.h"
+
+newtype ToggleButtonF = Pars [Pars]
+data Pars = LabelInside Bool | FontSpec FontSpec | Keys [(ModState, KeySym)]
+
+parameter_class(LabelInside,Bool)
+
+parameter_instance(LabelInside,ToggleButtonF)
+parameter_instance(FontSpec,ToggleButtonF)
+parameter_instance(Keys,ToggleButtonF)
+
+toggleButtonF lbl = toggleButtonF' standard lbl
+
+toggleButtonF' :: (Graphic lbl)=> Customiser ToggleButtonF -> lbl -> F Bool Bool
+toggleButtonF' pmod lbl = 
+    oldToggleButtonF' inside font keys lbl
+  where
+    inside = getLabelInside ps
+    font   = getFontSpec ps
+    keys   = getKeys ps
+    ps     = pmod ps0
+    ps0    =  Pars [LabelInside False,FontSpec (fontSpec buttonFont), Keys []]
diff --git a/hsrc/fudgets/DialogF.hs b/hsrc/fudgets/DialogF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/DialogF.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+module DialogF(inputPopupOptF, inputPopupF, passwdPopupOptF,
+               passwdPopupF, stringPopupOptF, stringPopupF,
+	       confirmPopupF, ConfirmMsg(..),
+	       oldConfirmPopupF, oldMessagePopupF,
+               messagePopupF) where
+import Spacer(marginHVAlignF,marginF)
+import Alignment
+import PushButtonF(Click(..))
+import DButtonF
+import FDefaults
+import CompOps
+import CompSP(preMapSP)
+import Defaults(labelFont,bgColor,defaultSep)--buttonFont,fgColor,
+import CmdLineEnv(argFlag)
+import DDisplayF
+import PopupF(popupShellF)
+import Fudget
+import Geometry(pP)
+import Spops
+import SpEither(filterJustSP,filterRightSP)
+import StringF
+import InputF(InF(..))
+import InputMsg(ConfirmMsg(..),toConfirm,fromConfirm,InputMsg(..),inputLeaveKey)
+--import EitherUtils(isM)
+import Data.Maybe(isJust,maybeToList)
+--import TextF(textF')
+--import ListRequest(replaceAll)
+--import NullF(startupF)
+import Placer(vBoxF,hBoxF)
+import AutoPlacer(autoP')
+import Sizing
+import Xtypes() -- synonyms, for hbc
+import Graphic -- instances (+ class Graphic, because of the monomorphism restr)
+import Drawing
+import GCAttrs() -- instances
+
+default(Int)
+
+oldMessagePopupF = popupShellF "Message" Nothing (labelabove 50 ok >=^< Left)
+oldConfirmPopupF = popupShellF "Confirm" Nothing (labelabove 50 confirm >=^< Left)
+
+-- Grr! Type signatures required because of the mononorphism restriction
+confirmPopupF :: Graphic msg => F msg (msg,ConfirmMsg)
+messagePopupF :: Graphic msg => F msg (msg,Click)
+confirmPopupF = msgPopupF confirm
+messagePopupF = msgPopupF ok
+
+msgPopupF buttons =
+    popupShellF "Confirm" Nothing
+      (filterRightSP>^^=< vBoxF (msgF>+<buttons)>=^<Left . layoutfix)
+  where
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+    msgF :: Graphic a => F (Drawing lbl a) b
+#endif
+    msgF = marginHVAlignF 5 aCenter aCenter $ displayF' pm
+     where pm = setBgColor [bgColor,"white"] . setSizing Dynamic .
+		setFont labelFont . setBorderWidth 0
+    layoutfix = PlacedD (autoP' (pP defaultSep 0)) . AtomicD
+
+genStringPopupOptF title inp default' =
+    inputPopupOptF title (inp default') (Just default')
+
+genStringPopupF title inp default' =
+    filterMaybePairF (genStringPopupOptF title inp default')
+
+stringPopupOptF = genStringPopupOptF "String Entry" oldStringF
+stringPopupF default' = filterMaybePairF (stringPopupOptF default')
+
+passwdPopupOptF = genStringPopupOptF "Password Entry" oldPasswdF
+passwdPopupF default' = filterMaybePairF (passwdPopupOptF default')
+
+inputPopupOptF :: String -> InF a b -> Maybe b -> F (Maybe String, Maybe a) ((Maybe String, Maybe a), Maybe b)
+inputPopupOptF title f default' =
+    let stringconfirm =
+            (filterDoneSP default' >^^=< vBoxF (f >+< confirm')) >=^< Left
+    in  popupShellF title
+		   Nothing
+		   (marginF 5 ((labelabove 50 stringconfirm >=^^< distPairSP)))
+
+inputPopupF title f def = filterMaybePairF (inputPopupOptF title f def)
+
+button k s = buttonF' (setKeys [([],k)]) s
+
+button' k s =
+  if argFlag "okkey" False
+  then button k s
+  else buttonF s
+       -- This is a fix for the problem that when you press return in a
+       -- stringPopupF, the next time the popup appears the string in it
+       -- isn't selected.
+
+#ifdef __HUGS__
+label :: F String a -- for Hugs
+#endif
+label = displayF' pm
+  where pm = setBorderWidth 0 . setBgColor [bgColor,"white"].setFont labelFont
+
+ok = marginHVAlignF 0 aLeft aBottom (button "Return" "OK")
+ok' = marginHVAlignF 0 aLeft aBottom (button' "Return" "OK")
+cancel = marginHVAlignF 0 aRight aBottom (button "Escape" "Cancel")
+
+confirm = toConfirm >^=< hBoxF (ok >+< cancel) >=^< fromConfirm
+confirm' = toConfirm >^=< hBoxF (ok' >+< cancel) >=^< fromConfirm
+
+labelabove len f = filterRightSP >^^=< vBoxF (label >+< f)
+
+filterMaybePairF :: (F a (b, Maybe c)) -> F a (b, c)
+filterMaybePairF f = preMapSP filterJustSP liftOpt >^^=< f
+
+liftOpt (x, Nothing) = Nothing
+liftOpt (x, Just y) = Just (x, y)
+
+distPairSP = concmapSP (\(x, y) -> otol Left x ++ otol Right y)
+  where otol f = maybeToList . fmap f
+
+filterDoneSP =
+    let fd s =
+            getSP $ \msg ->
+            let same = fd s
+            in case msg of
+	         Right Confirm -> if isJust s then putSP s same else same
+		 Right Cancel -> putSP Nothing same
+		 Left (InputChange s') -> fd (Just s')
+		 Left (InputDone k s') | k /= inputLeaveKey -> putSP (Just s') $
+                                                              fd (Just s')
+                 Left _ -> same
+    in  fd
+
+#ifdef __NHC__
+-- nhc bug workaround
+blaha=undefined::DisplayF
+#endif
diff --git a/hsrc/fudgets/Edit.hs b/hsrc/fudgets/Edit.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/Edit.hs
@@ -0,0 +1,362 @@
+{-# LANGUAGE CPP #-}
+module Edit(EditStop(..),editF, EditEvt(..), EditCmd(..)) where
+import BgF
+import Color
+import Command
+import DrawInWindow
+import XDraw(clearArea)
+import Defaults(inputFg, inputBg)
+import CmdLineEnv(argReadKey, argKey)
+import Dlayout(windowF)
+import Edtypes
+import Editfield
+import Event
+import Font
+import Fudget
+import FRequest
+import Gc
+import Geometry
+import LayoutRequest(plainLayout,LayoutResponse(..))
+import Message(message) --Message(..),
+import NullF
+import StateMonads
+import Control.Monad(when)
+import HbcUtils(apSnd)
+import Xtypes
+import UndoStack
+import TryLayout
+import Expose
+import Maptrace
+import GCAttrs(convFontK,fontdata2struct,FontSpec) -- instances
+import InputMsg(InputMsg(InputChange))
+
+default (Int) -- mostly for Hugs
+
+data EditStop = 
+     EditStopFn EditStopFn 
+   | EditPoint Point 
+   | EditLine EDirection
+
+data EditCmd = 
+     EditShowCursor Bool
+   | EditMove EditStop IsSelect
+   | EditReplace String
+   | EditGetText
+   | EditGetField
+   | EditGetSelection
+   | EditUndo
+   | EditRedo 
+     
+data EditEvt
+    = EditText String
+    | EditField (String,String,String)
+    | EditCursor Rect
+    | EditChange (InputMsg String)
+    deriving (Eq, Ord)
+
+godir wanted current = if wanted < current then ELeft else ERight
+
+toedstop :: (a ->String->String->(a,Maybe EDirection)) -> a -> EditStopFn
+toedstop sf st b a = case sf st b a of
+		      (_,Nothing) -> EdStop
+		      (st',Just dir) -> EdGo dir (toedstop sf st')
+
+notnull = not . null
+
+inputbg = argKey "editbg" inputBg
+inputfg = argKey "editfg" inputFg
+
+selectbg = argKey "selectbg" inputfg
+selectfg = argKey "selectfg" inputbg
+
+editF :: FontSpec -> F EditCmd EditEvt
+editF fontspec =
+  let eventmask = [ExposureMask]
+      startcmds = [XCmd $ ChangeWindowAttributes [CWBitGravity NorthWestGravity,
+						  CWEventMask eventmask]]
+  in  windowF startcmds (editK fontspec)
+
+splitwith c [] = (([], False), [])
+splitwith c (a : b) =
+    if a == c
+    then (([], True), b)
+    else let ((x, g), y) = splitwith c b
+	 in  ((a : x, g), y)
+
+splitwithnl = splitwith newline
+tabstop = 8
+untab t s =
+    case s of
+      '\t':s -> let t' = (t `div` tabstop + 1) * tabstop
+		in spaces (t'-t) ++ untab t' s
+      c:s -> c:untab (if c == newline then 0 else (t+1)) s
+      [] -> []
+
+spaces n = replicate n ' '
+
+editK fontspec = 
+  convFontK fontspec $ \ fd ->
+  fontdata2struct fd $ \ font ->
+  changeGetBackPixel inputbg $ \bg -> 
+  allocNamedColorPixel defaultColormap inputfg $ \fg -> 
+  allocNamedColorPixel defaultColormap selectbg $ \sbg -> 
+  allocNamedColorPixel defaultColormap selectfg $ \sfg -> 
+  let fid = font_id font
+      creategcs fg bg cont =
+	wCreateGC rootGC [GCFunction GXcopy, GCFont fid,
+			 GCForeground fg, GCBackground bg] $ \gc ->
+	wCreateGC gc [GCForeground bg, GCBackground fg] $ \igc -> cont (gc,igc)
+  in creategcs fg bg $ \drawGCs ->
+     creategcs sfg sbg $ \selectGCs ->
+     wCreateGC rootGC (invertColorGCattrs bg fg) $ \invertGC -> 
+  let drawimagestring =
+	if snd (font_range font) > '\xff'
+	then wDrawImageString16
+	else wDrawImageString
+      getCurp = apSnd (eolx.fst) . getLnoEdge
+      getLCurp = getCurp . setFieldDir ELeft
+      getRCurp = getCurp . setFieldDir ERight
+      npos = next_pos font
+      eolx = npos . reverse . fst . splitnl
+      maxrmargin x s =
+	if null s
+	then x
+	else let (l,r) = splitnl s
+	     in ctrace "editF1" (s,l,r,npos l) $ (x + npos l) `max` maxrmargin 0 r
+      lno = fst
+      xp = snd
+      p2line (Point x y) = (y `quot` lheight, x - xoffset)
+      line2p (l, x) = Point (x + xoffset) (l * lheight)
+      lheight = linespace font
+      move issel estop =
+	do field <- loadField
+	   lastpos <- loadLastpos
+	   invIfShowCursor
+	   let curp = getCurp field
+	       stoppoint wantp p@(l, x) bef aft = 
+		 let dircomp = godir wantp
+		     dist p' = abs (lno wantp - lno p') + abs (xp wantp - xp p')
+		     dir = dircomp p
+		     ahead = if dir == ELeft then bef else aft
+		 in case ahead of
+		      [] -> (p, Nothing)
+		      c:cs -> let p' = if c == newline
+				       then (dirint dir + l, if dir == ERight
+							     then 0
+							     else eolx cs)
+				       else (l, x + dirint dir * npos [c])
+			      in  (p', if dir == dircomp p'
+				       then Just dir
+				       else if dist p' < dist p
+					    then Just dir
+					    else Nothing)
+	       mf sf = moveField issel field sf
+	       (field', acc) =
+		 case estop of
+		   EditStopFn stopf -> mf stopf
+		   EditPoint p -> let lp = p2line p
+				      dir = godir lp curp
+				  in  mf (toedstop (stoppoint lp) curp)
+		   EditLine dir -> let wantp = (dirint dir + lno curp, xp lastpos)
+				   in  mf (toedstop (stoppoint wantp) curp)
+	   storeField field'
+	   let ol = lno curp
+	       nl = lno $ getCurp field'
+	   if issel
+	      then showlines (min ol nl) (max ol nl)
+	      else if notnull (getSelection field)
+		   then showSelLines field >> showlines nl nl
+		   else invIfShowCursor
+      showSelLines field = 
+	     showlines (lno $ getLCurp field) (lno $ getRCurp field) 
+      setSize (l,x) =
+	  do old@(ol,ox) <- loadTextWidth
+	     let new@(_,x') = (l,max x minWidth)
+	     when (old /= new) $
+	       do storeTextWidth new
+		  mtrace ("before trylayout "++show(x,x',ox))
+		  x <- toMs $ tryLayoutK $
+			 plainLayout (line2p (l,x') `padd` llmargin) True True
+		  mtrace "after trylayout"
+		  storeSize x
+	    where mtrace x = toMsc (ctrace "editF" x)
+      replace' s =
+	  do field <- loadField
+	     size <- loadSize
+	     width <- loadWidth
+	     let (ll,lx) = getLCurp field
+		 uts = untab (length $ fst $ splitnl $ getBef field) s
+		 rl = lno $ getRCurp field
+		 field' = replaceField field uts
+		 nls = nlines uts
+		 nldown = nls - (rl - ll)
+		 copy src dest h =
+		   let srcp = line2p src
+		       r = Rect srcp (pP width h)
+		   in when (h>0) $
+			putLowMs (wCopyArea (fst drawGCs) MyWindow
+					    r (line2p dest))
+	     (nlines,tw) <- loadTextWidth
+	     let changemarg new f = maxrmargin lx (new ++ fst (splitnl (getAft f)))
+		 oldm = changemarg (getSelection field) field
+		 newm = changemarg uts field'
+		 tw' = if newm >= tw
+		       then newm
+		       else if oldm < tw
+			    then tw
+			    else maxrmargin 0 (getField field')
+		 ss = (getLastLineNo field' + 1, tw')
+	     setSize ss
+	     storeField' field'
+	     us <- loadUndoStack
+	     us' <- doit us (field',ss) return
+	     storeUndoStack us'
+	     when (nldown /= 0) $
+		let tleft a = (rl + a + 1, 0)
+		    tnl = tleft nldown
+		in  copy (tleft 0) tnl (ycoord size - lheight * lno tnl)
+	     showlines ll (ll + nls)
+      dolines first last doline = du
+	 where du s p@(l,x) = let ((line,nl), rest) = splitwithnl s
+			      in if l > last || null s then return p
+			      else when (l >= first) (doline p (line,nl)) >> 
+				   du rest (if nl then (l+1,0) else (l,x+npos line))
+      showLine (gc,rgc) lp (line, withnl) = 
+	do let p = line2p lp
+	       d = pP 0 (font_ascent font)
+	   when (xp lp == 0) $
+	     putLowMs (clearArea (rR 0 (ycoord p) xoffset lheight) False)
+	   when (notnull line) $
+	     putLowMs (drawimagestring gc (p+d) line)
+	   when withnl $
+	     do width <- loadWidth
+		let pc = padd p (pP (npos line) 0)
+		    size = Point (width - xcoord pc) lheight
+		putLowMs (wFillRectangle rgc (Rect pc size))
+      showlines first last =
+	  do field <- loadField
+	     showc <- loadShowCursor
+	     let clno = lno $ getLCurp field
+		 sel = getSelection field
+		 aft = getAft field
+		 takenl n s = let (l,r) = splitnl s
+			      in if n <= 0 then l else l++newline:takenl (n-1) r
+		 bef = reverse $ takenl (clno-first) $ getBef field
+		 show gcs = dolines first last (showLine gcs)
+	     show drawGCs bef (clno-nlines bef,0) >>=
+		show (if showc then selectGCs else drawGCs) sel >>=
+		show drawGCs (aft++[newline]) >>= \_ ->
+		when (clno >= first && clno <= last) invIfShowCursor
+      showCursor v = do cv <- loadShowCursor
+			when (v /= cv ) $
+			  do field <- loadField
+			     storeShowCursor v
+			     if null (getSelection field) then
+			       invCursor
+			       else showSelLines field
+      invIfShowCursor = do cv <- loadShowCursor
+			   when cv invCursor
+      invCursor = do field <- loadField
+		     let lp = getCurp field
+			 sel = getSelection field
+		     when (null sel) $
+		       let p = line2p (apSnd ((-1) +) lp)
+			   s = pP 1 lheight
+			   cur = Rect p s
+		       in  putLowMs (wFillRectangle invertGC cur)
+      redraw = do --field <- loadField
+		  size <- loadSize
+		  putLowMs (clearArea (Rect origin size) True)
+      expose r = let Line l1 l2 = rect2line r
+		 in showlines (lno (p2line l1)) (lno (p2line l2) + 1)
+      undoredo d =
+	do us <- loadUndoStack
+	   case d us of
+	     Nothing -> nopMs
+	     Just ((field,size),us') -> do storeUndoStack us'
+					   storeField' field
+					   setSize size
+					   redraw
+
+      storeField' field' =
+	do storeField field'
+	   putHighMs (EditChange $ InputChange $ getField field')
+
+      puttext' f = do field <- loadField
+		      putHighMs (f field)
+
+      puttext f = puttext' (EditText . f)
+
+      putCursor =
+        do field <- loadField
+	   let lastpos = getCurp field
+	   putHighMs (EditCursor $ Rect (line2p lastpos `psub` Point xoffset 0) 
+					(Point xoffset lheight `padd` llmargin))
+
+      handleLow msg =
+	case msg of
+	  XEvt (Expose r aft) -> toMs (maxExposeK False r aft) >>= expose
+	  XEvt (GraphicsExpose r aft _ _) -> toMs (maxExposeK True r aft) >>= expose
+	  LEvt (LayoutSize s) -> storeSize s
+          _ -> nopMs
+
+      handleHigh cmd =
+	do case cmd of
+	     EditShowCursor s -> showCursor s
+	     EditMove estop issel -> move issel estop
+	     EditReplace s -> replace' s
+	     EditGetText -> puttext getField
+	     EditGetField -> puttext' (EditField . getField')
+	     EditGetSelection -> puttext getSelection
+	     EditUndo -> undoredo undo
+	     EditRedo -> undoredo redo
+	   putCursor
+	   field <- loadField
+	   let lastpos = getCurp field
+	   case cmd of
+	     EditMove (EditLine _) _ -> nopMs
+	     _ -> storeLastpos lastpos
+
+      proc = do message handleLow handleHigh =<< getKs
+		proc
+
+
+  in  stateK initstate (setSize (1,0) >> proc) nullK
+
+minWidth = 10
+xoffset = 2
+llmargin = Point 2 2
+
+defaultuslimit = Nothing
+uslimit = let ul = argReadKey "undodepth" (-1)
+	  in if ul == -1 then defaultuslimit else Just ul
+
+data EditState a = S { shocur :: Bool,
+		       twidth :: (Int,Int),
+		       undostack :: UndoStack a,
+		       field :: EditField,
+		       size :: Point,
+		       lastpos :: (Int,Int)
+		       }
+
+--initstate = (False,(1,0),undoStack uslimit, createField "", origin, (0, 0))
+initstate = S False (1,0) (undoStack uslimit) (createField "") origin (0, 0)
+
+loadShowCursor = fieldMs shocur
+loadTextWidth = fieldMs  twidth
+loadUndoStack = fieldMs  undostack
+loadField = fieldMs field
+loadSize = fieldMs size
+loadLastpos = fieldMs lastpos
+--loadWidth = loadSize >>= \size -> return (xcoord size)
+loadWidth = fmap xcoord loadSize
+
+
+#define MODMS(lbl) ( \ lbl -> (modMs ( \ s -> s { lbl=lbl } )))
+
+storeShowCursor = MODMS(shocur)
+storeTextWidth  = MODMS(twidth)
+storeUndoStack  = MODMS(undostack)
+storeField      = MODMS(field)
+storeSize       = MODMS(size)
+storeLastpos    = MODMS(lastpos)
diff --git a/hsrc/fudgets/Editor.hs b/hsrc/fudgets/Editor.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/Editor.hs
@@ -0,0 +1,214 @@
+module Editor(oldEditorF,selectall,loadEditor,setEditorCursorPos) where
+import Command
+import CompOps((>+<))
+import Cont(cmdContK')
+import Cursor
+import Defaults(menuFont,bgColor,metaKey)--defaultFont
+import CmdLineEnv(argReadKey)
+import QueryPointer
+import TimerF
+import Dlayout(groupF)
+import Edtypes
+import Edit--(EditStopT(..), EditCmd(..), EditEvt(..), IsSelect(..), editF)
+import Event
+--import Font(FontStruct)
+import Fudget
+import FRequest
+import Geometry() -- instances, for hbc
+import LayoutRequest
+import Loops(loopCompThroughRightF)
+--import Message(Message(..))
+import NullF
+--import Path(Path(..))
+import PopupMenuF
+--import SP
+import SelectionF
+--import Utils(mapList)--loop,
+import Xtypes
+import Data.Char(isAlpha,toLower,isPrint)
+--import Graphic
+import InputMsg(InputMsg(..))
+
+default(Int) -- mostly for Hugs
+
+ems = EditMove . EditStopFn
+stopafter n dir = ems (sa n) 
+	  where sa n b a = if (n::Int) <= 0 then EdStop else EdGo dir (sa (n-1))
+stop1 = stopafter 1
+
+ifhd p l = not (null l) && p (head l)
+aheadl dir b a = if dir == ELeft then b else a
+ifdirhd p dir b a = ifhd p (aheadl dir b a)
+stopwhen p dir = ems sw
+   where sw b a = if ifdirhd p dir b a then EdStop
+	          else EdGo dir sw
+stopat c = stopwhen (==c)
+stopnl = stopat newline
+
+stopborder p dir = ems sw
+  where sw b a = if ifdirhd (not . p) dir b a &&
+		    ifdirhd p dir a b then EdStop
+		 else EdGo dir sw
+
+stopword = stopborder isAlpha
+
+neverstop = stopwhen (const False)
+
+-- replaceAll is used for TextRequests
+loadEditor s = selectall++[EditReplace s]
+selectall = [neverstop ELeft False,
+	     neverstop ERight True]
+
+setEditorCursorPos (row,col) =
+   EditMove (EditPoint 0) False :
+   concat (replicate (row-1) (down `funmap` False)) ++
+   [stopafter (col-1) ERight False]
+
+horiz dir meta = stop1 dir : if meta then [stopword dir] else []
+left = horiz ELeft
+right = horiz ERight
+up = [EditMove (EditLine ELeft)]
+down = [EditMove (EditLine ERight)]
+
+undo = [const EditUndo]
+redo = [const EditRedo]
+
+cursorbindings meta = 
+    [("left", left meta), 
+     ("right",right meta),
+     ("up",up),
+     ("down",down),
+     ("b",left meta),
+     ("f",right meta)] 
+
+ctrls  = [("e",[stopnl ERight]),
+         ("a",[stopnl ELeft]),
+	 ("p",up),
+	 ("n",down),
+	 ("b",left False),
+	 ("f",right False),
+	 ("slash",undo),
+	 ("question",redo)]
+
+selectleft meta = funmap (left meta) True
+fl `funmap` x = [f x | f <- fl]
+hasMeta mods = metaKey `elem` mods
+hasControl mods = Control `elem` mods
+cursorkey mods key = flip lookup (if hasControl mods then ctrls 
+			     else cursorbindings (hasMeta mods))
+			    (map toLower key) 
+		     >>= \l-> Just (funmap l (Shift `elem` mods))
+
+isEnterKey key = key == "Return" || key == "KP_Enter"
+printorenter mods key ascii =
+    if hasMeta mods then Nothing
+    else if isEnterKey key then
+        Just [newline]
+    else if key == "Tab" then Just ['\t']
+    else if not (hasControl mods) then
+        case ascii of
+          c : _ | isPrint c -> Just [c]
+          _ -> Nothing
+   else Nothing
+toEdF = High . Left . Right . Right
+
+toSelF = High . Left . Right . Left . Left
+toTimerF = High . Left . Right . Left . Right
+
+toOut = High . Right
+
+getEdSel = getEd EditGetSelection
+getEdText = getEd EditGetText
+
+getEd ecmd =
+    cmdContK' (toEdF ecmd)
+              (\e ->
+               case e of
+                 High (Left (Right (Right (EditText t)))) -> Just t
+                 _ -> Nothing)
+
+getSel =
+    cmdContK' (toSelF PasteSel)
+              (\e ->
+               case e of
+                 High (Left (Right (Left (Left (SelNotify t))))) -> Just t
+                 _ -> Nothing)
+
+replace' s = putK (toEdF $EditReplace s)
+clearSel = replace' ""
+copySel k = getEdSel $ (\s -> putK (toSelF (Sel s)) k)
+click issel p = putK (toEdF $ EditMove (EditPoint p) issel)
+starttimer = putK (toTimerF $ Just (scrolldel,scrolldel))
+stoptimer = putK (toTimerF $ Nothing)
+scrolldel = argReadKey "scrolldel" 200
+
+oldEditorF font = loopCompThroughRightF g where
+   g = groupF (map XCmd [ChangeWindowAttributes 
+	       [CWEventMask [KeyPressMask,EnterWindowMask,LeaveWindowMask]],
+	       ConfigureWindow [CWBorderWidth 1],
+	       GrabButton True (Button 1) [Any] 
+	          [ButtonPressMask,PointerMotionMask,ButtonReleaseMask]])
+	      (setFontCursor 152 $ editorK False False)
+	      (menu ((selectionF >+< timerF) >+< editF font))
+   editorK bpressed focus = same where
+     same = 
+      getK $ \msg ->
+        case msg of
+         Low (XEvt event) ->
+	   case event of
+	     KeyEvent _ _ _ mods Pressed _ key ascii -> 
+		if hasMeta mods && isEnterKey key
+		then putInputDoneMsg key
+		else
+		case printorenter mods key ascii of
+		   Just s -> replace' s same
+		   Nothing -> case cursorkey mods key of
+		      Just eds -> putsK (map toEdF eds) same
+		      Nothing -> 
+			 if key `elem` ["Delete","BackSpace"] 
+			 then getEdSel $ \s -> 
+			      (if null s 
+			       then putsK (map toEdF 
+					      (selectleft (hasMeta mods)))
+			       else id) $ clearSel same
+			 else same
+	     MotionNotify {pos=p,state=mods} -> click True p same
+	     ButtonEvent {pos=p,state=mods,type'=Pressed,button=Button 1} ->
+		starttimer $
+		click (Shift `elem` mods) p $ showCursor True focus
+	     ButtonEvent {type'=Released,button=Button 1} -> 
+		stoptimer $ showCursor False focus
+	     FocusIn {mode=NotifyNormal} -> showCursor bpressed True
+	     FocusOut {mode=NotifyNormal} -> showCursor bpressed False
+	     _ -> same
+	 High (Left (Right (Left (Right Tick)))) ->
+	   queryPointerK $ \(_,_,p,_) -> click True p same
+	 High (Left (Left mencmd)) -> case mencmd of
+				      MenCut -> copySel $ clearSel same
+				      MenCopy -> copySel same
+				      MenPaste -> getSel $ \s ->
+						  replace' s same
+	 High (Left (Right (Right ecmd))) -> 
+	    (case ecmd of
+		  EditCursor r -> putK (Low $ LCmd $
+					layoutMakeVisible r)
+		  _ -> id) $
+	    putK (toOut ecmd) same
+	 High (Right ocmd) -> putK (toEdF ocmd) same
+	 _ -> same
+     showCursor b f = putK (toEdF (EditShowCursor (b || f))) $ 
+		    editorK b f
+     putInputDoneMsg key =
+       getEdText $ \ s ->
+       putK (toOut $ EditChange (InputDone key s)) $
+       putsK (map toEdF selectall) $
+       same
+
+data MenEvt = MenCut | MenCopy | MenPaste  deriving (Eq, Ord)
+
+menu = oldPopupMenuF bgColor True menuFont (Button 3) [] [] 
+     [(MenCut, []), (MenCopy, []), (MenPaste, [])]
+               (\x -> case x of
+                  MenCut -> "Cut"
+                  MenCopy -> "Copy"
+                  MenPaste -> "Paste")
diff --git a/hsrc/fudgets/Edtypes.hs b/hsrc/fudgets/Edtypes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/Edtypes.hs
@@ -0,0 +1,12 @@
+module Edtypes where
+
+data EDirection = ELeft | ERight deriving (Eq, Ord)
+
+
+newline = '\n'
+
+type EditStopFn = String -> String -> EditStopChoice
+data EditStopChoice = EdGo EDirection EditStopFn | EdStop
+type IsSelect = Bool
+
+
diff --git a/hsrc/fudgets/FilePickF.hs b/hsrc/fudgets/FilePickF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/FilePickF.hs
@@ -0,0 +1,64 @@
+module FilePickF(oldFilePickF,smallPickListF) where
+import List2(sort)
+import MoreF(pickListF)--,PickListRequest(..)
+import ListRequest(replaceAll)
+import CompOps
+--import Defaults(menuFont)
+import FilePaths
+import IoF(ioF)
+import HaskellIO(hIOerr)
+import Fudget
+import NullF(startupF,getK,putK)--F,K,
+--import FudgetIO
+import ReadFileF(readDirF)
+--import Geometry(Point(..))
+import LayoutDir(Orientation(..))
+import LayoutOps
+--import Spacer(layoutModifierF)
+import Loops(loopLeftF)
+import SerCompF(bypassF)
+import InputMsg(stripInputMsg)--InputMsg(..),
+import InputSP(inputLeaveDoneSP)--,inputDoneSP
+import InputF(inputThroughF)--,InF(..)
+import DStringF(stringF)
+import EitherUtils(stripEither)
+--import Message(Message(..))
+import DialogueIO hiding (IOError)
+
+dirF = aFilePath >^=< bypassF (inputLeaveDoneSP >^^=< stringF) -- startpath ?!!!
+
+shownameF = inputThroughF stringF
+
+startpath = "."
+
+lsF = paths>^=<readDirF>=^<filePath
+  where
+    paths (dir,resp) =
+        case resp of
+          Right files -> (map (extendPath sdir) . sort . filter (/=".")) files
+	  --Left err   -> [show err, filePath sdir]
+	  Left err   -> [aFilePath "Error", sdir]
+      where sdir = aFilePath dir
+
+smallPickListF f = {-layoutModifierF lf-} (snd.stripInputMsg>^=<pickListF f>=^<replaceAll)
+--  where lf (Layout _ fh fv) = Layout (Point 240 120) fh fv
+
+oldFilePickF =
+    let showdirF =
+            startupF [aFilePath startpath]
+                     ((compactPath >^=< filePickListF) >==< lsF)
+	filePickListF = smallPickListF pathTail
+        routeK =
+	    getK $ \ msg ->
+	    case msg of
+	      High p ->
+	        let s = filePath p
+		    cont r = putK (High (r s)) routeK
+		    fileCont = cont Right
+		    dirCont = cont Left
+		    checkCont (Str ('d':_)) = dirCont
+		    checkCont _ = fileCont
+		in hIOerr (StatusFile s) (const fileCont) checkCont
+        f1 >=#=< f2 = (f1,Below) >#==< f2
+    in  shownameF >=#=<
+        loopLeftF (((ioF routeK >==< showdirF) >=#=< dirF) >=^< stripEither)
diff --git a/hsrc/fudgets/GcWarningF.hs b/hsrc/fudgets/GcWarningF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/GcWarningF.hs
@@ -0,0 +1,43 @@
+-- If you get a type error when compiling this with HBC, try removing -O.
+module GcWarningF where
+import Dlayout(windowF)
+import Command(XCommand(ClearWindow,ChangeWindowAttributes,SetGCWarningHack))
+import DrawInPixmap
+import LayoutRequest
+import Geometry(Rect(..))
+import Xtypes
+import FudgetIO
+import FRequest(layoutRequestCmd)
+import Xcommand
+import NullF(nullK)
+--import ResourceIds
+import Pixmap(createPixmap)
+import GCtx(GCtx(..),pmCreateGCtx,rootGCtx)
+--import GCAttrs
+import Defaults(bgColor)
+
+-- Garbage Collection Warning Fudget
+
+gcWarningF = windowF startcmds warnK
+  where
+    startcmds = [layoutRequestCmd (plainLayout size True True)]
+
+    warnK =
+	createPixmap size copyFromParent $ \ gcon ->
+	createPixmap size copyFromParent $ \ gcoff ->
+	fg gcon [bgColor,"white"] $ \ (GC bg _) ->
+	fg gcon ["red","black"] $ \ (GC red _) ->
+	putLow (pmFillRectangle gcon bg r) $
+	putLow (pmFillRectangle gcoff bg r) $
+	putLow (pmFillArc gcon red r 0 (360*64)) $
+	xcommandK (SetGCWarningHack gcon gcoff) $
+	xcommandK (ChangeWindowAttributes [CWBackPixmap gcoff]) $
+	xcommandK ClearWindow $
+	nullK
+      where
+	r = Rect 0 size
+	fg pm colspec =
+	  pmCreateGCtx pm rootGCtx
+	    ([GCForeground colspec]::[GCAttributes [String] String])
+
+    size = 10
diff --git a/hsrc/fudgets/GraphicsF.hs b/hsrc/fudgets/GraphicsF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/GraphicsF.hs
@@ -0,0 +1,576 @@
+{-# LANGUAGE CPP #-}
+module GraphicsF(GraphicsF,setCursorSolid,setGfxEventMask,
+                 setAdjustSize,setCursor,setDoubleBuffer,
+                 graphicsF,graphicsF',
+		 graphicsGroupF,graphicsGroupF',
+		 graphicsDispGroupF,graphicsDispGroupF',
+		 graphicsLabelF,graphicsLabelF',
+		 graphicsDispF,graphicsDispF',
+		 GfxEventMask(..),GfxChange(..),GfxCommand(..),GfxEvent(..),
+                 GfxFCmd,GfxFEvent,
+		 replaceGfx,replaceAllGfx,showGfx,highlightGfx) where
+import Fudget
+import FudgetIO
+import Xcommand
+import FRequest
+import NullF(putK,putsK,getK,nullF)
+import Spops(nullSP)
+import CompSP(postMapSP)
+import SpEither(filterLeftSP)--mapFilterSP
+--import SerCompF(stubF)
+import Command
+import DrawInPixmap(pmFillRectangle,pmDrawPoint)
+--import DrawInWindow(wCopyArea)
+import Event
+import Xtypes
+import Geometry
+import Gc
+import Pixmap
+import Cursor
+--import Color
+--import Font(font_id,string_box_size)
+--import LoadFont(safeLoadQueryFont)
+import BgF(changeGetBackPixel)
+import Defaults(fgColor,bgColor,paperColor,labelFont)
+import CmdLineEnv(argFlag,argKeyList,argReadKey)
+import LayoutRequest
+import Alignment
+import Spacers(noStretchS,compS,minSizeS)
+import Message
+import CompOps
+import CompSP(idRightSP)
+import Dlayout(groupF)
+import Utils(number,pairwith)
+import HbcUtils(mapFst,mapSnd)
+--import InputMsg
+import Graphic
+import CompiledGraphics
+import MeasuredGraphics(MeasuredGraphics(SpacedM,MarkM),compileMG,DPath(..))--,emptyMG,emptyMG'
+import Graphic2Pixmap
+import GCtx(GCtx(..),wCreateGCtx,rootGCtx)
+import GCAttrs
+import MGOps(parentGctx,replaceMGPart,updateMGPart,groupMGParts,ungroupMGParts)
+import IdempotSP
+import DrawCompiledGraphics
+import Rects(intersectRects,overlaps)
+import EitherUtils(stripEither)--,mapEither
+import Sizing(newSize,Sizing(..))
+--import HO(apSnd)
+--import Maybe(fromMaybe)
+import Xrequest(xrequestK)
+import StdIoUtil(echoStderrK)
+--import ContinuationIO(stderr)
+--import Maptrace(ctrace) -- debugging
+
+import FDefaults
+#include "defaults.h"
+#include "exists.h"
+--  Commands for grapihcsF: ---------------------------------------------------
+
+data GfxChange gfx
+  = GfxReplace (Bool,Maybe gfx)
+  | GfxGroup Int Int -- position & length
+  | GfxUngroup Int -- position
+  
+data GfxCommand path gfx
+  = ChangeGfx [(path,GfxChange gfx)]
+  | ChangeGfxBg ColorSpec
+  | ChangeGfxBgPixmap PixmapId Bool -- True = free pixmap
+#ifdef USE_EXIST_Q
+  | EXISTS(bg) TSTHACK((Graphic EQV(bg)) =>) ChangeGfxBgGfx EQV(bg)
+#endif
+  | ChangeGfxCursor CursorId
+  | ChangeGfxFontCursor Int
+  | ShowGfx path (Maybe Alignment,Maybe Alignment) -- makes the selected part visible
+  | BellGfx Int -- sound the bell
+  | GetGfxPlaces [path] -- ask for rectangles of listed paths
+
+replaceAllGfx = replaceGfx []
+replaceGfx path gfx = ChangeGfx [(path,GfxReplace (False,Just gfx))]
+showGfx path = ShowGfx path (Nothing,Nothing)
+highlightGfx path on = ChangeGfx [(path,GfxReplace (on,Nothing))]
+
+instance Functor GfxChange where
+  fmap f (GfxReplace r) = GfxReplace (fmap (fmap f) r)
+  fmap f (GfxGroup from count) = GfxGroup from count
+  fmap f (GfxUngroup at) = GfxUngroup at
+
+instance Functor (GfxCommand path) where
+  fmap f cmd =
+    case cmd of
+      ChangeGfx changes -> ChangeGfx (mapSnd (fmap f) changes)
+      -- _ -> cmd -- Operationally, the rest is the same as this line.
+      ChangeGfxBg c -> ChangeGfxBg c
+      ChangeGfxBgPixmap pm b -> ChangeGfxBgPixmap pm b
+#ifdef USE_EXIST_Q
+      ChangeGfxBgGfx gfx -> ChangeGfxBgGfx gfx
+#endif
+      ChangeGfxCursor cursor -> ChangeGfxCursor cursor
+      ChangeGfxFontCursor shape -> ChangeGfxFontCursor shape
+      ShowGfx path a -> ShowGfx path a
+      BellGfx n -> BellGfx n
+      GetGfxPlaces paths -> GetGfxPlaces paths
+
+--  Events from graphicsF: ----------------------------------------------------
+
+data GfxEvent path
+  = GfxButtonEvent { gfxTime  :: Time,
+                     gfxState :: ModState,
+		     gfxType  :: Pressed,
+                     gfxButton:: Button,
+		     gfxPaths :: [(path,(Point,Rect))] }
+  | GfxMotionEvent { gfxTime  :: Time,
+                     gfxState :: ModState,
+		     gfxPaths :: [(path,(Point,Rect))] }
+  | GfxKeyEvent    { gfxTime  :: Time,
+                     gfxState::ModState,
+                     gfxKeySym::KeySym,
+		     gfxKeyLookup::KeyLookup }
+  | GfxFocusEvent  { gfxHasFocus :: Bool }
+  | GfxPlaces [Rect] -- response to GetGfxPlaces
+  | GfxResized Size
+  deriving (Eq,Show)
+
+
+--  graphicsF event masks: ----------------------------------------------------
+
+data GfxEventMask = GfxButtonMask | GfxMotionMask | GfxDragMask | GfxKeyMask
+
+allGfxEvents = [GfxButtonMask, GfxMotionMask, GfxDragMask, GfxKeyMask]
+gfxMouseMask = [GfxButtonMask, GfxDragMask] -- backward compat
+
+gfxEventMask = concatMap events
+  where
+    events GfxButtonMask = buttonmask
+    events GfxMotionMask = motionmask
+    events GfxDragMask   = dragmask
+    events GfxKeyMask    = keventmask
+
+    buttonmask = [ButtonPressMask,ButtonReleaseMask]
+    motionmask = [PointerMotionMask]
+    dragmask = [Button1MotionMask]
+    keventmask =
+	 [KeyPressMask,
+          EnterWindowMask, LeaveWindowMask -- because of CTT implementation
+	 ]
+
+--  Customisers for graphicsF: ------------------------------------------------
+
+newtype GraphicsF gfx = Pars [Pars gfx]
+
+data Pars gfx
+  -- Standard customisers:
+  = BorderWidth Int
+  | BgColorSpec ColorSpec
+  | FgColorSpec ColorSpec
+  | FontSpec FontSpec
+  | Sizing Sizing
+  | Stretchable (Bool,Bool)
+  | InitSize gfx
+  | InitDisp gfx
+  -- Special customisers:
+  | CursorSolid Bool
+  | GfxEventMask [GfxEventMask]
+  | AdjustSize Bool
+  | Cursor Int -- pointer cursor shape for XCreateFontCursor
+  | DoubleBuffer Bool
+-- Could also support:
+--  | Align Alignment
+--  | Spacer Spacer
+--  | Margin Int
+
+parameter_instance1(BorderWidth,GraphicsF)
+parameter_instance1(BgColorSpec,GraphicsF)
+parameter_instance1(FgColorSpec,GraphicsF)
+parameter_instance1(Sizing,GraphicsF)
+parameter_instance1(FontSpec,GraphicsF)
+parameter_instance1(Stretchable,GraphicsF)
+parameter_instance(InitSize,GraphicsF)
+parameter_instance(InitDisp,GraphicsF)
+parameter(CursorSolid)
+parameter(GfxEventMask)
+parameter(AdjustSize)
+parameter(Cursor)
+parameter(DoubleBuffer)
+
+-------------------------------------------------------------------------------
+
+type GfxFCmd a = GfxCommand DPath a
+type GfxFEvent = GfxEvent DPath
+
+graphicsDispF :: Graphic a => F (GfxFCmd a) (GfxFEvent)
+graphicsDispF = graphicsDispF' standard
+
+graphicsLabelF lbl = graphicsLabelF' standard lbl
+
+graphicsLabelF' customiser gfx = nullSP >^^=< d >=^^< nullSP'
+  where d = graphicsF' (customiser . params)
+	params = setInitDisp gfx .setGfxEventMask [] . setSizing Static .
+		 setBgColor bgColor . setBorderWidth 0
+	nullSP' = nullSP -- :: (SP anything (GfxCommand MeasuredGraphics))
+	-- this is a workaround necessary to resolve the overloading
+
+graphicsDispF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F (GfxFCmd gfx) (GfxFEvent)
+graphicsDispF' customiser  = graphicsF' (customiser . dispCustomiser)
+graphicsDispGroupF fud = graphicsGroupF' dispCustomiser fud
+graphicsDispGroupF' customiser fud =
+  graphicsGroupF' (customiser . dispCustomiser) fud
+
+dispCustomiser =
+  setCursorSolid True . setGfxEventMask gfxMouseMask . setSizing Growing
+
+graphicsF :: Graphic gfx => F (GfxFCmd gfx) (GfxFEvent)
+graphicsF = graphicsF' standard
+
+graphicsF' custom = filterLeftSP >^^=< graphicsGroupF' custom nullF >=^< Left
+
+graphicsGroupF :: Graphic gfx => F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
+graphicsGroupF = graphicsGroupF' standard
+
+--graphicsGroupF' :: (Graphic init,Graphic gfx => Customiser (GraphicsF init) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
+graphicsGroupF' :: Graphic gfx => Customiser (GraphicsF gfx) -> F i o -> F (Either (GfxFCmd gfx) i) (Either (GfxFEvent) o)
+graphicsGroupF' customiser fud = 
+  let solid = getCursorSolid params
+      mask = getGfxEventMask params
+      sizing = getSizing params
+      adjsize = getAdjustSize params
+      doublebuffer = getDoubleBuffer params
+      optcursor = getCursorMaybe params
+      font = getFontSpec params
+      bw = getBorderWidth params
+      bgcol = getBgColorSpec params
+      fgcol = getFgColorSpec params
+      optx = getInitDispMaybe params
+      optstretch = getStretchableMaybe params
+      optinitsize = getInitSizeMaybe params
+      params = customiser defaults
+      defaults = Pars [BorderWidth 1,
+                       BgColorSpec (colorSpec paperColor),
+                       FgColorSpec (colorSpec fgColor),
+		       Sizing Dynamic,
+		       CursorSolid False,
+		       GfxEventMask allGfxEvents,
+		       AdjustSize True,
+		       DoubleBuffer defaultdoublebuffer,
+		       FontSpec (fontSpec labelFont)]
+      eventmask = ExposureMask:
+	          gfxEventMask mask
+      --grabmask =  [ButtonReleaseMask, PointerMotionMask]
+      -- NOTE: some code below assumes that motion events occur ONLY
+      --       while Button1 is pressed!
+      startcmds = [ChangeWindowAttributes [CWEventMask eventmask,
+                                           CWBitGravity NorthWestGravity],
+                    ConfigureWindow [CWBorderWidth bw]--,
+		    --GrabButton False (Button 1) [] grabmask,
+		    --GrabButton False (Button 2) [] [ButtonReleaseMask]
+		  ]
+  in --compMsgSP layoutOptSP (idRightSP idempotSP) `serCompSP`
+     idRightSP (stripEither `postMapSP` idRightSP idempotSP) >^^=<
+     groupF (fmap XCmd startcmds)
+        (initK doublebuffer font optcursor fgcol bgcol $
+	 graphicsK0 solid sizing adjsize optstretch optinitsize optx)
+        fud
+
+dbeSwapBuffers cont =
+  xrequestK (DbeSwapBuffers swapaction) Just $ \ (DbeBuffersSwapped _) -> cont
+
+optDoubleBufferK False cont = cont Nothing
+optDoubleBufferK True cont =
+  xrequestK DbeQueryExtension Just $ \ (DbeExtensionQueried status major minor) ->
+  let ok=status/=0
+  in if not ok
+     then echoStderrK "Sorry, double buffering not available." $
+	  cont Nothing
+     else xrequestK (DbeAllocateBackBufferName swapaction) Just $ \ (DbeBackBufferNameAllocated backbuf) ->
+          --xcommandK ClearWindow $
+          cont (Just backbuf)
+
+initK doublebuffer font optcursor fgcol bgcol k =
+  changeGetBackPixel bgcol $ \ bg ->
+  maybe id setFontCursor optcursor $
+  convColorK [fgcol,colorSpec "black"] $ \ fg ->
+  wCreateGCtx rootGCtx [GCFont [font,fontSpec "fixed"],GCForeground fg,GCBackground bg] $ \ gctx@(GC gc _) ->
+  wCreateGC rootGC [GCForeground bg] $ \ cleargc ->
+  createCursorGC gc bg fg $ \ higc ->
+  optDoubleBufferK doublebuffer $ \ optbackbuf ->
+  k optbackbuf gctx bg cleargc higc
+
+optCompileGraphicK gctx optgfx cont =
+  case optgfx of
+    Nothing -> cont Nothing
+    Just gfx ->
+      measureGraphicK gfx gctx $ \ mg ->
+      cont (Just (mg,compileMG id mg))
+
+graphicsK0 solid sizing adjsize optstretch optinitsize optx optbackbuf gctx bg cleargc higc =
+    graphicsK1 
+  where
+    graphicsK1 =
+      optCompileGraphicK gctx optinitsize $ \ optcgsize ->
+      optCompileGraphicK gctx optx $ \ optcgx ->
+      graphicsK2 optcgsize optcgx
+    graphicsK2 optcgsize optcgx =
+        graphicsK init
+      where
+	optSizeS    = fmap (minSizeS . minsize . snd . snd) optcgsize
+        optStretchS = fmap stretchS optstretch
+          where stretchS (sh,sv) = noStretchS (not sh) (not sv)
+        spacerM =
+	  case (optStretchS,optSizeS) of
+	    (Just stretchS,Just sizeS) -> SpacedM (stretchS `compS` sizeS)
+	    (Just stretchS,_         ) -> SpacedM stretchS
+	    (_            ,Just sizeS) -> SpacedM sizeS
+	    _                          -> MarkM gctx
+
+        -- All incoming and outgoing paths have to be adjusted because of
+	-- the extra spacer. The functions pathIn & pathOut handle this.
+	init = pairwith (compileMG id) $ spacerM $ maybe (emptyMG 10) fst optcgx
+         -- Stretchiness is applied to all drawings as it should be, but
+	 -- optinitsize should be applied only to the first drawing!!!
+    
+    pathIn path = 0:path
+    -- pathOut (0:path) = path
+
+    -- locatePointOut p = mapFst pathOut . locatePoint p
+    locatePointOut p (CGMark cg) = locatePoint p cg
+    -- bug if top node isn't a CGMark !!
+
+    graphicsK (mg,(cg,req)) =
+      putLayoutReq req $
+      idleK cleargc req mg cg solid []
+
+    idleK cleargc req mg cg active es =
+        seq size $ -- prevents a space leak when sizing==Dynamic, TH 980724
+	getK $ message lowK highK
+      where
+	size = minsize req -- == current window size most of the time
+	curR = hiR (solid||active)
+	same = idleK cleargc req mg cg active es
+	newcleargc cleargc' = idleK cleargc' req mg cg active es
+
+	optInsertNew mg cg gctx path optreq optnew k =
+	  case optnew of
+	    Nothing  -> k mg cg optreq
+	    Just new -> measureGraphicK new gctx $ \ newmg ->
+			let mg' = replaceMGPart mg path newmg
+			    (cg',req) = compileMG (newSize sizing size) mg'
+			in k mg' cg' (Just req)
+
+	updGraphicsK mg cg optreq [] c =
+	  case optreq of
+	    Just req' | not (similar req' req)
+		 	     -> --ctrace "updgfx" (show (req,req')) $
+				putLayoutReq req' $ c req' mg cg False
+	    _                -> c req mg cg True
+	updGraphicsK mg cg optreq ((path,change):changes) c =
+          case change of
+            GfxReplace r -> replace r
+            GfxGroup from count -> group from count
+            GfxUngroup pos -> ungroup pos
+          where
+            replace (hi,optnew) =
+              optInsertNew mg cg (parentGctx gctx mg path) path optreq optnew $ \ mg' cg' optreq' ->
+              let cg'' = case (hi,optnew) of
+                           (False,Nothing) -> cgupdate cg' path removecursor
+                           (True,_)        -> cgupdate cg' path addcursor
+                           _ -> cg'
+              in updGraphicsK mg' cg'' optreq' changes c
+
+            group from count = updGraphicsK mg' cg' optreq changes c
+              where mg' = updateMGPart mg path (groupMGParts from count)
+                    cg' = cgupdate cg path (cgGroup from count)
+
+            ungroup pos = updGraphicsK mg' cg' optreq changes c
+              where mg' = updateMGPart mg path (ungroupMGParts pos)
+                    cg' = cgupdate cg path (cgUngroup pos)
+
+        bufDrawChangesK = maybe drawChangesK backBufDrawChangesK optbackbuf
+	bufDrawK = maybe drawK backBufDrawK optbackbuf
+
+        backBufDrawChangesK backbuf beQuick cur new old changes cont =
+            drawChangesK' (Just (DbeBackBuffer backbuf,cleargc)) False cur new old changes $
+	    dbeSwapBuffers $
+	    cont
+	backBufDrawK backbuf cur clip cg cont =
+            drawK' (DbeBackBuffer backbuf) cur clip cg $
+	    dbeSwapBuffers $
+	    --putLow (wCopyArea gc (DbeBackBuffer backbuf) (Rect 0 size) 0) $
+	    cont
+          where (GC gc _) = gctx
+
+	buttonEvent t p state type' button =
+	  -- High level output tagged Left is sent through idempotSP
+	  putHigh (Left $
+	           GfxButtonEvent t state type' button (locatePointOut p cg)) $
+	  same
+	motionEvent t p state =
+	  -- High level output tagged Left is sent through idempotSP
+	  putHigh (Left $ GfxMotionEvent t state (locatePointOut p cg)) $
+	  same
+	key t mods sym lookup =
+	  putHigh (Right $ GfxKeyEvent t mods sym lookup) $ same
+
+	highK (ShowGfx path align) = mkPathVisible cg (pathIn path) align same
+	highK (BellGfx n) = xcommandK (Bell n) same
+
+	highK (GetGfxPlaces paths) =
+	  putHigh (Right $ GfxPlaces $ fmap (cgrect . cgpart cg . pathIn) paths) $
+	  same
+	highK (ChangeGfxBg bgspec) =
+	  convColorK bgspec $ \ bgcol ->
+	  xcommandK (ChangeWindowAttributes [CWBackPixel bgcol]) $
+	  xcommandK clearWindowExpose $
+	  wCreateGC rootGC [GCForeground bgcol] $ \ cleargc' ->
+	  -- FreeGC cleargc
+	  newcleargc cleargc'
+	highK (ChangeGfxBgPixmap pixmap freeIt) =
+	  xcommandK (ChangeWindowAttributes [CWBackPixmap pixmap]) $
+	  xcommandK clearWindowExpose $
+	  wCreateGC rootGC [GCFillStyle FillTiled,GCTile pixmap] $ \ cleargc' ->
+	  -- FreeGC cleargc
+	  (if freeIt then xcommandK (FreePixmap pixmap) else id) $
+	  newcleargc cleargc'
+#ifdef USE_EXIST_Q
+        highK (ChangeGfxBgGfx gfx) =
+	  graphic2PixmapImage gfx gctx $ \ (PixmapImage size pm) ->
+	  highK (ChangeGfxBgPixmap pm True)
+#endif
+        highK (ChangeGfxCursor cursor) =
+          defineCursor cursor $
+          xcommandK Flush $
+	  same
+        highK (ChangeGfxFontCursor shape) =
+          setFontCursor shape $
+          xcommandK Flush $
+	  same
+	highK (ChangeGfx changes0) =
+	    updGraphicsK mg cg Nothing changes $ \ req' mg' cg' beQuick ->
+	    bufDrawChangesK beQuick (higc,curR) cg' cg (fmap fst changes) $
+	    --mkChangeVisible cg' changes $
+	    idleK cleargc req' mg' cg' active []
+	  where changes = mapFst pathIn changes0
+
+	changeActive active' =
+	  if active'==active
+	  then same
+	  else putHigh (Left $ GfxFocusEvent { gfxHasFocus=active' }) $
+	       bufDrawChangesK True (higc,hiR (solid||active')) cg cg (cursorPaths cg) $
+	       idleK cleargc req mg cg active' es
+
+        lowK (XEvt e) = eventK e
+	lowK (LEvt lresp) = layoutK lresp
+	lowK _ = same
+
+        layoutK lresp =
+	  case lresp of
+	    LayoutSize size'
+		| adjsize ->
+		    if size' == size then same
+		    else let cg'' = foldr restorecursor cg' (cgcursors cg)
+			       where
+			         restorecursor path cg = cgupdate cg path addcursor
+				 (cg',_) = compileMG (const size') mg
+			 in putHigh (Left $ GfxResized size') $
+			    bufDrawChangesK True (higc,curR) cg'' cg [] $
+			    idleK cleargc req' mg cg'' active es
+		| otherwise -> idleK cleargc req' mg cg active es
+	      where req' = mapLayoutSize (const size') req
+	    _ -> same
+
+	eventK event =
+	  case event of
+	    Expose r 0 ->
+	      let rs = r:es
+	      in bufDrawK (higc,curR) (intersectRects rs) (prune rs cg) $
+                 idleK cleargc req mg cg active []
+	    Expose r _ -> idleK cleargc req mg cg active (r:es)
+	    FocusIn  {} -> changeActive True
+	    FocusOut {} -> changeActive False
+
+	    ButtonEvent {time=t, pos=pos, type'=type', button=button, state=state} ->
+	       buttonEvent t pos state type' button
+	    MotionNotify {time=t,pos=pos,state=state} -> motionEvent t pos state
+	    KeyEvent t _ _ mods Pressed _ sym lookup -> key t mods sym lookup
+	    _ -> same
+
+prune rs (CGMark cg) = CGMark (prune rs cg)
+prune rs (CGraphics r cur cmds cgs) =
+  if any (overlaps r) rs
+  then if null cmds --  || all (null.snd) cmds
+       then CGraphics r cur cmds (fmap (prune rs) cgs)
+       else CGraphics r cur cmds cgs
+             -- cmds may overlap with cgs, so
+	     -- if cmds are redrawn then all cgs should be redrawn too.
+  else CGraphics r cur [] [] -- subtree rectangles are inside parent rectangles.
+
+{-
+locatePoint' p cg = fmap addrect $ locatePoint p cg
+  where
+    addrect = pairwith (cgrect . cgpart cg)
+-}
+
+locatePoint p (CGMark cg) = [(0:path,geom)|(path,geom)<-locatePoint p cg]
+ --  ^^ the wrong geometry will be return if CGMark came from a SpacerM !!
+locatePoint p (CGraphics r _ _ gs) =
+  if p `inRect` r
+  then let ps = fmap (locatePoint p) gs
+       in case [ (i:path,pr) | (i,paths)<-number 1 ps, (path,pr)<-paths] of
+            [] -> [([],(p-rectpos r,r))]
+	    ps -> ps
+  else []
+
+cursorPaths (CGMark cg) = fmap (0:) (cursorPaths cg)
+cursorPaths (CGraphics _ cur _ gs) =
+  if cur
+  then [[]]
+  else [i:p | (i,g)<-number 1 gs, p<-cursorPaths g]
+
+hiR True = solidCursorRects
+hiR False = hollowCursorRects
+
+solidCursorRects r = [r]
+
+hollowCursorRects (Rect (Point x y) (Point w h)) =
+   [rR x y w lw,rR x y lw h,rR x (y+h-lw) w lw,rR (x+w-lw) y lw h]
+ where lw=minimum [2,w,h]
+
+--putSize cg = putLayoutReq (Layout (cgsize cg) False False)
+
+mkChangeVisible cg changes =
+  case [ path | (path,(True,_))<-changes] of
+    path:_ -> mkPathVisible cg path (Nothing,Nothing)
+    _ -> id
+
+mkPathVisible cg path align =
+    putLayout (lMkVis (cgrect (cgpart cg path)))
+  where
+    lMkVis r = LayoutMakeVisible (r `growrect` 5) align
+			 -- growrect compensates for a layout bug !!
+
+putLayoutReq = putLayout . LayoutRequest
+--putSpacer = putLayout . LayoutSpacer
+putLayout = putK . Low . LCmd
+
+createCursorGC gc bg fg cont =
+  --allocNamedColorDefPixel defaultColormap cursorcolor "white" $ \ hipix ->
+  tryConvColorK cursorcolor $ \ opthipix ->
+  let hipix = fromMaybe fg opthipix
+  in if hipix/=bg && hipix/=fg && not mono
+     then wCreateGC gc [GCForeground hipix] $ \ cursorgc ->
+	  cont cursorgc
+     else createPixmap (Point 2 2) copyFromParent $ \ pm ->
+	  wCreateGC gc [GCForeground bg] $ \ cleargc ->
+	  putsK [Low $ pmFillRectangle pm cleargc (rR 0 0 2 2),
+		 Low $ pmDrawPoint pm gc 0] $
+	  wCreateGC gc [GCFillStyle FillTiled,GCTile pm] $ \ cursorgc ->
+	  cont cursorgc
+
+similar l1 l2 =
+  minsize l1==minsize l2 &&
+  fixedh l1==fixedh l2 &&
+  fixedv l1==fixedv l2
+
+cursorcolor = argKeyList "cursor" ["yellow"]
+mono = argFlag "mono" False
+defaultdoublebuffer = argFlag "doublebuffer" False
+swapaction = argReadKey "swapaction" DbeCopied
diff --git a/hsrc/fudgets/GuiElems.hs b/hsrc/fudgets/GuiElems.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/GuiElems.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE CPP #-}
+module GuiElems (
+  -- * GUI elements
+  -- ** Buttons
+  module DButtonF, module DRadioF, module DToggleButtonF,
+  module Border3dF,module ButtonBorderF,
+  module ButtonF,module ButtonGroupF,
+  module PushButtonF,module QuitButtonF,
+  module QuitF,module RadioF,
+  module ToggleButtonF,module ToggleGroupF,
+  -- ** Graphics
+  module GraphicsF,
+  module HyperGraphicsF,
+  -- ** Menus
+  module MenuButtonF,module MenuF,module MenuPopupF,
+  -- ** Popups
+  module DialogF,
+  module PopupMenuF,
+  module FilePickF,
+  -- ** Text elements
+  module LabelF,
+  module DDisplayF,module DStringF,
+  module MoreF, module MoreFileF,
+  module StringF, module TextF,
+  module TerminalF,
+  -- ** Special indicators
+  module OnOffDispF,
+  module GcWarningF,
+  module BellF,
+  -- ** Editors
+  module Edit,module Editor,module Edtypes,module InputEditorF
+ ) where
+import Border3dF
+import ButtonBorderF
+import ButtonF
+import ButtonGroupF
+import DialogF
+import Edit
+import Editor
+import Edtypes
+import InputEditorF
+import FilePickF
+import GraphicsF
+import HyperGraphicsF
+import LabelF
+import MenuButtonF
+import MenuF
+import MenuPopupF
+import TextF
+import MoreF
+import MoreFileF
+import PopupMenuF
+import PushButtonF
+import QuitButtonF
+import QuitF
+import RadioF
+import StringF
+import TerminalF
+import ToggleGroupF
+import ToggleButtonF
+import OnOffDispF
+import DButtonF
+import DToggleButtonF
+import DRadioF
+import DDisplayF
+import DStringF
+import GcWarningF
+import BellF
+
+#ifdef __NHC__
+import FDefaults -- Needed re-export instances for these classes
+#endif
diff --git a/hsrc/fudgets/HyperGraphicsF.hs b/hsrc/fudgets/HyperGraphicsF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/HyperGraphicsF.hs
@@ -0,0 +1,76 @@
+module HyperGraphicsF where
+--import Fudget
+--import Defaults(paperColor)
+--import InputMsg(inputDone)
+import Utils(swap)
+--import Xtypes(ColorName)
+import Loops(loopThroughRightF)
+import SerCompF(mapstateF)
+--import Graphic
+import Drawing
+import DrawingOps
+import GraphicsF
+import FDefaults
+import HbcUtils(assoc)
+import Sizing(Sizing(..))
+--import GCAttrs() -- instances
+import Event(Pressed(..))
+--import Maptrace(ctrace) -- debugging
+--import SpyF(teeF) -- debugging
+--import CompOps((>==<)) -- debugging
+
+hyperGraphicsF x = hyperGraphicsF' standard x
+
+{-
+hyperGraphicsF' :: (Eq annot,Graphic g) =>
+                  Customiser (GraphicsF (Drawing annot g)) ->
+                  Drawing annot g ->
+		  F (Either (Drawing annot g) (annot,Drawing annot g))
+		    annot
+-}
+hyperGraphicsF' custom init =
+    loopThroughRightF
+	(mapstateF ctrl state0)
+	({-teeF show "\n" >==<-} graphicsDispF' (custom . params))
+  where
+    --tr x = ctrace "hyper" (show x) x -- debugging
+    params = setInitDisp init .
+	     setGfxEventMask [GfxButtonMask] .
+	     setSizing Dynamic
+    state0 = (annotPaths init,init)
+
+    ctrl state@(paths,drawing) = either input output
+      where
+        same = (state,[])
+        output = either new newpart
+	  where
+	    --new d = newpart' d []
+	    -- avoid space leak for this common case:
+	    new d = ((annotPaths d,d),[Left (replaceAllGfx d)])
+	    newpart (a,d) = assoc (newpart' d) same paths a
+	    newpart' d path = ((paths',drawing'),[Left (replaceGfx path d)])
+	      where drawing' = replacePart drawing path d
+	            paths' = annotPaths drawing'
+			-- Space leak: drawing' isn't used until user clicks
+			-- in the window, so the old drawing is retained in
+			-- the closure for drawing'
+
+        input msg =
+	    case msg of
+	      GfxButtonEvent { gfxType=Pressed, gfxPaths=gfxPaths } ->  mouse gfxPaths
+	      _ -> same
+	  where
+	    lblPart = maybeDrawingPart drawing . drawingAnnotPart drawing . fst
+	    mouse paths =
+	      --ctrace "hyper" (show paths) $
+	      case [lbl|Just (LabelD lbl _)<-map lblPart (reverse paths)] of
+		lbl:_ -> (state,[Right lbl])
+{- -- All nodes have unique paths now, so this should not be necessary:
+		    Just d ->
+		      case annotChildren d of
+		        ([],LabelD a _):_ -> (state,[Right a])
+			_ -> same
+-}
+		_ -> same
+
+    annotPaths = map swap . drawingAnnots
diff --git a/hsrc/fudgets/InputEditorF.hs b/hsrc/fudgets/InputEditorF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/InputEditorF.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE CPP #-}
+module InputEditorF(
+    EditorF,
+    inputEditorF,inputEditorF',
+    editorF,editorF')
+  where
+import Editor(oldEditorF,loadEditor)
+import Edit(EditEvt(..))
+--import InputMsg(InputMsg(..))
+import CompOps
+import SpEither(mapFilterSP)
+import Spops(concatMapSP)
+import ResourceIds() -- synonym FontName, for hbc
+import GCAttrs --(FontSpec,fontSpec)
+import Defaults(defaultFont)
+import FDefaults
+
+#include "defaults.h"
+
+inputEditorF = inputEditorF' standard
+
+inputEditorF' pm =
+    mapFilterSP change >^^=< editorF' pm >=^^< concatMapSP loadEditor
+  where
+    change (EditChange inputmsg) = Just inputmsg
+    change _ = Nothing
+
+editorF = editorF' standard
+
+editorF' customiser = oldEditorF font
+  where
+    font = fromMaybe (fontSpec defaultFont) $ getFontSpecMaybe ps
+    ps = (customiser::(Customiser EditorF))  (Pars [])
+
+newtype EditorF = Pars [Pars]
+
+data Pars
+  = FontSpec FontSpec
+
+parameter_instance(FontSpec,EditorF)
diff --git a/hsrc/fudgets/LabelF.hs b/hsrc/fudgets/LabelF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/LabelF.hs
@@ -0,0 +1,28 @@
+module LabelF(labRightOfF, labLeftOfF, labBelowF, labAboveF, tieLabelF) where
+import Spacer(noStretchF,marginHVAlignF)
+import Alignment
+import CompOps((>=^<), (>^=<))
+import DDisplayF(labelF)
+--import Fudget
+--import Geometry
+import LayoutDir(Orientation(..))
+import LayoutOps
+import EitherUtils(stripEither)
+--import Xtypes
+
+--tieLabelF :: Orientation -> Alignment -> String -> F a b -> F a b
+tieLabelF orient align text fudget =
+    let disp = labelF text
+        fv = orient == Above || orient == Below
+        fh = not fv
+        lblF = noStretchF fh fv (marginHVAlignF 0 align align disp)
+    in  (stripEither >^=< ((lblF,orient) >#+< fudget)) >=^< Right
+
+
+labF orient = tieLabelF orient aCenter
+labAboveF   x = labF Above x
+labBelowF   x = labF Below x
+labLeftOfF  x = labF LeftOf x
+labRightOfF x = labF RightOf x
+
+-- eta expanded because of monomorphism restriction
diff --git a/hsrc/fudgets/MenuButtonF.hs b/hsrc/fudgets/MenuButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/MenuButtonF.hs
@@ -0,0 +1,44 @@
+module MenuButtonF(menuButtonF,menuLabelF) where
+import ButtonGroupF
+import CompOps((>^^=<),(>=^<))
+import SpEither(filterRightSP)
+import SerCompF(idRightF)
+import Defaults(inputFg,inputBg)
+--import EitherUtils(stripEither)
+import PushButtonF(Click(..))
+import ResourceIds(FontName(..))--ColorName(..),
+import Spacers(sepS)
+import GraphicsF
+import FDefaults
+import DrawingUtils(g,boxD,spacedD)--fgD,fontD,
+import Graphic
+import Drawing(DPath)
+import Geometry(pP)
+import Fudget
+import Sizing(Sizing(..))
+import GCAttrs()
+
+menuButtonF :: Graphic lbl => FontName -> lbl -> F lbl Click
+menuButtonF fname label =
+    filterRightSP >^^=< menuButtonGroupF (idRightF lblF >=^< prep)
+  where
+    lblF = menuLabelF fname label
+    toDisp = Left
+    through = Right
+    prep (Left BMNormal) = toDisp (Left False)
+    prep (Left BMInverted) = toDisp (Left True)
+    prep (Left BMClick) = through Click
+    prep (Right e) = toDisp (Right e)
+
+menuLabelF :: Graphic lbl => FontName -> lbl -> F (Either Bool lbl) (GfxEvent DPath)
+menuLabelF fname label =
+    lblF >=^< pre
+  where
+    lblF = graphicsDispF' custom
+    custom = setBgColor inputBg . setInitDisp (lblD label) .
+	     setGfxEventMask [] . setSizing Dynamic . setBorderWidth 0 .
+	     setFgColor inputFg . setFont fname
+    lblD label = boxD [spacedD (sepS (pP 3 1)) $ g label]
+
+    pre (Left highlight) = highlightGfx [] highlight
+    pre (Right label')  = replaceAllGfx (lblD label')
diff --git a/hsrc/fudgets/MenuF.hs b/hsrc/fudgets/MenuF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/MenuF.hs
@@ -0,0 +1,254 @@
+module MenuF(simpleMenuF, menuAltsF, menuF, oldMenuF, buttonMenuF, buttonMenuF', grabberF, MenuState,menuDown,EqSnd(..),fstEqSnd,sndEqSnd,toEqSnd) where
+import Command
+import Event
+import Geometry(pP,Point(..),Size,inRect,Rect(..))
+import Message(message )--Message(..),
+import Fudget
+import FRequest
+import FudgetIO
+import StreamProcIO
+import Xcommand
+import NullF
+import CompOps((>^=<), (>=^<), (>=^^<), (>^^=<),(>+<))
+import Dlayout(groupF)
+import SerCompF(bypassF)--,idRightF
+import Loops(loopCompThroughRightF)
+import LayoutDir(LayoutDir(..))
+import LayoutF(listLF)
+import LayoutRequest(LayoutResponse(..))
+import Placers
+import Spacers() -- synonym Distance, for hbc
+import MenuButtonF
+import MenuPopupF
+import Spops(nullSP)
+import MapstateK
+import SpEither(filterRightSP)
+import EitherUtils(mapEither)--stripEither
+import Xtypes
+import Defaults(menuFont)
+import CmdLineEnv(argFlag)
+import Graphic
+import Data.Array
+--import DialogueIO hiding (IOError)
+import ShowCommandF(showCommandF)
+import Debug.Trace(trace)
+
+data EqSnd a b = EqSnd a b
+
+instance (Eq b) => Eq (EqSnd a b) where
+    EqSnd a1 b1 == EqSnd a2 b2  =  b1 == b2
+
+fstEqSnd (EqSnd a b) = a
+sndEqSnd (EqSnd a b) = b
+toEqSnd x = map (uncurry EqSnd) x
+
+menuF :: (Graphic mlbl,Graphic albl) => mlbl -> [(alt,albl)] -> F alt alt
+menuF name altlbls =
+    bypassF ((nalts!) . sndEqSnd >^=< 
+      simpleMenuF menuFont name lblns fstEqSnd >=^^< nullSP)
+  where
+    (alts,lbls) = unzip altlbls
+    lblns = zipWith EqSnd lbls ixs
+    n = length alts
+    ixs =  [1 .. n]
+    nalts = array (1,n) (zip ixs alts)
+
+
+simpleMenuF fname name = oldMenuF fname name . map (\x -> (x,[]))
+
+oldMenuF :: (Graphic c, Eq b, Graphic a) => FontName -> a -> [(b, [(ModState, KeySym)])] -> (b -> c) -> F a b 
+oldMenuF fname name alts show_alt =
+    grabberF [] (buttonMenuF Horizontal fname name alts menuAlts>=^<mapEither id Left)
+  where
+    menuAlts = menuAltsF' fname (map fst alts) show_alt >=^^< filterRightSP
+
+menuAltsF' fname alts show_alt =
+    fst >^=< listLF (verticalP' 0) (map altButton alts)
+  where
+    altButton (alt{-, keys-}) = (alt, menuButtonF fname {-keys-} (show_alt alt))
+
+menuAltsF fname alts show_alt =
+   menuPopupF (menuAltsF' fname alts show_alt) >=^< Left
+
+grabberF alts mF = loopCompThroughRightF (groupF startcmds grabK0 mF)
+  where
+    startcmds = map XCmd transinit
+    grabK0 = grabK False
+
+    transinit =
+        if null keys
+	then []
+        else  [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]
+      where
+        keys = concatMap snd alts
+        tobutton e@(KeyEvent {state=s,keySym=ks}) | (s, ks) `elem` keys = Just e
+	tobutton _ = Nothing
+    grabK up = getK $ message low high
+      where
+	keyalts = [(k,a)|(a,ks)<-alts,k<-ks]
+	same = grabK up
+	popdown = grabK False
+	popup = grabK True
+	low event =
+	  case event of
+	    XEvt (KeyEvent {state=s,keySym=ks,type'=Pressed}) ->
+		puts [Left (Right alt)|(key,alt)<-keyalts,(s,ks)==key] same
+	    _ ->  same
+	high = either fromLoop fromOutside
+	fromLoop = either menuCoordination menuSelection
+	fromOutside x = putHigh (Left (Right x)) same
+	menuSelection x = putHigh (Right x) same
+	menuCoordination newState =
+	  case (up,newState) of
+	    (False,MenuUp _) ->
+	      --trace "grabberF: GrabEvents False" $
+	      xcommandK (GrabEvents False) popup
+	    (True,MenuDown) ->
+	      --trace "grabberF: UngrabEvents" $
+	      xcommandK UngrabEvents popdown
+	    _ -> same
+
+data MenuState = MenuDown | MenuUp MenuMode deriving (Show)
+type MenuMode = Bool -- True = sticky
+menuDown = MenuDown
+menuUpSticky = MenuUp True
+menuUpMPopup = MenuUp False
+-- Invariant: menu state never changes directly from MenuDown to menuUpSticky,
+-- i.e., when a menu first pops up, it always outputs menuUpMPopup
+
+data ButtonMenuState =
+  S { mpopup,othermpopup,sticky,debug::Bool, size::Size } deriving (Show)
+bstate0 = S False False False False 0
+
+{-
+buttonMenuF :: (Graphic a) =>
+	 LayoutDir -> FontName -> a ->
+	 [(b, [(ModState, KeySym)])] ->
+	 F (Either MenuState b) b ->
+	 F (Either MenuState (Either a b)) (Either MenuState b)
+-}
+buttonMenuF x = buttonMenuF' False x
+buttonMenuF' delayed dir fname name alts menuAltsF =
+    loopCompThroughRightF $
+    showCommandF "buttonMenuF" $
+    groupF startcmds
+	   (mapstateK proc bstate0)
+	   (filterRightSP >^^=< (menuLabelF fname name >+< theMenuF))
+  where
+    theMenuF = menuPopupF' delayed menuAltsF
+    topopup = High . Left . Right . Left
+    tosubmenus = High . Left . Right . Right . Left
+    inputtosubmenus = High . Left . Right . Right . Right
+    out = High . Right . Right
+    othermenu = High . Right . Left
+    toDisp = High . Left . Left
+    relabel = toDisp . Right
+    adjust =
+	case dir of
+	  Vertical -> \ (Point w _) -> pP w (-1)
+	  Horizontal -> \ (Point _ h) -> pP (-1) h
+    proc state@(S{mpopup=mpopup,othermpopup=othermpopup,sticky=sticky,size=size,debug=debug}) =
+	message low high
+      where
+	dbg x = if debug then trace ("buttonMenuF "++x) else id
+
+	popdownyield = popdown' True [] --pop down because other menu popped up
+	popdownlast = -- pop down, no other menu is up
+	  dbg "popdownlast" $
+	  popdown' False [othermenu MenuDown]
+	popdown' mpopup' msgs =
+	  (state{othermpopup=mpopup'},
+	   msgs++[tosubmenus menuDown,topopup PopdownMenu])
+
+	stickyMode =
+	  dbg "othermenu menuUpSticky" $
+	  (state{sticky=True},
+	   [othermenu menuUpSticky,topopup PopupMenuStick])
+
+	mPopupMode b = (state{mpopup=b},[])
+	highlight = toDisp . Left
+	put msgs = (state,msgs)
+
+	high = either fromMenu (either fromOtherMenu fromOutside)
+	fromOutside = either newLabel altInput
+	newLabel lbl = (state,[relabel lbl])
+	altInput x = (state,[inputtosubmenus x])
+
+	fromOtherMenu newMode =
+	  dbg ("fromOtherMenu "++show newMode) $
+	  case newMode of
+	    MenuUp False -> popdownyield -- other menu popped up, pop down
+	    MenuUp True -> (state{othermpopup=False},[])
+	    MenuDown -> popdown' False []
+
+	fromMenu alt =
+	  (state{sticky=False},
+	   [tosubmenus menuDown,othermenu menuDown,out alt])
+	low resp =
+	  dbg (unlines [show state, show resp,""]) $
+	  case resp of
+	    XEvt event ->
+	      case event of
+		ButtonEvent {button=Button 2,type'=Pressed,state=mods} ->
+		  trace "Button 2" $
+		  (state{debug=Control `elem` mods},[])
+		--ButtonEvent _ winpos rootpos mods Pressed (Button 1) ->
+		ButtonEvent {pos=winpos,rootPos=rootpos,state=mods,type'=Pressed,button=Button 1} ->
+		  dbg "output othermenu True" $
+		  (state{sticky=False},
+		   [othermenu menuUpMPopup, -- tell other menus to pop down
+		    topopup (PopupMenu (rootpos-winpos+adjust size) event)
+		    --highlight True,
+		    --Low (GrabEvents False)
+		    ])
+		LeaveNotify {mode=NotifyUngrab,detail=NotifyInferior}
+		    | stickyMenus && not mpopup -> stickyMode
+		LeaveNotify {mode=NotifyUngrab} {-  | not sticky-} -> popdownlast
+		--  ^^ these events get lost in focusMgr it seems
+		ButtonEvent {pos=pos,button=Button 1,type'=Released}
+		    | not (stickyMenus && pos `inRect` (Rect 0 size)) -> popdownlast
+			     --workaround
+		LeaveNotify {detail=detail}
+		    | detail/=NotifyInferior ->
+			if False --mpopup
+			then popdownlast
+			else put [highlight False]
+		EnterNotify {rootPos=rootpos,pos=winpos,mode=NotifyNormal}
+		  | mpopup || othermpopup ->
+		      dbg "output othermenu True" $
+		      (state{sticky=False},
+		       [othermenu menuUpMPopup, -- tell other menus to pop down
+			topopup (PopupMenu (rootpos-winpos+adjust size) event),
+			highlight True])
+		  | otherwise -> put [highlight True]
+		KeyEvent {state=s,type'=Pressed,keySym=ks} ->
+		  case [ a | (a,keys) <- alts, (s,ks) `elem` keys] of
+		    a:_ -> put [out a]
+		    _ -> error "MenuF.clickF bug"
+		MenuPopupMode b -> mPopupMode b
+		_ -> (state,[])
+	    LEvt (LayoutSize size') -> (state{size=size'},[])
+	    _ -> (state,[])
+
+    startcmds = map XCmd (MeButtonMachine : grab ++
+	                  [ConfigureWindow [CWBorderWidth 1],
+			   ChangeWindowAttributes wattrs] ++
+			  transinit)
+    grab = [GrabButton True (Button 1) [] ptrmask]
+    ptrmask = [ButtonPressMask, ButtonReleaseMask]
+    wattrs = [CWEventMask eventmask]
+    eventmask = [LeaveWindowMask, EnterWindowMask,
+		 ButtonPressMask -- Button 2 press, for debuggin only!
+		]
+
+    keys = concatMap snd alts
+
+    transinit =
+        if null keys
+	then []
+        else  [TranslateEvent tobutton [KeyPressMask, KeyReleaseMask]]
+      where
+        tobutton e@(KeyEvent {state=s,keySym=ks}) | (s, ks) `elem` keys = Just e
+	tobutton _ = Nothing
+
+stickyMenus = argFlag "stickymenus" False
diff --git a/hsrc/fudgets/MenuPopupF.hs b/hsrc/fudgets/MenuPopupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/MenuPopupF.hs
@@ -0,0 +1,117 @@
+module MenuPopupF(PopupMenu(..), menuPopupF, menuPopupF') where
+import Command
+import Cursor
+import Shells(unmappedShellF')
+import FDefaults() -- synonym Customiser, for hbc
+import DShellF(setFocusMgr)
+import Event
+import Fudget
+import FRequest
+import Geometry(Point)
+import Loops(loopCompThroughRightF,loopThroughRightF)
+--import Message(Message(..))
+import CompSP(prepostMapSP)
+import SerCompF(mapstateF)
+import NullF
+import Xtypes
+import Data.List(union)
+
+data PopupMenu
+  = PopupMenu Point XEvent -- Time to pop up the menu.
+  | PopupMenuStick	   -- The mouse button has been released, but stay up.
+  | PopdownMenu		   -- Time to hide the menu.
+  deriving Show
+  --deriving (Eq, Ord)
+
+menuPopupF = menuPopupF' False
+
+menuPopupF' delayed menu =
+    loopCompThroughRightF (dF $ unmappedShellF' pm startcmds popupShellK menu')
+  where
+    dF = if delayed then delayF else id
+    pm = setFocusMgr False
+    menu' = handleButtonMachinesF menu
+    startcmds = [XCmd $ ChangeWindowAttributes wattrs,
+		 XCmd $ ConfigureWindow [CWBorderWidth 1]]
+    wattrs = [CWEventMask [], CWSaveUnder True, CWOverrideRedirect True]
+
+popupShellK =
+    setFontCursor 110 downK
+  where
+    mouse (ButtonEvent {}) = True
+    mouse (EnterNotify {}) = True
+    mouse _ = False
+    samekey (KeyEvent {keySym=ks}) ks' = ks == ks'
+    samekey _ _ = False
+
+    toMenu = High . Left . Right
+    toBms = High . Left . Left
+    out = High . Right
+
+    popdown = map (Low . XCmd) [UnmapWindow]
+    popup p = toBms True:map (Low . XCmd) [moveWindow p, MapRaised]
+
+    downK =
+      getK $ \msg ->
+      case msg of
+	High (Right (Left (PopupMenu p ev))) -> putsK (popup p)     $ upK ev
+	High (Right (Right x))               -> putK  (toMenu x)    $ downK
+	High (Left x)                        -> putK  (out x)       $ downK
+	_ -> downK
+
+    upK ev =
+      getK $ \msg ->
+      case msg of
+	High (Right (Left (PopupMenu p ev))) -> putsK (popup p)     $ upK ev
+	High (Right (Left PopdownMenu))      -> putsK popdown       $ downK
+	High (Right (Left PopupMenuStick))   -> putK  (toBms False) $ upK ev
+	High (Right (Right x))               -> putK  (toMenu x)    $ upK ev
+	High (Left x) ->
+	  if mouse ev
+	  then putsK (out x : popdown) $ downK
+	  else putK  (out x)           $ upK ev
+	Low (XEvt (KeyEvent {type'=Released, keySym=ks})) ->
+	  if samekey ev ks
+	  then putsK popdown downK
+	  else upK ev
+	_ -> upK ev
+
+{- handleButtonMachineF fud records the paths of all button machines in fud, so
+   that a message can be broadcast to them when the MenuPopup mode changes.
+   It also keeps track of the current mode to avoid sending the same mode twice.
+-}
+
+handleButtonMachinesF fud =
+    loopThroughRightF ctrlF (liftbm fud)
+  where
+    ctrlF = mapstateF ctrl (False,[])
+
+    ctrl state@(mode,bms) = either fromLoop fromOutside
+      where
+	fromLoop (Left path) = addbm path
+	fromLoop (Right y) = out y
+
+        fromOutside (Left mode') = changeMode mode'
+	fromOutside (Right x) = inp x
+
+        addbm path = ((mode,[path] `union` bms),[Left (Left (path,mode))])
+	  -- Tell the new button the current mode. (Needed in case it is
+	  -- dynamically created inside a menu.)
+        out y = (state,[Right y])
+	inp x = (state,[Left (Right x)])
+
+	changeMode mode' =
+	  if mode'/=mode
+	  then ((mode',bms),[Left (Left (path,mode')) | path<-bms])
+	      -- !! This will send msgs also to buttons that have been destroyed
+	  else (state,[])
+
+    liftbm (F sp) = F $ prepostMapSP pre post sp
+      where
+	pre (High (Left (path,mode))) = Low (path,XEvt (MenuPopupMode mode))
+	pre (High (Right x)) = High x
+	pre (Low tevent) = Low tevent
+
+	post (Low (path,XCmd MeButtonMachine)) = High (Left path)
+	post (Low tcmd) = Low tcmd
+	post (High y) = High (Right y)
diff --git a/hsrc/fudgets/MoreF.hs b/hsrc/fudgets/MoreF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/MoreF.hs
@@ -0,0 +1,65 @@
+module MoreF(
+  moreF,moreF',
+  pickListF,pickListF',PickListRequest(..)
+) where
+
+import Fudget
+--import Xtypes
+import ResourceIds() -- synonym ColorName, for hbc
+import Spops
+import Geometry
+import ScrollF(oldVscrollF,grabScrollKeys)
+import TextF
+import Spacer(marginF)
+import SerCompF(absF)
+import Loops(loopThroughRightF)
+import CompOps((>=^<))
+import StringUtils(rmBS,expandTabs)
+import Defaults(labelFont,paperColor)
+import GCAttrs() -- instances
+
+import FDefaults
+--import Alignment
+import InputMsg(InputMsg,mapInp)
+import ListRequest(ListRequest(..),replaceAll,replaceItems,applyListRequest)
+
+txtF' pmod = marginF 5 $
+             --alignSepF 5 aLeft aTop $
+	     textF' pmod
+
+--stringListF :: Size -> FontName -> F TextRequest (InputMsg (Int,String))
+stringListF' size pmod = oldVscrollF grabScrollKeys (size,size) (txtF' pmod)
+
+moreF = moreF' standard
+
+moreF' :: Customiser TextF -> F [String] (InputMsg (Int,String))
+moreF' pmod =
+    stringListF' (pP 480 260) pmod' >=^<(replaceAll.map (rmBS.expandTabs 8))
+  where
+    pmod' = pmod.setBgColor paperColor
+
+type PickListRequest a = ListRequest a
+
+pickListF = pickListF' standard
+
+pickListF' :: Customiser TextF -> (a->String) -> F (PickListRequest a) (InputMsg (Int,a))
+pickListF' pmod show =
+    loopThroughRightF (absF (pickSP [])) altListF
+  where
+    pmod' = pmod.setFont labelFont
+    altListF = oldVscrollF grabScrollKeys (Point 240 260,Point 480 390) (txtF' pmod')
+    pickSP alts =
+      getSP $ \msg ->
+      case msg of
+        Right plreq@(ReplaceItems from cnt newalts') ->
+	  let alts' = applyListRequest plreq alts
+	      newalts = map show newalts'
+	  in putSP (Left (replaceItems from cnt newalts)) $
+	     evalSpine alts' $ -- prevents a space leak
+	     pickSP alts'
+        Right (HighlightItems ns) -> putSP (Left (HighlightItems ns)) $ pickSP alts
+	Right (PickItem n) ->  putSP (Left (PickItem n)) $ pickSP alts
+	Left msg -> putSP (Right (mapInp (\(n,_)->(n,alts!!n)) msg)) (pickSP alts)
+
+evalSpine [] = id
+evalSpine (x:xs) = evalSpine xs
diff --git a/hsrc/fudgets/MoreFileF.hs b/hsrc/fudgets/MoreFileF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/MoreFileF.hs
@@ -0,0 +1,44 @@
+module MoreFileF(
+  moreFileShellF,
+  moreShellF,moreShellF',
+  moreFileF
+) where
+import MoreF(moreF')
+import Command
+import CompOps((>==<), (>=^<), (>^=<), (>=^^<))
+import Shells(unmappedShellF, unmappedSimpleShellF)
+import Fudget
+import FRequest
+import ReadFileF(readFileF)
+--import Message(Message(..))
+import SpEither(toBothSP)
+import Spops(concmapSP)
+--import Xtypes
+import EitherUtils(stripEither)
+import FDefaults
+import InputMsg(InputMsg)
+import DialogueIO() -- instances, for hbc
+
+
+moreShellF' pmod name = unmappedSimpleShellF name $ moreF' pmod
+moreShellF = moreShellF' standard
+
+moreFileF :: F String (InputMsg (Int, String))
+moreFileF = moreFileF' standard
+moreFileF' pmod = moreF' pmod >=^< contents >==< readFileF
+
+moreFileShellF =
+  let startcmds = [XCmd $ StoreName "More Fudget"]
+      titleK = K{-kk-} $ concmapSP changeName  -- titleK never outputs anything
+  in stripEither >^=< unmappedShellF startcmds titleK moreFileF >=^^< toBothSP
+
+contents (name,file) =
+  case file of
+    Right s -> lines s
+    Left err -> [name++": "++show err] -- missing Show instance for IOError
+    --Left err -> [name++": error"]
+
+changeName msg =
+  case msg of
+    High name -> [Low $ XCmd $ StoreName name, Low $ XCmd MapRaised]
+    _ -> []
diff --git a/hsrc/fudgets/OnOffDispF.hs b/hsrc/fudgets/OnOffDispF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/OnOffDispF.hs
@@ -0,0 +1,30 @@
+module OnOffDispF where
+import CompOps((>=^<),(>^^=<))
+import NullF(F)
+import Spops(nullSP)
+--import Xtypes
+import ResourceIds() -- synonym ColorName, for hbc
+import Geometry(Point(..))
+import MeasuredGraphics(emptyMG)
+import GraphicsF(graphicsDispF',GfxCommand(..),setGfxEventMask)
+import FDefaults
+import GCAttrs
+--import Drawing( ) -- instances
+import Graphic( )
+import Defaults(bgColor, fgColor)
+import CmdLineEnv(argKey)
+import Sizing(Sizing(..))
+
+onOffDispF :: Bool -> F Bool nothing
+onOffDispF start = nullSP >^^=< graphicsDispF' custom >=^< pre
+  where
+    custom = setInitDisp (emptyMG dsize) . setGfxEventMask [] .
+	     setSizing Static . setBorderWidth 0 .
+	     setBgColor (color start)
+    color on = if on then onColor else offColor
+    dsize = Point 7 7
+    --pre :: Bool -> GfxCommand Bool -- resolving overloading...
+    pre = ChangeGfxBg . colorSpec . color
+
+offColor = argKey "toggleoff" bgColor
+onColor  = argKey "toggleon" fgColor
diff --git a/hsrc/fudgets/PopupMenuF.hs b/hsrc/fudgets/PopupMenuF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/PopupMenuF.hs
@@ -0,0 +1,90 @@
+module PopupMenuF(popupMenuF,oldPopupMenuF,oldPopupMenuF') where
+--import ButtonGroupF
+import Command
+import CompOps((>=^<), (>^=<),(>+<))--(>==<), 
+import InfixOps((>=..<))--(>^^=<),
+import Dlayout(groupF)
+import Event
+--import Font(FontStruct)
+import Fudget
+import FRequest
+--import Geometry(Line, Point, Rect, Size(..))
+import GreyBgF(changeBg)
+--import LayoutRequest(LayoutRequest)
+import MenuF(menuAltsF,toEqSnd,fstEqSnd,sndEqSnd)--EqSnd,
+import MenuPopupF(PopupMenu(..))
+import DynListF(dynF)
+--import Message(Message(..))
+import Path(here)
+import SerCompF(serCompLeftToRightF)--idRightF,
+import Spops
+import EitherUtils(mapEither)
+import Xtypes
+import CompSP(serCompSP)
+import Defaults(bgColor,menuFont)
+import Utils(pair)
+import NullF(delayF)
+--import ShowCommandF(showCommandF) -- debugging
+--import SpyF(teeF) -- debugging
+
+--popupMenuF :: [(alt,String)] -> F i o -> F (Either x i) (Either alt o)
+popupMenuF alts f =
+    mapEither fstEqSnd id>^=<
+    oldPopupMenuF bgColor True menuFont (Button 3) [] []
+                  (pre alts) sndEqSnd f
+    >=^< mapEither pre id
+  where
+    pre = map (`pair` []) . toEqSnd
+
+oldPopupMenuF bgcolor grab fname button mods keys alts show_alt f = 
+ serCompLeftToRightF $
+ oldPopupMenuF' bgcolor grab fname button mods keys alts show_alt f
+
+oldPopupMenuF' bgcolor grab fname button mods keys alts show_alt f =
+    let grabeventmask = [ButtonPressMask, ButtonReleaseMask]
+        grabcmd = if grab then [GrabButton True button mods grabeventmask]
+	          else []
+        eventmask =
+	  (if null keys then [] else [KeyPressMask, KeyReleaseMask]) ++
+          (if grab then [] else (OwnerGrabButtonMask:grabeventmask)) ++
+	  [LeaveWindowMask]
+        startcmds = grabcmd ++ [ChangeWindowAttributes [CWEventMask eventmask]]
+        ungrab = concatMapSP un where
+	       un (High m) = [High m,Low (here,XCmd UngrabEvents)]
+	       un m = [m]
+
+        F dynAltsFSP = dynAltsF
+	dynAltsF =
+	    dynF (altsF alts) >=^< mapEither altsF id
+	  where
+	    altsF alts' = delayF' (menuAltsF fname (map fst alts') show_alt)
+	     -- !! keyboard shortcuts ignored !!
+	    delayF' f = delayF f >=..< filterSP notDestroy
+	    --delayF' = id
+	    --delayF' f = delayF (showCommandF "altsF" f >==< teeF show "altsF: ")
+	    notDestroy (_,XEvt (DestroyNotify _)) = False
+	    notDestroy _ = True
+
+    in  (groupF (map XCmd startcmds)
+               (changeBg bgcolor (actionK grab button keys mods))
+               (F{-ff-} (ungrab `serCompSP` dynAltsFSP) >+< f))
+
+actionK grab button keys mods = K{-kk-} $ concmapSP action where
+    toF = High . Right
+    toMenu = High . Left . Right
+    newMenu = High . Left . Left
+    action msg = case msg of
+      High (Right hmsg) -> [toF hmsg]
+      High (Left alts) -> [newMenu alts] -- breaks backwards compatibility...
+      Low (XEvt ev) -> case ev of
+        ButtonEvent {rootPos=rootPos,state=m,type'=Pressed,button=b} | m == mods && b == button -> 
+	       [Low $ XCmd (GrabEvents True),toMenu (PopupMenu rootPos ev)]
+        KeyEvent {rootPos=rootPos,state=m,type'=Pressed,keySym=ks} | (m, ks) `elem` keys -> 
+	       [toMenu (PopupMenu rootPos ev)]
+        LeaveNotify {mode=NotifyUngrab} -> 
+	       [Low $ XCmd UngrabEvents,toMenu PopdownMenu]
+        ButtonEvent {type'=Released} -> 
+	       [Low $ XCmd UngrabEvents,toMenu PopdownMenu]
+        KeyEvent {type'=Released} -> [toMenu PopdownMenu]
+        _ -> []
+      Low _ -> []
diff --git a/hsrc/fudgets/PushButtonF.hs b/hsrc/fudgets/PushButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/PushButtonF.hs
@@ -0,0 +1,21 @@
+module PushButtonF(pushButtonF, pushButtonF', Click(..)) where
+import ButtonBorderF
+import ButtonGroupF
+import InputMsg(Click(..))
+import CompOps((>=^<))
+import Defaults(edgeWidth)
+--import Fudget
+import SerCompF(idRightF)
+
+pushButtonF = pushButtonF' edgeWidth
+
+pushButtonF' edgew keys f =
+    buttonGroupF keys (idRightF (buttonBorderF edgew f) >=^< prep)
+  where
+    toBorder = Left . Left
+    toFudget = Left . Right
+    through = Right
+    prep (Left BMNormal) = toBorder False
+    prep (Left BMInverted) = toBorder True
+    prep (Left BMClick) = through Click
+    prep (Right e) = toFudget e
diff --git a/hsrc/fudgets/QuitButtonF.hs b/hsrc/fudgets/QuitButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/QuitButtonF.hs
@@ -0,0 +1,21 @@
+module QuitButtonF where
+import Spacer(marginHVAlignF)
+import Alignment
+import DButtonF
+import FDefaults
+import CompOps((>==<))
+--import Defaults(buttonFont)
+--import Event(Event(..))
+--import Fudget
+--import PushButtonF
+import QuitF
+--import AuxTypes(Modifiers(..))
+import Defaults(metaKey)
+import Graphic( )
+
+quitButtonF =
+    quitF >==<
+    marginHVAlignF 0 aRight aBottom
+    (buttonF' (setKeys [([metaKey], "q")]) "Quit")
+
+
diff --git a/hsrc/fudgets/QuitF.hs b/hsrc/fudgets/QuitF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/QuitF.hs
@@ -0,0 +1,19 @@
+module QuitF(quitIdF, quitF) where
+import FudgetIO
+import HaskellIO
+import NullF
+import DialogueIO hiding (IOError) -- Exit
+
+--quitF :: F a b
+quitF =
+    getHigh $ \ _ ->
+    hIOSuccF (Exit 0) $
+    nullF
+
+--quitIdF :: (a -> Bool) -> F a a
+quitIdF p =
+    getHigh $ \ msg ->
+    (if p msg
+     then hIOSuccF (Exit 0)
+     else putHigh msg) $
+    quitIdF p
diff --git a/hsrc/fudgets/RadioF.hs b/hsrc/fudgets/RadioF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/RadioF.hs
@@ -0,0 +1,49 @@
+module RadioF(radioF, oldRadioGroupF) where
+import Spacer(noStretchF)
+--import Alignment(Alignment(..))
+--import ButtonGroupF
+import CompOps((>==<), (>=^<))
+import HbcUtils(lookupWithDefault)
+--import Fudget
+--import Geometry(Point, Rect, Size(..))
+import LayoutF(listLF)
+--import Placers
+import Loops(loopLeftF)
+import SerCompF(absF)
+import Spops
+import EitherUtils(stripEither)
+import ToggleButtonF(oldToggleButtonF')
+--import Xtypes
+import Utils(pair)
+
+radioF placer inside fname alts startalt =
+  oldRadioGroupF placer inside fname (map fst alts) startalt (lookupWithDefault alts (error "radioF"))
+
+oldRadioGroupF placer inside fname alts startalt show_alt =
+    let radioAlts = radioButtonsF placer inside fname alts show_alt
+        buttons = radioAlts >=^< stripEither
+    in  loopLeftF (excludeF startalt >==< buttons) >=^< (`pair` True)
+
+radioButtonsF placer inside fname alts show_alt =
+  listLF placer (map radiobutton alts)
+  where
+     radiobutton alt =
+        (alt, noStretchF False True $ 
+              oldToggleButtonF' inside fname [] (show_alt alt))
+
+excludeF start =
+    absF (putsSP [Left (start, True)] (excl start))
+  where
+    excl last' =
+      getSP $ \msg ->
+      case msg of
+	(new, False) -> if new == last'
+			then putsSP [Left (new, True)] (cont new)
+			else same
+	(new, True)  -> if new == last'
+		        then putsSP [Right new] (cont new)
+		        else putsSP [Left (last', False), Right new] (cont new)
+      where
+        same = excl last'
+	cont last'' = excl last''
+
diff --git a/hsrc/fudgets/StringF.hs b/hsrc/fudgets/StringF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/StringF.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE CPP #-}
+module StringF(
+  stringF'',StringF,
+  {-HasBorderWidth(..),HasAllowedChar(..),HasShowString(..),-}
+  getAllowedChar,setAllowedChar,getShowString,setShowString,
+  setInitStringSize,
+  getCursorPos,setCursorPos,getInitString,setInitString,
+  generalStringF, oldIntF, oldPasswdF, oldStringF, bdStringF, oldGeneralStringF
+  ) where
+import BgF(changeGetBackPixel)
+--import Color
+import Command
+import DrawInWindow
+import CompOps((>=^<), (>^=<))
+--import Utils(bitand)
+import HbcWord
+import Cursor
+import Defaults(defaultFont, inputFg, inputBg, metaKey)
+import CmdLineEnv(argKey, argKeyList)
+import Dlayout(windowF)
+import Event
+import Font(split_string,font_ascent,next_pos,linespace,font_id,string_box_size,font_range)
+import Fudget
+--import FudgetIO
+import FRequest
+import Xcommand
+import Gc
+import Xtypes
+import Geometry(Point(..), pP, rR,pmax)
+import LayoutRequest(plainLayout,LayoutResponse(..))
+--import LoadFont
+--import Message(Message(..))
+import NullF
+--import Spops
+import StringEdit
+import InputMsg(InputMsg(..),mapInp,inputLeaveKey)
+import InputF(InF(..))
+import SelectionF
+import Loops(loopThroughRightF)
+import Sizing
+#ifdef __GLASGOW_HASKELL__
+import FDefaults hiding (setInitSize,getInitSize,getInitSizeMaybe)
+#else
+-- Some versions of HBC fail if you mention a constructor class in an import spec.
+--import FDefaults hiding (HasInitSize)
+import FDefaults(cust,getpar,getparMaybe,HasBorderWidth(..),HasSizing(..),HasBgColorSpec(..),HasFgColorSpec(..),HasFontSpec(..),Customiser(..),PF(..))
+#endif
+import Data.Char(isPrint,isDigit)
+import GCAttrs --(ColorSpec,colorSpec,convColorK) -- + instances
+
+default(Int)
+
+-- chr/ord are defined in *some* versions of the library module Char...
+chr' = toEnum . wordToInt :: (Word->Char)
+ord' = fromIntegral . fromEnum :: (Char->Word)
+
+
+#include "defaults.h"
+
+newtype StringF = Pars [Pars]
+
+parameter(AllowedChar)
+parameter(ShowString)
+parameter(CursorPos)
+parameter(InitString)
+
+parameter_instance(BorderWidth,StringF)
+parameter_instance(FgColorSpec,StringF)
+parameter_instance(BgColorSpec,StringF)
+parameter_instance(FontSpec,StringF)
+parameter_instance(Sizing,StringF)
+--parameter_instance(InitSize,StringF) -- StringF has wrong kind for this
+parameter(InitSize)
+
+setInitStringSize = setInitSize -- avoid name clash
+
+data Pars
+  = BorderWidth Int
+  | FgColorSpec ColorSpec
+  | BgColorSpec ColorSpec
+  | FontSpec FontSpec
+  | AllowedChar (Char->Bool)
+  | ShowString (String->String)
+  | InitSize String
+  | Sizing Sizing
+  | CursorPos Int -- puts cursor after the nth character
+  | InitString String
+
+isTerminator key = key `elem` ["Escape", "Return", "KP_Enter", "Tab", "Up", "Down"]
+
+isBackSpace (c : _) = c == '\BS' || c == '\DEL'
+isBackSpace _ = False
+
+ctrl c = chr' (bitAnd (ord' c) (65535-96))
+
+isCtrl c (c':_) = c' == ctrl c
+isCtrl _ _      = False
+
+isKill = isCtrl 'u'
+
+modchar mods c0 = if metaKey `elem` mods then chr' (ord' c0 `bitOr` 128) else c0
+
+cursorBindings' =
+  [(([], "Left"), moveCursorLeft),
+   (([], "Right"), moveCursorRight),
+   (([], "Home"), moveCursorHome),
+-- (([], "Up"), moveCursorHome),
+   (([], "End"), moveCursorEnd),
+-- (([], "Down"), moveCursorEnd),
+--   (([Shift],"Control"), moveCursorHome), -- ???
+--   (([Shift],"Control"), moveCursorEnd), -- ???
+   (([Shift],"Left"), extendCursorLeft),
+   (([Shift],"Right"), extendCursorRight),
+   (([Shift],"Home"), extendCursorHome),
+   (([Shift],"Up"), extendCursorHome),
+   (([Shift],"End"), extendCursorEnd),
+   (([Shift],"Down"), extendCursorEnd)]
+   ++ emacsBindings
+
+emacsBindings = 
+  [(([Control], "b"), moveCursorLeft),
+   (([Control], "f"), moveCursorRight),
+   (([Control], "e"), moveCursorEnd),
+   (([Control], "a"), moveCursorHome)]
+
+cursorKey' mods key = lookup (filter (<=Mod5) mods,key) cursorBindings'
+
+hmargin = 3
+vmargin = 2
+
+placecursor font (Point x _) field =
+    case getField field of
+      [] -> field
+      cs -> let (lcs, rcs, _) = split_string font cs (x - hmargin)
+            in  createField2 (lcs, rcs)
+
+showinputfield gc gcinv font show' = showinputfield'
+  where
+    drimstr = if snd (font_range font) > '\xff'
+              then wDrawImageString16
+	      else wDrawImageString
+
+    showinputfield' active field =
+      let y = font_ascent font + 1
+	  draw x s = if null s then [] else [drimstr gc (pP x y) s]
+	  showpart gc' s0 (x, cmds) =
+	      let s = show' s0
+	      in  (x + next_pos font s, draw x s ++ cmds)
+	  showcursor s (x1, cmds) =
+	      let (x2, cmds') = showpart gc s (x1, cmds)
+		  cmd = if active
+			then [wFillRectangle gcinv
+					     (rR (x1 - 1) 1
+						 (x2 - x1 + 1) (linespace font))]
+		        else []
+	      in  (x2, cmds' ++ cmd)
+      in  snd (showField (showpart gc) showcursor field (hmargin, []))
+
+createField' pos s =
+  if pos<0
+  then createField s
+  else createField2 (splitAt pos s)
+
+stringK bw initsize sizing bgcolor fgcolor fontspec allowedchar show' cursor defaultText active =
+    setFontCursor 152 $
+    xcommandK (ConfigureWindow [CWBorderWidth bw]) $
+    changeGetBackPixel bgcolor $ \bg ->
+    convColorK fgcolor $ \fg ->
+    convFontK fontspec $ \ fd ->
+    fontdata2struct fd $ \ font ->
+    wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id font),
+                      GCForeground fg, GCBackground bg] $ \drawGC ->
+    wCreateGC rootGC (invertColorGCattrs bg fg) $ \invertGC ->
+    let drawit field active = map Low (XCmd ClearWindow : drawcmds)
+          where drawcmds = shinpf active field
+	shinpf = showinputfield drawGC invertGC font show'
+	stringproc size' field active =
+	   let redraw f =
+	         putsK (drawit f active) (stringproc size' f active)
+	       nochange = stringproc size' field active
+	       newsize s = stringproc s field active
+	       changeactive a = putsK (drawit field a) $
+	                        stringproc size' field a
+	       emit msg f a = putsK (drawit f a ++ [High (Right msg)]) $
+	                      stringproc size' f a
+	       emitchange f =
+	          let gf = getField f
+		  in  updlayout size' gf (emit (InputChange gf) f active)
+	       emitdone key f = emit (InputDone key (getField f)) f active
+	       emitleave =
+	         emit (InputDone inputLeaveKey (getField field)) field False
+	       paste = putK (High (Left PasteSel)) nochange
+	       copy = putK (High (Left (Sel (getField field)))) nochange
+	   in getK $ \msg ->
+	      case msg of
+	        Low (XEvt event) ->
+		  case event of
+	            Expose _ _ -> redraw field
+		    KeyEvent _ _ _ mods Pressed _ key ascii ->
+		      case ascii of
+			c0 : _ | allowedchar c -> ec (insertItem field c)
+			   where c = modchar mods c0
+			_ | isTerminator key ->
+			       emitdone key (createField (getField field))
+			  | isBackSpace ascii -> ec (deleteItemLeft field)
+			  | isCtrl 'd' ascii  -> ec (deleteItemRight field)
+			  | isCtrl 'k' ascii  -> ec (deleteToEnd field)
+			  | isCtrl 'y' ascii  -> paste
+			  | isCtrl 'c' ascii  -> copy
+			  | isCtrl 'w' ascii  -> copy -- should acutally be cut
+			  | isKill     ascii  -> ec (createField "")
+			  | otherwise ->
+			       case cursorKey' mods key of
+				 Just ed -> redraw (ed field)
+				 _ -> case key of
+					"SunPaste" -> paste
+					"SunCopy" -> copy
+					_ -> --putK (Low (Bell 0)) $
+					     nochange
+		       where ec = emitchange
+	            ButtonEvent {pos=p, button=Button 1} ->
+		      redraw (placecursor font p field)
+	            ButtonEvent {button=Button 2} -> paste
+		    FocusIn  {} -> changeactive True
+		    FocusOut {} -> emitleave
+                    _ -> nochange
+		Low (LEvt (LayoutSize nsize)) -> newsize nsize
+		High (Right (Right newtext)) ->
+		   if newtext/=getField field
+		   then emitchange (createField newtext)
+		   --else updlayout size' newtext (redraw (createField newtext))
+		   else nochange
+		High (Right (Left customiser)) ->
+		  reconfigure customiser field active
+		High (Left (SelNotify cs)) ->
+		     emitchange (insertItemsSelected field s)
+		   where s = filter allowedchar cs
+		_ -> nochange
+
+	reconfigure pmod field active =
+	    -- !! unload fonts, free GCs & colors...
+	    stringK bw' initsize' sizing' bgcolor' fgcolor' fontspec' allowed' show'' cursor' txt' active
+	    -- !!! Bad: active will be reset to False.
+	    -- !! A new layout request will be output (useful if font changed).
+	  where ps = pmod (Pars [BorderWidth bw,
+                                 BgColorSpec bgcolor,
+				 FgColorSpec fgcolor,
+				 FontSpec fontspec,
+				 AllowedChar allowedchar,
+				 ShowString show',
+				 CursorPos (-1), -- !!
+				 InitSize initsize,
+				 Sizing sizing])
+		bw' = getBorderWidth ps
+		initsize' = txt' --getInitSize ps -- hmm !!
+		sizing' = getSizing ps
+		bgcolor' = getBgColorSpec ps
+		fgcolor' = getFgColorSpec ps
+		fontspec' = getFontSpec ps
+		allowed' = getAllowedChar ps
+		show'' = getShowString ps
+		txt' = getField field
+		cursor' = getCursorPos ps
+
+	sizetext text = pP (2*hmargin) (2*vmargin) + string_box_size font text
+	size = pmax (sizetext defaultText) (sizetext initsize)
+	updlayout curSize gf =
+	   let reqSize = sizetext gf
+	       nsize = newSize sizing curSize reqSize
+	   in if nsize /= curSize then putlayoutlims nsize else id
+	putlayoutlims size' =
+	   putK (Low (layoutRequestCmd (plainLayout size' False True)))
+    in putlayoutlims size $
+       stringproc size (createField' cursor defaultText) active
+
+generalStringF bw initsize sizing bg fg fontspec allowedchar show' cursor txt =
+   loopThroughRightF winF selectionF
+  where
+    eventmask = [ExposureMask, KeyPressMask, ButtonPressMask,
+		 EnterWindowMask, LeaveWindowMask -- to be removed
+		 ]
+    startcmds = [XCmd $ 
+                 ChangeWindowAttributes [CWBitGravity NorthWestGravity,
+					 CWEventMask eventmask
+					 {-,CWBackingStore Always-}]
+		]
+    winF = windowF startcmds 
+	           (stringK bw initsize sizing bg fg fontspec
+		            allowedchar show' cursor txt False)
+
+stringF'' :: (Customiser StringF) -> PF StringF String (InputMsg String)
+stringF'' pmod = generalStringF bw initsize sizing bg fg font allowed show cursor initstring
+  where
+    ps = pmod (Pars [BorderWidth 1,
+                     BgColorSpec inputbg,
+		     FgColorSpec inputfg,
+		     FontSpec stringfont,
+		     AllowedChar isPrint',
+		     ShowString id,
+		     InitSize "xxxxx",
+		     Sizing Growing,
+		     CursorPos (-1),
+		     InitString ""])
+    bw = getBorderWidth ps
+    bg = getBgColorSpec ps
+    fg = getFgColorSpec ps
+    font = getFontSpec ps
+    allowed = getAllowedChar ps
+    show = getShowString ps
+    --initsize = "xxxxx"
+    initsize = getInitSize ps
+    sizing = getSizing ps
+    cursor = getCursorPos ps
+    initstring = getInitString ps
+
+
+oldGeneralStringF bw sizing font allowed show txt =
+  generalStringF bw "xxxxx" sizing inputbg inputfg font allowed show (-1) txt >=^< Right
+
+bdStringF bw dyn font = oldGeneralStringF bw dyn font isPrint' id
+
+oldStringF :: String -> InF String String
+oldStringF = bdStringF 1 Growing stringfont
+
+oldPasswdF :: String -> InF String String
+oldPasswdF = oldGeneralStringF 1 Static stringfont isPrint' (map (const '*'))
+
+oldIntF :: Int -> InF Int Int
+oldIntF default' =
+    mapInp read >^=<
+    oldGeneralStringF 1 Static stringfont isDigit id (show default') >=^<
+    show
+
+stringfont = fontSpec (argKey "inputfont" defaultFont)
+inputbg = colorSpec (argKeyList "stringbg" [inputBg])
+inputfg = colorSpec (argKeyList "stringfg" [inputFg])
+
+-- Workaround limitations of HBC's Char.isPrint to allow Unicode input.
+isPrint' c = c>'\xff' || isPrint c
diff --git a/hsrc/fudgets/TerminalF.hs b/hsrc/fudgets/TerminalF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/TerminalF.hs
@@ -0,0 +1,130 @@
+module TerminalF(terminalF,cmdTerminalF,TerminalCmd(..)) where
+import Spacer(marginF)
+--import Alignment(Alignment(..))
+import BgF
+import Color
+import Command
+import FRequest
+import DrawInWindow(wDrawImageString,wDrawImageString16,wCopyArea)
+import XDraw
+import Defaults(paperColor, fgColor)
+import Dlayout(simpleGroupF, windowF)
+import Event
+import Font
+import Fudget
+--import FudgetIO
+import Gc
+import Geometry(Point(..), Rect(..), origin, pP, padd,)-- rectsize
+import LayoutRequest
+--import Placer(spacerF)
+--import Spacers
+import LoadFont
+--import Message(Message(..))
+import NullF
+import StateMonads
+--import EitherUtils(mapMaybe, stripMaybeDef)
+import Xtypes
+import CompOps
+import GCAttrs() -- instances
+
+grmarginF m f = simpleGroupF [] (marginF m f)
+
+data TerminalCmd
+  = TermText String -- add string on a new line
+  | TermAppend String -- append string to last line
+  | TermClear
+
+terminalF :: FontName -> Int -> Int -> F String a
+terminalF fname nrows ncols = cmdTerminalF fname nrows ncols >=^< TermText
+
+cmdTerminalF :: FontName -> Int -> Int -> F TerminalCmd a
+cmdTerminalF fname nrows ncols =
+    let wattrs = [CWBackingStore WhenMapped, CWEventMask [ExposureMask]]
+    in  grmarginF 2
+                (windowF [XCmd $ ChangeWindowAttributes wattrs,
+			  XCmd $ ConfigureWindow [CWBorderWidth 1]]
+                         (terminalK fname nrows ncols))
+
+terminalK fname nrows ncols =
+    safeLoadQueryFont fname $ \fs ->
+    allocNamedColorPixel defaultColormap fgColor $ \fg ->
+    changeGetBackPixel paperColor $ \bg ->
+    wCreateGC rootGC [GCFunction GXcopy, GCFont (font_id fs), GCForeground fg, GCBackground bg]
+				 (terminalK1 fs nrows ncols)
+
+m1 $$$ m2 = m1>>m2
+
+m1 $> xm2 = m1 >>= xm2
+
+terminalK1 fs nrows ncols gc =
+    let charsize@(Point charw charh) = string_box_size fs "M"
+        startsize = curpos nrows ncols
+        size = startsize
+        curpos row col = pP (charw * col) (charh * row)
+        drawpos row col = padd (curpos row col) (pP 0 (font_ascent fs))
+	drimstr = if snd (font_range fs) > '\xff'
+		  then wDrawImageString16
+		  else wDrawImageString
+        k =
+            getKs $>
+            (\msg ->
+             (case msg of
+                Low (XEvt (Expose _ 0)) -> redraw
+                Low (LEvt (LayoutSize newsize)) -> setSize newsize
+                Low _ -> nopMs
+                High cmd -> case cmd of
+		  TermText line -> addDrawLine line
+		  TermAppend s -> appendDrawLine s
+		  TermClear -> clearit) $$$
+             k)
+        drawline (r, l) =
+            loadMs $>
+            (\(lines', row, col, nrows', ncols') ->
+             putLowMs (drimstr gc (drawpos r 0) l))
+        redraw =
+            loadMs $>
+            (\(lines', row, col, nrows', ncols') ->
+             putLowMs clearWindow $$$
+             foldr (\l -> (drawline l $$$)) nopMs (zip [0 ..] (reverse lines')))
+        setSize (Point x y) =
+            loadMs $>
+            (\(lines', row, col, nrows', ncols') ->
+             let ncols'' = x `quot` charw
+                 nrows'' = y `quot` charh
+                 row' = row `min` nrows''
+                 col' = col `min` ncols''
+                 lines'' = take nrows'' lines'
+             in  storeMs (lines'', row', col', nrows'', ncols'') $$$ redraw)
+        addLine line =
+            loadMs $>
+            (\(lines', row, col, nrows', ncols') ->
+             if row < nrows' - 1 then
+                 let lines'' = line : lines'
+                     row' = row + 1
+                 in  storeMs (lines'', row', col, nrows', ncols')
+             else
+                 let lines'' = take nrows' (line : lines')
+                 in  storeMs (lines'', row, col, nrows', ncols') $$$
+                     putLowsMs [wCopyArea gc
+                                           MyWindow
+                                           (Rect (pP 0 charh)
+                                                 (curpos (nrows' - 1) ncols'))
+                                           origin,
+                                clearArea  (Rect (curpos row 0)
+                                                 (curpos 1 ncols'))
+                                           False])
+        appendLine s =
+            loadMs $> \(lines', row, col, nrows', ncols') ->
+	    case lines' of
+	      []   -> storeMs ([s],row+1,col,nrows',ncols')
+	      l:ls -> storeMs ((l++s):ls, row, col, nrows', ncols')
+        clearit = loadMs $> \(lines, row, col, nrows, ncols) ->
+		  storeMs ([],-1,0,nrows,ncols) $$$ redraw
+        addDrawLine line =
+            (addLine line $$$ loadMs) $> 
+            (\(lines', row, col, nrows', ncols') -> drawline (row, line))
+	appendDrawLine s =
+	    (appendLine s $$$ loadMs) $>
+            (\(line:_, row, col, nrows', ncols') -> drawline (row, line))
+    in  putK (Low (layoutRequestCmd (plainLayout size False False))) $
+        stateK ([], -1, 0, nrows, ncols) k nullK
diff --git a/hsrc/fudgets/TextF.hs b/hsrc/fudgets/TextF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/TextF.hs
@@ -0,0 +1,300 @@
+{-# LANGUAGE CPP #-}
+module TextF(textF,textF',textF'',TextF,
+	     TextRequest(..)) where
+import Fudget
+import FudgetIO
+import FRequest
+import NullF
+import Utils
+import Geometry
+import Xtypes
+import Event
+import Command
+import XDraw
+import Dlayout
+import DoubleClickF
+import BgF
+--import Color
+--import EitherUtils(mapfilter)
+import Data.Maybe(mapMaybe)
+import Message(message) --Message(..),
+import Font
+--import LoadFont
+import Gc
+import InputMsg
+import LayoutRequest
+import Alignment(aLeft) --Alignment(..),
+import Defaults(defaultFont,bgColor,fgColor)
+import Sizing
+import FDefaults
+import GCAttrs --(ColorSpec,convColorK,colorSpec)
+import ListRequest(ListRequest(..),listEnd)
+#include "../defaults/defaults.h"
+
+default(Int) -- mostly for Hugs
+
+
+#ifndef __HBC__
+#define fromInt fromIntegral
+#endif
+
+type TextRequest = ListRequest String
+
+newtype TextF = Pars [Pars]
+
+data Pars
+  = BorderWidth Int
+  | FgColorSpec ColorSpec
+  | BgColorSpec ColorSpec
+  | FontSpec FontSpec
+  | Align Alignment
+  | Margin Int
+  | InitText [String]
+--  | InitSize String
+  | Stretchable (Bool,Bool)
+  | Sizing Sizing
+
+parameter_instance(BorderWidth,TextF)
+parameter_instance(FgColorSpec,TextF)
+parameter_instance(BgColorSpec,TextF)
+parameter_instance(FontSpec,TextF)
+parameter_instance(Align,TextF)
+parameter_instance(Margin,TextF)
+parameter_instance(InitText,TextF)
+--parameter_instance(InitSize,TextF)
+parameter_instance(Sizing,TextF)
+parameter_instance(Stretchable,TextF)
+
+textF = textF' standard
+textF' pm = noPF $ textF'' pm
+
+textF'' :: Customiser TextF ->
+           PF TextF TextRequest (InputMsg (Int, String))
+textF'' pmod =
+  let ps :: TextF
+      ps = pmod (Pars [BorderWidth 0,
+                       FgColorSpec textfg,
+		       BgColorSpec textbg,
+		       Margin 2,
+		       Align aLeft,
+		       InitText [],--InitSize "",
+		       Stretchable (False,False),
+		       Sizing Dynamic,
+		       FontSpec (fontSpec defaultFont)])
+      bw = getBorderWidth ps
+      fg = getFgColorSpec ps
+      bg = getBgColorSpec ps
+      font = getFontSpec ps
+      init = getInitText ps
+      minstr = "" --getInitSize ps
+      margin = getMargin ps
+      align = getAlign ps
+      sizing = getSizing ps
+      stretch = getStretchable ps
+
+      eventmask = [ExposureMask, ButtonPressMask]
+      startcmds = map XCmd 
+                  [ConfigureWindow [CWBorderWidth bw],
+  		   ChangeWindowAttributes
+		     [CWEventMask eventmask
+		      ,CWBitGravity (horizAlignGravity align)
+		      ,CWBackPixmap none -- elim flicker caused by XClearArea
+		      ]]
+  in doubleClickF doubleClickTime $
+     windowF startcmds $ textK0 bg fg font stretch align sizing margin minstr init
+
+
+textK0 bg fg font (flexh,flexv) align sizing margin minstr init =
+    changeGetBackPixel bg $ \ bgcol ->
+    convColorK fg $ \ fgcol ->
+    --allocNamedColorPixel defaultColormap fg $ \ fgcol ->
+    convFontK font $ \ fd ->
+    fontdata2struct fd $ \ fs ->
+    wCreateGC rootGC [GCFont (font_id fs),
+  		      GCForeground fgcol,
+		      GCBackground bgcol] $ \gc ->
+    wCreateGC gc     [GCForeground bgcol,
+		      GCBackground fgcol] $ \gcinv ->
+    let minw = next_pos fs minstr
+    in textK1 bgcol gc gcinv fs (not flexh) (not flexv) align sizing margin minw init
+
+textK1 bgcol gc gcinv fs fh fv align sizing margin minw =
+    replaceTextK origin origin [] [] 0 listEnd
+  where
+    ll size = Low (layoutRequestCmd (plainLayout size fh fv))
+    ls = linespace fs
+    base = font_ascent fs + margin
+    margsize = diag (2*margin)
+
+    measure = map (pairwith (next_pos fs))
+    txtwidth mtxt = maximum (1:minw:map snd mtxt)
+                         -- 0 width not allowed for windows
+
+    drimstr = if snd (font_range fs) > '\xff'
+              then DrawImageString16
+	      else DrawImageString
+
+    txtsize mtxt =
+      let width = txtwidth mtxt
+	  height = max 1 (ls*length mtxt)  -- 0 height not allowed for windows
+      in Point width height
+
+    replaceTextK winsize@(Point winwidth winheight) size sel mtxt dfrom dcnt newtxt=
+      let lines     = length mtxt
+	  from      = min lines (if dfrom==listEnd then lines else dfrom)
+	  after     = lines-from
+	  cnt       = min after (if dcnt==listEnd then after else dcnt)
+	  newcnt    = length newtxt
+	  diff      = newcnt-cnt
+	  scrollsize= after-cnt
+	  newlines  = lines+diff
+	  sel'      = mapMaybe reloc sel
+	  reloc n   = if n<from then Just n
+		      else if n<from+cnt then Nothing
+		      else Just (n+diff)
+	  mtxt'     = take from mtxt ++ measure newtxt ++ 
+		      (if scrollsize>0 then drop (from+cnt) mtxt else [])
+	  newwidth  = txtwidth mtxt'
+	  newsize   = Point newwidth (ls*newlines)
+	  llcmd     = let realwinsize@(Point w h) = winsize+diag margin
+	                  winsize'@(Point w' h') = newsize +margsize
+	                  change =
+			    winsize==origin ||
+			    newSize sizing realwinsize winsize'/=realwinsize
+	              in if change
+		      then [ll (newsize + margsize)]
+		      else []
+	  --width     = xcoord size
+	  drawwidth = max newwidth (winwidth-margin)
+		       -- !! always scrolls/clears the full width of the window
+	  scrollrect= rR margin (margin+ls*(from+cnt))
+	                 drawwidth (ls*scrollsize)
+	  scrolldest= Point margin (margin+ls*(from+newcnt))
+	  scrollcmd = if scrollsize>0 && diff/=0
+		      then [Low (wDraw gc $ CopyArea MyWindow scrollrect scrolldest)]
+		      else []
+	  drawrect  = rR margin (margin+ls*from) (drawwidth+margin) (ls*newcnt)
+	                 -- add margin to width to erase text in the margin
+			 -- when the text is wider than the window.
+	  belowrect = rR margin (margin+ls*newlines) drawwidth (-ls*diff)
+	  clearcmd  = (if newcnt>0
+		       then let vrect = growrect drawrect (pP 5 5) -- !! tmp fix
+		           in clearArea drawrect True++
+		              [Low (LCmd (layoutMakeVisible vrect))]
+		       else [])++
+		       (if diff<0
+		        then [Low $ XCmd $ ClearArea belowrect False]
+			     -- Needed because of margin and other things
+			     -- that cause the window to be taller than the
+			     -- text.
+			     -- clearcmd must be done after scrollcmd !!
+			else [])
+	  clearArea r e = map (Low . XCmd) 
+	                  [ChangeWindowAttributes [CWBackPixmap none],
+	                   ClearArea r e,
+			   ChangeWindowAttributes [CWBackPixel bgcol]]
+			-- Some backround may be lost if the windows becomes
+			-- obscured while the BackPixmap is none !!!
+      in if diff>0
+	 then resizeK llcmd $ \ newwinsize ->
+	      putsK (scrollcmd++clearcmd) $
+	      textK (newwinsize - diag margin) newsize sel' mtxt'
+	 else putsK (scrollcmd++clearcmd++llcmd) $
+	      textK winsize newsize sel' mtxt'
+
+    textK :: Size -> Size -> [Int] -> [(String,Int)] ->
+             PK TextF TextRequest (InputMsg (Int,String))
+    textK winsize@(Point winwidth _) size sel mtxt =
+       -- winsize is the size of the window excluding the right & bottom margins
+	getK $ message lowK (either paramChangeK textRequestK)
+      where
+        same = textK winsize size sel mtxt
+	textRequestK msg =
+	    case msg of
+	      ReplaceItems dfrom dcnt newtxt ->
+		replaceTextK winsize size sel mtxt dfrom dcnt newtxt
+	      HighlightItems sel' ->
+		changeHighlightK sel' $
+		textK winsize size sel' mtxt
+	      PickItem n -> output inputMsg n
+	      _ -> same
+	lowK event =
+	    case event of
+	      XEvt (ButtonEvent {button=Button 1,pos=Point _ y, type'=press}) ->
+		let l=y `quot` ls
+		    pressmsg = case press of
+				 MultiClick 2 -> inputMsg
+				 _ -> InputChange
+		in output pressmsg l
+	      XEvt (Expose {rect=r}) ->
+		redrawTextK r $
+		same
+	      XEvt (GraphicsExpose {rect=r}) ->
+		redrawTextK r $
+		same
+	      LEvt (LayoutSize newwinsize) ->
+	        textK (newwinsize - diag margin) size sel mtxt
+	      _ -> same
+	paramChangeK _ = same -- !!! Dynamic customisation not implemented yet
+        output pressmsg l = (if l>=0 && l<length mtxt
+	                     then putK (High (pressmsg (l,fst(mtxt!!l))))
+			     else id) $ same
+
+	changeHighlightK sel' =
+	    putsK (mkvis++[Low $ wDrawMany (map draw changes)])
+	  where
+	    changed n = (n `elem` sel) /= (n `elem` sel')
+	    nmtxt = number 0 mtxt
+	    changes = [l | l@(n,_)<-nmtxt, changed n]
+	    selected = [l | l@(n,_)<-nmtxt, n `elem` sel']
+	    draw (n,(s,w)) = (dgc sel' n,[drimstr (Point (x0 w) (base+n*ls)) s])
+	    mkvis =
+	      case (selected,last selected) of -- needs lazy evalution!
+		([],_) -> []
+		((n1,(_,w1)):_,(n2,(_,w2))) ->
+		    [Low (LCmd (layoutMakeVisible vrect))]
+		  where vrect = rR x1 y1 (x2-x1+5) (y2-y1+5)
+                        x1 = min (x0 w1) (x0 w2) -- !!! Should use min/max
+			x2 = max (x0 w1) (x0 w2) -- !!! of all changes.
+			y1 = n1*ls
+			y2 = (n2+1)*ls
+
+	redrawTextK r@(Rect (Point x y) (Point w h)) =
+	  let first = (max 0 (y-margin)) `quot` ls
+	      last = (y+h-1) `quot` ls
+	      lines = number first (take (last-first+1) (drop first mtxt))
+	      firsty = base+ls*first
+	      ys = [firsty,firsty+ls..]
+	  in putsK [Low $ XCmd $ ClearArea r False,
+		    Low $ wDrawMany
+	             [(dgc sel n,[drimstr (Point x1 ly) s]) | 
+		     ((n,s,x1,x2),ly)<-zip (map xi lines) ys,x<x2 && (x+w)>=x1]]
+		     -- !! The x coordnates should probably be stored
+		     -- rather than recomputed every time the text is
+		     -- redrawn...
+
+        xi (n,(s,w)) = (n,s,x1,x2) where x1=x0 w; x2=x1+w
+        x0 w = margin+floor (align*fromInt (winwidth-margin-w))
+	       -- !!! Problem: can't be sure that bitgravity moves stuff
+	       -- to the same pixel coordinates that are computed here...
+
+    dgc sel n = if n `elem` sel -- inefficient !!
+                then gcinv
+		else gc
+
+resizeK cmd cont = putsK cmd $ waitForMsg ans $ cont
+  where ans (Low (LEvt (LayoutSize newsize))) = Just newsize
+        ans _ = Nothing
+
+doubleClickTime = 400 -- The double click timeout should not be hard wired like this...
+textbg = colorSpec [bgColor,"white"]
+textfg = colorSpec [fgColor,"black"]
+
+horizAlignGravity align =
+    case (align::Alignment) of
+      0 -> NorthWestGravity
+      0.5 -> NorthGravity
+      1 -> NorthEastGravity
+      _ -> ForgetGravity
+
+--take' n | n>=0 = take n
diff --git a/hsrc/fudgets/ToggleButtonF.hs b/hsrc/fudgets/ToggleButtonF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/ToggleButtonF.hs
@@ -0,0 +1,37 @@
+module ToggleButtonF(toggleF, oldToggleButtonF, oldToggleButtonF') where
+--import Alignment
+import Spacer(marginF)
+import CompOps((>=^<), (>^=<),(>+<),(>=^^<))
+import CompSP(idRightSP)
+import SpEither(filterRightSP)
+import Spacers(compS,vCenterS,noStretchS)--,centerS,hvAlignS,spacerP
+--import Placers(horizontalP)
+import Placer(hBoxF,spacer1F)
+import EitherUtils(stripEither)
+import OnOffDispF
+import ButtonBorderF
+import ToggleGroupF
+--import Geometry(Point(..))
+import GraphicsF(graphicsLabelF')
+import Defaults(look3d, edgeWidth)
+import FDefaults -- setFont
+
+toggleF inside keys lblF =
+   toggleGroupF keys $
+   if inside
+   then buttonBorderF edgew (mF lblF) >=^^< idRightSP filterRightSP
+   else stripEither >^=< hBoxF (sF (buttonBorderF edgew indicatorF) >+< cF lblF)
+ where
+    indicatorF = mF (onOffDispF False)
+    mF = marginF innersep
+    sF = spacer1F (noStretchS True True `compS` vCenterS)
+    cF = spacer1F (noStretchS False True `compS` vCenterS)
+    innersep = 2
+    edgew    = if look3d then edgeWidth else max 0 (edgeWidth-1)
+
+oldToggleButtonF x = oldToggleButtonF' False x
+
+oldToggleButtonF' inside fname keys lbl =
+    stripEither >^=< toggleF inside keys lblF >=^< Left
+  where
+    lblF = graphicsLabelF' (setFont fname) lbl
diff --git a/hsrc/fudgets/ToggleGroupF.hs b/hsrc/fudgets/ToggleGroupF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/fudgets/ToggleGroupF.hs
@@ -0,0 +1,25 @@
+module ToggleGroupF(toggleGroupF) where
+import ButtonGroupF
+import CompOps((>=^^<))
+import Spops(mapstateSP)
+import Fudget
+--import Geometry(Line(..), Point(..), Rect(..), Size(..))
+--import Message(Message)
+import SerCompF(idLeftF)
+import Xtypes(KeySym(..), ModState(..))
+
+toggleGroupF :: [(ModState, KeySym)] -> (F (Either (Either Bool Bool) a) b) -> F (Either Bool a) (Either Bool b)
+toggleGroupF keys f =
+    let toPressed = Right . Left . Left
+        toStateF = Right . Left . Right
+        toFudget = Right . Right
+        through = Left
+        change s = (s, [toStateF s, through s])
+        prep s (Right (Left ns)) = change ns
+        prep s (Left BMClick) = change (not s)
+        prep s (Left BMNormal) = (s, [toPressed False])
+        prep s (Left BMInverted) = (s, [toPressed True])
+        prep s (Right (Right m)) = (s, [toFudget m])
+    in  buttonGroupF keys (idLeftF f >=^^< mapstateSP prep False)
+
+
diff --git a/hsrc/ghc-dialogue/AsyncInput.hs b/hsrc/ghc-dialogue/AsyncInput.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/AsyncInput.hs
@@ -0,0 +1,415 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -optc-DNON_POSIX_SOURCE -fvia-C -}
+--
+module AsyncInput
+   (doSocketRequest,doSelect,getAsyncInput',initXCall,XCallState)
+  where
+import P_IO_data({-Request(..),-}Response(..))
+import Xtypes
+import Sockets as S
+import DLValue
+import Unsafe.Coerce -- !!!
+--import ResourceIds
+import Utils(swap)
+
+import XCallTypes
+import StructFuns
+import Xlib
+import EncodeEvent
+import Marshall
+import MyForeign
+import GHC.Exts(addrToAny# )
+import GHC.Ptr(FunPtr(..))
+
+--import Ap
+import HbcUtils(lookupWithDefault)
+import Data.Maybe(mapMaybe)
+import Control.Monad(when)
+import Data.Traversable(traverse)
+
+import PQueue
+
+import Data.IORef(newIORef,readIORef,writeIORef,IORef)
+import System.Posix.DynamicLinker as DL
+
+import PackedString(unpackPS,lengthPS{-,packCBytesST,psToByteArray-})
+
+default (Int)
+
+#include "newstructfuns.h"
+
+H_STRUCTTYPE(fd_set)
+
+allocaInt = allocaElem (0::Int)
+
+type AiTable = [(Fd,Descriptor)]
+
+type IOVar a = IORef a
+
+newIOVar = newIORef
+readIOVar = readIORef
+writeIOVar = writeIORef
+
+type MsTime = Int
+
+data XCallState = XCallState
+      Cfd_set -- ^ read fd_set
+      (IOVar Fd) -- ^ highest fd in read fd_set
+      (IOVar AiTable)
+      (IOVar (PQueue MsTime (MsTime,Timer)))
+      (IOVar Time)
+
+initXCall =
+ XCallState
+  <$> newPtr
+  <*> newIOVar 0
+  <*> newIOVar []
+  <*> newIOVar empty
+  <*> newIOVar 0
+
+type Fd = Int32
+
+foreign import ccall "unistd.h read" cread :: Fd -> Addr -> CSize -> IO CSize
+foreign import ccall "unistd.h write" cwrite :: Fd -> CString -> CSize -> IO CSize
+foreign import ccall "sys/socket.h" accept :: Fd -> CsockAddr -> Addr -> IO Fd
+
+getAsyncInput' (XCallState fds maxfdvar aitable tq tno) =
+ AsyncInput <$> do
+   ai <- readIOVar aitable
+   let timeLeft =
+	  do tqv <- readIOVar tq
+	     case inspect tqv of
+	       Nothing -> return Nothing
+	       Just ((t,_),_) ->
+		 do ms <- mstime
+		    return . Just . max 0 $ t - ms
+   
+   let doSelect = do
+	  timeout <- traverse newTimeVal =<< timeLeft
+          readfds <- newPtr
+--	  _casm_ ``bcopy(%0,%1,sizeof(fd_set));'' fds readfds
+	  bcopy_fdset fds readfds
+          maxfdvar <- readIOVar maxfdvar
+	  n <- select (maxfdvar+1) readfds timeout
+	  maybe (return ()) freePtr timeout
+	  let findFd fd = do
+		  s <- fromC <$>
+--		       _casm_ ``%r=FD_ISSET(%0,(fd_set*)%1);'' fd readfds
+		       fd_isset fd readfds
+		  if not s then findFd (fd+1) 
+		    else let d = lookAi fd in case d of
+		       DisplayDe _ -> mkEvent fd d
+		       SocketDe _ ->
+		         let bufsize = 2000
+			 in alloca bufsize $ \ buf ->
+			 do got <- tryP "read" (>=0) $ cread fd buf (fromIntegral bufsize)
+			    str <- unmarshallString' (CString buf) (fromIntegral got)
+			    return (d,SocketRead str)
+		       LSocketDe _ ->
+		         allocaInt $ \ addrlen ->
+			 do addr <- newsockAddr
+			    sfd <- tryP "accept" (>=0) $ 
+				--_ccall_ ACCEPT fd addr addrlen
+				accept fd addr addrlen
+			    sf <- getfilep sfd "r+"
+			    --buf <- stToIO $ newCharArray (1,1000)
+			    --tryP "hostName" (==0) $ _ccall_ hostName addr buf
+			    --peer <- cstring <$> mutByteArr2Addr buf
+			    let peer = ""
+			    return (d,SocketAccepted (So sf) peer)
+
+		       _ -> error "getAsyncInput3"
+          e <- if n == -1 then error . ("select "++) =<< strerror =<< errno
+	       else if n > 0 then findFd 0
+	            else do tno <- removetimeq tq
+	                    return (TimerDe tno,TimerAlarm)
+	  freePtr readfds
+	  return e
+
+       mkEvent fd d = do
+           (window,fev) <- {-motionCompress display =<<-} getNextEvent display
+	   return (descriptor,XEvent (window,fev))
+         where descriptor@(DisplayDe display) = d
+         
+       lookAi = lookupWithDefault ai (error "getAsyncInput2")
+       dispde x@(fd,DisplayDe _) = Just x
+       dispde _ = Nothing
+   case mapMaybe dispde ai of
+       [] -> doSelect
+       (fd,d@(DisplayDe display)):_ -> do
+         q <- xPending display
+         if q>0 then mkEvent fd d else doSelect
+
+newTimeVal tleft =
+  do timeout <- newPtr
+     SET(timeVal,Int,timeout,tv_usec,(tleft `mod` 1000) * 1000)
+     SET(timeVal,Int,timeout,tv_sec,(tleft `div` 1000))
+     return timeout
+
+foreign import ccall "sys/select.h select" cselect :: Int32 -> Cfd_set -> Cfd_set -> Cfd_set -> CtimeVal -> IO Int32
+--foreign import ccall "unistd.h" getdtablesize :: IO Int
+
+select :: Int32 -> Cfd_set -> Maybe CtimeVal -> IO Int32
+select nfds readfds timeout = start where
+ start = do
+    n <- cselect nfds readfds nullPtr nullPtr (maybe nullPtr id timeout)
+{-
+      case timeout of
+        Nothing -> 
+           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,NULL);'' readfds
+	Just t -> 
+           _casm_ ``%r=select(getdtablesize(),%0,NULL,NULL,%1);'' readfds t
+-}
+    
+    if n /= -1 then return n else do
+       e <- errno
+       if e == CCONST(EINTR) --- || e == CCONST(EAGAIN)
+         then start -- again
+         else return n
+--}
+foreign import ccall "asyncinput.h get_errno" errno :: IO Int
+--errno :: IO Int
+--errno = _casm_ ``%r=errno;''
+
+foreign import ccall "sys/socket.h" listen :: Fd -> Int32 -> IO Int
+foreign import ccall "sys/socket.h" socket :: Int32 -> Int32 -> Int32 -> IO Fd
+foreign import ccall "stdio.h" fopen :: CString -> CString -> IO Int -- hmm
+foreign import ccall "stdio.h" fclose :: Int -> IO Int
+
+foreign import ccall "asyncinput.h" in_connect :: CString -> Int32 -> Int32 -> IO Int32
+foreign import ccall "asyncinput.h" in_bind :: Int32 -> Int32 -> IO Fd
+foreign import ccall "asyncinput.h" get_stdin :: IO Int
+
+doSocketRequest (XCallState fds maxfdvar aitable tq tno) sr =
+ case sr of
+   CreateTimer interval first -> do
+          tqv <- readIOVar tq
+          tnov <- readIOVar tno
+	  now <- mstime
+	  writeIOVar tq (insert tqv (now+first,(interval,Ti tnov)))
+	  writeIOVar tno (tnov+1)
+	  returnS (Timer (Ti tnov))
+   DestroyTimer t -> do
+          tqv <- readIOVar tq
+	  writeIOVar tq (remove tqv t)
+	  return Success
+   OpenSocket host port -> do
+     chost <- marshallString host
+     s <- tryP "in_connect" (>=0) $ 
+--           _casm_ ``%r=in_connect(%0,%1,SOCK_STREAM);'' chost port
+           in_connect chost (fromIntegral port) (fromIntegral CCONST(SOCK_STREAM))
+     sf <- getfilep s "r+"
+     freePtr chost
+     returnS (Socket (So sf))
+   OpenLSocket port -> do
+      s <- tryP "in_bind" (>=0) $ if port == 0 
+--         then _casm_ ``%r=socket(AF_INET,SOCK_STREAM,0);''
+           then socket (fromIntegral CCONST(AF_INET)) (fromIntegral CCONST(SOCK_STREAM)) 0
+--	   else _casm_ ``%r=in_bind(%0,SOCK_STREAM);'' port
+	   else in_bind (fromIntegral port) (fromIntegral CCONST(SOCK_STREAM))
+      tryP "listen" (==0) $ listen s 5
+      SocketResponse . LSocket . LSo <$> getfilep s "r+"
+   WriteSocket s str -> writeSocket s str
+   WriteSocketPS s str ->
+      do writeSocket s (unpackPS str) -- grr!
+         returnS (Wrote (lengthPS str)) -- grr!
+{-
+     do
+      fd <- fileno s
+      r <- tryP "WriteSocket[out]" (>=0) $ 
+        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s (psToByteArray str) (lengthPS str)
+--        bawrite fd (psToByteArray str) (lengthPS str)
+      return (SocketResponse (Wrote r))
+-}
+   CloseSocket (So s) -> close s
+   CloseLSocket (LSo s) -> close s
+   GetStdinSocket -> SocketResponse . Socket . So <$>
+--        _casm_ ``%r=stdin;''
+	get_stdin
+   GetSocketName (So s) -> socketname s
+   GetLSocketName (LSo s) -> socketname s
+   StartProcess cmd doIn doOut doErr -> startProcess cmd doIn doOut doErr
+   DLOpen path -> do dh <- dlopen path [RTLD_LAZY]
+                     case dh of
+                       Null -> failu =<< dlerror
+                       _ -> returnS $ S.DLHandle (DL dh)
+   DLClose (DL dh) -> do dlclose dh ; return Success
+   DLSym (DL dh) name ->
+       do FunPtr fp <- dlsym dh name
+          case addrToAny# fp of
+            (# hval #) -> returnS . DLVal $ DLValue (unsafeCoerce hval)
+   OpenFileAsSocket name mode -> do
+     cname <- marshallString name
+     cmode <- marshallString mode
+     s <- tryP "OpenSocketAsFile[fopen]" (/=0) $ fopen cname cmode
+     freePtr cname
+     freePtr cmode
+     returnS $ (Socket . So) s
+   _ -> error ("Not implemented: "++show sr)
+ where returnS = return . SocketResponse
+       close s = do
+          fclose s
+	  return Success
+       socketname s =
+          allocaInt $ \ lenp ->
+          do sa <- newsockAddr
+--	     tryP "GetLSocketName" (==0) $ _ccall_ GETSOCKNAME (s::Int) sa lenp
+	     tryP "GetLSocketName" (==0) $ getsockname s sa lenp
+	     len <- peek lenp
+	     strp <- GETC(sockAddr,char *,CString,sa,sa_data)
+--	     Str . unpackPS <$> (stToIO $ packCBytesST len strp)
+	     Str <$> unmarshallString' strp len
+
+writeSocket (So s) str =
+   do let n = length str
+      fd <- get_fileno s
+      cstr <- marshallString' str n
+      tryP "WriteSocket[out]" (>=0) $ 
+--        _casm_ ``%r=write(fileno((FILE*)%0),%1,%2);'' s cstr n
+        cwrite fd cstr (fromIntegral n)
+      freePtr cstr
+      return Success
+
+foreign import ccall "sys/socket.h" getsockname :: Int -> CsockAddr -> Addr -> IO Int
+foreign import ccall "stdio.h" fdopen :: Int32 -> CString -> IO Int
+
+getfilep s mode = tryP "fdopen" (/=0) $
+  do cmode <- marshallString (mode::String)
+--     _ccall_ fdopen (s::Int) cmode :: IO Int
+     fdopen s cmode :: IO Int
+
+foreign import ccall "string.h strerror" cstrerror :: Int -> IO CString
+strerror e = unmarshallString =<< cstrerror e
+
+tryP e p io = do
+    r <- io
+    if p (r{-::Int-}) then return r else do
+--      cstr <- _casm_ ``%r=strerror(errno);''
+      s <- strerror =<< errno
+      failu (e++": "++ s)
+
+
+peekq tq = do
+   tqv <- readIOVar tq
+   return (inspect tqv)
+
+removetimeq tq = do
+   tqv <- readIOVar tq
+   case inspect tqv of
+     Just ((first,v@(interval,tnov)),tqv') -> do
+        let tqv2 = if interval == 0 then tqv'
+	           else insert tqv' (first+interval,v)
+        writeIOVar tq tqv2
+	return tnov
+	
+foreign import ccall "sys/time.h" gettimeofday :: CtimeVal -> Addr -> IO ()
+
+mstime = do
+    now <- newtimeVal
+--    _casm_ ``gettimeofday(%0,NULL);'' now
+    gettimeofday now nullAddr
+    s <- GET(timeVal,Int,now,tv_sec)
+    us <- GET(timeVal,Int,now,tv_usec)
+    return (s * 1000 + us `div` 1000 :: Int)
+
+
+foreign import ccall "asyncinput.h" fdzero :: Cfd_set -> IO ()
+foreign import ccall "asyncinput.h fdset" fd_set :: Fd -> Cfd_set -> IO ()
+foreign import ccall "asyncinput.h fdisset" fd_isset :: Fd -> Cfd_set -> IO Int
+foreign import ccall "asyncinput.h" bcopy_fdset :: Cfd_set -> Cfd_set -> IO ()
+
+doSelect :: XCallState -> [Descriptor] -> IO Response
+doSelect (XCallState fds maxfdvar aitable _ _) dl =
+ do
+  fdzero fds
+  ait <- concat <$> mapM descriptor dl
+  let fds = map fst ait
+  writeIOVar aitable ait
+  writeIOVar maxfdvar (maximum fds)
+  mapM_ fdset fds
+  return Success
+ where descriptor d = case d of
+	   LSocketDe (LSo s) -> withd $ get_fileno s
+	   SocketDe (So s) ->  withd $ get_fileno s
+	   OutputSocketDe (So s) ->  withd $ get_fileno s
+	   DisplayDe ({-Display-} d) -> withd $ 
+--	         _casm_ ``%r=((Display*)%0)->fd;'' d
+		 xConnectionNumber d -- hmm
+	   TimerDe _ -> return []
+           _ -> do putStr "Unexpected descriptor: ";print d;return []
+          where withd m = m >>= \fd -> return [(fd,d)]
+
+       fdset :: Fd -> IO ()
+       --fdset s =  _casm_ ``FD_SET(%0,(fd_set*)%1);'' s fds
+       fdset s =  fd_set s fds
+
+foreign import ccall "asyncinput.h" get_fileno :: Int -> IO Fd
+{-
+
+-- Register problems with FD_ZERO under Redhat 6.1 Linux-i386...
+--fdzero :: Cfd_set -> IO ()
+--fdzero fds = _casm_ ``{ fd_set *s=%0; FD_ZERO(s);}'' fds
+--fdzero fds = _ccall_ FD_ZERO fds
+
+mutByteArr2Addr :: MutableByteArray RealWorld Int -> IO  Addr
+mutByteArr2Addr arr  = _casm_ `` %r=(void *)%0; '' arr
+--}
+
+foreign import ccall "unistd.h" fork :: IO Int
+foreign import ccall "unistd.h" execl :: CString -> CString -> CString -> CString -> Int -> IO Int
+foreign import ccall "unistd.h" pipe :: Addr -> IO Int
+foreign import ccall "unistd.h" dup :: Fd -> IO Fd
+foreign import ccall "asyncinput.h" disable_timers :: IO ()
+
+startProcess cmd doIn doOut doErr =
+  do inPipe <- optPipe doIn
+     outPipe <- optPipe doOut
+     errPipe <- optPipe doErr
+--     pid <- _ccall_ fork
+     pid <- fork
+     case pid::Int of
+       -1 -> failu "fork" -- use tryP instead
+       0 -> do -- child process
+	       -- Disable virtual timer, used by the GHC RTS
+	       disable_timers
+	       optDupIn 0 inPipe
+	       optDupOut 1 outPipe
+	       optDupOut 2 errPipe
+	       binsh <- marshallString "/bin/sh"
+	       sh <- marshallString "sh"
+	       dashc <- marshallString "-c"
+	       ccmd <- marshallString cmd
+	       execl binsh sh dashc ccmd (0::Int)
+	       --_ccall_ _exit 1
+	       failu "execl"
+       _ -> do -- parent process
+	       inS <- optPipeIn inPipe
+	       outS <- optPipeOut outPipe
+	       errS <- optPipeOut errPipe
+	       return $ SocketResponse $ ProcessSockets inS outS errS
+  where
+    optPipe False = return Nothing
+    optPipe True = Just `fmap` newPipe
+    newPipe = do pa <- newArray 2
+		 ok <- pipe (addrOf (pa::CInt32))
+		 [p0,p1] <- readArray pa 2
+		 freePtr pa
+		 when (ok/=0) $ failu "pipe" -- use tryP instead
+		 return (p0,p1)
+
+    optDupIn d = optDupOut d . fmap swap
+    optDupOut d = maybe (return ()) (dupOut d)
+    dupOut d (p0,p1) = do cclose d
+			  dup p1
+			  cclose p0
+			  cclose p1
+			  return ()
+
+    optPipeIn = optPipeS "w" . fmap swap
+    optPipeOut = optPipeS "r"
+    optPipeS m = maybe (return Nothing) (fmap Just . pipeS m)
+    pipeS m (p0,p1) = do cclose p1
+			 fmap So (getfilep p0 m)
+			 
+
+foreign import ccall "unistd.h close" cclose :: Int32 -> IO Int32
diff --git a/hsrc/ghc-dialogue/CSizes.hs b/hsrc/ghc-dialogue/CSizes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/CSizes.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE CPP #-}
+module CSizes where
+
+#define CSIZE(ctype) foreign import ccall "cfuns.h" fudsizeof_/**/ctype :: Int
+
+#include "csizes.h"
diff --git a/hsrc/ghc-dialogue/CString16.hs b/hsrc/ghc-dialogue/CString16.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/CString16.hs
@@ -0,0 +1,16 @@
+module CString16 where
+import Marshall
+
+-- A quick hack...
+
+type CString16 = CString -- !!
+
+marshallString16 s = marshallString16' s (length s)
+
+marshallString16' s n = marshallString' (split s) (2*n)
+  where
+    split [] = []
+    split (c:cs) = toEnum (i `div` 256):toEnum (i `mod` 256):split cs
+      where i = fromEnum c
+
+-- unmarshallString16 = ...
diff --git a/hsrc/ghc-dialogue/ContinuationIO.hs b/hsrc/ghc-dialogue/ContinuationIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/ContinuationIO.hs
@@ -0,0 +1,169 @@
+module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where
+--import DialogueIO
+--import XStuff
+--import P_IO_data hiding (Bin)
+--import Prelude hiding (IOError,appendFile,interact,print,readFile,writeFile)
+{-
+type SuccCont    =                Dialogue
+type StrCont     =  String     -> Dialogue
+type BinCont     =  Bin        -> Dialogue
+type FailCont    =  IOError    -> Dialogue
+type StrListCont =  [String]   -> Dialogue
+type Bin = ()
+-}
+stdin = "stdin"
+stdout = "stdout"
+stderr = "stderr"
+{-
+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
+echo          :: Bool   ->           FailCont -> SuccCont -> Dialogue
+getArgs	      ::		     FailCont -> StrListCont -> Dialogue
+getEnv	      :: String ->	     FailCont -> StrCont  -> Dialogue
+setEnv	      :: String -> String -> FailCont -> SuccCont -> Dialogue
+getProgName   ::		     FailCont -> StrCont  -> Dialogue
+readFileScattered :: String -> [Int] -> FailCont -> StrListCont  -> Dialogue
+
+done resps    =  []
+
+readFile name fail succ resps =
+    ReadFile name : strDispatch fail succ resps
+
+readFileScattered name offs fail succ resps =
+    ReadFileScattered name offs : strListDispatch fail succ resps
+
+writeFile name contents fail succ resps =
+    WriteFile name contents : succDispatch fail succ resps
+
+appendFile name contents fail succ resps =
+    AppendFile name contents : succDispatch fail succ resps
+
+{-
+readBinFile name fail succ resps =
+    ReadBinFile name : binDispatch fail succ resps
+
+writeBinFile name contents fail succ resps =
+    WriteBinFile name contents : succDispatch fail succ resps
+
+appendBinFile name contents fail succ resps =
+    AppendBinFile name contents : succDispatch fail succ resps
+
+readBinChan name fail succ resps =
+    ReadBinChan name : binDispatch fail succ resps
+
+appendBinChan name contents fail succ resps =
+    AppendBinChan name contents : succDispatch fail succ resps
+-}
+
+deleteFile name fail succ resps =
+    DeleteFile name : succDispatch fail succ resps
+
+statusFile name fail succ resps =
+    StatusFile name : strDispatch fail succ resps
+
+readChan name fail succ resps =
+    ReadChan name : strDispatch fail succ resps
+
+appendChan name contents fail succ resps =
+    AppendChan name contents : succDispatch fail succ resps
+
+echo bool fail succ resps =
+    Echo bool : succDispatch fail succ resps
+
+getArgs fail succ resps =
+    GetArgs : strListDispatch fail succ resps
+
+getProgName fail succ resps =
+    GetProgName : strDispatch fail succ resps
+
+getEnv name fail succ resps =
+    GetEnv name : strDispatch fail succ resps
+
+setEnv name val fail succ resps =
+    SetEnv name val : succDispatch fail succ resps
+
+
+strDispatch  fail succ (resp:resps) = case resp of 
+					Str val      -> succ val resps
+					Failure msg  -> fail msg resps
+
+binDispatch  fail succ (resp:resps) = case resp of 
+					Bn val       -> succ val resps
+					Failure msg  -> fail msg resps
+
+succDispatch fail succ (resp:resps) = case resp of
+					Success     -> succ resps
+					Failure msg -> fail msg resps
+
+strListDispatch fail succ (resp:resps) = case resp of
+					StrList val -> succ val resps
+					Failure msg -> fail msg resps
+
+
+abort		:: FailCont
+abort msg	=  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		:: (Show a) => a -> Dialogue
+print x		=  appendChan stdout (show x) exit done
+prints          :: (Show 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)
+
+------------------------------------ hbc bonus
+type DblCont = Double -> Dialogue
+
+sleep           :: Double ->           FailCont -> SuccCont    -> Dialogue
+changeDirectory :: String ->           FailCont -> SuccCont    -> Dialogue
+getTime         ::                     FailCont -> DblCont     -> Dialogue
+deleteDirectory :: String ->           FailCont -> SuccCont    -> Dialogue
+readDirectory   :: String ->           FailCont -> StrListCont -> Dialogue
+getCpuTime      ::                     FailCont -> DblCont     -> Dialogue
+getLocalTime    ::                     FailCont -> DblCont     -> Dialogue
+readDirectory name fail succ resps =
+    ReadDirectory name : strListDispatch fail succ resps
+
+getLocalTime fail succ resps =
+    GetLocalTime : dblDispatch fail succ resps
+
+sleep dbl fail succ resps =
+    Sleep dbl : succDispatch fail succ resps
+
+changeDirectory str fail succ resps =
+    ChangeDirectory str : succDispatch fail succ resps
+
+deleteDirectory str fail succ resps =
+    DeleteDirectory str : succDispatch fail succ resps
+
+getTime fail succ resps =
+    GetTime : dblDispatch fail succ resps
+
+getCpuTime fail succ resps =
+    GetCpuTime : dblDispatch fail succ resps
+
+dblDispatch  fail succ (resp:resps) = case resp of 
+                                        Dbl val      -> succ val resps
+                                        Failure msg  -> fail msg resps
+
+-}
diff --git a/hsrc/ghc-dialogue/DialogueIO.hs b/hsrc/ghc-dialogue/DialogueIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/DialogueIO.hs
@@ -0,0 +1,21 @@
+-- | Haskell 1.2 Dialogue I/O
+module DialogueIO(Request(..), Response(..), IOError(..)
+       , Dialogue(..), SigAct(..) , dialogueToIO
+       --, module _LibDialogue
+	) where
+import Prelude hiding (IOError)
+import P_IO_data
+import DoRequest
+import Control.Concurrent.Chan
+
+-- | Included just to illustrate that it is possible to convert a Dialogue
+-- IO function to a monadic IO function. The implementation relies on
+-- 'getChanContents' to construct the lazy list of responses needed by
+-- the dialogue IO function.
+dialogueToIO :: Dialogue -> IO ()
+dialogueToIO f =
+  do st <- initXCall
+     respchan <- newChan
+     reqs <- f `fmap` getChanContents respchan
+     let doReq req = writeChan respchan =<< doRequest st req
+     mapM_ doReq reqs
diff --git a/hsrc/ghc-dialogue/DoRequest.hs b/hsrc/ghc-dialogue/DoRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/DoRequest.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE CPP #-}
+module DoRequest(XCallState,initXCall,doRequest,getAsyncInput) where
+import Control.Applicative
+--import DialogueIO
+import P_IO_data
+import ContinuationIO(stdin,stdout,stderr)
+import qualified System.IO as IO
+import System.Environment as IO(getEnv,getProgName)
+import System.Process as IO(system)
+import System.Exit as IO
+import qualified IOUtil as IO
+import System.IO(openBinaryFile,withBinaryFile,IOMode(..),hPutStr,hGetContents)
+import System.Directory
+#ifdef VERSION_old_time
+import System.Time(getClockTime,toCalendarTime)
+#endif
+#ifdef VERSION_time
+import Data.Time(getCurrentTime,getZonedTime)
+#endif
+
+import DoXCommand
+import DoXRequest
+import AsyncInput(XCallState,initXCall,getAsyncInput',doSelect,doSocketRequest)
+import CmdLineEnv(argFlag)
+
+--import System
+import Prelude hiding (IOError)
+
+--import Ap
+
+deb = argFlag "dorequest" False
+
+doRequest =
+    if not deb
+    then doRequest'
+    else \state req -> do
+         eprint req
+	 resp <- doRequest' state req
+	 eprint resp
+	 return resp
+  where
+    eprint x = IO.hPutStrLn IO.stderr . take 239 . show $ x
+
+doRequest' :: XCallState -> Request -> IO Response
+doRequest' state req =
+  case req of
+    ReadFile   filename          -> rdCatch (readFile filename)
+    WriteFile  filename contents -> wrCatch (writeFile filename contents)
+    ReadBinaryFile filename      -> rdCatch (readBinaryFile filename)
+    WriteBinaryFile filename contents ->
+                                    wrCatch (writeBinaryFile filename contents)
+    AppendFile filename contents -> wrCatch (appendFile filename contents)
+    StatusFile filename          -> catchIo SearchError (statusFile filename)
+      where
+        statusFile path =
+	  do f <- doesFileExist path
+	     if f then permissions 'f' path
+               else do d <- doesDirectoryExist path
+		       if d then permissions 'd' path
+			  else fail path
+	permissions t path =
+	  do p <- getPermissions path
+	     let r = if readable p then 'r' else '-'
+		 w = if writable p then 'w' else '-'
+	     return (Str [t,r,w])
+    RenameFile from to         -> otCatch (renameFile from to>>ok)
+    GetCurrentDirectory        -> Str <$> getCurrentDirectory
+#ifdef VERSION_old_time
+    GetModificationTime path   -> catchIo SearchError (ClockTime <$> IO.getModificationTime path)
+#else
+    GetModificationTime path   -> catchIo SearchError (UTCTime <$> IO.getModificationTime path)
+#endif
+    ReadDirectory dir          -> rdCatch' StrList (getDirectoryContents dir)
+    DeleteFile filename        -> otCatch (removeFile filename>>ok)
+    CreateDirectory path mask  -> otCatch (createDirectory path>>ok)
+    ReadXdgFile xdg path      -> rdCatch $
+                                 do dir <- getAppXdgDir xdg
+                                    readFile (dir++"/"++path)
+    WriteXdgFile xdg path s   -> wrCatch $
+                                 do dir <- getAppXdgDir xdg
+                                    createDirectoryIfMissing True dir
+                                    writeFile (dir++"/"++path) s
+    ReadChan channelname ->
+      if channelname==stdin
+      then rdCatch getContents
+      else rfail $ ReadError $ "ReadChan: unknown channel "++channelname
+    AppendChan channelname contents
+        | channelname==stdout -> wr IO.stdout
+        | channelname==stderr -> wr IO.stderr
+        | otherwise           -> rfail $ WriteError $ "AppendChan: unknown channel "++channelname
+      where wr chan = wrCatch (IO.hPutStr chan contents>>IO.hFlush chan)
+    XRequest r      -> otCatch $ XResponse <$> doXRequest r
+    XCommand c      -> otCatch $ (doXCommand c >> ok)
+    GetAsyncInput   -> getAsyncInput state
+    SocketRequest r -> otCatch $ doSocketRequest state r
+    Select dl       -> otCatch $ doSelect state dl
+    Exit n	    -> exitWith (if n==0 then ExitSuccess else ExitFailure n)
+#ifdef VERSION_old_time
+    GetLocalTime    -> otCatch $ do
+		         CalendarTime <$> (toCalendarTime =<< getClockTime)
+			 --s <- readIO (formatCalendarTime undefined "%s" t)
+			 --GHC bug(?) workaround:
+                         --let s = ctSec t+60*(ctMin t+60*(ctHour t))
+			 --return (Dbl (fromIntegral s))
+    GetTime         -> otCatch $ ClockTime <$> getClockTime
+    ToCalendarTime t -> CalendarTime <$> toCalendarTime t
+#endif
+    GetEnv var      -> catchIo SearchError (Str <$> getEnv var)
+    System cmd      -> do exitcode <- system cmd
+		          case exitcode of
+		            ExitSuccess -> ok
+			    ExitFailure n -> rfail $ OtherError $ "System: Return code="++show n
+#ifdef VERSION_time
+    GetCurrentTime  -> otCatch $ UTCTime   <$> getCurrentTime
+    GetZonedTime    -> otCatch $ ZonedTime <$> getZonedTime
+#endif
+    _ -> do IO.hPutStrLn IO.stderr msg
+            rfail $ OtherError msg
+         where msg = "doRequest: unimplemented request: "++show req
+
+ok = return Success
+rfail = return . Failure
+
+getAsyncInput state = otCatch $ getAsyncInput' state
+
+rdCatch = rdCatch' Str
+rdCatch' c io = catchIo ReadError (c <$> io)
+wrCatch io = catchIo WriteError (io >> ok)
+otCatch = catchIo OtherError
+catchIo e io = IO.catch io (rfail . e . show)
+
+---- Should be put elsewhere:
+-- #ifndef __GLASGOW_HASKELL__
+-- instance Functor IO where map f io = io >>= (return . f)
+-- #endif
+
+--
+readBinaryFile path = hGetContents =<< openBinaryFile path ReadMode
+writeBinaryFile path s = withBinaryFile path WriteMode (flip hPutStr s)
+
+getAppXdgDir xdg = getXdgDirectory xdg =<< getProgName
diff --git a/hsrc/ghc-dialogue/DoXCommand.hs b/hsrc/ghc-dialogue/DoXCommand.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/DoXCommand.hs
@@ -0,0 +1,366 @@
+{-# LANGUAGE CPP #-}
+{- unused options -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}
+-- -O
+module DoXCommand(doXCommand) where
+
+import Command
+import Event
+import Geometry
+import Xtypes
+--import Font
+--import ResourceIds
+import DrawTypes
+import HbcUtils(chopList)
+
+import DoXRequest(getGCValues,translateCoordinates)
+import XCallTypes
+import StructFuns
+import Xlib
+import Marshall
+import MyForeign
+--import CCall
+import CString16
+
+import System.IO(hPutStr,hPutStrLn,stderr) -- for error reporting
+
+import PackedString(lengthPS,unpackPS)
+--import Word(Word32)
+import Data.Bits
+
+--import IO(hFlush,stdout) -- debugging
+
+default (Int)
+
+{-
+#include "newstructfuns.h"
+-}
+-- For debugging only:
+{-
+doXCommand req@(d,_,_) =
+  do r <- doXCommand' req
+   --hFlush stdout
+     xSync d False
+     return r
+--}
+--doXCommand cmd@(display,_,_) = withLockedDisplay display $ doXCommand' cmd
+
+doXCommand :: (Display, Window, XCommand) -> IO ()
+doXCommand (d,w,req) =
+  case req of
+   CloseDisplay d -> xCloseDisplay d
+   DestroyWindow -> xDestroyWindow d w
+   MapRaised -> xMapRaised d w
+   LowerWindow -> xLowerWindow d w
+   UnmapWindow -> xUnmapWindow d w
+   ClearWindow -> xClearWindow d w
+   StoreName s -> xStoreName d w s
+   FreeGC gc -> xFreeGC d gc
+   UngrabPointer -> xUngrabPointer d currentTime
+   Flush -> xFlush d
+   ClearArea (Rect (Point x y) (Point wi he)) exposures ->
+      xClearArea d w x y wi he exposures
+   GrabButton oe button ms evm ->
+      xGrabButton d (toC button) anyModifier w oe (toC evm) grabModeAsync grabModeAsync windowNone  cursorNone
+   UngrabButton b ms ->
+     --_casm_ ``XUngrabButton(%0,%1,AnyModifier,%2);'' d (toC b) w
+     xUngrabButton d (toC b) anyModifier w
+   FreePixmap p -> xFreePixmap d p
+   Draw drawable gc cmd -> doDrawCommand (getdr drawable) gc cmd
+   DrawMany drawable gccmds -> mapM_ doDrawMany gccmds
+      where
+        dr = getdr drawable
+	doDrawMany (gc,cmds) = mapM_ (doDrawCommand dr gc) cmds
+   ChangeGC gc gcattrs -> do
+     (gcvals,mask) <- getGCValues gcattrs
+     xChangeGC d gc mask gcvals
+   ChangeWindowAttributes was -> do
+     (attrs,mask) <- getWindowAttributes was
+     --putStr "CWA mask ";print mask
+     xChangeWindowAttributes d w mask attrs
+   ConfigureWindow wc -> do
+     (chgs,mask) <- getWindowChanges wc
+     xConfigureWindow d w mask chgs
+   SetNormalHints (Point x y) -> do
+      h <- newXSizeHints 
+      SET(XSizeHints,Int,h,x,x)
+      SET(XSizeHints,Int,h,y,y)
+      SET(XSizeHints,Int,h,flags,CCONST(USPosition)::Int)
+      xSetNormalHints d w h
+      freePtr h
+   SetWMHints i -> do
+      h <- newXWMHints
+      SET(XWMHints,Int,h,flags,CCONST(InputHint)::Int)
+      SET(XWMHints,Int,h,input,toC i)
+      xSetWMHints d w h
+      freePtr h
+   ShapeCombineMask kind (Point x y) p op ->
+     xShapeCombineMask d w kind x y p op
+   ShapeCombineRectangles kind (Point x y) rs op ord -> do
+      (rsa,size) <- storeRectangles rs
+      xShapeCombineRectangles d w kind x y rsa size op ord
+      freePtr rsa
+   ShapeCombineShape dst (Point x y)  p src op ->
+       xShapeCombineShape d w dst x y p src op
+   --RmDestroyDatabase RmDatabase |
+   --RmCombineDatabase RmDatabase RmDatabase Bool |
+   --RmPutLineResource RmDatabase String |
+   SetWMProtocols atoms -> xSetWMProtocols d w atoms (length atoms)
+   SendEvent dst propagate evm e -> do
+     xe <- getEvent dst e
+     status <- xSendEvent d dst propagate (fromIntegral $ toC evm) xe
+     return ()
+   SetSelectionOwner getit sel ->
+     xSetSelectionOwner d sel (if getit then w else windowNone)  currentTime
+   ConvertSelection  (Selection s t p) ->
+     xConvertSelection d s t p w currentTime
+   ChangeProperty w p t form@8 mode s -> -- !!
+     xChangeProperty d w p t form mode s (length s)
+   FreeColors cm pixls planes ->
+     do cmid <- dcmap d cm
+	(pxarr,size) <- toArray [fromIntegral p|Pixel p<-pixls] -- hmm
+	xFreeColors d cmid pxarr size planes
+   ReparentWindow newParent0 ->
+     do newParent <- if newParent0==rootWindow
+                     then xDefaultRootWindow d
+                     else return newParent0
+        mp <- translateCoordinates d w newParent
+        case mp of
+          Nothing -> hPutStr stderr "XTranslateCoordinates: windows on different screens!\n"
+          Just (Point x y) -> xReparentWindow d w newParent x y
+   --WarpPointer Point |
+   SetRegion gc r -> -- !!! modifies a GC -- cache problems!
+     do (rsa,_) <- storeRectangles [r]
+	r <- xCreateRegion
+	xUnionRectWithRegion rsa r r
+	xSetRegion d gc r
+	xDestroyRegion r
+	freePtr rsa
+   --AddToSaveSet |
+   --RemoveFromSaveSet 
+   Bell n -> xBell d n
+
+   _ -> hPutStr stderr (notImplemented req)
+ where getdr = getdrawable w
+
+       doDrawCommand drw gc cmd = case cmd of
+	  DrawLine (Line (Point x1 y1) (Point x2 y2)) -> 
+	    xDrawLine d drw gc x1 y1 x2 y2
+	  DrawImageString (Point x y) s ->
+	    xDrawImageString d drw gc x y s (length s)
+	  DrawString (Point x y) s ->
+	    xDrawString d drw gc x y s (length s)
+	  DrawImageString16 (Point x y) s ->
+	    do let n = length s
+	       cs <- marshallString16' s n
+	       xDrawImageString16 d drw gc x y cs n
+	  DrawString16 (Point x y) s ->
+	    do let n = length s
+	       cs <- marshallString16' s n
+	       xDrawString16 d drw gc x y cs n
+	  DrawRectangle (Rect (Point x1 y1) (Point x2 y2)) ->
+            xDrawRectangle d drw gc x1 y1 x2 y2
+	  FillRectangle (Rect (Point x1 y1) (Point x2 y2)) ->
+            xFillRectangle d drw gc x1 y1 x2 y2
+	  FillPolygon shape coordmode ps -> do
+	      (xpoints,size) <- storePoints ps
+	      xFillPolygon d drw gc xpoints size shape coordmode
+	      freePtr xpoints
+	  DrawLines coordmode ps -> do
+	      (xpoints,size) <- storePoints ps
+	      xDrawLines d drw gc xpoints size coordmode
+	      freePtr xpoints
+	  DrawArc (Rect (Point x y) (Point wi he)) a1 a2 ->
+	      xDrawArc d drw gc (f x) (f y) (f wi) (f he) (f a1) (f a2)
+            where f = fromIntegral
+	  FillArc (Rect (Point x y) (Point wi he)) a1 a2 ->
+	      xFillArc d drw gc (f x) (f y) (f wi) (f he) (f a1) (f a2)
+            where f = fromIntegral
+	  CopyArea src (Rect (Point srcx srcy) (Point wi he))
+		       (Point dstx dsty) ->
+	    xCopyArea d (getdr src) drw gc (i32 srcx) (i32 srcy) (u32 wi) (u32 he) (i32 dstx) (i32 dsty)
+	  CopyPlane src (Rect (Point srcx srcy) (Point wi he)) 
+			(Point dstx dsty) plane ->
+            --print (gc,drw,cmd) >>
+	    xCopyPlane d (getdr src)
+		       drw gc (f srcx) (f srcy) (f wi) (f he)
+                       (f dstx) (f dsty) (shiftL 1 plane)
+            -- >>putStrLn "done"
+            where f = fromIntegral
+	  DrawPoint (Point x y) -> xDrawPoint d drw gc x y
+	  CreatePutImage rect format pixels -> createPutImage drw gc rect format pixels
+	  DrawImageStringPS (Point x y) s ->
+	    xDrawImageString d drw gc x y (unpackPS s) (lengthPS s) -- !!
+	  DrawStringPS (Point x y) s ->
+	    xDrawString d drw gc x y (unpackPS s) (lengthPS s) -- !!
+          _ -> hPutStr stderr (notImplemented cmd)
+
+       createPutImage drw gc rect@(Rect (Point x y) (Point w h)) (ImageFormat format) pixels =
+        do --hPutStrLn stderr $ "Entering createPutImage "++show rect
+	   screen <- xDefaultScreen d
+	   depth <- xDefaultDepth d screen
+	   bpp <- default_bpp d depth
+	   --hPutStrLn stderr ("bpp="++show bpp)
+	   let byte_depth = (depth+7) `div` 8
+	       bytes_pp = (bpp+7) `div` 8
+	       bitmap_pad = 32
+	       bytes_per_line = ((w*bytes_pp+3) `div` 4) * 4 -- assumes bitmap_pad == 32
+	       nullCount = bytes_per_line - w*bytes_pp
+	       size= w*h
+	       pxlines = chopList (splitAt w) pixels
+	   byteOrder <- xImageByteOrder d
+#if 1
+	   -- High level solution, not fast enough:
+	   let pxlToBytes = if byteOrder==LSBFirst then lsb else msb
+	       msb (Pixel p) = pad ++ reverse (lsb' byte_depth (fromIntegral p))
+	       pad = replicate (bytes_pp-byte_depth) '\0'
+	       lsb (Pixel p) = lsb' byte_depth (fromIntegral p) ++ pad
+	       lsb' 0 _ = []
+	       lsb' n p = toEnum (p `mod` 256) : lsb' (n-1) (p `div` 256)
+	       linePad = replicate nullCount '\0'
+	       byteLine pxls = concatMap pxlToBytes pxls ++ linePad
+	       bytes = concatMap byteLine pxlines
+	       --imgdata = psToByteArray (packString bytes)
+           --hPutStrLn stderr "Checkpoint 1 in createPutImage"
+           --hPutStrLn stderr $ "nullCount="++show nullCount
+#else
+	   -- Low level solution, faster, but still not fast enough:
+	   imgdata <- stToIO $ newCharArray (1,bytes_per_line*h)
+	   let convImage = convLines 0 pixels
+	       convLines y pixels | y>=h = return ()
+	                          | otherwise =
+	         do pixels' <- convLine y pixels
+		    convLines (y+1) pixels'
+	       convLine y pixels = convPixels (y*bytes_per_line) 0 pixels
+	       convPixels i x pixels | x>=w = return pixels
+	       convPixels i x (Pixel p:pixels) =
+		 do convPixel i p
+		    convPixels (i+bytes_pp) (x+1) pixels
+	       convPixel =
+	         if byteOrder==(CCONST(LSBFirst)::Int)
+		 then convPixelLSB
+		 else convPixelMSB
+	       convPixelLSB i p =
+	           pixelBytes i p byte_depth
+		   -- pad with zeros?
+	         where
+		   pixelBytes i p 0 = return ()
+		   pixelBytes i p n =
+		     do SINDEX(char,imgdata,i::Int,p::Int)
+		        pixelBytes (i+1) (p `div` 256) (n-1)
+	       convPixelMSB i p =
+	           do let i' = i+bytes_pp-1
+		      -- pad with zeros?
+		      pixelBytes i' p bytes_pp
+	         where
+		   pixelBytes i p 0 = return ()
+		   pixelBytes i p n =
+		     do SINDEX(char,imgdata,i::Int,p::Int)
+		        pixelBytes (i-1) (p `div` 256) (n-1)
+		 
+	    in convImage
+#endif
+	   dv <- xDefaultVisual d screen
+           --hPutStrLn stderr "Checkpoint 2 in createPutImage"
+           --if bytes==bytes then return () else undefined
+           --hPutStrLn stderr "Checkpoint 3 in createPutImage"
+	   cbytes <- marshallString' bytes (h*bytes_per_line)
+	   image <- xCreateImage d dv depth format 0 cbytes w h bitmap_pad bytes_per_line
+           --hPutStrLn stderr $ "Checkpoint 4 in createPutImage "++show image
+	   xPutImage d drw gc image 0 0 (i32 x) (i32 y) (i32 w) (i32 h)
+--	   ioCmd $ _casm_ ``((XImage *)(%0))->data=NULL;XDestroyImage((XImage *)%0);'' image
+	   --_casm_ ``((XImage *)(%0))->data=NULL;'' image
+           --hPutStrLn stderr "Checkpoint 5 in createPutImage"
+	   setXImage_data image nullAddr
+           --hPutStrLn stderr "Checkpoint 6 in createPutImage"
+	   xDestroyImage image
+           --hPutStrLn stderr "Checkpoint 7 in createPutImage"
+	   freePtr cbytes
+           --hPutStrLn stderr "Returning from createPutImage"
+{-
+       default_bpp :: Display -> Int -> IO Int
+       default_bpp (Display display) depth =
+         _casm_
+	    ``{int i,cnt,bpp;
+	       XPixmapFormatValues *ps=XListPixmapFormats(%0,&cnt);
+	       bpp=%1; /* Hmm. Something is wrong if depth isn't found. */
+	       for(i=0;i<cnt;i++)
+	         if(ps[i].depth==%1) {
+		   bpp=ps[i].bits_per_pixel;
+		   break;
+		 }
+	       XFree(ps);
+	       %r=bpp;}'' display depth
+-}
+foreign import ccall "asyncinput.h" default_bpp :: Display -> Int -> IO Int
+foreign import ccall "asyncinput.h" setXImage_data :: CXImage -> Addr -> IO ()
+
+i32 :: Int->Int32
+i32 = toEnum
+u32 :: Int->Unsigned32
+u32 = toEnum
+
+getWindowAttributes = getValues newXSetWindowAttributes getWindowAttribute
+ where
+  getWindowAttribute swa wa =
+   case wa of
+    CWEventMask em    	 -> (SETWa(swa,event_mask,toC em),CWORD32(CWEventMask))
+    CWBackingStore bs 	 -> (SETWa(swa,backing_store,toC bs),CWORD32(CWBackingStore))
+    CWSaveUnder b     	 -> (SETWa(swa,save_under,toC b),CWORD32(CWSaveUnder))
+    CWDontPropagate em   -> (SETWa(swa,do_not_propagate_mask,toC em),CWORD32(CWDontPropagate))
+    CWOverrideRedirect b -> (SETWa(swa,override_redirect,toC b),CWORD32(CWOverrideRedirect))
+    CWBackPixel p	 -> (SETWa(swa,background_pixel,toC p),CWORD32(CWBackPixel))
+    CWCursor c		 -> (SETWaXID(swa,cursor,toXID c),CWORD32(CWCursor))
+    CWBitGravity g 	 -> (SETWa(swa,bit_gravity,toC g),CWORD32(CWBitGravity))
+    CWWinGravity g 	 -> (SETWa(swa,win_gravity,toC g),CWORD32(CWWinGravity))
+    CWBackPixmap p       -> (SETWaXID(swa,background_pixmap,toXID p),CWORD32(CWBackPixmap))
+    CWBorderPixmap p     -> (SETWaXID(swa,border_pixmap,toXID p),CWORD32(CWBorderPixmap))
+    CWBorderPixel p      -> (SETWa(swa,border_pixel,toC p),CWORD32(CWBorderPixel) :: Bitmask)
+    -- _ -> (return (),0) -- to skip unimplemented fields
+
+getWindowChanges = getValues newXWindowChanges getWindowChange where
+  getWindowChange s wc = case wc of
+     CWX x 	      -> (SET(XWindowChanges,Int,s,x,x),CWORD32(CWX))
+     CWY y 	      -> (SET(XWindowChanges,Int,s,y,y),CWORD32(CWY))
+     CWWidth w        -> (SET(XWindowChanges,Int,s,width,w),CWORD32(CWWidth))
+     CWHeight h       -> (SET(XWindowChanges,Int,s,height,h),CWORD32(CWHeight))
+     CWBorderWidth w  -> (SET(XWindowChanges,Int,s,border_width,w),CWORD32(CWBorderWidth))
+     CWStackMode sm   -> (SET(XWindowChanges,Int,s,stack_mode,toC sm),CWORD32(CWStackMode) :: Bitmask) 
+
+{- deriving toEnum & fromEnum appears broken (not anymore /TH 2000-11-28) -}
+
+instance ToC CoordMode where toC = getEnum CoordModeOrigin
+instance ToC Shape where toC = getEnum Complex
+instance ToC BackingStore where toC = getEnum NotUseful
+instance ToC Gravity where toC = getEnum ForgetGravity
+instance ToC StackMode where toC = getEnum StackAbove
+instance ToC ShapeKind where toC = getEnum ShapeBounding
+instance ToC ShapeOperation where toC = getEnum ShapeSet
+instance ToC Ordering' where toC = getEnum Unsorted
+
+instance ToC Button where toC AnyButton  = CCONST(AnyButton)
+			  toC (Button i) = i
+
+getEvent w e = do
+    xe <- newXEvent
+    SET(XAnyEvent,Window,xe,window,w::Window)
+    case e of
+      SelectionNotify time (Selection sel target props) -> do
+        SET(XSelectionEvent,Int,xe,type,CCONST(SelectionNotify)::Int)
+        SET(XSelectionEvent,Atom,xe,selection, sel)
+        SET(XSelectionEvent,Atom,xe,target, target)
+        SET(XSelectionEvent,Atom,xe,property, props)
+        SET(XSelectionEvent,Time,xe,time,time)
+    return xe
+
+
+storePoints ps = getArray newXPointArray
+	          (\xpoints (i,Point x y) -> do SETI(XPoint,Int,xpoints,i,x,x)
+					        SETI(XPoint,Int,xpoints,i,y,y)) ps
+
+storeRectangles rs =
+  getArray newXRectangleArray
+           (\rsa (i,Rect (Point x y) (Point w h)) -> do
+		     SETI(XRectangle,Int,rsa,i,x,x)
+		     SETI(XRectangle,Int,rsa,i,y,y)
+		     SETI(XRectangle,Int,rsa,i,width,w)
+		     SETI(XRectangle,Int,rsa,i,height,h)) rs
diff --git a/hsrc/ghc-dialogue/DoXRequest.hs b/hsrc/ghc-dialogue/DoXRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/DoXRequest.hs
@@ -0,0 +1,488 @@
+{-# LANGUAGE CPP #-}
+{- Obsolete OPTIONS -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}
+--  -optc-I/usr/X11R6/include
+module DoXRequest(doXRequest,getGCValues,translateCoordinates) where
+
+--import P_IO_data(Request(..),Response(..))
+import Geometry
+import Command
+import Event
+import Xtypes
+import Font
+--import ResourceIds
+import Visual
+import HbcWord(intToWord) -- for Visual
+import IOUtil(getEnvi)
+--import CmdLineEnv(argFlag)
+
+import XCallTypes
+import StructFuns
+import Xlib
+import Marshall
+import MyForeign -- debugging
+import CString16
+
+--import Ap
+
+{-
+#include "newstructfuns.h"
+-}
+
+newXID = newPtr :: IO CXID
+newLong = newPtr :: IO CLong
+newLongs n = sequence (replicate n newLong)
+readLong = readCVar :: CLong -> IO Int
+newInt32 = newPtr :: IO CInt32
+newInt32s n = sequence (replicate n newInt32)
+readInt32 = readCVar :: CInt32 -> IO Int32
+freePtrs xs = mapM_ freePtr xs
+
+--synchronize = argFlag "synchronize" False
+
+{-
+doXRequest req@(display,_,_) =
+  do r <- doXRequest' req
+     if synchronize && display/=noDisplay then xSync display False else return ()
+     return r
+-}
+{-
+doXRequest req@(display,_,_) | display/=noDisplay =
+    withLockedDisplay display $ doXRequest' req
+doXRequest req = doXRequest' req
+-}
+doXRequest (d@display,wi,req) =
+ case req of
+   OpenDisplay optname ->
+      do name <- if null optname
+		 then case getEnvi "DISPLAY" of
+		        Just n -> return n
+	                Nothing -> failu "DISPLAY variable is not set"
+		 else return optname
+         d <- xOpenDisplay name
+	 --xSynchronize d synchronize -- has no effect?!
+	 return (DisplayOpened d)
+   CreateSimpleWindow p r -> WindowCreated <$> createWindow wi r
+   CreateRootWindow r resname -> WindowCreated <$> do
+       dr <- xDefaultRootWindow display
+       this <- createWindow dr r
+       setClassHint display this resname "Fudgets"
+	  /* This is a hack that solves a focus problem with twm.
+	     The twm option NoTitleFocus also solves the problem. */
+       -- xSetWMHints display this InputHint True
+       return this
+   CreateGC dr oldgc gcattrs -> GCCreated <$> do
+     wi' <- if wi == noWindow then xDefaultRootWindow display else return wi
+     gcvals <- getGCValues gcattrs
+     gc <- createGC display (getdrawable wi' dr)
+     if oldgc == rootGC then do
+        screen <- xDefaultScreen display
+        xSetForeground display gc =<< xBlackPixel display screen
+	xSetBackground display gc =<< xWhitePixel display screen
+      else copyGC display oldgc gc
+     changeGC display gc gcvals
+     return gc
+   LoadFont fn -> FontLoaded <$> xLoadFont display fn
+   CreateFontCursor shp -> CursorCreated <$> xCreateFontCursor display shp
+   GrabPointer b evm ->
+     PointerGrabbed <$> xGrabPointer display wi b (toC evm)
+	  grabModeAsync grabModeAsync windowNone cursorNone currentTime
+   AllocNamedColor cm cn ->
+      ColorAllocated <$> (allocNamedColor display cn =<< dcm cm)
+   AllocColor cm rgb ->
+       ColorAllocated <$> (allocColor display rgb =<< dcm cm)
+   CreatePixmap (Point w h) depth -> PixmapCreated <$> do
+     depth' <- if depth == copyFromParent
+		  then xDefaultDepth display =<< xDefaultScreen display
+		  else return depth
+     WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi
+     xCreatePixmap display (DrawableId wi') w h depth'
+   ReadBitmapFile filename -> do
+      bm <- newXID
+      ints@[w,h,xhot,yhot] <- newInt32s 4
+      WindowId root <- xDefaultRootWindow display
+      cfilename <- marshallString filename -- GHC gives faulty code for marshallM?
+      --putStrLn "about to call xReadBitmapFile"
+      --writeCVar xhot 0
+      --putStrLn filename
+      --putStrLn =<< unmarshall cfilename
+      --print =<< readLong xhot
+      r <- xReadBitmapFile display (DrawableId root) cfilename w h bm xhot yhot
+      --putStrLn "returned from call to xReadBitmapFile"
+      freePtr cfilename -- crash?!!
+      --putStrLn "about to read xhot"
+      x <- fromIntegral <$> readInt32 xhot
+      --putStr "xhot =";print x
+      ret <-
+        if (r::Int) == CCONST(BitmapSuccess) then do
+	    hot <- if x == -1 then return Nothing 
+			      else Just . Point x . fromIntegral <$> readInt32 yhot
+	    BitmapReturn
+	      <$> (Point <$> (fromIntegral <$> readInt32 w) <*> (fromIntegral <$> readInt32 h))
+	     <*> return hot 
+	     <*> (PixmapId <$> readCVar bm)
+        else return BitmapBad
+      --putStrLn "about to free int parameters"
+      freePtrs ints
+      freePtr bm
+      return (BitmapRead ret)
+   CreateBitmapFromData (BitmapData size@(Point w h) hot bytes) ->
+     do cbytes <- marshallString' (map toEnum bytes) (((w+7) `div` 8)*h)
+        WindowId wi' <- if wi == noWindow then xDefaultRootWindow display else return wi
+        let cw = fromIntegral w
+            ch = fromIntegral h
+        pm <- xCreateBitmapFromData display (DrawableId wi') cbytes cw ch
+        freePtr cbytes
+        return (BitmapRead (BitmapReturn size hot pm))
+   --RmGetStringDatabase str ->
+   --RmGetResource rmd s1 s2 ->
+   TranslateCoordinates ->
+     do rootwin <- xDefaultRootWindow display
+        CoordinatesTranslated . maybe origin id
+          <$> translateCoordinates display wi rootwin
+   InternAtom str b -> GotAtom <$> xInternAtom display str b
+
+   GetAtomName a -> 
+     do at_ret <- xGetAtomName display a
+        if (at_ret == nullStr)
+           then return (GotAtomName Nothing)
+           else
+             do at_name <- unmarshallString at_ret
+                xFree at_ret
+                -- putStrLn at_name
+                case (length at_name) of
+                   0 -> return (GotAtomName Nothing)
+                   _ -> return (GotAtomName $ Just at_name)
+
+   GetWindowProperty offset property delete req_type ->
+     do let length = 1000 
+	actual_type <- newPtr
+	actual_format <- newPtr
+	nitems <- newLong
+	bytes_after <- newLong
+	prop_return <- newCString
+	xGetWindowProperty display wi property offset
+			   (length `div` (4::Int)) delete req_type
+	       actual_type actual_format nitems bytes_after prop_return
+	at <- readCVar actual_type
+	af <- readCVar actual_format
+	n <- readLong nitems
+	ba <- readLong bytes_after
+	str <- if (af::Int) == CCONST(None) then return "" else
+	    do let got = af*n `div` 8
+	       cstr <- readCVar prop_return
+	       str <- unmarshallString' cstr got
+	       xFree cstr
+	       return str
+	freePtr actual_type
+	freePtr actual_format
+	freePtr nitems
+	freePtr bytes_after
+	freePtr prop_return
+	return $ GotWindowProperty at af n ba str
+   QueryPointer -> do
+     ints@[root,child,root_x,root_y,win_x,win_y,mask] <- newLongs 7
+     same <- xQueryPointer display wi root child root_x root_y win_x win_y mask
+     ret <- PointerQueried same
+	      <$> mkPoint (readLong root_x) (readLong root_y)
+	     <*> mkPoint (readLong win_x) (readLong win_y)
+	     <*> (fromC <$> readLong mask)
+     freePtrs ints
+     return ret
+
+   QueryFont fid -> FontQueried <$> queryFont display fid
+   LoadQueryFont fn -> FontQueried <$> loadQueryFont display fn
+
+   QueryColor cmid (Pixel px) -> do
+      c <- newXColor
+      SET(XColor,Word,c,pixel,px)
+      cm <- dcm cmid
+      xQueryColor display cm c
+      r <- mkColor c
+      freePtr c
+      return (ColorQueried r)
+
+   ListFonts pattern maxnames ->
+     do cnt <- newLong
+	fnarr <- xListFonts display pattern maxnames cnt
+	fns <- unmarshallArray fnarr =<< readLong cnt
+	xFreeFontNames fnarr
+	freePtr cnt
+	return (GotFontList fns)
+   --QueryTree ->
+   DefaultRootWindow -> GotDefaultRootWindow <$> xDefaultRootWindow display
+   --GetGeometry ->
+   --GetResource rms ->
+   DefaultVisual ->
+     GotVisual <$> (mkVisual =<< xDefaultVisual d =<< xDefaultScreen d)
+   Sync b -> xSync display b >> return Synced
+   QueryTextExtents16 fid s ->
+     do let n = length s
+	cs <- marshallString16' s n
+        ints@[dir,ascent,descent,overall] <- newLongs 4
+        overall <- newPtr
+	xQueryTextExtents16 display fid cs n dir ascent descent overall
+        [asc,desc] <- mapM readLong [ascent,descent]
+        ov <- mkCharStruct overall
+        freePtrs ints
+	freePtr overall
+        return $ TextExtents16Queried asc desc ov
+   ListFontsWithInfo pattern maxnames ->
+     GotFontListWithInfo <$> listFontsWithInfo d pattern maxnames
+   DbeQueryExtension ->
+     do ints@[major,minor] <- newLongs 2
+        status <- xdbeQueryExtension display major minor
+	ma <- readLong major
+	mi <- readLong minor
+	freePtrs ints
+	return (DbeExtensionQueried status ma mi)
+   DbeAllocateBackBufferName swapAction ->
+       DbeBackBufferNameAllocated <$> xdbeAllocateBackBufferName d wi swapAction
+   DbeSwapBuffers swapAction -> -- applies only to the fudget's own window.
+       do (swapinfo,cnt) <- storeSwapAction [(wi,swapAction)]
+          status <- xdbeSwapBuffers display swapinfo cnt
+	  freePtr swapinfo
+	  return (DbeBuffersSwapped status)
+   _ -> error (notImplemented req)
+ where
+  createWindow parent (Rect (Point x y) (Point w h)) = do
+    screen <- xDefaultScreen display
+    blackP <- xBlackPixel display screen
+    whiteP <- xWhitePixel display screen
+    let border_width = 0 -- should agree with border_width in WindowF.hs !!
+    this <- xCreateSimpleWindow display parent x y w h border_width blackP whiteP
+    xStoreName display this "Fudgets"
+    return this
+  dcm = dcmap display
+
+{-
+type BorderWidth = Int
+type FontShape = Int
+-}
+
+setClassHint :: Display -> Window -> String -> String -> IO ()
+setClassHint d w resName resClass =
+  do class_hints <- newPtr
+     rn<-marshallString resName
+     SET(XClassHint,CString,class_hints,res_name,rn)
+     rc<-marshallString resClass
+     SET(XClassHint,CString,class_hints,res_class,rc)
+     xSetClassHint d w class_hints
+     freePtr rn
+     freePtr rc
+
+createGC :: Display -> DrawableId -> IO GCId
+createGC d w = xCreateGC d w 0 nullPtr
+--    _casm_ ``%r=XCreateGC(%0,%1,0,NULL);'' d w
+
+copyGC :: Display -> GCId -> GCId -> IO ()
+copyGC d oldgc gc = 
+  --xCopyGC d oldgc ``(1<<(GCLastBit+1))-1)''gc
+  xCopyGC d oldgc 8388607  gc
+--   _casm_ ``XCopyGC(%0,%1,(1<<(GCLastBit+1))-1,%2);'' d oldgc gc
+
+changeGC d gc (gcvals,mask) = xChangeGC d gc mask gcvals
+
+allocNamedColor :: Display -> String -> ColormapId -> IO (Maybe Color)
+allocNamedColor d colname cm = do
+   exact <- newPtr
+   screen <- newPtr
+   status <- xAllocNamedColor d cm colname screen exact
+   r <- returnColor status screen
+   freePtr exact
+   freePtr screen
+   return r
+
+returnColor status c = 
+ if status /= (0::Int)
+    then Just <$> mkColor c
+    else return Nothing
+
+mkColor xcol = 
+ Color . Pixel
+  <$> GET(XColor,Word,xcol,pixel)
+  <*> (RGB
+	 <$> GET(XColor,Int,xcol,red)
+	 <*> GET(XColor,Int,xcol,green)
+	 <*> GET(XColor,Int,xcol,blue)
+      )
+
+allocColor :: Display -> RGB -> ColormapId -> IO (Maybe Color)
+allocColor d rgb cm = do
+  color <- newXColor
+  setRGB rgb color
+  status <- xAllocColor d cm color
+  r <- returnColor status color
+  freePtr color
+  return r
+
+setRGB (RGB red green blue) color = do
+  SET(XColor,Int,color,red,red)
+  SET(XColor,Int,color,green,green)
+  SET(XColor,Int,color,blue,blue)
+
+type XGCValuesMask = (CXGCValues,Bitmask)
+
+getGCValues :: GCAttributeList -> IO XGCValuesMask
+getGCValues = getValues newPtr getGCValue where
+  getGCValue gcv ga = case ga of
+    GCFunction f           -> (SET(XGCValues,Int,gcv,function,fromEnum f),CWORD32(GCFunction)::Bitmask)
+    GCForeground p         -> (SET(XGCValues,Int,gcv,foreground,toC p),CWORD32(GCForeground))
+    GCBackground p         -> (SET(XGCValues,Int,gcv,background,toC p),CWORD32(GCBackground))
+    GCLineWidth w          -> (SET(XGCValues,Int,gcv,line_width,w),CWORD32(GCLineWidth))
+    GCLineStyle s          -> (SET(XGCValues,Int,gcv,line_style,fromEnum s),CWORD32(GCLineStyle))
+    GCFont f               -> (SET(XGCValues,XID,gcv,font,toXID f),CWORD32(GCFont))
+    GCCapStyle s           -> (SET(XGCValues,Int,gcv,cap_style,fromEnum s),CWORD32(GCCapStyle))
+    GCJoinStyle s          -> (SET(XGCValues,Int,gcv,join_style,fromEnum s),CWORD32(GCJoinStyle))
+    GCSubwindowMode m      -> (SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m),CWORD32(GCSubwindowMode))
+    GCGraphicsExposures g  -> (SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g),CWORD32(GCGraphicsExposures))
+    GCFillStyle f          -> (SET(XGCValues,Int,gcv,fill_style,fromEnum f),CWORD32(GCFillStyle))
+    GCTile p               -> (SET(XGCValues,XID,gcv,tile,toXID p),CWORD32(GCTile))
+    GCStipple p            -> (SET(XGCValues,XID,gcv,stipple,toXID p),CWORD32(GCStipple) :: Bitmask)
+    -- _ -> (return (),0)
+
+
+loadQueryFont :: Display -> FontName -> IO (Maybe FontStructList)
+loadQueryFont d fn = mkFontStructList =<< xLoadQueryFont d fn
+
+queryFont :: Display -> FontId -> IO (Maybe FontStructList)
+queryFont d fi = mkFontStructList =<< xQueryFont d fi
+
+listFontsWithInfo :: Display -> FontName -> Int -> IO [(FontName,FontStructList)]
+listFontsWithInfo d pattern maxnames =
+  do cnt <- newInt32
+     fsarrp <- newCXFontStruct
+     --putStrLn "About to call xListFontsWithInfo"
+     fnarr <- xListFontsWithInfo d pattern (fromIntegral maxnames) cnt fsarrp
+     --putStrLn "Returned from call xListFontsWithInfo"
+     n <- readInt32 cnt
+     --putStr "Number of fonts: " ; print n
+     freePtr cnt
+     fsarr <- readCVar fsarrp
+     freePtr fsarrp
+     --putStrLn "After free fsarrp"
+     if fnarr==nullStr then return []
+      else do
+       --putStrLn "Non-null name array"
+       fns <- unmarshallArray fnarr (fromIntegral n)
+       --putStrLn "Got name list";print fns
+       fss <- readArray fsarr (fromIntegral n)
+       --putStrLn "Got fontstruct list"
+       xFreeFontInfo fnarr fsarr n
+       --putStrLn "Freed fontinfo, returning"
+       return (zip fns fss)
+
+instance CVar CXFontStruct FontStructList
+instance Storable FontStructList where -- just for readArray...
+--sizeOf _ = sizeOf (undefined::CXFontStruct) -- Wrong size!!!
+  sizeOf _ = SIZEOF(XFontStruct)
+  alignment _ = alignment (undefined::CXFontStruct)
+  peek = mkFontStructList' . CXFontStruct
+
+mkFontStructList :: CXFontStruct -> IO (Maybe FontStructList)
+mkFontStructList fs =
+   if fs == CXFontStruct nullAddr
+   then return Nothing
+   else do fsl <- mkFontStructList' fs
+           --_casm_ ``XFreeFontInfo(NULL, %0, 1); '' fs
+	   xFreeFontInfo nullStr fs 1
+	   return (Just fsl)
+
+#if 0
+#define DEBUG(cmd) (putStrLn "cmd before">>(cmd)>>= \r->putStrLn "after">>return r)
+#else
+#define DEBUG(cmd) (cmd)
+#endif
+
+mkFontStructList' :: CXFontStruct -> IO FontStructList
+mkFontStructList' fs =
+  do --putStrLn "Enter mkFontStructList'"
+     min_char_or_byte2 <- GET(XFontStruct,Int,fs,min_char_or_byte2)
+     min_byte1 <-GET(XFontStruct,Int,fs,min_byte1)
+     max_char_or_byte2 <- GET(XFontStruct,Int,fs,max_char_or_byte2)
+     max_byte1 <-GET(XFontStruct,Int,fs,max_byte1)
+     n_prop <-GET(XFontStruct,Int,fs,n_properties)
+     -- putStrLn $ "font properties: " ++ (show n_prop)
+     --putStrLn "after min max"
+     let min = min_char_or_byte2 + 256*min_byte1
+         max = max_char_or_byte2 + 256*max_byte1
+         arrsize = (max_char_or_byte2 - min_char_or_byte2 + 1) *
+		   (max_byte1 - min_byte1 + 1)
+         --arrsize = max - min  :: Int -- This is wrong!
+     --print ("min max arrsize",min,max,arrsize)
+     per_char <- GET(XFontStruct,HT(XCharStruct),fs,per_char)
+     --putStrLn "after per_char"
+     elem9 <- if per_char /= nullPtr -- CCONST(NULL) 
+       then Just <$> mapM (\i -> INDEX(XCharStruct) per_char i >>= mkCharStruct) [0..arrsize-1] 
+       else return Nothing
+     --putStrLn "after elem9"
+     f_prop <- GET(XFontStruct,HT(XFontProp),fs,properties)
+     elemprop <- if f_prop /= nullPtr
+       then mapM (\i -> INDEX(XFontProp) f_prop i >>= mkFontProp) [0..n_prop-1]
+       else return []
+     -- putStrLn $ show elemprop
+     fsl <- FontStruct . FontId
+	<$> DEBUG(GET(XFontStruct,XID,fs,fid))
+	<*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,direction))
+	<*> return (toEnum min)
+	<*> return (toEnum max)
+	<*> fmap toEnum DEBUG(GET(XFontStruct,Int,fs,all_chars_exist))
+	<*> DEBUG(GET(XFontStruct,Char,fs,default_char))
+	<*> return elemprop
+	<*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)))
+	<*> (mkCharStruct =<< DEBUG(AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)))
+	<*> return elem9
+	<*> DEBUG(GET(XFontStruct,Int,fs,ascent))
+	<*> DEBUG(GET(XFontStruct,Int,fs,descent))
+     -- putStrLn $ "Returning from mkFontStructList'" ++ (show fsl)
+     return fsl
+
+-- Intermediate data for FontProp, containing just two integers:
+-- atom values will (hopefully) be retrieved lazily.
+
+mkFontProp :: CXFontProp -> IO FontProp
+
+mkFontProp fp = 
+  FontProp
+   <$> GET(XFontProp,Atom,fp,name)
+  <*> GET(XFontProp,Int,fp,card32)
+
+mkCharStruct :: CXCharStruct -> IO CharStruct
+mkCharStruct cs = 
+    CharStruct
+     <$> GET(XCharStruct,Int,cs,lbearing)
+     <*> GET(XCharStruct,Int,cs,rbearing)
+     <*> GET(XCharStruct,Int,cs,width)
+     <*> GET(XCharStruct,Int,cs,ascent)
+     <*> GET(XCharStruct,Int,cs,descent)
+
+mkVisual :: CVisual -> IO Visual
+mkVisual cv =
+  Visual
+   <$> GET(Visual,VisualID,cv,visualid)
+   <*> fmap toEnum GET(Visual,Int,cv,class)
+   <*> fmap intToWord GET(Visual,Int,cv,red_mask)
+   <*> fmap intToWord GET(Visual,Int,cv,green_mask)
+   <*> fmap intToWord GET(Visual,Int,cv,blue_mask)
+   <*> GET(Visual,Int,cv,bits_per_rgb)
+   <*> GET(Visual,Int,cv,map_entries)
+
+storeSwapAction :: [(WindowId,SwapAction)] -> IO (CXdbeSwapInfoArray,Int)
+storeSwapAction =
+  getArray newXdbeSwapInfoArray
+	   (\si (i,(wi,sa)) ->
+              do SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi)
+		 SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa))
+
+translateCoordinates display window dstwindow =
+  do dx <- newPtr
+     dy <- newPtr
+     child <- newPtr
+     ok <- xTranslateCoordinates display window dstwindow 0 0 dx dy child
+     p <- if ok
+          then Just <$> (Point <$> (fromEnum <$> readInt32 dx)
+                               <*> (fromEnum <$> readInt32 dy))
+          else return Nothing
+     freePtrs [dx,dy]
+     freePtr child
+     return p
+
diff --git a/hsrc/ghc-dialogue/EncodeEvent.hs b/hsrc/ghc-dialogue/EncodeEvent.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/EncodeEvent.hs
@@ -0,0 +1,261 @@
+{-# LANGUAGE CPP #-}
+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}
+module EncodeEvent(getNextEvent,motionCompress) where
+
+import Event
+import Xtypes
+--import ResourceIds
+
+import XCallTypes
+import StructFuns
+import Xlib
+import Marshall
+import MyForeign
+import qualified Foreign as F
+
+import FudUTF8(decodeUTF8)
+import Data.Maybe(fromMaybe)
+--import Ap
+
+--import GlaExts hiding(Word) --(primIOToIO,CCallable,CReturnable,Addr)
+--import MutableArray(MutableByteArray#)
+--import PrelGHC
+--import PrelBase
+--import GhcWord
+--import CString(unpackCStringIO)
+--import Command
+--import Font
+
+#include "newstructfuns.h"
+
+getNextEvent d = do
+   ev <- newXEvent
+   xNextEvent d ev
+   window <- GET(XAnyEvent,WindowId,ev,window)
+   fev <- encodeEvent ev
+   return (window,fev) -- no freePtr?!
+
+checkWindowEvent d w evmask = do
+   ev <- newXEvent
+   found <- xCheckWindowEvent d w (toC (evmask::[EventMask])) ev
+   if found
+     then Just <$> encodeEvent ev
+     else freePtr ev >> return Nothing
+
+motionCompress d e@(w,fev@MotionNotify{}) =
+  do me <- checkWindowEvent d w [PointerMotionMask]
+     case me of
+       Nothing -> return e
+       Just fev' -> motionCompress d (w,fev')
+motionCompress _ e = return e
+
+
+encodeEvent ev = do
+   evno <- GET(XAnyEvent,Int,ev,type)
+   case evno :: Int of
+
+{- ghc doesn't handle literal (``KeyPress'') patterns yet -}
+
+#define X_KeyPress		2
+#define X_KeyRelease		3
+#define X_ButtonPress		4
+#define X_ButtonRelease		5
+#define X_MotionNotify		6
+#define X_EnterNotify		7
+#define X_LeaveNotify		8
+#define X_FocusIn		9
+#define X_FocusOut		10
+#define X_KeymapNotify		11
+#define X_Expose		12
+#define X_GraphicsExpose	13
+#define X_NoExpose		14
+#define X_VisibilityNotify	15
+#define X_CreateNotify		16
+#define X_DestroyNotify		17
+#define X_UnmapNotify		18
+#define X_MapNotify		19
+#define X_MapRequest		20
+#define X_ReparentNotify	21
+#define X_ConfigureNotify	22
+#define X_ConfigureRequest	23
+#define X_GravityNotify		24
+#define X_ResizeRequest		25
+#define X_CirculateNotify	26
+#define X_CirculateRequest	27
+#define X_PropertyNotify	28
+#define X_SelectionClear	29
+#define X_SelectionRequest	30
+#define X_SelectionNotify	31
+#define X_ColormapNotify	32
+#define X_ClientMessage		33
+#define X_MappingNotify		34
+     X_KeyPress      	-> putKeyEvent ev Pressed
+     X_KeyRelease    	-> putKeyEvent ev Released
+     X_ButtonPress   	-> putButtonEvent ev Pressed
+     X_ButtonRelease 	-> putButtonEvent ev Released
+     X_MotionNotify  	-> putMotionEvent ev
+     X_EnterNotify   	-> putCrossingEvent ev True
+     X_LeaveNotify   	-> putCrossingEvent ev False
+     X_FocusIn       	-> putFocusChangeEvent ev True
+     X_FocusOut      	-> putFocusChangeEvent ev False
+     X_KeymapNotify  	-> return KeymapNotify
+     X_Expose	       	-> putExposeEvent ev
+     X_GraphicsExpose	-> putGraphicsExposeEvent ev
+     X_NoExpose		-> return NoExpose
+     X_VisibilityNotify	-> putVisibilityEvent ev
+     X_CreateNotify	-> putStructEvent ev CreateNotify
+     X_DestroyNotify	-> putStructEvent ev DestroyNotify
+     X_UnmapNotify	-> putStructEvent ev UnmapNotify
+     X_MapNotify	-> putStructEvent ev MapNotify
+     X_MapRequest	-> putStructEvent ev MapRequest
+     X_ReparentNotify	-> return ReparentNotify
+     X_ConfigureNotify	-> putConfigureEvent ev
+     X_ConfigureRequest	-> return ConfigureRequest
+     X_GravityNotify	-> return GravityNotify
+     X_ResizeRequest	-> putResizeRequestEvent ev
+     X_CirculateNotify	-> return CirculateNotify
+     X_CirculateRequest	-> return CirculateRequest
+     X_PropertyNotify	-> return PropertyNotify
+     X_SelectionClear	-> putSelectionClearEvent ev
+     X_SelectionRequest	-> putSelectionRequestEvent ev
+     X_SelectionNotify	-> putSelectionNotifyEvent ev
+     X_ColormapNotify	-> return ColormapNotify
+     X_ClientMessage	-> putClientMessageEvent ev
+     X_MappingNotify	-> return MappingNotify
+
+mkClientData ev = do
+  format <- GET(XClientMessageEvent,Int,ev,format)
+  d <- AGET(XClientMessageEvent,Addr,ev,data)
+  case format::Int of
+    32 -> Long <$> mapM (CINDEX(long) (d::Addr)) [0..(4::Int)]
+    16 -> Short <$> mapM (CINDEX(short) d) [0..(9::Int)]
+    8  -> Byte <$> mapM (CINDEX(char) d) [0..(19::Int)]
+
+putKeyEvent ev p = do
+  (key,l) <- xLookupString ev 100
+  KeyEvent
+   <$> GET(XKeyEvent,Time,ev,time)
+   <*> mkPoint GET(XKeyEvent,Int,ev,x) GET(XKeyEvent,Int,ev,y)
+   <*> mkPoint GET(XKeyEvent,Int,ev,x_root) GET(XKeyEvent,Int,ev,y_root)
+   <*> fmap fromC GET(XKeyEvent,Int,ev,state)
+   <*> return p
+   <*> fmap KeyCode GET(XKeyEvent,Int,ev,keycode)
+   <*> return key
+   <*> return (decodeUTF8 l)
+             -- !! Assume that XLookupString returns a UTF-8 string
+             -- https://gitlab.freedesktop.org/xorg/lib/libx11/-/issues/39
+
+putButtonEvent ev p =
+   ButtonEvent
+   <$> GET(XButtonEvent,Time,ev,time)
+   <*> mkPoint GET(XButtonEvent,Int,ev,x) GET(XButtonEvent,Int,ev,y)
+   <*> mkPoint GET(XButtonEvent,Int,ev,x_root) GET(XButtonEvent,Int,ev,y_root)
+   <*> fmap fromC GET(XButtonEvent,Int,ev,state)
+   <*> return p
+   <*> fmap Button GET(XButtonEvent,Int,ev,button)
+
+putMotionEvent ev =
+   MotionNotify
+   <$> GET(XMotionEvent,Time,ev,time)
+   <*> mkPoint GET(XMotionEvent,Int,ev,x) GET(XMotionEvent,Int,ev,y)
+   <*> mkPoint GET(XMotionEvent,Int,ev,x_root) GET(XMotionEvent,Int,ev,y_root)
+   <*> fmap fromC GET(XMotionEvent,Int,ev,state)
+
+putCrossingEvent ev c =
+   (if c then EnterNotify else LeaveNotify)
+   <$> GET(XCrossingEvent,Time,ev,time)
+   <*> mkPoint GET(XCrossingEvent,Int,ev,x) GET(XCrossingEvent,Int,ev,y)
+   <*> mkPoint GET(XCrossingEvent,Int,ev,x_root) GET(XCrossingEvent,Int,ev,y_root)
+   <*> fmap fromC GET(XCrossingEvent,Int,ev,detail)
+   <*> fmap fromC GET(XCrossingEvent,Int,ev,mode)
+   <*> fmap fromC GET(XCrossingEvent,Int,ev,focus)
+
+
+putFocusChangeEvent ev c =
+   (if c then FocusIn else FocusOut)
+   <$> fmap fromC GET(XFocusChangeEvent,Int,ev,detail)
+   <*> fmap fromC GET(XFocusChangeEvent,Int,ev,mode)
+
+putExposeEvent ev =
+   Expose
+   <$> mkRect GET(XExposeEvent,Int,ev,x) GET(XExposeEvent,Int,ev,y)
+	       GET(XExposeEvent,Int,ev,width) GET(XExposeEvent,Int,ev,height) 
+   <*> GET(XExposeEvent,Int,ev,count)
+
+putGraphicsExposeEvent ev =
+   GraphicsExpose 
+   <$> mkRect GET(XGraphicsExposeEvent,Int,ev,x) GET(XGraphicsExposeEvent,Int,ev,y)
+	       GET(XGraphicsExposeEvent,Int,ev,width) GET(XGraphicsExposeEvent,Int,ev,height) 
+   <*> GET(XGraphicsExposeEvent,Int,ev,count)
+   <*> GET(XGraphicsExposeEvent,Int,ev,major_code)
+   <*> GET(XGraphicsExposeEvent,Int,ev,minor_code)
+
+putVisibilityEvent ev =
+  VisibilityNotify . fromC <$> GET(XVisibilityEvent,Int,ev,state)
+
+putStructEvent ev c = c <$> GET(XMapEvent,WindowId,ev,window)
+
+putConfigureEvent ev =
+   ConfigureNotify
+   <$> mkRect GET(XConfigureEvent,Int,ev,x) GET(XConfigureEvent,Int,ev,y)
+               GET(XConfigureEvent,Int,ev,width) GET(XConfigureEvent,Int,ev,height)
+   <*> GET(XConfigureEvent,Int,ev,border_width)
+
+putResizeRequestEvent ev =
+   ResizeRequest 
+  <$> mkPoint GET(XResizeRequestEvent,Int,ev,width)
+             GET(XResizeRequestEvent,Int,ev,height)
+
+putSelectionClearEvent ev = SelectionClear
+ <$> GET(XSelectionClearEvent,Atom,ev,selection)
+
+putSelectionRequestEvent ev =
+  SelectionRequest
+  <$> GET(XSelectionRequestEvent,Time,ev,time)
+  <*> GET(XSelectionRequestEvent,WindowId,ev,requestor)
+  <*> (Selection <$> GET(XSelectionRequestEvent,Atom,ev,selection)
+		<*> GET(XSelectionRequestEvent,Atom,ev,target)
+		<*> GET(XSelectionRequestEvent,Atom,ev,property))
+
+putSelectionNotifyEvent ev =
+  SelectionNotify
+  <$> GET(XSelectionEvent,Time,ev,time)
+  <*> (Selection <$> GET(XSelectionEvent,Atom,ev,selection)
+		<*> GET(XSelectionEvent,Atom,ev,target)
+		<*> GET(XSelectionEvent,Atom,ev,property))
+
+putClientMessageEvent ev =
+  ClientMessage
+  <$> GET(XClientMessageEvent,Atom,ev,message_type)
+  <*> mkClientData ev
+
+foreign import ccall "X11/Xlib.h XLookupString"
+  cXLookupString :: CXKeyEvent -> Addr -> Int -> F.Ptr XlibKeySym -> Addr -> IO Int
+
+xLookupString :: CXKeyEvent -> Int -> IO (KeySym,String)
+xLookupString xev len =
+    alloca len $ \ arr ->
+    F.alloca $ \ keysyma ->
+    do len' <- {- _casm_ ``%r=(int)XLookupString((XKeyEvent *)%0,
+					  (char *)%1,
+					  (int)%2,
+					  (KeySym *)%3,
+					  NULL);'' xev arr len keysyma -}
+           cXLookupString xev arr len keysyma nullAddr
+       keysym <- F.peek keysyma
+       key <- xKeysymToString keysym
+       let key' = fromMaybe "(undefined)" key
+       str <- unmarshallString' (CString arr) len'
+       return (key',str)
+
+instance FromC Detail where fromC = toEnum' NotifyAncestor
+instance FromC Mode where fromC = toEnum' NotifyNormal
+instance FromC Visibility where fromC = toEnum' VisibilityUnobscured
+
+
+instance F.Storable XID where
+  sizeOf (XID x) = F.sizeOf x
+  alignment (XID x) = F.alignment x
+
+  peek a = fmap XID (F.peek (F.castPtr a))
+  poke a (XID x) = F.poke (F.castPtr a) x
diff --git a/hsrc/ghc-dialogue/IOUtil.hs b/hsrc/ghc-dialogue/IOUtil.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/IOUtil.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE CPP #-}
+module IOUtil(-- ** Some utilities that are a little dirty, but not very
+              getEnvi, progName, progArgs,
+              -- ** Backward compatibility
+              IOUtil.catch, try, getModificationTime) where
+
+import qualified Control.Exception as E
+import qualified System.Directory as D(getModificationTime)
+import System.Environment(getEnv,getProgName,getArgs)
+#ifdef VERSION_old_time
+import Data.Time(UTCTime)
+import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)
+import System.Time(ClockTime(..))
+#endif
+import UnsafePerformIO(unsafePerformIO)
+
+getEnvi :: String -> Maybe String
+getEnvi s = either (const Nothing) Just $ unsafePerformIO $ try (getEnv s)
+
+progName :: String
+progName = unsafePerformIO getProgName
+
+progArgs :: [String]
+progArgs = unsafePerformIO getArgs
+
+-- * GHC 6.12-7.6 compatibility
+catch = E.catch :: IO a -> (IOError -> IO a) -> IO a
+try   = E.try   :: IO a -> IO (Either IOError a)
+
+#ifdef VERSION_old_time
+getModificationTime path = toClockTime `fmap` D.getModificationTime path
+
+class    ToClockTime a         where toClockTime :: a -> ClockTime
+instance ToClockTime ClockTime where toClockTime = id
+instance ToClockTime UTCTime   where 
+    toClockTime = flip TOD 0 . floor . realToFrac . utcTimeToPOSIXSeconds
+#else
+getModificationTime path = D.getModificationTime path
+#endif
diff --git a/hsrc/ghc-dialogue/Marshall.hs b/hsrc/ghc-dialogue/Marshall.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/Marshall.hs
@@ -0,0 +1,187 @@
+module Marshall where
+import MyForeign
+import Control.Monad(zipWithM_)
+--import Ap
+
+class HasAddr a where
+   addrOf :: a -> Addr
+   --atAddr :: Addr -> a
+
+freePtr p = free (addrOf p)
+
+class HasAddr a => IsPtr a where
+   nullPtr :: a
+   newPtr :: IO a
+   newArray :: Int -> IO a
+
+   newPtr = newArray 1
+
+class (Storable h, HasAddr c) => CVar c h | c -> h where
+  readCVar :: c -> IO h
+  writeCVar :: c -> h -> IO ()
+  indexCVar :: c -> Int -> IO h
+  writeArray :: c -> [h] -> IO ()
+  readArray :: c -> Int -> IO [h]
+
+  readCVar = peek . addrOf
+  writeCVar = poke . addrOf
+  indexCVar = peekElemOff . addrOf
+  writeArray arr = zipWithM_ (pokeElemOff (addrOf arr)) [0..]
+  readArray arr n = mapM (indexCVar arr) [0..(n-1)]
+
+toArray xs =
+  do let n = length xs
+     a <- newArray n
+     writeArray a xs
+     return (a,n)
+
+{-
+instance (Storable a,Storable b) => (Storable (a,b)) where
+  sizeOf (a,b) = sizeOf a+sizeOf b
+  alignment (a,b) = max (alignment a) (alignment b)
+  poke p (a,b) = poke p a >> poke (p `plusAddr` sizeOf a) b
+  peek p = do a <- peek p
+	      b <- peek (p `plusAddr` sizeOf a) p
+	      return (a,b)
+-}
+
+-------------------
+class PrimArg ha pa r | ha->pa where
+  --marshall :: haskell -> IO (prim,IO ())
+  marshall :: (pa->r)->ha->r
+
+-- marshallM x = marshall return x -- GHC generates buggy code, it seems
+
+instance PrimArg Int Int c where marshall = id
+instance PrimArg Int32 Int32 c where marshall = id
+--instance PrimArg Char Char c where marshall = id
+instance PrimArg Bool Bool c where marshall = id
+--instance PrimArg () Int c where marshall f () = f 0
+instance PrimArg Addr Addr c where marshall = id
+instance PrimArg CLong CLong c where marshall = id
+instance PrimArg CInt32 CInt32 c where marshall = id
+instance PrimArg CString CString c where marshall = id
+
+class    Bind f                where bind :: IO o->(o->f)->f
+				     thn :: f->IO ()-> f
+instance Bind (IO a)           where bind = (>>=)
+				     thn f io = do r<-f;io;return r
+instance Bind f => Bind (a->f) where bind ioo oaf = bind ioo . flip oaf
+				     thn f io a = f a `thn` io
+
+instance Bind f => PrimArg String CString f where
+  marshall f str =
+     marshallString str `bind` \ cstr ->
+     f cstr `thn`
+     freePtr cstr
+
+class PrimResult prim haskell where
+  unmarshall :: prim -> haskell
+
+instance PrimResult () () where unmarshall = id
+instance PrimResult Bool Bool where unmarshall = id
+instance PrimResult Char Char where unmarshall = id
+instance PrimResult Int Int where unmarshall = id
+instance PrimResult Int32 Int32 where unmarshall = id
+
+--instance PrimResult Int (IO Int) where unmarshall = return
+
+instance PrimResult (IO ()) (IO ()) where unmarshall = id
+instance PrimResult (IO Int) (IO Int) where unmarshall = id
+instance PrimResult (IO Int32) (IO Int32) where unmarshall = id
+instance PrimResult (IO Bool) (IO Bool) where unmarshall = id
+instance PrimResult (IO CString) (IO CString) where unmarshall = id
+
+unmarshallM m = unmarshall =<< m
+unmarshallArray a n = mapM unmarshall =<< readArray a n
+
+instance PrimResult (IO CString) (IO (Maybe String)) where
+  unmarshall addrIO =
+    do cstr <- addrIO
+       if addrOf cstr==nullAddr
+        then return Nothing
+        else Just <$> unmarshall cstr
+
+instance PrimResult CString (IO String) where unmarshall = unmarshallString
+instance PrimResult (IO CString) (IO String) where unmarshall = unmarshallM
+
+instance (PrimArg ha pa pb,PrimResult pb hb) => PrimResult (pa->pb) (ha->hb) where
+    -- have: marshall      :: (pa->pb)->(ha->pb)
+    -- have: unmarshall    :: pb->hb
+    -- produce: unmarshall :: (pa->pb)->(ha->hb)
+    unmarshall papb ha = unmarshall (marshall papb ha)
+
+--- Primitive marshalling
+
+newtype CString = CString Addr deriving (Eq)
+instance HasAddr CString where addrOf (CString a) = a --; atAddr = CString
+instance CVar CString CString
+instance Storable CString where
+  sizeOf (CString a) = sizeOf a
+  alignment (CString a) = alignment a
+  peek p = CString <$> peek p
+  poke p (CString a) = poke p a
+
+nullStr = CString nullAddr
+
+marshallString :: String -> IO CString
+marshallString s = marshallString' s (length s)
+
+marshallString' :: String -> Int -> IO CString
+marshallString' s n = 
+  do a <- mallocElems (head s) (n+1)
+     zipWithM_ (pokeElemOff a) [0..n-1] s
+     pokeElemOff a n '\0'
+     return (CString a)
+
+
+unmarshallString :: CString -> IO String
+unmarshallString (CString addr) = get 0
+  where 
+    get i =
+      do c <- peekElemOff addr i
+	 if c=='\0'
+	  then return []
+	  else (c:) <$> get (i+1)
+              
+unmarshallString' :: CString -> Int -> IO String
+unmarshallString' (CString addr) n = get 0
+  where
+    get i =
+      if i<n
+      then (:) <$> peekElemOff addr i <*> get (i+1)
+      else return []
+     
+
+---
+
+-- | Pointer to long int (same size as pointers, 64 bits on 64-bit systems)
+newtype CLong = CLong Addr
+newtype CXID = CXID Addr
+
+instance HasAddr CLong where addrOf (CLong a) = a --;atAddr = CLong
+instance HasAddr CXID where addrOf (CXID a) = a --;atAddr = CLong
+
+instance IsPtr CLong where
+  nullPtr = CLong nullAddr
+  newPtr = CLong <$> mallocElem (0::Int)
+  newArray n = CLong <$> mallocElems (0::Int) n
+
+instance IsPtr CXID where
+  nullPtr = CXID nullAddr
+  newPtr = CXID <$> mallocElem (0::Int)
+  newArray n = CXID <$> mallocElems (0::Int) n
+
+instance CVar CLong Int
+
+-- | Pointer to C int (32 bits even on 64-bit system)
+newtype CInt32 = CInt32 Addr
+
+instance HasAddr CInt32 where addrOf (CInt32 a) = a --;atAddr = CInt
+
+instance IsPtr CInt32 where
+  nullPtr = CInt32 nullAddr
+  newPtr = CInt32 <$> mallocElem (0::Int32)
+  newArray n = CInt32 <$> mallocElems (0::Int32) n
+
+instance CVar CInt32 Int32
diff --git a/hsrc/ghc-dialogue/MyForeign.hs b/hsrc/ghc-dialogue/MyForeign.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/MyForeign.hs
@@ -0,0 +1,93 @@
+module MyForeign(module MyForeign,(<$>),(<*>),F.Int32,F.CSize(..)) where
+import Control.Applicative
+import qualified Foreign as F
+import qualified Foreign.C as F
+import Foreign.C.String(castCCharToChar,castCharToCChar)
+--import CCall
+import Control.Exception(bracket)
+--import Ap
+-- Emulate GHC 4.08 libraries on top of GHC 5.00 libraries...
+
+newtype Addr = Addr (F.Ptr F.Word8) deriving (Eq,Show)
+type AddrOff = Int
+
+--instance CCallable Addr
+--instance CReturnable Addr
+
+class Storable a where
+  sizeOf      :: a -> Int
+  alignment   :: a -> Int
+
+  peekElemOff :: Addr -> Int          -> IO a
+  pokeElemOff :: Addr -> Int     -> a -> IO ()
+
+  peekByteOff :: Addr -> AddrOff      -> IO a
+  pokeByteOff :: Addr -> AddrOff -> a -> IO ()
+
+  peek        :: Addr                 -> IO a
+  poke        :: Addr            -> a -> IO ()
+
+  peek a = peekByteOff a 0
+  poke a = pokeByteOff a 0
+
+  peekElemOff a i =
+    let iox = peekByteOff a (i*sizeOf (u iox))
+	u :: IO a -> a
+	u = undefined
+    in iox
+  pokeElemOff a i x = pokeByteOff a (i*sizeOf x) x
+
+  peekByteOff a i = peek (a `plusAddr` i)
+  pokeByteOff a i = poke (a `plusAddr` i)
+
+malloc n = Addr <$> F.mallocBytes n
+mallocElem x = malloc (sizeOf x)
+mallocElems x n = malloc (n*sizeOf x)
+free (Addr p) = F.free p
+alloca n = bracket (malloc n) free
+allocaElem x = bracket (mallocElem x) free
+allocaElems x n = bracket (mallocElems x n) free
+
+nullAddr = Addr F.nullPtr
+plusAddr (Addr p) n = Addr (F.plusPtr p n)
+minusAddr (Addr p1) (Addr p2) = F.minusPtr p1 p2
+
+instance Storable Addr where
+  sizeOf (Addr a) = F.sizeOf a
+  alignment (Addr a) = F.alignment a
+
+  peek a = Addr <$> fpeek a
+  poke a (Addr x) = fpoke a x
+
+instance Storable Char where
+  sizeOf _ = 1
+  alignment _ = 1
+
+  peek a = castCCharToChar <$> fpeek a
+  poke a c = fpoke a (castCharToCChar c)
+
+fpeek (Addr p) = F.peek (F.castPtr p)
+fpoke (Addr p) = F.poke (F.castPtr p)
+
+instance Storable Int where
+  sizeOf x = F.sizeOf x
+  alignment x = F.alignment x
+
+  peek = fpeek
+  poke = fpoke
+
+
+instance Storable F.Int32 where
+  sizeOf x = F.sizeOf x
+  alignment x = F.alignment x
+
+  peek = fpeek
+  poke = fpoke
+
+
+instance Storable F.Word32 where
+  sizeOf x = F.sizeOf x
+  alignment x = F.alignment x
+
+  peek = fpeek
+  poke = fpoke
diff --git a/hsrc/ghc-dialogue/PQueue.hs b/hsrc/ghc-dialogue/PQueue.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/PQueue.hs
@@ -0,0 +1,16 @@
+module PQueue where
+
+newtype PQueue a b = PQueue [(a,b)] deriving Show
+
+empty = PQueue []
+
+insert (PQueue q) v@(p,a) = PQueue $ insert' q where
+   insert' [] = [v]
+   insert' q@(v'@(p',_):q') | p < p'    = v : q
+			    | otherwise = v' : insert' q'
+
+inspect (PQueue q) = case q of
+	[] -> Nothing
+	(x:xs) -> Just (x,PQueue xs)
+
+remove (PQueue q) i = PQueue $ filter (\((_,(_,i')))->i'/=i) q
diff --git a/hsrc/ghc-dialogue/P_IO_data.hs b/hsrc/ghc-dialogue/P_IO_data.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/P_IO_data.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE CPP #-}
+-- | Types for Haskell 1.2 dialogue I/O
+module P_IO_data {-(module XStuff, module P_IO_data)-} where
+import XStuff
+import ShowFun()
+import Prelude hiding (IOError)
+import System.Directory(XdgDirectory)
+#ifdef VERSION_old_time
+import System.Time(ClockTime,CalendarTime)
+#endif
+#ifdef VERSION_time
+import Data.Time(UTCTime,ZonedTime)
+#endif
+
+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
+                 -- useful for IO with GHC >=6.12
+ 			| ReadBinaryFile  String         
+ 			| WriteBinaryFile String String
+                -- Files at standard locations for application data
+                        | ReadXdgFile XdgDirectory String
+                        | WriteXdgFile XdgDirectory String String
+		-- channel system requests:
+			| ReadChan	String 
+			| AppendChan    String String
+			| ReadBinChan   String 
+			| AppendBinChan String Bin
+			| StatusChan    String
+		-- environment requests:
+			| Echo          Bool
+			| GetArgs
+			| GetEnv        String
+			| SetEnv        String String
+		-- optional
+			| ReadChannels	[String]
+			| ReadBinChannels [String]
+			| CreateProcess	Dialogue
+			| CreateDirectory String String
+			| OpenFile	String Bool
+			| OpenBinFile	String Bool
+			| CloseFile	File
+			| ReadVal	File
+			| ReadBinVal	File
+			| WriteVal	File Char
+			| WriteBinVal	File Bin
+		-- hbc bonus
+			| Sleep		Double
+			| ChangeDirectory String
+			| GetTime -- returns ClockTime -- /TH 2002-04-14
+			| DeleteDirectory String
+			| System	String
+	                | ReadDirectory String
+	                | XCommand    (XDisplay,XWId,XCommand)
+	                | GetAsyncInput
+			| GetCpuTime
+			| GetProgName
+                        | GetLocalTime -- return CalendarTime
+#ifdef VERSION_old_time
+                        | ToCalendarTime ClockTime -- returns CalendarTime
+#endif
+			| SigAction Int SigAct
+			| Exit Int
+			| ReadFileScattered String [Int]
+			| Select       [Descriptor]
+			| SocketRequest SocketRequest
+			| XRequest     (XDisplay,XWId,XRequest)
+			| ReadFileFast String         
+			| RenameFile String String
+			| GetCurrentDirectory
+
+		        | GetModificationTime FilePath -- returns ClockTime
+                        | GetCurrentTime               -- returns UTCTime
+                        | GetZonedTime                 -- returns ZonedTime
+{-
+			-- Haskell 1.3 I/O
+			| H_OpenFile String Int		-- return Fil
+			| H_Close File			-- return Success
+			| H_FileSize File		-- return IntResp
+			| H_IsEOF File			-- return IntResp
+			| H_SetBuffering File Int	-- return Success
+			| H_GetBuffering File		-- return IntResp
+			| H_Flush File			-- return Success
+			| H_Seek File Int Int		-- return IntResp
+			| H_GetFlags File		-- return IntResp
+			| H_GetChar File		-- return IntResp
+			| H_UnGetChar File Int		-- return Success
+			| H_PutChar File Int		-- return Success
+			| H_PutString File String	-- return Success
+			| H_GetFile File		-- return Str
+			| H_Select ([File], [File], [Double]) -- return SelectResp, last list is a Maybe
+			| H_CCall _CPointer [_CUnion] _CUnion -- return CCallResp
+			| __RunAnswer __Answer		-- never returns
+			| H_GetTime			-- returns GetTimeResp
+			| H_GetErrno			-- returns IntResp
+-}
+                      deriving (Show,Read)
+
+{-
+data __Answer = __Answer EXISTVAR
+
+instance Text __Answer where
+    showsType _ = showString "__Answer"
+
+
+data _CUnion  =		  _CUInt Int
+			| _CUDouble Double 
+			| _CUString String 
+			| _CUPointer _CPointer
+#ifdef P_IO_data
+			| _CUByteVector _ByteVector._ByteVector
+#endif
+		deriving (Eq, Text)
+
+ISO(_CPointer , _CPointer , Int) deriving (Eq, Text)
+-}
+data SigAct   =		  SAIgnore
+			| SADefault
+			| SACatch (String -> Dialogue)
+		deriving (Show,Read)
+
+data Response =		  Success
+			| Str String 
+			| Bn  Bin
+			| Failure IOError
+			| Tag [(String, Char)]
+			| BinTag [(String, Bin)]
+	                | StrList [String]
+			| Fil File
+			| Dbl Double
+	                | AsyncInput AsyncInput
+			| SocketResponse SocketResponse
+			| XResponse XResponse
+			| IntResp Int
+			| SelectResp [([File], [File], [Double])]
+			| SigActResp SigAct
+--			| CCallResp _CUnion
+--			| GetTimeResp Double Bool String Int
+#ifdef VERSION_old_time
+			| ClockTime ClockTime -- response to GetTime --
+			| CalendarTime CalendarTime -- response to GetLocalTime
+#endif
+#ifdef VERSION_time
+                        | UTCTime UTCTime         -- response to GetCurrentTime
+                        | ZonedTime ZonedTime     -- response to GetZonedTime
+#endif
+		deriving (Show,Read)
+
+data IOError =		  WriteError   String
+			| ReadError    String
+			| SearchError  String
+			| FormatError  String
+			| OtherError   String
+		deriving (Show,Read)
+
+
+type Bin = Unused
+type Dialogue = [Response] -> [Request] -- not useful anymore
+--type _CUnion = Unused
+type File = Unused
+
+type Unused = ()
+
+#ifdef VERSION_old_time
+instance Read ClockTime -- !!!
+#endif
diff --git a/hsrc/ghc-dialogue/StructFuns.hs b/hsrc/ghc-dialogue/StructFuns.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/StructFuns.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE CPP #-}
+{- Obsolete OPTIONS -fvia-C -}
+module StructFuns(module StructFuns,module CSizes) where
+import MyForeign
+import Marshall
+import Xlib
+import CSizes
+import Xtypes(XID(..),Atom(..),Time,WindowId(..),Window)
+import Visual(VisualID(..))
+import HbcWord(Word)
+import Data.Word(Word32)
+
+--import GlaExts hiding (Word,(<#),Addr)
+
+{-
+#include "structs.h"
+#include "cimports.h"
+-}
+#include "ccalls.h"
+
+H_STRUCTTYPE(timeVal)
+H_STRUCTTYPE(sockAddr)
+
+type Cchar = Char
+type Clong = Int
+type Cshort = Int
diff --git a/hsrc/ghc-dialogue/XCallTypes.hs b/hsrc/ghc-dialogue/XCallTypes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/XCallTypes.hs
@@ -0,0 +1,116 @@
+{- unused options -#include <X11/Xlib.h> -#include <X11/Xutil.h> -fvia-C -}
+-- -optc-I/usr/X11R6/include
+module XCallTypes
+ --(module XCallTypes,newCharArray,MutableByteArray(..))
+ where
+
+import Data.Bits
+import Data.Word(Word32)
+import Control.Applicative
+import Control.Monad(foldM)
+--import MyForeign(Int32)
+
+import Utils(number)
+import Xtypes
+import Geometry
+--import Ap(foldR)
+--import PackedString(unpackPS,byteArrayToPS{-,packCString-})
+
+-- #include "structs.h"
+
+getEnum bla = fromEnum
+toEnum' bla = toEnum
+{-
+toEnum' s = (a!)
+  where a = listArray (0,length l - 1) l
+        l = [s..]
+
+getEnum s = (a!)
+  where a = listArray (s,last [s..]) [(0::Int)..]
+-}
+
+class ToC a where toC :: a -> Int
+class ToCl a where toCl :: [a] -> Int
+class FromC a where fromC :: Int -> a
+
+class ToXID a where toXID :: a -> XID
+--class FromXID a where fromXID :: XID -> a
+
+instance (ToCl a) => ToC [a] where toC = toCl
+
+instance ToCl EventMask where 
+   toCl = fromIntegral . foldr getE (0::Word32)
+     where
+       getE e m = setBit m (fromEnum e)
+
+instance ToC Bool where toC False = 0
+                        toC True = 1
+
+instance FromC Bool where fromC 0 = False
+                          fromC _ = True
+
+
+instance ToXID PixmapId where toXID (PixmapId p) = p
+instance ToC Pixel where toC (Pixel p) = fromIntegral p
+instance ToXID ColormapId where toXID (ColormapId p) = p
+instance ToXID CursorId where toXID (CursorId p) = p
+instance ToXID FontId where toXID (FontId p) = p
+--instance ToC WindowId where toC (WindowId p) = p
+--instance ToC Display where toC (Display p) = p
+--instance ToC Width where toC (Width p) = p
+--instance ToC Atom where toC (Atom p) = p
+--instance ToC PropertyMode where toC (PropertyMode p) = p
+
+--pIoCmd x = primIOToIO x :: IO ()
+--pIoCmd x = stToIO x :: IO ()
+ioCmd x = x :: IO ()
+
+getValues new getValue vl = do
+  vs <- new
+  let maskf mask val = do set; return (mask .|. m)
+                  where (set,m) = getValue vs val
+  mask <- foldM maskf 0 vl
+  return (vs,mask)
+
+failu :: String -> IO a
+failu = ioError . userError
+
+--unpackCharArray len a = fmap (take len . unpackPS . byteArrayToPS) $
+--    stToIO $ unsafeFreezeByteArray a
+
+--cstring :: Addr -> String -- This type looks a bit suspicious... /TH 990211
+--cstring = unpackCString
+
+getArray new mod l = do
+       arr <- new size
+       mapM_ (mod arr) (number 0 l)
+       return (arr,size)
+   where size = length l
+
+
+{-
+H_ARRAY(int)
+newInt = newintArray 1
+readInt i = CINDEX(int) (i::Cint) (0::Int) :: IO Int
+writeInt i v = SINDEX(int,i::Cint,0::Int,v::Int)
+-}
+
+mkPoint x y = Point <$> x <*> y
+mkRect x y w h = Rect <$> mkPoint x y <*> mkPoint w h
+
+--mkAtom a = fmap Atom a
+--mkSelection s t p = Selection <$> mkAtom s <*> mkAtom t <*> mkAtom p
+--mkSelection s t p = Selection <$> s <*> t <*> p
+
+instance FromC ModState where 
+ fromC ni = [toEnum i|i<-[15,14..0],testBit ni i]
+{-
+     concatMap toModifier [15,14..0]
+   where
+     toModifier i = [toEnum i|testBit ni i]
+--   toe = toEnum' Shift -- . fromIntegral
+--   n = fromIntegral ni :: Word32
+-}
+
+notImplemented x = take 79 ("Not implemented: "++show x)++"\n"
+
diff --git a/hsrc/ghc-dialogue/Xlib.hs b/hsrc/ghc-dialogue/Xlib.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/Xlib.hs
@@ -0,0 +1,344 @@
+{-# LANGUAGE CPP #-}
+{- Obsolete OPTIONS -optc-I/usr/X11R6/include -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/extensions/shape.h> -#include <X11/extensions/Xdbe.h> -fvia-C -}
+module Xlib where
+import Marshall
+import MyForeign
+import CSizes
+import Xtypes
+import Visual
+import Font(FontDirection)
+import CString16(CString16)
+
+import DrawTypes
+
+import Control.Monad(zipWithM_)
+--import Ap
+import Data.Word(Word,Word32)
+--import CCall
+default(Int)
+
+#include "structs.h"
+
+type Unsigned = Int -- hmm
+type Unsigned32 = Int32 -- hmm
+type Status = Int
+type Screen = Int
+type Bitmask = Word32
+type XlibKeySym = XID -- KeySym in Xlib, defined as String in Fudgets
+type ClipOrdering = Ordering'
+type CPixelArray = CLong
+type CStringArray = CString
+type CXFontStructArray = CXFontStruct
+type CDisplay = Addr
+type CGCId = Addr
+newtype Region = Region Addr
+
+#define FI(f) foreign import ccall unsafe "f" prim/**/f
+#define PXlib(f,p,h) FI(X/**/f) :: p ; x/**/f :: h ; x/**/f = call primX/**/f
+#define Xlib(f,h) PXlib(f,h,h)
+
+#define PReq0(f,pr,r) PXlib(f,CDisplay -> IO pr, Display -> IO r)
+#define Req0(f,r) PReq0(f,r,r)
+#define Req(f,t,r) PReq(f,t,r,t,r)
+#define PReq(f,p,pr,t,r) PXlib(f,CDisplay -> p -> IO pr, Display-> t ->IO r)
+#define WindowReq(f,t,r) Req(f,Window->t,r)
+#define PWindowReq(f,pt,pr,t,r) PReq(f,Window->pt,pr,Window->t,r)
+#define WindowReqP(f,t,pr,r) PReq(f,Window->t,pr,Window->t,r)
+#define DrawReq(f,t,r) Req(f,DrawableId->t,r)
+#define DrawReqP(f,t,pr,r) PReq(f,DrawableId->t,pr,DrawableId->t,r)
+
+#define Cmd0(f) PXlib(f,CDisplay -> IO (), Display-> IO ())
+#define Cmd(f,t) Req(f,t,())
+#define PCmd(f,p,t) PXlib(f,CDisplay -> p -> IO (), Display-> t ->IO ())
+#define WindowCmd0(f) Cmd(f,Window)
+#define WindowCmd(f,t) Cmd(f,Window->t)
+#define PWindowCmd(f,p,t) PCmd(f,Window->p,Window->t)
+#define DrawCmd(f,t) PCmd(f,DrawableId->CGCId->t,DrawableId->GCId->t)
+#define DrawPCmd(f,p,t) PCmd(f,DrawableId->CGCId->p,DrawableId->GCId->t)
+
+--- Calls ---------------------------------------------------------------------
+PXlib(OpenDisplay,  CString -> IO CDisplay, String -> IO Display)
+Cmd0(CloseDisplay)
+Req0(ConnectionNumber,Int32)
+Cmd0(Flush)
+Cmd(NextEvent,CXEvent)
+WindowReq(CheckWindowEvent,Int->CXEvent,Bool)
+Req0(Pending,Int)
+Cmd(FreePixmap,PixmapId)
+Cmd(Synchronize,Bool) -- result is ignored.
+Cmd(Sync,Bool)
+Cmd(Bell,Int)
+
+FI(XInitThreads) :: IO Int
+xInitThreads = fmap (/=0) primXInitThreads
+Cmd0(LockDisplay)
+Cmd0(UnlockDisplay)
+
+FI(XFree) :: Addr -> IO ()
+xFree p = primXFree (addrOf p)
+
+Req0(DefaultScreen,Screen)
+Req0(DefaultRootWindow,Window)
+PReq0(ImageByteOrder,Int,ByteOrder)
+Req(DefaultDepth,Screen,Int)
+Req(BlackPixel,Int,Unsigned)
+Req(WhitePixel,Int,Unsigned)
+Req(DefaultColormap,Int,ColormapId)
+Req(DefaultVisual,Screen,CVisual)
+
+PReq(LoadFont,CString,FontId,String,FontId)
+Req(QueryFont,FontId,CXFontStruct)
+PReq(LoadQueryFont,CString,CXFontStruct,String,CXFontStruct)
+PReq(ListFonts,CString->Int->CLong,CStringArray,String->Int->CLong,CStringArray)
+Xlib(FreeFontNames,CStringArray->IO())
+PReq(ListFontsWithInfo,CString->Int->CInt32->CCXFontStruct,CStringArray,String->Int->CInt32->CCXFontStruct,CStringArray)
+Xlib(FreeFontInfo,CStringArray->CXFontStructArray->Int32->IO ())
+Cmd(QueryTextExtents16,FontId->CString16->Int->CLong->CLong->CLong->CXCharStruct)
+
+Req(CreateFontCursor,Int,CursorId)
+Req(CreatePixmap,DrawableId->Unsigned->Unsigned->Unsigned,PixmapId)
+PReq(InternAtom,CString->Bool,Atom,String->Bool,Atom)
+Req(GetAtomName,Atom,CString)
+Req(AllocColor,ColormapId->CXColor,Status)
+PReq(AllocNamedColor,ColormapId->CString->CXColor->CXColor,Status,ColormapId->String->CXColor->CXColor,Status)
+Cmd(QueryColor,ColormapId->CXColor)
+Cmd(FreeColors,ColormapId->CPixelArray->Int->Pixel)
+{- -- This creates a dangling reference to the image data!
+PReq(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage,
+                 CVisual->Int->Int->Int->String->Int->Int->Int->Int,CXImage)
+-}
+Req(CreateImage,CVisual->Int->Int->Int->CString->Int->Int->Int->Int,CXImage)
+
+DrawCmd(PutImage,CXImage->Int32->Int32->Int32->Int32->Int32->Int32)
+
+-- Xlib(DestroyImage,CXImage->IO ()) -- XDestroyImage is a macro in X11/Xutil.h
+foreign import ccall "asyncinput.h" xDestroyImage :: CXImage -> IO ()
+
+
+WindowCmd0(DestroyWindow)
+WindowCmd0(MapRaised)
+WindowCmd0(LowerWindow)
+WindowCmd0(UnmapWindow)
+WindowCmd0(ClearWindow)
+WindowCmd(ClearArea,Int->Int->Int->Int->Bool)
+WindowReq(CreateSimpleWindow,Int->Int->Unsigned->Unsigned->Unsigned->Unsigned->Unsigned,Window)
+PWindowCmd(StoreName,CString,String)
+WindowCmd(SetClassHint,CXClassHint)
+WindowCmd(ConfigureWindow,Bitmask->CXWindowChanges)
+WindowCmd(ChangeWindowAttributes,Bitmask->CXSetWindowAttributes)
+WindowCmd(ReparentWindow,Window->Int->Int)
+PWindowCmd(SetWMProtocols,CAtomArray->Int,[Atom]->Int)
+WindowCmd(SetNormalHints,CXSizeHints)
+WindowCmd(SetWMHints,CXWMHints)
+WindowReq(SendEvent,Bool->Bitmask->CXEvent,Status)
+PWindowCmd(ChangeProperty,Atom->Atom->Int->PropertyMode->CString->Int,Atom->Atom->Int->PropertyMode->String->Int)
+WindowReq(GetWindowProperty,Atom->Int->Int->Bool->Atom->CAtom->CLong->CLong->CLong->CCString,Int)
+WindowReq(QueryPointer,CLong->CLong->CLong->CLong->CLong->CLong->CLong,Bool)
+WindowReq(TranslateCoordinates,Window->Int->Int->CInt32->CInt32->CLong,Bool)
+PWindowCmd(ShapeCombineMask,Int->Int->Int->PixmapId->Int,ShapeKind->Int->Int->PixmapId->ShapeOperation)
+PWindowCmd(ShapeCombineRectangles,Int->Int->Int->CXRectangleArray->Int->Int->Int,ShapeKind->Int->Int->CXRectangleArray->Int->ShapeOperation->ClipOrdering)
+PWindowCmd(ShapeCombineShape,Int->Int->Int->PixmapId->Int->Int,ShapeKind->Int->Int->PixmapId->ShapeKind->ShapeOperation)
+
+Cmd(GrabButton,Int->Int->Window->Bool->Unsigned->Int->Int->Window->CursorId)
+Cmd(UngrabButton,Int->Int->Window)
+WindowReqP(GrabPointer,Bool->Unsigned->Int->Int->Window->CursorId->Time,Int,GrabPointerResult)
+Cmd(UngrabPointer,Time)
+Cmd(SetSelectionOwner,Atom->Window->Time)
+Cmd(ConvertSelection,Atom->Atom->Atom->Window->Time)
+
+DrawCmd(DrawPoint,Int->Int)
+DrawCmd(DrawLine,Int->Int->Int->Int)
+DrawPCmd(DrawLines,CXPointArray->Int->Int,CXPointArray->Int->CoordMode)
+DrawPCmd(DrawImageString,Int->Int->CString->Int,Int->Int->String->Int)
+DrawPCmd(DrawString,Int->Int->CString->Int,Int->Int->String->Int)
+DrawPCmd(DrawImageString16,Int->Int->CString16->Int,Int->Int->CString16->Int)
+DrawPCmd(DrawString16,Int->Int->CString16->Int,Int->Int->CString16->Int)
+DrawCmd(DrawRectangle,Int->Int->Int->Int)
+DrawCmd(FillRectangle,Int->Int->Int->Int)
+DrawCmd(DrawArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
+DrawCmd(FillArc,Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
+DrawPCmd(FillPolygon,CXPointArray->Int->Int->Int,CXPointArray->Int->Shape->CoordMode)
+PCmd(CopyArea,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32)
+PCmd(CopyPlane,DrawableId->DrawableId->CGCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word,DrawableId->DrawableId->GCId->Int32->Int32->Unsigned32->Unsigned32->Int32->Int32->Word)
+
+#define GCCmd(f,t) PCmd(f,CGCId->t,GCId->t)
+
+DrawReqP(CreateGC,Bitmask->CXGCValues,CGCId,GCId)
+PCmd(CopyGC,CGCId->Bitmask->CGCId,GCId->Bitmask->GCId)
+GCCmd(ChangeGC,Bitmask->CXGCValues)
+PCmd(FreeGC,CGCId,GCId)
+
+GCCmd(SetForeground,Unsigned)
+GCCmd(SetBackground,Unsigned)
+GCCmd(SetPlaneMask,Bitmask)
+PCmd(SetFunction,CGCId->Int,GCId->GCFunction)
+PCmd(SetState,CGCId->Unsigned->Unsigned->Int->Unsigned,GCId->Unsigned->Unsigned->GCFunction->Unsigned)
+
+PXlib(KeysymToString,XlibKeySym->IO CString,XlibKeySym->IO (Maybe String))
+
+Req(ReadBitmapFile,DrawableId->CString->CInt32->CInt32->CXID->CInt32->CInt32,Int)
+Req(CreateBitmapFromData,DrawableId->CString->Int32->Int32,PixmapId)
+
+--- Regions -------------------------------------------------------------------
+Xlib(CreateRegion,IO Region)
+PCmd(SetRegion,CGCId->Region,GCId->Region)
+Xlib(DestroyRegion,Region->IO ())
+Xlib(UnionRectWithRegion,CXRectangle->Region->Region->IO ())
+IDAR(Region)
+
+--- Double buffer extension ---------------------------------------------------
+Req(dbeQueryExtension,CLong->CLong,Int)
+PWindowReq(dbeAllocateBackBufferName,Int,DbeBackBufferId,SwapAction,DbeBackBufferId)
+Req(dbeSwapBuffers,CXdbeSwapInfoArray->Int,Status)
+
+H_ARRAY(XdbeSwapInfo)
+ENUMAR(SwapAction)
+IDAR(DbeBackBufferId)
+--- Types ---------------------------------------------------------------------
+
+IORC(CDisplay,Display,fmap (Display . a2i))
+instance PrimArg Display CDisplay c where marshall c (Display d) = c (i2a d)
+
+IORC(CGCId,GCId,fmap (GCId . a2i))
+
+instance PrimArg GCId CGCId c where marshall c (GCId d) = c (i2a d)
+
+
+-- Instances for resource identifiers and simple values
+IDAR(Atom)
+IDAR(ColormapId)
+IDAR(CursorId)
+IDAR(DrawableId)
+IDAR(FontId)
+IDAR(Pixel)
+IDAR(PixmapId)
+IDAR(PropertyMode)
+IDAR(VisualID)
+IDAR(Window)
+IDAR0(Word32)
+IDAR0(Word)
+IDAR0(XID)
+ENUMAR(ByteOrder)
+ENUMAR(CoordMode)
+ENUMAR(DisplayClass)
+ENUMAR(FontDirection)
+ENUMAR(GrabPointerResult)
+ENUMAR(GCFunction)
+ENUMAR(GCLineStyle)
+ENUMAR(GCCapStyle)
+ENUMAR(GCJoinStyle)
+ENUMAR(GCSubwindowMode)
+ENUMAR(GCFillStyle)
+ENUMAR(ClipOrdering)
+ENUMAR(Shape)
+ENUMAR(ShapeKind)
+ENUMAR(ShapeOperation)
+
+IDAR0(CXID)
+ISTORE(XID)
+
+instance CVar CXID XID
+
+--- Structured types ----------------------------------------------------------
+H_STRUCTTYPE(XColor)
+H_STRUCTTYPE(XClassHint)
+H_STRUCTTYPE(XGCValues)
+H_STRUCTTYPE(XSetWindowAttributes)
+H_STRUCTTYPE(XSizeHints)
+H_STRUCTTYPE(XWMHints)
+H_STRUCTTYPE(XWindowChanges)
+
+H_ARRAY(Atom)
+ISTORE(Atom)
+instance CVar CAtom Atom
+instance PrimArg [Atom] CAtom (Int->IO a) where
+  marshall pf as n =
+    do aa <- newArray n
+       zipWithM_ (pokeElemOff (addrOf aa)) [0..(n-1)] [a|Atom a<-as]
+       r<-pf aa n
+       freePtr aa
+       return r
+
+H_STRUCTTYPE(XEvent)
+type CXAnyEvent = CXEvent
+type CXKeyEvent = CXEvent
+type CXButtonEvent = CXEvent
+type CXMotionEvent = CXEvent
+type CXCrossingEvent = CXEvent
+type CXFocusChangeEvent = CXEvent
+type CXExposeEvent = CXEvent
+type CXGraphicsExposeEvent = CXEvent
+type CXNoExposeEvent = CXEvent
+type CXVisibilityEvent = CXEvent
+type CXCreateWindowEvent = CXEvent
+type CXDestroyWindowEvent = CXEvent
+type CXUnmapEvent = CXEvent
+type CXMapEvent = CXEvent
+type CXMapRequestEvent = CXEvent
+type CXReparentEvent = CXEvent
+type CXConfigureEvent = CXEvent
+type CXGravityEvent = CXEvent
+type CXResizeRequestEvent = CXEvent
+type CXConfigureRequestEvent = CXEvent
+type CXCirculateEvent = CXEvent
+type CXClientMessageEvent = CXEvent
+type CXSelectionClearEvent = CXEvent
+type CXSelectionRequestEvent = CXEvent
+type CXSelectionEvent = CXEvent
+
+H_ARRAY(XPoint)
+H_ARRAY(XRectangle)
+C_STRUCTTYPE(XFontStruct);IDAR0(CXFontStruct)
+
+--C_STRUCTTYPE(XCharStruct);IDAR0(CXCharStruct)
+NEWTYPE(HT(XCharStruct));IPTR(XCharStruct);ISTORE(HT(XCharStruct));
+INSTCCALL(HT(XCharStruct));IDAR0(CXCharStruct)
+
+C_STRUCTTYPE(Visual);IDAR0(CVisual)
+C_STRUCTTYPE(XImage);IDAR0(CXImage)
+INSTCCALL(CString)
+
+NEWTYPE(HT(XFontProp));IPTR(XFontProp);ISTORE(HT(XFontProp));
+INSTCCALL(HT(XFontProp));IDAR0(CXFontProp)
+
+C_STRUCTTYPE(CXFontStruct);IDAR0(CCXFontStruct)
+newCXFontStruct = CCXFontStruct <$> mallocElem nullAddr
+instance CVar CCXFontStruct CXFontStruct
+
+C_STRUCTTYPE(CString);IDAR0(CCString)
+newCString = CCString <$> mallocElem nullAddr
+instance CVar CCString CString
+--- Constants -----------------------------------------------------------------
+anyModifier = 2^(15 :: Int)
+grabModeAsync = 1 :: Int
+--- Auxiliary functions/types -------------------------------------------------
+call f = unmarshall f
+uio f = fmap f
+
+a2i :: Addr -> Int
+a2i a = minusAddr a nullAddr
+
+{-# NOINLINE i2a #-} -- Workaround a GHC bug on 64-bit systems /TH 2016-12-29
+i2a :: Int -> Addr
+i2a = plusAddr nullAddr
+
+newtype DrawableId = DrawableId XID deriving Show
+getdrawable _ (Pixmap (PixmapId i)) = DrawableId i
+getdrawable (WindowId w) MyWindow = DrawableId w
+getdrawable _ (DbeBackBuffer (DbeBackBufferId b)) = DrawableId b
+
+dcmap display cmap =
+    if cmap == defaultColormap
+    then xDefaultScreen display >>= xDefaultColormap display
+    else return cmap
+
+data ByteOrder = LSBFirst | MSBFirst deriving (Eq,Enum)
+
+--withLockedDisplay display cmd = cmd
+{-
+withLockedDisplay display cmd =
+  do xLockDisplay display
+     result <- cmd
+     xUnlockDisplay display
+     return result
+-}
diff --git a/hsrc/ghc-dialogue/asyncinput.h b/hsrc/ghc-dialogue/asyncinput.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/asyncinput.h
@@ -0,0 +1,41 @@
+/*#ifndef ASYNCINPUT_H*/
+/* This file seems to be incldued twice for some strange reason... */
+#define ASYNCINPUT_H
+
+#undef _POSIX_SOURCE
+
+#include <sys/types.h>
+#include <sys/time.h>
+#include <unistd.h>
+
+#include <sys/socket.h>
+#define XLIB_ILLEGAL_ACCESS
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+
+typedef struct timeval timeVal;
+
+typedef struct sockaddr sockAddr;
+
+/* Things from socketlib, doesn't really belong here: */
+int in_connect(char *host,short port,int type);
+int in_bind(short port,	int type) ;
+void fdzero(fd_set *s);
+void fdset(int fd,fd_set *s);
+int fdisset(int fd,fd_set *s);
+void bcopy_fdset(fd_set *,fd_set *);
+int get_errno(void);
+long get_stdin(void);
+int get_fileno(long); /* The true argument type is FILE * */
+
+void xDestoryImage(XImage *ximage);
+int default_bpp(Display *,int depth);
+void setXImage_data(XImage *ximage,char *data);
+
+void disable_timers(void);
+
+/* Quick hack to work around typing problem: */
+/* #define GETSOCKNAME(s,a,len) getsockname(s,(struct sockaddr *)a,len) */
+/* #define ACCEPT(s,a,len) accept(s,(struct sockaddr *)a,len) */
+
+/*#endif*/
diff --git a/hsrc/ghc-dialogue/ccalls.h b/hsrc/ghc-dialogue/ccalls.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/ccalls.h
@@ -0,0 +1,208 @@
+AGET(XClientMessageEvent,Addr,ev,data)
+AGET(XFontStruct,HT(XCharStruct),fs,max_bounds)
+AGET(XFontStruct,HT(XCharStruct),fs,min_bounds)
+CCONST(AF_INET)
+CCONST(AnyButton)
+CCONST(BitmapSuccess)
+CCONST(EAGAIN)
+CCONST(EINTR)
+CCONST(InputHint)
+CCONST(LSBFirst)
+CCONST(None)
+CCONST(SOCK_STREAM)
+CCONST(SelectionNotify)
+CCONST(USPosition)
+CINDEX(char)
+CINDEX(long)
+CINDEX(short)
+CWORD32(CWBackPixel)
+CWORD32(CWBackPixmap)
+CWORD32(CWBackingStore)
+CWORD32(CWBitGravity)
+CWORD32(CWBorderPixel)
+CWORD32(CWBorderPixmap)
+CWORD32(CWBorderWidth)
+CWORD32(CWCursor)
+CWORD32(CWDontPropagate)
+CWORD32(CWEventMask)
+CWORD32(CWHeight)
+CWORD32(CWOverrideRedirect)
+CWORD32(CWSaveUnder)
+CWORD32(CWStackMode)
+CWORD32(CWWidth)
+CWORD32(CWWinGravity)
+CWORD32(CWX)
+CWORD32(CWY)
+CWORD32(GCBackground)
+CWORD32(GCCapStyle)
+CWORD32(GCJoinStyle)
+CWORD32(GCFillStyle)
+CWORD32(GCFont)
+CWORD32(GCForeground)
+CWORD32(GCFunction)
+CWORD32(GCGraphicsExposures)
+CWORD32(GCLineStyle)
+CWORD32(GCLineWidth)
+CWORD32(GCStipple)
+CWORD32(GCSubwindowMode)
+CWORD32(GCTile)
+GET(Visual,Int,cv,bits_per_rgb)
+GET(Visual,Int,cv,blue_mask)
+GET(Visual,Int,cv,class)
+GET(Visual,Int,cv,green_mask)
+GET(Visual,Int,cv,map_entries)
+GET(Visual,Int,cv,red_mask)
+GET(Visual,VisualID,cv,visualid)
+GET(XAnyEvent,Int,ev,type)
+GET(XAnyEvent,WindowId,ev,window)
+GET(XButtonEvent,Int,ev,button)
+GET(XButtonEvent,Int,ev,state)
+GET(XButtonEvent,Int,ev,x)
+GET(XButtonEvent,Int,ev,x_root)
+GET(XButtonEvent,Int,ev,y)
+GET(XButtonEvent,Int,ev,y_root)
+GET(XButtonEvent,Time,ev,time)
+GET(XCharStruct,Int,cs,ascent)
+GET(XCharStruct,Int,cs,descent)
+GET(XCharStruct,Int,cs,lbearing)
+GET(XCharStruct,Int,cs,rbearing)
+GET(XCharStruct,Int,cs,width)
+GET(XFontProp,Atom,fp,name)
+GET(XFontProp,Int,fp,card32)
+GET(XClientMessageEvent,Atom,ev,message_type)
+GET(XClientMessageEvent,Int,ev,format)
+GET(XColor,Int,xcol,blue)
+GET(XColor,Int,xcol,green)
+GET(XColor,Int,xcol,red)
+GET(XColor,Word,xcol,pixel)
+GET(XConfigureEvent,Int,ev,border_width)
+GET(XConfigureEvent,Int,ev,height)
+GET(XConfigureEvent,Int,ev,width)
+GET(XConfigureEvent,Int,ev,x)
+GET(XConfigureEvent,Int,ev,y)
+GET(XCrossingEvent,Int,ev,detail)
+GET(XCrossingEvent,Int,ev,focus)
+GET(XCrossingEvent,Int,ev,mode)
+GET(XCrossingEvent,Int,ev,x)
+GET(XCrossingEvent,Int,ev,x_root)
+GET(XCrossingEvent,Int,ev,y)
+GET(XCrossingEvent,Int,ev,y_root)
+GET(XCrossingEvent,Time,ev,time)
+GET(XExposeEvent,Int,ev,count)
+GET(XExposeEvent,Int,ev,height)
+GET(XExposeEvent,Int,ev,width)
+GET(XExposeEvent,Int,ev,x)
+GET(XExposeEvent,Int,ev,y)
+GET(XFocusChangeEvent,Int,ev,detail)
+GET(XFocusChangeEvent,Int,ev,mode)
+GET(XFontStruct,Char,fs,default_char)
+GET(XFontStruct,HT(XCharStruct),fs,per_char)
+GET(XFontStruct,HT(XFontProp),fs,properties)
+GET(XFontStruct,Int,fs,all_chars_exist)
+GET(XFontStruct,Int,fs,ascent)
+GET(XFontStruct,Int,fs,descent)
+GET(XFontStruct,Int,fs,direction)
+GET(XFontStruct,XID,fs,fid)
+GET(XFontStruct,Int,fs,max_byte1)
+GET(XFontStruct,Int,fs,max_char_or_byte2)
+GET(XFontStruct,Int,fs,min_byte1)
+GET(XFontStruct,Int,fs,min_char_or_byte2)
+GET(XFontStruct,Int,fs,n_properties)
+GET(XGraphicsExposeEvent,Int,ev,count)
+GET(XGraphicsExposeEvent,Int,ev,height)
+GET(XGraphicsExposeEvent,Int,ev,major_code)
+GET(XGraphicsExposeEvent,Int,ev,minor_code)
+GET(XGraphicsExposeEvent,Int,ev,width)
+GET(XGraphicsExposeEvent,Int,ev,x)
+GET(XGraphicsExposeEvent,Int,ev,y)
+GET(XKeyEvent,Int,ev,keycode)
+GET(XKeyEvent,Int,ev,state)
+GET(XKeyEvent,Int,ev,x)
+GET(XKeyEvent,Int,ev,x_root)
+GET(XKeyEvent,Int,ev,y)
+GET(XKeyEvent,Int,ev,y_root)
+GET(XKeyEvent,Time,ev,time)
+GET(XMapEvent,WindowId,ev,window)
+GET(XMotionEvent,Int,ev,state)
+GET(XMotionEvent,Int,ev,x)
+GET(XMotionEvent,Int,ev,x_root)
+GET(XMotionEvent,Int,ev,y)
+GET(XMotionEvent,Int,ev,y_root)
+GET(XMotionEvent,Time,ev,time)
+GET(XResizeRequestEvent,Int,ev,height)
+GET(XResizeRequestEvent,Int,ev,width)
+GET(XSelectionClearEvent,Atom,ev,selection)
+GET(XSelectionEvent,Atom,ev,property)
+GET(XSelectionEvent,Atom,ev,selection)
+GET(XSelectionEvent,Atom,ev,target)
+GET(XSelectionEvent,Time,ev,time)
+GET(XSelectionRequestEvent,Atom,ev,property)
+GET(XSelectionRequestEvent,Atom,ev,selection)
+GET(XSelectionRequestEvent,Atom,ev,target)
+GET(XSelectionRequestEvent,Time,ev,time)
+GET(XSelectionRequestEvent,WindowId,ev,requestor)
+GET(XVisibilityEvent,Int,ev,state)
+GET(timeVal,Int,now,tv_sec)
+GET(timeVal,Int,now,tv_usec)
+GETC(sockAddr,char *,CString,sa,sa_data)
+INDEX(XCharStruct)
+INDEX(XFontProp)
+SET(XAnyEvent,Window,xe,window,w::Window)
+SET(XClassHint,CString,class_hints,res_class,rc)
+SET(XClassHint,CString,class_hints,res_name,rn)
+SET(XColor,Int,color,blue,blue)
+SET(XColor,Int,color,green,green)
+SET(XColor,Int,color,red,red)
+SET(XColor,Word,c,pixel,px)
+SET(XGCValues,Int,gcv,background,toC p)
+SET(XGCValues,Int,gcv,cap_style,fromEnum s)
+SET(XGCValues,Int,gcv,join_style,fromEnum s)
+SET(XGCValues,Int,gcv,fill_style,fromEnum f)
+SET(XGCValues,XID,gcv,font,toXID f)
+SET(XGCValues,Int,gcv,foreground,toC p)
+SET(XGCValues,Int,gcv,function,fromEnum f)
+SET(XGCValues,Int,gcv,graphics_exposures, fromEnum g)
+SET(XGCValues,Int,gcv,line_style,fromEnum s)
+SET(XGCValues,Int,gcv,line_width,w)
+SET(XGCValues,XID,gcv,stipple,toXID p)
+SET(XGCValues,Int,gcv,subwindow_mode,fromEnum m)
+SET(XGCValues,XID,gcv,tile,toXID p)
+SET(XSelectionEvent,Atom,xe,property, props)
+SET(XSelectionEvent,Atom,xe,selection, sel)
+SET(XSelectionEvent,Atom,xe,target, target)
+SET(XSelectionEvent,Int,xe,type,CCONST(SelectionNotify)::Int)
+SET(XSelectionEvent,Time,xe,time,time)
+SET(XSizeHints,Int,h,flags,CCONST(USPosition)::Int)
+SET(XSizeHints,Int,h,x,x)
+SET(XSizeHints,Int,h,y,y)
+SET(XWMHints,Int,h,flags,CCONST(InputHint)::Int)
+SET(XWMHints,Int,h,input,toC i)
+SET(XWindowChanges,Int,s,border_width,w)
+SET(XWindowChanges,Int,s,height,h)
+SET(XWindowChanges,Int,s,stack_mode,toC sm)
+SET(XWindowChanges,Int,s,width,w)
+SET(XWindowChanges,Int,s,x,x)
+SET(XWindowChanges,Int,s,y,y)
+SET(timeVal,Int,timeout,tv_sec,(tleft `div` 1000))
+SET(timeVal,Int,timeout,tv_usec,(tleft `mod` 1000) * 1000)
+SETI(XPoint,Int,xpoints,i,x,x)
+SETI(XPoint,Int,xpoints,i,y,y)
+SETI(XRectangle,Int,rsa,i,height,h)
+SETI(XRectangle,Int,rsa,i,width,w)
+SETI(XRectangle,Int,rsa,i,x,x)
+SETI(XRectangle,Int,rsa,i,y,y)
+SETI(XdbeSwapInfo,Int,si,i,swap_action,fromEnum sa)
+SETI(XdbeSwapInfo,WindowId,si,i,swap_window,wi)
+SETWa(swa,background_pixel,toC p)
+SETWaXID(swa,background_pixmap,toXID p)
+SETWa(swa,backing_store,toC bs)
+SETWa(swa,bit_gravity,toC g)
+SETWa(swa,border_pixel,toC p)
+SETWaXID(swa,border_pixmap,toC p)
+SETWaXID(swa,cursor,toXID c)
+SETWa(swa,do_not_propagate_mask,toC em)
+SETWa(swa,event_mask,toC em)
+SETWa(swa,override_redirect,toC b)
+SETWa(swa,save_under,toC b)
+SETWa(swa,win_gravity,toC g)
+SINDEX(char,imgdata,i::Int,p::Int)
diff --git a/hsrc/ghc-dialogue/cfundefs.h b/hsrc/ghc-dialogue/cfundefs.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/cfundefs.h
@@ -0,0 +1,50 @@
+
+#define SETI(ctype,fhtype,p1,i1,field,v1) \
+  void seti_##ctype##_##field(ctype p[],int i,typeof(p[i].field) v) \
+    BODY({ p[i].field=v; })
+
+#define SINDEX(ctype,p1,i1,v1) \
+  void sindex_##ctype(ctype p[],int i,typeof(p[i]) v) \
+    BODY({ p[i]=v; })
+
+/*(_casm_ ``((ctype *)%0)[%1]=%2;'' (p) (i) (v) :: IO ())*/
+
+#define SET(ctype,fhtype,p1,field,v1) \
+  void set_##ctype##_##field(ctype *p,typeof(p->field) v) \
+    BODY({ p->field=v; })
+
+#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)
+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)
+
+/* (_casm_ ``((ctype *)%0)->field=%1;'' (addrOf (p)) (v) :: IO ())*/
+
+#define GET(ctype,rhtype,p1,field) \
+  typeof(((ctype *)0)->field) get_##ctype##_##field(ctype *p) \
+    BODY({ return p->field; })
+
+#define GETC(ctype,crtype,rhtype,p1,field) \
+  crtype get_##ctype##_##field(ctype *p) \
+    BODY({ return p->field; })
+
+/* (_casm_ `` %r = ((ctype *)%0)->field; '' (addrOf (p))) */
+
+#define AGET(ctype,rhtype,p1,field) \
+  typeof(&(((ctype *)0)->field)) aget_##ctype##_##field(ctype *p) \
+    BODY({ return &(((ctype *)p)->field); })
+
+/* (_casm_ `` %r = &(((ctype *)%0)->field); '' ((p)::HT(ctype))) */
+
+#define INDEX(ctype) \
+  ctype *index_##ctype(ctype *p,int i) \
+    BODY({ return p+i; })
+
+/* (\pP iI -> _casm_ ``%r = (ctype *)%0 + (int)%1;'' ((pP) :: HT(ctype)) iI) */
+
+#define CINDEX(t) \
+  t cindex_##t(t p[],int i) \
+    BODY({ return p[i]; })
+
+/* (\pP iI -> _casm_ ``%r = ((t *)%0)[(int)%1];'' pP iI) */
+
+#define CCONST(c)  int const_##c(void) BODY({ return (c);})
+#define CWORD32(c) int const_##c(void) BODY({ return (c);})
diff --git a/hsrc/ghc-dialogue/cfuns.c b/hsrc/ghc-dialogue/cfuns.c
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/cfuns.c
@@ -0,0 +1,4 @@
+#include <errno.h>
+
+#define BODY(b) b
+#include "cfuns.h"
diff --git a/hsrc/ghc-dialogue/cfuns.h b/hsrc/ghc-dialogue/cfuns.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/cfuns.h
@@ -0,0 +1,11 @@
+#include "asyncinput.h"
+#include <X11/extensions/Xdbe.h>
+
+#ifndef BODY
+#define BODY(b) ;
+#endif
+#include "cfundefs.h"
+#include "ccalls.h"
+
+#define CSIZE(ctype) int fudsizeof_##ctype(void) BODY({ return sizeof(ctype); })
+#include "csizes.h"
diff --git a/hsrc/ghc-dialogue/cimports.h b/hsrc/ghc-dialogue/cimports.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/cimports.h
@@ -0,0 +1,41 @@
+#define FI foreign import ccall unsafe "cfuns.h"
+
+#define SETI(ctype,fhtype,p1,i1,field,v1) \
+  FI seti_/**/ctype/**/_/**/field :: HTA(ctype) -> Int -> (fhtype) -> IO ()
+
+/*  (_casm_ ``((ctype *)%0)[%1].field=%2;'' ((p)::HT(ctype)) (i) (v) :: IO ()) */
+#define SINDEX(ctype,p1,i1,v1) \
+  FI sindex_/**/ctype :: Addr -> Int -> HT(ctype)  -> IO ()
+
+/*(_casm_ ``((ctype *)%0)[%1]=%2;'' (p) (i) (v) :: IO ())*/
+
+#define SET(ctype,fhtype,p1,field,v1) \
+  FI set_/**/ctype/**/_/**/field :: HT(ctype) -> fhtype -> IO ()
+
+/* (_casm_ ``((ctype *)%0)->field=%1;'' (addrOf (p)) (v) :: IO ())*/
+
+#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)
+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)
+
+
+#define GET(ctype,rhtype,p1,field) \
+  FI get_/**/ctype/**/_/**/field :: HT(ctype) -> IO rhtype
+
+#define GETC(ctype,rctype,rhtype,p1,field) GET(ctype,rhtype,p1,field)
+
+/* (_casm_ `` %r = ((ctype *)%0)->field; '' (addrOf (p))) */
+
+#define AGET(ctype,rhtype,p1,field) FI aget_/**/ctype/**/_/**/field :: HT(ctype) -> IO (rhtype)
+
+/* (_casm_ `` %r = &(((ctype *)%0)->field); '' ((p)::HT(ctype))) */
+
+#define INDEX(ctype)  FI index_/**/ctype :: HT(ctype) -> Int -> IO HT(ctype)
+
+/* (\pP iI -> _casm_ ``%r = (ctype *)%0 + (int)%1;'' ((pP) :: HT(ctype)) iI) */
+
+#define CINDEX(t) FI cindex_/**/t :: Addr -> Int -> IO (HT(t))
+
+/* (\pP iI -> _casm_ ``%r = ((t *)%0)[(int)%1];'' pP iI) */
+
+#define CCONST(c) FI const_/**/c :: Int
+#define CWORD32(c) FI const_/**/c :: Word32
diff --git a/hsrc/ghc-dialogue/csizes.h b/hsrc/ghc-dialogue/csizes.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/csizes.h
@@ -0,0 +1,19 @@
+
+CSIZE(Atom)
+CSIZE(XEvent)
+CSIZE(XPoint)
+CSIZE(XColor)
+CSIZE(XGCValues)
+CSIZE(XWMHints)
+CSIZE(XdbeSwapInfo)
+CSIZE(XClassHint)
+CSIZE(XSetWindowAttributes)
+CSIZE(XSizeHints)
+CSIZE(XWindowChanges)
+CSIZE(XRectangle)
+CSIZE(XCharStruct)
+CSIZE(XFontStruct)
+CSIZE(XFontProp)
+CSIZE(timeVal)
+CSIZE(sockAddr)
+CSIZE(fd_set)
diff --git a/hsrc/ghc-dialogue/newstructfuns.h b/hsrc/ghc-dialogue/newstructfuns.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/newstructfuns.h
@@ -0,0 +1,17 @@
+#include "structs.h"
+
+#define SETI(ctype,fhtype,p,i,field,v) (seti_/**/ctype/**/_/**/field (p) (i) (v))
+#define SINDEX(ctype,p,i,v) (sindex_/**/ctype (p) (i) (v))
+#define SET(ctype,fhtype,p,field,v) (set_/**/ctype/**/_/**/field (p) (v))
+#define GET(ctype,rhtype,p,field) (get_/**/ctype/**/_/**/field (p))
+#define GETC(ctype,rctype,rhtype,p,field) GET(ctype,rhtype,p,field)
+#define INDEX(ctype) index_/**/ctype
+#define CINDEX(t) cindex_/**/t
+
+#define SETWa(swa,field,v) SET(XSetWindowAttributes,Int,swa,field,v)
+#define SETWaXID(swa,field,v) SET(XSetWindowAttributes,XID,swa,field,v)
+
+#define AGET(ctype,rhtype,p,field) (aget_/**/ctype/**/_/**/field (p))
+
+#define CCONST(c) const_/**/c
+#define CWORD32(c) CCONST(c)
diff --git a/hsrc/ghc-dialogue/structs.h b/hsrc/ghc-dialogue/structs.h
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc-dialogue/structs.h
@@ -0,0 +1,57 @@
+--- New stuff for GHC 4.08.1, 2000-11-25 /TH
+
+#define IORC(p,t,c) instance PrimResult (IO (p)) (IO (t)) where{unmarshall=(c)}
+#define CA(t,p,c) instance PrimArg (t) (p) r where {marshall f = f .(c)}
+
+#define IDR(t) instance PrimResult (IO (t)) (IO (t)) where {unmarshall=id}
+#define IDA(t) CA(t,t,id)
+#define IDAR(t) IDR(t);IDA(t);INSTCCALL(t)
+#define IDAR0(t) IDR(t);IDA(t)
+
+#define ENUMR(t) IORC(Int,t,fmap toEnum)
+#define ENUMA(t) CA(t,Int,fromEnum)
+#define ENUMAR(t) ENUMR(t);ENUMA(t)
+
+--- Old stuff, modified to fit with the new stuff, 2000-11-25 /TH
+
+#define HT(ctype) C/**/ctype
+#define HTA(ctype) HT(ctype)Array
+
+#define NEWTYPE(t) newtype t = t Addr deriving (Eq,Show)
+#define HASADDR(t) instance HasAddr t where {addrOf (t addr) = addr}
+#if 0
+#define INSTCCALL(t) instance CCallable t;instance CReturnable t
+#else
+#define INSTCCALL(t)
+#endif
+
+#define ISTORE(t) \
+  instance Storable t where { \
+    sizeOf (t a) = sizeOf a; \
+    alignment (t a) = alignment a; \
+    peek p = t <$> peek p; \
+    poke p (t a) = poke p a }
+
+#define SIZEOF(ctype) (fudsizeof_/**/ctype)
+
+#define IPTR(ctype) \
+  new/**/ctype/**/Array n = HT(ctype) `fmap` malloc (n*SIZEOF(ctype)); \
+  new/**/ctype = new/**/ctype/**/Array 1; \
+  HASADDR(HT(ctype)); \
+  instance IsPtr HT(ctype) where { \
+    nullPtr = HT(ctype) nullAddr;\
+    newPtr = new/**/ctype ;\
+    newArray = new/**/ctype/**/Array}
+
+-- freePtr (HT(ctype) addr) = free addr
+
+#define H_STRUCTTYPE(ctype) \
+  NEWTYPE(HT(ctype));IPTR(ctype);IDAR(HT(ctype))
+
+#define H_ARRAY(ctype) H_STRUCTTYPE(ctype); ISTORE(HT(ctype)) ; type HTA(ctype) = HT(ctype)
+
+#define C_STRUCTTYPE(ctype) \
+  NEWTYPE(HT(ctype)); \
+  HASADDR(HT(ctype)); \
+  ISTORE(HT(ctype)); \
+  INSTCCALL(HT(ctype))
diff --git a/hsrc/ghc/DFudIO.hs b/hsrc/ghc/DFudIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/DFudIO.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+module DFudIO(Fudlogue,fudlogue,fudlogue'{-,fudIO,fudIO'-},HasCache(..)) where
+
+import FDefaults
+import FudIO(fudIO1)
+--import FudIO2(fudIO2)
+import Fudget
+--import Xtypes
+--import Cache(allcacheF)
+import NewCache(allcacheF)
+import CmdLineEnv(argFlag)
+
+#include "defaults.h"
+
+data Fudlogue = Pars [Pars]
+data Pars = Cache Bool
+
+parameter_class(Cache,Bool)
+parameter_instance(Cache,Fudlogue)
+
+fudlogue = fudlogue' standard
+fudlogue' :: Customiser Fudlogue -> F a b -> IO ()
+fudlogue' pmod f = fudIO1 (cache pmod f)
+{-
+fudIO = fudIO' standard
+--fudIO' :: Customiser Fudlogue -> F a b -> IO ()
+fudIO' pmod inCh outCh f = fudIO2 inCh outCh (cache pmod f)
+-}
+
+cache pmod = if getCache ps then allcacheF else id
+  where ps = pmod (Pars [Cache usecache])
+
+usecache = argFlag "cache" True
diff --git a/hsrc/ghc/DialogueSpIO.hs b/hsrc/ghc/DialogueSpIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/DialogueSpIO.hs
@@ -0,0 +1,55 @@
+module DialogueSpIO where
+import System.IO(hFlush,stdout)
+import SP
+import DoRequest(initXCall,doRequest,getAsyncInput)
+import DialogueIO(Request(XCommand,GetAsyncInput))
+import Queue
+import CmdLineEnv(argFlag)
+
+--dialogueSpIO :: SP FResponse FRequest -> IO ()
+{-
+--Old, simple implementation:
+dialogueSpIO sp =
+    case sp of
+      PutSP req sp' ->
+        do resp <- doRequest req
+	   dialogueSpIO (startupSP [resp] sp')
+      GetSP xsp ->
+        do resp <- doRequest GetAsyncInput
+	   dialogueSpIO (xsp resp)
+      NullSP -> return ()
+-}
+
+dialogueSpIO = if argFlag "dialogue-to-stdio" False
+               then stdioDialogueSpIO
+               else normalDialogueSpIO
+
+normalDialogueSpIO = dialogueSpIO' initXCall doRequest getAsyncInput
+
+stdioDialogueSpIO = dialogueSpIO' initXCall doRequest getAsyncInput
+  where
+    initXCall = return ()
+    doRequest _ req = do print req
+                         hFlush stdout
+                         readLn
+    getAsyncInput state = doRequest state GetAsyncInput
+
+-- More efficient queueing of responses
+dialogueSpIO' initXCall doRequest getAsyncInput sp = do
+  iostate <- initXCall
+  let doIO sp respq =
+	case sp of
+	  PutSP req sp' ->
+	    do resp <- doRequest iostate req
+	       case req of
+		 -- The response to an XCommand is always Success
+		 -- and is not propagated to the originating fudget.
+	         XCommand {} -> doIO sp' respq
+		 _ -> doIO sp' (enter respq resp)
+	  GetSP xsp ->
+	    case qremove respq of
+	      Just (resp,respq') -> doIO (xsp resp) respq'
+	      Nothing -> do resp <- getAsyncInput iostate
+			    doIO (xsp resp) respq
+	  NullSP -> return ()
+  doIO sp empty
diff --git a/hsrc/ghc/FudIO.hs b/hsrc/ghc/FudIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/FudIO.hs
@@ -0,0 +1,16 @@
+module FudIO(fudIO1) where
+import CmdLineEnv(argFlag)
+--import Fudget
+import SpIO
+import TagEvents
+import FudVersion
+
+--fudIO1 :: F a b -> IO ()
+fudIO1 mainF =
+    if argFlag "version" False
+    then showVersion
+    else spIO mainSP
+  where
+    mainSP = tagEventsSP mainF
+
+    showVersion = putStrLn ("Fudget library " ++ version)
diff --git a/hsrc/ghc/GetModificationTime.hs b/hsrc/ghc/GetModificationTime.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/GetModificationTime.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+module GetModificationTime where
+import HaskellIO
+import DialogueIO
+
+#ifdef VERSION_old_time
+getModificationTime path err cont =
+    hIOerr (GetModificationTime path) err $ \ (ClockTime t) ->
+    cont t
+#else
+getModificationTime path err cont =
+    hIOerr (GetModificationTime path) err $ \ (UTCTime t) ->
+    cont t
+#endif
diff --git a/hsrc/ghc/GetTime.hs b/hsrc/ghc/GetTime.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/GetTime.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+module GetTime where
+import HaskellIO(hIO)
+import DialogueIO
+
+#ifdef VERSION_old_time
+getTime      cont = hIO GetTime      $ \ (ClockTime t)    -> cont t
+getLocalTime cont = hIO GetLocalTime $ \ (CalendarTime t) -> cont t
+#endif
+
+#ifdef VERSION_time
+getCurrentTime cont = hIO GetCurrentTime $ \ (UTCTime t)   -> cont t
+getZonedTime   cont = hIO GetZonedTime   $ \ (ZonedTime t) -> cont t
+#endif
diff --git a/hsrc/ghc/HbcWord.hs b/hsrc/ghc/HbcWord.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/HbcWord.hs
@@ -0,0 +1,15 @@
+module HbcWord(module HbcWord,Word) where
+import Data.Word
+import Data.Bits
+
+--type Word=Word.Word32
+--type Short=Word16
+
+bitAnd x y = x .&. y
+bitOr x y = x .|. y
+bitXor x y = xor x y
+bitRsh x y = shiftR x y
+bitLsh x y = shiftL x y
+
+intToWord = fromIntegral :: Int->Word
+wordToInt = fromIntegral :: Word->Int
diff --git a/hsrc/ghc/List2.hs b/hsrc/ghc/List2.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/List2.hs
@@ -0,0 +1,3 @@
+module List2(sort) where
+-- List(sort) seem to be missing in ghc 2.01
+import Data.List(sort)
diff --git a/hsrc/ghc/LowLevel.hs b/hsrc/ghc/LowLevel.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/LowLevel.hs
@@ -0,0 +1,12 @@
+module LowLevel (-- * Low level
+  module Cont,module Display,module SpIO,module TagEvents,module WindowF,module Xrequest,module Xcommand,module Srequest,module DFudIO, module FudgetIO) where
+import Cont
+import Display
+import SpIO
+import TagEvents
+import WindowF
+import Xrequest
+import Xcommand
+import Srequest
+import DFudIO
+import FudgetIO
diff --git a/hsrc/ghc/PackedString.hs b/hsrc/ghc/PackedString.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/PackedString.hs
@@ -0,0 +1,22 @@
+-- | Fake PackedString type
+module PackedString{-(module PS)-} where
+--import Data.PackedString as PS
+
+newtype PackedString = PS String deriving (Eq,Ord)
+
+instance Show PackedString where
+  showsPrec n (PS s) r = s++r
+
+instance Read PackedString where
+  readsPrec n s0 = [(PS s,r)|(s,r)<-readsPrec n s0]
+
+packString = PS
+unpackPS (PS s) = s
+
+nullPS (PS s) = null s
+lengthPS (PS s) = length s
+
+appendPS (PS s1) (PS s2) = PS (s1++s2)
+mapPS f (PS s) = PS (map f s)
+nilPS = PS ""
+reversePS (PS s) = PS (reverse s)
diff --git a/hsrc/ghc/ShowFun.hs b/hsrc/ghc/ShowFun.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/ShowFun.hs
@@ -0,0 +1,9 @@
+module ShowFun where
+import Text.Show.Functions()
+
+{-
+In Haskell 98, the function type is no longer an instance of the Show class.
+This means that you can't derive Show for data types containing functions...
+-}
+
+instance Read (a->b)
diff --git a/hsrc/ghc/SpIO.hs b/hsrc/ghc/SpIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/SpIO.hs
@@ -0,0 +1,50 @@
+module SpIO(spIO) where
+--import Command
+--import Event
+import Loopthrough
+import Path(Path(..))
+import Cont(getRightSP)
+import ShowFailure
+--import Sockets
+import Spops
+import SP(SP)
+import Tables2
+--import Xtypes
+import DialogueSpIO
+import DialogueIO hiding (IOError)
+--import Table(Table) -- nhc bug workaround
+
+spIO :: (SP (Path, Response) (Path, Request)) -> IO ()
+spIO mainSP = dialogueSpIO (loopThroughRightSP tagRequestsSP mainSP)
+
+tagRequestsSP = tagRequests dtable0
+tagRequests dtable =
+  getSP $ \msg ->
+  case msg of
+    Left (path', cmd) ->
+      case cmd of
+	Select ds -> let dtable' = updateDe path' ds dtable
+		     in doReqSP (Select (listDe dtable')) $ \ resp ->
+			checkErr resp (tagRequests dtable')
+	XCommand _ -> putReqSP cmd $  -- \ resp ->
+		      -- The response to an XCommand is always Success
+		      -- and is not propagated to the originating fudget.
+		      tagRequests dtable
+	_ -> doReqSP cmd $ \ resp ->
+	     putSP (Left (path', resp)) $
+	     tagRequests dtable
+    Right ai@(AsyncInput (d, i)) ->
+      putSP (Left (lookupDe dtable d, ai)) $
+      tagRequests dtable
+    _ -> error ("tagRequests: " ++ show msg ++ "\n")
+
+checkErr resp cont =
+    case resp of
+      Success -> cont
+      Failure ioerr -> error ("IOerror: " ++ showFailure ioerr)
+
+doReqSP req = putReqSP req . getRespSP
+  where
+    getRespSP = getRightSP
+
+putReqSP = putSP . Right
diff --git a/hsrc/ghc/UnsafePerformIO.hs b/hsrc/ghc/UnsafePerformIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/ghc/UnsafePerformIO.hs
@@ -0,0 +1,3 @@
+module UnsafePerformIO(unsafePerformIO) where
+import System.IO.Unsafe(unsafePerformIO)
+
diff --git a/hsrc/hbc_library/FudUTF8.hs b/hsrc/hbc_library/FudUTF8.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/hbc_library/FudUTF8.hs
@@ -0,0 +1,34 @@
+-- | From the Char module supplied with HBC.
+module FudUTF8 where
+
+
+decodeUTF8 :: String -> String
+decodeUTF8 "" = ""
+decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs
+decodeUTF8 (c:c':cs) | '\xc0' <= c  && c  <= '\xdf' && 
+		      '\x80' <= c' && c' <= '\xbf' =
+	toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs
+decodeUTF8 (c:c':c'':cs) | '\xe0' <= c   && c   <= '\xef' && 
+		          '\x80' <= c'  && c'  <= '\xbf' &&
+		          '\x80' <= c'' && c'' <= '\xbf' =
+	toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs
+decodeUTF8 _ = error "UniChar.decodeUTF8: bad data"
+
+-- | Take a Unicode string and encode it as a string
+-- with the UTF8 method.
+encodeUTF8 :: String -> String
+encodeUTF8 "" = ""
+encodeUTF8 (c:cs) =
+	if c > '\x0000' && c < '\x0080' then
+	    c : encodeUTF8 cs
+	else if c < toEnum 0x0800 then
+	    let i = fromEnum c
+	    in  toEnum (0xc0 + i `div` 0x40) : 
+	        toEnum (0x80 + i `mod` 0x40) : 
+		encodeUTF8 cs
+	else
+	    let i = fromEnum c
+	    in  toEnum (0xe0 + i `div` 0x1000) : 
+	        toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : 
+		toEnum (0x80 + i `mod` 0x40) : 
+		encodeUTF8 cs
diff --git a/hsrc/infix/CompOps.hs b/hsrc/infix/CompOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/infix/CompOps.hs
@@ -0,0 +1,48 @@
+module CompOps where
+import CompF(compF)
+import ParF(parF)
+import CompFfun
+import Fudget
+import SerCompF(serCompF)
+import CompSP(serCompSP,compEitherSP)
+import ParSP(parSP)
+
+-- Change priority??
+infixl 5 >+<
+infixl 5 >*<
+infixr 4 >==<
+infixr 8 -==-, -+-, -*-
+infixr 7 >^^=<
+infixr 5 >..=<
+infixl 6 >=^^<
+infixl 6 >=..<
+infixr 7 >^=<
+infixr 6 >.=<
+infixl 6 >=^<
+infixl 6 >=.<
+
+-- Infix operators for common stream processor combinators.
+
+sp1 -==- sp2 = serCompSP sp1 sp2
+sp1 -+- sp2 = compEitherSP sp1 sp2
+sp1 -*- sp2 = parSP sp1 sp2
+
+-- Infix operators for common fudget combinators.
+
+w1 >+< w2 = compF w1 w2
+w1 >*< w2 = parF w1 w2
+w1 >==< w2 = serCompF w1 w2
+
+(>^^=<) :: (SP a b) -> (F e a) -> F e b
+f >^^=< w = postProcessHigh f w
+(>=^^<) :: (F c d) -> (SP e c) -> F e d
+w >=^^< f = preProcessHigh w f
+(>^=<) :: (a -> b) -> (F e a) -> F e b
+f >^=< w = postMapHigh f w
+(>=^<) :: (F c d) -> (e -> c) -> F e d
+w >=^< f = preMapHigh w f
+
+f >..=< w = postProcessLow f w
+w >=..< f = preProcessLow w f
+f >.=< w = postMapLow f w
+w >=.< f = preMapLow w f
diff --git a/hsrc/infix/InfixOps.hs b/hsrc/infix/InfixOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/infix/InfixOps.hs
@@ -0,0 +1,8 @@
+module InfixOps (-- * InfixOps
+  module CompOps,module LayoutOps,module OldLayoutOps) where
+import CompOps
+import LayoutOps
+import OldLayoutOps
+
+--import Fudget
+--import LayoutDir(Orientation)
diff --git a/hsrc/infix/LayoutOps.hs b/hsrc/infix/LayoutOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/infix/LayoutOps.hs
@@ -0,0 +1,11 @@
+module LayoutOps((>#==<), (>#+<)) where
+--import Fudget
+--import LayoutDir(Orientation)
+import LayoutF(compLF,serCompLF)
+
+infixl >#+<, >#==<
+
+-- Infix operators for common layout combinators.
+
+f1o >#+<  f2 = compLF f1o f2
+f1o >#==< f2 = serCompLF f1o f2
diff --git a/hsrc/infix/OldLayoutOps.hs b/hsrc/infix/OldLayoutOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/infix/OldLayoutOps.hs
@@ -0,0 +1,27 @@
+module OldLayoutOps((>==#<), (>+#<)) where
+--import Fudget
+import LayoutDir(Orientation(..))
+import Placers(horizontalP',verticalP')
+import Placer(placerF)
+import AlignP(revP)
+--import LayoutRequest
+--import Geometry
+import CompF(compF)
+import SerCompF(serCompF)
+
+infixl >+#<, >==#<
+
+-- Old version of infix operators for common layout combinators.
+-- Provided for backwards compatibility only.
+
+f1 >+#<  of2 = cLF compF f1 of2
+f1 >==#< of2 = cLF serCompF f1 of2
+
+cLF cF f1 (dist,ori,f2) =
+    let placer =
+            case ori of
+              Above -> verticalP'
+              Below -> revP . verticalP'
+              LeftOf -> horizontalP'
+              RightOf -> revP . horizontalP'
+    in placerF (placer dist) (cF f1 f2)
diff --git a/hsrc/internals/CompiledGraphics.hs b/hsrc/internals/CompiledGraphics.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/CompiledGraphics.hs
@@ -0,0 +1,145 @@
+module CompiledGraphics where
+import Geometry(Rect(..))
+import Utils(number)
+import DrawTypes(DrawCommand)
+import ResourceIds(GCId,rootGC)
+import Rects(overlaps,boundingRect)
+import Maptrace(ctrace)
+
+{-
+--Version 1:
+data CompiledGraphics = CGraphics Rect GCtx [DrawCommand] [CompiledGraphics]
+-}
+
+{-
+--Version 2:
+data CompiledGraphics = CGraphics Rect [XCommand] [CompiledGraphics]
+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand
+-}
+
+{-
+--Version 3:
+data CompiledGraphics = CGraphics Rect Cursor [XCommand] [CompiledGraphics]
+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand
+-}
+
+{-
+--Version 4:
+data CompiledGraphics
+  = CGraphics Rect Cursor [XCommand] [CompiledGraphics]
+       -- The only XCommand used is Draw MyWindow some_GC some_DrawCommand
+  | CGMark CompiledGraphics -- path preserving dummy nodes
+-}
+
+--Version 5:
+data CompiledGraphics
+  = CGraphics Rect Cursor [(GCId,[DrawCommand])] [CompiledGraphics]
+  | CGMark CompiledGraphics -- path preserving dummy nodes
+  deriving (Show)
+
+type Cursor = Bool
+
+cgLeaf r rcmds =
+    --ctrace "gctrace" cmds $
+    cg
+  where
+    cg = CGraphics r False  cmds []
+    --cmds = (map (Draw MyWindow gc) (f r))
+    cmds = rcmds r
+
+cgMark = CGMark
+
+cgCompose r cgs = CGraphics r False cmds cgs
+  where
+    cmds = if anyOverlap cgs
+	   then ctrace "cgoverlap" (map cgrect cgs) $
+		[(rootGC,[])] --trick coding to force all subtrees to be redrawn
+	   else []
+
+    -- This is O(n^2) in general, but the bounding rect makes it O(n) for
+    -- linear placers. It may also help somewhat for tables...
+    -- Sorting the rectangles can cut down the complexity too...
+    -- Better to let the placers tell if they produce overlapping parts...
+    anyOverlap [] = False
+    anyOverlap (cg:cgs) = anyOverlaps' [r] r cgs
+      where r = cgrect cg
+
+    anyOverlaps' rs bounding [] = False
+    anyOverlaps' rs bounding (cg:cgs) =
+        r `overlaps` bounding && any (overlaps r) rs ||
+	anyOverlaps' (r:rs) (boundingRect bounding r) cgs
+      where r = cgrect cg
+
+cgrect (CGMark cg) = cgrect cg
+cgrect (CGraphics r _ _ _) = r
+cgsize = rectsize.cgrect
+
+addcursor (CGMark cg) = CGMark (addcursor cg) -- hmm!!
+addcursor (CGraphics r _ cmds cgs) = CGraphics r True cmds cgs
+removecursor (CGMark cg) = CGMark (removecursor cg) -- hmm!!
+removecursor (CGraphics r _ cmds cgs) = CGraphics r False cmds cgs
+hascursor (CGMark cg) = hascursor cg -- hmm!!
+hascursor (CGraphics _ cur _ _) = cur
+
+cgpart cg [] = cg
+cgpart (CGMark cg) (0:ps) = cgpart cg ps
+cgpart (CGraphics _ _ _ parts) (p:ps) =
+  if p<1||p>length parts then error "bad path in CompiledGraphics.cgpart " else
+  cgpart (parts !! ((p::Int)-1)) ps
+
+cgreplace cg path new = cgupdate cg path (const new)
+
+{-
+cgupdate cg ps f =
+  (if any (<1) ps
+  then ctrace "cgupdate" ps
+  else id) $ cgupdate' cg ps f
+-}
+
+cgupdate cg                            []     f = f cg
+cgupdate (CGMark cg)                   (0:ps) f = CGMark (cgupdate cg ps f)
+cgupdate (CGMark cg)                   ps     f =
+   ctrace "badpath" ("(CGMark _) "++show ps) $
+   CGMark (cgupdate cg ps f)
+cgupdate cg                            (0:ps) f =
+   ctrace "badpath" (cg,0:ps) $
+   CGMark (cgupdate cg ps f)
+cgupdate (CGraphics r cur dcmds parts) (p:ps) f =
+    CGraphics r cur dcmds (pre++cgupdate cg' ps f:post)
+  where pre = take (p-1) parts
+        cg':post = drop ((p-1)::Int) parts
+
+cgcursors :: CompiledGraphics -> [[Int]]
+cgcursors (CGMark cg) = map (0:) (cgcursors cg)
+cgcursors (CGraphics _ cur _ parts) =
+    if cur
+    then []:partcursors
+    else partcursors
+  where
+    partcursors =
+      concatMap (\(n,ps) -> map (n:) (cgcursors ps)) (number 1 parts)
+
+cgGroup pos len (CGMark cg) = CGMark (cgGroup pos len cg) -- hmm!!
+cgGroup pos len (CGraphics r cur dcmds parts) =
+    CGraphics r cur dcmds (ds1++cgCompose r2 ds2:ds3)
+  where
+    (ds1,ds2a) = splitAt (pos-1) parts
+    (ds2,ds3) = splitAt len ds2a
+    r2 = foldr (boundingRect.cgrect) (Rect 0 0) ds2
+
+cgUngroup pos (CGMark cg) = CGMark (cgUngroup pos cg) -- hmm!!
+cgUngroup pos cg@(CGraphics r cur dcmds parts) =
+    case splitAt (pos-1) parts of
+      (ds1,d2:ds3) ->
+        case unmark 0 d2 of
+          (m,CGraphics r2 cur2 dcmds2 ds2) ->
+            CGraphics r cur (dcmds++dcmds2) (ds1++map (mark m) ds2++ds3)
+          _ -> cg -- hmm!!
+
+      _ -> cg -- hmm!!
+  where
+    unmark n (CGMark cg) = unmark (n+1) cg
+    unmark n cg = (n,cg)
+
+    mark 0 cg = cg
+    mark n cg = mark (n-1) (CGMark cg)
diff --git a/hsrc/internals/DLValue.hs b/hsrc/internals/DLValue.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/DLValue.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+module DLValue where
+
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+data DLValue = DLValue (forall a. a)
+#elif defined(__NHC__) || defined(__PFE__)
+-- not supported
+data DLValue = DLValue
+#else
+data DLValue = DLValue a 
+#endif
+
+instance Show DLValue where
+   showsPrec i d = ("DLValue"++)
+
+instance Read DLValue
diff --git a/hsrc/internals/DrawCompiledGraphics.hs b/hsrc/internals/DrawCompiledGraphics.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/DrawCompiledGraphics.hs
@@ -0,0 +1,24 @@
+module DrawCompiledGraphics(drawK,drawK',drawChangesK,drawChangesK') where
+import qualified DrawCompiledGraphics1 as D1
+--import qualified DrawCompiledGraphics2 as D2
+--import qualified DrawCompiledGraphics3 as D3
+import DrawTypes(Drawable(MyWindow))
+import CmdLineEnv(argReadKey)
+
+drawK x = D1.drawK' MyWindow x
+drawChangesK x = D1.drawChangesK' Nothing x
+
+drawK' x = D1.drawK' x
+drawChangesK' x = D1.drawChangesK' x
+--drawK' = drawChoice D1.drawK' D2.drawK' D3.drawK'
+--drawChangesK' = drawChoice D1.drawChangesK' D2.drawChangesK' D3.drawChangesK'
+
+
+drawChoice =
+  case choice of
+    1 -> \ d1 d2 d3 -> d1
+--  2 -> \ d1 d2 d3 -> d2
+--  3 -> \ d1 d2 d3 -> d3
+    _ -> error "unkown version of DrawCompiledGraphics"
+  where
+    choice = argReadKey "draw" (1::Int)
diff --git a/hsrc/internals/DrawCompiledGraphics1.hs b/hsrc/internals/DrawCompiledGraphics1.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/DrawCompiledGraphics1.hs
@@ -0,0 +1,94 @@
+module DrawCompiledGraphics1(drawK',drawChangesK',GCId) where
+--import Fudget
+import Xtypes
+import XDraw(DrawCommand(FillRectangle),clearArea,draw,drawMany,Drawable(..))
+import Geometry(growrect,(=.>),Rect(rectsize))
+--import Message
+--import NullF(putsK,putK)
+import Utils(number)
+--import EitherUtils(mapfilter)
+import Data.Maybe(mapMaybe)
+import CompiledGraphics
+--import Rects
+--import Maptrace(ctrace) -- debug
+--import Io(echoK) -- debug
+import FudgetIO(putLow)
+
+--tr x = seq x $ ctrace "drawtrace" x x
+--trLow = Low . tr
+--trLow = tr . Low
+--maptrLow = map trLow
+--debugK = echoK
+
+--drawK = drawK' MyWindow
+drawK' d (higc,hiR) clip cg =
+    case draw cg [] of
+      [] -> id
+      cmds -> putLow $ drawMany d cmds
+  where
+    draw (CGMark cg) = draw cg
+    draw (CGraphics r cur cmds gs) =
+      (if cur
+       then ((higc,[FillRectangle cr | hr<-hiR r,cr<-clip hr]):)
+       else id).
+      (cmds++) .
+      draws gs
+    draws [] = id
+    draws (g:gs) = draw g . draws gs
+
+drawChangesK' d beQuick higc  (CGMark cg) (CGMark ocg) changes =
+    --debugK (show [ ps | ps<-changes, take 1 ps/=[0]]) .
+    drawChangesK' d beQuick higc cg ocg (mapMaybe drop0 changes)
+  where drop0 [] = Just []
+        drop0 (0:ps) = Just ps
+	drop0 _ = Nothing
+
+drawChangesK' d beQuick higc  cg@(CGraphics r  _ cmds cgs )
+                          ocg@(CGraphics or _ ocmds ocgs) changes =
+    --debugK (unwords ["Changes:",show changes,"or",show or,"nr",show r]) .
+    if r/=or || [] `elem` changes
+       -- Hack for overlapping parts:
+       || not (null changes || null cmds && null ocmds)
+    then --debugK "Drawing" .
+         -- !! test if scrolling is enough
+	 eraseOldK d r or .
+         reDrawK' d beQuick higc cg
+    else if null changes
+         then --debugK "Pruning" .
+	      id
+	 else --debugK "Descending" .
+	      let changes' i= [ p | i':p <- changes, i'==i]
+	      in foldr (.) id [drawChangesK' d beQuick higc cg ocg (changes' i) |
+				(i,(cg,ocg))<-number 1 (zip cgs ocgs)]
+drawChangesK' d beQuick higc  cg ogc _ =
+    --debugK "drawNewK" .
+    drawNewK cg
+  where
+    drawNewK (CGMark cg) = drawNewK cg
+    drawNewK cg@(CGraphics r _ _ _) =
+      eraseOldK d r (cgrect ogc) .
+      reDrawK' d beQuick higc cg
+
+eraseOldK Nothing newrect oldrect =
+  -- It's enough to clear the part of oldrect that is outside newrect.
+  ifK (newrect/=oldrect)
+      (putLow $ clearArea (growrect oldrect 1) False)
+eraseOldK (Just (d,cleargc)) newrect oldrect =
+  ifK (newrect/=oldrect)
+      (putLow $ draw d cleargc (FillRectangle (growrect oldrect 1)))
+
+reDrawK' d beQuick higc (CGMark cg) = reDrawK' d beQuick higc cg
+reDrawK' Nothing beQuick higc cg@(CGraphics r _ _ _) =
+  -- When drawing directly in a window:
+  if (not beQuick || rectsize r =.> 400) -- heuristic
+  then -- for big areas: wait for exposure event and draw only the
+       -- visible part
+       putLow (clearArea r True)
+  else -- for small areas: draw everything immediately (reduced flicker)
+       putLow (clearArea r False) . drawK' MyWindow higc (:[]) cg
+reDrawK' (Just (d,cleargc)) beQuick higc cg@(CGraphics r _ _ _) =
+       -- For drawing in a back buffer or a pixmap (assumes d/=MyWindow):
+       putLow (draw d cleargc (FillRectangle r)) .
+       drawK' d higc (:[]) cg
+
+ifK b k = if b then k else id
diff --git a/hsrc/internals/Editfield.hs b/hsrc/internals/Editfield.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Editfield.hs
@@ -0,0 +1,84 @@
+module Editfield(EditField, moveField, replaceField, setFieldDir, getField,getField',
+                 deselectField, getSelection, getLastLineNo, getAft, getBef, getLnoEdge,
+                 createField, dirint, splitnl, nlines) where
+import HbcUtils(breakAt)
+import Edtypes
+
+--export EditField,newline,nlines,splitnl,
+data EditField = F EDirection String String String Int Int 
+                 deriving (Eq, Ord)
+
+--               bef     sel   aft     ^  lastlineno
+--                            lno for selection edge
+
+nlines s = length (filter (== newline) s)
+
+splitnl = breakAt newline
+
+dirint ERight = 1
+dirint ELeft = -1
+
+befaft dir bef sel aft =
+    if dir == ELeft then (bef, sel ++ aft) else (sel ++ bef, aft)
+
+createField s = F ERight [] [] s 0 (nlines s)
+getLnoEdge (F dir bef sel aft elno lno) =
+    (elno, befaft dir bef sel aft)
+getBef (F dir bef sel aft elno lno) = bef
+getAft (F dir bef sel aft elno lno) = aft
+getLastLineNo (F dir bef sel aft elno lno) = lno
+getSelection (F dir bef sel aft elno lno) =
+    if dir == ELeft then sel else reverse sel
+
+deselectField (F dir bef sel aft elno lno) =
+    let (bef', aft') = befaft dir bef sel aft
+    in  F dir bef' [] aft' elno lno
+
+getField f = reverse (getBef f) ++ getSelection f ++ getAft f
+getField' f = (reverse (getBef f),getSelection f,getAft f)
+
+setFieldDir ndir field@(F dir bef sel aft elno lno) =
+    if ndir == dir then
+        field
+    else
+        let elno' = elno + dirint ndir * nlines sel
+        in  F ndir bef (reverse sel) aft elno' lno
+
+replaceField (F dir bef sel aft elno lno) s =
+    let linessel = nlines sel
+        liness = nlines s
+        elno' = elno + liness - (if dir == ERight then linessel else 0)
+        lno' = lno + (liness - linessel)
+    in  F ERight (reverse s ++ bef) [] aft elno' lno'
+
+moveField :: IsSelect -> EditField -> EditStopFn -> (EditField,String)
+moveField issel (F dir bef sel aft elno lno) sf =
+    let mo dir' bef' sel' aft' elno' acc sf =
+            let stop = (F dir' bef' sel' aft' elno' lno, acc)
+                (b, a) = befaft dir' bef' sel' aft'
+            in case sf b a of 
+		 EdStop -> stop
+		 EdGo wdir sf' -> 
+		    let next c dir'' bef'' sel'' aft'' =
+			    let elno'' =
+				    if c == newline then
+					dirint wdir + elno'
+				    else
+					elno'
+			    in  mo dir'' bef'' sel'' aft'' elno'' (c:acc) sf'
+		    in  if wdir == dir' || null sel' then
+			    case wdir of
+			      ELeft -> case bef' of
+					 [] -> stop
+					 c:bef'' -> next c wdir bef'' (c:sel') aft'
+			      ERight -> case aft' of
+					  [] -> stop
+					  c:aft'' -> next c wdir bef' (c:sel') aft''
+			else
+			    let c:sel'' = sel'
+			    in  case dir' of
+				  ELeft -> next c dir' (c:bef') sel'' aft'
+				  ERight -> next c dir' bef' sel'' (c:aft')
+        (field, acc) = mo dir bef sel aft elno [] sf
+    in  if issel then (field, acc) else (deselectField field, [])
+
diff --git a/hsrc/internals/IntMemo.hs b/hsrc/internals/IntMemo.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/IntMemo.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE CPP #-}
+module IntMemo(memoInt) where
+import Prelude hiding (lookup)
+import CmdLineEnv(argFlag)
+
+#ifndef __NHC__
+#define STRICTARG(x) (x){-#STRICT#-}
+#else
+#define STRICTARG(x) (x)
+#endif
+
+data IntMemo a
+  = Tip
+  | Node a (IntMemo a) (IntMemo a)
+
+lookup :: Int -> IntMemo a -> Maybe a
+lookup n m =
+  case m of
+    Tip -> Nothing
+    Node x l r ->
+      case n of
+	0 -> Just x
+        _ -> lookup (n `div` 2) (STRICTARG(if n `mod` 2==0 then l else r))
+
+memoInt :: (Int->a)->(Int->a)
+memoInt f = if memoOn then g else f
+  where
+    g n = if n<0
+          then case lookup (-n) negtable of Just x -> x
+	  else case lookup n table of Just x -> x
+    table = tabulate 0 1
+    negtable = tabulate 0 (-1)
+    tabulate n b = Node (f n) (tabulate n (STRICTARG(2*b)))
+			      (tabulate (STRICTARG(n+b)) (STRICTARG(2*b)))
+
+memoOn = argFlag "memoint" True
diff --git a/hsrc/internals/IsRequest.hs b/hsrc/internals/IsRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/IsRequest.hs
@@ -0,0 +1,18 @@
+module IsRequest where
+
+import FRequest
+import DialogueIO hiding (IOError)
+
+isRequest c =
+  case c of
+    DReq (Select _) -> False
+    DReq _ -> True
+    XReq _ -> True
+    SReq _ -> True
+    _ -> False
+
+isResponse e =
+  case e of
+    XEvt _ -> False
+    LEvt _ -> False
+    _ -> True
diff --git a/hsrc/internals/MGOps.hs b/hsrc/internals/MGOps.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/MGOps.hs
@@ -0,0 +1,101 @@
+module MGOps where
+import MeasuredGraphics(MeasuredGraphics(..))
+import Maptrace(ctrace)
+import Utils(anth)
+
+{-
+mgPart drawing path =
+  case path of
+    [] -> drawing
+    p:ps -> part drawing
+      where
+        part drawing =
+	  case drawing of
+	    LeafM _ _ _     -> error "bad path in mgPart"
+	    SpacedM   _  d  -> part d
+	    PlacedM   _  d  -> part d
+	    ComposedM    ds -> mgPart (ds !! ((p::Int)-1)) ps
+-}
+
+{-    
+replaceMGPart drawing path new =
+  (if any (<1) path
+  then ctrace "replaceMGPart" path
+  else id) $ replaceMGPart' drawing path new
+-}
+
+replaceMGPart drawing path new = updateMGPart drawing path (const new)
+
+-- Replacing a part without changing the structure
+updateMGPart drawing path f =
+  case path of
+    [] -> f drawing
+    p:ps  -> repl drawing
+      where
+        err = error ("bad path in replaceMGPart: "++show path)
+	repl0 d = if p==0
+	          then updateMGPart d ps f
+		  else err
+        repl drawing =
+	  case drawing of
+	    LeafM _ _            -> err
+	    MarkM     gctx    d  -> MarkM gctx (repl0 d)
+	    SpacedM   spacer  d  -> SpacedM spacer (repl0 d)
+	    PlacedM   placer  d  -> PlacedM placer (repl0 d)
+	    ComposedM         ds -> ComposedM ds'
+              where ds' = anth p (\d->updateMGPart d ps f) ds
+
+-- Changing the structure but not the appearance
+groupMGParts pos len drawing =
+  case drawing of
+    ComposedM ds -> ComposedM (ds1++ComposedM ds2:ds3)
+      where
+        (ds1,ds2a) = splitAt (pos-1) ds
+        (ds2,ds3) = splitAt len ds2a
+    _ -> drawing
+
+-- Changing the structure but not the appearance
+ungroupMGParts pos drawing =
+  case drawing of
+    ComposedM ds ->
+        case splitAt (pos-1) ds of
+          (ds1,ComposedM ds2:ds3) -> ComposedM (ds1++ds2++ds3)
+          _ -> drawing
+    _ -> drawing
+
+parentGctx gctx mg path =
+  case path of
+    [] -> gctx
+    0:ps ->
+      case mg of
+        MarkM gctx' mg' -> parentGctx gctx' mg' ps
+	SpacedM _   mg' -> parentGctx gctx mg' ps
+	PlacedM _   mg' -> parentGctx gctx mg' ps
+	_ -> ctrace "badpath" path gctx -- This is actually an error
+    p:ps ->
+      case mg of
+	ComposedM   mgs ->
+	  --{-
+	  if p>length mgs
+	  then ctrace "badpath" path gctx -- This is actually an error
+	  else --}
+	  parentGctx gctx (mgs!!(p-1)) ps
+	_ -> ctrace "badpath" path gctx -- This is actually an error
+{-
+seqMG mg k =
+  case mg of
+    LeafM _ _ -> k
+    SpacedM _ mg -> seqMG mg k
+    PlacedM _ mg -> seqMG mg k
+    MarkM _ mg -> seqMG mg k
+    ComposedM mgs -> foldr seqMG k mgs
+
+
+sizeMG mg =
+  case mg of
+    LeafM _ _ -> 1::Int
+    SpacedM _ mg -> 1+sizeMG mg
+    PlacedM _ mg -> 1+sizeMG mg
+    MarkM _ mg -> 1+sizeMG mg
+    ComposedM mgs -> 1+sum (map sizeMG mgs)
+-}
diff --git a/hsrc/internals/MeasuredGraphics.hs b/hsrc/internals/MeasuredGraphics.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/MeasuredGraphics.hs
@@ -0,0 +1,123 @@
+module MeasuredGraphics(DPath,up,MeasuredGraphics(..),compileMG,emptyMG,emptyMG',measureString,measureImageString,measurePackedString) where
+import Geometry
+import LayoutRequest
+--import Placers2(overlayP)
+import AutoPlacer(autoP)
+import XDraw
+import ResourceIds(GCId)
+import Font
+import TextExtents(queryTextExtents16K)
+import Rects(boundingRect)
+import CompiledGraphics
+import GCtx(GCtx(..))
+import GCAttrs(FontData(..))
+import PackedString(unpackPS)
+import Utils(lunconcat)
+--import CmdLineEnv(argFlag)
+import Debug.Trace(trace)
+
+tr x y = y
+
+type DPath = [Int] -- path to a part of a drawing
+
+up :: DPath -> DPath
+up [] = []
+up path = init path
+
+data MeasuredGraphics
+--  = LeafM LayoutRequest GCtx (Rect->[DrawCommand])
+	    -- GCtx should be replaced by GCId !
+  = LeafM LayoutRequest (Rect->[(GCId,[DrawCommand])])
+  | SpacedM Spacer MeasuredGraphics
+  | PlacedM Placer MeasuredGraphics
+  | MarkM GCtx MeasuredGraphics -- path & Gctx preserving nodes
+  | ComposedM [MeasuredGraphics]
+
+emptyMG size = emptyMG' (plainLayout size False False)
+emptyMG' layout = LeafM layout (const [])
+
+compileMG f mg = (cg,req)
+  where
+    (reqs,cg) = tr "layoutMG" $ layoutMG mg places
+    (req0,placer2) = unP autoP reqs
+    req = mapLayoutSize f req0
+    place = tr "Rect" $ Rect origin (minsize req)
+    places = placer2 place
+
+    layoutMG :: MeasuredGraphics -> [Rect] -> ([LayoutRequest],CompiledGraphics)
+    layoutMG mg rs =
+      case mg of
+        MarkM _ mg' -> (lls,cgMark cg)
+	  where (lls,cg) = layoutMG mg' rs
+	LeafM ll rcmds -> (tr "LeafM"  [ll],cgLeaf r rcmds)
+	  where [r] = rs -- bug if length rs/=1 !!
+	SpacedM (S spacer1) mg' -> (tr "SpaceM" lls',cgMark cg)
+	  where (lls,cg) = layoutMG mg' rs'
+	        (lls',spacer2s) = unzip (map spacer1 lls)
+	        rs' = map2' id spacer2s rs
+	PlacedM (P placer1) mg -> (tr "PlacedM" [ll'],cgMark cg)
+	  where (lls,cg) = layoutMG mg rs'
+		(ll',placer2) = placer1 lls
+		rs' = placer2 r
+		[r] = tr ("#rs="++show (length rs)) rs
+	ComposedM [] -> (tr "ComposedM []" [],cgCompose (Rect origin origin) [])
+	ComposedM mgs -> (tr "ComposedM" lls',cgCompose r cgs)
+	  where (llss,cgs) = unzip (map2' layoutMG mgs rss)
+	        lls' = concat llss
+		r = case rs of
+		      [] -> trace ("ComposedM, rs=[], length mgs="++show (length mgs)) (rR 0 0 1 1)
+		      _ -> foldr1 boundingRect rs -- !!
+	        rss = lunconcat llss rs
+
+measureString'' unpack draw s (GC gc fd) k =
+     measure $ \ a d next size ->
+     let p1 = Point 0 a
+	 p2 = Point next a
+	 drawit (Rect p (Point _ h)) = [(gc,[draw (p+(Point 0 (h-d))) s])]
+	 size' = Point (xcoord p2) (ycoord size) -- paragraphP bug workaround
+     in --trace (unwords ["measureString ",unpack s,"rect",show r]) $
+        k (LeafM (refpLayout size' True True [p1,p2]) drawit)
+  where
+    us = unpack s
+    measure k =
+      case fd of
+        FS fs -> k a d next size
+	  where
+	    Rect _ size = string_rect fs us
+	    a = font_ascent fs
+	    d = font_descent fs
+	    next = next_pos fs us
+	FID fs ->
+          let fid = font_id fs
+	  in  if null us
+   	      then queryTextExtents16K fid " " $ \ a d cs ->
+	           k a d 0 (Point 0 (a+d))
+	      else queryTextExtents16K fid us $ \ a d cs ->
+	           k a d (char_width cs) (Point (char_rbearing cs) (a+d))
+
+measureString' draw8 draw16 s gctx@(GC _ fd) k =
+    measureString'' id draw s gctx k
+  where
+    draw =
+      case fd of
+        FS fs | snd (font_range fs) <= '\xff' -> draw8
+	_ -> draw16
+
+measureString s = measureString' DrawString DrawString16 s
+measureImageString s = measureString' DrawImageString DrawImageString16 s
+
+{- old:
+measureString =
+  if argFlag "string16bit" False
+  then measureString' id DrawString16
+  else measureString' id DrawString
+-}
+
+measurePackedString ps = measureString'' unpackPS DrawStringPS ps
+
+
+-- map2' is a lazier version of map2 (aka zipWith)
+-- length (map2' f xs ys) = length xs,
+-- map2' f xs ys = map2' f xs (ys++repeat undefined)
+map2' f [] _ = []
+map2' f (x:xs) ~(y:ys) = f x y:map2' f xs ys
diff --git a/hsrc/internals/PathTree.hs b/hsrc/internals/PathTree.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/PathTree.hs
@@ -0,0 +1,182 @@
+module PathTree
+  (
+    PathTree(..),DynTree(..),
+    -- PathTree should be abstract...
+    emptyPathTree,updateNode,mapPathTree,node,subTree,listNodes,
+    attrMapPathTree,
+    pruneTree,
+    pos,unpos,spineVals
+  ) where
+import Direction
+--import Path
+import HbcUtils(apSnd)
+import Maptrace(ctrace)
+
+data PathTree n
+   = Node n (PathTree n) (PathTree n)
+   | Dynamic (DynTree (PathTree n))
+   | Tip
+   deriving (Eq, Ord, Show)
+
+data DynTree n
+  = DynNode n (DynTree n) (DynTree n)
+  | DynTip 
+  deriving (Eq, Ord, Show)
+
+emptyPathTree = Tip
+lookupPath f z = subTree (\(Node w _ _) -> f w) z
+subNodes x = subTree (listNodes []) [] x
+
+listNodes ns t =
+    case t of
+      Tip -> ns
+      Node n l r -> listNodes (listNodes (n : ns) l) r
+      Dynamic dt -> listDynNodes ns dt
+
+listDynNodes ns dt =
+    case dt of
+      DynTip -> ns
+      DynNode t l r -> listNodes (listDynNodes (listDynNodes ns r) l) t
+
+subTree f z Tip _ = z
+subTree f z (Dynamic dt) p = dynSelect (subTree f z) z dt p
+subTree f z n [] = f n
+subTree f z (Node _ l _) (L : path') = subTree f z l path'
+subTree f z (Node _ _ r) (R : path') = subTree f z r path'
+--subTree _ _ t p = error ("subTree _ _ "++show t++" "++show p)
+-- Other cases of ill matching trees/paths return z, so why shouldn't this one?
+subTree _ z t p = ctrace "subTree" ("subTree _ _ "++show t++" "++show p) z
+
+{-
+dynSubTree f z DynTip _ _ = z
+dynSubTree f z (DynNode t _ _) 0 path' = subTree f z t path'
+dynSubTree f z (DynNode _ l r) n path' =
+    dynSubTree f z (if n `rem` 2 == 0 then l else r) (n `quot` 2) path'
+-}
+dynSelect f z dn (Dno n:p) = dynSelect' dn (pos n) where
+   dynSelect' DynTip _ = z
+   dynSelect' (DynNode t l r) n = if n == 0 then f t p else
+	     dynSelect' (if n `rem` 2 == 0 then l else r) (n `quot` 2)
+dynSelect f z dn _ = z
+
+pruneNode e = insertTree e Tip
+insertTree n = updTree id n . const
+pruneTree i e t path = updTree i e (const Tip) t path
+
+updateNode i e t path f = updTree i e g t path
+  where g Tip = Node (f e) Tip Tip
+        g (Node n l r) = Node (f n) l r
+
+updTree i e f t path' =
+    case path' of
+      [] -> f t
+      L : path'' -> updLeft i e f t path''
+      R : path'' -> updRight i e f t path''
+      Dno n : path'' -> updateDyn i e f t (pos n) path''
+
+updLeft i e f t path' =
+    case t of
+      Tip -> Node e (updTree i e f Tip path') Tip
+      Node n l r -> Node (i n) (updTree i e f l path') r
+                    -- !!! space leak danger if i n is never used
+		    -- need stingy evaluation!!
+      Dynamic _ -> error "PathTree.hs: updLeft (Dynamic _)"
+
+updRight i e f t path' =
+    case t of
+      Tip -> Node e Tip (updTree i e f Tip path')
+      Node n l r -> Node (i n) l (updTree i e f r path')
+                    -- !!! space leak danger if i n is never used
+		    -- need stingy evaluation!!
+      Dynamic _ -> error "PathTree.hs: updRight (Dynamic _)"
+
+updateDyn i e f t n path' =
+    case t of
+      Tip -> Dynamic (updateDyn' i e f DynTip n path')
+      Node _ _ _ -> Dynamic (updateDyn' i e f DynTip n path') -- throwing away part of the tree !!!
+      Dynamic t' -> Dynamic (updateDyn' i e f t' n path')
+
+updateDyn' i e f DynTip 0 path' =
+    DynNode (updTree i e f Tip path') DynTip DynTip
+updateDyn' i e f (DynNode t l r) 0 path' = DynNode (updTree i e f t path') l r
+updateDyn' i e f t n path' =
+    (if n `rem` 2 == 0 then updDynLeft else updDynRight) i e f
+                                                         t
+                                                         (n `quot` 2)
+                                                         path'
+
+updDynLeft i e f t n path' =
+    case t of
+      DynTip -> DynNode Tip (updateDyn' i e f DynTip n path') DynTip
+      DynNode t' l r -> DynNode t' (updateDyn' i e f l n path') r
+
+updDynRight i e f t n path' =
+    case t of
+      DynTip -> DynNode Tip DynTip (updateDyn' i e f DynTip n path')
+      DynNode t' l r -> DynNode t' l (updateDyn' i e f r n path')
+
+pos :: Int->Int
+pos 0 = 0
+pos n = if n < 0 then (-2) * n else 2 * n + 1
+
+unpos :: Int->Int
+unpos n =
+  if even n
+  then -(n `quot` 2)
+  else n `quot` 2
+
+mapPathTree f t =
+  case t of
+    Node n lt rt -> Node (f n) (mapPathTree f lt) (mapPathTree f rt)
+    Dynamic dt -> Dynamic (mapDyn (mapPathTree f) dt)
+    Tip -> Tip
+
+mapDyn f dt =
+  case dt of
+    DynNode n lt rt -> DynNode (f n) (mapDyn f lt) (mapDyn f rt)
+    DynTip -> DynTip
+
+attrMapPathTree :: (i -> [s] -> a -> (i,s,b)) -> i -> PathTree a -> 
+		   ([s],PathTree b)
+attrMapPathTree f i t = case t of
+   Node n lt rt -> ([s],Node n' lt' rt') where
+      (sl,lt') = attrMapPathTree f i' lt
+      (sr,rt') = attrMapPathTree f i' rt
+      (i',s,n') = f i (sl++sr) n
+      -- should perhaps extract ++ and []
+   Tip -> ([],Tip)
+   Dynamic dt -> apSnd Dynamic (attrMapDyn f i dt)
+
+attrMapDyn f i dt = case dt of
+   DynTip -> ([],DynTip)
+   DynNode t lt rt -> (s++sl++sr,DynNode t' lt' rt') where
+	     --        order?
+      (sl,lt') = attrMapDyn f i lt
+      (sr,rt') = attrMapDyn f i rt
+      (s,t') = attrMapPathTree f i t
+
+spineVals t p = case t of
+	  Tip -> []
+	  Node v l r -> v : case p of
+	       L:p' -> spineVals l p'
+	       R:p' -> spineVals r p'
+	       _    -> []
+          Dynamic dt -> dynSelect spineVals [] dt p
+
+node t =
+  case t of
+    Node i lt rt -> (Just i,children lt (children rt []))
+    Tip -> (Nothing,[])
+    Dynamic dt -> (Nothing,dynChildren dt [])
+
+children t ts =
+  case t of
+    Tip -> ts
+    Node _ _ _ -> t:ts
+    Dynamic dt -> dynChildren dt ts
+
+dynChildren dt ts =
+  case dt of
+    DynTip -> ts
+    DynNode t lt rt -> (children t . dynChildren lt . dynChildren rt) ts
+      -- !! order??
diff --git a/hsrc/internals/Queue.hs b/hsrc/internals/Queue.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Queue.hs
@@ -0,0 +1,17 @@
+module Queue(QUEUE, qmember, isempty, qremove, enter, empty) where
+
+data QUEUE a = Queue [a] [a]  deriving (Eq, Ord)
+
+empty = Queue [] []
+
+enter (Queue outl' inl) x = Queue outl' (x : inl)
+
+isempty (Queue [] []) = True
+isempty _ = False
+
+qremove (Queue (a : outl') inl) = Just (a, Queue outl' inl)
+qremove (Queue [] []) = Nothing --error "qremove from empty queue"
+qremove (Queue [] inl) = qremove (Queue (reverse inl) [])
+
+qmember (Queue outl' inl) x = x `elem` outl' || x `elem` inl
+
diff --git a/hsrc/internals/StringEdit.hs b/hsrc/internals/StringEdit.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/StringEdit.hs
@@ -0,0 +1,51 @@
+module StringEdit(
+       moveCursorHome,moveCursorEnd,extendCursorHome,extendCursorEnd,
+       moveCursorRight, moveCursorLeft, extendCursorLeft,extendCursorRight,
+       deleteItemRight, deleteItemLeft, deleteToEnd, deleteToHome,
+       insertItem, insertItemsSelected, showField, getField,
+       createField2, createField, Field) where
+
+data Field a = F [a] [a] [a]  deriving (Eq, Ord)
+
+createField s = F [] s []
+
+createField2 (before, after) = F (reverse before) [] after
+
+getField (F l c r) = reverse l ++ c ++ r
+
+showField show' show_cursor (F l c r) =
+    show' r . show_cursor c . show' (reverse l)
+
+insertItem (F l c r) i = F (i : l) [] r
+insertItemsSelected (F l c r) i = F l i r
+
+deleteItemLeft f@(F [] [] _) = f
+deleteItemLeft (F (i : l) [] r) = F l [] r
+deleteItemLeft (F l c r) = F l [] r
+
+deleteItemRight f@(F _ [] []) = f
+deleteItemRight (F l [] (i : r)) = F l [] r
+deleteItemRight (F l c r) = F l [] r
+
+deleteToEnd (F l c r) = F l [] []
+deleteToHome (F l c r) = F [] [] r
+
+extendCursorRight (F l c (i : r)) = F l (c ++ [i]) r
+extendCursorRight f@(F _ _ []) = f
+
+extendCursorLeft (F (i : l) c r) = F l (i : c) r
+extendCursorLeft f@(F [] _ _) = f
+
+moveCursorLeft f@(F [] [] _) = f
+moveCursorLeft (F (i : l) [] r) = F l [] (i : r)
+moveCursorLeft (F l c r) = F l [] (c ++ r)
+
+moveCursorRight f@(F _ [] []) = f
+moveCursorRight (F l [] (i : r)) = F (i : l) [] r
+moveCursorRight (F l c r) = F (reverse c ++ l) [] r
+
+moveCursorHome f = F [] [] (getField f)
+moveCursorEnd  f = F (reverse (getField f)) [] []
+
+extendCursorHome (F l c r) = F [] (reverse l++c) r
+extendCursorEnd (F l c r) = F l (c++r) []
diff --git a/hsrc/internals/Table.hs b/hsrc/internals/Table.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Table.hs
@@ -0,0 +1,23 @@
+module Table(table, mapTable, listTable, tableUpdate, tableLookup, emptyTable,
+             Table) where
+import Tree234
+
+newtype Table a = T (Tree234 a) deriving (Eq, Ord,Show)
+
+emptyTable = T initTree234
+
+tableLookup n j x (T t) = treeSearch n j (keyCmp x) t
+
+tableUpdate x (T t) = T (update' x t)
+
+update' x = treeAdd const keyCmp x
+
+mapTable f (T t) = T (treeMap f t)
+
+listTable (T t) = treeList t
+
+table xs = T (treeFromList const keyCmp xs)
+
+keyCmp (a, _) (b, _) lt eq gt =
+    if a == b then eq else if a < b then lt else gt
+
diff --git a/hsrc/internals/Tables.hs b/hsrc/internals/Tables.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Tables.hs
@@ -0,0 +1,99 @@
+module Tables(PathTable(..), WidTable(..), updatePath, lookupPath, wid2path0,
+              pruneWid, updateWid, subWids, lookupWid, path2wid0, PathTree,
+	      moveWids,movePaths, prunePath) where
+import Direction
+--import Fudget
+import Path
+import Table
+import PathTree
+import Utils(oo)
+import Xtypes
+
+-- Most functions here should be imported from PathTree instead !!!
+
+type WidTable = PathTree WindowId
+
+path2wid0 = Tip
+
+lookupWid = subTree (\(Node w _ _) -> w) noWindow
+
+moveWids path2wid opath npath = insertTree st pt npath where
+    st = subTree id Tip path2wid opath 
+    pt = pruneWid path2wid opath
+
+subWids = oo (filter (/= noWindow)) (subTree (listWids []) [])
+
+listWids = listNodes
+
+updateWid t path' wid = insertTree (Node wid Tip Tip) t path'
+
+pruneWid t path' = insertTree Tip t path'
+
+insertTree = updTree . const
+updTree f t path' =
+    case path' of
+      [] -> f t
+      L : path'' -> updLeft f t path''
+      R : path'' -> updRight f t path''
+      Dno n : path'' -> updateDyn f t (pos n) path''
+
+updLeft f t path' =
+    case t of
+      Tip -> Node nowid (updTree f Tip path') Tip
+      Node w l r -> Node w (updTree f l path') r
+      Dynamic _ -> error "tables.m: updLeft (Dynamic _)"
+
+updRight f t path' =
+    case t of
+      Tip -> Node nowid Tip (updTree f Tip path')
+      Node w l r -> Node w l (updTree f r path')
+      Dynamic _ -> error "tables.m: updRight (Dynamic _)"
+
+updateDyn f t n path' =
+    case t of
+      Tip -> Dynamic (updateDyn' f DynTip n path')
+      Dynamic t' -> Dynamic (updateDyn' f t' n path')
+
+updateDyn' f DynTip 0 path' =
+    DynNode (updTree f Tip path') DynTip DynTip
+updateDyn' f (DynNode t l r) 0 path' = DynNode (updTree f t path') l r
+updateDyn' f t n path' =
+    (if n `rem` 2 == 0 then updDynLeft else updDynRight) f
+                                                         t
+                                                         (n `quot` 2)
+                                                         path'
+
+updDynLeft f t n path' =
+    case t of
+      DynTip -> DynNode Tip (updateDyn' f DynTip n path') DynTip
+      DynNode t' l r -> DynNode t' (updateDyn' f l n path') r
+
+updDynRight f t n path' =
+    case t of
+      DynTip -> DynNode Tip DynTip (updateDyn' f DynTip n path')
+      DynNode t' l r -> DynNode t' l (updateDyn' f r n path')
+
+nowid = noWindow
+
+-------
+type PathTable = Table (WindowId, Path)
+
+nopath = here -- error "window not associated with a path"
+
+wid2path0 = emptyTable
+
+-- This part should be replaced with something more efficient!!
+lookupPath wid2path wid =
+    tableLookup nopath snd (wid, nopath) wid2path
+
+-- normal code
+updatePath wid2path wid path' = tableUpdate (wid, path') wid2path
+
+movePaths wid2path opath npath = mapTable move wid2path where
+  move (wid,path) = (wid,repath opath path) where
+     repath [] rest = absPath npath rest
+     repath (x:xs) (y:ys) | x == y = repath xs ys
+     repath _ _ = path
+
+-- should be implemented in Tree234
+prunePath wid2path w = table $ filter ((/=w).fst) $ listTable wid2path
diff --git a/hsrc/internals/Tables2.hs b/hsrc/internals/Tables2.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Tables2.hs
@@ -0,0 +1,24 @@
+module Tables2(DTable(..), dtable0, lookupDe, listDe, updateDe) where
+import Utils(pair)
+import Direction() -- instances
+import Path(here,Path(..))
+import Sockets(Descriptor)
+import Table
+
+type DTable = Table (Descriptor, Path)
+
+updateDe :: Path -> [Descriptor] -> DTable -> DTable
+updateDe path' ds dtable =
+    table (map (`pair` path') ds ++
+           filter ((/= path') . snd) (listTable dtable))
+
+listDe :: DTable -> [Descriptor]
+listDe dtable = map fst (listTable dtable)
+
+lookupDe :: DTable -> Descriptor -> Path
+lookupDe dtable de =
+    tableLookup (error ("Descriptor without path: "++show de)) snd (de, here) dtable
+
+dtable0 :: DTable
+dtable0 = table []
+
diff --git a/hsrc/internals/Tree234.hs b/hsrc/internals/Tree234.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/Tree234.hs
@@ -0,0 +1,239 @@
+module Tree234(treeMap, treeCombine, treeRebuild, treeFromList, treeMapList,
+               treeList, treeUpdate, treeSearch, treeAdd, initTree234, Tree234) where
+
+data Tree234 a = Leaf |
+                 Leaf2 a |
+                 Leaf3 a a |
+                 Leaf4 a a a |
+                 Node2 a (Tree234 a) (Tree234 a) |
+                 Node3 a a (Tree234 a) (Tree234 a) (Tree234 a) |
+                 Node4 a a a (Tree234 a) (Tree234 a) (Tree234 a) (Tree234 a) 
+                 deriving (Eq, Ord,Show)
+
+initTree234 = Leaf
+
+treeAdd comb cmp a t = treeAdd' comb cmp a id Node2 t
+
+treeSearch fail cont p Leaf = fail
+treeSearch fail cont p (Leaf2 a1) = p a1 fail (cont a1) fail
+treeSearch fail cont p (Leaf3 a1 a2) =
+    p a1 fail (cont a1) (p a2 fail (cont a2) fail)
+treeSearch fail cont p (Leaf4 a1 a2 a3) =
+    p a2 (p a1 fail (cont a1) fail) (cont a2) (p a3 fail (cont a3) fail)
+treeSearch fail cont p (Node2 a1 t1 t2) =
+    p a1 (treeSearch fail cont p t1) (cont a1) (treeSearch fail cont p t2)
+treeSearch fail cont p (Node3 a1 a2 t1 t2 t3) =
+    p a1
+      (treeSearch fail cont p t1)
+      (cont a1)
+      (p a2
+         (treeSearch fail cont p t2)
+         (cont a2)
+         (treeSearch fail cont p t3))
+treeSearch fail cont p (Node4 a1 a2 a3 t1 t2 t3 t4) =
+    p a2
+      (p a1
+         (treeSearch fail cont p t1)
+         (cont a1)
+         (treeSearch fail cont p t2))
+      (cont a2)
+      (p a3
+         (treeSearch fail cont p t3)
+         (cont a3)
+         (treeSearch fail cont p t4))
+
+treeUpdateFailed = error "treeUpdate couldn't find the node"
+
+treeUpdate update p Leaf = Leaf
+treeUpdate update p (Leaf2 a1) =
+    p a1 treeUpdateFailed (Leaf2 (update a1)) treeUpdateFailed
+treeUpdate update p (Leaf3 a1 a2) =
+    p a1
+      treeUpdateFailed
+      (Leaf3 (update a1) a2)
+      (p a2 treeUpdateFailed (Leaf3 a1 (update a2)) treeUpdateFailed)
+treeUpdate update p (Leaf4 a1 a2 a3) =
+    p a2
+      (p a1 treeUpdateFailed (Leaf4 (update a1) a2 a3) treeUpdateFailed)
+      (Leaf4 a1 (update a2) a3)
+      (p a3 treeUpdateFailed (Leaf4 a1 a2 (update a3)) treeUpdateFailed)
+treeUpdate update p (Node2 a1 t1 t2) =
+    p a1
+      (Node2 a1 (treeUpdate update p t1) t2)
+      (Node2 (update a1) t1 t2)
+      (Node2 a1 t1 (treeUpdate update p t2))
+treeUpdate update p (Node3 a1 a2 t1 t2 t3) =
+    p a1
+      (Node3 a1 a2 (treeUpdate update p t1) t2 t3)
+      (Node3 (update a1) a2 t1 t2 t3)
+      (p a2
+         (Node3 a1 a2 t1 (treeUpdate update p t2) t3)
+         (Node3 a1 (update a2) t1 t2 t3)
+         (Node3 a1 a2 t1 t2 (treeUpdate update p t3)))
+treeUpdate update p (Node4 a1 a2 a3 t1 t2 t3 t4) =
+    p a2
+      (p a1
+         (Node4 a1 a2 a3 (treeUpdate update p t1) t2 t3 t4)
+         (Node4 (update a1) a2 a3 t1 t2 t3 t4)
+         (Node4 a1 a2 a3 t1 (treeUpdate update p t2) t3 t4))
+      (Node4 a1 (update a2) a3 t1 t2 t3 t4)
+      (p a3
+         (Node4 a1 a2 a3 t1 t2 (treeUpdate update p t3) t4)
+         (Node4 a1 a2 (update a3) t1 t2 t3 t4)
+         (Node4 a1 a2 a3 t1 t2 t3 (treeUpdate update p t4)))
+
+treeMapList f Leaf = []
+treeMapList f (Leaf2 a1) = f a1
+treeMapList f (Leaf3 a1 a2) = f a1 ++ f a2
+treeMapList f (Leaf4 a1 a2 a3) = f a1 ++ f a2 ++ f a3
+treeMapList f (Node2 a1 t1 t2) =
+    treeMapList f t1 ++ f a1 ++ treeMapList f t2
+treeMapList f (Node3 a1 a2 t1 t2 t3) =
+    treeMapList f t1 ++
+    f a1 ++ treeMapList f t2 ++ f a2 ++ treeMapList f t3
+treeMapList f (Node4 a1 a2 a3 t1 t2 t3 t4) =
+    treeMapList f t1 ++
+    f a1 ++
+    treeMapList f t2 ++
+    f a2 ++ treeMapList f t3 ++ f a3 ++ treeMapList f t4
+
+treeMap f Leaf = Leaf
+treeMap f (Leaf2 a1) = Leaf2 (f a1)
+treeMap f (Leaf3 a1 a2) = Leaf3 (f a1) (f a2)
+treeMap f (Leaf4 a1 a2 a3) = Leaf4 (f a1) (f a2) (f a3)
+treeMap f (Node2 a1 t1 t2) =
+    Node2 (f a1) (treeMap f t1) (treeMap f t2)
+treeMap f (Node3 a1 a2 t1 t2 t3) =
+    Node3 (f a1) (f a2) (treeMap f t1) (treeMap f t2) (treeMap f t3)
+treeMap f (Node4 a1 a2 a3 t1 t2 t3 t4) =
+    Node4 (f a1)
+          (f a2)
+          (f a3)
+          (treeMap f t1)
+          (treeMap f t2)
+          (treeMap f t3)
+          (treeMap f t4)
+
+treeFromList comb cmp l = treeAddList comb cmp l Leaf
+
+treeAddList comb cmp [] t = t
+treeAddList comb cmp (x : xs) t =
+    treeAddList comb cmp xs (treeAdd comb cmp x t)
+
+treeRebuild comb cmp t = treeFromList comb cmp (treeMapList (: []) t)
+
+treeCombine comb cmp t1 t2 =
+    treeAddList comb cmp (treeMapList (: []) t2) t1
+
+treeAdd' comb cmp a keep split Leaf = keep (Leaf2 a)
+treeAdd' comb cmp a keep split (Leaf2 a1) =
+    keep (cmp a a1 (Leaf3 a a1) (Leaf2 (comb a a1)) (Leaf3 a1 a))
+treeAdd' comb cmp a keep split (Leaf3 a1 a2) =
+    keep (cmp a
+              a1
+              (Leaf4 a a1 a2)
+              (Leaf3 (comb a a1) a2)
+              (cmp a a2 (Leaf4 a1 a a2) (Leaf3 a1 (comb a a2)) (Leaf4 a1 a2 a)))
+treeAdd' comb cmp a keep split (Leaf4 a1 a2 a3) =
+    cmp a
+        a2
+        (cmp a
+             a1
+             (split a2 (Leaf3 a a1) (Leaf2 a3))
+             (keep (Leaf4 (comb a a1) a2 a3))
+             (split a2 (Leaf3 a1 a) (Leaf2 a3)))
+        (keep (Leaf4 a1 (comb a a2) a3))
+        (cmp a
+             a3
+             (split a2 (Leaf2 a1) (Leaf3 a a3))
+             (keep (Leaf4 a1 a2 (comb a a3)))
+             (split a2 (Leaf2 a1) (Leaf3 a3 a)))
+treeAdd' comb cmp a keep split (Node2 a1 t1 t2) =
+    keep (cmp a
+              a1
+              (treeAdd' comb
+                        cmp
+                        a
+                        (\t1' -> Node2 a1 t1' t2)
+                        (\a0' -> \t0' -> \t1' -> Node3 a0' a1 t0' t1' t2)
+                        t1)
+              (Node2 (comb a a1) t1 t2)
+              (treeAdd' comb
+                        cmp
+                        a
+                        (\t2' -> Node2 a1 t1 t2')
+                        (\a2' -> \t2' -> \t3' -> Node3 a1 a2' t1 t2' t3')
+                        t2))
+treeAdd' comb cmp a keep split (Node3 a1 a2 t1 t2 t3) =
+    keep (cmp a
+              a1
+              (treeAdd' comb
+                        cmp
+                        a
+                        (\t1' -> Node3 a1 a2 t1' t2 t3)
+                        (\a0' -> \t0' -> \t1' -> Node4 a0' a1 a2 t0' t1' t2 t3)
+                        t1)
+              (Node3 (comb a a1) a2 t1 t2 t3)
+              (cmp a
+                   a2
+                   (treeAdd' comb
+                             cmp
+                             a
+                             (\t2' -> Node3 a1 a2 t1 t2' t3)
+                             (\a1_5' ->
+                              \t1_5' ->
+                              \t2' -> Node4 a1 a1_5' a2 t1 t1_5' t2' t3)
+                             t2)
+                   (Node3 a1 (comb a a2) t1 t2 t3)
+                   (treeAdd' comb
+                             cmp
+                             a
+                             (\t3' -> Node3 a1 a2 t1 t2 t3')
+                             (\a3' ->
+                              \t3' -> \t4' -> Node4 a1 a2 a3' t1 t2 t3' t4')
+                             t3)))
+treeAdd' comb cmp a keep split (Node4 a1 a2 a3 t1 t2 t3 t4) =
+    cmp a
+        a2
+        (cmp a
+             a1
+             (split a2
+                    (treeAdd' comb
+                              cmp
+                              a
+                              (\t1' -> Node2 a1 t1' t2)
+                              (\a0' -> \t0' -> \t1' -> Node3 a0' a1 t0' t1' t2)
+                              t1)
+                    (Node2 a3 t3 t4))
+             (keep (Node4 (comb a a1) a2 a3 t1 t2 t3 t4))
+             (split a2
+                    (treeAdd' comb
+                              cmp
+                              a
+                              (\t2' -> Node2 a1 t1 t2')
+                              (\a2' -> \t2' -> \t3' -> Node3 a1 a2' t1 t2' t3')
+                              t2)
+                    (Node2 a3 t3 t4)))
+        (keep (Node4 a1 (comb a a2) a3 t1 t2 t3 t4))
+        (cmp a
+             a3
+             (split a2
+                    (Node2 a1 t1 t2)
+                    (treeAdd' comb
+                              cmp
+                              a
+                              (\t3' -> Node2 a3 t3' t4)
+                              (\a2' -> \t2' -> \t3' -> Node3 a2' a3 t2' t3' t4)
+                              t3))
+             (keep (Node4 a1 a2 (comb a a3) t1 t2 t3 t4))
+             (split a2
+                    (Node2 a1 t1 t2)
+                    (treeAdd' comb
+                              cmp
+                              a
+                              (\t4' -> Node2 a3 t3 t4')
+                              (\a4' -> \t4' -> \t5' -> Node3 a3 a4' t3 t4' t5')
+                              t4)))
+
+treeList t = treeMapList (: []) t
+
diff --git a/hsrc/internals/UndoStack.hs b/hsrc/internals/UndoStack.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/internals/UndoStack.hs
@@ -0,0 +1,27 @@
+module UndoStack(UndoStack,undoStack,doit,undo,redo) where
+--import EitherUtils(mapMaybe)
+
+data UndoStack a = U (Maybe Int) [a] [a] [a]
+--                   depth limit undos temp-undos temp-redos
+undoStack:: Maybe Int -> UndoStack a
+undoStack on = U (fmap (\n -> max 0 n + 1) on) [] [] []
+
+otake on l = case on of
+	        Nothing -> l
+		Just n -> take n l
+
+doit :: UndoStack a -> a -> (UndoStack a -> c) -> c
+doit (U on u tu tr) a c = seq (length u') $ c (U on u' (tail u') [])
+    where u' = otake on (a:take 1 tr++u)
+
+undo :: UndoStack a -> Maybe (a,UndoStack a)
+undo (U on u tu tr) = case tu of
+			a:tu' -> Just (a,U on u tu' (a:tr))
+			[] -> Nothing
+
+redo :: UndoStack a -> Maybe (a,UndoStack a)
+redo (U on u tu tr) = 
+     case tr of
+       a:b:tr' -> Just (b,U on u (a:tu) (b:tr'))
+       [a] -> Just (head u,U on u (a:tu) [])
+       [] -> Nothing
diff --git a/hsrc/io/AppStorage.hs b/hsrc/io/AppStorage.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/AppStorage.hs
@@ -0,0 +1,20 @@
+module AppStorage where
+import System.Directory(XdgDirectory(..))
+import ReadFileF
+import WriteFile
+import HbcUtils(apSnd)
+import CompOps
+import NullF
+import Spops
+
+appStorageF :: (Read a,Show a) => String -> a -> F a a
+appStorageF key d =
+  either (const d) (maybe d id . readM) . snd
+  >^=< startupF [key] (readXdgFileF XdgData)
+  >=^^< nullSP
+  >==< writeXdgFileF XdgData
+  >=^< (,) key . show
+
+readM x = case reads x of
+            [(x,s)] | lex s == [("","")] -> Just x
+            _ -> Nothing
diff --git a/hsrc/io/AsyncTransmitter.hs b/hsrc/io/AsyncTransmitter.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/AsyncTransmitter.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE CPP #-}
+module AsyncTransmitter(asyncTransmitterF,asyncTransmitterF',closerF) where
+import Sockets
+import Srequest
+import FRequest
+import Message(message)
+import NullF(getK,nullK,nullF)
+import Fudget()
+import FudgetIO
+import CompOps((>==<))
+import IoF(ioF)
+import DialogueIO hiding (IOError)
+import qualified PackedString as PS
+import Queue(QUEUE,empty,enter,qremove)
+
+{- asyncTransmitterF has two states:
+
+   - Idle state: we have nothing to send and don't want to be notified when
+                 the socket becomes writable.
+
+   - Blocked state: we have something to send and want to be notified when
+                   the socket becomes writable.
+
+   idleK handles the idle state. Transistion to the idleState is done
+   with goIdleK. idleK should only be called when in the idle state.
+
+   blockedK handles the blocked state. Transition to the blocked state is done
+   with goBlockedK. blockedK should only be called when in the blocked state.
+
+   writeK is called in blocked mode when the socket become writable. If there
+   is something left in the buffer to write, writeK writes a chunk to the
+   socket and continues in blocked mode, otherwise writeK switches to
+   idle mode.
+-}
+
+asyncTransmitterF socket = closerF socket >==< asyncTransmitterF' socket
+
+asyncTransmitterF' socket =
+    -- Start in idle mode
+    ioF idleK
+  where
+    -- To be called while in idle mode only:
+    idleK = getMsg (const idleK) high
+      where
+	high "" = closeK
+	high str = goBlockedK (buf1 str)
+
+    -- To swich from blocked to idle mode:
+    goIdleK = select [] $ idleK
+
+    -- To switch from idle mode to blocked mode:
+    goBlockedK buf =
+      select [OutputSocketDe socket] $
+      blockedK buf initblocksize
+
+    -- To be called while in blocked mode only:
+    blockedK buf n = getMsg low high
+      where
+        low (DResp (AsyncInput (_,SocketWritable))) = writeK buf n
+	high str = blockedK (putbuf buf str) n
+
+    -- To be called while in blocked mode, when socket becomes writable:
+    writeK buf n =
+      case getbuf buf n of
+        Empty -> goIdleK
+	EoS   -> closeK
+	More ps buf' -> sIOerr (WriteSocketPS socket ps) errK okK
+	  where
+	    okK (Wrote n')  = blockedK buf' n
+	    errK _          = blockedK buf' n -- Ignore errors?!
+
+    closeK =
+      select [] $
+      --sIOsucc (CloseSocket socket) $
+      -- Can't close the socket until the receiver (if any) has deselected it!
+      putHigh () $
+      nullK
+
+closerF socket =
+  getHigh $ \ _ ->
+  sIOsucc (CloseSocket socket) $
+  nullF
+
+getMsg l h = getK $ message l h
+
+data Buffer = Buf String (QUEUE String)
+data GetBuf = More PS.PackedString Buffer | Empty | EoS
+
+--buf0 = Buf "" empty
+buf1 str = Buf str empty -- pre: str/=""
+
+putbuf (Buf s q) str = Buf s (enter q str) -- str=="" to indicate eos
+
+getbuf (Buf s q) n = getbuf' s q
+  where
+    getbuf' "" q =
+      case qremove q of
+        Nothing -> Empty
+	Just (s,q') ->
+	  if null s
+	  then EoS
+	  else getbuf'' s q'
+
+    getbuf' s q = getbuf'' s q
+
+    getbuf'' s q =
+      case splitAt n s of
+        (s1,s2) -> More (PS.packString s1) (Buf s2 q)
+
+
+initblocksize = 512 :: Int
+
+#if defined(__GLASGOW_HASKELL__) || defined(__PFE__)
+nullPS = PS.nullPS
+#else
+nullPS = PS.null
+#endif
diff --git a/hsrc/io/HaskellIO.hs b/hsrc/io/HaskellIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/HaskellIO.hs
@@ -0,0 +1,63 @@
+module HaskellIO{-(hIOSucc, hIOSuccK, hIOSuccF,
+	         hIO, hIOK, hIOF,
+	         hIOerr, hIOerrK, hIOerrF,
+	         haskellIO, haskellIOK, haskellIOF)-} where
+import Prelude hiding (IOError)
+--import Command
+--import Cont(cmdContF)
+import FudgetIO
+import NullF(F)
+import FRequest
+--import Event
+--import Fudget
+--import Message(Message(..))
+import ShowFailure
+--import Sockets
+--import Xtypes
+import DialogueIO
+
+hIOSucc req = hIO req . const
+
+hIOerr req fcont scont =
+  haskellIO req $ \ resp ->
+  case resp of
+    Failure f -> fcont f
+    _ -> scont resp
+
+haskellIO request = cmdContLow (DReq request) expected
+  where
+    expected (DResp response) = Just response
+--  expected (SResp sresp) = Just (SocketResponse sresp) -- for backward compat
+    expected _ = Nothing
+
+hIO req = hIOerr req (\e -> error ("IOError: " ++ showFailure e))
+
+------
+
+haskellIOF :: Request -> (Response -> F a b) -> F a b
+haskellIOF = haskellIO
+
+hIOerrF :: Request -> (IOError -> F a b) -> (Response -> F a b) -> F a b
+hIOerrF = hIOerr
+
+hIOF :: Request -> (Response -> F a b) -> F a b
+hIOF = hIO
+
+hIOSuccF :: Request -> (F a b) -> F a b
+hIOSuccF = hIOSucc
+
+{---
+
+haskellIOK :: Request -> (Response -> K a b) -> K a b
+haskellIOK = haskellIO
+
+hIOerrK :: Request -> (IOError -> K a b) -> (Response -> K a b) -> K a b
+hIOerrK = hIOerr
+
+hIOK :: Request -> (Response -> K a b) -> K a b
+hIOK = hIO
+
+hIOSuccK :: Request -> (K a b) -> K a b
+hIOSuccK = hIOSucc
+
+---}
diff --git a/hsrc/io/InOut.hs b/hsrc/io/InOut.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/InOut.hs
@@ -0,0 +1,17 @@
+module InOut (-- * IO
+  module HaskellIO,module StdIoUtil,module IoF,module Socketio,module OpenSocket,module Transceivers,module AsyncTransmitter,module TimerF,module ReadFileF,module WriteFile,module AppStorage,module Process,module UnsafeGetDLValue,module GetTime,module GetModificationTime) where
+import HaskellIO
+import StdIoUtil
+import IoF
+import Socketio
+import OpenSocket
+import Transceivers
+import AsyncTransmitter
+import TimerF
+import ReadFileF
+import WriteFile
+import AppStorage
+import Process
+import UnsafeGetDLValue
+import GetTime -- compiler dependent!
+import GetModificationTime -- compiler dependent!
diff --git a/hsrc/io/IoF.hs b/hsrc/io/IoF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/IoF.hs
@@ -0,0 +1,14 @@
+module IoF(ioF) where
+--import Command(Command(..), XCommand)
+--import Direction
+--import Event(Event(..))
+--import Fudget
+--import Geometry(Line(..), Point(..), Rect(..), Size(..))
+--import Message(Message)
+--import Path(Path(..))
+--import SP
+import WindowF(kernelF)
+--import Xtypes(WindowAttributes)
+
+ioF = kernelF
+
diff --git a/hsrc/io/OpenSocket.hs b/hsrc/io/OpenSocket.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/OpenSocket.hs
@@ -0,0 +1,28 @@
+module OpenSocket(
+  openSocketF,openSocketErrF,
+  openLSocketF,openLSocketErrF,
+  openFileAsSocketF,openFileAsSocketErrF
+  ) where
+import Srequest
+import Sockets
+
+-- All eta expanstion are due to the monomorphism restriction
+
+openSocketF h = openSocketF' sIO h
+openLSocketF p = openLSocketF' sIO p
+openFileAsSocketF h = openFileAsSocketF' sIO h
+
+openSocketErrF h p e = openSocketF' (sIOerr' e) h p
+openLSocketErrF p e = openLSocketF' (sIOerr' e) p
+openFileAsSocketErrF n m e = openFileAsSocketF' (sIOerr' e) n m
+
+openSocketF' sio host port cont =
+  sio (OpenSocket host port) $ \ (Socket socket) -> cont socket
+
+openLSocketF' sio port cont =
+  sio (OpenLSocket port) $ \(LSocket lsocket) -> cont lsocket
+
+openFileAsSocketF' sio name mode cont =
+  sio (OpenFileAsSocket name mode) $ \ (Socket socket) -> cont socket
+
+sIOerr' e r = sIOerr r e
diff --git a/hsrc/io/Process.hs b/hsrc/io/Process.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/Process.hs
@@ -0,0 +1,15 @@
+module Process where
+--import Fudget
+--import Xtypes
+import Srequest
+import NullF()
+--import FudgetIO
+import Sockets
+import Transceivers
+import CompOps
+--import DialogueIO hiding (IOError)
+
+subProcessF cmd =
+  sIO (StartProcess cmd True True True) $
+     \ (ProcessSockets (Just sin) (Just sout) (Just serr)) ->
+     (receiverF sout>+<receiverF serr)>==<transmitterF sin
diff --git a/hsrc/io/ReadFileF.hs b/hsrc/io/ReadFileF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/ReadFileF.hs
@@ -0,0 +1,40 @@
+module ReadFileF(readFileF,readBinaryFileF,readXdgFileF,readDirF) where
+import Fudget() -- synonym KEvent, for hbc
+import NullF
+import FudgetIO
+import IoF(ioF)
+import HaskellIO(haskellIO)
+import Message(Message(..))
+import DialogueIO hiding (IOError)
+
+readFileF = ioF readFileK
+readBinaryFileF = ioF readBinaryFileK
+readXdgFileF = ioF . readXdgFileK
+
+readFileK = readFileK' ReadFile
+readBinaryFileK = readFileK' ReadBinaryFile
+readXdgFileK = readFileK' . ReadXdgFile
+
+readFileK' req =
+  getK $ \ msg ->
+  case msg of
+    High filename ->
+      haskellIO (req filename) $ \ resp ->
+      putHigh (filename,case resp of
+                          Str s -> Right s
+		          Failure err -> Left err)
+      readFileK
+    _ -> readFileK
+
+readDirF = ioF readDirK
+
+readDirK =
+  getK $ \ msg ->
+  case msg of
+    High dirname ->
+      haskellIO (ReadDirectory dirname) $ \ resp ->
+      putHigh (dirname,case resp of
+		         StrList filenames -> Right filenames
+			 Failure err -> Left err)
+      readDirK
+    _ -> readDirK
diff --git a/hsrc/io/Socketio.hs b/hsrc/io/Socketio.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/Socketio.hs
@@ -0,0 +1,34 @@
+module Socketio where
+import Fudget
+import FudgetIO
+import FRequest
+import Srequest
+--import Message(Message(..))
+import NullF
+import Sockets
+import Utils(loop)
+--import Xtypes
+import DialogueIO hiding (IOError)
+
+transmitterF' s =
+  loop $ \l -> getF $ \str ->
+  if null str
+  then putHigh () nullF
+  else sIOsucc (WriteSocket s str) l
+
+receiverF' s =
+    select [SocketDe s] $
+    loop $ \l ->
+          getMessageFu $ \e ->
+           case e of
+             Low (DResp (AsyncInput (_, SocketRead str))) ->
+	       if null str
+	       then closeDown
+	       else putF str l
+             High _ -> closeDown
+  where
+    closeDown =
+      select [] $
+      putHigh "" $
+      sIOsucc (CloseSocket s) $
+      nullF
diff --git a/hsrc/io/StdIoUtil.hs b/hsrc/io/StdIoUtil.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/StdIoUtil.hs
@@ -0,0 +1,60 @@
+module StdIoUtil(linesSP, inputLinesSP, echoK, echoStderrK,
+          appendChanK, appendStdoutK, appendStderrK,
+          outputF, stdioF, stderrF, stdoutF, stdinF) where
+--import Command
+import CompOps((>==<))
+import CompSP(serCompSP)
+--import Event
+import HaskellIO(hIOSucc)
+import Srequest
+import IoF
+import Message(message)
+import Transceivers(receiverF)
+import Sockets
+import Spops
+--import Xtypes
+import Fudget
+--import FudgetIO
+import NullF(getK{-,F,K-})
+import ContinuationIO(stdout,stderr)
+import DialogueIO hiding (IOError)
+
+stdoutF = outputF stdout
+stderrF = outputF stderr
+stdioF = stdinF >==< stdoutF
+
+outputF :: String -> F String a
+outputF = ioF . outputK
+
+stdinF = sIO GetStdinSocket $ \ (Socket s) -> receiverF s
+
+{-
+outputK chan =
+    let f msg =
+            case msg of
+              High s -> [Low (DoIO (AppendChan chan s))]
+              _ -> []
+    in  concmapSP f
+-}
+
+outputK chan =
+  getK $ message (const $ outputK chan) $ \ s ->
+  appendChanK chan s $
+  outputK chan
+
+appendChanK chan s = hIOSucc (AppendChan chan s)
+
+appendStdoutK s = appendChanK stdout s
+appendStderrK s = appendChanK stderr s
+echoK         s = appendStdoutK (s ++ "\n")
+echoStderrK   s = appendStderrK (s ++ "\n")
+
+linesSP = lnSP []
+  where
+    lnSP acc =
+      getSP $ \msg ->
+      case msg of
+        '\n' -> putSP (reverse acc) (lnSP [])
+	c    -> lnSP (c : acc)
+
+inputLinesSP = linesSP `serCompSP` concatSP -- inefficient!!!
diff --git a/hsrc/io/TimerF.hs b/hsrc/io/TimerF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/TimerF.hs
@@ -0,0 +1,37 @@
+module TimerF(timerF,Tick(..)) where
+import Fudget
+import FudgetIO
+import FRequest
+import Srequest(sIO,sIOsucc,select)
+--import Message(Message(..))
+import NullF
+import Sockets
+--import Xtypes
+import DialogueIO hiding (IOError)
+
+data Tick = Tick deriving (Show,Eq)
+
+--timerF :: F (Maybe (Int,Int)) Tick
+timerF =  f Nothing
+  where
+    f oTno =
+      getMessageFu $ \ msg ->
+      let same = f oTno
+	  settimer int first = case oTno of
+	    Just _ -> same
+	    Nothing ->
+	      sIO (CreateTimer int first) $ \ (Timer tno) ->
+	      -- error handling?!
+	      select [TimerDe tno] $
+	      f (Just tno)
+	  removetimer = case oTno of
+		Just tno -> sIOsucc (DestroyTimer tno) $
+			    select [] $
+			    f Nothing
+		Nothing -> same
+      in case msg of
+	   High (Just (interval, first)) -> settimer interval first
+	   High Nothing -> removetimer
+	   Low (DResp (AsyncInput (_, TimerAlarm))) ->
+	     putHigh Tick $
+	     same
diff --git a/hsrc/io/Transceivers.hs b/hsrc/io/Transceivers.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/Transceivers.hs
@@ -0,0 +1,13 @@
+module Transceivers where
+import Socketio
+import AsyncTransmitter
+import CompOps((>==<),(>=^^<))
+import Spops(nullSP)
+
+transmitterF s = closerF s >==< transmitterF' s
+
+receiverF s = receiverF' s >=^^< nullSP
+
+transceiverF s = receiverF' s >==< transmitterF' s
+
+asyncTransceiverF s = receiverF' s >==< asyncTransmitterF' s
diff --git a/hsrc/io/UnsafeGetDLValue.hs b/hsrc/io/UnsafeGetDLValue.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/UnsafeGetDLValue.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE CPP #-}
+module UnsafeGetDLValue where
+import DLValue
+
+--unsafeDLValue :: DLValue -> anytype
+#if defined(__NHC__) || defined(__PFE__)
+unsafeGetDLValue DLValue = error "unsafeGetDLValue not implemented yet"
+#else
+unsafeGetDLValue (DLValue v) = v
+#endif
+
+-- This is unsafe, because the response from DLSym contains a DLValue of
+-- a particular type. unsafeGetDLValue allows it to be used at any type.
diff --git a/hsrc/io/WriteFile.hs b/hsrc/io/WriteFile.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/io/WriteFile.hs
@@ -0,0 +1,18 @@
+module WriteFile where
+import HaskellIO(haskellIOF)
+--import CompOps((>^=<))
+import Cont(contMap)
+--import NullF
+import DialogueIO hiding (IOError)
+
+writeFileF = writeFileF' WriteFile
+writeXdgFileF = writeFileF' . WriteXdgFile
+
+writeFileF' write = contMap wr
+    where
+      wr (file,contents) cont =
+        haskellIOF (write file contents) $ \ resp ->
+	cont (file,post resp)
+
+      post (Failure e) = Left e
+      post Success = Right ()
diff --git a/hsrc/kernelutils/BgF.hs b/hsrc/kernelutils/BgF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/BgF.hs
@@ -0,0 +1,21 @@
+module BgF(changeBackPixel, changeGetBackPixel) where
+--import Color
+import Command
+--import Fudget
+--import FudgetIO
+--import Message(Message(..))
+import Xcommand
+--import NullF
+import Xtypes
+--import HaskellIO
+import GCAttrs
+
+--changeGetBackPixel :: ColorName -> Cont (K a b) Pixel
+changeGetBackPixel bgcol f =
+    --allocNamedColorDefPixel defaultColormap bgcol "white" $ \bgp ->
+    convColorK [colorSpec bgcol,colorSpec "white"] $ \ bgp ->
+    xcommandK (ChangeWindowAttributes [CWBackPixel bgp]) $
+    xcommandK clearWindowExpose $
+    f bgp
+
+changeBackPixel bgcol = changeGetBackPixel bgcol . const
diff --git a/hsrc/kernelutils/GetVisual.hs b/hsrc/kernelutils/GetVisual.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/GetVisual.hs
@@ -0,0 +1,9 @@
+module GetVisual where
+import Command(XRequest(..))
+import Event(XResponse(..))
+import Xrequest(xrequest)
+
+defaultVisual cont = xrequest DefaultVisual gotit cont
+  where gotit (GotVisual v) = Just v
+        gotit _ = Nothing
+
diff --git a/hsrc/kernelutils/GetWindowProperty.hs b/hsrc/kernelutils/GetWindowProperty.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/GetWindowProperty.hs
@@ -0,0 +1,19 @@
+module GetWindowProperty(getWindowPropertyK,getGeometryK) where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+--import Path(Path(..))
+import Xrequest
+--import Xtypes
+
+getWindowPropertyK offset prop delete req_type =
+    let gotit (GotWindowProperty typ format nitems after str) =
+            Just (typ, format, nitems, after, str)
+        gotit _ = Nothing
+    in  xrequestK (GetWindowProperty offset prop delete req_type) gotit
+
+getGeometryK = xrequestK GetGeometry
+   (\r -> case r of GotGeometry r bw d -> Just (r,bw,d); _ -> Nothing)
diff --git a/hsrc/kernelutils/GreyBgF.hs b/hsrc/kernelutils/GreyBgF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/GreyBgF.hs
@@ -0,0 +1,85 @@
+module GreyBgF(changeBg, darkGreyBgK, lightGreyBgK, greyBgK, knobBgK, changeBackPixmap) where
+import BgF(changeBackPixel)
+import Color
+import Command
+import XDraw
+--import Event(XEvent,BitmapReturn)
+import Fudget
+--import FudgetIO
+import Xcommand
+import Gc
+import Geometry(Rect(..), lL, pP)
+--import LayoutRequest(LayoutRequest)
+--import Message(Message(..))
+--import NullF
+import Pixmap
+import Cont(tryM)
+import Xtypes
+import GCAttrs(convColorK) -- + instances
+
+--changeBackPixmap :: ColorName -> ColorName -> Size -> [DrawCommand] -> (K a b) -> K a b
+changeBackPixmap fgcol bgcol size draw f =
+    convColorK fgcol $ \fg ->
+    convColorK bgcol $ \bg ->
+    changeBackPixmapCol fg bg size draw f
+
+changeBackPixmapCol fg bg size draw f =
+    createPixmap size copyFromParent $ \pm ->
+    wCreateGC rootGC [{-GCFunction GXcopy,-}
+                      GCForeground fg, GCBackground bg,
+		      GCGraphicsExposures False] $ \gc ->
+    wCreateGC gc [GCForeground bg] $ \gcbg ->
+    xcommandsK [DrawMany (Pixmap pm)
+                  [(gcbg,[FillRectangle (Rect (pP 0 0) size)]),
+		   (gc, draw)],
+		ChangeWindowAttributes [CWBackPixmap pm],
+		clearWindowExpose,
+		FreePixmap pm]
+    f
+
+knobBgK cont =
+    try2 "grey33" "black" $ \ (Color fg _) ->
+    try2 "grey" "white" $ \ (Color bg  _) ->
+    changeBackPixmapCol fg bg (pP 8 8)
+                        [DrawLine (lL 0 0 2 2), DrawLine (lL 4 6 6 4)] cont
+
+dithered50BgK fg bg =
+  changeBackPixmapCol fg bg (pP 2 2) [DrawLine (lL 0 0 1 1)]
+
+dithered25BgK fg bg =
+  changeBackPixmapCol fg bg (pP 2 2) [DrawLine (lL 0 0 0 0)]
+
+dithered75BgK fg bg = dithered25BgK bg fg
+
+trySolidGreyBgK cname dithK cont =
+  alloc3 cname $ \ (Color black b) (Color white w) (Color gray g) ->
+  if g==b || g==w
+  then dithK white black cont
+  else xcommandsK [ChangeWindowAttributes [CWBackPixel gray],
+                   clearWindowExpose] $
+       cont
+
+greyBgK = trySolidGreyBgK "grey" dithered50BgK
+darkGreyBgK = trySolidGreyBgK "dark grey" dithered25BgK
+lightGreyBgK = trySolidGreyBgK "light grey" dithered75BgK
+
+changeBg :: ColorName -> (K a b) -> K a b
+changeBg bg =
+  case bg of
+    "Nothing" -> id
+    "grey" -> greyBgK
+    _ -> changeBackPixel bg
+
+alloc3 colorname cont =
+    allocNamedColor defaultColormap "black" $ \black ->
+    allocNamedColor defaultColormap "white" $ \white ->
+    tryAllocNamedColor defaultColormap colorname $ \ ocolor ->
+    let color = case ocolor of
+	         Nothing -> black
+		 Just c -> c in
+    cont black white color
+    
+try2 cname1 cname2 cont =
+  tryM (tryAllocNamedColor defaultColormap cname1)
+       (allocNamedColor defaultColormap cname2 cont)
+       cont
diff --git a/hsrc/kernelutils/InternAtom.hs b/hsrc/kernelutils/InternAtom.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/InternAtom.hs
@@ -0,0 +1,35 @@
+module InternAtom(internAtomK, internAtomF, internAtom,
+                  atomNameK, atomNameF, atomName) where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+import Xrequest
+--import Xtypes
+
+internAtomK = ia xrequestK
+
+internAtomF = ia xrequestF
+
+internAtom a e = ia xrequest a e
+
+ia k atomNm ifExists =
+    let gotit (GotAtom atom) = Just atom
+        gotit _ = Nothing
+    in  k (InternAtom atomNm ifExists) gotit
+
+atomNameK = an xrequestK
+
+atomNameF = an xrequestF
+
+atomName a = an xrequest a
+
+-- Here we need a Maybe String, so add an extra Just (the inner Just
+-- is stripped by the fudlogue).
+
+an k atom = 
+    let gotit (GotAtomName (Just s)) = Just (Just s)
+        gotit _ = Nothing
+    in  k (GetAtomName atom) gotit
diff --git a/hsrc/kernelutils/KernelUtils.hs b/hsrc/kernelutils/KernelUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/KernelUtils.hs
@@ -0,0 +1,14 @@
+module KernelUtils (-- * Kernel utilities
+  module BgF,module GetWindowProperty,module GreyBgF,module InternAtom,module ParK,module QueryPointer,module QuitK,module ShapeK,module SimpleF,module QueryTree,module GetVisual,module MapstateK) where
+import BgF
+import GetWindowProperty
+import GreyBgF
+import InternAtom
+import ParK
+import QueryPointer
+import QuitK
+import ShapeK
+import SimpleF
+import QueryTree
+import GetVisual
+import MapstateK
diff --git a/hsrc/kernelutils/MapstateK.hs b/hsrc/kernelutils/MapstateK.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/MapstateK.hs
@@ -0,0 +1,5 @@
+module MapstateK where
+import Fudget
+import Spops(mapstateSP)
+
+mapstateK f s = K $ mapstateSP f s
diff --git a/hsrc/kernelutils/ParK.hs b/hsrc/kernelutils/ParK.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/ParK.hs
@@ -0,0 +1,52 @@
+module ParK(parK,compK) where
+--import Command(Command(..))
+import CompSP
+--import Event(Event(..))
+import Fudget
+--import Message(Message(..))
+--import Path(Path(..))
+--import SP
+import Spops
+import IsRequest
+import CompFfun
+import SpEither
+
+
+parK :: K a b -> K a b -> K a b
+parK (K l) (K r) = K{-kk-} (parKSP l r)
+
+parKSP :: KSP a b -> KSP a b -> KSP a b
+parKSP l r = pkp [] (l `compEitherSP` r) where
+   pkp routeq k = pk routeq (pullSP k)
+   pk routeq (os,k) = pos os where
+      pos os =
+        case os of
+         [] ->
+	   getSP $ \msg ->
+	   case msg of
+	    Low e | isResponse e ->
+	      case routeq of
+	        [] -> pos [] -- response without request?
+		r:routeq -> feed routeq [r msg]
+            _ -> feedr [Left msg, Right msg]
+           where feed routeq l = pkp routeq (startupSP l k)
+		 feedr = feed routeq
+	 o:os -> case o of
+		   Right (High a) -> out (High a)
+		   Left (High a) -> out (High a)
+		   Right (Low c) -> lowout c Right
+		   Left (Low c) -> lowout c Left
+           where
+             lowout c route =
+	       putSP (Low c) $ 
+	       if isRequest c
+	       then pk (routeq++[route]) (os,k)
+	       else pos os
+             out m = putSP m $ pos os
+
+compK :: K a b -> K c d -> K (Either a c) (Either b d)
+compK (K l) (K r) = K{-kk-} (compKSP l r)
+
+compKSP :: KSP a b -> KSP c d -> KSP (Either a c) (Either b d)
+compKSP l r = parKSP (Left `postMapHigh'` l `preProcessHigh'` filterLeftSP)
+		     (Right `postMapHigh'` r `preProcessHigh'` filterRightSP)
diff --git a/hsrc/kernelutils/QueryPointer.hs b/hsrc/kernelutils/QueryPointer.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/QueryPointer.hs
@@ -0,0 +1,15 @@
+module QueryPointer(queryPointerK) where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+import Xrequest
+--import Xtypes
+
+queryPointerK =
+    let f (PointerQueried s r w m) = Just (s, r, w, m)
+        f _ = Nothing
+    in  xrequestK QueryPointer f
+
diff --git a/hsrc/kernelutils/QueryTree.hs b/hsrc/kernelutils/QueryTree.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/QueryTree.hs
@@ -0,0 +1,45 @@
+module QueryTree where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+--import Path(Path(..))
+import Xrequest
+--import Xtypes
+
+queryTreeK = 
+    xrequestK QueryTree gotit
+  where
+    gotit (TreeQueried r p cs) = Just (r,p,cs)
+    gotit _ = Nothing
+
+queryTreeF = 
+    xrequestF QueryTree gotit
+  where
+    gotit (TreeQueried r p cs) = Just (r,p,cs)
+    gotit _ = Nothing
+
+{-
+(defaultRootWindowK,defaultRootWindowF) =
+    (xrequestK DefaultRootWindow gotit,xrequestF DefaultRootWindow gotit)
+  where
+    gotit (GotDefaultRootWindow w) = Just w
+    gotit _ = Nothing
+
+Doesn't work???
+-}
+
+defaultRootWindowK = 
+    xrequestK DefaultRootWindow gotit
+  where
+    gotit (GotDefaultRootWindow w) = Just w
+    gotit _ = Nothing
+
+defaultRootWindowF = 
+    xrequestF DefaultRootWindow gotit
+  where
+    gotit (GotDefaultRootWindow w) = Just w
+    gotit _ = Nothing
+
diff --git a/hsrc/kernelutils/QuitK.hs b/hsrc/kernelutils/QuitK.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/QuitK.hs
@@ -0,0 +1,61 @@
+module QuitK where
+import Command
+import Event
+import Fudget
+--import FudgetIO
+import FRequest
+import Xcommand
+import HaskellIO(haskellIO)
+import InternAtom
+--import Message(Message(..))
+import NullF
+import Spops(nullSP)
+import CompFfun(postProcessHighK,preProcessHighK)
+--import Sockets
+import Xtypes
+import DialogueIO hiding (IOError)
+
+quitK action =
+   nullSP `postProcessHighK`
+   wmK (Just action)
+   `preProcessHighK` nullSP
+
+-- (*) wmK always enables the WM_DELETE_WINDOW protocol, since some window
+-- managers provide a close button that destroy the window if the protocol
+-- is disabled. Sigh.
+
+wmK optAction =
+    wmDeleteWindowK $ \dw -> -- (*)
+    case optAction of
+      Just action ->
+        -- wmDeleteWindowK $ \dw -> -- (*)
+    	internAtomK "WM_PROTOCOLS" False $ \ pr ->
+    	wmK' (lowHandler action pr dw)
+      Nothing -> wmK' (const id)
+  where
+    lowHandler action pr dw event =
+      case event of
+	XEvt (ClientMessage a (Long (p : _))) | a == pr && Atom (fromIntegral p) == dw ->
+	  action 
+        _ -> id
+
+    wmK' lowHandler = loop
+      where
+	loop =
+	  getK $ \msg ->
+	  case msg of
+	    Low event -> lowHandler event loop
+	    High (Left title) -> xcommandK (StoreName title) loop
+	    High (Right True) -> xcommandK MapRaised loop
+	    High (Right False) -> unmapWindowK loop
+	    _ -> loop
+
+-- Some handlers:
+exitK cont = haskellIO (Exit 0) (const nullK)
+unmapWindowK = xcommandK UnmapWindow
+reportK = putK (High ())
+
+wmDeleteWindowK cont =
+    internAtomK "WM_DELETE_WINDOW" False $ \dw ->
+    xcommandK (SetWMProtocols [dw]) $
+    cont dw
diff --git a/hsrc/kernelutils/ShapeK.hs b/hsrc/kernelutils/ShapeK.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/ShapeK.hs
@@ -0,0 +1,55 @@
+module ShapeK(dynShapeK, shapeK) where
+import Command(XCommand(FreeGC,FreePixmap,ShapeCombineMask,DrawMany))
+import XDraw
+import CompFfun(prepostMapHigh')
+import Convgc
+--import Event
+import LayoutRequest(LayoutResponse(..))
+import FRequest
+import Gc
+import Fudget
+--import FudgetIO
+import Xcommand
+import NullF
+import ParK
+import Pixmap
+import EitherUtils(stripEither)
+import Data.Maybe(fromJust)
+import Geometry(pP,Rect(..),origin,Size)
+import Xtypes
+
+dynShapeK gcattrs shapeCmds f = compK (shapeK1 gcattrs shapeCmds) f
+
+shapeK :: (Size -> [DrawCommand]) -> K a b -> K a b
+shapeK shapeCmds f =
+    K{-kk-} (prepostMapHigh' Right stripEither dk)
+  where
+    K dk = dynShapeK [] shapeCmds f
+
+shapeK1 gcattrs shape =
+    convGCattrsK gcattrs (\gcattrs' -> shapeP gcattrs' shape Nothing)
+
+shapeP gcattrs shape size =
+    let reshape shape' size' =
+          createPixmap size' 1 $ \pm ->
+	  pmCreateGC pm rootGC [GCFunction GXcopy, GCForeground pixel0] $ \gcclr ->
+	  pmCreateGC pm gcclr (GCForeground pixel1 :
+                               GCBackground pixel0 :
+                               gcattrs) $ \gc ->
+	  xcommandsK [drawshape pm size' shape' gc gcclr,
+	              ShapeCombineMask ShapeBounding (pP 0 0) pm ShapeSet,
+		      FreePixmap pm,
+		      FreeGC gcclr,
+		      FreeGC gc] $
+	  shapeP gcattrs shape' (Just size')
+    in getK $ \msg ->
+       case msg of
+         Low (LEvt (LayoutSize size')) -> reshape shape size'
+	 High shape' | size /= Nothing -> reshape shape' (fromJust size)
+	 _ -> shapeP gcattrs shape size
+
+drawshape pm size shapeCmds gc gcclr =
+    DrawMany (Pixmap pm) [
+      (gcclr,[FillRectangle (Rect origin size)]),
+      (gc,shapeCmds size)]
+
diff --git a/hsrc/kernelutils/SimpleF.hs b/hsrc/kernelutils/SimpleF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/kernelutils/SimpleF.hs
@@ -0,0 +1,48 @@
+module SimpleF(Drawer(..), Fms'(..), MapState(..), simpleF, simpleWindowF, simpleK) where
+import Color
+import Command
+import XDraw
+import Dlayout(windowF)
+import DShellF
+--import FDefaults
+--import Event
+import Fudget
+import FudgetIO
+import FRequest
+--import Xcommand
+import Gc
+import Geometry(Size)
+import LayoutRequest
+--import Message(Message(..))
+--import NullF
+--import Spops
+import MapstateK
+import Xtypes
+
+type MapState a b c = a -> b -> (a, c)
+
+type Fms' a b c = MapState a (KEvent b) [KCommand c]
+
+type Drawer = DrawCommand -> FRequest
+
+simpleK k size s0 = simpleK' k size True True s0
+
+simpleK' :: (Drawer->Drawer->Fms' a b c) -> Size -> Bool -> Bool -> a -> K b c
+simpleK' k size fixedh fixedv s0 =
+    allocNamedColorPixel defaultColormap "black" $ \fg ->
+    allocNamedColorPixel defaultColormap "white" $ \bg ->
+    wCreateGC rootGC [GCFunction GXcopy,GCForeground fg,GCBackground bg] $ \fgc ->
+    wCreateGC fgc [GCForeground bg] $ \bgc ->
+    putLow (layoutRequestCmd (plainLayout size fixedh fixedv)) $
+    mapstateK (k (wDraw fgc) (wDraw bgc)) s0
+
+simpleF title k size s0 =
+    shellF title $
+    simpleWindowF k size False False s0
+
+simpleWindowF k size fh fv s0 =
+    windowF [XCmd $ ChangeWindowAttributes [CWEventMask eventmask]] $
+    simpleK' k size fh fv s0
+  where
+    eventmask = [ExposureMask, KeyPressMask, KeyReleaseMask, ButtonPressMask,
+                 ButtonReleaseMask]
diff --git a/hsrc/layout/AlignP.hs b/hsrc/layout/AlignP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/AlignP.hs
@@ -0,0 +1,35 @@
+module AlignP where
+--import Alignment(Alignment(..))
+--import Geometry(Line(..), Point(..), Rect(..), Size(..), padd, psub, rR)
+--import LayoutDir(LayoutDir)
+import LayoutRequest
+import Utils(mapPair, number, swap)
+import HbcUtils(apSnd)
+import List2(sort)
+--import Spacers
+
+-- placer operations
+
+idP :: Placer
+idP = P $ \ [req] -> (req, (: []))
+
+--revP :: Placer -> Placer
+revP = mapP revP'
+  where revP' placer = apSnd (reverse .) . placer . reverse
+
+mapP f (P p) = P (f p)
+
+flipP :: Placer -> Placer
+flipP = mapP flipP'
+  where
+    flipP' placer = mapPair (flipReq,flipP2) . placer . map flipReq
+    flipP2 p2 = map flipRect.p2.flipRect
+
+permuteP :: [Int] -> Placer -> Placer
+permuteP perm = mapP permuteP'
+  where
+    permuteP' placer = apSnd (rpermf .) . placer . fpermf
+    rperm = (map snd . sort . map swap . number 0) perm
+    fpermf = permf perm
+    rpermf = permf rperm
+    permf perm xs = map (xs!!) perm
diff --git a/hsrc/layout/Alignment.hs b/hsrc/layout/Alignment.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Alignment.hs
@@ -0,0 +1,12 @@
+module Alignment where
+
+type Alignment = Double
+
+aTop = 0 :: Alignment
+aBottom = 1 :: Alignment
+
+aLeft = 0 :: Alignment
+aRight = 1 :: Alignment
+
+aCenter = 0.5 :: Alignment
+
diff --git a/hsrc/layout/AutoLayout.hs b/hsrc/layout/AutoLayout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/AutoLayout.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE CPP #-}
+module AutoLayout(autoLayoutF,autoLayoutF',nowait) where
+--import Prelude hiding (IO)
+import LayoutRequest(LayoutMessage(..),LayoutResponse(..),LayoutRequest(minsize),LayoutHint,Spacer,Placer(..),Placer2,unS)
+import LayoutDoNow
+import PathTree hiding (pos)
+import Geometry(Rect)
+import Fudget
+--import Spops
+--import FudgetIO
+import NullF(getK,putK,putsK) --,F,K
+import Loops(loopThroughRightF)
+import UserLayoutF
+--import Xtypes
+--import Event
+--import Command
+import FRequest
+--import Path
+import Direction
+--import Placers
+--import LayoutDir(LayoutDir)
+--import CompOps
+import IoF(ioF)
+import CmdLineEnv(argFlag)
+--import EitherUtils()
+import Data.Maybe(isJust)
+import HbcUtils(apFst,apSnd)
+import Spacers(idS,compS,spacerP)
+import AutoPlacer(autoP)
+import SizingF
+#ifdef __NHC__
+import qualified Sizing
+#else
+import qualified Sizing(Sizing(..))
+#endif
+--import ContinuationIO(stderr)
+
+-- debugging:
+import StdIoUtil(echoStderrK)
+--import NonStdTrace(trace)
+--import Maptrace(ctrace)
+--import SpyF
+
+debugK :: String -> K hi ho -> K hi ho
+debugK =
+    if dbg
+    then \ msg -> echoStderrK ("AutoLayout: "++msg)
+    else const id
+  where
+    dbg = argFlag "ad" False
+
+type LayoutTree = PathTree LayoutInfo
+
+mapLT lf nf = mapPathTree (mapLayoutInfo lf nf)
+
+top0 = Node (NodeInfo (Just "top",NoPlacerInfo)) Tip Tip
+
+data LayoutInfo
+  = NodeInfo NodeInfo
+  | LeafInfo LeafInfo -- only in leaves
+  deriving (Show)
+
+mapLayoutInfo lf nf n = case n of
+     NodeInfo n -> NodeInfo (nf n)
+     LeafInfo l -> LeafInfo (lf l)
+
+type LeafInfo = (LayoutRequest,Maybe Rect)
+  -- (Layout s fh fv,Nothing) : received layout req, layout not computed
+  -- (Layout s fh fv,Just rect) : rect is current placement.
+
+type NodeInfo = ((Maybe LayoutHint), PlacerInfo)
+
+data PlacerInfo =
+   NoPlacerInfo |
+   JustSpacer Spacer |
+   SpacerPlacer Spacer Placer (Maybe Placer2) Spacer 
+  deriving (Show)
+
+data PlacementState
+  = Placed (Rect->Rect)
+  | Waiting 
+  deriving (Show)
+
+autoLayoutF = autoLayoutF' nowait Sizing.Dynamic
+
+nowait = argFlag "nowait" False
+
+autoLayoutF' :: Bool -> Sizing.Sizing -> F a b -> F a b
+autoLayoutF' nowait sizing fud =
+    loopThroughRightF 
+      (userLayoutF (layoutDoNow fud)) 
+      ({- spyF -} (sizingF sizing (ioF (autoLayoutMgrK0 state0 top0))))
+	-- Note that the sizingF filter is not wrapped around fud and hence
+	-- does not have to examine all commands and events!
+  where
+    state0 = if nowait then Placed id else Waiting
+
+autoLayoutMgrK0 pstate ltree =
+  debugK "autoLayoutMgrK" $
+  autoLayoutMgrK pstate ltree
+
+autoLayoutMgrK pstate ltree =
+    --echoK (show (pstate,ltree)) $
+    getK $ \ msg ->
+    case msg of
+      High (path,layoutmsg) ->
+        case layoutmsg of
+	  LayoutDoNow ->
+	    debugK "LayoutDoNow" $
+	    debugK (show ltree) $
+	    newPlace ltree
+	  LayoutRequest req ->
+	       debugK (show path ++ " Layout "++show (minsize req)) $
+	       debugK (show ltree') $
+	       changePlacement ltree'
+	    where ltree' = updateLeaf path req ltree''
+	          ltree'' = if newBox ltree path
+		            then forgetPlaces ltree
+			    else ltree
+	  -- LayoutHint & LayoutPlacer are only sent during initialisation.
+	  -- They will be received before any child Layout requests.
+	  LayoutHint hint ->
+	    debugK (show path ++ " LayoutHint "++ show hint) $
+	    updnode (insertHint hint)
+	  LayoutPlacer placer ->
+	    debugK (show path ++ " LayoutPlacer ...") $
+	    updnode (insertPlacer placer)
+	  LayoutSpacer spacer ->
+	    debugK (show path ++ " LayoutSpacer ...") $
+	    updnode (insertSpacer spacer)
+	  -- LayoutReplaceSpacer is sent by dynSpacerF.
+	  LayoutReplaceSpacer spacer ->
+	    debugK (show path ++ " LayoutReplaceSpacer ...") $
+	    replnode (replaceSpacer spacer)
+	  LayoutReplacePlacer placer ->
+	    debugK (show path ++ " LayoutReplacePlacer ...") $
+	    replnode (replacePlacer placer)
+	  LayoutDestroy -> 
+	    debugK (show (path,ltree) ++ " LayoutDestroy") $
+	    -- should check if the subtree contains anything but hints.
+	    if newBox ltree path then debugK ("not in tree") same else
+	    changePlacement (forgetPlaces (pruneLTree path ltree))
+	      -- !! forgetPlaces should be called when the structure changes,
+	      -- but not when an existing fudget requests a new size...
+	  LayoutMakeVisible _ _ -> putK (Low (LCmd layoutmsg)) $ same
+	  LayoutScrollStep  _ -> putK (Low (LCmd layoutmsg)) $ same
+	  _ -> same -- !!! handle other layout requests?!
+        where updnode  u = newTree (updateLNode path u ltree)
+	      replnode u = changePlacement (forgetPlaces (updateLNode path u ltree))
+      Low (LEvt (LayoutPlace rect)) ->
+          debugK ("splitting 1 Place into "++show (length msgs)) $
+          putsK (map High msgs) $
+	  newTree ltree'
+	where (ltree',msgs) = doLayout (s2 rect) ltree
+	      s2 = case pstate of
+			Placed s2 -> s2
+			_ -> id
+      Low _ -> debugK "Ignored low level msg" same
+  where
+    same = autoLayoutMgrK pstate ltree
+    newTree t' = newState pstate t'
+    newState p' t' = autoLayoutMgrK p' t'
+    changePlacement ltree' =
+      case pstate of
+        Placed _ -> newPlace ltree'
+	Waiting -> newTree ltree'
+    newPlace ltree =
+      let ltree' = chooseLayout ltree
+      in case collectReqs ltree' of
+           ([],_) -> debugK "newPlace without any requests in ltree" same
+	   ((req,s2):_,ltree2) ->
+	     putK (Low (layoutRequestCmd req)) $
+	     newState (Placed s2) ltree2
+
+updateLNode path i t = updateNode id emptyNode t path $
+     \(NodeInfo ni) -> NodeInfo (i ni)
+
+insertHint hint (_,pi) = (case pi of
+	   SpacerPlacer _ _ _ _ -> Nothing
+	   _ -> Just hint,pi)
+
+insertPlacer placer (hint,pi) = (Nothing,case pi of
+   NoPlacerInfo -> SpacerPlacer idS placer Nothing idS
+   JustSpacer s -> SpacerPlacer s placer Nothing idS
+   SpacerPlacer s1 p _ s2 -> SpacerPlacer (s1 `compS` s2) (p `compP` placer)
+			           Nothing idS)
+     where compP :: Placer -> Placer -> Placer
+	   compP (P p1) (P p2) = P $ \ reqs ->
+	       let (req1,p1r) = p1 [req2]
+	           (req2,p2r) = p2 reqs
+	       in (req1,p2r.head.p1r)
+
+insertSpacer spacer (hint,pi) = (hint,case pi of
+   NoPlacerInfo -> JustSpacer spacer
+   JustSpacer s -> JustSpacer (s `compS` spacer)
+   SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 p p2 (s2 `compS` spacer))
+
+replaceSpacer spacer (hint,pi) = (hint,pi')
+  where
+    pi' = case pi of
+            NoPlacerInfo -> JustSpacer spacer
+	    JustSpacer s -> JustSpacer spacer
+	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer spacer p p2 s2 -- hmm
+
+replacePlacer placer (hint,pi) = (hint,pi')
+  where
+    pi' = case pi of
+            NoPlacerInfo -> SpacerPlacer idS placer Nothing idS
+	    JustSpacer s -> SpacerPlacer s placer Nothing idS
+	    SpacerPlacer s1 p p2 s2 -> SpacerPlacer s1 placer Nothing s2
+
+updateLeaf path l t =
+  updateNode invalid emptyNode t path (const (LeafInfo (l,Nothing)))
+
+pruneLTree path t = pruneTree invalid emptyNode t path
+
+forgetPlaces = mapLT (apSnd (const Nothing)) id
+ 
+newBox x = subTree (const False) True x
+
+invalid (NodeInfo i) = NodeInfo (invalid' i)
+  where
+    invalid' (hi,SpacerPlacer s p p2 s2) = (hi,SpacerPlacer s p Nothing s2)
+    invalid' ni = ni
+
+emptyNode = NodeInfo (Nothing,NoPlacerInfo)
+
+hasPlacer (Nothing,SpacerPlacer _ _ _ _) = True
+hasPlacer _ = False
+
+-- strip hints below placer, insert autoP where there are hints left
+chooseLayout = snd . attrMapLT lf nf False where
+  lf strip _ i = (strip,(),i)
+  nf strip _ n = (strip',(),n') where
+     strip' = case n of
+	    (Nothing,SpacerPlacer _ _ _ _) -> True
+	    _ -> strip --
+     n' = if strip then n else choosePlacer n
+
+choosePlacer i = case i of
+   (hi@(Just _),pi) -> (hi,case pi of
+     NoPlacerInfo -> SpacerPlacer idS autoP Nothing idS
+     JustSpacer s -> SpacerPlacer s autoP Nothing idS
+     p -> p)
+   i -> i
+
+attrMapLT lf nf = attrMapPathTree f where
+   f i s a = case a of
+     LeafInfo li -> a3 LeafInfo $ lf i s li
+     NodeInfo ni -> a3 NodeInfo $ nf i s ni
+   a3 c (i,s,b) = (i,s,c b)
+
+collectReqs = apFst (flip compose []) . attrMapLT lf nf idS where
+  lf s _ i@(req,oplace) = (s,reqf,i) where 
+       reqf = (unS s lr:)
+       lr = case oplace of
+{- -- You can use static sizing of shell windows instead of this:
+	      Just (Rect _ currentsize) ->
+		-- use current size, not originally requested size
+		--ctrace "spacer" ("current",i) $
+		mapLayoutSize (const currentsize) req
+-}
+	      _ -> --ctrace "spacer" ("nocurrent",i)
+	           req
+  nf s reqfs n@(hi,pi) = case pi of
+       NoPlacerInfo -> (s,reqf,n)
+       JustSpacer s1 ->
+	 --ctrace "spacer" (fst ((s `compS` s1) (Layout origin False False))) $
+	 (s `compS` s1,reqf,n)
+       SpacerPlacer s1 p orp2 s2 ->
+	  --ctrace "spacer" (n,fst (compp $ [Layout origin False False])) $ 
+	             (inherS,syntreq,n') where
+		   rp2@(req2,p2) = compp `spacer2P` reqfl
+		   reqfl = reqf []
+		   compp = if hashint then p else sl `spacerP` p
+		   inherS = if hashint then sl `compS` s2 else s2
+		   syntreq = if null reqfl then id else (unS idS req2:)
+		   sl = s `compS` s1
+		   hashint = isJust hi
+		   orp2' = if null reqfl then Nothing else Just rp2
+		   n' = (hi,SpacerPlacer s1 p orp2' s2)
+--	  Just (req,_) -> ctrace "spacer" (n,req) (s2,(idS req:),n)
+    where reqf = compose reqfs
+
+  compose = foldr (.) id
+
+doLayout rect tree = runIO (doLayoutIO tree []) [rect]
+
+spacer2P (P p) reqfs = (req,s2f.p2) where
+   (reqs,s2s) = unzip reqfs
+   s2f rs = [s2 r | (s2,r) <- zip s2s rs]
+   (req,p2) = p reqs
+
+doLayoutIO t path =
+  case t of
+    Tip -> returnIO t
+    Node (LeafInfo (l,maybeOldRect)) _ _ ->
+      getIO `bindIO` \ r ->
+      putIO (reverse path,r) `thenIO` 
+         -- check if r is different from old rect?
+      returnIO (Node (LeafInfo (l,Just r)) Tip Tip)
+    Dynamic dt -> returnIO Dynamic `ap` dynDoLayoutIO dt path 0 1
+    Node ni@(NodeInfo (_,pi)) lt rt ->
+	case pi of
+	  SpacerPlacer s1 p orp2  s2 ->
+	    case orp2 of
+	      Just (req,placer2) ->
+		   getIO `bindIO` \ r ->
+		   ungetIO (placer2 r) `thenIO`
+		   doBranches
+	      Nothing -> returnIO t -- no requests in this tree
+	  _ -> doBranches
+      where
+        doBranches =
+	  returnIO (Node ni) `ap` doLayoutIO lt (L:path)
+	                      `ap` doLayoutIO rt (R:path)
+
+
+dynDoLayoutIO dt path n i =
+  case dt of
+    DynTip -> returnIO dt
+    DynNode t lt rt ->
+      returnIO DynNode `ap`
+      doLayoutIO t (Dno (unpos n):path) `ap`
+      dynDoLayoutIO lt path n (2*i) `ap`
+      dynDoLayoutIO rt path (n+i) (2*i)
+
+--
+
+type IO' a i o = i -> o -> (a,(i,o))
+
+runIO io i =
+  let (a,(_,o)) = io i []
+  in (a,o)
+
+returnIO a i o = (a,(i,o))
+putIO o1 is os = ((),(is,o1:os))
+getIO (i:is) os  = (i, (is,os))
+--getIO (i:is) os  = (Just i, (is,os))
+--getIO []     os  = (Nothing,(is,os))
+ungetIO is' is os = ((),(is'++is,os))
+
+bindIO io1 xio2 i0 o0  =
+  let (x,(i1,o2)) = io1 i0 o1
+      (y,(i2,o1)) = xio2 x i1 o0
+  in (y,(i2,o2))
+
+thenIO f1 f2 = f1 `bindIO` const f2
+
+fIO `ap` xIO = fIO `bindIO` \ f ->
+               xIO `bindIO` \ x ->
+	       returnIO (f x)
diff --git a/hsrc/layout/AutoPlacer.hs b/hsrc/layout/AutoPlacer.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/AutoPlacer.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE CPP #-}
+module AutoPlacer(autoP,autoP') where
+import LayoutRequest
+import Geometry
+import Placers(horizontalP',verticalP')
+import Spacers() -- synonym Distance, for hbc
+import AlignP(idP)
+--import LayoutDir
+import CmdLineEnv(argFlag)
+import Defaults(defaultSep)
+import Data.Ratio
+import Debug.Trace(trace)
+
+-- should get hints somehow
+autoP = autoP' defaultSep
+
+autoP' :: Size -> Placer
+autoP' (Point hsep vsep) = P $ \ requests ->
+ case requests of
+   [] -> trace "autoP []" $ (plainLayout 1 True True, \ r -> [])
+   [r] -> unP idP requests
+   _ -> p where
+        h2@(h,_) = unP (horizontalP' hsep) requests
+	v2@(v,_) = unP (verticalP' vsep) requests
+	p = if goodness h2 requests<goodness v2 requests
+            then h2 else v2
+
+{-
+--godness : measure how good a layout is.
+-- 1st: a layout is better if it uses less screen space.
+-- 2nd: a layout is better if it is more quadratic 
+-- (rather than long and narrow)
+goodness (Layout {minsize=Point x y}) = (x*y,x+y)
+                                 -- (area, circumference of rect / 2)
+-- This doesn't work, because of separation between fudgets...
+-}
+
+goodness =
+  if argFlag "sg" False
+  then \ p1 rs -> (1%1,simpleGoodness (fst p1))
+  else newGoodness
+
+simpleGoodness (Layout {minsize=Point w h}) = w+h
+
+#if 1
+-- normal version
+newGoodness (Layout {minsize=s@(Point w h)},placer2) reqs =
+    (wasted % (w*h),w+h)
+  where
+    wasted = sum (zipWith waste reqs (placer2 (Rect origin s)))
+    waste (Layout {minsize=Point rw rh,fixedh=fh,fixedv=fv}) (Rect _ (Point aw ah)) =
+      case (fh,fv) of
+        (True,True) -> aw*ah-rw*rh
+	(False,False) -> 0
+	(True,False) -> (aw-rw)*ah
+	(False,True) -> (ah-rh)*aw
+#else
+-- Röjemo's debug version
+-- needs updating
+newGoodness (Layout {minsize=s@(Point w h)},placer2) reqs =
+     trace ("w = " ++ show w ++ "\n"
+         ++ "h = " ++ show h ++ "\n"
+         ++ "wlist = " ++ show wlist ++ "\n"
+         ++ "wasted = " ++ show wasted ++ "\n"
+         ++ "w*h = " ++ show (w*h) ++ "\n"
+         ++ "(wasted % (w*h),w+h) = " ++ show     (wasted % (w*h),w+h) ++ "\n")
+    (wasted % (w*h),w+h)
+  where
+    wlist =  (zipWith waste reqs (placer2 (Rect origin s)))
+    wasted = sum wlist
+    waste (Layout (Point rw rh) fh fv) (Rect _ (Point aw ah)) =
+      case (fh,fv) of
+        (True,True) ->    trace ("aw*ah-rw*rh = " ++ show aw ++ '*':show ah ++ '-':show rw ++ '*':show rh ++ "\n") $ aw*ah-rw*rh
+        (False,False) ->  trace ("0\n")  0
+        (True,False) ->   trace ("(aw-rw)*ah = (" ++ show aw ++ '-':show rw ++ ")*" ++ show ah ++ "\n") $ (aw-rw)*ah
+        (False,True) ->   trace ("(ah-rh)*aw = (" ++ show ah ++ '-':show rh ++ ")*" ++ show aw ++ "\n") $ (ah-rh)*aw
+#endif
diff --git a/hsrc/layout/CondLayout.hs b/hsrc/layout/CondLayout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/CondLayout.hs
@@ -0,0 +1,32 @@
+module CondLayout(ifSizeP,ifSizeS,stretchCaseS,alignFixedS,alignFixedS') where
+import LayoutRequest
+--import Geometry(Size)
+import Spacers(idS,hAlignS,vAlignS,hvAlignS,compS,noStretchS)
+
+--ifSizeP :: (Size->Size->Bool) -> Placer -> Placer -> Placer
+--ifSizeS :: (Size->Size->Bool) -> Spacer -> Spacer -> Spacer
+ifSizeP b (P p1) (P p2) = P $ ifSize b p1 p2
+ifSizeS b (S s1) (S s2) = S $ ifSize b s1 s2
+
+ifSize p primP spareP reqs =
+    if p primSize spareSize
+    then primP2
+    else spareP2
+  where
+    primP2@(Layout {minsize=primSize},_) = primP reqs
+    spareP2@(Layout {minsize=spareSize},_) = spareP reqs
+
+stretchCaseS :: ((Bool,Bool)->Spacer) -> Spacer
+stretchCaseS sS = S $ \ req -> unS (sS (fixedh req,fixedv req)) req
+
+alignFixedS ha va =
+  stretchCaseS $ \ fixedhv ->
+  case fixedhv of
+    (False,False) -> idS
+    (True, False) -> hAlignS ha
+    (False,True)  -> vAlignS va
+    (True, True)  -> hvAlignS ha va
+
+alignFixedS' ha va =
+  stretchCaseS $ \ fhv ->
+   uncurry noStretchS fhv `compS` alignFixedS ha va
diff --git a/hsrc/layout/DynListLF.hs b/hsrc/layout/DynListLF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/DynListLF.hs
@@ -0,0 +1,34 @@
+module DynListLF(dynListLF) where
+import Fudget
+import CompOps((>+<))
+import DynListF
+import Dynforkmerge(DynMsg(..))
+import Loops(loopThroughRightF)
+import SerCompF(concatMapF)
+import UserLayoutF
+--import Geometry
+import LayoutRequest
+import LayoutSP(dynLayoutMgrF)
+import LayoutF(LayoutDirection(..))
+
+dynListLF :: Placer -> F (Int, DynFMsg a b) (Int, b)
+dynListLF lter =
+  loopThroughRightF
+    (concatMapF ctrl) (dynLayoutMgrF 0 Forward lter>+<userLayoutF dynListF)
+
+ctrl msg =
+  case msg of
+    Right dyn@(i,dynmsg) ->
+      case dynmsg of
+        DynCreate _ -> [toMgrDyn (i,True),toDyn dyn]
+	DynDestroy -> [toMgrDyn (i,False),toDyn dyn]
+	DynMsg _ -> [toDyn dyn]
+    Left (Left pp) -> [toDynL pp]
+    Left (Right (Left ll)) -> [toMgr ll]
+    Left (Right (Right x)) -> [out x]
+
+toDyn=Left. Right. Right
+toDynL=Left. Right. Left
+toMgr=Left. Left. Left
+toMgrDyn=Left. Left. Right
+out=Right
diff --git a/hsrc/layout/DynSpacerF.hs b/hsrc/layout/DynSpacerF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/DynSpacerF.hs
@@ -0,0 +1,18 @@
+module DynSpacerF(dynSpacerF,dynPlacerF) where
+import Fudget
+import LayoutRequest
+import SerCompF(idLeftF)
+import CompSP(postMapSP)
+import Path(here)
+import Message
+--import Command
+import FRequest
+
+dynSpacerF = dynLayoutMsgF LayoutReplaceSpacer
+dynPlacerF = dynLayoutMsgF LayoutReplacePlacer
+
+dynLayoutMsgF lmsg fud = F (post `postMapSP` fudsp)
+  where
+    F fudsp = idLeftF fud
+    post = message Low (either sendLmsg High)
+    sendLmsg x = Low (here,LCmd (lmsg x))
diff --git a/hsrc/layout/HorizontalAlignP.hs b/hsrc/layout/HorizontalAlignP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/HorizontalAlignP.hs
@@ -0,0 +1,96 @@
+module HorizontalAlignP where
+import Data.List(mapAccumL)
+import LayoutRequest
+import Geometry
+import Spacers(Distance(..),layoutModifierS,idS)
+import Defaults(defaultSep)
+
+-- Better names:
+alignP = horizontalAlignP
+alignP' = horizontalAlignP'
+
+horizontalAlignP = horizontalAlignP' defaultSep
+
+horizontalAlignP' :: Distance -> Placer
+horizontalAlignP' sep = P haP
+  where
+    haP reqs = (req,placer2)
+      where
+	sepp = pP sep 0
+	req = refpLayout rsize fh fv [ref1,ref2]
+	fh = all fixedh reqs
+	fv = False -- any fixedv reqs
+	reqrects0 = snd $ mapAccumL reqrect (-sepp) reqs
+	  where
+	    reqrect ref0 (Layout {minsize=s,fixedh=fh,fixedv=fv,refpoints=rps}) =
+		(ref2',((Rect d s,(fh,fv)),(d+ref1,ref2')))
+	      where d = ref0-ref1+sepp
+		    ref2' = d+ref2
+		    (ref1,ref2) = case rps of
+				    [] -> middleRefs s
+				    _  -> (head rps,last rps)
+
+	reqrects = map adj reqrects0
+	  where adj ((r,f),(ref1,ref2)) =
+		  ((moverect r (-minp),f),(ref1-minp,ref2-minp))
+		minp = pMin (0:[d | ((Rect d _,_),_) <- reqrects0])
+
+	rsize = pMax (1:[p+s | ((Rect p s,_),_) <- reqrects])
+	(ref1,ref2) =
+	  case reqrects of
+	    [] -> middleRefs rsize
+	    _ -> (fst . snd . head $ reqrects,snd . snd . last $ reqrects)
+
+	placer2 rect@(Rect p asize) = [moverect r d | ((r,_),_)<-reqrects]
+	  where d = p -- + scalePoint 0.5 (pmax 0 (asize-rsize))
+
+--refMiddleS :: Spacer
+refMiddleS = S refMiddleS'
+
+refMiddleS' req =
+ let (ref1,ref2) = middleRefs (minsize req)
+ in (req{refpoints=[ref1,ref2]},id)
+-- in (Layout s fh fv wa ha [ref1,ref2] wanted,id)
+
+--refEdgesS :: Spacer
+refEdgesS = S refEdgesS'
+  where
+    refEdgesS' req@(Layout {refpoints=[]}) = refMiddleS' req
+    refEdgesS' req@(Layout {minsize=Point w _,refpoints=rps}) =
+        (req {refpoints=[ref1,ref2]},id)
+      where
+        ref1 = (head rps){xcoord=0}
+	ref2 = (last rps){xcoord=w}
+
+middleRefs (Point w h) = (pP 0 h2,pP w h2)
+  where h2 = h `div` 2
+
+noRefsS :: Spacer
+noRefsS = S $ \ req -> (req {refpoints=[]},id)
+
+moveRefsS :: Point -> Spacer
+moveRefsS d = layoutModifierS (mapLayoutRefs (d+))
+
+---
+
+spacersP :: Placer -> [Spacer] -> Placer
+spacersP (P placer) spacers = P $ \ reqs ->
+  let
+    (reqs',spacers2) = unzip (zipWith unS (spacers++repeat idS) reqs)
+    (req,placer2) = placer reqs'
+    placer2' = zipWith id spacers2 . placer2
+  in  (req,placer2')
+
+---
+overlayAlignP :: Placer
+overlayAlignP = P $ \ ls ->
+  let maxrp = maximum [head (refpoints l) | l<-ls, not (null (refpoints l))]
+      ss = [f ms rps | Layout { minsize=ms,refpoints=rps}<-ls ]
+	where f s [] = s
+	      f s (rp:_) = s+maxrp-rp
+      req = refpLayout (pMax ss) (any fixedh ls) (any fixedv ls) [maxrp]
+      placer2 r = [f r rps | Layout {refpoints=rps} <- ls]
+	where f r [] = r
+	      f (Rect p s) (rp:_) = Rect (p+d) (s-d)
+		where d=maxrp-rp
+  in (req,placer2)
diff --git a/hsrc/layout/Layout.hs b/hsrc/layout/Layout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Layout.hs
@@ -0,0 +1,29 @@
+module Layout (-- * Layout
+  module AutoLayout,module AlignP,module Alignment,
+ --module Barlayouter,
+ module LayoutDir,module LayoutF,module LayoutRequest,module Placers,module MatrixP,module Layoutspec,module TableP,module TryLayout,module NameLayout,module UserLayoutF,module AutoPlacer,module DynListLF,module Placer,module Spacer,module Spacers,module Placers2,module DynSpacerF,module Sizing,module CondLayout,module HorizontalAlignP,module ParagraphP) where
+import AutoLayout
+import AlignP
+import Alignment
+--import Barlayouter
+import LayoutDir
+import LayoutF
+import LayoutRequest
+import Placers
+import MatrixP
+import Layoutspec
+import TableP
+import TryLayout
+import NameLayout
+import UserLayoutF
+import DynListLF
+import AutoPlacer
+import Placer
+import Spacer
+import Spacers
+import Placers2
+import DynSpacerF
+import Sizing
+import CondLayout
+import HorizontalAlignP
+import ParagraphP
diff --git a/hsrc/layout/LayoutDir.hs b/hsrc/layout/LayoutDir.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutDir.hs
@@ -0,0 +1,35 @@
+module LayoutDir where
+import Geometry(Point(..), xcoord, ycoord)
+import LayoutRequest
+import Utils(swap)
+
+data Orientation = Above | Below | RightOf | LeftOf
+                   deriving (Eq, Ord, Show)
+
+data LayoutDir = Horizontal | Vertical  deriving (Eq, Ord, Show)
+
+
+xc Horizontal = xcoord
+xc Vertical = ycoord
+
+yc Horizontal = ycoord
+yc Vertical = xcoord
+
+fixh Horizontal = fixedh
+fixh Vertical = fixedv
+
+fixv Horizontal = fixedv
+fixv Vertical = fixedh
+
+mkp Horizontal x y = Point x y
+mkp Vertical x y = Point y x
+
+vswap Horizontal = id
+vswap Vertical = swap
+
+colinear Horizontal h v = h
+colinear Vertical   h v = v
+
+orthogonal Horizontal h v = v
+orthogonal Vertical   h v = h
+
diff --git a/hsrc/layout/LayoutDoNow.hs b/hsrc/layout/LayoutDoNow.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutDoNow.hs
@@ -0,0 +1,27 @@
+module LayoutDoNow where
+
+import Fudget
+--import Command
+import FRequest
+--import Event
+--import Message
+import Spops
+--import SP(SP)
+import Path(here)
+import LayoutRequest
+import IsRequest
+
+layoutDoNow (F sp) = F{-ff-} (layoutDoNow' sp)
+
+layoutDoNow' f = donow 0 (pullSP f) where
+  donow pendingreqs (os,f) = 
+      putsSP os $ 
+      let n' = pendingreqs + newreqs
+          newreqs = length (filter isReq os)
+	  isReq (Low (_,c)) = isRequest c
+	  isReq _ = False
+	  nResp (Low (_,e)) | isResponse e = 1
+	  nResp _ = 0
+      in if n' == 0 then putSP (Low (here,LCmd LayoutDoNow)) f
+	 else 
+      getSP $ \msg -> donow (n' - nResp msg) (walkSP f msg)
diff --git a/hsrc/layout/LayoutF.hs b/hsrc/layout/LayoutF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutF.hs
@@ -0,0 +1,52 @@
+module LayoutF(serCompLF, compLF, listLF, untaggedListLF,
+	       --rbLayoutF,
+               nullLF, holeF, holeF', lF, LayoutDirection(..),orientP) where
+--import TableP
+import CompF
+import CompOps((>^=<))
+import Fudget
+import FRequest
+import Geometry() -- instances
+import LayoutDir(Orientation(..))
+import LayoutRequest
+import Placers
+import ListF
+import NullF
+import FudgetIO
+import SerCompF(serCompF)
+import Utils(number)
+--import Xtypes
+import AlignP(revP)
+import Placer(placerF)
+
+data LayoutDirection = Forward | Backward  deriving (Eq, Ord,Show)
+
+holeF' s = putLow (layoutRequestCmd (plainLayout s False False)) nullF
+holeF = holeF' 0
+nullLF = holeF
+
+--listLF :: Eq a => Placer -> [(a, F b c)] -> F (a, b) (a, c)
+listLF placer fl = lF (length fl) Forward placer (listF fl)
+
+untaggedListLF :: Placer -> [F a b] -> F (Int, a) b
+untaggedListLF layout fs = snd >^=< listLF layout (number 0 fs)
+
+compLF = cLF compF
+serCompLF = cLF serCompF
+--rbLayoutF sep = lF 3 Forward (rightBelowP sep)
+
+cLF :: ((F a b) -> (F c d) -> F e f) -> (F a b,Orientation) -> F c d -> F e f
+cLF cF (f1,ori) f2 = lF 2 Forward (orientP ori) (cF f1 f2)
+
+lF :: Int -> LayoutDirection -> Placer -> (F a b) -> F a b
+lF 0 _ _ f = nullLF
+lF nofudgets dir placer f = placerF placer' f where 
+     placer' = if dir == Backward then revP placer else placer
+
+orientP :: Orientation -> Placer
+orientP ori =
+   case ori of
+     Above -> verticalP
+     Below -> revP verticalP
+     LeftOf -> horizontalP
+     RightOf -> revP horizontalP
diff --git a/hsrc/layout/LayoutHints.hs b/hsrc/layout/LayoutHints.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutHints.hs
@@ -0,0 +1,15 @@
+module LayoutHints(module LayoutHints,LayoutHint(..)) where
+import Fudget
+import LayoutRequest
+import FRequest
+--import Geometry(Point, Size(..),Rect)
+import NullF(putMessageFu)
+--import Command
+
+serHint  = "ser" :: LayoutHint
+parHint  = "par" :: LayoutHint
+listHint = "list" :: LayoutHint
+loopHint = "loop" :: LayoutHint
+
+layoutHintF :: LayoutHint -> F a b -> F a b
+layoutHintF hint = putMessageFu (Low (LCmd (LayoutHint hint)))
diff --git a/hsrc/layout/LayoutRequest.hs b/hsrc/layout/LayoutRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutRequest.hs
@@ -0,0 +1,81 @@
+module LayoutRequest where
+import Geometry(Point(..), Size(..),Rect(..){-,padd,psub,pmax,pP-})
+--import EitherUtils(mapMaybe)
+--import HO(apFst)
+--import Maptrace(ctrace) -- debugging
+import Alignment
+import ShowFun()
+
+data LayoutRequest
+  = Layout { minsize :: Size,
+	     fixedh, fixedv :: Bool,
+	     wAdj, hAdj :: Int -> Size,
+		-- If the available width is w
+		-- then the size of this box should be wAdj w.
+		-- Analogously for hAdj.
+	     refpoints :: [Point], -- used by some placers
+	     wantedPos :: Maybe (Point,Size,Alignment)
+           }
+  deriving (Show)
+
+plainLayout s fh fv = refpLayout s fh fv []
+refpLayout s fh fv rps = Layout s fh fv wa ha rps Nothing
+  where
+    wa w = {-ctrace "wa" (show (w::Int,s)) $-} s
+    ha h = {-ctrace "ha" (show (h::Int,s)) $-} s
+    --wa = if fh then const s else \ w -> pmax s (pP w 0)
+    --ha = if fv then const s else \ h -> pmax s (pP 0 h)
+
+data LayoutMessage
+  = LayoutRequest LayoutRequest
+  | LayoutMakeVisible Rect (Maybe Alignment,Maybe Alignment)
+  | LayoutScrollStep Int
+  | LayoutName String
+  | LayoutPlacer Placer
+  | LayoutSpacer Spacer
+  | LayoutHint LayoutHint
+  | LayoutDoNow
+  | LayoutDestroy
+  | LayoutReplaceSpacer Spacer  -- for use by dynSpacerF
+  | LayoutReplacePlacer Placer  -- for use by dynPlacerF
+  deriving (Show)
+
+data LayoutResponse
+  = LayoutPlace Rect
+  | LayoutSize Size
+  | LayoutPos Point -- Position in parent window. Occationally useful.
+  deriving Show
+
+layoutMakeVisible r = LayoutMakeVisible r (Nothing,Nothing)
+
+newtype Placer = P Placer1 deriving (Show)
+
+type Placer1 = ([LayoutRequest] -> Placer2)
+type Placer2 = (LayoutRequest, Rect -> [Rect])
+unP (P p) = p
+
+newtype Spacer = S Spacer1 deriving (Show)
+type Spacer1 = (LayoutRequest -> Spacer2)
+type Spacer2 = (LayoutRequest, Rect -> Rect)
+unS (S s) = s
+
+type LayoutHint = String -- ??
+
+--mapLayoutSize f req@(Layout {minsize=s}) = req{minsize=f s}
+mapLayoutSize f = mapAdjLayoutSize f id id
+
+mapAdjLayoutSize f wf hf req@(Layout {minsize=s,wAdj=wa,hAdj=ha}) =
+  req{minsize=f s, wAdj=f.wa.wf, hAdj=f.ha.hf}
+
+mapLayoutRefs f req@(Layout{refpoints=rps}) = req{refpoints=map f rps}
+
+flipReq (Layout p fh fv wa ha rps wanted) =
+  Layout (flipPoint p) fv fh
+	 (flipPoint . ha) (flipPoint . wa)
+	 (map flipPoint rps)
+	 (fmap flipWanted wanted)
+
+flipWanted (p,s,a) = (flipPoint p,flipPoint s,a)
+
+flipRect (Rect p s) = Rect (flipPoint p) (flipPoint s)
+flipPoint (Point x y) = Point y x
diff --git a/hsrc/layout/LayoutSP.hs b/hsrc/layout/LayoutSP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/LayoutSP.hs
@@ -0,0 +1,125 @@
+module LayoutSP(layoutMgrF,dynLayoutMgrF) where
+--import Command
+import Data.List(sortBy)
+--import Direction
+--import Event
+import FRequest
+import Fudget
+import CompOps((>=^<))
+import Geometry(Rect,rR)
+import LayoutRequest
+import Path(here,showPath{-,Path(..),subPath-})
+import Spops
+--import EitherUtils(mapMaybe)
+--import Utils(number, replace)
+import HbcUtils(apFst)
+--import Xtypes
+--import NonStdTrace(trace)
+--import CmdLineEnv(argKey)
+import LayoutF(LayoutDirection(..))
+import Maptrace(ctrace)
+
+default (Int)
+
+mytrace x = ctrace "layoutftrace" x
+
+layoutMgrF :: Int -> LayoutDirection -> Placer -> F (Path, LayoutMessage) (Path, Rect)
+layoutMgrF fudgetCnt dir lter1 = dynLayoutMgrF fudgetCnt dir lter1 >=^< Left
+
+dynLayoutMgrF :: Int -> LayoutDirection -> Placer -> F (Either (Path, LayoutMessage) (Int,Bool)) (Path, Rect)
+dynLayoutMgrF fudgetCnt0 dir (P lter1) = F{-ff-} $ getNLimits fudgetCnt0 []
+  where
+   sortTags = sortBy (order dir)
+     where
+       order Forward = ofst compare
+       order Backward = ofst (flip compare)
+       ofst r (x,_) (y,_) = r x y
+   getNLimits 0 l = doLter1 Nothing $ sortTags l
+   getNLimits n l =
+    let same = getNLimits n l in
+    getSP $ \msg -> case msg of
+      High (Left (path,lmsg)) ->
+        case lmsg of
+	 LayoutRequest lr -> getNLimits (n-1) ((path,lr):l)
+	 _ -> putSP (Low (path,LCmd lmsg)) same -- !!!
+      High (Right (dyn,created)) ->
+        if created
+	then getNLimits (n+1) l
+	else mytrace "fudget destroyed during getNLimits in layoutMgrF" $
+	     --let l' =
+	     -- if {-already received layout request from the destoyed fudget-}
+	     -- then {-remove it from l-}
+	     -- else l
+	     -- in getNLimits (n-1) l'
+	     same
+      Low _ -> mytrace "unexpected event in getNLimits in layoutMgrF" $
+               same
+   doLter1 oplace slims =
+     let (req,lter2) = lter1 (map snd slims)
+     in mytrace ("req is"++show req) $ 
+        putSP (Low (here,layoutRequestCmd req)) $
+	mytrace ("enter loop with "++show (length slims)) $
+	loop lter2 slims oplace
+   loop lter2 slims oplace =
+    let same = loop lter2 slims oplace
+    in
+    getSP $ \msg -> case msg of
+      High (Left (path,LayoutRequest lr)) ->
+	 case upd slims path lr of
+	   Nothing -> case (oplace >>= \place ->
+			    flip lookup (zip (map fst slims) (snd place)) path) of
+			Nothing -> same
+			Just r -> putSP (High (path,r)) same
+	   Just slims' -> mytrace ("reenter: "++show (length slims')) $
+	                  doLter1 (fmap (apFst (const $ rR 0 0 0 0)) oplace) slims'
+         where upd slims path lr =
+	         try path Nothing $
+		 mytrace ("lF: trying subPath"++
+		          show(path,slims,longesteq path (map fst slims)::Path)) $
+		 try (longesteq path (map fst slims)) (Just path) Nothing
+                 where try path orepl fail = u slims []
+			  where u [] _ = fail
+				u (pl@(path',lr'):rest) l = 
+				  let nslims p = Just (reverse l ++ ((p,lr):rest)) in
+				  if path'==path then case orepl of
+				       Nothing -> {-if lr == lr' then Nothing else -} nslims path
+				       Just repl -> nslims repl
+
+				  else u rest (pl:l)
+      High (Left (path,lr)) -> putSP (Low (path,LCmd lr)) same -- !!!
+      High (Right (dyn,created)) ->
+        if created
+	then getNLimits 1 slims
+	else mytrace "fudget destroyed in loop in layoutMgrF" $
+	     -- remove it!
+	     same
+      Low (path,LEvt (LayoutPlace r)) -> mytrace ("Layoutplace "++showPath path++","++show r) $
+	case oplace of 
+	  Just (r',_) | r == r' -> mytrace ("lF: same rect "++show r) same
+	  _ -> let rects = lter2 r
+		   slims' = slims {-map (\((path,Layout s v h),Rect p s') ->
+				   mytrace (show (showPath path,s,s'))$(path,Layout s' v h)) $ zip slims rects-}
+		   paths = map fst slims
+		   crects = zip paths rects {- case oplace of
+		    Nothing -> zip paths rects
+		    Just (_,orects) -> 
+			   [(path,r) | 
+			    (path,r,r') <- zip3 paths rects orects, r /= r']-}
+	       in --mytrace (show$slims'==slims') $
+		  putsSP [mytrace ("putsSP "++show (showPath path,r))$High pr | pr@(path,r) <- crects] $
+		  loop (snd $ lter1 (map snd slims')) slims' (Just (r,rects))
+      Low _ -> mytrace "unexpected event in loop in layoutMgrF" $
+               same
+
+--{-
+--This is a fix for a problem with dynF, I (th) suppose. I think you can fix it in dynF instead.
+begineqlen x = eq 0 x where
+  eq n (x:xs) (y:ys) | x == y = eq (n+1) xs ys
+  eq n _ _ = n
+
+longesteq p1 (p:ps) = le (p1,begineqlen p1 p) ps where
+  le (pm,l) [] = pm
+  le (pm,l) (p:ps) = let len = begineqlen p1 p
+                         pl1 = if len > l then (p,len) else (pm,l)
+		     in le pl1 ps
+-- -}
diff --git a/hsrc/layout/Layoutspec.hs b/hsrc/layout/Layoutspec.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Layoutspec.hs
@@ -0,0 +1,60 @@
+module Layoutspec(marginHVAlignLs, hvAlignLs, marginLs, sepLs,hBoxLs', vBoxLs',
+        placeLs,spaceLs,revLs, permLs, leafLs, layoutF, Layout) where
+import AlignP
+--import Alignment(Alignment(..))
+import Fudget
+--import Geometry(Point, Rect, Size(..))
+--import LayoutDir(LayoutDir, Orientation)
+import LayoutF(LayoutDirection(..), lF)
+import LayoutRequest
+import Placers
+import Spacers
+import Utils(oo,unconcat)
+
+data Layout = LeafL | NodeL Placer [Layout]  --deriving (Eq, Ord)
+
+layoutF :: Layout -> (F a b) -> F a b
+layoutF layout f =
+    let (n, lter) = layouter layout
+    in  lF n Forward lter f
+
+leafLs = LeafL
+
+revLs LeafL = LeafL
+revLs (NodeL lter ls') = NodeL (revP lter) ls'
+
+npermLs _    LeafL = LeafL
+permLs perm (NodeL lter ls') = NodeL (permuteP perm lter) ls'
+
+modLs ltermod l =
+    case l of
+      LeafL -> NodeL (ltermod idP) [LeafL]
+      NodeL lter ls' -> NodeL (ltermod lter) ls'
+
+placeLs = NodeL
+spaceLs = modLs . spacerP
+
+vBoxLs' = placeLs . verticalP'
+hBoxLs' = placeLs . horizontalP'
+
+sepLs = spaceLs . sepS
+marginLs = spaceLs . marginS
+hvAlignLs = oo spaceLs hvAlignS
+marginHVAlignLs sep ha va = spaceLs (marginHVAlignS sep ha va)
+
+--layouter :: Layout -> (Int, Placer)
+layouter layout =
+    case layout of
+      LeafL -> (1, idP)
+      NodeL lter ls' -> let (ns, lters) = unzip (map layouter ls')
+                        in  (sum ns, combl lter ns lters)
+
+combl rootlter ns nodelters = P $ \ leafreqs ->
+    let (nodereqs, noderess) =
+            unzip (zipWith unP nodelters (unconcat ns leafreqs))
+        (rootreq, rootres) = unP rootlter nodereqs
+        leafres rootrect = concatMap apply (zip noderess (rootres rootrect))
+    in  (rootreq, leafres)
+
+apply (f, x) = f x
+
diff --git a/hsrc/layout/MatrixP.hs b/hsrc/layout/MatrixP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/MatrixP.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE CPP #-}
+module MatrixP(matrixP,matrixP') where
+import Geometry
+import LayoutRequest
+import LayoutDir(LayoutDir(..),xc,yc,mkp)
+import Spacers(Distance)
+import Defaults(defaultSep)
+import Data.List(mapAccumL)
+
+#ifndef __HBC__
+#define fromInt fromIntegral
+#endif
+
+matrixP n = matrixP' n Horizontal defaultSep
+
+matrixP' :: Int -> LayoutDir -> Distance -> Placer
+matrixP' count' ld sep = P $ \ requests ->
+    let n = length requests
+        maxsize = (pMax . (origin:) . map minsize) requests
+	rps' = concatMap refpoints requests
+        maxh = xc ld maxsize
+        maxv = yc ld maxsize
+        ncols = count' `min` n
+        nrows = (n - 1) `quot` count' + 1
+        his = sep * (ncols - 1)
+        vis = sep * (nrows - 1)
+        h = his + maxh * ncols
+        v = vis + maxv * nrows
+        mat2 (Rect gotpos gotsize) =
+            let x0 = xc ld gotpos
+	        y0 = yc ld gotpos
+		width = xc ld gotsize
+		height = yc ld gotsize
+                goth,gotv :: Double
+                goth = fromInt (width - his) / fromInt ncols
+                gotv = fromInt (height - vis) / fromInt nrows
+                pl i _ =
+		  let (x, y) = (i `rem` count', i `quot` count')
+		  in (i + 1, Rect
+		   (mkp ld (x0 + truncate (fromInt x * (goth + fromInt sep)))
+			   (y0 + truncate (fromInt y * (gotv + fromInt sep))))
+		   (mkp ld (truncate goth)
+			   (truncate gotv)))
+            in  snd (mapAccumL pl 0 requests)
+    in  (refpLayout (mkp ld h v) False False rps', mat2)
+
+#ifdef __NHC__
+fromInt = fromIntegral
+#endif
diff --git a/hsrc/layout/NameLayout.hs b/hsrc/layout/NameLayout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/NameLayout.hs
@@ -0,0 +1,193 @@
+module NameLayout(LName(..),placeNL,spaceNL,modNL,marginNL,sepNL,hvAlignNL,marginHVAlignNL,nullNL,hBoxNL,hBoxNL',vBoxNL, vBoxNL',leafNL, NameLayout, nameF,
+ listNF, nameLayoutF) where
+
+--import NonStdTrace(trace)
+import LayoutRequest
+import NullF
+import Spops
+--import Command
+--import Event
+import FRequest
+--import Xtypes
+import EitherUtils(plookup)
+import Data.Maybe(fromJust)
+import Fudget
+import Path
+import Geometry
+import Placers
+import Spacers
+--import Message
+import ListF
+import Loopthrough
+import Cont
+--import LayoutDir
+import AlignP
+--import Alignment
+import Utils
+import Maptrace
+import AutoLayout
+import ParF
+
+type LName = String
+newtype NameLayout = NL (MLNode LName) -- abstract
+
+-- The layout structure datatype
+type MLNode a = (Maybe LayoutRequest, LNode a)
+data LNode a = 
+      LNode Int Placer (Maybe (Rect -> [Rect])) [MLNode a]
+    | LLeaf (LLeaf a) deriving Show
+
+data LLeaf a = Name a | Req LayoutRequest deriving Show
+
+type NPath = [Int]
+
+-----------------------------------------------------------------------------------
+-- Exported functions
+
+placeNL :: Placer -> [NameLayout] -> NameLayout
+placeNL lter ns = let dns = map deNL ns in
+   buildnl $ LNode (length (filter (nothing.fst) dns)) lter Nothing dns
+
+spaceNL :: Spacer -> NameLayout -> NameLayout
+spaceNL = modNL . spacerP
+
+modNL :: (Placer -> Placer) -> NameLayout -> NameLayout
+modNL ltermod (NL (req,n)) = NL $ case n of
+   LNode i lter f ls -> (req,LNode i (ltermod lter) f ls)
+   LLeaf l -> 
+      let lter = ltermod idP
+          P lter' = lter in 
+      case l of
+	 Req r -> leafReq $ fst $ lter' $ [r]
+	 _ -> (Nothing,LNode 1 lter Nothing [(req,n)])
+
+marginNL = spaceNL . marginS
+sepNL = spaceNL . sepS
+
+hvAlignNL = spaceNL `oo` hvAlignS
+marginHVAlignNL sep ha va = spaceNL (marginHVAlignS sep ha va)
+
+hBoxNL = placeNL $ horizontalP
+hBoxNL' d = placeNL $ horizontalP' d
+vBoxNL = placeNL $ verticalP
+vBoxNL' d = placeNL $ verticalP' d
+leafNL name = buildnl $ LLeaf $ Name name
+nullNL = NL $ leafReq $ plainLayout (Point 1 1) False False
+
+nameF :: LName -> F a b -> F a b
+nameF n = putMessageFu (Low (LCmd (LayoutName n))) . autoLayoutF
+
+-- local
+
+nothing Nothing = True
+nothing _ = False
+
+buildnl :: LNode LName -> NameLayout
+buildnl x = NL (Nothing,x)
+deNL (NL x) = x
+
+leafReq :: LayoutRequest -> MLNode a
+leafReq req = (Just req,LLeaf $ Req $ req)
+
+listNF :: (Eq a, Show a) => [(a, F b c)] -> F (a, b) (a, c)  
+listNF fs = listF [(t, nameF (show t) f) | (t, f) <- fs]
+
+-- The main layout function
+nameLayoutF :: NameLayout -> F a b -> F a b
+nameLayoutF (NL ltree) (F fsp) =
+    let layoutSP =
+            getAllPNames (countLNames ltree) [] $ \pnames ->
+            let (pathTable, ltree') = rebuildTree pnames [] ltree
+	    in lSP pathTable ltree'
+        lSP pt ltree = 
+            let same = lSP pt ltree in
+            getSP $ \msg ->
+	    case msg of
+	      -- A message from the fudget
+	      Left (Low (path, LCmd (LayoutRequest lr))) ->
+		  ctrace "nameLayoutF" lr $
+		  let ltree' = updateTree path (pathlookup pt path) ltree lr
+		  in case ltree' of 
+			(Just lreq, _) -> --trace (show ltree') $
+			    putSP (Right (Low ([], layoutRequestCmd lreq))) $
+			    lSP pt ltree'
+			_ -> lSP pt ltree'
+	      Left x -> putSP (Right x) $ same
+	      -- A message to the fudget
+	      Right (Low (path, LEvt (LayoutPlace r))) ->
+		  putsSP (map (Left. Low) $ traverseTree r ltree) $ same
+	      Right x -> putSP (Left x) $ same
+    in parF nullF $ F{-ff-} $ loopThroughRightSP layoutSP fsp
+--  fix for autolayout
+
+-----------------------------------------------------------------------------------
+-- Local functions
+
+-- Counts the number of named leafs in a layout structure
+countLNames :: MLNode a -> Int
+countLNames (_, LLeaf (Name _)) = 1
+countLNames (_, LLeaf _) = 0
+countLNames (_, LNode _ _ _ ns) = sum (map countLNames ns)
+
+-- Traverses the layout structure, returning a mapping from leaf names to paths
+getAllPNames :: Int -> [(LName, Path)] -> 
+	     Cont (SP (Either (FCommand a) b) c) [(LName,Path)]
+getAllPNames 0 pnames c = c pnames
+getAllPNames n pnames c =
+    waitForSP layoutName $ \pname ->
+    getAllPNames (n-1) (pname:pnames) c
+    where layoutName (Left (Low (path, LCmd (LayoutName name)))) = 
+              Just(name, path)
+          layoutName _ = Nothing
+
+-- Rebuilds the layout structure. 
+-- Returns also a mapping from ordinary paths to number paths.
+rebuildTree :: [(LName, Path)] -> NPath -> MLNode LName ->
+               ([(Path, NPath)], MLNode Path)
+rebuildTree pnames np (_, LLeaf (Name name)) = 
+    case lookup name pnames of
+        Nothing -> error ("Couldn't find name "++ show name ++ 
+			  " in (name, path) table.")
+	Just path -> ([(path, np)], (Nothing, LLeaf $ Name path))
+rebuildTree pnames np (_, (LLeaf (Req r))) = ([],(Just r, (LLeaf (Req r))))
+rebuildTree pnames np (_, LNode c lter Nothing ns) =
+    (concat ts, (Nothing, LNode c lter Nothing ns'))
+    where (ts, ns') = unzip (zipWith (rebuildTree pnames) 
+                                     (map ((np++) . (:[])) [1..]) ns)
+
+
+-- Inserts layout requests in the layout structure.
+-- Trigged by some fudget emitting a layout request
+updateTree :: Path -> 
+              Maybe NPath -> 
+	      MLNode Path -> 
+	      LayoutRequest -> 
+              MLNode Path
+updateTree path Nothing _ lr = 
+    error ("Hmmm. Couldn't find path " ++ show path ++
+    "in updateTree\nSomeone has probably forgotten to name a fudget.")
+updateTree path (Just npath) lo lr = snd $ upd npath lo lr
+    where upd _ (mlr, LLeaf (Name p)) lr = 
+                 (nothing mlr, (Just lr, LLeaf (Name path)))
+          upd (n:np) (mlr, LNode c lter@(P lter') mr ns) lr =
+	      let (before, this:after) = splitAt (n-1) ns
+	          (ready, child) = upd np this lr
+	          c' = if ready then max (c-1) 0 else c
+		  ns' = before ++ [child] ++ after
+	      in if c' == 0 then
+	             let (lreq, rectf) = lter' (map (fromJust . fst) ns')
+		     in (nothing mlr, 
+		         (Just lreq, LNode c' lter (Just rectf) ns'))
+		 else
+		     (False, (Nothing, LNode c' lter mr ns'))
+          upd _ othernode _ = (False,othernode)
+
+-- We have got a rectangle. Emit commands to all subfudgets saying how large
+-- they should be. 
+traverseTree :: Rect -> MLNode Path -> [TEvent]
+traverseTree r (_, LLeaf (Name path)) = [(path, LEvt $ LayoutPlace r)]
+traverseTree r (_, LLeaf _) = []
+traverseTree r (_, LNode _ _ (Just rectf) ns) =
+    concat (zipWith traverseTree (rectf r) ns) 
+
+pathlookup table p = plookup (flip subPath p) table
diff --git a/hsrc/layout/ParagraphP.hs b/hsrc/layout/ParagraphP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/ParagraphP.hs
@@ -0,0 +1,51 @@
+module ParagraphP where
+import LayoutRequest
+import Geometry
+--import ListUtil(chopList)
+import HbcUtils(apFst,chopList)
+import Defaults(defaultSep)
+import Placers(verticalP')
+import Spacers() -- synonym Distance, for hbc
+import HorizontalAlignP(horizontalAlignP')
+--import Maptrace(ctrace)
+import Utils(oo)
+import CmdLineEnv(argReadKey)
+--import IntMemo
+
+paragraphP = paragraphP' defaultSep
+paragraphP' = paragraphP'' horizontalAlignP'
+
+paragraphP'' :: (Int->Placer) -> Size -> Placer
+paragraphP'' horizP' (Point hsep vsep) = P paP
+  where
+    paP reqs = ({-ctrace "paraReq" (req, wAdj req $ xcoord $ minsize req)-} req,paraPlacer2)
+      where
+	width0 = argReadKey "paragraph-width" 600 :: Int
+	req = (paraReq width0) { wAdj=minsize . paraReq }
+	paraReq width = fst (paraP width)
+	paraPlacer2 rect@(Rect _ (Point w _)) =
+	  --ctrace "paraPlacer2" rect $
+	  snd (paraP w) rect
+	paraP = {-memoInt-} paraP' -- memoInt slows down and consumes a lot of heap
+	paraP' width = (vreq,placer2)
+	  where
+	    (vreq,vplacer2) = unP (verticalP' vsep) hreqs
+	    placer2 = concat . zipWith id hplacers2 . vplacer2
+	    (hreqs,hplacers2) =
+	      unzip . map (unP (horizP' hsep)) . breakLines width $ reqs
+
+	breakLines w rs = {-ctrace "breakLines" (w,map length rss)-} rss
+	    where rss = breakLines' w rs
+
+	breakLines' = chopList . (atLeastOne `oo` takeLine)
+	takeLine wremain reqs = 
+	  case reqs of
+	    [] -> ([],[])
+	    r:rs -> --ctrace "takeLine" (wremain,w) $
+		    if wremain<w
+		    then ([],reqs)
+		    else apFst (r:) (takeLine (wremain-w-hsep) rs)
+	      where w=xcoord (minsize r)
+
+atLeastOne ([],x:xs) = ([x],xs)
+atLeastOne xsys = xsys
diff --git a/hsrc/layout/Placer.hs b/hsrc/layout/Placer.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Placer.hs
@@ -0,0 +1,34 @@
+module Placer where
+import Fudget
+import LayoutRequest
+import FRequest
+--import Geometry(Point, Size(..),Rect)
+import NullF(putMessageFu)
+--import Command
+--import Defaults(defaultSep)
+import Placers(horizontalP,verticalP)
+import MatrixP(matrixP)
+import Spacers(spacerP)
+import TableP(tableP)
+import AlignP(revP)
+import AutoPlacer(autoP)
+
+--import AlignP
+--import Alignment
+
+placerF :: Placer -> F a b -> F a b
+placerF placer = putMessageFu (Low (LCmd (LayoutPlacer placer)))
+
+spacerF :: Spacer -> F a b -> F a b
+spacerF spacer = putMessageFu (Low (LCmd (LayoutSpacer spacer)))
+
+spacer1F s = placerF (s `spacerP` autoP)
+
+hBoxF = placerF horizontalP
+vBoxF = placerF verticalP
+
+revHBoxF = placerF (revP horizontalP)
+revVBoxF = placerF (revP verticalP)
+
+matrixF = placerF . matrixP
+tableF  = placerF . tableP
diff --git a/hsrc/layout/Placers.hs b/hsrc/layout/Placers.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Placers.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE CPP #-}
+module Placers(linearP, verticalP, horizontalP, horizontalP', verticalP') where
+import Geometry
+import LayoutDir
+import LayoutRequest
+import Spacers(Distance(..))
+import Data.List(mapAccumL)
+import Utils(part)
+import Defaults(defaultSep)
+import Maptrace(ctrace) -- debugging
+--import NonStdTrace(trace)
+import IntMemo
+
+#ifndef __HBC__
+#define fromInt fromIntegral
+#endif
+ 
+horizontalP = horizontalP' defaultSep
+verticalP = verticalP' defaultSep
+
+horizontalP' = linearP Horizontal
+verticalP' = linearP Vertical
+
+linearP :: LayoutDir -> Distance -> Placer
+linearP ld sep = P $ linearP' ld sep
+
+linearP' ld sep [] = ctrace "linearP" ("linearP "++show ld++" []") $
+		    (plainLayout 1 (ld==Horizontal) (ld==Vertical),\ r -> [])
+linearP' ld sep requests =
+    let minsizes = map minsize requests
+        totis = sep * (max 0 (length requests - 1))
+        h = max 0 (h'-sep)   -- totis + sum (map (xc ld) minsizes)
+	(h',rpss) = mapAccumL adjust 0 requests
+	  where adjust x (Layout {minsize=rsz,refpoints=rps}) =
+		    (x+rw+sep,map adj1 rps)
+		  where adj1 p = mkp ld (x+xc ld p) (yc ld p)
+		        rw = xc ld rsz
+        v = (maximum . (0:) . map (yc ld)) minsizes
+        line2 gotr =
+            let goth = (fromInt . xc ld . rectsize) gotr - fromInt totis
+                gotv = (yc ld . rectsize) gotr
+                startx = (fromInt . xc ld . rectpos) gotr
+                starty = (yc ld . rectpos) gotr
+#if 0
+-- Old solution
+		requests' = requests
+#else
+-- New, experimental solution:
+		requests' = map req' requests
+		  where
+		    req' req = req {minsize=adj gotv}
+		      where adj=orthogonal ld (wAdj req) (hAdj req)
+#endif
+                (fih, flh) = part (fixh ld) requests'
+                fixedh' =
+		  (fromInt . sum . map (xc ld . minsize)) fih
+                floath = (fromInt . sum . map (xc ld . minsize)) flh
+                fixedR = if floath > 0.0 then 1.0 else goth / fixedh'
+                floatR =
+                    if floath == 0.0 then 1.0 else (goth - fixedh') / floath
+                rR' req = if fixh ld req then fixedR else floatR
+                pl x req =
+                    let width = (fromInt . xc ld . minsize) req * rR' req
+                    in  (x + width + fromInt sep,
+                         Rect (mkp ld (truncate x) starty)
+                              (mkp ld (truncate width) gotv))
+            in  snd (mapAccumL pl startx requests')
+	(fh',fv') = vswap ld (allf and fixh,allf or fixv)
+	rps' = concat rpss --concatMap refpoints requests
+	allf conn fix = conn (map (fix ld) requests)
+	req0 = refpLayout (mkp ld h v) fh' fv' rps'
+	req =
+	  case ld of
+	    Horizontal -> req0 { hAdj=memoInt ha } 
+	      where ha h = Point (totis+sum ws) h
+		      where ws = map (xcoord . flip hAdj h) requests
+	    Vertical -> req0 { wAdj=memoInt wa } 
+	      where wa w = Point w (totis+sum hs)
+		      where hs = map (ycoord . flip wAdj w) requests
+    in (req,line2)
+
+#ifdef __NHC__
+fromInt = fromIntegral
+#endif
diff --git a/hsrc/layout/Placers2.hs b/hsrc/layout/Placers2.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Placers2.hs
@@ -0,0 +1,72 @@
+module Placers2(overlayP,
+		verticalLeftP,verticalLeftP',
+		horizontalCenterP,horizontalCenterP') where
+import LayoutRequest
+import Spacers(Distance(..))
+import Geometry
+import Defaults(defaultSep)
+import Data.List(mapAccumL)
+import IntMemo
+
+overlayP :: Placer
+overlayP = P overlayP'
+  where
+    overlayP' ls = (req,placer2)
+      where
+	ss = map minsize ls
+	rps = concatMap refpoints ls
+	wa w = Point w (maximum (1:map (ycoord . flip wAdj w) ls))
+	ha h = Point (maximum (1:map (xcoord . flip hAdj h) ls)) h
+	req = (refpLayout (pMax ss) (any fixedh ls) (any fixedv ls) rps) {wAdj=memoInt wa,hAdj=memoInt ha}
+	placer2 r = [r | _ <- ls]
+
+verticalLeftP = verticalLeftP' defaultSep
+
+verticalLeftP' :: Distance -> Placer 
+verticalLeftP' sep = P vlP
+  where
+    vlP ls = (req,placer2)
+      where
+	req = (refpLayout (Point w h) False (and fvs) (concat rpss)) {wAdj=memoInt wa}
+	wa aw = Point aw (sum hs+totsep)
+	  where hs = [ycoord (wAdj (min aw w)) | Layout{minsize=Point w _,wAdj=wAdj}<-ls]
+	totsep = sep*(length ls-1)
+	(ss,fhs,fvs) = unzipsfhv ls
+	(ws,hs) = unzip [(w,h) | Point w h <- ss]
+	w = maximum (1:ws)
+	h = max 1 (h'-sep) -- (sum hs + sep*(length hs-1))
+	(h',rpss) = mapAccumL adjust 0 ls
+	  where adjust y (Layout {minsize=Point _ rh,refpoints=rps}) =
+		    (y+rh+sep,map adj1 rps)
+		  where adj1 (Point rx ry) = Point rx (y+ry)
+	placer2 (Rect (Point x0 y0) _) = placer2' hs ss y0
+	  where placer2' (h:hs) (s:ss) y =
+		   Rect (Point x0 y) s:placer2' hs ss (y+sep+h)
+		placer2' _ _ _ = []
+
+horizontalCenterP = horizontalCenterP' defaultSep
+
+horizontalCenterP' :: Distance -> Placer 
+horizontalCenterP' sep = P hcP
+  where
+    hcP ls = (req,placer2)
+      where
+	req = (refpLayout (Point w h) (and fhs) False (concat rpss)) {hAdj=memoInt ha}
+	(ss,fhs,fvs) = unzipsfhv ls
+	ha ah = Point (sum ws+totsep) ah
+	  where ws = [xcoord (hAdj (min ah h)) | Layout{minsize=Point _ h,hAdj=hAdj}<-ls]
+	totsep = sep*(length ls-1)
+	(ws,hs) = unzip [(w,h) | Point w h <- ss]
+	w = max 1 w' --(sum ws + sep*(length ws-1))
+	h = maximum (1:hs)
+	(w',rpss) = mapAccumL adjust 0 ls
+	  where adjust x (Layout {minsize=Point rw rh,refpoints=rps}) =
+		    (x+rw+sep,map adj1 rps)
+		  where adj1 (Point rx ry) = Point (x+rx) (ry+(h-rh) `div` 2)
+	placer2 (Rect (Point x0 y0) (Point _ ah)) = placer2' ws hs ss x0
+	  where placer2' (w:ws) (h:hs) (s:ss) x =
+		  Rect (Point x (y0+(ah-h) `div` 2)) s:placer2' ws hs ss (x+sep+w)
+		placer2' _ _ _ _ = []
+
+unzipsfhv ls =
+  unzip3 [(s,fh,fv) | Layout {minsize=s,fixedh=fh,fixedv=fv} <- ls]
diff --git a/hsrc/layout/Sizing.hs b/hsrc/layout/Sizing.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Sizing.hs
@@ -0,0 +1,14 @@
+module Sizing where
+import Geometry(pmax)
+
+data Sizing
+  = Static | Growing | Dynamic
+--  | StaticDebug
+  deriving (Eq,Show,Read)
+
+newSize sizing curSize reqSize =
+  case sizing of
+    Static  -> curSize
+--    StaticDebug  -> curSize
+    Growing -> pmax curSize reqSize
+    Dynamic -> reqSize
diff --git a/hsrc/layout/SizingF.hs b/hsrc/layout/SizingF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/SizingF.hs
@@ -0,0 +1,47 @@
+module SizingF(sizingF) where
+import LoopLow(loopThroughLowF)
+import Spops(mapAccumlSP)
+import LayoutRequest
+import FRequest
+--import Event
+--imaport Command
+import Geometry(Rect(..))
+--import Fudget
+import Sizing(newSize)
+--import Maptrace(ctrace) -- debugging
+
+sizingF = loopThroughLowF . sizingSP
+
+sizingSP sizing = mapAccumlSP sizingT state0
+  where
+    --tr = if sizing==StaticDebug then ctrace "dsizing" else const id
+    state0 = Nothing
+
+    sizingT Nothing msg =
+      case msg of
+	Left (path,LCmd (LayoutRequest (Layout size' fh' fv' wa' ha' rps' wanted'))) ->
+	  (Just (Nothing,size',fh',fv'{-,rps'-}),msg)
+	_ -> (Nothing,msg)
+    sizingT s@(Just state@(optpos,size,fh,fv{-,rps-})) msg =
+      case msg of
+	Left (path,LCmd (LayoutRequest r@(Layout size' fh' fv' wa' ha' rps' wanted'))) ->
+	    case (state' == state,optpos) of
+	      (True,Just pos) -> (s,Right (path,LEvt (LayoutPlace (Rect pos size))))
+	      _ -> --tr (show (state,state'))
+	            (Just state',msg')
+	  where size'' = newSize sizing size size'
+	        state' = (optpos,size'',fh',fv'{-,rps'-})
+	        msg' = Left (path,layoutRequestCmd r{minsize=size''})
+	Right (_,LEvt (LayoutPlace rect@(Rect pos' size'))) -> (Just (Just pos',size',fh,fv{-,rps-}),msg)
+	_ -> (s,msg)
+
+{-
+sizingF prevents a fudget from outputting a layout request that doesn't change
+anything. The sizing parameter also restricts what kind of resizing is allowed.
+
+sizingF assumes that the argument fudget has only ONE layout box and will
+confuse things if layout requests are received from several different paths.
+
+sizingF is used in autoLayoutF and there is probably no reason to use it in
+other places (i.e., use autoLayoutF' if there seems to be a need for sizingF).
+-}
diff --git a/hsrc/layout/Spacer.hs b/hsrc/layout/Spacer.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Spacer.hs
@@ -0,0 +1,17 @@
+-- replaces modules AlignF and SepF
+module Spacer(module Spacer,Distance(..)) where
+--import LayoutRequest
+import Spacers
+import Placer(spacer1F)
+
+marginHVAlignF m h v = spacer1F $ marginHVAlignS m h v
+
+alignF uladd bradd halign valign =
+  spacer1F (hvMarginS uladd bradd `compS` hvAlignS halign valign)
+
+layoutModifierF = spacer1F . layoutModifierS
+
+noStretchF fh fv = spacer1F (noStretchS fh fv)
+
+sepF = spacer1F . sepS
+marginF = spacer1F . marginS
diff --git a/hsrc/layout/Spacers.hs b/hsrc/layout/Spacers.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/Spacers.hs
@@ -0,0 +1,112 @@
+module Spacers where
+import LayoutRequest
+import Geometry
+import Utils(mapPair)
+import Alignment
+
+---- Spacer types
+
+type Distance = Int
+
+
+---- Primitive Spacers
+
+-- Fixed margins
+
+hMarginS, vMarginS :: Distance -> Distance -> Spacer
+hMarginS dLeft dRight = hvMarginS (pP dLeft 0) (pP dRight 0)
+vMarginS dTop dBottom = hvMarginS (pP 0 dTop) (pP 0 dBottom)
+
+hvMarginS :: Size -> Size -> Spacer
+hvMarginS dUpperLeft dBottomRight = S $ \ req ->
+  let growth = dUpperLeft + dBottomRight
+  in (mapLayoutRefs (+dUpperLeft) $
+        mapAdjLayoutSize (+growth) (+(-xcoord growth)) (+(-ycoord growth)) req,
+      center' dUpperLeft growth)
+
+center p (Rect r s) = Rect (r+p) (s-(p+p))
+center' offset shrink (Rect r s) = Rect (r+offset) (s-shrink)
+
+sepS :: Size -> Spacer
+sepS s = hvMarginS s s
+
+marginS :: Distance -> Spacer
+marginS d = sepS (diag d)
+
+-- Flexible margins
+
+leftS = hAlignS aLeft
+hCenterS = hAlignS aCenter
+rightS = hAlignS aRight
+
+vAlignS = flipS . hAlignS
+topS = flipS leftS
+vCenterS = flipS hCenterS
+bottomS = flipS rightS
+
+hvAlignS hpos vpos = hAlignS hpos `compS` vAlignS vpos
+centerS = vCenterS `compS` hCenterS
+
+hAlignS :: Alignment -> Spacer
+hAlignS hpos = S $ \ (Layout size@(Point rw _) fh fv wa ha rps wanted) ->
+  let
+    wa' w = wa (min rw w)
+    hAlignR (Rect p@(Point x y) s@(Point aw ah)) =
+	Rect (pP (x+spaceLeft) y) (pP rw' ah)
+      where
+	space = aw-rw'
+	spaceLeft = scale hpos space
+	rw' = min rw aw
+	rw = xcoord (ha ah)
+  in (Layout size False{-fh-} fv wa' ha rps wanted,hAlignR)
+
+marginHVAlignS sep halign valign = marginS sep `compS` hvAlignS halign valign
+
+--- Spacer operations
+
+spacerP :: Spacer -> Placer -> Placer
+spacerP (S spacer) (P placer) = P $ \ reqs ->
+  let   (req',placer2) = placer reqs
+        (req'',spacer2) = spacer req'
+  in (req'',placer2.spacer2)
+
+--flipS :: Spacer -> Spacer
+flipS = mapS flipS'
+  where
+    flipS' spacer = mapPair (flipReq,flipS2) . spacer . flipReq
+    flipS2 spacer2 = flipRect.spacer2.flipRect
+
+mapS f (S sp) = S (f sp)
+
+--idS :: Spacer
+idS = S $ \ req -> (req,id)
+
+compS :: Spacer -> Spacer -> Spacer
+compS (S spa) (S spb) = S $ \ req ->
+  let   (req',spb2) = spb req
+        (req'',spa2) = spa req'
+  in (req'',spb2.spa2)
+
+
+sizeS,maxSizeS,minSizeS :: Size -> Spacer
+sizeS    = resizeS . const
+maxSizeS = resizeS . pmin
+minSizeS = resizeS . pmax
+
+resizeS :: (Size->Size) -> Spacer
+resizeS = layoutModifierS . mapLayoutSize
+-- The above and below lines now mean the same
+--resizeS f = layoutModifierS (mapAdjLayoutSize f id id)
+
+noStretchS :: Bool -> Bool -> Spacer
+noStretchS fh fv = layoutModifierS lf
+  where lf req = req { fixedh=fh, fixedv=fv }
+--noStretchS fh fv req = (mapLayout lf req ,id)
+--  where lf size _ _ wa ha rps = Layout size fh fv wa ha rps
+
+mapLayout f req =
+  case req of
+    Layout size fh fv wa ha rps wanted -> f size fh fv wa ha rps wanted
+
+--layoutModifierS :: (LayoutRequest -> LayoutRequest) -> Spacer
+layoutModifierS lf = S $ \ req -> (lf req,id)
diff --git a/hsrc/layout/TableP.hs b/hsrc/layout/TableP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/TableP.hs
@@ -0,0 +1,141 @@
+{-# LANGUAGE CPP #-}
+module TableP(tableP,tableP') where
+import Geometry(Point(..), Rect(..), rR, xcoord, ycoord)
+import LayoutDir(LayoutDir(..), vswap)
+import LayoutRequest
+import Spacers(Distance(..))
+import HbcUtils(chopList)
+import Data.List(transpose,mapAccumL)
+import Utils(lhead)
+import Defaults(defaultSep)
+import IntMemo
+
+import Maptrace(ctrace)
+tr x = ctrace "tableP" x x
+
+tableP n = tableP' n Horizontal defaultSep
+
+tableP' :: Int -> LayoutDir -> Distance -> Placer
+tableP' count' ld sep = P $ \ requests ->
+    let --sizes = map minsize requests
+        (rows, columns) =
+            let hmatrix = chopList (splitAt count') requests
+                vmatrix = transpose hmatrix
+            in  vswap ld (hmatrix, vmatrix)
+        nrows = length rows
+        ncols = length columns
+        vsep = (nrows - 1) * sep
+        hsep = (ncols - 1) * sep
+        rowhs = map (maximum . (0:) . map (ycoord.minsize)) rows
+        colws = map (maximum . (0:) . map (xcoord.minsize)) columns
+	--rowfixws = map (and . map fixedh) rows
+	rowfixhs = map (or . map fixedv) rows
+	colfixws = map (or . map fixedh) columns
+	--colfixhs = map (and . map fixedv) columns
+        h = sum rowhs
+        w = sum colws
+        toth = h + vsep
+        totw = w + hsep
+	tot = Point totw toth
+	totfh = and rowfixhs
+	totfw = and colfixws
+        rps = concatMap (\(r,p)->map (p+) (refpoints r)) (zip requests cellps)
+	  where	cellps = [Point x y | y<-place 0 sep rowhs,x<-place 0 sep colws]
+--	  where	cellps = [Point x y | y<-0:init rowhs,x<-0:init colws] --sep??
+        table2 (Rect (Point x0 y0) got@(Point width height)) =
+            let --Point extraw extrah = (got `psub` tot) --`pmax` origin
+#if 0
+-- old solution
+		rowhs' = arowhs height --pad flexh extrah rowhs rowfixhs
+		colws' = acolws width --pad flexw extraw colws colfixws
+#else
+-- new solution
+		((colws',rowhs'),(w',h')) =
+		  if width<=totw -- hmm...
+		  then (adjrowhs width,(width,sum rowhs'+vsep))
+		  else (adjcolws height,(sum colws'+hsep,height))
+#endif
+		colws'' = adjsizes (tr (width-w')) colws' colfixws
+		rowhs'' = adjsizes (tr (height-h')) rowhs' rowfixhs
+		xs = place x0 sep colws''
+		ys = place y0 sep rowhs''
+		placedrows =
+		  [[rR x y w h|(x,w)<-zip xs colws'']|(y,h)<-zip ys rowhs'']
+{- old
+		w' = sum colws'
+		h' = sum rowhs'
+		hscale,vscale :: Double
+                hscale = fromInt (width - hsep) / fromInt w'
+                vscale = fromInt (height - vsep) / fromInt h'
+                placecols x y h' [] = []
+                placecols x y h' (w' : ws) =
+                    let w'' = scale hscale w'
+                    in  rR x y w'' h' : placecols (x + w'' + sep) y h' ws
+                placerows y [] = []
+                placerows y (h' : hs) =
+                    let h'' = scale vscale h'
+                    in  placecols x0 y h'' colws' : placerows (y + h'' + sep) hs
+                placedrows = placerows y0 rowhs'
+-}
+
+                rectss =
+                    case ld of
+                      Horizontal -> placedrows
+                      Vertical -> transpose placedrows
+		rects = concat rectss
+            in (if length rects<length requests 
+	        then ctrace "tableP" (length requests,length rects)
+	        else id) $
+	       lhead requests rects
+
+	acolws aw = adjsizes (aw-totw) colws colfixws
+	arowhs ah = adjsizes (ah-toth) rowhs rowfixhs
+
+	adjsizes extra ss fixs = pad flex extra ss fixs
+	  where
+	    flex = sum [s | (s,fixed) <-zip ss fixs, not fixed]
+
+	    pad _    0     ws _ = ws
+	    pad 0    extra ws _ = ws
+	    pad flex extra (w:ws) (fixed:fs) =
+	      if fixed
+	      then w:pad flex extra ws fs
+	      else let e = (extra*w `quot` flex) `max` (-w)
+		   in w+e:pad (flex-w) (extra-e) ws fs
+	    pad _ _ _ _ = []
+
+	adjrowhs = memoInt adjrowhs'
+	adjrowhs' w = (colws,map maximum (transpose colhs))
+	  where colhs = [map (ycoord . flip wAdj colw) column |
+			  (colw,column) <- zip colws columns]
+	        colws = acolws w
+
+	adjcolws = memoInt adjcolws'
+	adjcolws' h = (map maximum (transpose rowws),rowhs)
+	  where rowws = [map (xcoord . flip hAdj rowh) row |
+			  (rowh,row) <- zip rowhs rows]
+		rowhs = arowhs h
+
+	wa w = ctrace "tablePwa" s s
+	  where s = Point w (vsep+h)
+	        h = sum (snd (adjrowhs w))
+{- --old:
+		h = sum . map maximum . transpose $ colhs
+		colhs =  [map (ycoord . flip wAdj colw) col |
+			  (colw,col) <- zip (acolws w) columns]
+-}
+	ha h = Point (hsep+w) h
+	  where w = sum (fst (adjcolws h))
+{- --old:
+		w = sum . map maximum . transpose $ rowws
+		rowws =  [map (xcoord . flip hAdj rowh) row |
+			  (rowh,row) <- zip (arowhs h) rows]
+-}
+    in ((refpLayout tot totfw totfh rps){wAdj=memoInt wa,hAdj=memoInt ha}, table2)
+
+place pos0 sep = snd . mapAccumL f pos0
+  where f pos size = (pos+size+sep,pos)
+
+#ifdef __NHC__
+fromInt = fromIntegral
+#endif
diff --git a/hsrc/layout/TryLayout.hs b/hsrc/layout/TryLayout.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/TryLayout.hs
@@ -0,0 +1,16 @@
+module TryLayout(tryLayoutK) where
+
+import FRequest
+--import Message
+import Cont
+import LayoutRequest
+--import Command
+--import Fudget
+--import Xtypes
+--import Event
+
+tryLayoutK lreq =
+  cmdContK (layoutRequestCmd lreq) $ \r ->
+  case r of
+    LEvt (LayoutSize s) -> Just s
+    _ -> Nothing
diff --git a/hsrc/layout/UserLayoutF.hs b/hsrc/layout/UserLayoutF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/layout/UserLayoutF.hs
@@ -0,0 +1,26 @@
+module UserLayoutF where
+import Fudget
+import FRequest
+--import Command
+--import Event
+import Geometry(Rect)
+--import CompOps
+import Spops(concatMapSP)
+import CompSP(preMapSP,serCompSP)
+import LayoutRequest
+--import Message(Message(..))
+
+userLayoutF :: F a b -> F (Either (Path,Rect) a) (Either (Path,LayoutMessage) b)
+userLayoutF (F fud) = F{-ff-} (concatMapSP post `serCompSP` fud `preMapSP` pre)
+  where
+    pre msg =
+      case msg of
+        High (Right x) -> High x
+	High (Left (p,place)) -> Low (p,LEvt (LayoutPlace place))
+	Low pev -> Low pev
+    post msg =
+      case msg of
+        High x -> [High (Right x)]
+	Low (p,LCmd req) -> [High (Left (p,req))]
+	--Low d@(p,XCmd DestroyWindow) -> [Low d] --,High (Left (p,LayoutDestroy))]
+	Low pcmd -> [Low pcmd]
diff --git a/hsrc/lowlevel/Cont.hs b/hsrc/lowlevel/Cont.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/Cont.hs
@@ -0,0 +1,97 @@
+module Cont(Cont(..),conts, tryM, cmdContF, cmdContK, cmdContK', waitForSP, waitForK, waitForF, waitForFu, cmdContSP,tryGet,getLeftSP,getRightSP,fContWrap,kContWrap,dropSP,contMap) where
+--import Direction
+import Fudget
+import Message(stripHigh, stripLow, aLow) --Message(..),
+import Path(here)
+--import SP
+import Spops
+import StreamProcIO
+import EitherUtils(stripLeft,stripRight)
+
+cmdContSP :: a -> (b -> Maybe c) -> Cont (SP b a) c
+cmdContSP cmd expected process =
+    putsSP [cmd] (waitForSP expected process)
+
+waitForSP expected process =
+    let contSP pending =
+            getSP (\msg ->
+                   case expected msg of
+                     Just answer -> startupSP (reverse pending) (process answer)
+                     Nothing -> contSP (msg : pending))
+    in  contSP []
+
+waitForK expected = kContWrap (waitForSP expected)
+
+waitForF :: (a -> Maybe b) -> Cont (F a c) b
+waitForF expected = fContWrap (waitForSP expectHigh)
+  where expectHigh msg = stripHigh msg >>= expected
+
+waitForFu :: (KEvent hi -> Maybe ans) -> Cont (F hi ho) ans
+waitForFu expected = fContWrap (waitForSP expectk)
+  where expectk = expected . aLow snd
+
+getLeftSP = waitForSP stripLeft
+getRightSP = waitForSP stripRight
+
+waitForLow expected = waitForSP expectLow
+  where expectLow msg = stripLow msg >>= expected
+
+cmdContLow cmd expected = putSP (Low cmd) . waitForLow expected
+
+{- old:
+cmdContLow cmd exp' =
+    cmdContSP (Low cmd)
+              (\msg ->
+               case msg of
+                 Low ev -> exp' ev
+                 _ -> Nothing)
+-}
+
+cmdContK :: FRequest -> (FResponse -> Maybe a) -> Cont (K b c) a
+cmdContK xcmd expected = kContWrap (cmdContLow xcmd expected)
+
+cmdContK' msg expected = kContWrap (cmdContSP msg expected)
+
+cmdContF :: FRequest -> (FResponse -> Maybe a) -> Cont (F b c) a
+cmdContF cmd exp' =
+    fContWrap $
+    cmdContLow (here, cmd)
+               (\tev ->
+                case tev of
+                  (t, ev) | t == here -> exp' ev
+                  _ -> Nothing)
+
+conts :: (a -> Cont c b) -> [a] -> Cont c [b]
+conts g sl c =
+    let co al [] = c (reverse al)
+        co al (s : sl') = g s (\a -> co (a : al) sl')
+    in  co [] sl
+
+tryM :: Cont c (Maybe a) -> c -> Cont c a
+tryM e errc c = e $ \ov ->
+                case ov of
+		   Nothing -> errc
+		   Just v -> c v
+
+tryGet :: Cont c (Maybe a) -> (Cont c a) -> Cont c a
+tryGet e errc c = tryM e (errc c) c
+
+dropSP expected c = dropit where
+    dropit =
+      getSP $ \msg ->
+      case expected msg of
+	Just m -> c m
+	Nothing -> dropit
+
+contMap op = m
+  where m = get $ \ x -> op x $ \ y -> put y $ m
+-- or:  where m = get $ flip op $ flip put m
+
+
+fContWrap :: Cont (FSP hi ho) a -> Cont (F hi ho) a
+fContWrap waitsp = F{-ff-} . waitsp . fContSP
+  where fContSP contF x = case contF x of F sp -> sp
+
+kContWrap :: Cont (KSP hi ho) a -> Cont (K hi ho) a
+kContWrap waitsp = K{-kk-} . waitsp . kContSP
+  where kContSP contK x = case contK x of K sp -> sp
diff --git a/hsrc/lowlevel/Display.hs b/hsrc/lowlevel/Display.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/Display.hs
@@ -0,0 +1,17 @@
+module Display(openDisplay) where
+import Command
+import Event
+--import Font(FontStruct)
+--import Fudget
+--import Geometry(Line, Point, Rect, Size(..))
+--import LayoutRequest(LayoutRequest)
+import Xrequest
+--import Xtypes
+
+-- DECONSTR :: (a<->b) -> b -> (Maybe a) 
+openDisplay name =
+    xrequestF (OpenDisplay name)
+              (let e (DisplayOpened a) = Just a
+                   e _ = Nothing
+               in  e)
+
diff --git a/hsrc/lowlevel/FudgetIO.hs b/hsrc/lowlevel/FudgetIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/FudgetIO.hs
@@ -0,0 +1,32 @@
+module FudgetIO where
+import Fudget
+import EitherUtils(Cont(..))
+import Message(stripLow,stripHigh)
+
+{-
+The purpose of the FudgetIO class is to allow the many IO operations that
+can be performed from both fudgets and fudget kernels, e.g., createGC,
+loadQueryFont and allocNamedColor, to use one overloaded name instead of
+two separate names.
+-}
+
+class FudgetIO f where
+  waitForMsg :: (KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
+  putMsg :: KCommand ho -> f hi ho -> f hi ho
+
+  -- Less useful methods:
+  --nullMsg :: f hi ho -- name ?!
+  --getMsg :: (KEvent hi -> f hi ho) -> f hi ho
+
+putMsgs msgs k = foldr putMsg k msgs
+putHigh x = (putMsg . High) x
+putLow x = (putMsg . Low) x
+putLows lows k = foldr putLow k lows
+
+getHigh x = waitForMsg stripHigh x
+getLow x = waitForMsg stripLow x
+
+cmdContMsg msg expected = putMsg msg . waitForMsg expected
+
+cmdContLow cmd expected = cmdContMsg (Low cmd) expectLow
+  where expectLow msg = stripLow msg >>= expected
diff --git a/hsrc/lowlevel/Srequest.hs b/hsrc/lowlevel/Srequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/Srequest.hs
@@ -0,0 +1,48 @@
+module Srequest(select,sIOsucc,sIOstr,sIOerr,sIO,Cont(..)) where
+import FRequest
+import FudgetIO
+import EitherUtils(Cont(..))
+--import NullF(F,K)
+import DialogueIO hiding (IOError) -- Select
+import ShowFailure
+
+sIOsucc sreq cont =
+  socketIO sreq sFail $ \ r ->
+  case r of
+    Left Success -> cont
+    Left r -> error ("sIOsucc: Expected Success, but got "++show r)
+    Right r -> error ("sIOsucc: Expected Success, but got "++show r)
+
+sIO sreq = sIOerr sreq sFail
+
+sIOerr sreq fcont rcont =
+    socketIO sreq fcont $ \ r ->
+    case r of
+      Right sr -> rcont sr
+      Left dr -> error ("Socket IO: expected a SocketResponse, but got "++show dr)
+
+sIOstr sreq cont =
+  socketIO sreq sFail $ \ r ->
+  case r of
+    Left (Str s) -> cont s
+    Left r -> error ("sIOsucc: Expected Str, but got "++show r)
+    Right r -> error ("sIOsucc: Expected Str, but got "++show r)
+    
+---
+
+sFail f = error ("Socket IO error: "++showFailure f)
+
+socketIO sreq econt scont =
+    cmdContLow (SReq sreq) expect $ either econt scont
+  where expect msg =
+          case msg of
+            SResp sr -> Just (Right (Right sr))
+	    DResp (Failure f) -> Just (Left f)
+	    DResp r -> Just (Right (Left r))
+            _ -> Nothing
+
+----
+
+select ds = putLow . DReq . Select $ ds
+ -- no response from Select
+-- eta expanded because of the monomorphism restriction
diff --git a/hsrc/lowlevel/TagEvents.hs b/hsrc/lowlevel/TagEvents.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/TagEvents.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE CPP #-}
+module TagEvents(tagEventsSP) where
+import Command
+import CompSP(preMapSP,serCompSP)
+import SpEither(mapFilterSP)
+import Cont(cmdContSP)
+import CmdLineEnv(argFlag)
+--import Direction
+import Event
+--import Font(FontStruct)
+import Fudget
+import FRequest
+--import Geometry(Line, Point, Rect, Size(..))
+import IOUtil(getEnvi)
+--import LayoutRequest(LayoutRequest)
+import Loopthrough
+import Message(stripLow) --Message(..),
+import Path
+import WindowF(autumnize)
+import ShowCommandF
+import Sockets
+import Spops
+import Tables
+--import Version
+import Xtypes
+--import Maptrace
+--import EitherUtils
+import Data.Maybe(isNothing)
+import ShowFailure
+import DialogueIO
+import Prelude hiding (IOError)
+
+--mtrace = ctrace "tagEvents"
+mtrace x y = y
+
+tagEventsSP :: F i o -> SP (Path, Response) (Path, Request)
+tagEventsSP mainF =
+    loopThroughRightSP
+      tagEventsCtrlSP
+      (mapFilterSP stripLow `serCompSP` mainFSP `preMapSP` Low)
+  where
+    F mainFSP = traceit mainF
+
+openDisplay' cont =
+    if isNothing (getEnvi "DISPLAY")
+    then cont faildisp
+    else
+    cmdContSP (tox $ XRequest (noDisplay, noWindow, OpenDisplay ""))
+              (\e ->
+               case e of
+                 Right (_, XResponse (DisplayOpened d)) -> Just d
+                 Right (_, Failure f) -> error ("Cannot open the display (the program is probably not linked with the X routines): "++showFailure f)
+                 _ -> Nothing)
+              (\disp ->
+               if disp == Display 0 then
+                   error "Cannot open display"
+               else
+                   putSP (tox $ Select [DisplayDe disp]) $ cont disp)
+  where faildisp = error "the environment variable DISPLAY is not set!"
+        tox x = Right (here,x)
+
+tagEventsCtrlSP::
+    SP (Either TCommand (Path,Response)) (Either TEvent (Path,Request))
+tagEventsCtrlSP =
+    openDisplay' tagEventsCtrlSP'
+  where
+    tagEventsCtrlSP' disp =
+	tagSP noSel Nothing path2wid0 wid2path0
+      where
+	noSel = here
+	tagSP selp grabpath path2wid wid2path =
+	  let same = tagSP selp grabpath path2wid wid2path
+	      tagSPs = tagSP selp
+	      tagSPns s = tagSP s grabpath path2wid wid2path
+	  in getSP $ \msg -> case msg of
+	    Left (path', cmd) ->
+	      let newwindow path'' wid = 
+		    putSP (Left (path'', XResp (WindowCreated wid))) $
+		    tagAdd path'' wid
+		  tox xc = Right (path',xc)
+		  convertcmd = convert (lookupWid path2wid path')
+		  convert w cmd = putSP (tox (XCommand (disp, w, cmd)))
+		  tagAdd p w = tagSPs grabpath (updateWid path2wid p w) 
+					       (updatePath wid2path w p)
+	      in case cmd of
+		 XCmd xcmd@(SetSelectionOwner s atom) ->
+		 -- currently, different selections are not distinguished
+		   convertcmd xcmd $ 
+		   (if s && selp /= noSel && path' /= selp then 
+		       putSP (Left (selp,XEvt (SelectionClear atom))) else id) $
+		   tagSPns (if s then path' else noSel)
+		 XCmd (ReparentToMe rchild w) -> 
+		   -- lookup w in table, change path to rchild, emit reparent cmd
+		   -- TODO: change subpaths too!
+		   let npath' = newChildPath path' rchild
+		       npath = autumnize npath' -- used in repTest (?)
+		       wpath = lookupPath wid2path w
+		       opath = autumnize wpath
+		       nparent = lookupWid path2wid path'
+		       npath2wid = moveWids path2wid opath npath
+		       nwid2path = movePaths wid2path opath npath
+		   in convert w (ReparentWindow nparent) $
+		      if null wpath
+		      then {-ctrace "rep" (npath',opath,w) $-} tagAdd npath' w
+		      else tagSPs grabpath npath2wid nwid2path
+		 XCmd (SelectWindow w) -> tagAdd path' w
+		 XCmd GetWindowId -> putSP (Left (path',XEvt (YourWindowId wid))) same
+		     where wid = lookupWid path2wid path'
+		 XCmd DestroyWindow ->
+		   putsSP [tox (XCommand (disp, wid, DestroyWindow))
+			  | wid <- subWids path2wid path']
+			 (tagSPs grabpath (pruneWid path2wid path') wid2path)
+		 XCmd (GrabEvents toMe) -> mtrace ("Grab",toMe,msg) $
+		   tagSPs (Just (toMe,path',autumnize path')) path2wid wid2path
+		 XCmd UngrabEvents -> tagSPs Nothing path2wid wid2path
+		 --DoXCommands xcmds -> foldr convertcmd same xcmds
+		 XCmd (DrawMany w gcdcmdss) | not optimizeDrawMany ->
+		    foldr convertcmd same
+		      [Draw w gc dcmd | (gc,dcmds)<-gcdcmdss,dcmd<-dcmds]
+		 XCmd xcmd -> convertcmd xcmd same
+		 DReq req -> putSP (tox req) same
+		 SReq sreq -> putSP (tox (SocketRequest sreq)) same
+		 XReq xreq ->
+		   case xreq of
+		     CreateMyWindow _ -> error "GUI fudget outside a shell fudget"
+		     CreateSimpleWindow rchild _ ->
+			createWindow disp xreq (lookupWid path2wid path')
+				      (newwindow (newChildPath path' rchild))
+		     CreateRootWindow _ _ -> 
+			 createWindow disp xreq rootWindow (newwindow path')
+		     _ -> putSP (tox (XRequest (disp, 
+				  lookupWid path2wid path', xreq))) same
+		 LCmd _ -> same -- layout pseudo command
+	    Right (path', resp) -> case resp of
+	      AsyncInput (_, XEvent (wid, event)) ->
+		case event of
+		  MappingNotify -> same
+		  ButtonEvent {} -> checkGrab
+		  KeyEvent {} -> checkGrab
+		  MotionNotify {} -> checkGrab
+		  SelectionClear atom -> pass $ tagSPns noSel
+		  DestroyNotify w -> if argFlag "destroyPrune" False then
+		     pass $ tagSPs grabpath path2wid' (prunePath wid2path w)
+		    else passame
+		    where path2wid' = if null path2' then path2wid
+						    else pruneWid path2wid path2'
+		  _ -> passame
+		where path2' = lookupPath wid2path wid
+		      passto p = putSP (Left (p, XEvt event))
+		      pass = passto path2'
+		      passame = pass same
+		      checkGrab = case grabpath of
+				    Nothing -> passame
+				    Just (toMe,kpath,path) -> 
+				      if path `subPath` path2' then passame
+				      else if toMe then passto kpath same
+					   else same
+              XResponse xresp -> putSP (Left (path',XResp xresp)) same
+	      SocketResponse sresp -> putSP (Left (path',SResp sresp)) same
+	      _ -> putSP (Left (path', DResp resp)) same
+
+newChildPath parent rchild = absPath (autumnize parent) rchild
+  
+createWindow disp xreq wid cont =
+    cmdContSP (Right (here, XRequest (disp, wid, xreq)))
+              (\msg -> case msg of
+                         Right (_, XResponse (WindowCreated wid')) -> Just wid'
+                         _ -> Nothing)
+              cont
+
+traceit = showCommandF "debug"
+
+optimizeDrawMany =
+  argFlag "optdrawmany"
+#ifdef __GLASGOW_HASKELL__
+    True
+#else
+    False
+#warning "not optimising DrawMany"
+#endif
diff --git a/hsrc/lowlevel/WindowF.hs b/hsrc/lowlevel/WindowF.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/WindowF.hs
@@ -0,0 +1,148 @@
+module WindowF(adjustBorderWidth,border_width,getBWidth,kernelF, toKernel, kernelTag,autumnize, windowKF) where
+import Command
+import CompOps((>+<))
+import CompSP(prepostMapSP)
+--import CompSP(serCompSP)
+import Utils(pair,mapList)
+import Direction
+import Event
+--import Font(FontStruct)
+import Fudget
+import FRequest
+import Geometry(Point(..), Rect(..), origin, padd, pmax, rR)
+import LayoutRequest
+import LoopLow
+--import Message(Message(..))
+import NullF
+import Path
+--import SerCompF(idRightF)
+import CompFfun(prepostMapLow)
+import Spops
+--import EitherUtils
+import Data.Maybe(fromMaybe,isJust)
+import Xtypes
+import CmdLineEnv(argFlag)
+--import DialogueIO hiding (IOError)
+
+kernelF :: (K a b) -> F a b
+kernelF (K proc) =
+    let prep (High a) = High a
+        prep (Low (_, b)) = Low b
+        post (High a) = High a
+        post (Low b) = Low (here, b)
+    in  {-F-}ff (prepostMapSP prep post proc)
+
+toLowHere = mapList (Low . pair here)
+
+winF :: (Rect -> FRequest) -> [FRequest] -> Rect -> K a b -> F a b
+winF winCmd startcmds rect w =
+    putMessagesF (toLowHere (winCmd rect : startcmds)) (kernelF w)
+
+newKTag = not (argFlag "oldKTag" True) -- trouble with autolayout...
+
+kernelTag = if newKTag then here else turn L here
+autumnize  = if newKTag then id else autumnize' where
+  autumnize' [] = []
+  autumnize' l = (reverse . tail . reverse) l
+
+
+toKernel x = mapList (Low . pair kernelTag) x
+
+getBWidth cws = case cws of
+   [] -> Nothing
+   CWBorderWidth bw':_ -> Just bw'
+   _:cws -> getBWidth cws
+
+adjustBorderWidth b (Point x y) = Point (x+b2) (y+b2) where b2 = 2*b
+
+border_width = 0::Int -- Should agree with the value in the core for XCreateSimpleWindow in xdecode.c and ghc-dialogue/DoXRequest.hs
+
+windowKF :: (Rect -> FRequest) -> Bool -> Bool -> [FRequest] -> Maybe Rect -> K a b -> F c d -> F (Either a c) (Either b d)
+windowKF winCmd isShell nomap startcmds oplace k f =
+ let ctrlSP (bw,nomap) =
+       getSP $ \msg ->
+       let same = ctrlSP (bw,nomap)
+           pass = putSP msg 
+	   passame = pass same
+	   adjB b s = if isShell then s else adjustBorderWidth b s
+       in case msg of
+         Left (tag,cmd) -> case cmd of
+            XReq (CreateMyWindow r) | tag /= kernelTag ->
+		   putSP (Left (kernelTag, 
+	                    XReq (CreateSimpleWindow tag r))) same
+	    XCmd (ReparentToMe r w) | r == here && tag /= kernelTag ->
+		   putSP (Left (kernelTag,XCmd (ReparentToMe tag w))) same
+            XCmd (ConfigureWindow cws) | tag == kernelTag -> 
+	        -- hopefully, this occurs before LayoutMsg
+		let bw' = fromMaybe bw (getBWidth cws) in
+		if bw'==bw' then pass $ ctrlSP (bw',nomap) else error "windowKF"
+            LCmd (LayoutRequest req) ->
+	        putSP (Left (tag,layoutRequestCmd (mapLayoutSize (adjB bw) req))) $
+		same
+	    _ -> passame
+	 Right (tag,evt) -> case evt of
+	    XResp (WindowCreated _) | tag==kernelTag -> same 
+	    -- does not correspond to internal request
+            LEvt (LayoutPlace (Rect p s)) -> let ads = adjB (-bw) s in
+	       putsSP ([Right (tag, LEvt (LayoutPlace (Rect origin ads))),
+		      Right (kernelTag, LEvt (LayoutSize ads)),
+		      Right (kernelTag, LEvt (LayoutPos p))] ++   -- TH 990321
+		       (if isShell then []
+		        else mapList (Left. pair kernelTag)
+			         ([XCmd $ moveResizeWindow (checkSize (Rect p ads))] ++
+			          (if nomap || static then []
+				   else [XCmd MapRaised])))) $
+               ctrlSP (bw,True)
+	    -- The LayoutSize message is not sent by the ordinary layout
+	    -- system, but by popupGroupF for convenience, to resize the
+	    -- window without moving it.
+            LEvt (LayoutSize s) -> let ads = adjB (-bw) s in
+	       putsSP ([Right (tag, LEvt (LayoutPlace (Rect origin ads))),
+		      Right (kernelTag, LEvt (LayoutSize ads))] ++
+		       (if isShell then []
+		        else [(Left. pair kernelTag)
+			        (XCmd $ resizeWindow (pmax ads minSize))])) $
+               same
+	    _ -> passame
+
+     minSize = Point 1 1
+     checkSize (Rect p s) = Rect p (pmax s minSize)
+     static = isJust oplace
+     startplace =
+	 case oplace of
+	   Nothing -> rR 0 0 10 10
+	   Just p -> p
+     statlimits (Rect p s) = layoutRequestCmd (plainLayout (padd p s) True True)
+     wf =
+	 winF winCmd
+	      (startcmds ++
+	       (case oplace of
+		  Nothing -> []
+		  Just r -> [statlimits r] ++
+			    (if nomap then [] else [XCmd MapRaised])))
+	      startplace
+	      k
+     wff = adjTag (wf>+<f)
+     adjTag = if newKTag then prepostMapLow addktag removektag else id where
+	    addktag ([],m) = ([L],m)
+	    addktag tm = tm
+	    removektag ([L],m) = ([],m)
+	    removektag tm = tm
+
+     windowf = loopThroughLowF (ctrlSP (border_width,nomap)) wff
+     --windowf = windowf' ctrlSP nomap wf f
+ in  case oplace of
+          Nothing -> windowf
+          Just place -> let prep' (High ltag) = [(ltag, LEvt (LayoutPlace place))]
+                            prep' (Low (_, LEvt (LayoutPlace _))) = []
+                            prep' (Low msg) = [msg]
+                            post' (ltag, LCmd _) = [High ltag]
+                            post' cmd = [Low cmd]
+                        in  loopLow (concmapSP post') (concmapSP prep') windowf
+
+{-
+windowf' ctrlSP nomap wf f =
+  let wff = wf>+<f
+      windowf = loopThroughLowF (ctrlSP (border_width,nomap)) wff
+  in windowf
+--}
diff --git a/hsrc/lowlevel/Xcommand.hs b/hsrc/lowlevel/Xcommand.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/Xcommand.hs
@@ -0,0 +1,15 @@
+module Xcommand(
+  xcommand,xcommandK,xcommandF,
+  xcommands,xcommandsK,xcommandsF) where
+import FRequest
+import FudgetIO
+import NullF(F,K)
+
+xcommandK = xcommand :: (XCommand -> K i o -> K i o)
+xcommandF = xcommand :: (XCommand -> F i o -> F i o)
+
+xcommandsK = xcommands :: ([XCommand] -> K i o -> K i o)
+xcommandsF = xcommands :: ([XCommand] -> F i o -> F i o)
+
+xcommand xcmd = putLow (XCmd xcmd)
+xcommands xcmds = putLows (map XCmd xcmds)
diff --git a/hsrc/lowlevel/Xrequest.hs b/hsrc/lowlevel/Xrequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/lowlevel/Xrequest.hs
@@ -0,0 +1,31 @@
+module Xrequest(xrequest,xrequestF, xrequestK,Cont(..)) where
+--import Command(XRequest)
+--import Event(XResponse)
+import FRequest
+import FudgetIO
+import EitherUtils(Cont(..))
+import NullF(F,K)
+--import DialogueIO hiding (IOError)
+
+xrequestK = xrequest :: (XRequest -> (XResponse -> Maybe a) -> Cont (K b c) a)
+xrequestF = xrequest :: (XRequest -> (XResponse -> Maybe a) -> Cont (F b c) a)
+
+xrequest xreq expected = cmdContLow (XReq xreq) expectXResp
+  where expectXResp msg =
+          case msg of
+            XResp xr -> expected xr
+            _ -> Nothing
+
+{- old:
+xrequestK = xrequest cmdContK
+
+xrequestF = xrequest cmdContF
+
+xrequest k cmd exp' =
+    k (DoXRequest cmd)
+      (\msg ->
+       case msg of
+         IOResponse (XResponse xr) -> exp' xr
+         _ -> Nothing)
+
+-}
diff --git a/hsrc/sp/CompSP.hs b/hsrc/sp/CompSP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/CompSP.hs
@@ -0,0 +1,156 @@
+module CompSP(prepostMapSP, postMapSP, preMapSP, idRightSP, idLeftSP, idHighSP,
+              idLowSP, compMsgSP, compSP, compEitherSP, serCompSP) where
+import Message(Message(..))
+import SP
+import Spops
+
+--serCompSP :: SP b c -> SP a b -> SP a c
+serCompSP sp1 sp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP y (serCompSP sp1' sp2)
+      GetSP xsp1 -> serCompSP1 xsp1 sp2
+      NullSP -> NullSP
+
+serCompSP1 xsp1 sp2 =
+    case sp2 of
+      PutSP y sp2' -> serCompSP (xsp1 y) sp2'
+      GetSP xsp2 -> GetSP (serCompSP1 xsp1 . xsp2)
+      NullSP -> NullSP
+
+---
+
+compSP = compEitherSP
+
+--compEitherSP :: SP a1 b1 -> SP a2 b2 -> SP (Either a1 a2) (Either b1 b2)
+compEitherSP sp1 sp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Left y) (compEitherSP sp1' sp2)
+      GetSP xsp1 -> compEitherSP1 xsp1 sp2
+      NullSP -> rEitherSP sp2
+
+--and compEitherSP1 :: (*a1->SP *a1 *b1) -> SP *a2 *b2 -> SP (Either *a1 *a2) (Either *b1 *b2)
+compEitherSP1 xsp1 sp2 =
+    case sp2 of
+      PutSP y sp2' -> PutSP (Right y) (compEitherSP1 xsp1 sp2')
+      GetSP xsp2 -> compEitherSP12 xsp1 xsp2
+      NullSP -> lEitherSP (GetSP xsp1)
+
+--and compEitherSP2 :: (SP *a1 *b1) -> (*a2->SP *a2 *b2) -> SP (Either *a1 *a2) (Either *b1 *b2)
+compEitherSP2 sp1 xsp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Left y) (compEitherSP2 sp1' xsp2)
+      GetSP xsp1 -> compEitherSP12 xsp1 xsp2
+      NullSP -> rEitherSP (GetSP xsp2)
+
+--and compEitherSP12 :: (*a1->SP *a1 *b1) -> (*a2->SP *a2 *b2) -> SP (Either *a1 *a2) (Either *b1 *b2)
+compEitherSP12 xsp1 xsp2 =
+    GetSP (\x ->
+           case x of
+             Left a -> compEitherSP2 (xsp1 a) xsp2
+             Right b -> compEitherSP1 xsp1 (xsp2 b))
+
+lEitherSP sp1 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Left y) (lEitherSP sp1')
+      GetSP xsp1 -> lEitherSP1 xsp1
+      NullSP -> NullSP
+
+lEitherSP1 xsp1 =
+    GetSP (\x ->
+           case x of
+             Left a -> lEitherSP (xsp1 a)
+             Right b -> lEitherSP1 xsp1)
+
+rEitherSP sp2 =
+    case sp2 of
+      PutSP y sp2' -> PutSP (Right y) (rEitherSP sp2')
+      GetSP xsp2 -> rEitherSP2 xsp2
+      NullSP -> NullSP
+
+rEitherSP2 xsp2 =
+    GetSP (\x ->
+           case x of
+             Right a -> rEitherSP (xsp2 a)
+             Left b -> rEitherSP2 xsp2)
+
+---
+--and preMapSP :: SP *b *c -> (*a->*b) -> SP *a *c
+preMapSP sp pre =
+    case sp of
+      PutSP y sp' -> PutSP y (preMapSP sp' pre)
+      GetSP xsp -> GetSP (\x -> preMapSP (xsp (pre x)) pre)
+      NullSP -> NullSP
+
+--and postMapSP :: (*b->*c) -> SP *a *b -> SP *a *c
+postMapSP post sp =
+    case sp of
+      PutSP y sp' -> PutSP (post y) (postMapSP post sp')
+      GetSP xsp -> GetSP (\x -> postMapSP post (xsp x))
+      NullSP -> NullSP
+
+prepostMapSP pre post sp =
+    case sp of
+      PutSP y sp' -> PutSP (post y) (prepostMapSP pre post sp')
+      GetSP xsp -> GetSP (\x -> prepostMapSP pre post (xsp (pre x)))
+      NullSP -> NullSP
+
+---
+idLowSP sp = compMsgSP idSP sp
+
+idHighSP sp = compMsgSP sp idSP
+
+idLeftSP sp = compEitherSP idSP sp
+
+idRightSP sp = compEitherSP sp idSP
+
+---
+--and compMsgSP :: SP *a1 *b1 -> SP *a2 *b2 -> SP (Message *a1 *a2) (Message *b1 *b2)
+-- compMsgSP was constructed from compEitherSP with some global substitutions
+compMsgSP sp1 sp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Low y) (compMsgSP sp1' sp2)
+      GetSP xsp1 -> compMsgSP1 xsp1 sp2
+      NullSP -> rMsgSP sp2
+
+compMsgSP1 xsp1 sp2 =
+    case sp2 of
+      PutSP y sp2' -> PutSP (High y) (compMsgSP1 xsp1 sp2')
+      GetSP xsp2 -> compMsgSP12 xsp1 xsp2
+      NullSP -> lMsgSP (GetSP xsp1)
+
+compMsgSP2 sp1 xsp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Low y) (compMsgSP2 sp1' xsp2)
+      GetSP xsp1 -> compMsgSP12 xsp1 xsp2
+      NullSP -> rMsgSP (GetSP xsp2)
+
+compMsgSP12 xsp1 xsp2 =
+    GetSP (\x ->
+           case x of
+             Low a -> compMsgSP2 (xsp1 a) xsp2
+             High b -> compMsgSP1 xsp1 (xsp2 b))
+
+lMsgSP sp1 =
+    case sp1 of
+      PutSP y sp1' -> PutSP (Low y) (lMsgSP sp1')
+      GetSP xsp1 -> lMsgSP1 xsp1
+      NullSP -> NullSP
+
+lMsgSP1 xsp1 =
+    GetSP (\x ->
+           case x of
+             Low a -> lMsgSP (xsp1 a)
+             High b -> lMsgSP1 xsp1)
+
+rMsgSP sp2 =
+    case sp2 of
+      PutSP y sp2' -> PutSP (High y) (rMsgSP sp2')
+      GetSP xsp2 -> rMsgSP2 xsp2
+      NullSP -> NullSP
+
+rMsgSP2 xsp2 =
+    GetSP (\x ->
+           case x of
+             High a -> rMsgSP (xsp2 a)
+             Low b -> rMsgSP2 xsp2)
+
diff --git a/hsrc/sp/Dynforkmerge.hs b/hsrc/sp/Dynforkmerge.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/Dynforkmerge.hs
@@ -0,0 +1,34 @@
+module Dynforkmerge(DynMsg(..), DynSPMsg(..), dynforkmerge) where
+import SP
+import Utils(part)
+
+data DynMsg a b = DynCreate b |
+                  DynDestroy |
+                  DynMsg a 
+                  deriving (Eq, Ord)
+
+type DynSPMsg a b = DynMsg a (SP a b)
+
+dynforkmerge :: Eq a => SP (a, DynSPMsg b c) (a, c)
+dynforkmerge = dfm []
+
+dfm dynxsps =
+    GetSP (\msg ->
+           case msg of
+             (t, DynCreate dynsp) -> dfmout t dynsp dynxsps
+             (t, DynMsg msg') -> dfmin t msg' dynxsps
+             (t, DynDestroy) -> dfmrm t dynxsps)
+
+dfmout t dynsp dynxsps =
+    case dynsp of
+      PutSP y sp' -> PutSP (t, y) (dfmout t sp' dynxsps)
+      GetSP xsp -> dfm ((t, xsp) : dynxsps)
+      NullSP -> dfm dynxsps
+
+dfmin t msg dynxsps =
+    case part ((== t) . fst) dynxsps of
+      ([], _) -> dfm dynxsps
+      ([(_, xsp)], dynxsps') -> dfmout t (xsp msg) dynxsps'
+      _ -> error "Same tag used twice in dynforkmerge (or dynListF)."
+
+dfmrm t dynxsps = dfm (filter ((t /=) . fst) dynxsps)
diff --git a/hsrc/sp/IdempotSP.hs b/hsrc/sp/IdempotSP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/IdempotSP.hs
@@ -0,0 +1,17 @@
+module IdempotSP where
+import Spops(getSP,putSP)
+import SP(SP)
+
+idempotSP :: Eq a => SP a a
+idempotSP =
+    getSP $ \ x ->
+    putSP x $
+    idempotSP' x
+  where
+    idempotSP' x =
+      getSP $ \ x' ->
+      (if x'==x
+       then id
+       else putSP x') $
+      idempotSP' x'
+
diff --git a/hsrc/sp/InputSP.hs b/hsrc/sp/InputSP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/InputSP.hs
@@ -0,0 +1,70 @@
+module InputSP where
+import InputMsg
+import Spops
+import CompSP(serCompSP)
+import SpEither(mapFilterSP)
+import Utils(replace,setFst,setSnd)
+
+-- New version: works with abstract InputMsg.
+inputPairSP = mapFilterSP lift `serCompSP` ipSP (Nothing,Nothing)
+  where
+    ipSP optvalues = getSP $ either (change setFst) (change setSnd)
+      where
+	change setOne inputmsg =
+	    putSP (mapInp (const optvalues') inputmsg) $
+	    ipSP optvalues'
+	  where
+	    optvalues' = setOne optvalues (Just $ stripInputMsg inputmsg)
+
+    lift = liftMaybeInputMsg . mapInp liftMaybePair
+
+    liftMaybePair (Just x,Just y) = Just (x,y)
+    liftMaybePair _               = Nothing
+
+    liftMaybeInputMsg m = fmap im (stripInputMsg m)
+      where im x = mapInp (const x) m
+
+{- -- old version:
+inputPairSP = ipSP Nothing Nothing
+  where
+    ipSP optx opty =
+        getSP $ \msg ->
+          case msg of
+	    Left (InputChange x) -> changeL InputChange x
+	    Left (InputDone k x) -> changeL (InputDone k) x
+	    Right (InputChange y) -> changeR InputChange y
+	    Right (InputDone k y) -> changeR (InputDone k) y
+      where
+        changeL f x =
+            case opty of
+	      Just y -> putsSP [f (x,y)] cont
+	      Nothing -> cont
+	  where cont = ipSP (Just x) opty
+        changeR f y =
+            case optx of
+	      Just x -> putsSP [f (x,y)] cont
+	      Nothing -> cont
+	  where cont = ipSP optx (Just y)
+-}
+
+inputListSP tags = ilSP [(tag,Nothing)|tag<-tags]
+  where
+    ilSP acc =
+        getSP $ \(t,msg) ->
+          case msg of
+	    InputChange x -> change t InputChange x
+	    InputDone k x -> change t (InputDone k) x
+      where
+        change t f x = putsSP [f [(t,x)|(t,Just x)<-acc']] (ilSP acc')
+	  where acc' = replace (t,Just x) acc
+
+
+stripInputSP = mapFilterSP notLeave
+  where 
+    notLeave (InputChange s) = Just s
+    notLeave (InputDone k s) = if k == inputLeaveKey
+                               then Nothing
+			       else Just s
+
+inputDoneSP = mapFilterSP inputDone
+inputLeaveDoneSP = mapFilterSP inputLeaveDone
diff --git a/hsrc/sp/Loop.hs b/hsrc/sp/Loop.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/Loop.hs
@@ -0,0 +1,69 @@
+module Loop(loopLeftSP,loopSP,loopOnlySP) where
+import SP
+import Queue
+
+-- New versions with explicit queues for improved efficiency:
+-- (Adding a message to the loop queue is O(1) instead of O(n), n=queue length.)
+
+loopLeftSP sp = llSP empty sp
+  where
+    llSP q sp =
+      case sp of
+	PutSP (Right out) sp' -> PutSP out (llSP q sp')
+	PutSP (Left loop') sp' -> llSP (enter q loop') sp'
+	GetSP xsp ->
+	  case qremove q of
+	    Just (loop',q') -> llSP q' (xsp (Left loop'))
+	    Nothing -> GetSP (loopLeftSP.xsp.Right)
+	NullSP -> NullSP
+
+loopSP sp = lSP empty sp
+  where
+    lSP q sp =
+      case sp of
+	PutSP x sp' -> PutSP x (lSP (enter q x) sp')
+	GetSP xsp ->
+	  case qremove q of
+	    Just (x,q') -> lSP q' (xsp x)
+	    Nothing -> GetSP (loopSP.xsp)
+	NullSP -> NullSP
+
+loopOnlySP sp = loSP empty sp
+  where
+    loSP q sp =
+      case sp of
+	PutSP x sp' -> loSP (enter q x) sp'
+	GetSP xsp ->
+	  case qremove q of
+	    Just (x,q') -> loSP q' (xsp x)
+	    Nothing -> GetSP (loopOnlySP.xsp)
+	NullSP -> NullSP
+
+
+{--- old:
+
+loopLeftSP sp =
+    case sp of
+      PutSP (Right out) sp' -> PutSP out (loopLeftSP sp')
+      PutSP (Left loop') sp' -> loopLeftSP (feed1SP (Left loop') sp')
+      GetSP xsp -> GetSP (loopLeftSP.xsp.Right)
+      NullSP -> NullSP
+
+loopSP sp =
+  case sp of
+    PutSP x sp' -> PutSP x (loopSP (feed1SP x sp'))
+    GetSP xsp -> GetSP (loopSP.xsp)
+    NullSP -> NullSP
+
+loopOnlySP sp =
+  case sp of
+    PutSP x sp' -> loopOnlySP (feed1SP x sp')
+    GetSP xsp -> GetSP (loopOnlySP.xsp)
+    NullSP -> NullSP
+
+feed1SP x sp =
+    case sp of
+      PutSP y sp' -> PutSP y (feed1SP x sp')
+      GetSP xsp' -> xsp' x
+      NullSP -> NullSP
+-}
diff --git a/hsrc/sp/Loopthrough.hs b/hsrc/sp/Loopthrough.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/Loopthrough.hs
@@ -0,0 +1,79 @@
+module Loopthrough(loopThroughRightSP) where
+import SP
+--import Spops
+import Queue
+
+loopThroughRightSP sp1 sp2 = ltrSP empty sp1 sp2
+
+-- When sp1 and sp2 are unknown:
+ltrSP q sp1 sp2 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (ltrSP q sp1' sp2)
+      PutSP (Left loop') sp1' -> ltrSP (enter q loop') sp1' sp2
+      GetSP xsp1 -> ltrSP1 q xsp1 sp2
+      NullSP -> NullSP
+
+-- When sp1 is waiting for input:
+ltrSP1 q xsp1 sp2 =
+    case sp2 of
+      PutSP x sp2' -> ltrSP q (xsp1 (Left x)) sp2'
+      GetSP xsp2 ->
+	case qremove q of
+	  Just (x,q') -> ltrSP1 q' xsp1 (xsp2 x)
+	  Nothing -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)
+      NullSP -> GetSP (lltrSP . xsp1 . Right)
+
+-- When sp2 is waiting for input:
+ltrSP2 sp1 xsp2 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (ltrSP2 sp1' xsp2)
+      PutSP (Left loop') sp1' -> loopThroughRightSP sp1' (xsp2 loop')
+      GetSP xsp1 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)
+      NullSP -> NullSP
+
+-- When sp2 has terminated:
+lltrSP sp1 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (lltrSP sp1')
+      PutSP (Left loop') sp1' -> lltrSP sp1'
+      GetSP xsp1 -> GetSP (lltrSP . xsp1 . Right)
+      NullSP -> NullSP
+
+{- old (inefficient queueing and too strict in sp2):
+
+loopThroughRightSP sp1 sp2 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (loopThroughRightSP sp1' sp2)
+      PutSP (Left loop') sp1' -> case sp2 of
+                                  GetSP xsp2 -> loopThroughRightSP sp1'
+                                                                   (xsp2 loop')
+                                  NullSP -> lltrSP sp1'
+                                  _ -> loopThroughRightSP sp1'
+                                                          (feedSP' loop' [] sp2)
+      GetSP xsp1 -> ltrSP1 xsp1 sp2
+      NullSP -> NullSP
+
+ltrSP1 xsp1 sp2 =
+    case sp2 of
+      PutSP x sp2' -> loopThroughRightSP (xsp1 (Left x)) sp2'
+      GetSP xsp2 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)
+      NullSP -> GetSP (lltrSP . xsp1 . Right)
+
+ltrSP2 sp1 xsp2 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (ltrSP2 sp1' xsp2)
+      PutSP (Left loop') sp1' -> loopThroughRightSP sp1' (xsp2 loop')
+      GetSP xsp1 -> GetSP (\x -> ltrSP2 (xsp1 (Right x)) xsp2)
+      NullSP -> NullSP
+
+lltrSP sp1 =
+    case sp1 of
+      PutSP (Right out) sp1' -> PutSP out (lltrSP sp1')
+      PutSP (Left loop') sp1' -> lltrSP sp1'
+      GetSP xsp1 -> GetSP (lltrSP . xsp1 . Right)
+      NullSP -> NullSP
+
+-- normal code
+feedSP' = feedSP
+
+-}
diff --git a/hsrc/sp/ParSP.hs b/hsrc/sp/ParSP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/ParSP.hs
@@ -0,0 +1,21 @@
+module ParSP(seqSP, parSP) where
+import SP
+
+parSP sp1 sp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP y (parSP sp1' sp2)
+      GetSP xsp1 -> parSP1 xsp1 sp2
+      NullSP -> sp2
+
+parSP1 xsp1 sp2 =
+    case sp2 of
+      PutSP y sp2' -> PutSP y (parSP1 xsp1 sp2')
+      GetSP xsp2 -> GetSP (\x -> parSP (xsp1 x) (xsp2 x))
+      NullSP -> GetSP xsp1
+
+seqSP sp1 sp2 =
+    case sp1 of
+      PutSP y sp1' -> PutSP y (seqSP sp1' sp2)
+      GetSP xsp -> GetSP (\x -> seqSP (xsp x) sp2)
+      NullSP -> sp2
+
diff --git a/hsrc/sp/SP.hs b/hsrc/sp/SP.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/SP.hs
@@ -0,0 +1,8 @@
+module SP where
+import ShowFun() -- show instance for function types
+
+data SP a b = PutSP b (SP a b) |
+              GetSP (a -> SP a b) |
+              NullSP 
+          deriving (Show)
+
diff --git a/hsrc/sp/SPmonad.hs b/hsrc/sp/SPmonad.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/SPmonad.hs
@@ -0,0 +1,26 @@
+module SPmonad where
+import SP(SP)
+import ParSP(seqSP)
+import Spops
+import StateMonads(Mk(..),toMkc) --,bmk,toMs
+
+type SPm i o ans = Mk (SP i o) ans
+
+putsSPm :: [o] -> SPm i o ()
+putsSPm = toMkc . putsSP
+
+putSPm :: o -> SPm i o ()
+putSPm = toMkc . putSP
+
+getSPm :: SPm i o i
+getSPm = Mk getSP
+
+nullSPm :: SPm i o ()
+nullSPm = return ()
+
+monadSP :: (SPm i o ()) -> SP i o
+monadSP (Mk spm) = spm (const nullSP)
+
+toSPm :: (SP i o) -> SPm i o ()
+toSPm sp = toMkc (seqSP sp)
+
diff --git a/hsrc/sp/SPstateMonad.hs b/hsrc/sp/SPstateMonad.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/SPstateMonad.hs
@@ -0,0 +1,23 @@
+module SPstateMonad where
+import SP(SP)
+import Spops
+import StateMonads(Mk(..),Ms(..),toMs,toMsc,loadMs,storeMs)
+
+type SPms i o s ans = Ms (SP i o) s ans
+
+putsSPms :: [o] -> SPms i o s ()
+putSPms :: o -> SPms i o s ()
+getSPms :: SPms i o s i
+nullSPms :: SPms i o s ()
+loadSPms :: SPms i o s s
+storeSPms :: s -> SPms i o s ()
+stateMonadSP :: s -> SPms i o s ans -> (ans -> SP i o) -> SP i o
+
+putsSPms  = toMsc . putsSP
+putSPms   = toMsc . putSP
+getSPms   = toMs getSP
+nullSPms  = return ()
+loadSPms  = loadMs
+storeSPms = storeMs
+
+stateMonadSP s0 (Mk spm) sp = spm (\ans state->sp ans) s0
diff --git a/hsrc/sp/SpEither.hs b/hsrc/sp/SpEither.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/SpEither.hs
@@ -0,0 +1,19 @@
+module SpEither where
+import SP
+import EitherUtils(stripLeft,stripRight)
+import Spops(concatMapSP)
+
+mapFilterSP f = m
+  where m = GetSP $ \x->
+	    case f x of
+	      Just y  -> PutSP y m
+	      Nothing -> m
+
+filterLeftSP = mapFilterSP stripLeft
+filterRightSP = mapFilterSP stripRight
+
+filterJustSP = mapFilterSP id
+
+splitSP = concatMapSP (\(x, y) -> [Left x, Right y])
+
+toBothSP = concatMapSP (\x -> [Left x, Right x])
diff --git a/hsrc/sp/Spinterp.hs b/hsrc/sp/Spinterp.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/Spinterp.hs
@@ -0,0 +1,9 @@
+module Spinterp(interpSP) where
+import SP
+
+interpSP put get null' sp =
+    case sp of
+      PutSP x sp' -> put x (interpSP put get null' sp')
+      GetSP xsp -> get (\x -> interpSP put get null' (xsp x))
+      NullSP -> null'
+
diff --git a/hsrc/sp/Spops.hs b/hsrc/sp/Spops.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/Spops.hs
@@ -0,0 +1,96 @@
+module Spops(module Spops,Cont(..)) where
+import SP
+import EitherUtils(Cont(..))
+
+{- INLINE nullSP -}
+nullSP :: SP a b
+nullSP = NullSP
+
+putsSP :: [b] -> SP a b -> SP a b
+putsSP [] sp = sp
+putsSP (x : xs) sp = PutSP x (putsSP xs sp)
+
+{- INLINE putSP -}
+putSP :: b -> SP a b -> SP a b
+putSP = PutSP
+
+appendStartSP :: [b] -> SP a b -> SP a b
+appendStartSP zs (PutSP y sp) = PutSP y (putsSP zs sp)
+appendStartSP zs sp = putsSP zs sp
+
+stepSP :: [b] -> Cont (SP a b) a
+stepSP ys xsp = putsSP ys (GetSP xsp)
+
+getSP :: Cont (SP a b) a
+getSP = GetSP
+
+walkSP sp x =
+    case sp of
+      PutSP y sp' -> let (ys, sp'') = walkSP sp' x
+                     in  (y : ys, sp'')
+      GetSP xsp' -> pullSP (xsp' x)
+      NullSP -> ([], NullSP)
+
+pullSP sp =
+    case sp of
+      PutSP y sp' -> let (ys, sp'') = pullSP sp'
+                     in  (y : ys, sp'')
+      _ -> ([], sp)
+
+runSP sp xs =
+    case sp of
+      PutSP y sp' -> y : runSP sp' xs
+      GetSP xsp -> case xs of
+                     x : xs' -> runSP (xsp x) xs'
+                     [] -> []
+      NullSP -> []
+
+feedSP :: a -> [a] -> SP a b -> SP a b
+feedSP x xs sp =
+    case sp of
+      PutSP y sp' -> PutSP y (feedSP x xs sp')
+      GetSP xsp' -> startupSP xs (xsp' x)
+      NullSP -> NullSP
+
+startupSP :: [a] -> SP a b -> SP a b
+startupSP [] sp = sp
+startupSP (x : xs) sp = feedSP x xs sp
+
+delaySP sp = GetSP (\x -> startupSP [x] sp)
+
+mapSP f = m where m = GetSP (\x -> PutSP (f x) m)
+
+idSP = GetSP (\x -> PutSP x idSP)
+
+--and concatMapSP :: (*a->[*b]) -> SP *a *b
+concatMapSP f = m where m = GetSP (\x -> putsSP (f x) m)
+
+concmapSP = concatMapSP
+
+concatMapAccumlSP f s0 =
+    GetSP (\x ->
+           let (s, y) = f s0 x
+           in putsSP y (concatMapAccumlSP f s))
+
+mapstateSP = concatMapAccumlSP
+
+mapAccumlSP f s0 =
+    GetSP (\x ->
+           let (s, y) = f s0 x
+           in PutSP y (mapAccumlSP f s))
+
+concatSP = GetSP (\xs -> putsSP xs concatSP)
+concSP = concatSP
+
+zipSP (x : xs) = getSP (\y -> putSP (x, y) (zipSP xs))
+zipSP [] = nullSP
+
+filterSP p = getSP (\x -> (if p x then putSP x else id) (filterSP p))
+
+splitAtElemSP :: (a -> Bool) -> Cont (SP a b) [a]
+splitAtElemSP p xsp =
+    let lSP acc =
+            getSP (\x -> if p x then xsp (reverse acc) else lSP (x : acc))
+    in  lSP []
+
+chopSP splitSP' = splitSP' (\xs -> putSP xs (chopSP splitSP'))
diff --git a/hsrc/sp/StreamProc.hs b/hsrc/sp/StreamProc.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/StreamProc.hs
@@ -0,0 +1,16 @@
+module StreamProc (-- * Stream processors
+  module CompSP,module Dynforkmerge,module Loop,module Loopthrough,module ParSP,module SP,module SPmonad,module SPstateMonad,module Spinterp,module Spops,module SpEither,module IdempotSP,module StreamProcIO,module InputSP) where
+import CompSP
+import Dynforkmerge
+import Loop
+import Loopthrough
+import ParSP
+import SP(SP)
+import SPmonad
+import SPstateMonad
+import Spinterp
+import Spops
+import SpEither
+import IdempotSP
+import StreamProcIO
+import InputSP
diff --git a/hsrc/sp/StreamProcIO.hs b/hsrc/sp/StreamProcIO.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/sp/StreamProcIO.hs
@@ -0,0 +1,14 @@
+module StreamProcIO where
+import SP
+
+class StreamProcIO sp where -- or: SPIO SP_IO SpIO SpIo ?
+  put :: o -> sp i o -> sp i o
+  get :: (i -> sp i o) -> sp i o
+  end :: sp i o -- null?
+
+puts xs sp = foldr put sp xs
+
+instance StreamProcIO SP where
+  put = PutSP
+  get = GetSP
+  end = NullSP
diff --git a/hsrc/types/Direction.hs b/hsrc/types/Direction.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Direction.hs
@@ -0,0 +1,3 @@
+module Direction(Direction(..)) where
+
+data Direction = L | R | Dno Int  deriving (Eq, Ord, Read, Show)
diff --git a/hsrc/types/Drawcmd.hs b/hsrc/types/Drawcmd.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Drawcmd.hs
@@ -0,0 +1,37 @@
+module Drawcmd(move, moveDrawCommands, moveDrawCommand) where
+import DrawTypes
+import Geometry(Move(..))
+--import Xtypes
+
+instance Move DrawCommand where move = flip moveDrawCommand
+
+moveDrawCommand cmd v =
+    case cmd of
+      DrawLine l -> DrawLine (move v l)
+      DrawLines cm ps -> DrawLines cm (movePoints cm ps v)
+      DrawImageString p s -> DrawImageString (move v p) s
+      DrawString p s -> DrawString (move v p) s
+      DrawRectangle r -> DrawRectangle (move v r)
+      FillRectangle r -> FillRectangle (move v r)
+      FillPolygon shape coordMode ps ->
+	FillPolygon shape coordMode (movePoints coordMode ps v)
+      DrawArc r a1 a2 -> DrawArc (move v r) a1 a2
+      FillArc r a1 a2 -> FillArc (move v r) a1 a2
+      CopyArea d r p -> CopyArea d r (move v p)
+      CopyPlane d r p n -> CopyPlane d r (move v p) n
+      DrawPoint p -> DrawPoint (move v p)
+      CreatePutImage r fmt pxls -> CreatePutImage (move v r) fmt pxls
+      DrawImageStringPS p s -> DrawImageStringPS (move v p) s
+      DrawStringPS p s -> DrawStringPS (move v p) s
+      DrawImageString16 p s -> DrawImageString16 (move v p) s
+      DrawString16 p s -> DrawString16 (move v p) s
+
+movePoints cm ps v =
+ case cm of
+   CoordModeOrigin -> move v ps
+   CoordModePrevious ->
+     case ps of
+       p:ps' -> move v p:ps'
+       [] -> []
+
+moveDrawCommands cmds p = map (`moveDrawCommand` p) cmds
diff --git a/hsrc/types/Fudget.hs b/hsrc/types/Fudget.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Fudget.hs
@@ -0,0 +1,44 @@
+module Fudget(
+  module Fudget,SP,
+  --XCommand,XEvent,
+  FRequest,FResponse,
+  Message(..),Path(..),Direction) where
+--import Command(XCommand)
+--import Event(XEvent)
+import FRequest(FRequest,FResponse)
+import Message(Message(..))
+import Direction(Direction)
+import Path(Path(..))
+import SP(SP)
+
+type TEvent   = (Path, FResponse)
+type TCommand = (Path, FRequest)
+
+type Fa a b c d = SP (Message a c) (Message b d)
+
+type FEvent a = Message TEvent a
+type KEvent a = Message FResponse a
+
+type FCommand a = Message TCommand a
+type KCommand a = Message FRequest a
+
+type Fudget a b = F a b
+
+-- Traditional definitions:
+--type F a b = Fa TEvent TCommand a b
+--type K a b = Fa XEvent XCommand a b
+
+-- New definitions:
+
+type FSP hi ho = SP (FEvent hi) (FCommand ho)     --  = old def of F hi ho
+type KSP hi ho = SP (KEvent hi) (KCommand ho)     --  = old def of K hi ho
+
+newtype F hi ho = F (FSP hi ho)
+newtype K hi ho = K (KSP hi ho)
+--data F hi ho = F (FSP hi ho)
+--data K hi ho = K (KSP hi ho)
+
+kk=K
+ff=F
+unK (K sp) = sp
+unF (F sp) = sp
diff --git a/hsrc/types/InputMsg.hs b/hsrc/types/InputMsg.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/InputMsg.hs
@@ -0,0 +1,41 @@
+-- | Types for messages from buttons and input fields
+module InputMsg where
+import AuxTypes(KeySym(..))
+
+-- | Button clicks
+data Click = Click  deriving (Eq, Ord, Show)
+
+-- | Output from dialog popups with OK and Cancel buttons
+data ConfirmMsg = Confirm | Cancel  deriving (Eq, Ord, Show)
+
+toConfirm (Left _)  = Confirm
+toConfirm (Right _) = Cancel
+fromConfirm Confirm = Left Click
+fromConfirm Cancel  = Right Click
+
+data InputMsg a = InputChange a |
+                  InputDone KeySym a 
+                  deriving (Eq, Ord, Show)
+
+inputMsg = InputDone inputButtonKey
+inputChange = InputChange
+
+inputButtonKey = "." :: KeySym
+inputLeaveKey  = ""  :: KeySym
+
+stripInputMsg (InputDone _ x) = x
+stripInputMsg (InputChange x) = x
+
+tstInp p (InputChange s) = p s
+tstInp p (InputDone k s) = p s
+
+mapInp f (InputChange s) = InputChange (f s)
+mapInp f (InputDone k s) = InputDone k (f s)
+
+instance Functor InputMsg where fmap = mapInp
+
+inputDone (InputDone k s) | k /= inputLeaveKey = Just s
+inputDone _ = Nothing
+
+inputLeaveDone (InputDone _ s) = Just s
+inputLeaveDone _ = Nothing
diff --git a/hsrc/types/ListRequest.hs b/hsrc/types/ListRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/ListRequest.hs
@@ -0,0 +1,31 @@
+module ListRequest where
+
+default (Int)
+
+data ListRequest a
+  = ReplaceItems Int Int [a] -- from, how many, new lines
+  | HighlightItems [Int]     -- replaces list of highlighted lines
+  | PickItem Int            -- as if user clicked on a line
+listEnd = -1
+
+replaceAll          = ReplaceItems 0    listEnd           -- replace all text
+replaceAllFrom from = ReplaceItems from listEnd
+deleteItems from cnt = ReplaceItems from cnt     []
+insertItems from     = ReplaceItems from 0
+appendItems          = ReplaceItems listEnd listEnd
+changeItems from txt = ReplaceItems from (length txt) txt
+
+replaceItems = ReplaceItems
+highlightItems = HighlightItems
+pickItem = PickItem
+
+--applyListRequest (ReplaceItems 0 cnt newtxt) oldtxt | cnt==listEnd = newtxt
+applyListRequest (ReplaceItems from cnt newtxt) oldtxt =
+  let before = if from==listEnd
+               then oldtxt
+	       else take from oldtxt
+      after  = if from==listEnd || cnt==listEnd
+               then []
+	       else drop (from+cnt) oldtxt
+  in before++newtxt++after
+applyListRequest _ oldtxt = oldtxt
diff --git a/hsrc/types/Message.hs b/hsrc/types/Message.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Message.hs
@@ -0,0 +1,33 @@
+module Message where
+
+data Message a b = Low a | High b  deriving (Eq, Ord, Show)
+
+isHigh (High _) = True
+isHigh _ = False
+
+isLow (Low _) = True
+isLow _ = False
+
+stripHigh (High a) = Just a
+stripHigh _ = Nothing
+
+stripLow (Low b) = Just b
+stripLow _ = Nothing
+
+mapMessage fl fh' (Low l) = Low (fl l)
+mapMessage fl fh' (High h) = High (fh' h)
+
+message fl fh (Low l) = fl l
+message fl fh (High h) = fh h
+
+aLow f (Low l) = Low (f l)
+aLow f (High h) = High h
+
+aHigh f (High h) = High (f h)
+aHigh f (Low l) = Low l
+
+pushMsg (High xs) = fmap High xs
+pushMsg (Low xs) = fmap Low xs
+
+instance Functor (Message a) where
+  fmap = aHigh
diff --git a/hsrc/types/Path.hs b/hsrc/types/Path.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Path.hs
@@ -0,0 +1,30 @@
+module Path(showPath, subPath, absPath, path, turn, here, Path(..)) where
+import Direction
+import Utils(lhead)
+
+type Path = [Direction]
+
+here :: Path
+here = []
+
+turn :: Direction -> Path -> Path
+turn dir p = dir : p
+
+path :: Path -> (Direction, Path)
+path (dir : p) = (dir, p)
+path [] = error "path.m: path []"
+
+absPath :: Path -> Path -> Path
+absPath absp relp = absp ++ relp
+
+subPath :: Path -> Path -> Bool
+subPath subp p = length subp <= length p && lhead subp p == subp
+
+showPath :: Path -> String
+showPath =
+    concatMap (\x ->
+               case x of
+                 L -> "L"
+                 R -> "R"
+                 Dno n -> "N(" ++ show n ++ ")")
+
diff --git a/hsrc/types/Popupmsg.hs b/hsrc/types/Popupmsg.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Popupmsg.hs
@@ -0,0 +1,5 @@
+module Popupmsg where
+import Geometry
+
+data PopupMsg a = Popup Point a | Popdown  deriving (Eq, Ord)
+
diff --git a/hsrc/types/Rects.hs b/hsrc/types/Rects.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Rects.hs
@@ -0,0 +1,52 @@
+module Rects where
+import Geometry
+
+--newtype Region = Region [Rect]
+
+intersectRects rs (Rect p2 s2) = ir rs
+  where
+    br2 = p2+s2
+    ir [] = []
+    ir (Rect p1 s1:es) =
+      let ul = pmax p1 p2
+          br = pmin (p1+s1) br2
+	  s@(Point w h) = br-ul
+      in if w<=0 || h<=0 then ir es else Rect ul s:ir es
+
+overlaps (Rect (Point x1 y1) (Point w1 h1))
+         (Rect (Point x2 y2) (Point w2 h2)) =
+  x1<x2+w2 && x2<x1+w1 && y1<y2+h2 && y2<y1+h1
+--x1<=x2+w2 && x2<=x1+w1 && y1<=y2+h2 && y2<=y1+h1
+-- rR 0 0 10 10 doesn't overlap with rR 0 10 10 10
+
+boundingRect r1@(Rect p1 s1) r2@(Rect p2 s2) =
+    if s1==0 then r2 else if s2==0 then r1 else Rect p s
+  where p = pmin p1 p2
+        s = pmax (p1+s1) (p2+s2) - p
+
+diffRect r1 r2@(Rect (Point x2 y2) (Point w2 h2)) =
+    if overlaps r1 r2 -- faster handling of common(?) case
+    then intersectRects outside_r2 r1
+    else [r1]
+  where
+    u@(Rect p1@(Point x1 y1) s1@(Point w1 h1)) = boundingRect r1 r2
+    outside_r2 = [a,b,c,d]
+    a = Rect p1 (Point w1 (y2-y1))
+    b = Rect (Point x1 y2) (Point (x2-x1) h2)
+    c = Rect (Point xc y2) (Point (x1+w1-xc) h2) where xc = x2 + w2
+    d = Rect (Point x1 yd) (Point w1 (y1+h1-yd)) where yd = y2+h2
+
+{-
+    u:
+       +-----------------------------+
+       |            a                |
+       |                             |
+       +--------+-------+------------+
+       |   b    |  r2   |     c      |
+       |        |       |            |
+       +--------+-------+------------+
+       |                             |
+       |             d               |
+       |                             |
+       +-----------------------------+
+-}
diff --git a/hsrc/types/Types.hs b/hsrc/types/Types.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/types/Types.hs
@@ -0,0 +1,11 @@
+module Types (-- * Types
+  module Direction,module Drawcmd,module Fudget,module Message,module Path,module Popupmsg,module InputMsg,module ListRequest,module Rects) where
+import Direction
+import Drawcmd
+import Message
+import Path
+import Popupmsg
+import InputMsg
+import ListRequest
+import Fudget
+import Rects
diff --git a/hsrc/utils/CmdLineEnv.hs b/hsrc/utils/CmdLineEnv.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/CmdLineEnv.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE CPP #-}
+module CmdLineEnv(options, progName, resourceName, args, argKey, argReadKey, argFlag, argKeyList) where
+import IOUtil(progArgs,progName,getEnvi)
+import FilePaths(aFilePath,pathTail)
+--import ListUtil(chopList,breakAt)
+import Utils(segments)
+import HbcUtils(apFst, apSnd, breakAt)
+import Data.Char
+import Data.Maybe(fromMaybe)
+--import NonStdTrace(trace)
+
+argReadKey key def = case lookupOptions key of
+	   Nothing -> def
+	   Just a -> case reads a of
+		(v,_):_ -> v
+		_ -> error (" Illegal value to flag -"++key++
+			    " (default value is "++show def++" of type "++
+			    showType def++"): "++a)
+#ifndef __HBC__
+  where showType _ = "<type??>"
+#endif
+
+argKey key def = lookupOptions key `elseM` def
+argFlag key def = argKey key (if def then yes else no) == yes
+argKeyList key def = maybe def (segments (/=':')) (lookupOptions key)
+
+lookupOptions key = lookup key options
+	      `orM` (env ("FUD_"++ removePath progName++"_"++key))
+	      `orM` (env ("FUD_"++key))
+
+    where removePath = reverse . fst . breakAt '/' . reverse
+	  env e = getEnvi e >>= \v -> Just (if v == "" then yes else v)
+	  --getEnvi' e = trace ("getEnvi "++e) $ getEnvi e
+
+orM :: Maybe a -> Maybe a -> Maybe a
+--orM = (++)
+orM Nothing  b = b
+orM a        b = a
+
+elseM :: Maybe a -> a -> a
+elseM = flip fromMaybe
+--elseM (Just a) a' = a
+--elseM Nothing  a' = a'
+
+yes = "yes"
+no = "no"
+
+(args, options) =
+    let parse (('-' : ak) : av : al) = case av of
+	      '-':avr -> if not (null avr) && isAlpha (head avr)
+	          && reverse (take 4 (reverse ak)) /= "font" 
+		  then apSnd ((ak, yes) :) (parse (av:al))
+		  else thearg
+	      _ -> thearg
+            where thearg = apSnd ((ak, av) :) (parse al)
+        parse ['-' : ak] = ([], [(ak, yes)])
+        parse ("-":al) = (al,[])
+        parse (a : al) = apFst (a :) (parse al)
+        parse [] = ([], [])
+    in  parse progArgs
+
+
+resourceName = pathTail (aFilePath progName)
diff --git a/hsrc/utils/Defaults.hs b/hsrc/utils/Defaults.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/Defaults.hs
@@ -0,0 +1,56 @@
+module Defaults(look3d, new3d, edgeWidth, defaultSep,
+		paperColor, fgColor, bgColor, inputFg, inputBg,
+		shadowColor, shineColor,
+		defaultPosition, defaultSize, defaultFont, menuFont,
+                buttonFont, labelFont, metaKey) where
+import Geometry(pP)
+--import ListUtil(chopList,breakAt)
+import Utils(segments)
+import AuxTypes(Modifiers(..))
+import ResourceIds(FontName(..),ColorName(..))
+import CmdLineEnv
+
+argFont = argKey :: ( String -> FontName -> FontName)
+argColor = argKey :: (String -> ColorName -> ColorName)
+
+buttonFont  = argFont "buttonfont" labelFont
+menuFont    = argFont "menufont"   labelFont
+labelFont   = argFont "labelfont"  "variable"
+defaultFont = argFont "font"       "fixed"
+
+shineColor  = argColor "shine"   (if look3d then "white" else "lightgrey")
+shadowColor = argColor "shadow"  (if look3d
+                                  then if new3d
+				       then "grey45"
+				       else "black"
+				  else "grey30")
+paperColor  = argColor "paper"   "white"
+inputFg     = argColor "inputfg" fgColor
+inputBg     = argColor "inputbg" paperColor
+fgColor     = argColor "fg"      "black"
+bgColor     = argColor "bg"      "grey"
+
+--defaultSep :: Int
+defaultSep :: (Num a) => a
+defaultSep = fromIntegral (argReadKey "sep" 5::Int)
+
+defaultPosition =
+    case segments (/='+') (argKey "geometry" "") of
+      [_, x, y] -> Just (pP (read x) (read y))
+      _ -> Nothing
+
+defaultSize =
+    case segments (/='x') (takeWhile (/='+') (argKey "geometry" "")) of
+      [x, y] -> Just (pP (read x) (read y))
+      _ -> Nothing
+
+edgeWidth :: Int
+edgeWidth = argReadKey "edgew" (if look3d then 2 else 4)
+
+look3d = argFlag "look3d" True
+new3d = argFlag "new3d" True
+
+
+-- | This should be modifier corresponding to Meta_L & Meta_R (see xmodmap).
+-- It is usually Mod1, but in XQuartz it appears to be Mod2 instead...
+metaKey = argReadKey "metakey" Mod1
diff --git a/hsrc/utils/EitherUtils.hs b/hsrc/utils/EitherUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/EitherUtils.hs
@@ -0,0 +1,51 @@
+module EitherUtils where
+import Data.Maybe
+import Data.List(find)
+
+type Cont c a = (a -> c) -> c
+
+plookup p = fmap snd . find (p.fst)
+
+-- mapfilter = Maybe.mapMaybe
+-- stripMaybe = Maybe.fromJust
+-- stripMaybeDef = Maybe.fromMaybe
+-- isM = Maybe.isJust
+
+--mapMaybe :: (a->b) -> Maybe a -> Maybe b
+--mapMaybe = fmap
+
+stripLeft (Left a) = Just a
+stripLeft _ = Nothing
+
+stripRight (Right b) = Just b
+stripRight _ = Nothing
+
+stripEither (Left a) = a
+stripEither (Right b) = b
+
+filterLeft = mapMaybe stripLeft
+
+filterRight = mapMaybe stripRight
+
+isLeft (Left _) = True
+isLeft _ = False
+
+isRight (Right _) = True
+isRight _ = False
+
+mapEither fl fr (Left l) = Left (fl l)
+mapEither fl fr (Right r) = Right (fr r)
+
+swapEither (Left x) = Right x
+swapEither (Right y) = Left y
+
+-- JSP 920929
+splitEitherList [] = ([], [])
+splitEitherList (x : xs) =
+    let (lefts, rights) = splitEitherList xs
+    in  case x of
+          Left a -> (a : lefts, rights)
+          Right a -> (lefts, a : rights)
+
+fromLeft (Left x) = x
+fromRight (Right y) = y
diff --git a/hsrc/utils/FilePaths.hs b/hsrc/utils/FilePaths.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/FilePaths.hs
@@ -0,0 +1,86 @@
+module FilePaths(AFilePath,rootPath,aFilePath,filePath,
+                 compactPath,isAbsolute,joinPaths,pathRelativeTo,
+		 extendPath,pathTail,pathHead,pathLength) where
+import Data.List(intersperse)
+--import IO(openDirectory, statFile)
+--import ListUtil(chopList,breakAt)
+import Utils(segments)
+
+newtype AFilePath = P [String] deriving (Eq,Ord)
+-- data AFilePath = Root | Cwd | AFilePath :/ String
+
+aFilePath :: FilePath -> AFilePath
+aFilePath = P . splitpath
+
+rootPath = P [""]
+
+filePath :: AFilePath -> FilePath
+filePath (P path) = joinpath path
+
+compactPath (P path) = P (compactpath path)
+
+extendPath (P path) node = P (node:path)
+
+pathTail :: AFilePath -> String
+pathTail (P []) = "." -- ??
+pathTail (P [""]) = "/" -- ??
+pathTail (P (t:_)) =  t
+
+pathHead (P []) = (P []) -- ??
+pathHead (P (t:h)) = P h
+
+pathLength (P path) = length path
+
+isAbsolute (P ns) = isabsolute ns
+
+joinPaths (P parent) (P child) =
+ if isabsolute child
+ then P child
+ else P (child++parent) -- compactpath?
+
+P file `pathRelativeTo` P dir =
+    if take dirlen rfile == rdir
+    then P (reverse (drop dirlen rfile))
+    else P file
+  where
+    rdir = reverse dir
+    rfile = reverse file
+    dirlen = length rdir
+
+isabsolute [] = False
+isabsolute ns = null (last ns)
+
+splitpath = reverse . segments (/='/')
+
+joinpath [] = "."
+joinpath [""] = "/"
+joinpath ns = concat (intersperse "/" (reverse ns))
+
+compactpath [] = []
+compactpath (".." : xs) =
+  case compactpath xs of
+    [""] -> [""] -- parent of root directory, stay in root directory
+    ys@("..":_) -> "..":ys -- relative path to grandparent, keep ".."
+    _:ys -> ys -- parent of child, optimize
+    ys -> "..":ys -- other, keep ".."
+--compactpath ["..",""] = [""] -- parent of root directory
+--compactpath (".." : "." : xs) = compactpath ("..":xs)
+--compactpath (".." : x : xs) | x /= ".." = compactpath xs
+compactpath ("" : xs@(_:_)) = compactpath xs
+compactpath ("." : xs) = compactpath xs
+compactpath (x : xs) = x : compactpath xs
+
+{-
+ls s =
+    let paths = map (: s) . sort . filter (/= ".")
+    in  case openDirectory (joinpath s) of
+          Right files -> paths files
+          Left msg -> [msg : s]
+
+isdir s =
+    case statFile (joinpath s) of
+      Right ns -> let mode = ns !! (3 - 1)
+                  in  bitand mode 61440 == 16384
+      Left _ -> False
+
+-}
diff --git a/hsrc/utils/FudUtilities.hs b/hsrc/utils/FudUtilities.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/FudUtilities.hs
@@ -0,0 +1,15 @@
+module FudUtilities (-- * Utilities
+  module Defaults, module CmdLineEnv, module FilePaths,  module Geometry, module MapstateMsg, module EitherUtils, module StringUtils, module Utils, module FudVersion) where
+import Defaults
+import CmdLineEnv
+import Geometry
+import FilePaths
+import MapstateMsg
+import EitherUtils
+import StringUtils
+import Utils
+import FudVersion
+
+--import Message(Message)
+--import SP(SP)
+--import Xtypes(FontName(..))
diff --git a/hsrc/utils/FudVersion.hs b/hsrc/utils/FudVersion.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/FudVersion.hs
@@ -0,0 +1,7 @@
+module FudVersion where
+
+version = version_0_18_3
+
+version_0_18_3 = "version 0.18.3" -- only for documentation, use "version" instead
+
+-- The version number should be increased immediately after a public release.
diff --git a/hsrc/utils/Geometry.hs b/hsrc/utils/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/Geometry.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE CPP #-}
+module Geometry where
+-- This module should be moved to ../types/
+
+import Data.Ix
+
+class Move a where move :: Point -> a -> a
+
+fmove 0 = id
+fmove p = fmap (move p)
+
+instance Move a => Move [a]       where move = fmove
+instance Move a => Move (Maybe a) where move = fmove
+
+data Point = Point { xcoord, ycoord :: Int }
+   deriving (Eq, Ord, Show, Read, Ix)
+type Size = Point
+data Line = Line Point Point  deriving (Eq, Ord, Show, Read)
+data Rect = Rect {rectpos::Point, rectsize::Size}
+ deriving (Eq, Ord, Show, Read)
+{-
+instance Show Point where showsPrec d (Point x y) = showsPrec d (x,y)
+instance Read Point where readsPrec d s = [(pP x y,r)|((x,y),r)<-readsPrec d s]
+
+instance Show Rect where
+  showsPrec d (Rect p s) =
+    showParen (d>=10) $
+    showString "R " . showsPrec 10 p . showChar ' ' . showsPrec 10 s
+-}
+-- convenient abbreviations:
+origin = Point 0 0
+pP x y = Point x y
+lL x1 y1 x2 y2 = Line (Point x1 y1) (Point x2 y2)
+rR x y w h = Rect (Point x y) (Point w h)
+diag x = Point x x
+
+-- selectors:
+--xcoord (Point x _) = x
+--ycoord (Point _ y) = y
+
+--rectsize (Rect _ size) = size
+--rectpos (Rect pos _) = pos
+
+-- basic operations:
+padd (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
+psub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)
+
+instance Num Point where
+	 (+) = padd
+	 (-) = psub
+	 Point x1 y1 * Point x2 y2 = Point (x1*x2) (y1*y2) -- hmm
+	 negate = psub origin
+	 abs (Point x y) = Point (abs x) (abs y) -- hmm
+	 signum (Point x y) = Point (signum x) (signum y) -- hmm
+	 fromInteger i = let i' = fromInteger i in Point i' i'
+#ifdef __HBC__
+	 fromInt i = Point i i
+#endif
+
+rsub (Rect p1 _) (Rect p2 _) = psub p1 p2
+
+posrect (Rect pos size) newpos = Rect newpos size
+moverect (Rect pos size) delta = Rect (padd pos delta) size
+sizerect (Rect pos size) newsize = Rect pos newsize
+growrect (Rect pos size) delta = Rect pos (padd size delta)
+
+moveline (Line p1 p2) delta = Line (padd p1 delta) (padd p2 delta)
+
+rect2line (Rect p s) = Line p (p `padd` s)
+line2rect (Line p1 p2) = Rect p1 (p2 `psub` p1)
+
+instance Move Point where move = padd
+instance Move Rect where move = flip moverect
+instance Move Line where move = flip moveline
+
+-- misc:
+Point x1 y1 =.> Point x2 y2 = x1 >= x2 && y1 >= y2
+inRect pt (Rect p1 p2) = pt =.> p1 && p2 =.> psub pt p1
+scale k i = truncate (k * fromIntegral i)
+scalePoint k (Point x y) = Point (scale k x) (scale k y)
+rectMiddle (Rect (Point x y) (Point w h)) =
+    Point (x + w `quot` 2) (y + h `quot` 2)
+
+freedom (Rect _ outer) (Rect _ inner) = psub outer inner
+
+pmin (Point x1 y1) (Point x2 y2) = Point (x1 `min` x2) (y1 `min` y2)
+pmax (Point x1 y1) (Point x2 y2) = Point (x1 `max` x2) (y1 `max` y2)
+
+pMin (p : pl) = foldr pmin p pl
+pMin [] = error "pMin on []"
+
+pMax (p : pl) = foldr pmax p pl
+pMax [] = error "pMax on []"
+
+plim p0 p1 p = pmax p0 (pmin p1 p)
+
+-- | confine outer inner: moves an shrinks inner to fit within outer
+confine (Rect outerpos outersize) (Rect innerpos innersize) =
+    let newsize = pmin outersize innersize
+        maxpos = padd outerpos (psub outersize newsize)
+    in  Rect (plim outerpos maxpos innerpos) newsize
+
+-- | rmax gives an enclosing rect
+rmax r1 r2 = line2rect (Line (pmin lp1 lp2) (pmax lp1' lp2'))
+   where Line lp1 lp1' = rect2line r1
+	 Line lp2 lp2' = rect2line r2
diff --git a/hsrc/utils/HbcUtils.hs b/hsrc/utils/HbcUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/HbcUtils.hs
@@ -0,0 +1,44 @@
+-- | Useful functions from hbc-library modules ListSet, ListMap, ListUtil, HO
+-- and UTF8
+module HbcUtils(module HbcUtils,module FudUTF8) where
+import Data.List((\\))
+import FudUTF8
+
+-- * From ListSet
+
+-- | Union of sets as lists
+union :: (Eq a) => [a] -> [a] -> [a]
+union xs ys = xs ++ (ys \\ xs)
+
+
+-- * From ListMap
+lookupWithDefault :: (Eq a) => [(a, b)] -> b -> a -> b
+lookupWithDefault [] d _ = d
+lookupWithDefault ((x,y):xys) d x' = if x == x' then y else lookupWithDefault xys d x'
+
+
+-- * From ListUtil
+mapFst f = map (apFst f)
+mapSnd f = map (apSnd f)
+
+breakAt c = apSnd (drop 1) . break (==c)
+
+chopList :: ([a] -> (b, [a])) -> [a] -> [b]
+chopList f l = unfoldr f null l
+  where
+    -- | 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
+
+assoc :: Eq k => (v -> r) -> r -> [(k, v)] -> k -> r
+assoc f z xs k = maybe z f (lookup k xs)
+
+-- * From HO
+
+apFst f (x, y) = (f x, y)
+apSnd f (x, y) = (x, f y)
+
+curry3 f x y z = f (x,y,z)
+uncurry3 f ~(x,y,z) = f x y z
diff --git a/hsrc/utils/MapstateMsg.hs b/hsrc/utils/MapstateMsg.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/MapstateMsg.hs
@@ -0,0 +1,26 @@
+module MapstateMsg(mapLow, mapHigh, mapstateLow, mapstateHigh) where
+import Message(Message(..))
+--import SP(SP)
+import Spops
+import HbcUtils(apSnd)
+
+mapstateHigh p s =
+    let ms s' (Low msg) = (s', [Low msg])
+        ms s' (High msg) = apSnd (map High) (p s' msg)
+    in  mapstateSP ms s
+
+mapstateLow p s =
+    let ms s' (High msg) = (s', [High msg])
+        ms s' (Low msg) = apSnd (map Low) (p s' msg)
+    in  mapstateSP ms s
+
+mapHigh p =
+    let ms (High msg) = map High (p msg)
+        ms (Low msg) = [Low msg]
+    in  concmapSP ms
+
+mapLow p =
+    let ms (Low msg) = map Low (p msg)
+        ms (High msg) = [High msg]
+    in  concmapSP ms
+
diff --git a/hsrc/utils/StringUtils.hs b/hsrc/utils/StringUtils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/StringUtils.hs
@@ -0,0 +1,17 @@
+module StringUtils where
+--import Char(isAlpha,isAlphanum,isDigit)
+
+expandTabs n = exp (n::Int)
+  where
+    exp k [] = []
+    exp k ('\t':xs) = [' '|_<-[1..k]] ++ exp n xs
+    exp k (x:xs) = x:exp (if k==1 then n else k-1) xs
+
+rmBS "" = ""
+rmBS (c:'\b':cs) = rmBS cs
+rmBS (c:cs) = c:rmBS cs
+
+wrapLine n xs =
+    let first = take n xs
+        rest = drop n xs
+    in  first : (if null rest then [] else wrapLine n rest)
diff --git a/hsrc/utils/Utils.hs b/hsrc/utils/Utils.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/utils/Utils.hs
@@ -0,0 +1,101 @@
+module Utils where
+--import ListSet(union)
+--import HbcWord
+import HbcUtils
+
+infixr 1 `thenC`
+infixl 1 `ifC`
+
+aboth f (x, y) = (f x, f y)
+mapPair (f, g) (x, y) = (f x, g y)
+pairwith f x = (x, f x)
+swap (x, y) = (y, x)
+pair = (,)
+
+setFst (_,y) x = (x,y)
+setSnd (x,_) y = (x,y)
+
+oo f g x y = f (g x y)
+
+-- | Apply a function to the nth element of a list
+anth :: Int -> (a->a) -> [a] -> [a]
+anth _ _ [] = []
+anth 1 f (x : xs) = f x : xs
+anth n f (x : xs) = x : anth (n - 1) f xs
+
+--dropto p = while (\l -> l /= [] && (not . p . head) l) tail
+
+number :: Int -> [a] -> [(Int,a)]
+number _ [] = []
+number i (x : xs) = (i, x) : number (i + 1) xs
+
+loop f =
+    let yf = f yf
+    in  yf
+
+ifC c b = if b then c else id
+thenC = flip ifC
+
+gmap g f = foldr (\x -> \ys -> g (f x) ys) []
+
+unionmap f = gmap union f
+
+-- | Remove the first occurence
+remove a (b : bs) | a == b = bs
+remove a (b : bs) = b : remove a bs
+remove a [] = []
+
+-- | Replace the first occurence
+replace p [] = [p]
+replace (t, v) ((t', v') : ls') | t == t' = (t, v) : ls'
+replace p (l : ls') = l : replace p ls'
+
+unconcat [] _ = []
+unconcat (n : ns) xs = xs1:unconcat ns xs2
+  where (xs1,xs2) = splitAt n xs
+
+-- | lunconcat xss ys = unconcat (map length xss) ys
+lunconcat [] _ = []
+lunconcat (n : ns) xs = xs1:lunconcat ns xs2
+  where (xs1,xs2) = lsplit n xs
+
+
+-- | lhead xs ys = take (length xs) ys, but the rhs is stricter
+lhead (x : xs) (y : ys) = y : lhead xs ys
+lhead _ _ = []
+
+-- | ltail xs ys = drop (length xs) ys, but the rhs is stricter
+ltail [] ys = ys
+ltail _ [] = []
+ltail (x : xs) (y : ys) = ltail xs ys
+
+-- | lsplit xs ys = (lhead xs ys,ltail xs ys), but without the space leak, -fpbu
+lsplit [] ys = ([], ys)
+lsplit _ [] = ([], [])
+lsplit (x : xs) (y : ys) =
+    let (yhs, yts) = lsplit xs ys
+    in  (y : yhs, yts)
+
+-- | JSP 920928
+part p [] = ([], [])
+part p (x : xs) =
+    let (ys, zs) = part p xs
+    in  if p x then (x : ys, zs) else (ys, x : zs)
+
+issubset a b = all (`elem` b) a
+
+-- | To avoid problems caused by poor type inference for constructor classes in
+-- Haskell 1.3:
+mapList = map :: ((a->b)->[a]->[b])
+
+-- From Compat.hs:
+--bitxor,bitand::Int->Int->Int
+--bitxor x y = wordToInt (bitXor (fromIntegral x) (fromIntegral y))
+--bitand x y = wordToInt (bitAnd (fromIntegral x) (fromIntegral y))
+
+
+-- | @chopList (breakAt c) == segments (/=c)@
+segments p [] = []
+segments p xs = case span p xs of
+                  (xs1,_:xs2) -> xs1:segments p xs2
+                  (xs1,_) -> [xs1]
diff --git a/hsrc/xtypes/AuxTypes.hs b/hsrc/xtypes/AuxTypes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/AuxTypes.hs
@@ -0,0 +1,56 @@
+-- | Auxiliary Xlib types
+module AuxTypes where
+
+data Gravity = ForgetGravity |
+               NorthWestGravity |
+               NorthGravity |
+               NorthEastGravity |
+               WestGravity |
+               CenterGravity |
+               EastGravity |
+               SouthWestGravity |
+               SouthGravity |
+               SouthEastGravity |
+               StaticGravity 
+               deriving (Eq, Ord, Read, Show, Bounded, Enum)
+
+data ShapeKind = ShapeBounding | ShapeClip
+                 deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data ShapeOperation = ShapeSet |
+                      ShapeUnion |
+                      ShapeIntersect |
+                      ShapeSubtract |
+                      ShapeInvert 
+                      deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+-- There already is an Ordering in the 1.3 Prelude
+data Ordering' = Unsorted | YSorted | YXSorted | YXBanded
+     deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+type RmClass = String
+type RmName = String
+type RmQuery = (RmClass, RmName)
+type RmSpec = [RmQuery]
+type RmValue = String
+type RmDatabase = Int
+
+rmNothing = 0::Int
+
+data Modifiers = Shift | Lock | Control
+               | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
+               | Button1 | Button2 | Button3 | Button4 | Button5
+               | Mod13 | Mod14 -- non-standard, but used in XQuartz
+               | Any 
+               deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+clModifiers =
+    [Shift, Lock, Control, Mod1, Mod2, Mod3, Mod4, Mod5,
+     Button1, Button2, Button3, Button4, Button5]
+
+data Button = AnyButton | Button Int  deriving (Eq, Ord, Read, Show)
+
+type ModState = [Modifiers]
+
+type KeySym = String
+
diff --git a/hsrc/xtypes/Command.hs b/hsrc/xtypes/Command.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Command.hs
@@ -0,0 +1,132 @@
+module Command(module Command,DrawCommand,Drawable(..)) where
+import Event(XEvent)
+import Direction() -- for hbc
+import Path(Path(..))
+import Geometry
+--import LayoutRequest(LayoutMessage(..))
+import Xtypes
+import DrawTypes
+--import DialogueIO(Request)
+import ShowFun()
+
+-- Same order as in .../lml/src/lib/xlib/xlib.h
+data XCommand -- X commands
+  = CloseDisplay Display
+  | DestroyWindow
+  | MapRaised
+  | LowerWindow
+  | UnmapWindow
+  | Draw Drawable GCId DrawCommand
+  | DrawMany Drawable [(GCId,[DrawCommand])] -- use instead of XDoCommands
+  | ClearArea Rect Bool
+  | ClearWindow
+  | ChangeGC GCId GCAttributeList
+  | FreeGC GCId
+  | ChangeWindowAttributes [WindowAttributes]
+  | ConfigureWindow [WindowChanges]
+  | StoreName String
+  | SetNormalHints Point
+  | SetWMHints Bool -- input
+  | UngrabPointer
+  | GrabButton Bool Button ModState [EventMask]
+  | UngrabButton Button ModState
+  | Flush
+  | FreePixmap PixmapId
+  | ShapeCombineMask ShapeKind Point PixmapId ShapeOperation
+  | ShapeCombineRectangles ShapeKind Point [Rect] ShapeOperation Ordering'
+  | ShapeCombineShape ShapeKind Point PixmapId ShapeKind ShapeOperation
+  | RmDestroyDatabase RmDatabase
+  | RmCombineDatabase RmDatabase RmDatabase Bool
+  | RmPutLineResource RmDatabase String
+  | SetWMProtocols [Atom]
+  | SendEvent Window Bool [EventMask] XEvent
+  | SetSelectionOwner Bool Atom
+  | ConvertSelection Selection
+  | ChangeProperty Window Atom Atom Int PropertyMode String
+  | FreeColors ColormapId [Pixel] Pixel{-planes-}
+  | ReparentWindow Window {- parent -}
+  | WarpPointer Point
+  | SetRegion GCId Rect -- !!! modifies a GC -- cache problems!
+  | AddToSaveSet
+  | RemoveFromSaveSet
+  | Bell Int
+  | SetGCWarningHack {gcon,gcoff::PixmapId}
+-- ONLY Pseudo commands below, add new Xlib command above this line !!!
+  | GrabEvents Bool
+  | UngrabEvents
+  | TranslateEvent (XEvent -> Maybe XEvent) [EventMask]
+  | ReparentToMe Path Window
+  | GetWindowId -- move to XRequest?
+  | SelectWindow Window
+-- Layout pseudo commands
+--  | LayoutMsg LayoutMessage
+-- An I/O request to be passed through the top level (not anymore)
+--  | DoIO Request
+--  | DoXRequest XRequest
+--
+--  | DoXCommands [XCommand]
+		-- Drawing speed hack, bypasses caches and resource management.
+		-- Do not put any Alloc/Free, Create/Destroy, Grab/Ungrab type
+		-- of commands inside DoXCommands!
+--
+  | MeButtonMachine -- tells menuPopupF where the buttons are
+  deriving (Show,Read)
+
+-- layoutRequestCmd = LayoutMsg . LayoutRequest
+
+data XRequest
+  = OpenDisplay DisplayName
+  | CreateSimpleWindow Path Rect
+  | CreateRootWindow Rect String -- resource name
+  | CreateGC Drawable GCId GCAttributeList
+  | LoadFont FontName
+  | CreateFontCursor Int
+  | GrabPointer Bool [EventMask]
+  | LMLQueryFont FontId -- doesn't work in Haskell
+  | AllocNamedColor ColormapId ColorName
+  | AllocColor ColormapId RGB
+  | CreatePixmap Size Depth
+  | ReadBitmapFile FilePath
+  | CreateBitmapFromData BitmapData
+  | RmGetStringDatabase String
+  | RmGetResource RmDatabase String String
+  | TranslateCoordinates
+  | InternAtom String Bool
+  | GetAtomName Atom
+  | GetWindowProperty Int Atom Bool Atom
+  | QueryPointer
+  | QueryFont FontId
+  | LoadQueryFont FontName
+  | QueryColor ColormapId Pixel
+  | QueryTree
+  | DefaultRootWindow
+  | GetGeometry
+  | DefaultVisual
+  | Sync Bool -- discard::Bool
+  | QueryTextExtents16 FontId String
+  | ListFonts FontName Int -- pattern, maxnames
+  | ListFontsWithInfo FontName Int -- pattern, maxnames
+  | GetResource RmSpec
+  | DbeQueryExtension
+  | DbeAllocateBackBufferName SwapAction
+  | DbeSwapBuffers SwapAction -- applies only to the fudget's own window.
+  -- ONLY Pseudo requests below:
+  | CreateMyWindow Rect
+  deriving (Eq, Ord, Show, Read)
+
+type Command = XCommand
+
+data BitmapData = BitmapData Size (Maybe Point) [Int] 
+                  deriving (Eq, Ord, Show, Read)
+
+type DisplayName = String
+
+-- Convenient abbreviations:
+moveWindow (Point x y) = ConfigureWindow [CWX x, CWY y]
+resizeWindow (Point w h) = ConfigureWindow [CWWidth w, CWHeight h]
+moveResizeWindow (Rect (Point x y) (Point w h)) =
+    ConfigureWindow [CWX x, CWY y, CWWidth w, CWHeight h]
+
+clearWindowExpose = ClearArea (rR 0 0 0 0) True
+                    -- Clears the window and generates appropriate
+		    -- exposure events.See man page for XClearArea.
diff --git a/hsrc/xtypes/DrawInPixmap.hs b/hsrc/xtypes/DrawInPixmap.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/DrawInPixmap.hs
@@ -0,0 +1,23 @@
+module DrawInPixmap where
+--import Geometry
+import XDraw
+
+-- convenient abbreviations for drawing in pixmaps:
+pmDrawLine pm gc l = draw (Pixmap pm) gc (DrawLine l)
+pmDrawLines pm gc mode ps = draw (Pixmap pm) gc (DrawLines mode ps)
+pmDrawImageString pm gc p s = draw (Pixmap pm) gc (DrawImageString p s)
+pmDrawString pm gc p s = draw (Pixmap pm) gc (DrawString p s)
+pmDrawImageString16 pm gc p s = draw (Pixmap pm) gc (DrawImageString16 p s)
+pmDrawString16 pm gc p s = draw (Pixmap pm) gc (DrawString16 p s)
+pmDrawImageStringPS pm gc p s = draw (Pixmap pm) gc (DrawImageStringPS p s)
+pmDrawStringPS pm gc p s = draw (Pixmap pm) gc (DrawStringPS p s)
+pmDrawRectangle pm gc r = draw (Pixmap pm) gc (DrawRectangle r)
+pmFillRectangle pm gc r = draw (Pixmap pm) gc (FillRectangle r)
+pmFillPolygon pm gc shape mode ps =
+   draw (Pixmap pm) gc (FillPolygon shape mode ps)
+pmDrawArc pm gc r a1 a2 = draw (Pixmap pm) gc (DrawArc r a1 a2)
+pmFillArc pm gc r a1 a2 = draw (Pixmap pm) gc (FillArc r a1 a2)
+pmCopyArea dst gc src r p = draw (Pixmap dst) gc (CopyArea src r p)
+pmCopyPlane dst gc src r p i = draw (Pixmap dst) gc (CopyPlane src r p i)
+pmDrawPoint dst gc p = draw (Pixmap dst) gc (DrawPoint p)
+pmCreatePutImage dst gc r s d = draw (Pixmap dst) gc (CreatePutImage r s d)
diff --git a/hsrc/xtypes/DrawInWindow.hs b/hsrc/xtypes/DrawInWindow.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/DrawInWindow.hs
@@ -0,0 +1,24 @@
+module DrawInWindow where
+--import Geometry
+import XDraw
+
+-- convenient abbreviations for drawing in windows:
+wDrawLine gc l = draw MyWindow gc (DrawLine l)
+wDrawLines gc mode ps = draw MyWindow gc (DrawLines mode ps)
+wDrawImageString gc p s = draw MyWindow gc (DrawImageString p s)
+wDrawString gc p s = draw MyWindow gc (DrawString p s)
+wDrawImageString16 gc p s = draw MyWindow gc (DrawImageString16 p s)
+wDrawString16 gc p s = draw MyWindow gc (DrawString16 p s)
+wDrawImageStringPS gc p s = draw MyWindow gc (DrawImageStringPS p s)
+wDrawStringPS gc p s = draw MyWindow gc (DrawStringPS p s)
+wDrawRectangle gc r = draw MyWindow gc (DrawRectangle r)
+wFillRectangle gc r = draw MyWindow gc (FillRectangle r)
+wFillPolygon gc shape mode ps = draw MyWindow gc (FillPolygon shape mode ps)
+wDrawArc gc r a1 a2 = draw MyWindow gc (DrawArc r a1 a2)
+wFillArc gc r a1 a2 = draw MyWindow gc (FillArc r a1 a2)
+wDrawCircle gc p r = draw MyWindow gc (drawCircle p r)
+wFillCircle gc p r = draw MyWindow gc (fillCircle p r)
+wCopyArea gc src r p = draw MyWindow gc (CopyArea src r p)
+wCopyPlane gc src r p i = draw MyWindow gc (CopyPlane src r p i)
+wDrawPoint gc p = draw MyWindow gc (DrawPoint p)
+wCreatePutImage gc r s d = draw MyWindow gc (CreatePutImage r s d)
diff --git a/hsrc/xtypes/DrawTypes.hs b/hsrc/xtypes/DrawTypes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/DrawTypes.hs
@@ -0,0 +1,44 @@
+module DrawTypes where
+import Geometry(Point,Rect,Line)
+import PackedString(PackedString)
+import Xtypes(Pixel,PixmapId,ImageFormat,DbeBackBufferId)
+
+data DrawCommand
+-- Don't forget to change ../types/Drawcmd.hs too, if you change things here!!
+  = DrawLine Line
+  | DrawImageString Point String
+  | DrawString Point String
+  | DrawRectangle Rect
+  | FillRectangle Rect
+  | FillPolygon Shape CoordMode [Point]
+  | DrawArc Rect Int Int
+  | FillArc Rect Int Int
+  | CopyArea Drawable Rect Point
+  | CopyPlane Drawable Rect Point Int
+  | DrawPoint Point
+  | CreatePutImage Rect ImageFormat [Pixel]
+  --
+  | DrawImageStringPS Point PackedString
+  | DrawStringPS Point PackedString
+  --
+  | DrawLines CoordMode [Point]
+  | DrawImageString16 Point String
+  | DrawString16 Point String
+  deriving (Eq, Ord, Show, Read)
+
+data Drawable
+  = MyWindow
+  | Pixmap PixmapId
+  | DbeBackBuffer DbeBackBufferId
+   deriving (Eq, Ord, Show, Read)
+
+data CoordMode
+  = CoordModeOrigin
+  | CoordModePrevious 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data Shape
+  = Complex
+  | Nonconvex
+  | Convex
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
diff --git a/hsrc/xtypes/Event.hs b/hsrc/xtypes/Event.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Event.hs
@@ -0,0 +1,122 @@
+module Event(module Event,FontStructList,FontStruct) where
+import Font(FontStruct,FontStructList,CharStruct)
+import Visual(Visual)
+import Geometry
+import Xtypes
+--import DialogueIO hiding (IOError)
+
+newtype KeyCode = KeyCode Int deriving (Eq, Ord, Show, Read)
+
+data Pressed = Pressed | Released | MultiClick Int
+               deriving (Eq, Ord, Show, Read)
+
+data Detail = NotifyAncestor |
+              NotifyVirtual |
+              NotifyInferior |
+              NotifyNonlinear |
+              NotifyNonlinearVirtual |
+              NotifyPointer |
+              NotifyPointerRoot |
+              NotifyDetailNothing 
+              deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data Mode = NotifyNormal |
+            NotifyGrab |
+            NotifyUngrab |
+            NotifyWhileGrabbed 
+            deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data Visibility = VisibilityUnobscured |
+                  VisibilityPartiallyObscured |
+                  VisibilityFullyObscured 
+                  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data ClientData = Byte String |
+                  Short [Int] |
+                  Long [Int] 
+                  deriving (Eq, Ord, Show, Read)
+
+data XEvent
+  = FocusIn   { detail::Detail, mode::Mode }
+  | FocusOut  { detail::Detail, mode::Mode }
+  | KeymapNotify
+  | GraphicsExpose { rect::Rect, count::Int, major_code, minor_code::Int}
+  | KeyEvent { time::Time, pos,rootPos::Point, state::ModState, type'::Pressed, keycode::KeyCode, keySym::KeySym, keyLookup::KeyLookup }
+  | ButtonEvent { time::Time, pos,rootPos::Point, state::ModState, type'::Pressed, button::Button}
+  | MotionNotify { time::Time, pos,rootPos::Point, state::ModState }
+  | EnterNotify  { time::Time, pos,rootPos::Point, detail::Detail, mode::Mode, focus::Bool }
+  | LeaveNotify  { time::Time, pos,rootPos::Point, detail::Detail, mode::Mode, focus::Bool }
+  | Expose {rect::Rect, count::Int}
+  | NoExpose
+  | VisibilityNotify Visibility
+  | CreateNotify Window
+  | DestroyNotify Window
+  | UnmapNotify Window
+  | MapNotify Window
+  | MapRequest Window
+  | ReparentNotify
+  | ConfigureNotify Rect Int
+  | ConfigureRequest
+  | GravityNotify
+  | ResizeRequest Point
+  | CirculateNotify
+  | CirculateRequest
+  | PropertyNotify
+  | SelectionClear Atom
+  | SelectionRequest Time Window Selection
+  | SelectionNotify Time Selection
+  | ColormapNotify
+  | ClientMessage Atom ClientData
+  | MappingNotify
+  -- Pseudo event below:
+--  | IOResponse Response
+--
+--  | LayoutPlace Rect
+--  | LayoutSize Size
+--  | LayoutPos Point -- Position in parent window. Occationally useful.
+  | YourWindowId Window
+  | MenuPopupMode Bool -- used by buttonmachine to adjust its behaviour
+  deriving (Show,Read)
+
+type Event = XEvent
+
+data XResponse
+  = DisplayOpened Display
+  | WindowCreated Window
+  | GCCreated GCId
+  | CursorCreated CursorId
+  | PointerGrabbed GrabPointerResult
+  | FontLoaded FontId
+  | LMLFontQueried FontStruct
+  | ColorAllocated (Maybe Color)
+  | PixmapCreated PixmapId
+  | BitmapRead BitmapReturn
+  | RmDatabaseCreated RmDatabase
+  | GotResource (Maybe (String, RmValue))
+  | CoordinatesTranslated Point
+  | GotAtom Atom
+  | GotAtomName (Maybe String)
+  | GotEvent (Window, XEvent)
+  | GotWindowProperty Atom Int Int Int String
+  | PointerQueried Bool Point Point ModState
+  | FontQueried (Maybe FontStructList)
+  | ColorQueried Color
+  | TreeQueried Window Window [Window]  -- root parent children
+  | GotDefaultRootWindow Window
+  | GotGeometry Rect Int Int
+  | GotVisual Visual
+  | Synced
+  | TextExtents16Queried Int Int CharStruct -- ascent descent overall
+  | GotFontList [FontName]
+  | GotFontListWithInfo [(FontName,FontStructList)]
+--  | GotFontListWithInfo [(FontStructList)]
+  | DbeExtensionQueried Int Int Int -- status (/=0 means ok), major, minor
+  | DbeBuffersSwapped Int -- status (useless?)
+  | DbeBackBufferNameAllocated DbeBackBufferId
+  deriving (Show,Read)
+
+data BitmapReturn
+  = BitmapBad
+  | BitmapReturn Size (Maybe Point) PixmapId 
+  deriving (Eq, Ord, Show, Read)
+
diff --git a/hsrc/xtypes/EventMask.hs b/hsrc/xtypes/EventMask.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/EventMask.hs
@@ -0,0 +1,37 @@
+module EventMask where
+
+-- Same order as in X
+data EventMask = KeyPressMask |
+                 KeyReleaseMask |
+                 ButtonPressMask |
+                 ButtonReleaseMask |
+                 EnterWindowMask |
+                 LeaveWindowMask |
+                 PointerMotionMask |
+                 PointerMotionHintMask |
+                 Button1MotionMask |
+                 Button2MotionMask |
+                 Button3MotionMask |
+                 Button4MotionMask |
+                 Button5MotionMask |
+                 ButtonMotionMask |
+                 KeymapStateMask |
+                 ExposureMask |
+                 VisibilityChangeMask |
+                 StructureNotifyMask |
+                 ResizeRedirectMask |
+                 SubstructureNotifyMask |
+                 SubstructureRedirectMask |
+                 FocusChangeMask |
+                 PropertyChangeMask |
+                 ColormapChangeMask |
+                 OwnerGrabButtonMask 
+                 deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+clEventMask =
+    [KeyPressMask, KeyReleaseMask, ButtonPressMask, ButtonReleaseMask, EnterWindowMask,
+     LeaveWindowMask, PointerMotionMask, PointerMotionHintMask, Button1MotionMask,
+     Button2MotionMask, Button3MotionMask, Button4MotionMask, Button5MotionMask,
+     ButtonMotionMask, KeymapStateMask, ExposureMask, VisibilityChangeMask, StructureNotifyMask,
+     ResizeRedirectMask, SubstructureNotifyMask, SubstructureRedirectMask, FocusChangeMask,
+     PropertyChangeMask, ColormapChangeMask, OwnerGrabButtonMask]
diff --git a/hsrc/xtypes/FRequest.hs b/hsrc/xtypes/FRequest.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/FRequest.hs
@@ -0,0 +1,34 @@
+-- | Fudget low-level message types
+module FRequest(
+  module FRequest,
+  XCommand,XEvent,XRequest,XResponse,
+  SocketRequest,SocketResponse,
+  LayoutMessage,LayoutResponse
+  --AsyncInput(..)
+) where
+import Command(XCommand,XRequest)
+import Event(XEvent,XResponse)
+import Sockets(SocketRequest,SocketResponse{-,AsyncInput-})
+import DialogueIO(Request,Response)
+import LayoutRequest(LayoutMessage(..),LayoutResponse)
+
+data FRequest
+  = XCmd XCommand
+  | LCmd LayoutMessage
+  -- asynchronous above, synchronous below, but see ../internal/IsRequest.hs
+  | XReq XRequest
+  | SReq SocketRequest
+  | DReq Request
+  deriving Show
+
+data FResponse
+  = XEvt  XEvent
+  | LEvt  LayoutResponse
+--  | SEvt  AsyncInput -- still represented as DResp (AsyncInput ...)
+  -- asynchronous above, synchronous below, but see ../internal/IsRequest.hs
+  | XResp XResponse
+  | SResp SocketResponse
+  | DResp Response
+  deriving Show
+
+layoutRequestCmd = LCmd . LayoutRequest
diff --git a/hsrc/xtypes/Image.hs b/hsrc/xtypes/Image.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Image.hs
@@ -0,0 +1,7 @@
+module Image where
+
+newtype ImageFormat = ImageFormat Int deriving (Eq, Ord, Read, Show)
+
+xyBitmap = ImageFormat 0
+xyPixmap = ImageFormat 1
+zPixmap  = ImageFormat 2
diff --git a/hsrc/xtypes/ResourceIds.hs b/hsrc/xtypes/ResourceIds.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/ResourceIds.hs
@@ -0,0 +1,44 @@
+module ResourceIds where
+--import Data.Word(Word32)
+
+newtype XID = XID Int deriving (Eq,Ord)
+
+instance Show XID where showsPrec d (XID w32) = showsPrec d w32
+instance Read XID where readsPrec d s = [(XID w,r)|(w,r)<-readsPrec d s]
+
+newtype WindowId = WindowId XID deriving (Eq, Ord, Show, Read)
+
+type Window = WindowId
+type XWId = WindowId
+
+rootWindow = WindowId (XID 0)
+noWindow = WindowId (XID (-1))
+windowNone = WindowId (XID 0)
+
+newtype PixmapId = PixmapId XID deriving (Eq, Ord, Show, Read)
+newtype DbeBackBufferId = DbeBackBufferId XID deriving (Eq, Ord, Show, Read)
+newtype FontId = FontId XID deriving (Eq, Ord, Read, Show)
+newtype GCId = GCId Int deriving (Eq, Ord, Read, Show)
+newtype CursorId = CursorId XID deriving (Eq, Ord, Read, Show)
+newtype ColormapId = ColormapId XID deriving (Eq, Ord, Read, Show)
+
+defaultColormap = ColormapId (XID 0)
+cursorNone = CursorId (XID 0)
+
+newtype Atom = Atom Int deriving (Eq, Ord, Show, Read)
+
+
+type ColorName = String
+type FontName = String
+
+type Time = Int
+currentTime = 0::Time
+
+type Depth = Int
+
+copyFromParent = 0 :: Depth
+parentRelative = PixmapId (XID 1)
+none = PixmapId (XID 0)
+
+rootGC = GCId 0
+
diff --git a/hsrc/xtypes/Sockets.hs b/hsrc/xtypes/Sockets.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Sockets.hs
@@ -0,0 +1,68 @@
+module Sockets(DLValue,module Sockets) where
+import Event(XEvent)
+import Xtypes(WindowId,Display)
+import PackedString(PackedString)
+import DLValue
+import System.Posix.DynamicLinker(DL)
+
+-- NOTE: Matching definitions for the C world appear in xlib/sockets.h --------
+
+data SocketRequest = OpenLSocket Port                -- -> SR LSocket
+                   | OpenSocket Host Port            -- -> SR Socket
+                   | WriteSocket Socket String       -- -> SR Success
+                   | CloseSocket Socket              -- -> SR Success
+                   | CloseLSocket LSocket            -- -> SR Success
+                   | GetStdinSocket                  -- -> SR Socket
+                   | CreateTimer Int Int             -- -> SR Timer
+                   | DestroyTimer Timer              -- -> Success
+		   | GetLSocketName LSocket          -- -> Str
+		   | GetSocketName Socket            -- -> Str
+		   | StartProcess String Bool Bool Bool -- -> ProcessSockets
+		   | DLOpen String                   -- -> SR DLHandle
+		   | DLClose DLHandle		     -- -> Success
+                   | DLSym DLHandle String           -- -> SR DLValue
+		   | OpenFileAsSocket String String  -- -> SR Socket
+		                   -- name,  mode  (as in fopen(name,mode))
+		   | WriteSocketPS Socket PackedString -- -> SR Wrote
+                   | GetStdoutSocket                 -- -> SR Socket
+                      deriving (Show,Read)
+
+data SocketResponse = LSocket LSocket
+                    | Socket Socket
+                    | Timer Timer
+		    | ProcessSockets (Maybe Socket) (Maybe Socket) (Maybe Socket)
+                    | DLHandle DLHandle
+                    | DLVal DLValue
+		    | Wrote Int
+                      deriving (Show,Read) --(Eq, Ord, Text)
+
+type Port = Int
+type Host = String
+type Peer = Host
+
+newtype Socket = So Int deriving (Eq,Ord,Show,Read)
+newtype LSocket = LSo Int deriving (Eq,Ord,Show,Read)
+
+newtype Timer = Ti Int deriving (Eq,Ord,Show,Read)
+
+type AsyncInput = (Descriptor, AEvent)
+
+data Descriptor
+  = LSocketDe LSocket
+  | SocketDe Socket
+  | OutputSocketDe Socket
+  | TimerDe Timer
+  | DisplayDe Display 
+  deriving (Eq, Ord, Read, Show)
+
+data AEvent
+  = SocketAccepted Socket Peer
+  | SocketRead String
+  | SocketWritable
+  | TimerAlarm
+  | XEvent (WindowId, XEvent) 
+  deriving (Show,Read)
+
+newtype DLHandle = DL DL deriving Show
+
+instance Read DLHandle
diff --git a/hsrc/xtypes/Visual.hs b/hsrc/xtypes/Visual.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Visual.hs
@@ -0,0 +1,19 @@
+module Visual where
+import HbcWord
+
+data DisplayClass
+  = StaticGray | GrayScale
+  | StaticColor | PseudoColor
+  | TrueColor | DirectColor
+  deriving (Eq,Show,Read,Bounded,Enum)
+
+newtype VisualID = VisualID Int deriving (Eq,Show,Read)
+
+data Visual
+  = Visual { visualid :: VisualID,
+	     visualClass :: DisplayClass,
+	     red_mask,green_mask,blue_mask :: Word,
+	     bits_per_rgb :: Int,
+	     map_entries :: Int
+	   }
+  deriving (Show,Read)
diff --git a/hsrc/xtypes/XDraw.hs b/hsrc/xtypes/XDraw.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/XDraw.hs
@@ -0,0 +1,20 @@
+module XDraw(module DrawTypes,module XDraw) where
+import Command(XCommand(Draw,DrawMany,ClearArea,ClearWindow))
+import FRequest
+import Geometry(Rect(..),Point(..))
+import DrawTypes
+
+draw d gc dcmd = XCmd (Draw d gc dcmd)
+drawMany d dcmds = XCmd (DrawMany d dcmds)
+
+wDraw = draw MyWindow
+wDrawMany = drawMany MyWindow
+
+pmDraw = draw . Pixmap 
+pmDrawMany = drawMany . Pixmap
+
+clearArea r b = XCmd (ClearArea r b)
+clearWindow = XCmd ClearWindow
+
+fillCircle p r = FillArc (Rect p (Point r r)) 0 (64 * 360)
+drawCircle p r = DrawArc (Rect p (Point r r)) 0 (64 * 360)
diff --git a/hsrc/xtypes/XStuff.hs b/hsrc/xtypes/XStuff.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/XStuff.hs
@@ -0,0 +1,8 @@
+module XStuff(XCommand,XEvent,XWId(..),WindowId,XRequest,XResponse,AsyncInput(..),AEvent,SocketRequest,Descriptor,SocketResponse,XDisplay(..),Display) where
+import Command
+import Event
+import Sockets
+import Xtypes
+
+-- This file part is NOT part of the Fudget library. It is used
+-- to create an interface file for use in the Prelude construction.
diff --git a/hsrc/xtypes/XTypesModules.hs b/hsrc/xtypes/XTypesModules.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/XTypesModules.hs
@@ -0,0 +1,11 @@
+module XTypesModules (-- * X types
+  module FRequest,module Command,module Event,module Sockets ,module Xtypes,module Visual,module XDraw,module DrawInPixmap, module DrawInWindow) where
+import FRequest
+import Command
+import Event
+import Sockets
+import Xtypes
+import Visual
+import XDraw
+import DrawInPixmap
+import DrawInWindow
diff --git a/hsrc/xtypes/Xtypes.hs b/hsrc/xtypes/Xtypes.hs
new file mode 100644
--- /dev/null
+++ b/hsrc/xtypes/Xtypes.hs
@@ -0,0 +1,164 @@
+module Xtypes(module Xtypes,module EventMask,module AuxTypes,module ResourceIds,module Image) where
+--import Geometry(Line, Point, Rect)
+import EventMask
+import AuxTypes
+import ResourceIds
+import Image
+import Data.Ix
+import HbcWord
+
+-- #ifdef __NHC__
+-- Bug in export of newtype
+-- #define newtype data
+-- #endif
+
+newtype Display = Display Int deriving (Eq, Ord, Show, Read)
+type XDisplay = Display
+
+noDisplay = Display (-1)
+
+type KeyLookup = String
+type Width = Int
+
+newtype Pixel = Pixel Word deriving (Eq, Ord, Show, Read)
+
+type PlaneMask = Pixel
+
+pixel0 = Pixel 0
+pixel1 = Pixel 1
+--black = Pixel 0 -- not always true !!
+--white = Pixel 1 -- not always true !!
+
+data RGB = RGB Int Int Int deriving ( Eq, Ord, Show, Read, Ix )
+data Color = Color { colorPixel::Pixel, colorRGB::RGB }
+             deriving (Eq, Ord, Show, Read)
+
+maxRGB :: Int -- for hugs
+maxRGB = 65535
+grayRGB x = RGB x x x
+whiteRGB = grayRGB maxRGB
+blackRGB = grayRGB 0
+
+data Selection = Selection Atom Atom Atom  deriving (Eq, Ord, Show, Read)
+
+
+newtype PropertyMode = PropertyMode Int deriving (Eq, Ord, Show, Read)
+
+propModeReplace = PropertyMode 0
+propModePrepend = PropertyMode 1
+propModeAppend  = PropertyMode 2
+
+--data EventMask -- moved to EventMask.hs
+
+data BackingStore
+  = NotUseful | WhenMapped | Always 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data GrabPointerResult
+  = GrabSuccess
+  | AlreadyGrabbed
+  | GrabInvalidTime
+  | GrabNotViewable
+  | GrabFrozen 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+-- Same order as in X.h
+data GCFunction
+  = GXclear
+  | GXand
+  | GXandReverse
+  | GXcopy
+  | GXandInverted
+  | GXnoop
+  | GXxor
+  | GXor
+  | GXnor
+  | GXequiv
+  | GXinvert
+  | GXorReverse
+  | GXCopyInverted
+  | GXorInverted
+  | GXnand
+  | GXset 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+
+-- Same order as in X.h
+data GCLineStyle
+  = LineSolid | LineDoubleDash | LineOnOffDash 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data GCCapStyle
+  = CapNotLast | CapButt | CapRound | CapProjecting 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data GCJoinStyle
+  = JoinMiter | JoinRound | JoinBevel
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+  
+data GCSubwindowMode
+  = ClipByChildren | IncludeInferiors 
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data GCFillStyle
+  = FillSolid | FillTiled | FillStippled | FillOpaqueStippled
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
+
+data GCAttributes a b
+  = GCFunction GCFunction
+  | GCForeground a
+  | GCBackground a
+  | GCLineWidth Width
+  | GCLineStyle GCLineStyle
+  | GCFont b
+  | GCCapStyle GCCapStyle
+  | GCSubwindowMode GCSubwindowMode
+  | GCGraphicsExposures Bool
+  | GCFillStyle GCFillStyle
+  | GCTile PixmapId
+  | GCStipple PixmapId
+  | GCJoinStyle GCJoinStyle
+  deriving (Eq, Ord, Show, Read)
+
+type GCAttributeList = [GCAttributes Pixel FontId]
+
+--invertGCattrs = invertColorGCattrs white black
+
+invertColorGCattrs bgcol fgcol =
+    [GCFunction GXxor, GCForeground (invcol bgcol fgcol)]
+
+invcol (Pixel bg) (Pixel fg) = Pixel (bitXor bg fg)
+
+data WindowAttributes
+  = CWEventMask [EventMask]
+  | CWBackingStore BackingStore
+  | CWSaveUnder Bool
+  | CWDontPropagate [EventMask]
+  | CWOverrideRedirect Bool
+  | CWBackPixel Pixel
+  | CWCursor CursorId
+  | CWBitGravity Gravity
+  | CWWinGravity Gravity
+  | CWBackPixmap PixmapId
+  | CWBorderPixmap PixmapId
+  | CWBorderPixel Pixel
+  deriving (Eq, Ord, Show, Read)
+
+data WindowChanges
+  = CWX Int
+  | CWY Int
+  | CWWidth Int
+  | CWHeight Int
+  | CWBorderWidth Int
+  | CWStackMode StackMode 
+  deriving (Eq, Ord, Show, Read)
+
+data StackMode
+  = StackAbove | StackBelow | TopIf | BottomIf | Opposite 
+  deriving (Eq, Ord, Read, Show, Bounded, Enum)
+
+
+-- DBE (double buffering extension):
+data SwapAction
+  = DbeUndefined | DbeBackground | DbeUntouched | DbeCopied
+  deriving (Eq, Ord, Show, Read, Bounded, Enum)
diff --git a/xlib/fdzero.c b/xlib/fdzero.c
new file mode 100644
--- /dev/null
+++ b/xlib/fdzero.c
@@ -0,0 +1,53 @@
+#include <sys/types.h>
+#include <errno.h>
+#include <stdio.h>
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#ifdef __MACH__
+#include <sys/time.h>
+#endif
+
+/* For use in ghc-dialogue/AsyncInput.hs since
+   calling FD_ZERO from _casm_ doesn't work with ghc on Linux-386. gcc
+   compilains about a spilled register. /TH 2000-03-17
+
+   Used for more functions after getting rid of _casm_/_ccall_ for GHC 6.2... 
+   /TH 2004-03-25
+*/
+
+void fdzero(fd_set *s) { FD_ZERO(s); }
+void fdset(int fd,fd_set *s) { FD_SET(fd,s); }
+int fdisset(int fd,fd_set *s) { return FD_ISSET(fd,s); }
+/* void bcopy_fdset(fd_set *src,fd_set *dst) { bcopy(src,dst,sizeof(fd_set)); } */
+void bcopy_fdset(fd_set *src,fd_set *dst) { *dst=*src; }
+
+int get_errno(void) { return errno; }
+long get_stdin(void) { return (long)stdin; }
+int get_fileno(long f) { return fileno((FILE *)f); }
+
+void xDestroyImage(XImage *ximage) { XDestroyImage(ximage); }
+void setXImage_data(XImage *ximage,char *data) { ximage->data=data; }
+
+int default_bpp(Display *d,int depth) {
+  int i,cnt,bpp;
+  XPixmapFormatValues *ps=XListPixmapFormats(d,&cnt);
+  bpp=depth; /* Hmm. Something is wrong if depth isn't found. */
+  for(i=0;i<cnt;i++)
+    if(ps[i].depth==depth) {
+      bpp=ps[i].bits_per_pixel;
+      break;
+    }
+  XFree(ps);
+  /*fprintf(stderr,"default_bpp(%d,%d)=%d\n",(int)d,depth,bpp);*/
+  return bpp;
+}
+
+void disable_timers(void) {
+#ifdef __MACH__
+  /* Disable timers set up by the GHC RTS. */
+  struct itimerval zero;
+  timerclear(&zero.it_interval);
+  timerclear(&zero.it_value);
+  setitimer(ITIMER_VIRTUAL,&zero,NULL);
+#endif
+}
diff --git a/xlib/socketlib/defs.h b/xlib/socketlib/defs.h
new file mode 100644
--- /dev/null
+++ b/xlib/socketlib/defs.h
@@ -0,0 +1,18 @@
+/*
+ * (c) Copyright 1991 by Panagiotis Tsirigotis
+ * Read the file COPYRIGHT for more details.
+ * 
+ */
+/*
+ * $Header: /home/magnus/cvs/Fudgets/xlib/socketlib/defs.h,v 1.1.1.1 1996-03-10 16:56:13 magnus Exp $
+ */
+
+#define SYSCALL_ERROR		-1
+#define RESOLVER_ERROR		-2
+#define OPTION_ERROR			-3
+
+/*
+ * How many times to try gethostbyname
+ */
+#define MAX_TRIES				3
+
diff --git a/xlib/socketlib/inet.c b/xlib/socketlib/inet.c
new file mode 100644
--- /dev/null
+++ b/xlib/socketlib/inet.c
@@ -0,0 +1,404 @@
+/*
+ * (c) Copyright 1991 by Panagiotis Tsirigotis
+ * Read the file COPYRIGHT for more details.
+ * 
+ */
+/*
+ * Internet support library.
+ *
+ * INTERFACE:
+ *
+ *		in_address			: form an internet address
+ *		in_bind				: bind a socket to an internet address
+ *		in_bind_opt			: bind a socket to an internet address and
+ *								  set (for now, binary) options
+ *		in_connect			: connect to an internet address
+ *		in_connect_opt		: connect to an internet address and
+ *								  set (for now, binary) options
+ *
+ */
+
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+#include <netdb.h>
+/* #include <stdarg.h> */
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+#include <unistd.h>
+#include <errno.h>    /* on some systems, errno is not a variable */
+/* extern int errno ; */
+
+#include <sys/param.h>
+#ifdef MAXHOSTNAMELEN
+#define HOST_NAME_LEN		MAXHOSTNAMELEN
+#else
+#define HOST_NAME_LEN		32
+#endif
+
+#include "defs.h"
+
+#if defined(__NetBSD__) || defined(_HPUX_SOURCE)
+extern int h_errno;
+#endif
+
+/*
+ * $Header: /home/magnus/cvs/Fudgets/xlib/socketlib/inet.c,v 1.7 2013-07-28 12:09:13 hallgren Exp $
+ */
+
+#define PRIVATE				static
+
+static char *version = VERSION ;
+
+enum status_e { OK, ERROR } ;
+
+
+/*
+ * Close a file descriptor without destroying errno
+ */
+#define CLOSE( sd, t )				t = errno ;						\
+											(void) close( sd ) ;			\
+											errno = t
+#ifndef FALSE
+#define FALSE			0
+#define TRUE			1
+#endif
+
+
+/*
+ * Returns TRUE if the host argument has the form:
+ *		<num>.<num>
+ *		<num>.<num>.<num>
+ *		<num>.<num>.<num>.<num>
+ */
+PRIVATE int is_number_address( host )
+	char *host ;
+{
+	register int dot_count = 0 ;
+	register char *p ;
+
+	if ( host == NULL )
+		return( FALSE ) ;
+	
+	for ( p = host ; *p ; p++ )
+		if ( isascii( *p ) && isdigit( *p ) )		/* skip digits */
+			continue ;
+		else if ( *p == '.' )							/* count dots */
+		{
+			dot_count++ ;
+			if ( dot_count > 3 )
+				return( FALSE ) ;
+		}
+		else													/* reject everything else */
+			return( FALSE ) ;
+	return( dot_count > 0 ) ;
+}
+
+
+
+/*
+ * Form an Internet address.
+ * If host is NULL, the current host is assumed (but this does not
+ * guarantee the use of the loopback address)
+ *
+ * Return value:
+ *		0					: if successful
+ *		RESOLVER_ERROR	: if an error occurs
+ *
+ * In case of error, errno is set to the value of h_errno, if the OS
+ * supports h_errno; if not, the value of errno is undefined.
+ */
+int in_address( host, port, address )
+	char *host ;
+	short port ;
+	struct sockaddr_in *address ;
+{
+	char host_name[ HOST_NAME_LEN ] ;
+	char *the_host ;
+	struct hostent *hp ;
+
+	bzero( (char *) address, sizeof( *address ) ) ;
+
+	/*
+	 * Determine the host name
+	 */
+	if ( host == NULL )
+	{
+		(void) gethostname( host_name, HOST_NAME_LEN ) ;
+		the_host = host_name ;
+	}
+	else
+		the_host = host ;
+	
+	/*
+	 * Get host address
+	 */
+	if ( is_number_address( host ) )
+		address->sin_addr.s_addr = inet_addr( host ) ;
+	else
+	{
+
+#ifndef HAS_H_ERRNO
+		if ( ( hp = gethostbyname( the_host ) ) == NULL )
+			return( RESOLVER_ERROR ) ;
+#else
+		int tries = 0 ;
+
+		while ( ( hp = gethostbyname( the_host ) ) == NULL &&
+				  (h_errno == TRY_AGAIN
+#if __FreeBSD__ == 2
+   /* Needed because of FreeBSD 2.2-961014-SNAP bug? */
+				   || h_errno == NETDB_INTERNAL
+#endif
+				   ) &&
+				  tries < MAX_TRIES )
+			tries++ ;
+		if ( hp == NULL )
+		{
+			errno = h_errno ;
+			return( RESOLVER_ERROR ) ;
+		}
+#endif	/* HAS_H_ERRNO */
+
+		bcopy( hp->h_addr, (char *) &address->sin_addr, hp->h_length ) ;
+	}
+
+	address->sin_family = AF_INET ;
+	address->sin_port = htons( port ) ;
+
+	return( 0 ) ;
+}
+
+
+
+/*
+ * Bind an internet address. Port is the port that will be used; the
+ * address is that of the machine the program runs on.
+ * Type is the type of socket; this also defines the protocol
+ * that will be used (i.e. for SOCK_STREAM use TCP etc)
+ *
+ * Return value:
+ *		a file descriptor	:  if the operation is successful
+ *		SYSCALL_ERROR 		: if there is a system call error
+ *		RESOLVER_ERROR 	: if there is a resolver error
+ * In case of error, errno contains a description of the error
+ */
+PRIVATE	int bind_address() ;
+
+int in_bind( port, type )
+	short port ;
+	int type ;
+{
+	int sd ;
+
+	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )
+		return( SYSCALL_ERROR ) ;
+	
+	return( bind_address( sd, port ) ) ;
+}
+
+#if 0
+PRIVATE	va_list apply_options() ;
+#endif
+
+/*
+ * Same as in_bind but also sets socket-level options.
+ * The option list is a list of pairs (option, option_value) terminated
+ * by NULL.
+ */
+#if 0
+int in_bind_opt( port, type, va_alist )
+	short port ;
+	int type ;
+	va_dcl
+{
+	int sd ;
+	enum status_e status ;
+	va_list ap ;
+	
+	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )
+		return( SYSCALL_ERROR ) ;
+	
+	va_start( ap ) ;
+	ap = apply_options( sd, ap, &status );
+	va_end( ap ) ;
+	if ( status == ERROR )
+		return( OPTION_ERROR ) ;
+
+	return( bind_address( sd, port ) ) ;
+}
+#endif
+
+
+
+/*
+ * bind_address binds the address <INADDR_ANY,port> to a socket.
+ * Return value:
+ *		socket			: if successful
+ *		SYSCALL_ERROR	: if bind fails
+ *		RESOLVER_ERROR	: if it can't get the address of the local host
+ */
+PRIVATE int bind_address( sd, port )
+	int sd ;
+	short port ;
+{
+	struct sockaddr_in sin ;
+	int errno_save ;
+
+	sin.sin_family = AF_INET ;
+	sin.sin_addr.s_addr = INADDR_ANY ;
+	sin.sin_port = htons( port ) ;
+
+	if ( bind( sd, (struct sockaddr *) &sin, sizeof( sin ) ) == -1 )
+	{
+		CLOSE( sd, errno_save ) ;
+		return( SYSCALL_ERROR ) ;
+	}
+	return( sd ) ;
+}
+
+
+/*
+ * Apply the options in the option_list.
+ * Return value:
+ *		The remaining part of the argument list
+ *
+ * The status argument shows if there has been an error.
+ * In case of error, the socket is closed.
+ */
+#if 0
+PRIVATE va_list apply_options( sd, option_list, status )
+	int sd ;
+	va_list option_list ;
+	enum status_e *status ;
+{
+	register int option ;
+	int errno_save ;
+
+	/*
+	 * Apply the options
+	 */
+	while ( ( option = va_arg( option_list, int ) ) != NULL )
+	{
+		int option_value ;
+
+		/*
+		 * For the moment accept only boolean options
+		 */
+		switch ( option )
+		{
+			case SO_DEBUG:
+			case SO_REUSEADDR:
+			case SO_KEEPALIVE:
+			case SO_DONTROUTE:
+			case SO_BROADCAST:
+			case SO_OOBINLINE:
+				option_value = va_arg( option_list, int ) ;
+				if ( setsockopt( sd, SOL_SOCKET, option,
+							&option_value, sizeof( option_value ) ) == -1 )
+				{
+					CLOSE( sd, errno_save ) ;
+					*status = ERROR ;
+					return( option_list ) ;
+				}
+				break ;
+
+			default:
+				break ;
+		}
+	}
+	*status = OK ;
+	return( option_list ) ;
+}
+#endif
+
+PRIVATE	int connect_to_host() ;
+
+/*
+ * Connect to an internet address. The address is specified by the
+ * host, port arguments. Type is the type of the socket which
+ * defines the type of the protocol to be used.
+ * If host is NULL, then the local host is implied.
+ *
+ * Return value:
+ *		a file descriptor	:  if the operation is successful
+ *		SYSCALL_ERROR 		: if there is a system call error
+ *		RESOLVER_ERROR 	: if there is a resolver error
+ * In case of error errno contains a description of the error
+ */
+int in_connect( host, port, type )
+	char *host ;
+	short port ;
+	int type ;
+{
+	int sd ;
+
+	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )
+		return( SYSCALL_ERROR ) ;
+	
+	return( connect_to_host( sd, host, port ) ) ;
+}
+
+
+
+/*
+ * Same as in_connect but also sets socket-level options
+ */
+#if 0
+int in_connect_opt( host, port, type, va_alist )
+	char *host ;
+	short port ;
+	int type ;
+	va_dcl
+{
+	int sd ;
+	enum status_e status ;
+	va_list ap ;
+	int connect_to_host() ;
+	va_list apply_options() ;
+
+	if ( ( sd = socket( AF_INET, type, 0 ) ) == -1 )
+		return( SYSCALL_ERROR ) ;
+	
+	va_start( ap ) ;
+	ap = apply_options( sd, ap, &status ) ;
+	va_end( ap ) ;
+	if ( status == ERROR )
+		return( OPTION_ERROR ) ;
+	
+	return( connect_to_host( sd, host, port ) ) ;
+}
+#endif
+
+/*
+ * connect_to_host tries to connect socket sd to the address <host,port>
+ * Return value:
+ *		socket				: if the operation is successful
+ *		RESOLVER_ERROR		: if there is a resolver error
+ *		SYSCALL_ERROR		: if connect(2) fails
+ */
+PRIVATE int connect_to_host( sd, host, port )
+	int sd ;
+	char *host ;
+	short port ;
+{
+	struct sockaddr_in sin ;
+	int errno_save ;
+
+	if ( in_address( host, port, &sin ) == RESOLVER_ERROR )
+	{
+		CLOSE( sd, errno_save ) ;
+		return( RESOLVER_ERROR ) ;
+	}
+
+	if ( connect( sd, (struct sockaddr *) &sin, sizeof( sin ) ) == -1 )
+	{
+		CLOSE( sd, errno_save ) ;
+		return( SYSCALL_ERROR ) ;
+	}
+	return( sd ) ;
+}
+