SPACE 2/SPACE - Library 2 - Volume 1.iso/apps/659/winshell/winshell.lst

File List | 1993-01-01 | 44.2 KB | 1,106 lines

'
' *****************************************************************************
' *                                                                           *
' *                             GFA Basic Vers. 3+                            *
' *                          GEM Multiple Window Shell                        *
' *                           by Sterling Kelly Webb                          *
' *                                                                           *
' *                                    1992                                   *
' *                      ---------- SKWare One -----------                    *
' *                                                                           *
' *****************************************************************************
'
' Date: 12-15-92
'
' {some portions of this code adapted from code provided by  GFA Systemtechnik}
' {some portions of this code adapted from code by Jeff and Tim Randall,  1987}
' {some portions of this code adapted from GEMSHELL.GFA by John Eidsvoog, 1992}
' {Hey!  I wrote a lot of it myself!  Stop being so damn modest! SKWare1, 1992}
'
' I suppose that WinShell is a response to the GEM Shell code recently
' posted by John Eidsvoog of the Codeheads. His stated concern was about
' how GFA programmers handle the redraws created by calling .ACC's
' (many are CodeHeads' pretty products), a reasonable concern, but...
'
' As a GFA programmer, I don't honestly feel that the GFA code methods
' that John proposed are the proper, correct, or even desirous methods of
' managing GEM through GFA programming.   The xxxxW #N commands are
' inadequate, unreliable, and dangerous to the health of your operating
' system; even GFA discourages their use (by implication, at least)!
'
' GFA provides command bindings for all AES libraries. But you have to
' understand that GEM leaves window management entirely up to the appli-
' ication programmer, and the AES provides a powerful set of tools to do
' it with. They can be used to produce a variety of interface protocols;
' This program is an illustration of the simplest, most elementary kind
' of GEM interface: a multiple window environment in which each window
' represents a buffer containing data of the same type (graphic images).
'
' -------------------------- WINSHELL.GFA --------------------------
'
' This program is designed to display multiple graphic windows,
' with GEM activities being handled directly through GFA commands.
' Although this example is for graphic display, it could be easily
' adapted to text buffers or any variety of multiple buffer operations.
' This program does not "do" anything, it only provides a structure
' and the GFA tools to manage the logic of GEM and the AES in a direct
' fashion. It also demonstrates some management of resource files, menus
' in particular. It is reasonably resolution-independent and non-hardware-
' oriented. This is about as GEM-legitimate as GFA gets, you guys...
'
' GEM Multiple Window Shell may be freely distributed, dissected, and
' any portion of this code may be utilized in any way you deem useful.
'
' (Despite the size of this file, the GFA code, when stripped of com-
' mentary and a few "teaching" lines, is less than 12 Kbytes in length.)
'
' Ok, here we go...
'
' ********************************* INIT ***********************************
'
'
DEFINT "a-z"
'
' Message buffer so our APPL can chat with the boys up at GEM HeadQuarters
DIM pipeline&(20)
adr_mes=V:pipeline&(0)                       ! this address used in EVNT_MULTI
'
' gather basic information about the system executing this program
max_x=WORK_OUT(0)                            ! horizontal monitor resolution
max_y=WORK_OUT(1)                            ! vertical monitor resolution
mid_x=SHR(max_x,1)                          ! center of screen --- x 'n y
mid_y=SHR(max_y,1)
'
num_of_colors=WORK_OUT(13)                   ! number of displayable colors
hi_color_index=PRED(num_of_colors)          ! highest color index 0-to-?
num_of_planes=LEN(BIN$(hi_color_index))     ! true of all interleaved rasters
' and of course, Num_of_colors% = 2^Num_of_planes%, if you want it backwards
'
' GFA always does this anyway, John, but why not? Couldn't hurt...
~APPL_INIT()
' and while we're at it, the basic question, who am I?
' when I'm interpreted...
gfa=APPL_FIND("GFABASIC")                     ! GEM only accepts CAPS for this
' when I'm compiled...
winshell=APPL_FIND("WINSHELL")                ! has to be eight chars, pad
'
' this location is guaranteed, so Atari says...
tos_version_number=VAL(HEX$(DPEEK(ADD(LPEEK(&H4F2),2))))
' say what? &H4f2 contains pointer to a LONG, least significant WORD of which
' contains the tos version number in hexadecimal, if =>2(.)00 allows 7 windows
tos=DIV(tos_version_number,100)
IF tos>1
  max_num_of_windows=7
ELSE
  max_num_of_windows=4
ENDIF
' shorthand, 'cause who want to type "max_num_of_windows" a hunnerd times?
wn=max_num_of_windows
'
' since this program is going to display pictures in Degas uncompressed format
' and the Degas picture format uses the hardware color registers for palettes
' (sorry, vdi-fans), we will gather this machine's current hardware register.
userpal$=""
FOR i=0 TO 15                         ! STe hardware register always 16 words
  userpal$=userpal$+MKI$(XBIOS(7,i,-1))
NEXT i
' a palette for every window and a window for every palette...
DIM palette$(SUCC(wn)),empty!(SUCC(wn))
FOR i=0 TO wn
  palette$(i)=userpal$
  empty!(i)=TRUE                      ! nobody home right now
NEXT i
'
'
' first, check the maximum size limits to a window
CLR wx,wy,ww,wh
~WIND_GET(0,4,wx,wy,ww,wh)       ! Get work area of the desktop (window 0)
' these coordinates are the absolute maximums for fulled windows
abswx=wx
abswy=wy
absww=ww
abswh=wh
'
' Send a redraw message to the desktop and get that lovely green blotto...
~FORM_DIAL(3,0,0,0,0,wx,wy,ww,wh)
'
' in order to have multiple windows (and images), we must able to maintain
' window parameters in tabled form: stored as indexed variables. Their names
' are shorthand for: window_x, window_y, window_width, window_height, which
' here ALWAYS refer to the total area of the window to its outer borders!
DIM wx(9),wy(9),ww(9),wh(9)
' and a set of tables to store former values of the above variables
DIM ox(9),oy(9),ow(9),oh(9)       ! for restoration after WM_FULLED
' a variable to hold the window_title strings
DIM title_string&(80)                 ! an explanation of this odd behavior
ARRAYFILL title_string&(),0           ! can be found at the end of the code
DIM wintitle$(9)                      ! under the heading: ODD BEHAVIOR
FOR i=0 TO 9
  wintitle$(i)="No Loaded File"
  BMOVE V:wintitle$(i),V:title_string&(MUL(i,8)),14
