\ 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 @
;