module Menus where

import Tcl


menus = 
     do w <- window []

	f1  <- frame w []
	e   <- edit w [width 40, height 20]
	vs  <- vscroll e []
	
	f2  <- frame w []

        bs  <- sequence $ menu_buts w
	mapM_ (\b -> packAdd b [packH,inFrame f2]) bs

	packAdd f2 [packV,packAnchor W]

	packAdd e [expand True,fillXY,packH,inFrame f1]
	packAdd vs [fillY,packH,inFrame f1]
	packAdd f1 [packV,expand True,fillXY]

	return ()
     where
	menu_buts w = [file_menu w, basic_menu w, cascades_menu w , 
		       icons_menu w,more_menu w, colors_menu w] 


-------------------------------------------------------------------------------
-- File menu
-------------------------------------------------------------------------------

file_menu :: Window -> GUI Menubutton
file_menu w = 
     do	b <- menubutton w [text "File", underline 0]
	m <- menu b []
        cset b [use_menu m]
	mbutton m [wgt_label "Open...",    	command (report "Info" msg1)] 
	mbutton m [wgt_label "New", 	    	command (report "Info" msg2)] 
	mbutton m [wgt_label "Save",       	command (report "Info" msg3)] 
	mbutton m [wgt_label "Save As...", 	command (report "Info" msg4)] 
	separator m 
	mbutton m [wgt_label "Print Setup...",	command (report "Info" msg5)] 
	mbutton m [wgt_label "Print...",   	command (report "Info" msg6)] 
	separator m 
	mbutton m [wgt_label "Dismiss Menus Demo", 
					command (destroy w)] 
	return b
     where
	msg1  = msg ++ "\"Open...\" entry"
	msg2  = msg ++ "\"New\" entry"
	msg3  = msg ++ "\"Save\" entry"
	msg4  = msg ++ "\"Save As...\" entry"
	msg5  = msg ++ "\"Print Setup...\" entry"
	msg6  = msg ++ "\"Print...\" entry"
	msg = "This is just a demo: no action has been defined for the "
-------------------------------------------------------------------------------
-- Basic menu
-------------------------------------------------------------------------------

basic_menu :: Window -> GUI Menubutton
basic_menu w = 
     do	b <- menubutton w [text "Basic", underline 0]
	m <- menu b []
        cset b [use_menu m]
	mbutton m [wgt_label "Long entry that does nothing"]
	mapM_ (mkButtons m) ["A", "B", "C", "D", "E", "F"]
	return b
     where
	mkButtons m nm =
	     do	b <- mbutton m [ underline 14, wgt_label txt, 
						command (report " " nm)] 
		return b	
	     where 
		txt = "Print letter \"" ++ nm ++ "\""

-------------------------------------------------------------------------------
-- Cascades menu
-------------------------------------------------------------------------------

cascades_menu :: Window -> GUI Menubutton
cascades_menu w = 
     do	b  <- menubutton w  [text "Cascades",underline 0]
	m  <- menu b []
	cm <- menu b []
	rm <- menu b []
	cset b [use_menu m]

	mbutton m [wgt_label "Print Hello", underline 6, 
			command (report "" "Hello")] 
	mbutton m [wgt_label "Print Goodbye", underline 6, 
			command (report "" "Goodbye")] 
	cascade m cm [wgt_label "Check buttons", underline 0] 

	chks <- mapM (car_che cm) (zip check_l bool_l)

	separator cm

	mbutton cm [wgt_label "Show current values", 
			command(showCheckValues chks)]


	cascade m rm [wgt_label "Radio buttons", underline 0]
	rb1 <- mapM (fontSize_rb rm) size_l
	r1  <- mradio rb1
	setRadio r1 1

	separator rm

	rb2 <- mapM (attr_rb rm) attr_l
	r2  <- mradio rb2
	setRadio r2 1	

	separator rm

	mbutton rm [wgt_label "Show current values", 
			command(showRadValues r1 r2)]
	

	return b
     where
	check_l = ["Oil", "Transmission", "Brakes", "Lights"]
	bool_l  = [True, False, False, True]	

	car_che cm (c,b) = 
	     do	cb <-mcheckbutton cm [wgt_label (c ++ " checked")]
		setMCheck cb b
		return cb

	showCheckValues chks = 
	     do	bool_l <- mapM getMCheck chks
		report "Current Values" (msg (zip check_l bool_l))
		return ()
	     where
		dsc (c,b) = c ++ (replicate (spaces c) ' ') ++ ": " ++ (show b)
		spaces c = 14 - (length c)
		msg c_b = unlines (title : (map dsc c_b))
		title = "Variable values :     \n"

	size_l = [10, 14, 18, 24, 32]
	attr_l = ["Roman", "Bold", "Italic"]
	fontSize_rb rm s = mradiobutton rm [wgt_label ((show s) ++ " point")]
	attr_rb rm a     = mradiobutton rm [wgt_label a]

	showRadValues r1 r2 = 
	     do	v1 <- getRadio r1
		v2 <- getRadio r2		
		let sz   = size_l !! v1  
		    attr = attr_l !! v2
		report "Current Values" (msg sz attr) 
		return ()
	     where
		msg sz attr = unlines ["Variable values :      "
				      ,""
				      ,"Point Size :  " ++ (show sz)
				      ,"Style      :  " ++ attr
				      ,""
				      ]

-------------------------------------------------------------------------------
-- Icons menu
-------------------------------------------------------------------------------

icons_menu :: Window -> GUI Menubutton
icons_menu w = 
     do	b <- menubutton w [text "Icons", underline 0]
	m <- menu b [tearoff False]
	cset b [use_menu m]
	mbutton m ["bitmap" %% "@[file join images pattern.bmp]",
			command (report "Bitmaps" (msg "pattern"))]

	mapM_ (builtinBmp m) ["info", "questhead", "error"]
	return b
     where
	builtinBmp m nm = mbutton m ["bitmap" %% nm,
				     command (report "Bitmaps" (msg nm))]
	msg nm = "You invoked the " ++ nm ++ " bitmap."

-------------------------------------------------------------------------------
-- More menu
-------------------------------------------------------------------------------

more_menu :: Window -> GUI Menubutton
more_menu w =  
     do	b <- menubutton w [text "More", underline 0]
	m <- menu b [tearoff False]
	cset b [use_menu m]	
	mapM_ (mkButton m)  but_l
	
	return b
     where
	but_l = ["An entry", "Another entry", "Does nothing", 
		 "Does almost nothing", "Make life meaningful"]
	
	mkButton m nm = mbutton m [wgt_label nm, 
				   command (report "More" msg)]
		     where
			msg = "You invoked \"" ++ nm ++ "\""	


-------------------------------------------------------------------------------
-- Colors menu
-------------------------------------------------------------------------------

colors_menu :: Window -> GUI Menubutton
colors_menu w = 
     do	b <- menubutton w [text "Colors",underline 1]
	m <- menu b [tearoff True]
	cset b [use_menu m]
	mapM_ (mkColors m) ["red", "orange", "yellow", "green", "blue"]
	return b
     where
	mkColors m c = mbutton m [wgt_label c, background c, 
			command (report "Colors" ("You invoked " ++ c))] 

-------------------------------------------------------------------------------
-- Report Dialogue
-------------------------------------------------------------------------------

report :: String -> String -> GUI ()
report ttl msg =
     do 
	w <- window []
	title w ttl
	m <- message w [aspect 5000,text msg]
        f <- frame w [borderwidth 2, relief Ridge]
        b <- button w [text " Dismiss ", command (destroy w)]
	packAdd m []
	packAdd f []
	packAdd b [inFrame f]
	focus b


 