NEXT i
'
' since memory for screens will be pre-allotted, provide the option to limit the
' number of screens to four even if seven windows are possible. Particularly
' useful where screens are 153,600 bytes each...
IF wn=7
  ALERT 2," | To Reduce Screen Memory, | You Have the Option to | Limit Windows to Four. ",2,"Four|Seven",choice
  IF choice=1
    wn=4
  ENDIF
ENDIF
'
' now we're going to initialize our own WINDOW_LIST:  a stack that maintains
' the order in which windows are opened and closed; our own window management
' tool. The actual values contained in Window%() are the GEM window handles.
' GEM keeps a stack, too, but it holds the displayed order of overlaps in
' any current window configuration on-screen. We need our stack to sort
' through their stack!
DIM window(9)
FOR activew=1 TO wn                ! all attributes except the INFO line.
  window(activew)=WIND_CREATE(&X111111101111,wx,wy,ww,wh)
  wx(activew)=wx                  ! initialize the tables
  wy(activew)=wy
  ww(activew)=ww
  wh(activew)=wh
  ox(activew)=wx
  oy(activew)=wy
  ow(activew)=ww
  oh(activew)=wh
NEXT activew
' windows are indexed by us from 1; when no window is open, this index is 0.
activew=0
'
' this program is intended to display only screen-size raster images
' making it suitable for simple picture formats, like PrismPaint, Degas,
' NeoChrome and TINY images. The following memory array creates a single
' large buffer which will hold four images in a vertical stack of
' continuous scan-lines (like the buffer in Spectrum512). You will note
' that, since windows are indexed 1 through Wn%, that leaves the 0th screen
' position in the buffer always empty: the perfect place to store a
' temporary screen or a full-screen menu of icons, etc. for rapid display
' or for use as an offscreen drawing buffer with xbios 5 paging for some
' smooth fast screen alteration; an extra screen always a handy thing to have...
'
' first, let's calculate the memory for a bit-interleaved screen raster
scan_line_byte_length=(SUCC(max_x)*num_of_planes)\8
screen_size=SUCC(max_y)*scan_line_byte_length
integer_data_length=4
screen_array_size=PRED(screen_size\integer_data_length)
'
DIM picture(screen_array_size,wn)  ! GFA always creates one more than asked!
'
' we will be loading only DEGAS uncompressed files in this example.
'
' WIDTH may be defined in two contradictory ways: first, as a diferential
' distance between two pixel positions, and second as the number_of_pixels
' per scan line. The two definitions differ from each other by ONE, as in
' an image 640 pixels WIDE has a WIDTH of 639. The AES always uses the
' first definition (differential width) as WIDTH and this program does
' the same for the images it displays (also for HEIGHT and HIGH) as below:
'
DIM width(9),height(9),wide(9),high(9)  ! tables for image dimensions
FOR i=0 TO 8
  width(i)=max_x                         ! initialize for all images
  height(i)=max_y
  wide(i)=SUCC(max_x)
  high(i)=SUCC(max_y)
NEXT i
'
' for image display, we need to specify the starting coordinates IN THE
' IMAGE to be placed in the upper left-hand corner of the window display
DIM startx(9),starty(9)
'
' indexing all these variables also insures that they will be something that
' ALL variables should be:  GLOBAL! GLOBAL! GLOBAL!  (OK, enough prejudices)
'
DIM file$(9)                     ! names of loaded files
FOR i=0 TO 9
  file$(i)="                    "+CHR$(0)
NEXT i
' where to get'em
path$=CHR$(ADD(GEMDOS(25),65))+":\*.PI"+STR$(SUCC(XBIOS(4)))
'
'
DIM in_use!(9)                   ! records whether window is open or closed
CLR rez&
'
'
' the WinShell menu contains most of the neat stuff that Atari wants
' a menu to have, where they want it to have them, named the way they
' want it named, with the keyboard equivalents they want, yassir, baas!
'
' our menu is to be loaded from this program's .rsc file
' every GFA 3+ programmer has the Resource Construction Set #2
' every GFA 3+ programmer should USE IT! --- USE IT! --- USE IT!
'
' ok, rant'n'rave over...
'
' create our own little array to check out the .rsc file header
DIM rsc_header&(20)
' insert the name of your .rsc here...
rsc_file$="\winshell.rsc"
' we can do this, can't we? sure we can...
IF EXIST(rsc_file$)
  OPEN "I",#1,rsc_file$
  rsc_file_len=LOF(#1)
  BGET #1,V:rsc_header&(0),39
  CLOSE #1
ELSE
  EDIT
ENDIF
'
' some questions we might be interested in: how many trees in this .rsc?
num_of_trees=rsc_header&(11)         ! now you know where the num_of_trees is!
IF rsc_header&(17)<>rsc_file_len
  ' oh well, it probably is, anyway...
  ' Alert 3," | May Not Be Valid | RSC File Format! | ",1,"GO AHEAD!",Courage%
ENDIF
IF rsc_header&(11)<1
  ' if the num_of_trees is not at least 1, we in real trouble...
  ALERT 3," | Not Object Tree Structure! | ",1,"Abort!",uh_oh
  EDIT
ENDIF
'
' other resource-ful questions we might be interested in some other time...
'
' Rsc_header&(1) contains the Offset_to_first_object%
' Rsc_header&(2) contains the Offset_to_first_tedinfo_object%
' Rsc_header&(3) contains the Offset_to_first_iconblk_object%
' Rsc_header&(4) contains the Offset_to_first_bitblk_object%
' Rsc_header&(5) contains the Offset_to_free_string_pointer_table%
' Rsc_header&(6) contains the Offset_to_tied_string_table%
' Rsc_header&(7) contains the Offset_to_icon_data%
' Rsc_header&(8) contains the Offset_to_free_images%
' Rsc_header&(9) contains the Offset_to_object_tree_pointer_table%
' Rsc_header&(10) contains the Num_of_objects%
' Rsc_header&(11) contains the Num_of_trees%
' Rsc_header&(12) contains the Num_of_tedinfos%
' Rsc_header&(13) contains the Num_of_iconblks%
' Rsc_header&(14) contains the Num_of_bitblks%
' Rsc_header&(15) contains the Num_of_free_strings%
' Rsc_header&(16) contains the Num_of_free_images%
' Rsc_header&(17) contains the Len_of_rsc_file%
'
' oh well, I suppose we have to give a little memory back to GEM...
' for absolute compatibility on all TOSes, measure memory in 256-byte chunks
RESERVE FRE(0)-10240
' once RESERVEd, we MUST exit through a RESERVE FRE(0)+10240 statement
ON ERROR GOSUB escape
ON BREAK GOSUB escape
' now, let GEM load the .rsc file up top
rsc_ok!=RSRC_LOAD(rsc_file$)
IF rsc_ok!=FALSE
  ' no gottum .rsc! how come?
  ALERT 3," | Cannot Find WINSHELL.RSC! |  Your Next Stop Will Be | ",1,"DeskTop",nurtz
  @escape
ENDIF
'
' now, here's how a program can look for a principal menu in a resource file
men_tree=-1
FOR i=0 TO PRED(num_of_trees)
  ~RSRC_GADDR(0,i,tree_adr)
  ' the first title of the menu is the 3th (=0,1,2,3=4th) obj in a menu tree
  IF OB_TYPE(tree_adr,3)=32            ! 32 is the ob_type of a menu title
    men_tree=i
  ENDIF
  ' this only looks for ONE, but a resource may contain as many as it wants to!
  ' you could always keep on looking till you find'em all, you know...
  EXIT IF men_tree>-1
NEXT i
'
IF men_tree=-1
  ' this .rsc has no menu!
  @escape
ELSE
  '
  ' DON'T YOU JUST HATE IT WHEN...
  ' you start a GEM program in low resolution and its menu wrap around the
  ' screen from the right to the left and screws everything up!
  '
  ' I purposely created a high-rez menu, wide enough for its entries to do
  ' a screen wrap in low resolution, so I could show you how to fix'em
  ' on the fly, so one menu will work in all resolutions. The only hitch is
  ' the menu titles themselves must fit in the low-resolution width.
  '
  ' get the address of the menu tree
  ~RSRC_GADDR(0,men_tree,tree_adr)
  ' and, of course, the position of that line below the menu is...
  bar=ADD(OB_Y(tree_adr,1),OB_H(tree_adr,1))
  ' ...and, if we want to avoid it, we want the first position beneath it
  ADD bar,1
  ' nor do we want the menu_bar line to wrap around the screen, either...
  OB_W(tree_adr,1)=max_x
  ' probably already is...
  OB_Y(tree_adr,2)=0
  ' skip over the menu titles themselves, which follow, because
  ' they are the children of the menu title box...
  obj=3
  WHILE OB_TYPE(tree_adr,obj)=32             ! Ob_type 32 = Menu Title
    obj=ADD(obj,1)
  WEND
  ' set the menu background to whole screen
  OB_H(tree_adr,obj)=SUB(max_y,bar)
  OB_Y(tree_adr,obj)=bar
  ' go through all the menu entry objects and ...
  REPEAT
    ' ...skip over the G_STRING (ob_type=28) items until...
    ' (we will also need to know the ob_type of the previous object)
    last_obtype=OB_TYPE(tree_adr,obj)
    obj=ADD(obj,1)
    ' (set all G_BOX objects to new coordinates, ignoring ob_type=28=entries,
    ' UNLESS it's inside ANOTHER G_BOX, especially one with an ICON in it!)
    IF OB_TYPE(tree_adr,obj)=20 AND last_obtype<>20 AND last_obtype<>23
      ' ...we can check all the G_BOX objects in the menu tree to see...
      obx=OB_X(tree_adr,obj)
      obw=OB_W(tree_adr,obj)
      ' ...if they're going to extend off the screen and wrap around and...
      IF ADD(obx,obw)>max_x
        obe=ADD(obx,obw)
        IF obe>max_x
          offset=SUB(obe,max_x)
          ' ...move them to the left to avoid the screen edge!
          OB_X(tree_adr,obj)=SUB(obx,offset)
        ENDIF
      ENDIF
    ENDIF
  UNTIL OB_TYPE(tree_adr,obj)=0              ! end of the menu tree...
ENDIF
'
'
' Jeez, I think we're ready to start now!
'
'
' these memory locations WILL NOT not move around... (uh, better not!)
ABSOLUTE mes_type&,adr_mes                        ! Adr_mes is V:Pipeline&(0)
ABSOLUTE m_title&,ADD(adr_mes,6)                  ! M_title& is Pipeline&(3)
ABSOLUTE m_entry&,ADD(adr_mes,8)                  ! M_entry& is Pipeline&(4)
' get the menu_bar address
~RSRC_GADDR(0,men_tree,menu_adr)
' put up the menu
~MENU_BAR(menu_adr,1)
'
' we're about ready, but first I'd like to advertize a little...
@about
'
' ********************************* MAIN ***********************************
'
DO
  '
  oret=ret                                      ! last return from evnt_multi
  '
  ' This EVNT_MULTI looks for timer_evnts, message_evnts, and keyboard_evnts
  ret=EVNT_MULTI(&X110001,0,0,0,0,0,0,0,0,0,0,0,0,0,adr_mes,5,mx&,my&,mk&,kstat&,key&,clks&)
  '
  ' @Pipeline     ! un-comment this if you want to see message buffer values
  '
  ' first, is it a keyboard event?
  IF key&>0
    scan_code=BYTE{V:key&}
    ascii_code=BYTE{SUCC(V:key&)}
    key&=0
    ' here's one of those cases where GFA's mouse handling and GEM's mouse stuff
    ' quarrel over the poor little rodent, causing it to flicker like crazy.
    ' another such occurance is the FILESELECT that comes on with a stuck mouse.
    ' the cure's a brief refreshing EVNT_MULTI; GEM really likes these quickies.
    REPEAT
      ' repeat until the keyboard event is cleared out
      junk_ret=EVNT_MULTI(&X111111,0,0,0,0,0,0,0,0,0,0,0,0,0,adr_mes,1,mx&,my&,mk&,kstat&,key&,clk&)
    UNTIL key&=0
    @key_reader(ascii_code,activew)
  ENDIF
  '
  ' we will look to the first message of the buffer as our signal to act:
  '
  ' so, is it a message event?
  message=mes_type&                     ! fixed memory location: Pipeline&(0)
  '
  SELECT message
    '
  CASE 10                                ! these are menu messages
    '
    ' object number of the menu item selected
    obj_nr=m_entry&                     ! fixed location: Pipeline&(4)
    ' we handle response to all menu messages, natch
    mt&=m_title&                         ! save the title; it may change...
    @menu_wrangler(obj_nr,activew)     ! go get wrangled
    ' since we use first message, we must clear first message = no repeats
    pipeline&(0)=0                       ! I heard ya already!
    CLR menu                            ! compulsive neatness
    ' turn off menu title highlight
    ~MENU_TNORMAL(menu_adr,mt&,1)       ! turn out the light
    '
  CASE 20 TO 28                          ! these are window messages
    '
    window_handle=pipeline&(3)          ! which window?
    IF window_handle>wn
      ' this could never happen!  Still, I have heard the sound
      SOUND 1,15,3,2,16
      SOUND 1,0,0,0
    ELSE
      ' we do windows, too...            ! window messages are wrangled also
      @western_union(window_handle,activew)
    ENDIF
    ' clear the message buffer of the primary message
    pipeline&(0)=0                       ! enough
    '
  ENDSELECT
  '
LOOP
'
@quit
'
' ********************************* PROC ***********************************
'
PROCEDURE menu_wrangler(menu,VAR activew) ! menu messages come here
  '
  ' the value passed as Menu% is the obj_number of the menu entry chosen
  SELECT menu
    '
    ' the actual object numbers must be read from the resource file
    ' by a program designed to analyze and record their values for you.
    '
  CASE 9                                    ! Credit_panel
    @about
  CASE 18                                   ! New_picture
    @new_picture(activew)
  CASE 19                                   ! Open_window
    @open(activew)
  CASE 20                                   ! Close_window
    @close(activew)
  CASE 27                                   ! Quit_program
    @quit
  DEFAULT
    @escape
  ENDSELECT
  '
RETURN
'
PROCEDURE key_reader(key,VAR activew)     ! key messages come here
  '
  SELECT key
  CASE 14                                   ! you get the idea...
    @new_picture(activew)
  CASE 15
    @open(activew)
  CASE 17
    @quit
  CASE 23
    @close(activew)
  ENDSELECT
  '
RETURN
'
'
PROCEDURE western_union(winhand,VAR activew)     ! window messages come here
  '
  window_message=pipeline&(0)                     ! this is the message
  '
  ' This is our window stack manager...
  w=1                                             ! this little roundel
  REPEAT                                           ! flips through our
    EXIT IF window(w)=winhand                   ! window stack, looking
    ADD w,1                                       ! at each one in order
  UNTIL w>wn                                     ! for a match to windohandle
  '
  IF w=<wn
    '
    ' the message may refer to windows other than the active window,
    ' especially in the case of redraws of non-active windows
    ' and in the case of a non-active window being made the new
    ' active window. So, we will change the window index to that of
    ' the window being affected by the menu message and then restore
    ' the window index after the message has been acted upon...
    ' ...unless the message requires a change of window index.
    ' this insures that all window commands may be safely made
    ' with Activew% as the window index in all cases, for simplicity.
    '
    resactivew=activew             ! save the true active window index
    activew=w                      ! temporary window index
    '
    wx(activew)=pipeline&(4)       ! intout coordinates for window message:
    wy(activew)=pipeline&(5)       ! very handy for updating our table values
    ww(activew)=pipeline&(6)       ! in theory (i.e., with one window), this
    wh(activew)=pipeline&(7)       ! would handle the table values without
    '                                ! our having to bother with updating them;
    '                                ! however, in practice, we must update
    '                                ! them whenever they are changed inside
    '                                ! this procedure (or any procedure called
    '                                ! from within this procedure (see below)
    '
    ' returns window workarea (without borders) of this window
    ~WIND_GET(window(activew),4,ax,ay,aw,ah)
    '
    SELECT window_message           ! What's the word?
      '
    CASE 20                          ! WM_REDRAW
      @redraw
      activew=resactivew           ! restore the proper window index
      '
    CASE 21                          ! WM_TOPPED
      ' in this case the proper window index is changed to a new window...
      ' = top this window = make this window the active window
      ~WIND_SET(window(activew),10,wx(activew),wy(activew),ww(activew),wh(activew))
      ' set the color palette for this window
      ~XBIOS(6,L:V:palette$(activew))
      '
    CASE 22                          ! WM_CLOSED
      ' in this case the proper window index is changed to a new window...
      @close(activew)
      ' the color palette is set for new window in PRO CLOSE
      '
      '
      ' in all the following routines, the active window index does not change.
      '
    CASE 23                          ! WM_FULLED
      '
      full!=NOT full!                ! Toggle between full and normal
      IF full!=TRUE
        ox(activew)=wx(activew)  ! save the current window coordinates for
        oy(activew)=wy(activew)  ! restoration after the fulling operation
        ow(activew)=ww(activew)
        oh(activew)=wh(activew)
        ' record slider positions for restoration
        ~WIND_GET(window(activew),8,ohmark,dum,dum,dum)
        ~WIND_GET(window(activew),9,ovmark,dum,dum,dum)
        ' record image starting coordinates for restoration
        ostartx=startx(activew)
        ostarty=starty(activew)
        ' = close the window at the old size
        ~WIND_CLOSE(window(activew))
        ' = re-open the same window at maximum allowed size
        ~WIND_OPEN(window(activew),abswx,abswy,absww,abswh)
        ' = returns new window workarea
        ~WIND_GET(window(activew),4,ax,ay,aw,ah)
        @bound_check(aw,ah)
        @size_both_sliders(activew)
      ELSE
        ' restore the window to its former coordinates
        ~WIND_SET(window(activew),5,ox(activew),oy(activew),ow(activew),oh(activew))
        ' restore image starting coordinates
        startx(activew)=ostartx
        starty(activew)=ostarty
        ' restore slider positions
        ~WIND_SET(window(activew),8,ohmark,dum,dum,dum)
        ~WIND_SET(window(activew),9,ovmark,dum,dum,dum)
        ' = returns new window workarea
        ~WIND_GET(window(activew),4,ax,ay,aw,ah)
        @bound_check(aw,ah)
        @size_both_sliders(activew)
        ' forced re_draw required for new image coordinates
        @refresh(activew)
        ' see, I told you GEM left the management of windows to the programmer!
      ENDIF
      '
    CASE 24                          ! WM_ARROWED
      ' an additional message is included, indicating which gadget was twiddled!
      sub_message=SUCC(pipeline&(4))
      ON sub_message GOSUB raster_up,raster_down,pixel_row_up,pixel_row_down,raster_left,raster_right,pixel_col_right,pixel_col_left
      ' forced re_draw required for new image coordinates
      @refresh(activew)
      '
    CASE 25                          ! WM_HSLID
      ' GEM passes new position to appl
      hmark=pipeline&(4)
      @use_horz_slider(hmark)
      ' forced re_draw required for new image coordinates
      @refresh(activew)
      '
    CASE 26                          ! WM_VSLID
      ' GEM passes new position to appl
      vmark=pipeline&(4)
      @use_vert_slider(vmark)
      ' forced re_draw required for new image coordinates
      @refresh(activew)
      '
    CASE 27                          ! WM_SIZED
      full!=FALSE
      ' numerical values indicate minimum window sizes, set as you wish
      ' = set this window to these dimensions at this position
      ~WIND_SET(window(activew),5,wx(activew),wy(activew),MAX(80,ww(activew)),MAX(48,wh(activew)))
      ' re-set table values right away whenever changed
      ~WIND_GET(window(activew),5,wx(activew),wy(activew),ww(activew),wh(activew))
      ' = returns new window workarea
      ~WIND_GET(window(activew),4,ax,ay,aw,ah)
      @bound_check(aw,ah)
      @size_both_sliders(activew)
      '
    CASE 28                          ! WM_MOVED
      full!=FALSE
      ' = set this window to these dimensions at this position
      ~WIND_SET(window(activew),5,wx(activew),wy(activew),ww(activew),wh(activew))
      '
    ENDSELECT
  ENDIF
  '
