(FILECREATED "30-Dec-85 11:42:33" {DSK19}TOGMENU.;4 8187
changes to: (FNS \TogMenuRepaintFn TogMenuReset \TogMidMenuFn MakeTogMenu TogMenu
\TogMenuButtonFn \SetTogMenuValue)
previous date: "15-Aug-85 14:21:27" {DSK19}TOGMENU.;1)
(* Copyright (c) 1985 by Henry Thompson. All rights reserved.)
(PRETTYCOMPRINT TOGMENUCOMS)
(RPAQQ TOGMENUCOMS [(FNS MakeTogMenu TogMenu TogMenuReset TogMenuValue)
(FNS \TogMenuButtonFn \TogMidMenuFn \TogMenuRepaintFn \SetTogMenuValue)
(DECLARE: DONTEVAL@LOAD DOCOPY (SYSRECORDS TogMenu)
(INITRECORDS TogMenu))
(DECLARE: DONTCOPY (RECORDS TogMenu TogMenuItem))
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T])
(DEFINEQ
(MakeTogMenu
[LAMBDA (items) (* ht: "10-Apr-85 13:28")
(create TogMenu
set ← items])
(TogMenu
[LAMBDA (togMenu title font orgX orgY dontOpen minWidth) (* ht: "15-Aug-85 14:21")
(LET ((height (HEIGHTIFWINDOW (FONTPROP font 'HEIGHT)
title))
[width (WIDTHIFWINDOW (APPLY (FUNCTION MAX)
(NCONC [for item in togMenu:set
unless (AND (LISTP item)
item:skip)
collect (LET ((it (if (LISTP item)
then
item:TogMenuItem.name
else item)))
(SELECTQ (TYPENAME it)
(BITMAP
(BITMAPWIDTH
it))
(LISTP 0)
(STRINGWIDTH
it font]
[if title
then (LIST (STRINGWIDTH title
(DSPFONT
NIL
WindowTitleDisplayStream]
(if minWidth
then (LIST minWidth]
window)
window←(if togMenu:window
then (SHAPEW togMenu:window (if orgX
then (CREATEREGION orgX orgY width height)
else (CREATEREGION
(fetch LEFT
of (WINDOWPROP togMenu:window
'REGION))
(fetch BOTTOM
of (WINDOWPROP togMenu:window
'REGION))
width height)))
(WINDOWPROP togMenu:window 'TITLE
title)
(if dontOpen
then (CLOSEW togMenu:window))
togMenu:window
else (CREATEW [if orgX
then (CREATEREGION orgX orgY width height)
else (GETBOXREGION width height NIL NIL NIL
(PACK (NCONC (LIST
"Please indicate position for toggle menu ")
title]
title NIL dontOpen))
(WINDOWPROP window 'BUTTONEVENTFN
(FUNCTION \TogMenuButtonFn))
(WINDOWPROP window 'CURSORINFN
(FUNCTION \TogMenuButtonFn))
(WINDOWPROP window 'CURSORMOVEDFN
(FUNCTION \TogMenuButtonFn))
(WINDOWPROP window 'ToggleMenu
togMenu)
(WINDOWPROP window 'REPAINTFN
(FUNCTION \TogMenuRepaintFn))
(DSPFONT font window)
togMenu:window←window
(if togMenu:state=NIL
then (togMenu:state←togMenu:set))
(\SetTogMenuValue togMenu)
(if dontOpen=NIL
then (REDISPLAYW window))
window])
(TogMenuReset
[LAMBDA (togMenu state set) (* ht: "12-Apr-85 13:37")
(if set
then (replace set of togMenu with set)
else (SETQ set (fetch set of togMenu)))
(replace state of togMenu with (if state
then (OR (MEMB state set)
(AND (SASSOC state set)
(MEMB (SASSOC state set)
set))
set)
else set))
(\SetTogMenuValue togMenu)
(REDISPLAYW (fetch window of togMenu])
(TogMenuValue
[LAMBDA (togMenu) (* ht: "10-Apr-85 13:44")
(fetch value of (OR togMenu $$TogMenu$$])
)
(DEFINEQ
(\TogMenuButtonFn
[LAMBDA ($$TogWindow$$) (* ht: "15-Aug-85 14:21")
(DECLARE (SPECVARS $$TogWindow$$ $$TogMenu$$))
(LET [($$TogMenu$$ (WINDOWPROP $$TogWindow$$ 'ToggleMenu]
(if (MOUSESTATE LEFT)
then (INVERTW $$TogWindow$$)
(if [NOT (ERSETQ (until [OR (MOUSESTATE UP)
(NOT (INSIDEP $$TogWindow$$
(CURSORPOSITION NIL
$$TogWindow$$]
finally (if (INSIDEP $$TogWindow$$
(CURSORPOSITION NIL
$$TogWindow$$))
then (ERSETQ
(if (AND (LISTP
$$TogMenu$$:state:1)
$$TogMenu$$:state:1:outFn)
then (EVAL
$$TogMenu$$:state:1:outFn)))
(do ($$TogMenu$$:state←(OR
$$TogMenu$$:state::1
$$TogMenu$$:set))
repeatwhile
(AND (LISTP
$$TogMenu$$:state:1)
$$TogMenu$$:state:1:skip))
(\SetTogMenuValue $$TogMenu$$)
(REDISPLAYW $$TogWindow$$)
else (INVERTW $$TogWindow$$]
then (INVERTW $$TogWindow$$))
elseif (MOUSESTATE MIDDLE)
then (MENU (create MENU
ITEMS ←(for item in $$TogMenu$$:set
collect (LIST (if (LISTP item)
then (SELECTQ
item:skip
((T NIL)
item:TogMenuItem.name)
item:skip)
else item)
item
(if (LISTP item)
then item:explainString)))
WHENSELECTEDFN ←(FUNCTION \TogMidMenuFn])
(\TogMidMenuFn
[LAMBDA (item menu button) (* ht: "10-Apr-85 14:30")
(TogMenuReset $$TogMenu$$ (CADR item])
(\TogMenuRepaintFn
[LAMBDA ($$TogWindow$$ reg) (* ht: "30-Dec-85 11:41")
(DECLARE (SPECVARS $$TogWindow$$ $$TogMenu$$))
(CLEARW $$TogWindow$$)
(LET* (($$TogMenu$$ (WINDOWPROP $$TogWindow$$ 'ToggleMenu))
(item (CAR (fetch state of $$TogMenu$$)))
(name (if (LISTP item)
then (if (LISTP (fetch name of item))
then (EVAL (fetch name of item))
else (fetch name of item))
else item)))
(if (type? BITMAP name)
then (HELP "not implemented yet")
else (CENTERPRINTINREGION name NIL $$TogWindow$$])
(\SetTogMenuValue
[LAMBDA (togMenu) (* ht: "10-Apr-85 13:52")
togMenu:value←(if (LISTP togMenu:state:1)
then (if togMenu:state:1:valSet
then (if (LISTP togMenu:state:1:valSet)
then (EVAL togMenu:state:1:valSet)
else togMenu:state:1:valSet)
else (if (LISTP togMenu:state:1:name)
then (EVAL togMenu:state:1:name)
else togMenu:state:1:name))
else togMenu:state:1])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
[ADDTOVAR SYSTEMRECLST
(DATATYPE TogMenu (set state value window))
]
(/DECLAREDATATYPE 'TogMenu
'(POINTER POINTER POINTER POINTER)
'((TogMenu 0 POINTER)
(TogMenu 2 POINTER)
(TogMenu 4 POINTER)
(TogMenu 6 POINTER))
'8)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE TogMenu (set state value window))
(RECORD TogMenuItem (name valSet outFn explainString skip))
]
(/DECLAREDATATYPE 'TogMenu
'(POINTER POINTER POINTER POINTER)
'((TogMenu 0 POINTER)
(TogMenu 2 POINTER)
(TogMenu 4 POINTER)
(TogMenu 6 POINTER))
'8)
)
(DECLARE: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(RESETSAVE DWIMIFYCOMPFLG T)
)
(PUTPROPS TOGMENU COPYRIGHT ("Henry Thompson" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (741 4163 (MakeTogMenu 751 . 903) (TogMenu 905 . 3414) (TogMenuReset 3416 . 3993) (
TogMenuValue 3995 . 4161)) (4164 7405 (\TogMenuButtonFn 4174 . 5989) (\TogMidMenuFn 5991 . 6151) (
\TogMenuRepaintFn 6153 . 6860) (\SetTogMenuValue 6862 . 7403)))))
STOP