home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Fred Fish Collection 1.5
/
ffcollection-1-5-1992-11.iso
/
ff_disks
/
200-299
/
ff239.lzh
/
JGoodies
/
HeadClean
/
gadget_tools
< prev
next >
Wrap
Text File
|
1989-08-21
|
3KB
|
110 lines
\ General Purpose Gadget tools
\ originally used in HeadClean program.
\
\ Author: Phil Burk
\ Public Domain, Freely Redistributable
include? gr.init ju:amiga_graph
include? ev.getclass ju:amiga_events
include? boolean.setup ju:gadget_support
ANEW TASK-GADGET_TOOLS
variable FIRST-GADGET ( first in linked list )
variable LAST-GADGET ( last one defined )
\ Border for gadget
border BOOLG-BORDER
create BOOLG-XYS 5 cells allot
: GT.GAD.FREE ( gadget -- , free intuitext and gadget )
dup ..@ gg_gadgetText if>rel ?dup
IF freeblock
THEN
freeblock
;
: GT.FREE.ALL ( -- , free all gadgets )
first-gadget @
BEGIN dup
WHILE dup ..@ gg_nextgadget if>rel swap
gt.gad.free
REPEAT drop
first-gadget off
;
: GT.ABORT ( -- , free gadgets then abort )
gt.free.all
abort
;
\ Gadgets will be dynamically allocated and initialized,
\ then linked to the end of the gadget chain.
\ You could use this word in other programs after
\ customizing it.
: GT.GAD.MAKE ( cfa text x y w h -- , allocate and build a gadget)
\ Allocate a Gadget structure
allocstruct gadget ?dup
IF dup>r menubutton.setup ( set defaults )
\ Allocate IntuiText structure
allocstruct IntuiText ?dup
IF dup >abs r@ ..! gg_gadgettext ( use it )
itext.setup ( eat text and setup Intuitext )
\ Use the border to draw gadget.
boolg-border >abs r@ ..! gg_gadgetrender
\ Store CFA in Gadget for PROCESS.GADGET to execute
r@ ..! gg_userdata
\ Seems to be needed for proper highlighting
RELVERIFY r@ ..! gg_Activation
\ Link to last gadget in chain
first-gadget @ 0=
IF r@ first-gadget !
ELSE r@ >abs last-gadget @ ..! gg_nextgadget
THEN
r@ last-gadget !
ELSE 2drop ." Couldn't allocate Intuitext" gt.abort
THEN
rdrop
ELSE 6 xdrop ." Couldn't allocate Gadget" gt.abort
THEN
;
: GT.PROCESS.GADGET ( gadget -- , execute CFA in gadget)
..@ gg_userdata ?dup
IF execute ( do NOT pass gadget address )
ELSE ." NO CFA!"
THEN
;
: GT.REFRESH ( -- , refresh gadgets )
first-gadget @
gr-curwindow @ ( assume in current window )
NULL
refreshgadgets()
;
variable IF-QUIT
: GT.PROCESS.EVENT ( class -- done? , process events from IDCMP )
false if-quit !
CASE
GADGETUP ( execute CFA stored in gadget )
OF ev-last-iaddress @ ( -- gadget )
>rel gt.process.gadget
ENDOF
GADGETDOWN ( just wait for UP )
OF noop
ENDOF
CLOSEWINDOW ( set var to quit )
OF true if-quit !
ENDOF
." GADGET.LOOP -- Unrecognized event = " dup . cr
ENDCASE
if-quit @
;