RETURN
'
' forced re_draw
PROCEDURE refresh(activew)
  '
  @bound_check(aw,ah)
  ~WIND_UPDATE(1)
  RC_COPY V:picture(0,window(activew)),startx(activew),starty(activew),aw,ah TO XBIOS(3),ax,ay,3
  ~WIND_UPDATE(0)
  '
RETURN
'
' these are the routines to size the sliders and handle messages
' involving the sliders and arrows fiddled at by the user...
'
PROCEDURE size_both_sliders(activew)  ! sets size and position of both sliders
  ' GEM size index = 0 to 1000
  horz_slider_size=INT((aw/(width(activew)))*1000)
  vert_slider_size=INT((ah/(height(activew)))*1000)
  ' set sizes of both sliders
  ~WIND_SET(window(activew),15,horz_slider_size,dum,dum,dum)
  ~WIND_SET(window(activew),16,vert_slider_size,dum,dum,dum)
  ' calculate position of both sliders
  @set_vmark(activew)
  @set_hmark(activew)
  ' set position of both sliders
  @adjust_vert_slider(vmark,activew)
  @adjust_horz_slider(hmark,activew)
RETURN
PROCEDURE set_hmark(activew)        ! sets horizontal position of slider
  IF width(activew)>aw
    hmark=INT((startx(activew)/(width(activew)-aw))*1000)
  ELSE
    hmark=0
  ENDIF
RETURN
PROCEDURE set_vmark(activew)        ! sets vertical position of slider
  IF height(activew)>ah
    vmark=INT((starty(activew)/(height(activew)-ah))*1000)
  ELSE
    vmark=0
  ENDIF
RETURN
PROCEDURE use_horz_slider(hmark)    ! calculates horizontal position of image
  ' = sets slider to position index indicated by user and passed us in pipeline
  ~WIND_SET(window(activew),8,hmark,dum,dum,dum)
  ' calculate new position in image
  ' GEM position index = 0 to 1000
  place=INT((hmark/1000)*(width(activew)-aw))
  startx(activew)=place
RETURN
PROCEDURE use_vert_slider(vmark)    ! calculates vertical position of image
  ' = sets slider to position index indicated by user and passed us in pipeline
  ~WIND_SET(window(activew),9,vmark,dum,dum,dum)
  ' calculate new position in image
  ' GEM position index = 0 to 1000
  place=INT((vmark/1000)*(height(activew)-ah))
  starty(activew)=place
RETURN
PROCEDURE adjust_horz_slider(hmark,activew) ! sets horizontal slider
  ' = sets position index of horizontal slider
  ~WIND_SET(window(activew),8,hmark,dum,dum,dum)
RETURN
PROCEDURE adjust_vert_slider(vmark,activew) ! sets vertical slider
  ' = sets position index of vertical slider
  ~WIND_SET(window(activew),9,vmark,dum,dum,dum)
RETURN
PROCEDURE raster_up                           ! jump up slider-height
  SUB starty(activew),ah
  @bound_check(aw,ah)
  @set_vmark(activew)
  @adjust_vert_slider(vmark,activew)
RETURN
PROCEDURE raster_down                         ! jump down slider-height
  ADD starty(activew),ah
  @bound_check(aw,ah)
  @set_vmark(activew)
  @adjust_vert_slider(vmark,activew)
RETURN
PROCEDURE pixel_row_up                        ! jump up one scan line
  DEC starty(activew)
  @set_vmark(activew)
  @adjust_vert_slider(vmark,activew)
RETURN
PROCEDURE pixel_row_down                      ! jump down one scan line
  ADD starty(activew),1
  @set_vmark(activew)
  @adjust_vert_slider(vmark,activew)
RETURN
PROCEDURE raster_left                         ! jump left slider-width
  SUB startx(activew),aw
  @bound_check(aw,ah)
  @set_hmark(activew)
  @adjust_horz_slider(hmark,activew)
RETURN
PROCEDURE raster_right                        ! jump right slider-width
  ADD startx(activew),aw
  @bound_check(aw,ah)
  @set_hmark(activew)
  @adjust_horz_slider(hmark,activew)
RETURN
PROCEDURE pixel_col_left                      ! jump left one pixel
  ADD startx(activew),1
  @set_hmark(activew)
  @adjust_horz_slider(hmark,activew)
RETURN
PROCEDURE pixel_col_right                     ! jump right one pixel
  DEC startx(activew)
  @set_hmark(activew)
  @adjust_horz_slider(hmark,activew)
RETURN
PROCEDURE bound_check(wind_wide,wind_high)  ! check boundary conditions
  IF ADD(startx(activew),wind_wide)>max_x ! and curb excesses; keep in
    startx(activew)=SUB(max_x,wind_wide)  ! limits of image boundaries
  ENDIF
  IF startx(activew)<0
    startx(activew)=0
  ENDIF
  IF ADD(starty(activew),wind_high)>max_y
    starty(activew)=SUB(max_y,wind_high)
  ENDIF
  IF starty(activew)<0
    starty(activew)=0
  ENDIF
RETURN
'
'
PROCEDURE open(VAR activew)                 ! Open Window
  '
  l=1
  REPEAT                                     ! window list manager
    EXIT IF NOT in_use!(l)
    ADD l,1
  UNTIL l>wn
  IF l=<wn
    activew=l                              ! assign a window
    IF empty!(window(activew))=FALSE       ! previously closed
      ~WIND_OPEN(window(activew),wx(activew),wy(activew),ww(activew),wh(activew))
      in_use!(activew)=TRUE                 ! restore its status
    ENDIF
    IF empty!(window(activew))=TRUE        ! never opened yet
      ~WIND_OPEN(window(activew),wx(activew),wy(activew),ww(activew),wh(activew))
      ~WIND_GET(window(activew),5,wx(activew),wy(activew),ww(activew),wh(activew))
      ~WIND_GET(window(activew),4,ax,ay,aw,ah)
      @size_both_sliders(activew)
      adr_ptr=V:title_string&(MUL(activew,8))
      ' = pass window title address to AES   ! see ODD BEHAVIOR at end of code
      ~WIND_SET(window(activew),2,CARD(SWAP(adr_ptr)),CARD(adr_ptr),0,0)
      in_use!(activew)=TRUE
      @load_picture(activew)                ! if CANCELED, In_use! is set false
    ENDIF
  ELSE
    ALERT 3," | No More Windows |    Available! | ",1,"Sorry",nurtz
  ENDIF
  ~XBIOS(6,L:V:palette$(activew))
  '
RETURN
'
'
PROCEDURE close(VAR activew)                ! Close Window
  '
  ~WIND_CLOSE(window(activew))             ! close the open window
  in_use!(activew)=FALSE                    ! tag it as not_in_use
  ' find out who's now top of GEM's little list...
  ~WIND_GET(0,10,windohand,dum,dum,dum)  ! get handle of new active window
  ' so we can keep them straight, re-set the ACTIVEW variable
  l=1
  REPEAT                                     ! window list manager
    EXIT IF window(l)=windohand
    ADD l,1
  UNTIL l>wn
  IF l>wn
    activew=0
  ELSE
    activew=l
    ' top new active window
    ~WIND_SET(window(activew),10,wx(activew),wy(activew),ww(activew),wh(activew))
  ENDIF
  ' re-set the color palette for the new window
  ~XBIOS(6,L:V:palette$(activew))
  '
RETURN
'
'
PROCEDURE new_picture(VAR activew)          ! New Picture
  '
  IF activew>0 AND activew=<wn
    @load_picture(activew)
  ELSE IF activew=0 AND empty!(1)=TRUE
    @open(activew)
  ELSE
    ALERT 1," |   No Window Open! | Open a Window First!",1,"Will Do!",nurtz
  ENDIF
  '
RETURN
'
'
PROCEDURE about                              ! About WinShell
  '
  ~XBIOS(6,L:V:userpal$)                     ! return to desk colors
  ~WIND_UPDATE(1)
  about=1                                   ! credits is second tree in .rsc
  ~RSRC_GADDR(0,about,about_adr)           ! get address of about object tree
  ok=6                                      ! objc_number of exit button
  ~FORM_CENTER(about_adr,x0,y0,x1,y1)   ! set coordinates to center dialog
  ~FORM_DIAL(0,mid_x,mid_y,2,2,x0,y0,x1,y1)      ! reserve screen area
  ~FORM_DIAL(1,mid_x,mid_y,2,2,x0,y0,x1,y1)      ! draw pop_up_out lines
  ~OBJC_DRAW(about_adr,0,7,x0,y0,x1,y1)           ! draw the object tree
  ' NOTE: NEVER USE A DEPTH INDEX GREATER THAN SEVEN!  ! La Bomba!
  ~OBJC_CHANGE(about_adr,ok,0,x0,y0,x1,y1,32,1)  ! unselect the exit
  REPEAT
    exit=FORM_DO(about_adr,0)                        ! let GEM manage things
  UNTIL exit=ok
  ~OBJC_CHANGE(about_adr,exit,0,x0,y0,x1,y1,33,1)! select the exit
  PAUSE 24                           ! WAIT, so user can see the selected button
  ~FORM_DIAL(3,mid_x,mid_y,2,2,x0,y0,x1,y1)   ! release reserved screen &
  '                                                 ! slap down green_screen
  ~FORM_DIAL(2,mid_x,mid_y,2,2,x0,y0,x1,y1)   ! draw pop_back_in lines
  ~WIND_UPDATE(0)
  ~XBIOS(6,L:V:palette$(activew))                  ! return to image colors
  '
