tut 8.5 (menu)

1 files changed, 61 insertions, 0 deletions

diff --git a/tut8_5.icl b/tut8_5.icl
new file mode 100644
index 0000000..76a4752
--- /dev/null
+++ b/tut8_5.icl
@@ -0,0 +1,61 @@
+module tut8_5
+
+// ********************************************************************************
+// Clean tutorial example program.
+//
+// This program creates a Multiple Document Interface process with a Window menu.
+// ********************************************************************************
+
+import StdEnv, StdIO, Notice
+
+Start :: *World -> *World
+Start world 
+# (id, world) = openId world
+= startIO MDI Void (initialise id) [ProcessClose quit] world
+
+quit :: (PSt .l) -> PSt .l
+quit pst = openNotice notice pst
+where
+    notice = Notice ["Do you really want to quit?"]
+            (NoticeButton "&Ok" (noLS closeProcess))
+            [NoticeButton "&Cancel" id]
+
+initialise :: Id (PSt .l) -> PSt .l
+initialise closeid pst
+    # (err, pst)        = openMenu 0 menu pst
+    | err <> NoError    = abort "MDI could not open File Menu"
+    | otherwise = pst
+where
+    menu = Menu "&File"
+            ({newLS=1, newDef=MenuItem "&New" [MenuShortKey 'n', MenuFunction new]} :+:
+             MenuItem "&Close" [MenuShortKey 'w', MenuFunction (noLS close), MenuId closeid, MenuSelectState Unable] :+:
+             MenuSeparator [] :+:
+             MenuItem "&Quit" [MenuShortKey 'q', MenuFunction (noLS quit)]) []
+
+    close :: (PSt .l) -> PSt .l
+    close pst
+        # pst           = closeActiveWindow pst
+        # (rest, pst)   = accPIO getWindowsStack pst
+        | isEmpty rest  = appPIO (disableMenuElements [closeid]) pst
+        | otherwise     = pst
+
+    new :: (Int, PSt .l) -> (Int, PSt .l)
+    new (i,pst)
+        # (err, pst)        = openWindow Void window pst
+        | err <> NoError
+            # notice = Notice ["MDI could not open new window"] (NoticeButton "&Ok" id) []
+            = (i, openNotice notice pst)
+        | otherwise = (i+1, appPIO (enableMenuElements [closeid]) pst)
+    where
+        window = Window ("Window " +++ toString i) NilLS [
+                WindowClose (noLS close),
+                WindowViewSize {w=300, h=300},
+                WindowLook True look ]
+
+        look :: SelectState UpdateState *Picture -> *Picture
+        look _ {newFrame=frame=:{corner1,corner2}} picture
+            # picture = unfill frame picture
+            # picture = draw frame picture
+            # picture = drawLine corner1 corner2 picture
+            = drawLine {corner1 & x=corner2.x} {corner2 & x=corner1.x} picture
+