REM >!RunImage REM (C) Martyn Fox REM shape drawing program REM based on Wimp shell program v0.01 version$="0.01 (date)" ON ERROR SYS "Wimp_CloseDown",task%,&4B534154:REPORT:PRINT" at line ";ERL:END SYS "Wimp_Initialise",200,&4B534154,"Shapes" TO ,task% PROCinit PROCcreateicon ON ERROR IF FNerror THEN PROCclose:END 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 ON ERROR OFF PROClose_fonts SYS "Wimp_CloseDown",task%,&4B534154 ENDPROC : DEFPROCpoll REM main program Wimp polling loop SYS "Wimp_Poll",&3831,b% TO r% 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%"*" 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",,".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% textbuf%=!(stack%+88+32*7+20) 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% 2047,menspc% 2047,stack% 1023,list% 2047,ptsize% 12,fontname% 50 $ptsize%="" $fontname%="Trinity.Medium" wsend%=ws%+2048:stackend%=stack%+1024:stackptr%=stack%:menend%=menspc%+2048:fontlist%=list%+1024 quit%=FALSE:printing%=FALSE !list%=-1:!fontlist%=-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 WHEN &400C0:PROCmenu_message 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 PROCfont_size_menu PROCattach(wmenu%,0,options%) PROCattach(wmenu%,2,saveas%) PROCattach(wmenu%,3,1) PROCattach(wmenu%,4,fmenu%) $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":PROCchecksave WHEN "Print":PROCprint OTHERWISE IF LEFT$($c%,5)="Font.":PROCpick_font 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%) IF plot%=0 THEN PROCtext(xorig%+x%,yorig%-y%,colour%,coords%) ELSE SYS "Wimp_SetColour",colour% PLOT plot%,xorig%+x%,yorig%-y% coords%+=4 ENDIF 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,Font_M,Font size,Print,* 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%-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% THEN coords%-=4 IF (!coords% AND &FF000000)=0 coords%-=!coords%:SYS "Font_LoseFont",coords%!4 !coords%=-1 ELSE VDU 7 ENDIF PROCforce_redraw(main%) ENDPROC : DEFPROCopt_box(button%,icon%) CASE icon% OF WHEN 0,1,2,3,6: 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 PROClose_fonts !list%=-1 PROCforce_redraw(main%) ENDPROC : DEFFNerror IF printing%:SYS "XPDriver_AbortJob",pfile%:SYS "Hourglass_Off":CLOSE#pfile%:printing%=FALSE !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) PROClose_fonts 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) PROCupdate_fonts !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%=FNend2+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 : DEFPROCtext(x%,y%,col%,RETURN coords%) fh%=coords%!4:coords%+=8 SYS "Wimp_SetFontColours",,1,col% SYS "Font_SetFont",fh% SYS "Font_Paint",,coords%,%10000,x%,y% WHILE ?coords%>=32:coords%+=1:ENDWHILE coords%+=1:WHILE (coords% MOD 4)<>0:coords%+=1:ENDWHILE coords%+=4 ENDPROC : DEFPROCadd_text(RETURN coords%) LOCAL n%,pt%,fonth% PROCterm(textbuf%) IF coords%+LEN$textbuf%>list%+984:VDU 7:coords%-=4:ENDPROC pt%=VAL$ptsize%*16:IF pt%=0 pt%=14*16 SYS "Font_FindFont",,fontname%,pt%,pt% TO fonth% PROCadd_font(fonth%,pt%) coords%!4=fonth% $(coords%+8)=$textbuf% n%=LEN$textbuf%+8 coords%?n%=0 n%+=1 WHILE n% MOD 4<>0:n%+=1:ENDWHILE coords%!n%=n% coords%+=n% ENDPROC : DEFPROCfont_size_menu RESTORE+1 DATA Font size,_W,ptsize%,12,* fmenu%=FNmake_menu ENDPROC : DEFPROCmenu_message CASE TRUE OF WHEN topmenu%=wmenu% AND b%!32=3 AND b%!36=-1:PROCfont_list(b%!24,b%!28) ENDCASE ENDPROC : DEFPROCfont_list(menx%,meny%) buf%=menspc% SYS "Font_ListFonts",,0,%101<<19,,0,,0 TO ,,,bsize1%,,bsize2% IF bsize1%>menend%-buf% ERROR 1<<30,"Not enough space to list all the fonts" IF bsize2%>wsend%-ws% ERROR 1<<30,"Insufficient indirected workspace to list all fonts" SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname% PROCattach(wmenu%,3,buf%) SYS "Wimp_CreateSubMenu",,buf%,menx%,meny% ENDPROC : DEFPROCpick_font SYS "Wimp_DecodeMenu",,buf%,b%+4,fontname% SYS "Font_ListFonts",,buf%,%101<<19,menend%-buf%,ws%,wsend%-ws%,fontname% ENDPROC : DEFPROCadd_font(h%,p%) LOCAL n%,found% found%=FALSE n%=fontlist% WHILE !n%<>-1 IF !n%=h% found%=TRUE n%+=8 WHILE ?n%>=32:n%+=1:ENDWHILE n%+=1 WHILE n% MOD 4<>0 n%+=1:ENDWHILE ENDWHILE IF NOT found% THEN !n%=h%:n%!4=p%:$(n%+8)=$fontname% n%+=8 WHILE ?n%>=32:n%+=1:ENDWHILE n%+=1 WHILE n% MOD 4<>0 n%+=1:ENDWHILE !n%=-1 ENDIF ENDPROC : DEFFNend2 LOCAL n% n%=fontlist% WHILE !n%<>-1 n%+=4 ENDWHILE =n% : DEFPROCupdate_fonts LOCAL n% n%=fontlist% WHILE !n%<>-1 AND n%0:err%=newh%:!err%=1<<30:PROCclear:SYS "OS_GenerateError",err% PROCupdate_plot_list(oldh%,newh%) !n%=newh% n%+=8 WHILE ?n%>=32:n%+=1:ENDWHILE n%+=1 WHILE n% MOD 4<>0:n%+=1:ENDWHILE ENDWHILE ENDPROC : DEFPROCupdate_plot_list(old%,new%) LOCAL n% n%=FNend WHILE n%>list% IF (!n% AND &FF000000)<>0 THEN n%-=4 ELSE n%-=!n% IF n%!4=old% n%!4=new% IF n%>list% n%-=4 ENDIF ENDWHILE ENDPROC : DEFPROClose_fonts LOCAL n% n%=FNend WHILE n%>list% IF (!n% AND &FF000000)<>0 THEN n%-=4 ELSE n%-=!n% SYS "Font_LoseFont",n%!4 IF n%>list% n%-=4 ENDIF ENDWHILE !fontlist%=-1 ENDPROC : DEFPROCprint printxpos%=93675:printypos%=216855 transx_to_x%=1<<16:transx_to_y%=0 transy_to_x%=0:transy_to_y%=1<<16 SYS "XPDriver_Info" TO err%,,,fea%;flags% IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err% SYS "Hourglass_On" pfile%=OPENOUT"printer:" printing%=TRUE SYS "XPDriver_SelectJob",pfile% TO err%;flags% IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err% xorig%=0:yorig%=0 !b%=xorig%:b%!4=yorig%-1020:b%!8=xorig%+1020:b%!12=yorig% b%!16=transx_to_x%:b%!20=transx_to_y% b%!24=transy_to_x%:b%!28=transy_to_y% b%!32=printxpos%:b%!36=printypos% SYS "XPDriver_GiveRectangle",0,b%,b%+16,b%+32,&FFFFFF00 TO err%;flags% IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err% SYS "XPDriver_DrawPage",1,b%+28 TO more%;flags% IF (flags% AND 1)<>0 !more%=1<<30:SYS "OS_GenerateError",more% WHILE more%<>0 PROCdraw(b%,xorig%,yorig%) SYS "XPDriver_GetRectangle",,b%+28 TO more%;flags% IF (flags% AND 1)<>0 !more%=1<<30:SYS "OS_GenerateError",more% ENDWHILE SYS "XPDriver_EndJob",pfile% TO err%;flags% IF (flags% AND 1)<>0 !err%=1<<30:SYS "OS_GenerateError",err% printing%=FALSE CLOSE#pfile% SYS "Hourglass_Off" ENDPROC :