A small set of demos for FranTk. 
These show some of the basics of programming in FranTk.
To run the demos, run main

\begin{code}
module Main where
import FranTk
import qualified StaticTypes as S
import IOExts
import Compatibility

main :: IO ()
main = display $ runAll
\end{code}

Make the demos main window. This is the root window. It's a hypertext 
introduction to all the demos.

\begin{code}
runAll :: WComponent
runAll =  do
  quit <- mkGUIL_ quit
  let men = mkMenu [] 
             [mcascade [text "File"] $ 
                mkMenu []
                 [mbutton [text "Quit"] quit]] 

  withRootWindow [title "Demos",useMenu men] $ do
   mk <- mkGUIL $ maybe (return ()) render . flip lookup demos
   hypertextPage (lift0 demotxt) mk    
 where
   demotxt = [Heading "FranTk Demo Set\n",
	      Text "Follow the links to run the FranTk demos. The demos illustrate various widgets. They all appear in the usermanual. The first set appear in the introductory concepts chapter, the second in the widgets chapter.\n\n",
              Heading "Demos 1\n",
	      link "Hello world",
	      Text "\nA simple hello world example.\n\n",
	      link "Counter",
              Text "\nA counter with inputs via buttons and a slider.\n\n",
	      link "Converter",
	      Text "\nA distance converter translating between inches, feet, yards and miles. Type in a distance and press return.\n\n",
              link "Shared login system",
              Text "\nThe shared login system. It allows a group of users to log on to a system and monitor who else is also logged on. Users can log on with the register window. They each have an individual window that displays their name in the title bar. They can change their own details using the entry area. Pressing the \"set\" button updates their details with the current value of the entry area. Each user can \neach see the name of the other users and if they wish their details. The details field is only shown \nwhen the \"view\" checkbutton is selected.\n\n" ,
	      Heading "Demos 2\n",
              link "Message widget",
	      Text "\nA message widget. Displays multiline formatted text\n\n",
	      link "List of objects",
	      Text "\nA dynamic list of labels. Type in a name, then press add or delete. Filter by typing in a list of names. Sort in ascending or descending order.\n\n",
	      link "List of menu objects",
	      Text "\nA dynamic list of menu objects. Like the previous list except, dynamicly alters menu items, not buttons.\n\n",
	      link "Canvas items",
	      Text "\nA dynamic list of canvas items. Create each type by clicking on the relevant button. Click and drag \nto move an object around.\n\n",
	      link "Stacking Canvas items",
	      Text "\nA dynamic list of canvas items. Order in the list affects how high up the pile the item is. Click and drag \nto move an object around. (Clicking on an object also moves it to the top of the pile.\n\n",
	      link "Multiple text widgets",
              Text "\nTwo text widgets. Typing in either affects the text in both.\n\n",
	      link "Simple hypertext example",
	      Text "\nA simple hypertext example. Two pages, with connecting hyperlinks.\n\n",
	      link "Talk program",
	      Text "\nAn example program, like unix talk. Each user has two text areas. The top widget is the one you type \ninto. The bottom one shows the other users typing.\n\n",
	      link "Shared text editor",
	      Text "\nAn example text editor, with two views. Can set the font size and color, and copy, cut and paste.\n\n"
	      ]

   link s = Link s s

   demos = [("Hello world", test1),
	    ("Counter", test2),
	    ("Converter", test3),
	    ("Shared login system", test4),

	    ("Message widget",test5),
	    ("List of objects", test6),
	    ("List of menu objects", test7),
	    ("Canvas items", test8),
	    ("Stacking Canvas items", test9),
	    ("Multiple text widgets", test10),
	    ("Simple hypertext example", test11),
	    ("Talk program", test12),
            ("Shared text editor", test13)]
\end{code}


The hello world program
\begin{code}
test1 :: WComponent
test1 =  withStyle [background $ S.yellow] $
	  mkWindow [title "Hello World"] $
           mkLabel [text "Hello world"]
\end{code}

The counter with button and slider (from the user manual)
\begin{code}
test2 :: WComponent
test2 = 
  mkWindow [title "Counter"] $ 
    do m <- mkBVar 0;composite m
 where
  composite,slider,counterB,lbl,incb,decb :: BVar Int -> Component
  composite m = above (counterB m) (slider m)
  slider m = mkHScale [scaleValB (bvarBehavior m)] (input m)
  counterB m = above (lbl m) (beside (incb m) (decb m))

  lbl m = mkLabel [textB (lift1 show (bvarBehavior m))]

  bound :: Int -> Int
  bound x = if x > 100 then 100 else if x < 0 then 0 else x

  incr,decr :: Int -> Int
  incr x = bound (x + 1)
  decr x = bound (x - 1)

  incb m = mkButton [text "inc"] (tellL (bvarUpdInput m) incr)
  decb m = mkButton [text "dec"] (tellL (bvarUpdInput m) decr)

