REM >!RunImage
 REM (C) Martyn Fox
 REM shape drawing program
 REM based on Wimp shell program v0.01
 version$="0.01 (date)"
 ON ERROR PROCclose:REPORT:PRINT" at line ";ERL:END
 SYS "Wimp_Initialise",200,&4B534154,"Shapes" TO ,task%
 PROCinit
 PROCcreateicon
 ON ERROR IF FNerror THEN PROCclose:END
 T=TIME
 REPEAT
   PROCpoll
 UNTIL quit%
 PROCclose
 END
 :
 DEFPROCcreateicon
 REM creates the application's icon and puts it on the icon bar
 !b%=-1:b%!4=0:b%!8=0:b%!12=68:b%!16=68:b%!20=&3002
 $(b%+24)="!shapes":SYS"Wimp_CreateIcon",,b% TO i%
 ENDPROC
 :
 DEFPROCclose
 REM tells the Wimp to quit the application
 SYS "Wimp_CloseDown",task%,&4B534154
 ENDPROC
 :
 DEFPROCpoll
 REM main program Wimp polling loop
 SYS "Wimp_Poll",1,b% TO r%
 IF TIME>=T+10 VDU7:T=TIME
 CASE r% OF
   WHEN 1:PROCredraw(b%)
   WHEN 2:SYS "Wimp_OpenWindow",,b%
   WHEN 3:SYS "Wimp_CloseWindow",,b%
   WHEN 6:PROCmouseclick
   WHEN 7:PROCdragend
   WHEN 8:PROCkeypress
   WHEN 9:PROCmenuclick
   WHEN 17,18:PROCreceive
 ENDCASE
 ENDPROC
 :
 DEFPROCmouseclick
 REM handles mouse clicks in response to Wimp_Poll reason code 6
 REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
 CASE b%!12 OF
   WHEN -2:CASE b%!8 OF
     WHEN 2:PROCshowmenu(mainmenu%,!b%-64,96+2*44):REM replace '2' with number of main menu items
     WHEN 4:!b%=main%:SYS "Wimp_GetWindowState",,b%:b%!28=-1:SYS "Wimp_OpenWindow",,b%
   ENDCASE
   WHEN main%:PROCwindow_click
   WHEN options%:PROCopt_box(b%!8,b%!16)
   WHEN saveas%:PROCsavebox
 ENDCASE
 ENDPROC
 :
 DEFPROCget_origin(handle%,RETURN xorig%,RETURN yorig%)
 REM returns coordinates of window work area origin
 LOCAL c%
 c%=FNstack(36)
 !c%=handle%
 SYS "Wimp_GetWindowState",,c%
 xorig%=c%!4-c%!20:yorig%=c%!16-c%!24
 PROCunstack(c%)
 ENDPROC
 :
 DEFFNstack(size%)
 REM allocates temporary memory from stack block
 REM stack must be cleared after use with PROCunstack
 IF stackptr%+size%>stackend%  ERROR 1,"No room in stack"
 stackptr%+=size%
 =stackptr%-size%
 :
 DEFPROCunstack(old_ptr%)
 REM removes temporary memory from stack
 stackptr%=old_ptr%
 IF stackptr%<stack% stackptr%=stack%
 ENDPROC
 :
 DEFFNmake_menu
 REM creates menu block from DATA statements
 LOCAL start%,title$,item$,ul%,tail$,writable%,buffer%,buflen%
 start%=menspc%
 READ title$
 $(start%)=title$
 start%?12=7:REM title foreground colour
 start%?13=2:REM title background colour
 start%?14=7:REM work area foreground colour
 start%?15=0:REM work area background colour
 start%!20=44:REM height of menu items
 start%!24=0:REM gap between items
 width%=LEN(title$)-3
 menspc%+=28
 REPEAT
   READ item$
   IF item$<>"*" THEN
     !menspc%=0
     writable%=FALSE
     ul%=INSTR(item$,"_")
     IF ul% THEN
       tail$=RIGHT$(item$,LEN(item$)-ul%)
       IF INSTR(tail$,"T") !menspc%=!menspc% OR 1:REM tick
       IF INSTR(tail$,"D") !menspc%=!menspc% OR 2:REM dotted line
       IF INSTR(tail$,"W") !menspc%=!menspc% OR 4:writable%=TRUE:READ buffer%:READ buflen%:REM writable icon
       IF INSTR(tail$,"M") !menspc%=!menspc% OR 8:REM generate message
       item$=LEFT$(item$,ul%-1)
     ENDIF
     IF LENitem$>width% width%=LENitem$
     menspc%!4=-1:REM submenu ptr
     IF writable% THEN
       menspc%!8=&0700F121:menspc%!12=buffer%:menspc%!16=-1:menspc%!20=buflen%:$buffer%=item$
       ELSE
       IF LENitem$<12 THEN
         menspc%!8=&07000021:$(menspc%+12)=item$
         ELSE
         menspc%!8=&07000121:menspc%!12=ws%:menspc%!16=-1:menspc%!20=LENitem$+1
         $ws%=item$:ws%+=LENitem$+1
       ENDIF
     ENDIF
     menspc%+=24
   ENDIF
 UNTIL item$="*"
 start%!16=width%*16+32
 !(menspc%-24)=!(menspc%-24) OR &80
 mptr%=menspc%
 =start%
 :
 DEFPROCload_templates
 REM opens window template file, loads and creates window
 SYS "Wimp_OpenTemplate",,"<Shapes$Dir>.Templates"
 REM ****** load and create Info box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"progInfo",0 TO ,,ws%
 $stack%!(88+32*0+20)=version$
 SYS "Wimp_CreateWindow",,stack% TO info%
 REM ****** load and create main window ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Main",0 TO ,,ws%
 SYS "Wimp_CreateWindow",,stack% TO main%
 REM ****** load and create Options dialogue box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"Options",0 TO ,,ws%
 SYS "Wimp_CreateWindow",,stack% TO options%
 REM ****** load and create Save box ******
 SYS "Wimp_LoadTemplate",,stack%,ws%,wsend%,-1,"xfer_send",0 TO ,,ws%
 savestr%=!(stack%+88+32*2+20)
 SYS "Wimp_CreateWindow",,stack% TO saveas%
 REM ****** end of window creation ******
 SYS "Wimp_CloseTemplate"
 ENDPROC
 :
 DEFPROCattach(menu%,item%,sub%)
 REM attach submenu or dialogue box to main menu
 !(menu%+28+item%*24+4)=sub%
 ENDPROC
 :
 DEFPROCinit
 REM initialisation before polling loop starts
 DIM b% 255,ws% 1023,menspc% 1023,stack% 1023,list% 1023
 wsend%=ws%+1024:stackend%=stack%+1024:stackptr%=stack%
 quit%=FALSE
 !list%=-1
 colsel%=7
 PROCload_templates
 PROCmenus
 !b%=main%:SYS "Wimp_GetWindowState",,b%:SYS "Wimp_OpenWindow",,b%
 ENDPROC
 :
 DEFPROCreceive
 REM handles messages received from the Wimp with reason codes 17 or 18
 CASE b%!16 OF
   WHEN 0:quit%=TRUE
   WHEN 2:PROCsave
   WHEN 3:PROCload
 ENDCASE
 ENDPROC
 :
 DEFPROCwindow_click
 REM handles mouse clicks on window
 REM b%!0=mousex,b%!4=mousey:b%!8=buttons:b%!12=window handle (-2 for icon bar):b%!16=icon handle
 CASE b%!8 OF
   WHEN 2:PROCshowmenu(wmenu%,!b%,b%!4)
   WHEN 1:PROCdelete_item
   WHEN 4:PROCadd_item
 ENDCASE
 ENDPROC
 :
 DEFPROCmenus
 REM create menus and attach submenus and dialogue boxes
 PROCmain_menu
 PROCattach(mainmenu%,0,info%)
 PROCwindow_menu
 PROCattach(wmenu%,0,options%)
 PROCattach(wmenu%,2,saveas%)
 $savestr%="ShapeFile"
 ENDPROC
 :
 DEFPROCshowmenu(menu%,x%,y%)
 REM opens menu at given coordinates
 topmenu%=menu%:topx%=x%:topy%=y%
 SYS "Wimp_CreateMenu",,menu%,x%,y%
 ENDPROC
 :
 DEFPROCmenuclick
 REM handles mouse clicks on menu in response to Wimp_Poll reason code 9
 LOCAL c%,adj%
 c%=FNstack(20)
 SYS "Wimp_GetPointerInfo",,c%
 adj%=(c%!8 AND 1)
 SYS "Wimp_DecodeMenu",,topmenu%,b%,c%
 CASE $c% OF
   WHEN "Quit":quit%=TRUE
   WHEN "Clear":PROCclear
   WHEN "Save":PROCsave
 ENDCASE
 IF adj% PROCshowmenu(topmenu%,topx%,topy%)
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCmain_menu
 REM creates main menu, calling FNmake_menu
 RESTORE +1
 DATA Shapes,Info,Quit,*
 mainmenu%=FNmake_menu
 ENDPROC
 :
 DEFPROCredraw(b%)
 REM redraws window contents
 LOCAL xorig%,yorig%,more%
 PROCget_origin(!b%,xorig%,yorig%)
 SYS "Wimp_RedrawWindow",,b% TO more%
 WHILE more%
   PROCdraw(b%,xorig%,yorig%)
   SYS "Wimp_GetRectangle",,b% TO more%
 ENDWHILE
 ENDPROC
 :
 DEFPROCdraw(b%,xorig%,yorig%)
 REM called when all or part of window needs redrawing
 REM xorig% and yorig% are coordinates of work area origin (top left-hand corner of window work area)
 REM b% points to block:
 REM b%!0  : window handle
 REM b%!4  : visible area minimum x coordinate
 REM b%!8  : visible area minimum y coordinate
 REM b%!12 : visible area maximum x coordinate
 REM b%!16 : visible area maximum y coordinate
 REM b%!20 : scroll x offset relative to work area origin
 REM b%!24 : scroll y offset relative to work area origin
 REM b%!28 : current graphics window minimum x coordinate
 REM b%!32 : current graphics window minimum y coordinate
 REM b%!36 : current graphics window maximum x coordinate
 REM b%!40 : current graphics window maximum y coordinate
 LOCAL coords%,colour%,plot%
 MOVE xorig%,yorig%
 coords%=list%
 WHILE !coords%<>-1
   PROCplot_shape(!coords%,x%,y%,colour%,plot%)
   SYS "Wimp_SetColour",colour%
   PLOT plot%,xorig%+x%,yorig%-y%
   coords%+=4
 ENDWHILE
 ENDPROC
 :
 DEFPROCplot_shape(word%,RETURN x%,RETURN y%,RETURN colour%,RETURN plot%)
 REM returns parameters of object to be plotted, decoded from word%
 x%=(word% AND &3FF)*4:y%=(word%>>12) AND &FFC
 colour%=(word%>>10) AND &F
 plot%=(word%>>24) AND &FF
 ENDPROC
 :
 DEFPROCwindow_menu
 RESTORE +1
 DATA Shapes,Options,Clear,Save,*
 wmenu%=FNmake_menu
 ENDPROC
 :
 DEFFNicon_state(window%,icon%)
 LOCAL c%
 c%=FNstack(40)
 !c%=window%
 c%!4=icon%
 SYS "Wimp_GetIconState",,c%
 PROCunstack(c%)
 =((c%!24) AND (1<<21))<>0
 :
 DEFPROCadd_item
 x%=!b%:y%=b%!4
 PROCget_origin(main%,xorig%,yorig%)
 coords%=FNend
 IF coords%<list%+1020 THEN
 CASE TRUE OF
   WHEN FNicon_state(options%,0):plot%=4:REM MOVE
   WHEN FNicon_state(options%,1):plot%=5:REM DRAW
   WHEN FNicon_state(options%,2):plot%=157:REM CIRCLE FILL
   WHEN FNicon_state(options%,3):plot%=101:REM RECTANGLE FILL
   OTHERWISE:plot%=4:REM MOVE - all icons deselected
 ENDCASE
 !coords%=(((x%-xorig%) AND &FFC) DIV 4)+((yorig%-y%) AND &FFC)*(1<<12)+(colsel% AND &F)*(1<<10)
 coords%?3=plot%
 coords%!4=-1
 PROCforce_redraw(main%)
 ENDIF
 ENDPROC
 :
 DEFFNend
 LOCAL n%
 n%=list%
 WHILE !n%<>-1
   n%+=4
 ENDWHILE
 =n%
 :
 DEFPROCforce_redraw(window%)
 LOCAL c%
 c%=FNstack(36)
 !c%=window%
 SYS "Wimp_GetWindowState",,c%
 SYS "Wimp_ForceRedraw",-1,c%!4,c%!8,c%!12,c%!16
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCdelete_item
 coords%=FNend
 IF coords%>list% coords%-=4:!coords%=-1 ELSE VDU 7
 PROCforce_redraw(main%)
 ENDPROC
 :
 DEFPROCopt_box(button%,icon%)
 CASE icon% OF
   WHEN 0,1,2,3:
   WHEN 5:
     !b%=options%:b%!4=4
     SYS "Wimp_GetIconState",,b%
     colsel%=(b%!24)>>28
     IF button%=4 SYS "Wimp_CreateMenu",,-1
   OTHERWISE
     !b%=options%:b%!4=icon%
     SYS "Wimp_GetIconState",,b%
     b%!4=4:b%!8=(b%!24) AND &F<<28:b%!12=&F<<28
     SYS "Wimp_SetIconState",,b%
 ENDCASE
 ENDPROC
 :
 DEFPROCclear
 !list%=-1
 PROCforce_redraw(main%)
 ENDPROC
 :
 DEFFNerror
 !b%=ERR
 CASE !b% OF
 WHEN 1<<30:err_str$="":box%=3
 OTHERWISE:err_str$=" at line "+STR$ERL:box%=2
 ENDCASE
 $(b%+4)=REPORT$+err_str$+CHR$0
 SYS "Wimp_ReportError",b%,box%,"Shapes" TO ,response%
 =(response%=2)
 :
 DEFPROCload
 IF b%!40<>&012 ERROR 1<<30,"Filetype not recognised"
 PROCterm(b%+44)
 SYS "XOS_CLI","LOAD "+$(b%+44)+" "+STR$~list% TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 b%!12=b%!8
 b%!16=4:REM Message_DataLoadAck
 SYS "Wimp_SendMessage",17,b%,b%!4
 $savestr%=$(b%+44)
 !b%=main%
 SYS "Wimp_GetWindowState",,b%
 IF ((b%!32) AND 1<<16)=0 THEN
   SYS "Wimp_OpenWindow",,b%
 ELSE
   PROCforce_redraw(main%)
 ENDIF
 ENDPROC
 :
 DEFPROCterm(a%)
 LOCAL n%
 WHILE a%?n%>31
   n%+=1
 ENDWHILE
 a%?n%=13
 ENDPROC
 :
 DEFPROCsavebox
 CASE b%!16 OF
   WHEN 0:IF b%!8=1 OR b%!8=4 THEN PROCchecksave
   WHEN 1:IF b%!8=16 OR b%!8=64 THEN PROCdrag(b%!12,1)
 ENDCASE
 ENDPROC
 :
 DEFPROCdrag(window%,icon%)
 LOCAL c%
 c%=FNstack(56)
 PROCget_origin(window%,xorig%,yorig%)
 !c%=window%:c%!4=icon%
 SYS "Wimp_GetIconState",,c%
 xmin%=xorig%+c%!8:ymin%=yorig%+c%!12:xmax%=xorig%+c%!16:ymax%=yorig%+c%!20
 c%!4=5:REM drag type
 c%!8=xmin%:REM coordinates of drag box
 c%!12=ymin%
 c%!16=xmax%
 c%!20=ymax%
 c%!24=0:REM screen min x
 c%!28=0:REM screen min y
 c%!32=4096:REM screen max x
 c%!36=3072:REM screen max y
 SYS "Wimp_DragBox",,c%
 PROCunstack(c%)
 ENDPROC
 :
 DEFPROCdragend
 SYS "Wimp_GetPointerInfo",,b%
 b%!20=b%!12:REM destination window handle
 b%!24=b%!16:REM destination icon handle
 b%!28=b%!0:REM destination x coordinate
 b%!32=b%!4:REM destination y coordinate
 b%!36=FNend+4-list%:REM length of data
 a$=$savestr%:REM get leafname
 WHILE INSTR(a$,".")<>0
   n%=INSTR(a$,".")
   a$=MID$(a$,n%+1)
 ENDWHILE
 $(b%+44)=a$:REM leafname of file
 !b%=44+((LENa$+1) DIV 4)*4:REM length of block
 IF ((LENa$+1) MOD 4)<>0 !b%+=4
 b%!12=0:REM your_ref for original message
 b%!16=1:REM Message_DataSave
 SYS "Wimp_SendMessage",18,b%,b%!20
 ENDPROC
 :
 DEFPROCsave
 PROCterm(b%+44)
 $savestr%=$(b%+44)
 PROCsave2
 b%!12=b%!8
 b%!16=3:REM Message_DataLoad
 SYS "Wimp_SendMessage",18,b%,b%!20
 ENDPROC
 :
 DEFPROCsave2
 n%=FNend+4
 SYS "XOS_CLI","SAVE "+$savestr%+" "+STR$~list%+" "+STR$~n% TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 SYS "XOS_CLI","SETTYPE "+$savestr%+" 012" TO err%;flags%
 IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err%
 SYS "Wimp_CreateMenu",,-1
 ENDPROC
 :
 DEFPROCchecksave
 IF INSTR($savestr%,"::")<>0 AND INSTR($savestr%,"$.")<>0 THEN
   PROCsave2
 ELSE
   SYS "Wimp_CreateMenu",,-1
   ERROR 1<<30,"To save, drag the icon to a directory display"
 ENDIF
 ENDPROC
 :
 DEFPROCkeypress
 REM processes keypresses in response to Wimp_Poll reason code 8
 IF b%!24=13 THEN
   !b%=saveas%
   SYS "Wimp_GetWindowState",,b%
   IF (b%!32 AND 1<<16)<>0 THEN PROCchecksave
 ELSE
   SYS "Wimp_ProcessKey",b%!24
 ENDIF
 ENDPROC
 :