\ Multi-Forth Intuition misc.
\ Copyright (c) 1986 Creative Solutions, Inc.
\    by David Butler  3-27-86

\ Note:  It is YOUR responsibilty to see to it that all the
\ screens and windows that you open are purged before your
\ program exits.  When you use OpenWindow and OpenScreen,
\ the variables CurrentWindow and CurrentScreen are set.  If you will
\ be opening more than one window or screen, be sure to stash
\ the wptr(s) and/or sptr(s) so that you can later
\ perform a CloseWindow/CloseScreen for each.

cr ." loading misc. intuition..."

 : |  or ;      \ alias for logical OR

find r! not   \ anticipate relocation version of , and !
iftrue
  : r, , ;
  : r! ! ;
ifend

: NULL 0 ;    : NL 0 ;

: struct  \ 'C' like version defines structure instance and allots space
         find dup -found -null create  execute allot ;

: cstruct \ 'C' like version that does not allot space 
           find dup -found -null drop create ;

: structend  ;  \ a nop to make source code more readable

0 constant JAM1    \ needed here and there...
1 constant JAM2

: !window  ( wptr --| change current window ) CurrentWindow ! ;
: !screen  ( sptr --| change current screen ) CurrentScreen ! ;

\ New Window defaults
  cstruct NewWindow wDefault    ( use to init window defaults)
   0 w, 10 w, 580 w, 140 w,          ( Ledge TopEdge Width Height )
   0 c, 1 c,                         ( DetailPen BlockPen )
   0 ,                               ( IDCMPFlags )
 WINDOWCLOSE ACTIVATE | WINDOWDRAG |
 WINDOWDEPTH | WINDOWSIZING | ,
   0 ,  0 ,                          ( FirstGaget  CheckMark )
   0  ,                              ( title )
   0 ,   0 ,                         ( Screen   BitMap  )
   10 w, 10 w, 640 w, 200 w,         ( MinW MinH MaxW MaxH )
   wbenchscreen  w,                  ( Type )
  structend

 : InitWindow  ( NewWindow  --- )
      wDefault swap  NewWindow cmove ;

struct NewWindow Sample

: SampleWindow      ( display a sample window )
    Sample  InitWindow
    0"  Sample Window  " Sample +nwTitle !
    Sample OpenWindow ;

: CloseCurrentWindow  ( close current window )
     CurrentWindow @ CloseWindow ;

\ New Screen defaults
cstruct NewScreen NScreenDefault
    0 w, ( +nsLeftEdge )         0 w, ( +nsTopEdge )
  640 w, ( +nsWidth )          200 w, ( +nsHeight )
    4 w, (  +nsDepth      # bitplanes )
    1 c, ( +nsDetailPen )        2 c, ( +nsBlockPen )
          HIRES w, \ +nsViewModes
   CUSTOMSCREEN w, \ +nsType
              0  , \ +nsFont
              0  , \ +nsDefaultTitle
              0  , \ +nsGadgets
              0  , \ +nsCustomBitMap
structend

: InitScreen ( NewScrPtr -- )  \ initialize a new screen
     NScreenDefault swap  NewScreen cmove ;

: screen? ( -- )  \  See if a custom screen is open
    CurrentScreen @ not abort" No custom screen open!"  ;

: VerifyWindow ( -- )  \ make sure window opened without error
     currentwindow @ 0=
     if
       currentscreen @ 0= not
       if
         currentscreen @ CloseScreen
       then
       cr ." Could not open window, probably not enough memory. "
       ?turnkey if bye else abort then
     then ;

: VerifyScreen ( -- )  \ make sure screen opened without error
   currentscreen @ 0=
   if
     cr ." Could not open screen, probably not enough memory. "
     ?turnkey if bye else abort then
   then ;


\ Event Message
structure Event
    long: +eClass
   short: +eCode
   short: +eQualifier
     ptr: +eIaddress   ( like gadgets or screen ..)
   short: +eMouseX     short: +eMouseY
    long: +eSeconds     long: +eMicros
     ptr: +eIDCMPWindow
structure.end

struct Event ThisEvent  \ define an occurrance of the Event structure

\ message port support

: GetEvent  ( -- 0 or class )
   CurrentWindow @ +wUserPort @ eGetMsg dup
   if
     dup +imClass ThisEvent +eClass Event cmove
     eReplyMsg    ThisEvent +eClass @
   then ;

:  ScanEvents  ( -- )  \ for debugging
     begin
       GetEvent dup  if dup . then
       fCLOSEWINDOW = ?terminal or
     until ;