\end{code}

a distance converter

\begin{code}

test3 :: WComponent
test3 = mkWindow [title "Converter"] $ do
	 state <- mkBVar (snd $ head units)
    	 value <- mkBVar 0
    	 converter state value units

type Convert = (Double -> Double,Double -> Double)

units :: [(String,Convert)]
units = [("Inches",(id,id)),
	 ("Feet",(\x -> x * 12,\x -> x / 12)),
	 ("Yards",(\x -> x * 36, \x -> x / 36)),
	 ("Miles", (\x -> x * 63400,\x -> x /63400))]

converter :: BVar Convert -> BVar Double -> [(String,Convert)]
	  	-> Component 
converter state value types = 
  radiobuttons state types `above` entry state value 

entry :: BVar Convert -> BVar Double -> Component
entry state value = mkEntryRtrn [textB (currentValue state value)] 					     (setValue state value)

currentValue :: BVar Convert -> BVar Double 
   -> Behavior String
currentValue state value =
		lift2 getVal (bvarBehavior state) (bvarBehavior value)
  where
 	getVal :: Convert -> RealVal -> String
	getVal (toUnit,fromUnit) unit = show $ fromUnit unit

setValue :: BVar Convert -> BVar Double -> Listener String
setValue state value = 
	withSnapL setVal (bvarBehavior state) (input value)
  where
	setVal :: String -> Convert -> RealVal
	setVal val (toUnit,fromUnit) = toUnit $ read val

radiobuttons :: BVar Convert -> [(String,Convert)] -> Component
radiobuttons state types = do
 r <- mkRadio (Just $ fst $ head types)
 let radio (s,info) = mkRadiobutton [text s,useRadio r s]
				  (tellL (input state) info)
 nbeside (map radio types)


\end{code}


The shared login system from the user manual 
\begin{code}

test4 :: WComponent 
test4 = do
 privatelst <- mkListBVar []
 windows (addUser privatelst) (collection privatelst)
   
data PublicUser = PublicUser {
	publicName :: String,
	publicDetails :: Behavior String
	}

mkPublicNode :: PublicUser -> Component
mkPublicNode (PublicUser nm details) = do
 visdetails <- mkBVar True
 let name = mkLabel [text nm]
     vischeck = mkCheckbutton [text "view", checkVal True] (input visdetails) 
     detailsLbl = mkLabel [textB $ details]
 above (nbeside [name,vischeck]) 
       (ifB (bvarBehavior visdetails) detailsLbl emptyComponent)

data PrivateUser = PrivateUser {
	name :: String,
	details :: BVar String,
	otherUsers :: ListB PublicUser,
	exit :: Listener ()
	}
instance Show PrivateUser where
 show p = name p

instance Eq PrivateUser where
 p == p1 = name p == name p1

mkEditWithButton :: String -> Listener String -> Component
mkEditWithButton bname inputL = do
 wire <- mkWire 
 let button = mkButton [text bname] (tellL (input wire) ())
     entry = mkEntry [] (event wire) inputL
 beside entry button

usersArea :: ListB PublicUser -> Component
usersArea users = nabove $ fmap mkPublicNode users 

mkUserWindow :: PrivateUser -> WComponent
mkUserWindow (PrivateUser nm details others exit) = do
 let winmenu = mkMenu [] [mcascade [text "Run"] 
				(mkMenu [] [mbutton [text "Exit"] exit])]
 mkWindow [title $ "User " ++ nm,useMenu winmenu] $ 
   let editarea = mkEditWithButton "set" (input details)
       usersarea = usersArea others
   in above editarea usersarea


registerWindow :: Listener String -> WComponent
registerWindow add = mkWindow [title "Register user"] $  
			mkEditWithButton "add" add

windows :: Listener String -> ListB PrivateUser -> WComponent
windows add users = pile [registerWindow add,
         		  pile $ fmap mkUserWindow users]

addUser :: ListBVar PrivateUser -> Listener String
addUser lst = mapIOL mkUser (appendListB lst)
  where
     mkUser :: String -> IO PrivateUser
     mkUser nm = do 
		details <- newBVar ""
   		let exit = tellL (deleteListB lst) pu 
  		    pu = PrivateUser nm details others exit 
		    others = fmap toPublic $ 
      				filterLB (\x -> name x /= nm) $ 
				collection lst
		return pu

     toPublic :: PrivateUser -> PublicUser
     toPublic (PrivateUser {name = nm,details = ds}) = 
			PublicUser nm (bvarBehavior ds)
\end{code}

A multiline message widget

\begin{code}

test5 :: WComponent
test5 = mkWindow [title "Message widget"] $ 
	 exampleMessage

exampleMessage :: Component
exampleMessage = 
  matrix 3 $ [mkMessage [text msg, aspect (75 * i), justify pos] 
	      | pos <- [LeftJ,CenterJ,RightJ], i  <- [1 .. 3]]
   where
      msg = "the message widget displays and formats a text"



\end{code}


A little interface with a dynamic list of objects. 
There is a text entry area, an add, delete and move button,
and a dynamic list of items. 
When the add button is pressed, it sends a message down a wire to the entry.
This snap shots the entry and appends a new item to the list with the given
text. The delete button sends a message down a wire to the entry, snasphoting
it's value and deleting the given item from the list. The move button also
samples the text entry via a wire. It moves an item above or below the other
items depending on the value. For instance, if the text area contained

one + two

this would mean place item one before item two.

\begin{code}
test6 :: WComponent
test6 = mkWindow [title "Lists of objects"] $ do
	  (w,l) <- listapp 
          nabove [w,
	          nabove $ fmap mkC l]
  where
   mkC :: String -> Component
   mkC s = mkLabel [text s]

listapp :: GUI (Component,ListB String)
listapp = do
 sortbv <- mkBVar False
 let toSort False = compare
     toSort True = flip compare
 filterwr <- mkWire
 filterbv <- mkBVar []
 let ops =  nbeside [mkButton [text "Sort"]  
			      (tellL (bvarUpdInput sortbv) not),
		     mkButton [text "Filter"] (input filterwr)
		    ]
 let snapE = [snapEntry (\_ s -> words s) (event filterwr) 
			(input filterbv)]

 (c,l) <- listapp' snapE
 l <- liftIO $ sortListB lift0 (lift1 toSort $ bvarBehavior sortbv) 
             $ collection l
 l <- liftIO $ filterListB lift0 (lift1 (\xs x -> not $ elem x xs) 
					(bvarBehavior filterbv)) $ 
	       l
 return (c `above` ops,l)

listapp' :: [Conf Entry] -> GUI (Component,ListBVar String)
listapp' cs = do
 l <- mkListBVar ["one"]
 addwr <- mkWire
 delwr <- mkWire
 movewr <- mkWire

 let ops = nbeside [mkButton [text "Add"] (input addwr),
		    mkButton [text "Delete"] (input delwr),
		    mkButton [text "Move"] (input movewr)]
		   
 let mover [s,"+"] = Just (s,PlaceTop)
     mover [s,"-"] = Just (s,PlaceBottom)
     mover [s,"+",n] = Just (s,PlaceBefore n)
     mover [s,"-",n] = Just (s,PlaceAfter n)
     mover _ = Nothing

 let ent = mkEntry' $ [snapEntry (\_ s -> s) (event addwr) (appendListB l),
		       snapEntry (\_ s -> s) (event delwr) (deleteListB l),
		       snapEntry (\_ s -> mover $ words s) (event movewr) 
			         (isJustL $ moveListB l)] ++ cs

 return (above ops ent,l)

 
\end{code}


similar to the last but with a dynamic list of menu items, rather
than labels. 

\begin{code}
test7 :: WComponent
test7 = do
 (w,l) <- listapp' []
 last <- mkBVar "none"
 let m = mkMenu [] [mcascade [text "menu"] $ 
		     mkMenuL [] $ 
 			fmap (mkC last) $ collection l]
 mkWindow [title "Lists of objects",useMenu m] $ 
   w `beside` mkLabel [textB $ bvarBehavior last]
  where
   mkC :: BVar String -> String -> MenuItem
   mkC b s = mbutton [text s] (tellL (input b) s)
\end{code}

all the canvas items 

\begin{code}

test8 :: WComponent
test8 = mkWindow [title "All canvas items"] $ do
 l <- mkListBVar' fst []
 mvW <- mkWire
 nbeside (map (genButton l) ops)
  `above`
  mouseMove (input mvW) 
            (mkCanvas [] $ 
	      pile $ 
	       fmap (item (deleteListB l) (event mvW)) 
		    (collection l)
	    )
  where
     genButton :: ListBVar (Ident,CComponent) -> (String,CComponent) 
	       -> Component
     genButton l (nm,w) = do
       let mkact :: a -> GUI (Ident,CComponent)
	   mkact = const $ do 
		n <- getUniqueName
		return (identify n,w)
       mk <- mapGUIL mkact (appendListB l)
       mkButton [text nm] mk

     item :: Listener (Ident,CComponent) -> Event S.Point2 
          -> (Ident,CComponent) -> CComponent

     item delete mvE obj@(id,c) = do
       p <- mkBVar $ S.point2XY 10 10
       m <- mkBVar False
       addListener (mvE `whenE` (bvarBehavior m)) 
	            (input p)
       moveTo (bvarBehavior p) $
         stretch 4 $ 
         mousePress 1 (tellL (input m) True) $
         mouseRelease 1 (tellL (input m) False) $
	 mousePress 3 (tellL delete obj) $
         c

     ops :: [(String,CComponent)]
     ops = zip  ["oval","line","arc","rectangle","polygon","text","bitmap",
	 	 "button"] 
	        [mkCOval (vector2XY 10 10) [fillColor S.green],
		 mkCLine [point2XY 0 0, point2XY 10 10] [fillColor S.blue],
		 mkCArc (vector2XY 10 10) 0 180 [fillColor S.yellow],
		 mkCRectangle (vector2XY 10 10) [fillColor S.brown],
		 mkCPolygon [point2XY 10 0, point2XY 0 10,point2XY 20 10] [],
		 mkCText [text "Text item",anchor NW,fillColor S.white],
		 mkCBitmap [bitmap (namedBitmap "hourglass"),anchor NW],
		 mkCWindow [anchor NW] $ 
			mkButton [text "button"] (mkL_ $ print "ouch")
		]

\end{code}

canvas items, with restacking

\begin{code}

test9 :: WComponent
test9 = mkWindow [title "Canvas Items"] $ do
	 we <- mkWire
	 visibles <- mkBVar []
	 (c,l) <- listapp' 
		    [snapEntry (\_ s -> words s) (event we) (input visibles)]
	 w <- mkWire
         (c `beside` mkButton [text "Filter"] (input we))
	  `above` 
	  mouseMove (input w) 
		    (mkCanvas [] (pile $ fmap (item visibles l $ event w) $ 
					 collection l))
 where
  item visibles l mvE s = do
    p <- mkBVar $ S.point2XY 10 10
    m <- mkBVar False
    addListener (mvE `whenE` (bvarBehavior m)) 
	         (input p)
    ifB (lift1 (elem s) $ bvarBehavior visibles) emptyComponent
     (moveTo (bvarBehavior p) $
       mousePress 1 
	(tellL (moveListB l) (s,PlaceTop) `mergeL` tellL (input m) True) $
        mouseRelease 1 (tellL (input m) False) $
         mkCText [text s,anchor NW] `over` 
          mkCRectangle (vector2XY 40 40) [fillColor $ S.blue])

 
	 
\end{code}

simple shared textwidget. There are two text entries. Typing in either updates
the text in both.

\begin{code}
test10 :: WComponent
test10 = mkWindow [title "Text Edit"] $ do
	 doc <- mkDocumentBVar emptyIDoc
         let edit = mkEdit [useDocBVar doc]
         beside edit edit
\end{code}


A very limited hypertext renderer. It has headings, normal text and links.
The pages are held as a data type, an action is provided to load a page,
and the the page is displayed in a read-only edit area.

\begin{code}
type Hypertext = [HypertextTag]
data HypertextTag = Heading String | Text String | Link String Address 
 deriving Show
type Address = String
\end{code}

\begin{code}
test11 :: WComponent 
test11 = mkWindow [title "Hypertext"] $ do
          pagestate <- mkBVar init
          hypertextPage (bvarBehavior pagestate)
			(mapL get $ input pagestate) 
 where
  get "web:1" = init
  get "web:2" = back

  back = [Heading "Next document",
	  Text "Go back to ",
	  Link "previous document" "web:1"]

  init = [Heading "This document",
	  Text "What is this all about. To find out more try ",
          Link "this" "web:2"]

hypertextPage :: Behavior Hypertext -> Listener Address -> Component
hypertextPage hypertext readPage = do 
 mkScrollableEdit [setIDocB $ lift1 toDoc hypertext,
	           readOnly True,wrap WordWrap] [] []
  where
   toDoc :: Hypertext -> IDoc
   toDoc text = structured $ SGroup $ map (tag readPage) text

   tag :: Listener Address -> HypertextTag -> Structured
   tag change (Text s) = SText s
   tag change (Heading s) = 
        STextTagged [SText $ s ++ "\n"]  
		    (mkEditTag [font $ namedFont "Helvetica" 14 [Bold]])

   tag change (Link s addr) = STextTagged [SText s] 
			              (mousePress 1 (tellL change addr) $
			               mkEditTag [foreground S.blue])


\end{code}


A shared edit, somewhat like unix talk. Two users have a view.
Each has two areas on their screen. They type in the top area,
and see the other user's typing in the bottom area. Users can
clear their screens. They can also quit

\begin{code}

test12 :: WComponent
test12 = do
 st1 <- mkDocumentBVar emptyIDoc
 st2 <- mkDocumentBVar emptyIDoc
 pile [sharedEdit (docBVarUpdInput st1) (docB st2), 
       sharedEdit (docBVarUpdInput st2) (docB st1)]
 
sharedEdit :: Listener (IDoc -> IDoc) -> DocumentB -> WComponent
sharedEdit send recv = do
 clearown <- mkWire
 let men = mkMenu []
		  [mcascade [text "File"] 
		    (mkMenu []
			 [mbutton [text "Clear Own Area"] 
				  (tellL (mergeL (input clearown) send) clearIDoc)])]
 mkWindow [useMenu men] $ do
  let myinput = mkEdit [listenDoc send,setIDocE $ event clearown]
      otheruser = mkEdit [readOnly True, 
			  setDocB recv]
  above myinput otheruser

\end{code}

A simple text editor, but with multiple views like emacs

\begin{code}

test13 :: WComponent
test13 = do
 text <- mkDocumentBVar emptyIDoc
 textEditor text 
 textEditor text

mkTag :: EditTag -> DocumentBVar -> Listener [Conf EditTag] 
mkTag select evb = 
     snapTagL select (mapMaybeL insertEdit (docBVarUpdInput evb))
 where
  insertEdit :: ([Conf EditTag],Maybe ((Int,Int),(Int,Int))) -> Maybe (IDoc -> IDoc)
  insertEdit (cs,Nothing) = Nothing
  insertEdit (cs,Just ((x,y),(a,b))) = Just $
   insertTagIDoc (mkEditTag (withIndex (Just $ (tindex x y,tindex a b)):cs))

radioGroup :: Listener [Conf EditTag]
           -> String -> String -> (a -> Conf EditTag) 
           -> [(String,a)]
           -> MenuItem
radioGroup tagL gpname init config vals = 
       mcascade [text gpname] $ do
             rad <- mkRadio (Just init)
             mkMenu [] $ 
              let mr (c,v) = 
                   mradiobutton [text c,useRadio rad c]
				(tellL tagL [config v])
	      in map mr vals
  
textEditor :: DocumentBVar -> WComponent
textEditor evb = do 
  select <- selectEditTag []
  clipB <- mkWire
  let menu = do
	   let tagL = mkTag select evb
	   mkMenu []
	      [mcascade [text "File"] $ mkMenu [] $
		 [mbutton [text "New"] 
			  (tellL (docBVarUpdInput evb) clearIDoc)],
	       mcascade [text "Edit"] $ mkMenu [] $
			[mbutton [text "Copy"] (tellL (input clipB) Copy),
			 mbutton [text "Cut"] (tellL (input clipB) Cut),
			 mbutton [text "Paste"] (tellL (input clipB) Paste)],
	       mcascade [text "Style"]  $ mkMenu [] $
                [radioGroup tagL "Text Color" "black" foregroundB
                        [("black",black),("red",red),
		         ("green",green),("blue",blue)],
                 mseparator,
                 let mkfont :: Int -> Conf EditTag
                     mkfont x = font (namedFont "Times" x [])
                 in radioGroup tagL "Font" "8" mkfont 
			       (map (\x -> (show x,x)) [8,10,12,14])
                ]
		          ]
  mkWindow [title "Editor",useMenu menu] $
	mkEdit [font (namedFont "Times" 8 []),
		  clipboardE (event clipB), 
		  useDocBVar evb,
		  updIDoc (insertTagIDoc (return select))]
\end{code}