RETURN
'
'
PROCEDURE redraw                   ! Walk the rectangle list and do redraws
  '
  ~WIND_UPDATE(1)                  ! Lock out other activity while we redraw
  ~WIND_GET(window(activew),11,rx,ry,rw,rh) ! Get first rectangle in the list
  ~WIND_GET(window(activew),4,ax,ay,aw,ah)  ! Workarea of our window
  REPEAT
    IF RC_INTERSECT(ax,ay,aw,ah,rx,ry,rw,rh)  ! Find intersection
      CLIP rx,ry,rw,rh OFFSET ax,ay   ! Set clipping to the area in question
      DEFFILL 0,2,8
      PBOX rx,ry,ADD(rx,rw),ADD(ry,rh)
      @fillwindow                           ! Call our routine to redraw the area
      CLIP 0,0,max_x,max_y OFFSET 0,0     ! Reset full-screen clipping
    ENDIF
    ~WIND_GET(window(activew),12,rx,ry,rw,rh) ! Get next rectangle in the list
  UNTIL rw=0 AND rh=0                ! Keep repeating until no more rectangles
  ~WIND_UPDATE(0)                      ! Re-enable other GEM activity
  '
RETURN
'
'
PROCEDURE fillwindow                   ! Redraw sections of our window
  '
  c1=ADD(startx(activew),SUB(rx,ax))
  c2=ADD(starty(activew),SUB(ry,ay))
  IF ADD(rx,rw)=<max_x
    c3=ADD(c1,rw)
  ELSE
    c3=ADD(SUB(startx(activew),ax),max_x)
  ENDIF
  IF ADD(ry,rh)=<max_y
    c4=ADD(c2,rh)
  ELSE
    c4=ADD(SUB(starty(activew),ay),max_y)
  ENDIF
  '
  ' RC_COPY is ideal for screen-sized "pages," but of no use where image size
  ' is variable (IMG, PCX, IFF, TIFF, etc.). There, the safest thing is to use
  ' copy_raster_opaque and copy_raster_transparent or to use GFA's VDI BITBLT,
  ' the BITBLT Source%(),Destination%(),Parameters%() form of GFA's BITBLiTters.
  '
  RC_COPY V:picture(0,window(activew)),c1,c2,rw,rh TO XBIOS(3),rx,ry,3
  '
RETURN
'
' THIS PROCEDURE NOT CALLED IN WINSHELL:
' while RC_INTERSECT is a very handy command (probably why Frank wrote it!),
' calculations of redraw areas from AES rectangle lists are straightforward:
'
PROCEDURE redraw_calculation
  x1=pipeline&(4)
  y1=pipeline&(5)
  w1=pipeline&(6)
  h1=pipeline&(7)
  gret=WIND_GET(window(activew),11,x2,y2,w2,h2)
  ~WIND_UPDATE(1)
  WHILE w2<>0 AND h2<>0
    tww=MIN(ADD(x1,PRED(w1)),ADD(x2,PRED(w2)))
    thh=MIN(ADD(y1,PRED(h1)),ADD(y2,PRED(h2)))
    txx=MAX(x1,x2)
    tyy=MAX(y1,y2)
    x2=txx
    y2=tyy
    w2=SUB(tww,txx)
    h2=SUB(thh,tyy)
    IF tww=>txx AND thh=>tyy
      CLIP x2,y2,w2,h2
      ' place the call to your re_drawing routine here...
    ENDIF
    gret=WIND_GET(window(activew),12,x2,y2,w2,h2)
  WEND
  ~WIND_UPDATE(0)
  CLIP 0,0,max_x,max_y
