Commit b41ce340 authored by Robert Sprowson's avatar Robert Sprowson
Browse files

Reimport of source file

This is a text version of former !RunImage,ffb revision 4.1.1.1 so CVS can sensibly diff it.
Not tagged.
parent 044d08dc
bas/** gitlab-language=bbcbasic linguist-language=bbcbasic linguist-detectable=true
*,ffb gitlab-language=bbcbasic linguist-language=bbcbasic linguist-detectable=true
REM >!Chars.!RunImage
REM Copyright 2015 Castle Technology Ltd
REM
REM Licensed under the Apache License, Version 2.0 (the "License");
REM you may not use this file except in compliance with the License.
REM You may obtain a copy of the License at
REM
REM http://www.apache.org/licenses/LICENSE-2.0
REM
REM Unless required by applicable law or agreed to in writing, software
REM distributed under the License is distributed on an "AS IS" BASIS,
REM WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
REM See the License for the specific language governing permissions and
REM limitations under the License.
REM
REM !Chars
REM Copyright Acorn Computers 1989,1990,1991
DIM q% 255, C$(8), CharDef 8, buffer% &200
DIM wid% 1024 : REM added to allow centring of font chars in the grid
: REM if curf% > -1 then each wid%!(4*i%) holds the width in millipoints of character code i.
FOR i% = 0 TO 255: wid%!i% = 0: NEXT i%
PROCms_load("chars:messages")
LM%=16:RM%=16:BM%=16:TM%=16
MXSP%=24:MYSP%=44
FOR X%=0 TO 31
IF X%<=15 THEN C$(0)+=FNCH(X%,0) ELSE C$(8)+=FNCH(X%,0)
FOR Y%=1 TO 7:C$(Y%)+=FNCH(X%,Y%):NEXT
NEXT
R$=CHR$23+CHR$32+STRING$(8,CHR$0):C$(3)+=R$:C$(8)+=R$
font$=$sysfont%:curf%=-1
HotKey%=-1:REM Shift key
!q%=10:q%!4=&502:q%!8=&400c1:q%!12=0
SYS"Wimp_Initialise",300,&4B534154,FNms_1("Tsk",""),q% TO wimpversion%,TaskHandle
SYS"Wimp_OpenTemplate",,"Chars:Templates"
LOCAL ERROR
ON ERROR RESTORE ERROR:SYS"Wimp_CloseTemplate":PROCms_end:ERROR ERR, REPORT$
SYS"Wimp_LoadTemplate",,q%+4,0,0,-1,"Characters",0
RESTORE ERROR
SYS"Wimp_CloseTemplate"
DIM InputVars 3*4-1, OutputVars 2*4-1
InputVars!0=4:InputVars!4=5:InputVars!8=-1:REM XEigFactor, YEigFactor
PROCReadModeVars
q%!12=q%!4+LM%+31*MXSP%+16+RM%
q%!8=q%!16-TM%-7*MYSP%-32-BM%
SYS"Wimp_CreateWindow",,q%+4 TO WindowHandle
!q%=WindowHandle:q%!28=-1
PROCOpenWindow
Null=0:Redraw=1:Open=2:Close=3:PointerLeaving=4:PointerEntering=5:MouseChange=6
MenuSelect=9:MessageA=17:MessageB=18
PollFlags=1<<Null
HIMEM=END+1024:END=HIMEM+8*1024:HIMEM=END+3072
menudata%=HIMEM
REPEAT
SYS "Wimp_Poll",PollFlags,q% TO reason
CASE reason OF
WHEN Null: PROCCheckHotKey
WHEN Redraw: PROCRedrawWindow
WHEN Open: PROCOpenWindow
WHEN Close: PROCCloseWindow
WHEN PointerLeaving: PROCPointerLeaving
WHEN PointerEntering: PROCPointerEntering
WHEN MouseChange: PROCCheckMouse(!q%,q%!4,q%!8,q%!12,q%!16,q%!20)
WHEN MenuSelect: PROCdomenu(FALSE)
WHEN MessageA, MessageB: PROCMessage
ENDCASE
UNTIL FALSE
END
DEFPROCCheckHotKey
IsDown%=INKEY HotKey%
IF IsDown% AND NOT WasDown% THEN
SYS "Wimp_GetPointerInfo",,q%
PROCDoChar
ENDIF
WasDown%=IsDown%
ENDPROC
DEFPROCRedrawWindow
LOCAL ch%,F%
SYS "Wimp_RedrawWindow",,q% TO flag%
IFcurf%>-1 THEN
SYS "XFont_SetFont",curf%:SYS "Wimp_SetFontColours",,0,7 TO ;F%
IF F% AND 1 PROCfonterror(FALSE): ENDPROC
ELSE
VDU23,17,7,4,MXSP%>>XEIG%;MYSP%>>YEIG%;0;
ENDIF
WHILE flag%
StartX%=q%!4+LM%-q%!20:StartY%=q%!16-TM%-q%!24
IFcurf%>-1 THEN
ox0%=(q%!28-StartX%)DIVMXSP%:IFox0%>31 ox0%=31
ox1%=(q%!36-StartX%)DIVMXSP%:IFox1%>31 ox1%=31
FOR Y%=1 TO 7:CY%=StartY%-24-Y%*MYSP%
IF CY%<q%!40+MYSP% AND CY%+MYSP%>=q%!32 THEN
FORX%=ox0%TOox1%
ch% = Y%*32+X%
SYS "XFont_Paint",,CHR$(ch%),&14,StartX%+X%*MXSP% + MXSP%DIV2 -(wid%!(4*ch%) DIV 800),CY% TO ;F%
IF F% AND 1 PROCfonterror : ENDPROC
NEXT
ENDIF
NEXT
ELSE
FOR Y%=0 TO 7:CY%=StartY%-Y%*MYSP%
IF CY%<q%!40+31 AND CY%>=q%!32 THEN
MOVE StartX%,CY%:PRINT C$(Y%);:IF Y%=0 PRINT C$(8);
ENDIF
NEXT
ENDIF
SYS "Wimp_GetRectangle",,q% TO flag%
ENDWHILE
IF curf%>-1 THEN
ELSE
VDU23,17,7,4,16>>XEIG%;32>>YEIG%;0;
ENDIF
ENDPROC
DEFPROCOpenWindow
SYS"Wimp_OpenWindow",,q%
ENDPROC
DEFPROCCloseWindow
IFcurf%>-1 SYS "XFont_LoseFont",curf%:curf%=-1
PROCms_end
SYS"Wimp_CloseDown"
END
ENDPROC
DEFPROCPointerLeaving
PollFlags=PollFlags OR (1<<Null):REM No more null events
ENDPROC
DEFPROCPointerEntering
PollFlags=PollFlags AND NOT (1<<Null):REM Enable null events
WasDown%=INKEY HotKey%
ENDPROC
DEFPROCMessage
CASE q%!16 OF
WHEN 0:PROCCloseWindow
WHEN 10: PROCsave_desktop_state
WHEN &400C1:PROCReadModeVars
WHEN &502:PROCDoHelp
ENDCASE
ENDPROC
DEFFNCH(X%,Y%)
C%=X%+Y%*32
IF C%<32 OR C%=127 THEN
IF C%=127 THEN C%=ASC"?" ELSE C%=C% OR ASC"@"
CharDef?0=C%:SYS"OS_Word",10,CharDef
C$=CHR$23+CHR$32
FOR I%=1 TO 8
C$+=CHR$(CharDef?I% EOR &FF)
NEXT
C$+=" "
ELSE
C$=CHR$C%
ENDIF
=C$
DEFPROCReadModeVars
LOCAL F%
SYS"OS_ReadVduVariables",InputVars,OutputVars
XEIG%=OutputVars!0:YEIG%=OutputVars!4
IFcurf%>-1 THEN
SYS"XFont_LoseFont",curf%
SYS"XFont_FindFont",,a$,13*16,15*16 TO curf%; F%
IF F% AND 1 PROCfonterror: ENDPROC
ENDIF
ENDPROC
DEFPROCCheckMouse(mousex%,mousey%,b%,handle%,icon%,ob%)
IF b% AND 4 THEN
PROCDoChar
ELSE
IF b% AND 2 THEN PROCpopupmenu
ENDIF
ENDPROC
DEF PROCpopupmenu
LOCAL A%
SYS "Hourglass_On"
SYS "Font_ListFonts",,0,7<<19,,0,,FNf(font$) TO ,,,size1%,,size2%
SYS "Wimp_SlotSize",menudata%+size1%+size2%-&8000,-1 TO A%
IF A%+&8000<menudata%+size1%+size2% THEN ERROR 224,FNms_1("MenuSpc","")
menustrings%=menudata%+size1%
SYS "Font_ListFonts",,menudata%,7<<19,size1%,menustrings%,size2%,FNf(font$)
SYS "Hourglass_Off"
A%=menudata%?12
REM $menudata% = LEFT$(FNms_1("Menu",""),12)
REM menudata%!(28+12)=sysfont%
REM menudata%!16 = FNmax(menudata%!16,FNmax(LEN$menudata%-3,LEN$sysfont%)*16+12)
REMmenudata%?12=A%
SYS "Wimp_CreateMenu",,menudata%,mousex%-102,mousey%+64
ENDPROC
DEF FNmax(A%,B%) IF A%>B% THEN =A% ELSE =B%
DEF FNf(font$) IF font$=$sysfont% THEN =1 ELSE =font$
REM ** fake% = TRUE means that this call is not really in response
REM ** to a menu hit. We assume sysfont and ignore button 3 in this case.
DEF PROCdomenu(fake%)
LOCAL i%,w%,F%
IF fake% OR !q%=0 THEN
a$=$sysfont%
ELSE
SYS "Font_DecodeMenu",,menudata%,q%,STRING$(200,CHR$0),200 TO ,,,a$
ENDIF
IFa$<>"" AND a$<>font$ THEN
IFcurf%>-1 SYS "XFont_LoseFont",curf%:curf%=-1
font$=a$
IFa$<>$sysfont% THEN
SYS "XFont_FindFont",,a$,13*16,15*16 TO curf%; F%
IF F% AND 1 PROCfonterror: ENDPROC
REM set up the wid% array
SYS "Font_SetFont",curf%:SYS "Wimp_SetFontColours",,0,7
FOR i% = 32 TO 255
SYS "Font_StringWidth",,CHR$(i%),1000000,1000000,-1,1 TO ,,w%
wid%!(4*i%)=w%
NEXT i%
ENDIF
SYS "Wimp_ForceRedraw",WindowHandle,0,-1024,1280,0
ENDIF
IF NOT fake% THEN
SYS "Wimp_GetPointerInfo",,q%:IFq%?8AND1 PROCpopupmenu
ENDIF
ENDPROC
DEFPROCDoChar
IF q%!12=WindowHandle THEN
Char%=FNCoordsToChar(q%!0,q%!4)
IF Char%<>-1 THEN SYS"Wimp_ProcessKey",Char%
ENDIF
ENDPROC
DEFPROCDoHelp
MES$=""
HisTaskHandle%=q%!4
HisRef%=q%!8
IF q%!32=WindowHandle THEN
Char%=FNCoordsToChar(q%!20,q%!24)
IF Char%<>-1 THEN
MES$=FNms_2("Help",STR$Char%,FNH(Char%))
ENDIF
ELSE
IF wimpversion%>=218 AND q%!36<>-1 THEN MES$=FNms_1("MH","")
ENDIF
q%!0=((20+LENMES$+1)+3)ANDNOT3
q%!12=HisRef%
q%!16=&503
$(q%+20)=MES$
q%?(20+LENMES$)=0
SYS"Wimp_SendMessage",MessageA,q%,HisTaskHandle%
ENDPROC
DEFFNCoordsToChar(MouseX%,MouseY%)
!q%=WindowHandle
SYS "Wimp_GetWindowState",,q%
YOff%=(q%!16-TM%-q%!24+((MYSP%-32)>>1)-MouseY%)DIV MYSP%
Char%=-1
IF YOff%>=0 AND YOff%<=7 THEN
XOff%=(MouseX%-(q%!4+LM%-q%!20+((16-MXSP%)>>1)))DIV MXSP%
IF XOff%>=0 AND XOff%<=31 THEN
Char%=XOff%+YOff%*32
ENDIF
ENDIF
=Char%
REM ** bodge alert
REM ** get here if a Font_ swi returns an error. Force return to
REM ** system font with an error message. We force any open menu shut
REM ** because we don't know whether to re-encode our own menu (it may
REM ** or may not be open -- can't tell!)
DEF PROCfonterror
LOCAL N$
N$=FNms_1("Tsk","")
SYS "XWimp_ReportError", FNms_1_error("FontErr","",999), 0, N$
SYS "Wimp_CreateMenu", -1
PROCdomenu(TRUE)
ENDPROC
DEFFNH(X%)=RIGHT$("0"+STR$~X%,2)
DEF PROCms_load(name$)
SYS "MessageTrans_FileInfo",,name$
DIM ms_text% 256
SYS "OS_Module",6,,,17+LEN(name$) TO ,,ms_desc%
$(ms_desc%+16)=name$
SYS "MessageTrans_OpenFile",ms_desc%,ms_desc%+16
DIMsysfont% 28
$sysfont% = FNms_1("Font","")
ENDPROC
DEF PROCms_end
SYS "XMessageTrans_CloseFile",ms_desc%
SYS "XOS_Module",7,,ms_desc%
ENDPROC
DEF FNms_1(tag$,arg1$)
LOCAL L%
REM non-X version; let it blow out with default message if token not found
SYS "MessageTrans_Lookup",ms_desc%,tag$,ms_text%,256,arg1$ TO ,,,L%
ms_text%?L%=13
=$ms_text%
DEF FNms_2(tag$,arg1$,arg2$)
LOCAL L%
REM non-X version; let it blow out with default message if token not found
SYS "MessageTrans_Lookup",ms_desc%,tag$,ms_text%,256,arg1$,arg2$ TO ,,,L%
ms_text%?L%=13
=$ms_text%
REM returns an error block instead
DEF FNms_1_error(tag$,arg1$,errno%)
LOCAL L%
REM non-X version; let it blow out with default message if token not found
SYS "MessageTrans_Lookup",ms_desc%,tag$,ms_text%+4,252,arg1$ TO ,,,L%
ms_text%?(L%+4)=13
!ms_text% = errno%
=ms_text%
DEFPROCsave_desktop_state
LOCAL i%,l%
LOCAL ERROR
ON ERROR LOCAL q%!12=q%!8:SYS"Wimp_SendMessage",19,q%,q%!4:ENDPROC
i%=q%!20
SYS"XOS_ReadVarVal","Chars$Dir",buffer%,1024,0,3 TO ,,l%
buffer%?l%=13
BPUT#i%,"AddTinyDir "+$buffer%
ENDPROC
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment