(FILECREATED "12-Apr-85 17:13:45" {DSK}<LISPFILES>HTHOMPSON>TOGMENU.;12 7560
changes to: (FNS TogMenu TogMenuReset \TogMenuButtonFn)
(RECORDS TogMenuItem)
previous date: "10-Apr-85 19:53:46" {DSK}<LISPFILES>HTHOMPSON>TOGMENU.;8)
(* 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))))
(DEFINEQ
(MakeTogMenu
[LAMBDA (items) (* ht: "10-Apr-85 13:28")
(create TogMenu set←items])
(TogMenu
[LAMBDA (togMenu title font orgX orgY dontOpen minWidth) (* ht: "12-Apr-85 17:11")
(let ((height (HEIGHTIFWINDOW (FONTPROP font 'HEIGHT)
title))
[width (WIDTHIFWINDOW (APPLY (FUNCTION MAX)
(NCONC [for item in (fetch set of togMenu)
unless (AND (LISTP item)
(fetch skip of item))
collect (let ((it (if (LISTP item)
then (fetch (TogMenuItem
name)
of item)
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 (togMenu:set←set)
else set←togMenu:set)
togMenu:state←(if state
then (OR (MEMB state set)
(AND (SASSOC state set)
(MEMB (SASSOC state set)
set))
set)
else set)
(\SetTogMenuValue togMenu)
(REDISPLAYW togMenu:window])
(TogMenuValue
[LAMBDA (togMenu) (* ht: "10-Apr-85 13:44")
(fetch value of (OR togMenu $$TogMenu$$])
)
(DEFINEQ
(\TogMenuButtonFn
[LAMBDA ($$TogWindow$$) (* edited: "12-Apr-85 11:12")
(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$$ item:2])
(\TogMenuRepaintFn
[LAMBDA ($$TogWindow$$ reg) (* ht: "10-Apr-85 13:43")
(DECLARE (SPECVARS $$TogWindow$$ $$TogMenu$$))
(CLEARW $$TogWindow$$)
(LET* (($$TogMenu$$ (WINDOWPROP $$TogWindow$$ 'ToggleMenu))
(item $$TogMenu$$:state:1)
(name (if (LISTP item)
then (if (LISTP item:name)
then (EVAL item:name)
else item:name)
else item)))
(if (type? BITMAP name)
then (HELP "not implemented yet")
else (printout $$TogWindow$$ .CENTER 0 name])
(\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)
)
(PUTPROPS TOGMENU COPYRIGHT ("Henry Thompson" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (656 3889 (MakeTogMenu 666 . 809) (TogMenu 811 . 3252) (TogMenuReset 3254 . 3719) (
TogMenuValue 3721 . 3887)) (3890 6856 (\TogMenuButtonFn 3900 . 5541) (\TogMidMenuFn 5543 . 5695) (
\TogMenuRepaintFn 5697 . 6303) (\SetTogMenuValue 6305 . 6854)))))
STOP