RETURN
'
PROCEDURE load_picture(VAR activew)                ! Degas pic loader
  '
  flag!=TRUE                                        ! assume empty-ness as true
  IF empty!(activew)=TRUE
    ~WIND_GET(window(activew),4,ax,ay,aw,ah)  ! total workarea
    ~WIND_UPDATE(1)                                 ! taking over
    CLIP ax,ay,aw,ah OFFSET 0,0                 ! just the window workarea
    DEFFILL 0,2,8                                   ! clear the window workarea
    PBOX ax,ay,ADD(ax,aw),ADD(ay,ah)
    CLIP rx,ry,rw,rh OFFSET ax,ay             ! re-set
    ~WIND_UPDATE(0)                                 ! all yours again
  ENDIF
  '
  ' this will cure the "stickies," the "flickers," and other mouse disorders!
  REPEAT
    junk_ret=EVNT_MULTI(&X111111,0,0,0,0,0,0,0,0,0,0,0,0,0,adr_mes,1,mx&,my&,mk&,kstat&,key&,clk&)
  UNTIL mk&=0 AND kstat&=0
  '
  FILESELECT #"LOAD DEGAS FILE",path$,"",file$(activew)
  '
  IF file$(activew)<>"" AND file$(activew)<>"\"   ! got one!
    rez&=0
    OPEN "I",#11,file$(activew)
    BGET #11,V:rez&,2                               ! resolution flag
    IF rez&=XBIOS(4)                                ! go complain to Tom
      BGET #11,V:palette$(activew),32                  ! suck in palette
      ' Raster_address%=V:Picture%(0,Window%(Activew%)) ! where we is
      BGET #11,V:picture(0,window(activew)),screen_size   ! suck in screen
      flag!=FALSE                    ! a file has been loaded = NOT empty
      path$=file$(activew)                         ! update the path
      WHILE RIGHT$(path$,1)<>"\"
        path$=LEFT$(path$,PRED(LEN(path$)))
      WEND
      path$=path$+"*.PI"+STR$(SUCC(XBIOS(4)))
      wintitle$(activew)=file$(activew)           ! convert file name
      WHILE INSTR(wintitle$(activew),"\",1)        ! to window title$
        wintitle$(activew)=RIGHT$(wintitle$(activew),PRED(LEN(wintitle$(activew))))
      WEND                                          ! window title string
      wintitle$(activew)=" "+wintitle$(activew)+" "+STRING$(2,0) !+ 2 NUL's
      BMOVE V:wintitle$(activew),V:title_string&(activew*8),16
      adr_ptr=V:title_string&(activew*8)          ! see ODD BEHAVIOR (below)
      ~WIND_SET(window(activew),2,CARD(SWAP(adr_ptr)),CARD(adr_ptr),0,0)
      ' instead of:
      ' ~Wind_set(Window%(Activew%),2,Card(Swap(V:Wintitle$(Activew%))),Card(V:Wintitle$(Activew%)),0,0)
      ~WIND_UPDATE(1)                               ! watch it!
      @fillwindow                                   ! re_draw
      ~WIND_UPDATE(0)                               ! all clear
      @size_both_sliders(activew)
    ELSE
      ' either wrong rez or compressed file
      IF rez&<128
        ALERT 3," | Wrong Monitor! | ",1,"Abort!",nurtz
      ELSE
        ' compressed files have a value in the high byte = $8000+xbios(4),
        ' but this won't happen because of untrapped EOF error first,
        ' but that won't happen because of the Rez&-check trap first!
        ALERT 3," | Compressed File! | ",1,"Abort!",nurtz
      ENDIF
    ENDIF
    CLOSE #11
  ENDIF
  ~XBIOS(6,L:V:palette$(activew))
  IF empty!(activew)=TRUE AND flag!=FALSE
    empty!(activew)=FALSE
  ENDIF
  ' if no image is loaded and no prior image in buffer, then...
  IF empty!(activew)=TRUE AND flag!=TRUE
    @close(activew)                       ! withdraw the window
  ENDIF
  '
RETURN
'
' two exit routines
'
PROCEDURE quit
  '
  ALERT 3," | Are You Sure | You Want to | Exit to GEM? ",1,"Exit|Stay",dummie
  IF dummie=1                          ! I gotta go!
    FOR a=1 TO wn
      IF in_use!(a)=TRUE               ! if windows open...
        ~XBIOS(6,L:V:palette$(a))      ! well, I think it's a nice touch...
        PAUSE 14
        ~WIND_CLOSE(window(a))        ! ...close'em
      ENDIF
      ~WIND_DELETE(window(a))         ! kill'em all
    NEXT a
    ~XBIOS(6,L:V:userpal$)              ! desk colors returned
    ~MENU_TNORMAL(menu_adr,m_title&,1) ! turn off the lights
    ~MENU_BAR(menu_adr,0)              ! menu kill
    CLIP 0,0,max_x,max_y              ! clip liberation front
    ~RSRC_FREE()                        ! dump the objects
    RESERVE FRE(0)+10240                ! gimme my memory back
    EDIT                                ! I'm outta here!
  ENDIF
  '
RETURN
'
'
PROCEDURE escape                        ! as above, without freedom of choice
  '
  ~XBIOS(6,L:V:userpal$)
  FOR a=0 TO wn
    IF in_use!(a)=TRUE
      ~WIND_CLOSE(window(a))
    ENDIF
    ~WIND_DELETE(window(a))
  NEXT a
  ~WIND_UPDATE(0)                       ! just in case we err'ed out before...
  ~MENU_TNORMAL(menu_adr,m_title&,1)
  ~MENU_BAR(menu_adr,0)
  CLIP 0,0,max_x,max_y
  ~RSRC_FREE()
  RESERVE FRE(0)+10240
  EDIT
  '
RETURN
'
' this routine, if uncommented from MAIN, shows the values contained in the
' message pipeline in the menu title box; it requires an 80-column display.
'
PROCEDURE pipeline
  IF oret<>ret AND max_x>320
    PRINT AT(40,1);"PIPE(";STR$(activew);"):  ";     ! Activew% also shown
    FOR i=0 TO 7
      PRINT pipeline&(i);" ";
    NEXT i
    PRINT "   ";
  ENDIF
RETURN
'
'
'
' ODD BEHAVIOR EXPLAINED:
' Window Title String Addresses:
'
' Here is one of GFA's real weak points: GEM assumes a string address
' to be kept at a fixed address in memory; once this address is passed
' to GEM, it will always refer to this location until another address
' passed. However, GFA has the most dynamic string management of any
' programming language ever; it slings strings around constantly and
' they never stay in one place very long. So, in program operation,
' it's inevitable that GEM will go to a string address and find a stranger
' living there. This wouldn't be so bad if GEM didn't also have an
' absolute requirement that strings end in a NUL byte (or two). When
' GEM starts flushing in what it thinks is string data and the nearest
' NUL byte happens to be a long way down the pike, GEM will overwrite
' itself, resulting in what can only be described as operating-system
' psychosis! Cures are as follows: BMOVE the string data (+ 2 NUL bytes)
' to a fixed (indexed) word-variable array and pass GEM the indexed array
' address instead of the string address (tricky), or if you only have one
' or two windows in a program, put the WIND_SET title call in the bottom of
' of the window message handler (PRO WESTERN_UNION in this program) so
' the window title address is re-set with EVERY window message. Crude,
' but it works... WINSHELL uses the first method (above). Since file names
' are twelve characters + a space before and after = 14 bytes, the array
' allows 16 bytes for each title_string, with two NUL's included. This
' method prevents the occasional brief display of high_ascii garbage in
' the window title line, which does no harm but annoys me nevertheless!
'
'
'
' TERMINAL NOTES:
'
' These routines can be adapted to any image format that limits itself to
' screen-sized images (Neo, Degas, PrismPaint, Tiny). Neo's are uncompressed,
' Degas and Prism may be, Tiny can't be. There is a Neo specification for all
' Atari screen sizes (including TT). There isn't any reason why Degas (or
' rather the .P?? file extent sub-set of image files) could not be easily
' extended to include TT and all Falcon screens, too.
'
'
' *********************************** END **********************************