Home » Personal collection » Acorn ADFS disks » Archimedes » ALPS.ADF » !ALPS/!RunImage
!ALPS/!RunImage
This website contains an archive of files for the Acorn Electron, BBC Micro, Acorn Archimedes, Commodore 16 and Commodore 64 computers, which Dominic Ford has rescued from his private collection of floppy disks and cassettes.
Some of these files were originally commercial releases in the 1980s and 1990s, but they are now widely available online. I assume that copyright over them is no longer being asserted. If you own the copyright and would like files to be removed, please contact me.
| Tape/disk: | Home » Personal collection » Acorn ADFS disks » Archimedes » ALPS.ADF |
| Filename: | !ALPS/!RunImage |
| Read OK: | ✔ |
| File size: | 1D244 bytes |
| Load address: | FFFFFB42 |
| Exec address: | C7ABC11 |
Duplicates
There is 1 duplicate copy of this file in the archive:
- Personal collection » Acorn hard disk » apps » Alps » !ALPS/!RunImage
- Personal collection » Acorn ADFS disks » Archimedes » ALPS.ADF » !ALPS/!RunImage
File contents
10REM >$.!ALPS.!RunImage
20REM Copyright Alpine Software/Philip Hawthorne 1989
30REM With modifications by Keith McAlpine
40version$="5.08C, 22-Nov-1989"
50
60DIM block &200,mistake 300,quitblk 100
70
80ON ERROR MODE 0:PRINT REPORT$:PRINT ":";ERL:SYS"Wimp_CloseDown":END
90
100@%=&10:ctr%=0
110mode%=MODE
120testing=FALSE
130resources_ok=FNOS_Var("Alps$Resources") AND FNOS_Var("Alps$Data")
140
150SYS "OS_GetEnv" TO Env$
160I%=INSTR(Env$,CHR$34,INSTR(Env$,CHR$34)+1)
170ef$=MID$(Env$,I%+1)
180WHILE LEFT$(ef$,1)=" "
190ef$=MID$(ef$,2)
200ENDWHILE
210
220theLastMenu = 0 : tick$=""
230
240type$="CF8"
250
260DIM tempBlk 4
270$tempBlk = "TASK"
280SYS "Wimp_Initialise",200,!tempBlk,"ALPS" TO ,task%
290
300IF NOT resources_ok THEN ERROR 1,"The ALPS resources are not available. Open up the directory viewer with !ALPS in it.":SYS "Wimp_CloseDown",task%,!tempBlk:END
310PROCinstall_texted
320PROCinit2
330ON ERROR dialog=FNerrorbox(REPORT$,ERR,1,-99):GOTO 500
340PROCnew
350PROCassemble(armcode%)
360PROCfill(text_block%,text_blocksize%,dummy_spc)
370PROCfill(verb_type,2*(maxvbn+1),0)
380PROCfill(nref+4,nref_size-4,0)
390PROCfill(aref+4,aref_size-4,0)
400PROCclear
410claimpoll$="":claimmenu$="":quit%=FALSE
420
430path$=ef$
440IF ef$<>"" THEN
450$filename%=FNleafname(ef$)
460PROCload_all(ef$)
470PROCopen(ALPSmain,400,800,600,600)
480ENDIF
490
500REPEAT
510SYS Poll,,block TO reason
520CASE reason OF
530 WHEN 1: PROCredraw(!block)
540 WHEN 2: SYS OpenW,,block
550 WHEN 3: PROCclose(!block)
560 WHEN 6: PROCcheckmouse(!block,block!4,block!8,block!12,block!16,block!20)
570 WHEN 7: PROCsave:REM User has dragged 'Alps' file icon to another window
580 WHEN 8: PROCuserkeypressed(!block,block!4,block!24)
590 WHEN 9: PROCmenuselect(!block,block!4)
600 WHEN 17,18: PROCreceive(block)
610 ENDCASE
620UNTIL quit%
630SYS "Wimp_CloseDown",task%,!tempBlk:IF testing THEN OSCLI("FX4"):REPORT:PRINT" at line ";ERL:END
640END
650
660DEF PROCinit2
670PROCgetmodeinfo:oldsize=scrnsize
680data_saved=TRUE:loaded$=""
690DIM a_list$(10)
700small_areasize%=30
710DIM small_area% small_areasize%
720
730DIM D%(3),shade%(15),scale 15,pixtr 15
740REM ---------------------------------
750REM Manifest constants for the system
760
770maxrms=1000:maxobs=255:maxsw%=10:maxtokens=128
780
790listoption=2:REM Default LISTO
800
810DIM pos$(3)
820FOR I%=0 TO 3:READ pos$(I%):NEXT
830DATA T,B,L,R
840
850DIM oldpars 73
860FOR I%=0 TO 72
870READ B%:oldpars?I%=B% AND &F
880NEXT
890
900DATA 0,0,0,0,0,1,161,193
910DATA 161,193,2,1,0,128,128,0
920DATA 128,0,0,128,0,1,1,1
930DATA 1,65,1,0,0,0,65,0
940DATA 130,194,130,194,193,193,129,129
950DATA 193,193,131,195,1,130,128,128
960DATA 2,2,66,0,1,66,3,67
970DATA 0,1,1,65,65,65,3,0
980DATA 1,1,130,130,130,2,130,2
990DATA 2
1000
1010maxlen=10:REM Maximum word length in vocabulary
1020
1030REM Room and object data block lengths (in bytes)
1040r_len=74:o_len=16
1050
1060num_vars=60:REM Number of ALPS variables
1070var_size=num_vars*2:REM 2 bytes per variable
1080
1090maxmsg=65535:maxobn=255:maxvbn=255:maxconst=65535
1100maxadj=255:maxprep=50:maxconj=10:maxspec=30:maxnoise=50:maxpix=50
1110
1120noun_size=3000
1130verb_size=3000
1140adjc_size=2000
1150prep_size=400:REM Size of prepositions list
1160conj_size=50:REM size of conjunctions list
1170spec_size=100:REM size of 'specials' list (IT, THEM, ALL)
1180noise_size=200:REM size of 'noise' list (THE,A,AN)
1190aref_size=2000:REM size of adjective object reference table
1200nref_size=2000:REM size of nouns object reference table
1210pix_size=1000:REM size of pix filename list
1220
1230DIM nouns noun_size,verbs verb_size,adjects adjc_size,preps prep_size,conjs conj_size,specs spec_size,noise noise_size,pixs pix_size
1240
1250DIM aref aref_size,nref nref_size,verb_type 2*(maxvbn+1)
1260
1270noun_end=nouns+noun_size:verb_end=verbs+verb_size
1280adjc_end=adjects+adjc_size:prep_end=preps+prep_size:conj_end=conjs+conj_size:spec_end=specs+spec_size:noise_end=noise+noise_size
1290aref_end=aref+aref_size:nref_end=nref+nref_size:pix_end=pixs+pix_size
1300
1310REM Printer codes etc
1320condensed=15:reset=64
1330pline$=STRING$(132,"-")
1340pline2$=STRING$(79,"-")
1350
1360REM ------- Set up data areas for rooms and objects and clear them ------
1370DIM rdata% (maxrms+1)*r_len,odata% (maxobs+1)*o_len,controom% 12
1380
1390REM Set up the save buffers
1400initareasize=7*(maxobs+1)+22*(maxrms+1)
1410DIM initsave initareasize,ramsave initareasize+var_size+128
1420$controom%="0":cont_room=0:container=FALSE
1430
1440rptr=1:optr=1:last_room=1:last_object=1
1450
1460REM areas to store flag descriptions
1470maxd%=13
1480DIM o_flags% maxd%*8,r_flags% maxd%*8
1490
1500REM Set the flag descriptions
1510FOR I%=7 TO 0 STEP-1
1520READ flag$
1530$(o_flags%+I%*maxd%)=LEFT$(flag$,maxd%-1)
1540NEXT
1550
1560FOR I%=7 TO 0 STEP-1
1570READ flag$
1580$(r_flags%+I%*maxd%)=LEFT$(flag$,maxd%-1)
1590NEXT
1600
1610REM Object Flag descriptions
1620DATA "","",Being worn,Wearable,Scenery,Invisible,Takeable,Light source
1630
1640REM Room flag descriptions
1650DATA "","","","","","",Visited,Light
1660
1670REM Room Exit flag descriptions
1680DATA Invisible,Closed door,Open door,Locked door,Unl'ked door,Blocked,Reserved,Reserved
1690
1700DIM exit_flag$(7)
1710FOR flag=7 TO 0 STEP-1:READ exit_flag$(flag):NEXT
1720
1730DIM proc% 12,exit% 12,def% 12
1740$proc%="":$def%="":$exit%=""
1750
1760REM prg_sel% = Section of program selected for editing
1770REM 2=Main, 3=Proc, 4=Define, 5=Exit
1780REM progval$ = STR$ value of proc or exit number or name of selected verb
1790
1800prg_sel%=2:progval$=""
1810
1820REM voc_sect% = Section of vocabulary selected for editing
1830REM 1=Nouns, 2=Verbs
1840voc_sect%=1
1850
1860pbsize=(scrnsize DIV 2)+400:REM size of picture buffer
1870
1880DIM picbuf pbsize
1890
1900prgbsize=&1000
1910DIM prgbuf% prgbsize
1920
1930REM ------- Some constants for the character designer -------
1940
1950cur_chr%=ASC"A":max_chr%=125
1960DIM charnum 12
1970$charnum=""
1980
1990REM ------- Dimension the other arrays needed -------
2000ucsize=500
2010SYS "OS_File",5,"<ALPS$Resources>.ASIobjcode" TO ftype,,,,codesize
2020pbyte_size=148
2030DIM armcode% 1000,pbytes pbyte_size,work% &1100,asicode% codesize+10
2040DIM usercode% ucsize
2050run=asicode%:printmsg=asicode%+4:search=asicode%+12:findcode=asicode%+16
2060setup=asicode%+20
2070OSCLI("LOAD <ALPS$Resources>.ASIobjcode "+STR$~asicode%)
2080DIM pal%(2)
2090DIM q% &2000,erroraddr%(4)
2100DIM indexdata% 32*24+20
2110maxbuf%=&3000
2120DIM buffer% maxbuf%:curbuff%=buffer%
2130nh%=32:ni%=11
2140DIM handle%(nh%+1),wident$(nh%),wptr%(nh%)
2150FOR I%=0TOnh%:handle%(I%)=I%-1:wident$(I%)="":NEXT:handleSP%=nh%
2160DIM icon%(ni%+1),iconbar$(ni%)
2170FOR I%=0 TO ni%:icon%(I%)=-1:READ iconbar$(I%):NEXT
2180icon%(ni%+1)=-1
2190oldicon%=0:oldrmicon%=0
2200
2210REM ------ Names of icons (sprites) on icon bar ------
2220DATA disk35,arclogo,door,key,quill,info,listing,chardes,vocab,swap,eye,face
2230
2240diskicon=0:texticon=4:progicon=6:staricon=99
2250vocabicon=8:faceicon=99:arcicon=1:swapicon=9
2260alpsicon=5:helpicon=13:eyeicon=10
2270THEkeyicon=3:THEdooricon=2:texticon=4:THEcharicon=7
2280
2290DIM menufree% &1800:menuend%=menufree%+&1800
2300DIM menulist% &100
2310DIM qBlk% 256
2320dx%=2:lsY%=40:ypixel%=4:chX%=16:chY%=32
2330currentwindow%=-1:currenticon%=-1
2340spritef$=""
2350DIM mb_wident% 12,filename% 64,filename2% 64,import% 64
2360IF testing $filename%="demo" ELSE $filename%="starter"
2370$filename2%="charset":$import%=""
2380DIM start(20),sys_b2% &300,os_block 50
2390
2400PROCKeyWordRead
2410PROCErrorMsgRead
2420
2430REM ----- Define the "Wimp" and "OS" SYS numbers ------
2440Wimp=&400C0
2450CreateW=Wimp+1
2460CreateI=Wimp+2
2470DeleteW=Wimp+3
2480DeleteI=Wimp+4
2490OpenW=Wimp+5
2500CloseW=Wimp+6
2510Poll=Wimp+7
2520RedrawW=Wimp+8
2530UpdateW=Wimp+9
2540GetW=Wimp+11
2550GetWI=Wimp+&C
2560SetCaret=Wimp+&12
2570GetCaret=Wimp+&13
2580GetR=Wimp+&A
2590SetI=Wimp+&D
2600GetI=Wimp+&E
2610GetP=Wimp+&F
2620Drag=Wimp+&10
2630ForceR=Wimp+&11
2640CreateM=Wimp+&14
2650SetP=Wimp+&18
2660ReadPal=&2F
2670
2680REM ------ Set up our own sprite area and read the sprites in ------
2690SYS "OS_File",5,"<ALPS$Resources>.AlpsSprite" TO ,,,,spritesize
2700spritesize+=4
2710DIM spritearea% spritesize
2720!spritearea%=spritesize
2730SYS "OS_SpriteOp",266,spritearea%,"<Alps$Resources>.AlpsSprite"
2740DIM fontcounts% 255,mb_wident% 24
2750
2760REM ------ Set up the wimps and their handles ------
2770
2780DIMrgb(19,3)
2790PROCloadtemplates("<Alps$Resources>.ALPS")
2800
2810REM ------ Name the window handles ------
2820objhandle=handle%(FNmatchident("objected"))
2830roomhandle=handle%(FNmatchident("roomedit"))
2840texthandle=handle%(FNmatchident("texted"))
2850design=handle%(FNmatchident("chrdesign"))
2860infohandle=handle%(FNmatchident("info"))
2870savehandle=handle%(FNmatchident("saveas"))
2880ALPSmain=handle%(FNmatchident("iconbar")):dialogue%=0
2890setuph=handle%(FNmatchident("Setup"))
2900desticon=47:exitprogicon=48
2910
2920iconbar% = -2
2930windowindex%=nh%+1
2940
2950PROCchangeicon(infohandle,7,version$,dummy)
2960
2970firstIconBarIcon% = FNiconbar(spritearea%, "face",31,19)
2980THEmiscicon=firstIconBarIcon%
2990
3000
3010REM ------ Define the colours ------
3020barfgcol=11:barbgcol=3
3030`wbcol=0:`tbcol=2:`sco=&3:`mbcol=&B
3040`wfcol=7:`tfcol=7:`sci=&D:`tbcol2=&C
3050
3060cur_pal%=7:phys_col%=16
3070
3080first_token=&30:REM Lowest keyword token value
3090PROCfind_token(keyword$(),"INC",var_token,dummy):REM Tokens from here up allow variables
3100PROCfind_token(keyword$(),"DEFINE",def_token,dummy)
3110PROCfind_token(keyword$(),"STOP",stop_token,dummy)
3120PROCfind_token(keyword$(),"END",end_token,dummy)
3130PROCfind_token(keyword$(),"EXIT",exit_token,dummy)
3140PROCfind_token(keyword$(),"DEFPROC",proc_token,dummy)
3150PROCfind_token(keyword$(),"PREP",prep_token,dummy)
3160PROCfind_token(keyword$(),"NOTPREP",notprep_token,dummy)
3170
3180REM ------ Set up the dictionary ------
3190dict_size=1000
3200DIM dict% dict_size,tok$(maxtokens)
3210!dict%=3:dict%?2=&80
3220
3230REM ------ Find the available memory ------
3240memfree=(HIMEM-END)-50000
3250IF memfree<0 THEN null=FNerrorbox("Not enough memory available in 'Next' slot",0,1,-99):SYS "Wimp_CloseDown":END
3260maxtext%=0.83*memfree
3270code_size%=0.17*memfree
3280
3290REM ------ Areas for storing messages, switch info etc; ------
3300DIM text% maxtext%,swdata% 12*maxsw%,switch_vals(maxsw%),m_msg% 12
3310DIM switch_buf% 2*maxsw%+1
3320$swdata%=STRING$(12*maxsw%,CHR$13):$m_msg%=""
3330
3340REM ------ Initialise the text area ------
3350!text%=1:text%!2=&B:text%!6=0:text%!10=0
3360DIM st_msg% 12,end_msg% 12
3370$st_msg%="1":$end_msg%="1"
3380mptr=1:REM The current message number
3390text_owner$="":REM The current owner of any text in the text editor
3400
3410datavalid=TRUE
3420
3430REM ------ Set up the program area ------
3440DIM program% code_size%
3450!program%=0
3460program%!4=0
3470errflag=FALSE
3480
3490REM ------ Set up the menu structure ------
3500m_controom%=FNcrmenu
3510DATA "#Number,$controom%(5)"
3520m_contain=FNcrmenu
3530DATA "Container,Use room>m_controom%"
3540m_chardes%=FNcrmenu
3550DATA "#CHANGE TO?,$charnum(2)"
3560char_fname%=FNcrmenu
3570DATA "#Filename:,$filename2%(11)"
3580menu_fname%=FNcrmenu
3590DATA "#Filename:,$filename%(11)"
3600m_gotomsg%=FNcrmenu
3610DATA "$m_msg%(12)"
3620m_proc%=FNcrmenu
3630DATA "#Number:,$proc%(4)"
3640m_def%=FNcrmenu
3650DATA "#Verb:,$def%(12)"
3660m_exit%=FNcrmenu
3670DATA "#Number:,$exit%(4)"
3680m_listopts=FNcrmenu
3690DATA "#Display:,Vocabulary as numbers,Vocabulary as strings"
3700m_import%=FNcrmenu
3710DATA "#Filename:,$import%(11)"
3720sw1=FNcrmenu:nxtsw=swdata%+12
3730DATA "#Value:,$swdata%(12)"
3740sw2=FNcrmenu:nxtsw=nxtsw+12
3750DATA "#Value:,$nxtsw"
3760sw3=FNcrmenu:nxtsw=nxtsw+12
3770DATA "#Value:,$nxtsw"
3780sw4=FNcrmenu:nxtsw=nxtsw+12
3790DATA "#Value:,$nxtsw"
3800sw5=FNcrmenu:nxtsw=nxtsw+12
3810DATA "#Value:,$nxtsw"
3820sw6=FNcrmenu:nxtsw=nxtsw+12
3830DATA "#Value:,$nxtsw"
3840sw7=FNcrmenu:nxtsw=nxtsw+12
3850DATA "#Value:,$nxtsw"
3860sw8=FNcrmenu:nxtsw=nxtsw+12
3870DATA "#Value:,$nxtsw"
3880sw9=FNcrmenu:nxtsw=nxtsw+12
3890DATA "#Value:,$nxtsw"
3900sw10=FNcrmenu:nxtsw=nxtsw+12
3910DATA "#Value:,$nxtsw"
3920m_switch%=FNcrmenu
3930DATA "#Switch,No switches,1>sw1,2>sw2,3>sw3,4>sw4,5>sw5,6>sw6,7>sw7,8>sw8,9>sw9,10>sw10"
3940m_text%=FNcrmenu
3950DATA "#MSG: nnnnn,Insert,Overtype#,Cut,Copy,Paste#,Next,Previous,First,Last,Goto msg#>m_gotomsg%,Edit switch#>m_switch%,Print this"
3960m_prog%=FNcrmenu
3970DATA "#Program Editor,Insert,Overtype#,Cut,Copy,Paste#,Main,Procedure>m_proc%,Define>m_def%,Exit routine#>m_exit%,Print this,List options>m_listopts"
3980m_vocab%=FNcrmenu
3990DATA "#Vocabulary,Insert,Overtype#,Cut,Copy,Paste#,Nouns,Verbs,Adjectives,Prepositions,Conjunctions,Specials,Noise#,Print this"
4000pixmenu=FNcrmenu
4010DATA "#Pictures,Print"
4020progmenu=FNcrmenu
4030DATA "#Program,Print,Import#>m_import%,Run"
4040charmenu=FNcrmenu
4050DATA "#CharSet,Save>char_fname%,Load>char_fname%"
4060vocabmenu=FNcrmenu
4070DATA "#Vocabulary,Print"
4080diskmenu=FNcrmenu
4090DATA "#Files,Save all>savehandle,Setup disk"
4100facemenu=FNcrmenu
4110DATA "#Actors,Print"
4120miscmenu=FNcrmenu
4130DATA "#ALPS,Info>infohandle,Quit"
4140msg2%=FNcrmenu
4150DATA "$st_msg%(6)"
4160msg3%=FNcrmenu
4170DATA "$end_msg%(6)"
4180msg1%=FNcrmenu
4190DATA "#From/To?,Start msg>msg2%,End msg>msg3%"
4200textmenu=FNcrmenu
4210DATA "#Text,Print>msg1%,Import>m_import%"
4220objmenu=FNcrmenu
4230DATA "#Objects,Print,Import>m_import%"
4240mo_user5=FNcrmenu:ofl%=o_flags%+maxd%*3
4250DATA "#Description:,$o_flags%(13)"
4260mo_user4=FNcrmenu:ofl%=ofl%+maxd%
4270DATA "#Description:,$ofl%(13)"
4280mo_user3=FNcrmenu:ofl%=ofl%+maxd%
4290DATA "#Description:,$ofl%(13)"
4300mo_user2=FNcrmenu:ofl%=ofl%+maxd%
4310DATA "#Description:,$ofl%(13)"
4320mo_user1=FNcrmenu:ofl%=ofl%+maxd%
4330DATA "#Description:,$ofl%(13)"
4340mo_user0=FNcrmenu:ofl%=ofl%+maxd%
4350DATA "#Description:,$ofl%(13)"
4360m_objflag=FNcrmenu
4370DATA "#Flags,7 Light source,6 Takeable,5 Invisible,4 Scenery,3 Wearable,2 Being worn,1 User flag>mo_user1,0 User flag>mo_user0"
4380roommenu=FNcrmenu
4390DATA "#Rooms,Print,Import>m_import%"
4400mr_user6=FNcrmenu:rfl%=r_flags%+maxd%*2
4410DATA "#Description:,$r_flags%(13)"
4420mr_user5=FNcrmenu:rfl%=rfl%+maxd%
4430DATA "#Description:,$rfl%(13)"
4440mr_user4=FNcrmenu:rfl%=rfl%+maxd%
4450DATA "#Description:,$rfl%(13)"
4460mr_user3=FNcrmenu:rfl%=rfl%+maxd%
4470DATA "#Description:,$rfl%(13)"
4480mr_user2=FNcrmenu:rfl%=rfl%+maxd%
4490DATA "#Description:,$rfl%(13)"
4500mr_user1=FNcrmenu:rfl%=rfl%+maxd%
4510DATA "#Description:,$rfl%(13)"
4520mr_user0=FNcrmenu:rfl%=rfl%+maxd%
4530DATA "#Description:,$rfl%(13)"
4540m_rmflag=FNcrmenu
4550DATA "#Flags,7 Light,6 Visited,5 User (Trans)>mr_user5,4 User (Open)>mr_user4,3 User flag>mr_user3,2 User flag>mr_user2,1 User flag>mr_user1,0 User flag>mr_user0"
4560m_exitf=FNcrmenu
4570DATA "#Flags,7 Invisible exit,6 Closed door,5 Open door,4 Locked door,3 Unlocked door,2 Blocked exit,1 Reserved,0 Reserved"
4580
4590ENDPROC
4600
4610REM ------ Now we have the Procedures and Functions!! ------
4620
4630DEF PROCgetmodeinfo
4640LOCAL x,y,xeig,yeig,cols
4650mode=MODE
4660
4670SYS "OS_ReadModeVariable",mode,1 TO ,,textcols%
4680SYS "OS_ReadModeVariable",mode,2 TO ,,textrows%
4690text_maxllen%=textcols%-2
4700SYS "OS_ReadModeVariable",mode,3 TO ,,cols
4710SYS "OS_ReadModeVariable",mode,4 TO ,,xeig
4720SYS "OS_ReadModeVariable",mode,5 TO ,,yeig
4730SYS "OS_ReadModeVariable",mode,7 TO ,,scrnsize
4740SYS "OS_ReadModeVariable",mode,11 TO ,,x
4750SYS "OS_ReadModeVariable",mode,12 TO ,,y
4760scrw=((x+1)<<xeig)-1:scrh=((y+1)<<yeig)-1
4770ENDPROC
4780
4790DEF PROCclear
4800PROCfill(odata%,(maxobs+1)*o_len,0)
4810PROCfill(rdata%,(maxrms+1)*r_len,0)
4820PROCfill(program%+4,code_size%-20,0)
4830REM PROCfill(initsave,initareasize,0)
4840ENDPROC
4850
4860
4870DEF PROCreturn(x%,y%)
4880PROCcol(128+12):PROCcol(7)
4890PROCcentre(" Hit any key/button to return to the editor ",y%)
4900REPEAT
4910MOUSE X%,Y%,B%
4920UNTIL B%=0
4930
4940REPEAT
4950any=INKEY(0)
4960MOUSE X%,Y%,B%
4970UNTIL any>0 OR B%>0
4980ENDPROC
4990
5000DEF PROCcentre(t$,r)
5010PRINTTAB((textcols%-LEN t$+1) DIV 2,r);t$;
5020ENDPROC
5030
5040REM ------ General window handling routines ------
5050
5060DEF PROCdeletewindow(I%)
5070!q%=handle%(I%)
5080handle%(I%)=handleSP%:handleSP%=I%
5090SYS DeleteW,,q%
5100wident$(I%)=""
5110ENDPROC
5120
5130DEF PROCloadtemplates(tfile$)
5140tmp%=0
5150SYS "Wimp_OpenTemplate",,tfile$
5160tf_index%=0:REPEAT
5170$mb_wident%="*"
5180SYS "Wimp_LoadTemplate",,q%+4,curbuff%,buffer%+maxbuf%,fontcounts%,mb_wident%,tf_index% TO ,,curbuff%,,,,tf_index%
5190IF tf_index%<>0 THEN PROCloadtemp($mb_wident%)
5200UNTIL tf_index%=0
5210SYS "Wimp_CloseTemplate"
5220ENDPROC
5230
5240DEF PROCloadtemp(wident$)
5250I%=FNmatchident(wident$):IF I%<>-1 THEN PROCdeletewindow(I%)
5260q%!68=spritearea% : REM user sprite area
5270PROCcrwindow(q%+4,wident$)
5280ENDPROC
5290
5300DEF PROChighlight(I%)
5310ENDPROC
5320SYS SetCaret,handle%(I%),-1,0,0,&2000000,0
5330ENDPROC
5340
5350DEF PROCretitle(handle%,newtitle$,RETURN handle%)
5360index%=windowindex%
5370REPEAT
5380 index%-=1: IFindex%<0 ERROR 255,"Invalid window"
5390UNTIL handle%(index%)=handle%
5400!q%=handle%
5410SYS GetWI,,q%
5420SYS DeleteW,,q%
5430$(q%+76)=LEFT$(newtitle$,11)
5440SYS CreateW,,q%+4 TO handle%
5450handle%(index%)=handle%
5460ENDPROC
5470
5480DEF PROCcrwindow(q%,wident$)
5490SYS CreateW,,q% TO handle%
5500m%=handleSP%:handleSP%=handle%(handleSP%):handle%(m%)=handle%
5510!q%=handle%
5520SYS GetW,,q%
5530currentwindow%=m%:wident$(m%)=wident$
5540currenticon%=-1
5550PROChighlight(m%)
5560ENDPROC
5570
5580DEF PROCclose(wind)
5590i%=ni%+1
5600CASE wind OF
5610 WHEN objhandle:i%=THEkeyicon:IF icon%(i%)<>-1 PROCstore_obj(optr)
5620 WHEN roomhandle: i%=THEdooricon:IF icon%(i%)<>-1 PROCstore_room(rptr)
5630 WHEN texthandle
5640 i%=texticon
5650 PROCremove_markers
5660 CASE text_owner$ OF
5670 WHEN "texted" : PROCstore_msg
5680 WHEN "program" : IF NOT text_ok THEN PROCstore_prog
5690 WHEN "vocab" : IF NOT text_ok THEN PROCstore_vocab
5700 WHEN "pix" : PROCstore_pix
5710 ENDCASE
5720 IF NOT errflag THEN
5730 text_owner$="":REM release Text Editor window
5740 PROCfill(text_block%,text_blocksize%,dummy_spc)
5750 ENDIF
5760 WHEN design: i%=THEcharicon
5770ENDCASE
5780IF (text_owner$="program" AND errflag AND wind=texthandle) OR (text_owner$="vocab" AND errflag AND wind=texthandle) OR (text_owner$="pix" AND errflag AND wind=texthandle) OR (text_owner$="texted" AND errflag AND wind=texthandle) THEN
5790ELSE
5800 icon%(i%)=-1
5810 !block=wind
5820 SYS CloseW,,block
5830ENDIF
5840ENDPROC
5850
5860DEF PROCopen(handle,x,y,w,d)
5870!block=handle
5880block!4=x:block!8=y-d
5890block!12=x+w:block!16=y
5900block!20=0:block!24=0
5910block!28=-1
5920SYS OpenW,,block
5930ENDPROC
5940
5950DEF PROCredraw(handle)
5960block!0=handle
5970SYS RedrawW,0,block TO more%
5980PROCinfo(block+4)
5990IF handle=texthandle THEN dummy=FNredraw_text(TRUE)
6000ENDPROC
6010
6020DEF PROCforceR(handle)
6030REM Force the given window ONLY to be redrawn
6040PROCgetw(handle)
6050SYS ForceR,handle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%),scy%
6060ENDPROC
6070
6080DEF FNmatchident(A$)
6090IF A$="" THEN =-1
6100LOCAL I%
6110I%=nh%+1:REPEATI%=I%-1:UNTILA$=wident$(I%)ORI%=0
6120IFA$=wident$(I%)THEN=I%ELSE=-1
6130
6140DEF PROCgetw(handle%)
6150IF handle%=iconbar% ENDPROC
6160!block=handle%:SYSGetW,0,block
6170PROCinfo(block+4):bhandle%=block!28:flags%=block!32
6180ontop=flags% AND &20000
6190ENDPROC
6200
6210DEF PROCinfo(b)
6220x0%=!b:y0%=b!4:x1%=b!8:y1%=b!12:scx%=b!16:scy%=b!20
6230bx%=x0%-scx%:by%=y1%-scy%
6240gwxl%=b!24:gwyb%=b!28:gwxr%=b!32:gwyt%=b!36
6250ENDPROC
6260
6270DEF PROCgetpointer
6280SYSGetP,0,block
6290mousex%=!block:mousey%=block!4:b%=block!8:handle%=block!12:icon%=block!16:ob%=block!20
6300ENDPROC
6310
6320DEF PROCsys_claiminputfocus(window%,icon%,xofst%,yofst%,height%,index%)
6330SYSSetCaret, window%,icon%,xofst%,yofst%,height%,index%
6340ENDPROC
6350
6360DEF PROCsys_getcaretposition(RETURN window%,RETURN icon%,RETURN xofst%,RETURN yofst%,RETURN height%,RETURN indx%)
6370SYSGetCaret,0,b
6380window%=!block: icon%=block!4: xofst%=block!8: yofst%=block!12: height%=block!16: indx%=block!20
6390ENDPROC
6400
6410DEF PROCcursor(x%,y%)
6420PROCsys_claiminputfocus(texthandle,-1,(x%-1)*chX%,-y%*lsY%-9*ypixel%,&1000000 OR10*ypixel%,-1)
6430ENDPROC
6440
6450DEF PROCtext_menubox
6460CASE text_owner$ OF
6470WHEN "texted"
6480 tick$="message"
6490 null = FNtick_message
6500 SYS CreateM,0,m_text%,mousex%-64,mousey%:claimmenu$="message"
6510 theLastMenu = m_text%
6520
6530WHEN "program"
6540 tick$="program"
6550 null = FNtick_program
6560 SYS CreateM,0,m_prog%,mousex%-64,mousey%:claimmenu$="program"
6570 theLastMenu = m_prog%
6580
6590WHEN "vocab"
6600 tick$="vocab"
6610 null = FNtick_vocab
6620 SYS CreateM,0,m_vocab%,mousex%-64,mousey%:claimmenu$="vocab"
6630 theLastMenu = m_vocab%
6640
6650ENDCASE
6660
6670ENDPROC
6680
6690DEF PROCcheckmouse(mousex%,mousey%,button%,handle%,icon%,ob%)
6700IFhandle%=-1 THEN ENDPROC
6710PROCgetw(handle%)
6720IFhandle%=ALPSmain THEN
6730 IFicon%<>-1 THEN
6740REM icon% -= firstIconBarIcon%
6750 CASETRUE OF
6760 WHEN(button%AND1)=1 : REM adjust does nothing
6770 WHEN(button%AND2)=2 : void=EVAL("FNmenu_"+iconbar$(icon%))
6780 WHEN(button%AND4)=4 : PROCopenup(icon%)
6790 ENDCASE
6800 ENDIF
6810ELSE
6820 IF handle%=iconbar% THEN
6830 REM The RISC OS icon bar
6840 CASE TRUE OF
6850 WHEN (button%AND2)=2 : void=FNmenu_misc
6860 WHEN (button%AND4)=4
6870 IF icon%=firstIconBarIcon% THEN PROCopen(ALPSmain,400,800,600,600)
6880 ENDCASE
6890 ELSE
6900 index%=windowindex%
6910 REPEAT
6920 index%-=1: IFindex%<0 ERROR 255,"Invalid window"
6930 UNTIL handle%(index%)=handle%
6940 void=EVAL("FNbutton_"+wident$(index%))
6950 ENDIF
6960ENDIF
6970ENDPROC
6980
6990DEF PROCuserkeypressed(handle%,icon%,key%)
7000PROCgetw(handle%)
7010LOCALindex%
7020index%=windowindex%
7030REPEAT
7040index%-=1: IFindex%<0 THEN ENDPROC
7050UNTILhandle%(index%)=handle%
7060void=EVAL("FNkeypress_"+wident$(index%))
7070ENDPROC
7080
7090DEF PROCmenuselect(item0%,item1%)
7100SYS "Wimp_GetPointerInfo",,block
7110buTTon = block!8
7120void=EVAL("FNmenuselect_"+claimmenu$)
7130IF buTTon=1 THEN
7140 REM *** ADJUST pressed so keep the menu structure ***
7150 null = EVAL("FNtick_"+tick$)
7160 SYS CreateM,0,theLastMenu,0,0
7170ELSE
7180 claimmenu$=""
7190ENDIF
7200ENDPROC
7210
7220DEF PROCupdate(handle%,ux0%,uy0%,ux1%,uy1%)
7230!block=handle%:block!4=ux0%:block!8=uy0%:block!12=ux1%:block!16=uy1%
7240SYS UpdateW,0,block TO more%:PROCinfo(block+4)
7250ENDPROC
7260
7270DEF PROCopenup(icon%)
7280IF icon%(icon%)=-1 THEN
7290 IF icon%<>diskicon AND icon%<>texticon AND icon%<>arcicon AND icon%<>swapicon AND icon%<>progicon AND icon%<>vocabicon AND icon%<>eyeicon THEN icon%(icon%)=icon%
7300 CASE icon% OF
7310 WHEN diskicon:
7320 SYS CreateM,0,diskmenu,mousex%-64,mousey%
7330 IF loaded$<>"" THEN f$=path$ ELSE f$="AlpsFile"
7340 PROCchangeicon(savehandle,2,f$,void)
7350 claimmenu$="disk35":theLastMenu=diskmenu:tick$=""
7360 REM WHEN THEmiscicon:
7370 REM *********** do nothing for this icon *******
7380 WHEN texticon:
7390 IF text_owner$="" THEN
7400 PROCretitle(texthandle,"MESSAGES",texthandle)
7410 PROCopen(texthandle,0,1000,scrw,400)
7420 text_owner$="texted":text_ok=TRUE
7430 PROCshow_msg(mptr)
7440 ELSE
7450 VDU 7
7460 ENDIF
7470 WHEN THEdooricon:
7480 PROCopen(handle%(FNmatchident("roomedit")),0,720,1280,1040)
7490 PROCrestore_room(rptr)
7500 WHEN THEkeyicon:
7510 PROCopen(handle%(FNmatchident("objected")),850,560,800,680)
7520 PROCrestore_obj(optr)
7530 WHEN progicon:
7540 IF text_owner$="" THEN
7550 PROCretitle(texthandle,"PROGRAM",texthandle)
7560 PROCopen(texthandle,0,1000,scrw,400)
7570 text_owner$="program":text_ok=TRUE
7580 PROClist(prg_sel%,progval$)
7590 ELSE
7600 VDU 7
7610 ENDIF
7620 WHEN THEcharicon:
7630 PROCopen(handle%(FNmatchident("chrdesign")),0,560,1280,860)
7640 PROCdisplay_chr(cur_chr%)
7650 PROCchangeicon(design,64,CHR$(cur_chr%),dummy)
7660 WHEN vocabicon:
7670 IF text_owner$="" THEN
7680 PROCretitle(texthandle,"VOCABULARY",texthandle)
7690 PROCopen(texthandle,0,1000,scrw,400)
7700 text_owner$="vocab":text_ok=TRUE
7710 PROClist_vocab(voc_sect%)
7720 ELSE
7730 VDU 7
7740 ENDIF
7750 WHEN helpicon:
7760 PROCopen(handle%(FNmatchident("HELP")),0,500,960,400)
7770 WHEN eyeicon:
7780 IF text_owner$="" THEN
7790 PROCretitle(texthandle,"PICTURES",texthandle)
7800 PROCopen(texthandle,0,1000,scrw,400)
7810 text_owner$="pix":text_ok=TRUE
7820 PROClist_pix
7830 ELSE
7840 VDU 7
7850 ENDIF
7860 WHEN arcicon:dummy=FNkeypress_status
7870 WHEN swapicon
7880 datavalid=NOT datavalid:VDU 7:PROCswap_data
7890 IF datavalid THEN
7900 PROCchangeicon(ALPSmain,swapicon,"swap",swapicon)
7910 ELSE
7920 PROCchangeicon(ALPSmain,swapicon,"swap_x",swapicon)
7930 ENDIF
7940 PROCforceR(ALPSmain)
7950 ENDCASE
7960ENDIF
7970ENDPROC
7980
7990
8000REM ------ `button` routines to deal with clicks in given window ------
8010
8020DEF FNbutton_texted
8030LOCALmx%,my%
8040IF button%<>2 THEN
8050PROCgetpointer
8060mx%=(mousex%-bx%+chX%DIV4) AND(NOT(chX%-1))
8070my%=(mousey%-by%) - ((mousey%-by%) MODlsY%)
8080text_col%=1+mx% DIVchX%
8090text_row%=-((mousey%-by%) DIVlsY%)
8100IF text_row%>last_row% text_row%=last_row%
8110IF text_col%>text_rowlen%(text_row%) text_col%=text_rowlen%(text_row%)+1
8120IF text_col%<1 text_col%=1
8130ENDIF
8140
8150CASE button% OF
8160WHEN 2
8170PROCtext_menubox
8180WHEN 4
8190PROClocate_ptr
8200PROCcursor(text_col%,text_row%)
8210WHEN 1
8220IF text_owner$<>"pix" THEN
8230PROClocate_ptr
8240IF mrk<2 THEN
8250mark(mrk)=text_ptr%
8260col(mrk)=text_col%:row(mrk)=text_row%
8270asc(mrk)=?text_ptr%
8280IF asc(mrk)=13 THEN VDU23,dummy_cr ELSE VDU23,chr(mrk)
8290?os_block=asc(mrk)
8300SYS "OS_Word",&A,os_block
8310FOR R%=1 TO 8
8320row_value=R%?os_block
8330VDU row_value EOR &FF
8340NEXT
8350IF asc(mrk)=13 THEN ?text_ptr%=dummy_cr ELSE ?text_ptr%=chr(mrk)
8360PROCupdate(texthandle,chX%*(text_col%-1),-(text_row%+1)*lsY%,chX%*(text_col%-1)+chX%,-(text_row%)*lsY%)
8370dummy=FNredraw_text(TRUE)
8380mrk+=1
8390PROCcursor(text_col%,text_row%)
8400ENDIF
8410ENDIF
8420ENDCASE
8430=0
8440
8450DEF PROClocate_ptr
8460text_ptr%=text_block%
8470IF text_row%>0 THEN
8480 FOR R%=0 TO text_row%-1
8490 text_ptr%+=text_rowlen%(R%)
8500 IF text_rowlen%(R%)<text_maxllen% THEN text_ptr%+=1
8510 NEXT
8520ENDIF
8530text_ptr%+=text_col%-1
8540IF text_ptr%>text_end% THEN text_ptr%=text_end%
8550ENDPROC
8560
8570DEF FNbutton_objected
8580CASE icon% OF
8590WHEN 0:
8600
8610REM First set the 'tick' bits for each menu item
8620null = FNtick_objected
8630SYS CreateM,0,m_objflag,mousex%-64,mousey%:claimmenu$="objected"
8640tick$="objected"
8650theLastMenu = m_objflag
8660
8670WHEN 5:PROCfirst_obj
8680WHEN 6:PROClast_obj
8690WHEN 27:PROCnext_obj
8700WHEN 16:PROCprev_obj
8710WHEN 20:PROCfwd_obj(10)
8720WHEN 21:PROCrewind_obj(10)
8730WHEN 17
8740PROCstore_obj(optr)
8750optr=VAL(FNgeticondata(objhandle,7))
8760IF optr<1 THEN optr=1
8770IF optr>maxobs THEN optr=maxobs
8780PROCrestore_obj(optr)
8790WHEN 22:last_object=optr
8800WHEN 26:
8810SYS CreateM,0,m_contain,mousex%-64,mousey%:claimmenu$="container"
8820tick$=""
8830theLastMenu = m_contain
8840OTHERWISE
8850ENDCASE
8860IF optr>last_object last_object=optr:data_saved=FALSE
8870=0
8880
8890DEF FNbutton_roomedit
8900CASE icon% OF
8910WHEN 1:
8920tick$="roomedit"
8930null = FNtick_roomedit
8940SYS CreateM,0,m_rmflag,mousex%-64,mousey%:claimmenu$="roomedit"
8950theLastMenu = m_rmflag
8960
8970WHEN 5:PROCfirst_room
8980WHEN 6:PROClast_room
8990WHEN 7:PROCnext_room
9000WHEN 8:PROCprev_room
9010WHEN 9:PROCfwd_room(10)
9020WHEN 10:PROCrewind_room(10)
9030WHEN 11
9040PROCstore_room(rptr)
9050rptr=VAL(FNgeticondata(roomhandle,33))
9060IF rptr<1 THEN rptr=1
9070IF rptr>maxrms THEN rptr=maxrms
9080PROCrestore_room(rptr)
9090
9100WHEN 12:last_room=rptr
9110ENDCASE
9120IF rptr>last_room last_room=rptr:data_saved=FALSE
9130
9140REM Now check for clicking menu on selected EXITR icon
9150
9160CASE TRUE OF
9170
9180WHEN icon%>53 AND icon%<70
9190
9200oldrmicon%=icon%
9210null = FNtick_exitedit
9220tick$="exitedit"
9230SYS CreateM,0,m_exitf,mousex%-64,mousey%:claimmenu$="exitedit"
9240theLastMenu = m_exitf
9250OTHERWISE
9260ENDCASE
9270=0
9280
9290DEF FNbutton_chrdesign
9300CASE TRUE OF
9310WHEN icon%>=0 AND icon%<64
9320 PROCset_icon(design,icon%,&50000000,0)
9330 PROCwrite_chr(cur_chr%)
9340 PROCset_icon(design,64,0,0)
9350WHEN icon%=66
9360 cur_chr%+=1
9370 IF cur_chr%>max_chr% cur_chr%=max_chr%
9380 PROCchangeicon(design,64,CHR$(cur_chr%),icon%)
9390 PROCdisplay_chr(cur_chr%)
9400WHEN icon%=67
9410 cur_chr%-=1
9420 IF cur_chr%<32 cur_chr%=32
9430 PROCchangeicon(design,64,CHR$(cur_chr%),icon%)
9440 PROCdisplay_chr(cur_chr%)
9450WHEN icon%=68
9460 SYS CreateM,0,m_chardes%,mousex%-64,mousey%:claimmenu$="chrdef"
9470 theLastMenu = m_chardes%:tick$=""
9480ENDCASE
9490=0
9500
9510
9520DEF FNbutton_info
9530IF icon%=5 THEN
9540PROCclose(infohandle)
9550ENDIF
9560=0
9570
9580DEF FNbutton_saveas
9590CASE icon% OF
9600WHEN 0 : PROCsave_all(FNgeticondata(savehandle,2))
9610WHEN 1 : PROCgetw(savehandle)
9620 dummy$=FNgeticondata(savehandle,1)
9630 block!4=5:block!8=block!8+bx%
9640 block!12=block!12+by%
9650 block!16=block!16+bx%
9660 block!20=block!20+by%
9670 block!24=0:block!28=0:block!32=scrw+1:block!36=scrh+1
9680 SYS "Wimp_DragBox",,block
9690ENDCASE
9700=0
9710
9720DEF FNbutton_Setup
9730CASE icon% OF
9740WHEN 0
9750WHEN 1:PROCcreate_dirs(FNgeticondata(setuph,2),FNgeticondata(setuph,5))
9760ENDCASE
9770PROCclose(setuph)
9780MOUSE RECTANGLE 0,0,scrw,scrh
9790=0
9800
9810REM ------ `keypress` routines deal with pressing key `key%` in a window
9820
9830DEF FNkeypress_texted
9840CASE TRUE OF
9850WHEN key%=13:PROCnewline:data_saved=FALSE:text_ok=FALSE
9860WHEN key%=&18F:PROCup
9870WHEN key%=&18E:PROCdown
9880WHEN key%=&18D:PROCright
9890WHEN key%=&18A:FOR I%=1 TO tab_set:PROCright:NEXT
9900WHEN key%=&19A:FOR I%=1 TO tab_set:PROCleft:NEXT
9910WHEN key%=&18C:PROCleft
9920WHEN key%=&1AB:PROCdelete_line:data_saved=FALSE:text_ok=FALSE
9930WHEN key%=&1ED:PROCinsert_line:data_saved=FALSE:text_ok=FALSE
9940WHEN key%=&1AC:PROCleft_end
9950WHEN key%=&1AD:PROCright_end
9960WHEN key%=&18B:PROCright:PROCdelete_char:data_saved=FALSE:text_ok=FALSE
9970WHEN key%=&1CD:overwrite=NOT overwrite
9980WHEN key%=127:PROCdelete_char:data_saved=FALSE:text_ok=FALSE
9990WHEN (key%>31) AND (key%<126)
10000IF overwrite THEN PROCoverwrite_char(key%) ELSE PROCinsert_char(key%)
10010data_saved=FALSE:text_ok=FALSE
10020OTHERWISE SYS "Wimp_ProcessKey",key%
10030ENDCASE
10040
10050PROCcursor(text_col%,text_row%)
10060=0
10070
10080DEF FNkeypress_saveas
10090IF key%=13 THEN PROCsave_all(FNgeticondata(savehandle,2)) ELSE SYS "Wimp_ProcessKey",key%
10110=0
10120
10130DEF FNkeypress_objected
10140IF key%=13 AND icon%=7 THEN
10150 PROCstore_obj(optr)
10160 optr=VAL(FNgeticondata(objhandle,icon%))
10170 IF optr<1 THEN optr=1
10180 IF optr>maxobs THEN optr=maxobs
10190 PROCrestore_obj(optr)
10200ENDIF
10210
10220CASE key% OF
10230WHEN 13,&18E:REM Return or down arrow
10240IF icon%<15 THEN
10250 icon%+=1
10260ELSE
10270 icon%=7
10280ENDIF
10290WHEN &18F:REM Up arrow
10300IF icon%>7 THEN
10310 icon%-=1
10320ELSE
10330 icon%=15
10340ENDIF
10350OTHERWISE SYS "Wimp_ProcessKey",key%
10360ENDCASE
10370PROCsys_claiminputfocus(objhandle,icon%,0,0,-1,LEN(FNgeticondata(objhandle,icon%)))
10380=0
10390
10400DEF FNkeypress_roomedit
10410CASE key% OF
10420WHEN 13,&18E,&18F
10430
10440IF key%=13 AND icon%=33 THEN
10450 PROCstore_room(rptr)
10460 rptr=VAL(FNgeticondata(roomhandle,icon%))
10470 IF rptr<1 THEN rptr=1
10480 IF rptr>maxrms THEN rptr=maxrms
10490 PROCrestore_room(rptr)
10500ENDIF
10510
10520IF key%=13 OR key%=&18E THEN
10530CASE TRUE OF
10540WHEN icon%=37:newicon%=71
10550WHEN icon%=71:newicon%=38
10560WHEN icon%=69:newicon%=33
10570WHEN icon%<37:newicon%=icon%+1
10580WHEN (icon%>37 AND icon%<54):newicon%=icon%+16
10590WHEN (icon%>53 AND icon%<69):newicon%=icon%-15
10600ENDCASE
10610ENDIF
10620
10630IF key%=&18F THEN
10640CASE TRUE OF
10650WHEN icon%=71:newicon%=37
10660WHEN icon%=38:newicon%=71
10670WHEN icon%=33:newicon%=69
10680WHEN icon%>33:newicon%=icon%-1
10690WHEN (icon%>37 AND icon%<54):newicon%=icon%-16
10700WHEN (icon%>53 AND icon%<69):newicon%=icon%+15
10710ENDCASE
10720ENDIF
10730
10740OTHERWISE SYS "Wimp_ProcessKey",key%
10741ENDCASE
10750PROCsys_claiminputfocus(roomhandle,newicon%,0,0,-1,LEN(FNgeticondata(roomhandle,newicon%)))
10760=0
10770
10780DEF FNkeypress_status
10790PROCcol(128+2)
10800VDU 26,4,12
10810PROCcol(9):PROCcol(128+7)
10820PROCcentre(STRING$(27," ")+"System Status Information"+STRING$(28," "),0)
10830PROCcol(128+2):PROCcol(7)
10840PROCstatus
10850PROCcol(128+7):PROCcol(9)
10860PROCcentre(STRING$(31," ")+"Integer Variables"+STRING$(32," "),10)
10870PROCcol(128+2):PROCcol(7)
10880PROClvar
10890OFF:PROCreturn(18,31):ON
10900VDU 26,5
10910SYS ForceR,-1,0,0,scrw+1,scrh+1
10920=0
10930
10940DEF FNkeypress_chrdef
10950IF key%=13 AND icon%=64 THEN
10960cur_chr%=ASC(FNgeticondata(design,icon%))
10970PROCdisplay_chr(cur_chr%)
10980PROCchangeicon(design,64,CHR$(cur_chr%),icon%)
10981ELSE
10982IF key%<>13 THEN SYS "Wimp_ProcessKey",key%
10983ENDIF
10990=0
11000
11010DEF FNkeypress_Setup
11020IF key%=&18E OR key%=13 AND icon%=2 THEN newicon%=5
11030IF key%=13 AND icon%=5 THEN icon%=1:void=FNbutton_Setup:=0
11040IF key%=&18E AND icon%=5 THEN newicon%=2
11050IF key%=&18F AND icon%=5 THEN newicon%=2
11060IF key%=&18F AND icon%=2 THEN newicon%=5
11061IF key%<>13 AND key%<>&18E AND key%<>&18F THEN SYS "Wimp_ProcessKey",key%
11070PROCsys_claiminputfocus(setuph,newicon%,0,0,-1,LEN(FNgeticondata(setuph,newicon%)))
11080=0
11090
11100REM ------ The `menu` routines to open the selected menu ------
11110
11120DEF FNmenu_
11130=0
11140
11150DEF FNmenu_swap
11160=0
11170
11180DEF FNmenu_arclogo
11190=0
11200
11210DEF FNmenu_info
11220=0
11230
11240
11250DEF FNmenu_disk35
11260SYS CreateM,0,diskmenu,mousex%-64,mousey%
11270IF loaded$<>"" THEN f$=path$ ELSE f$="AlpsFile"
11280PROCchangeicon(savehandle,2,f$,void)
11290theLastMenu= diskmenu
11300claimmenu$="disk35":tick$=""
11310=0
11320
11330
11340DEF FNmenu_key
11350SYS CreateM,0,objmenu,mousex%-64,mousey%
11360theLastMenu = objmenu
11370claimmenu$="key":tick$=""
11380=0
11390
11400DEF FNmenu_door
11410SYS CreateM,0,roommenu,mousex%-64,mousey%
11420theLastMenu = roommenu
11430claimmenu$="door":tick$=""
11440=0
11450
11460DEF FNmenu_quill
11470$end_msg%=STR$(FNmaxmsg)
11480SYS CreateM,0,textmenu,mousex%-64,mousey%
11490theLastMenu = textmenu
11500claimmenu$="quill":tick$=""
11510=0
11520
11530
11540DEF FNmenu_listing
11550SYS CreateM,0,progmenu,mousex%-64,mousey%
11560theLastMenu = progmenu
11570claimmenu$="listing":tick$=""
11580=0
11590
11600
11610DEF FNmenu_chardes
11620=0
11630SYS CreateM,0,charmenu,mousex%-64,mousey%
11640theLastMenu = charmenu
11650claimmenu$="chardes":tick$=""
11660=0
11670
11680DEF FNmenu_vocab
11690SYS CreateM,0,vocabmenu,mousex%-64,mousey%
11700theLastMenu = vocabmenu
11710claimmenu$="vocabulary":tick$=""
11720=0
11730
11740DEF FNmenu_face
11750SYS CreateM,0,facemenu,mousex%-64,mousey%
11760theLastMenu = facemenu
11770claimmenu$="actors":tick$=""
11780=0
11790
11800DEF FNmenu_misc
11810null = FNtick_misc
11820SYS CreateM,0,miscmenu,mousex%-64,FNmenuHeight(miscmenu,1)
11830theLastMenu = miscmenu
11840claimmenu$="misc":tick$="misc"
11850=0
11860
11870DEF FNmenu_help
11880=0
11890
11900
11910DEF FNmenu_eye
11920SYS CreateM,0,pixmenu,mousex%-64,mousey%
11930theLastMenu = pixmenu
11940claimmenu$="eye":tick$=""
11950=0
11960
11970
11980REM `menuselect` functions - called when a selection is made from a menu
11990REM `item0%` is the number of selection from first menu (0,1,2...)
12000REM `item1%` is the number of selection from second menu (0,1,2...)
12010
12020DEF FNmenuselect_
12030=0
12040
12050
12060DEF FNmenuselect_message
12070LOCAL changed_msg
12080
12090CASE item0% OF
12100 WHEN -1
12110 WHEN 0,1:overwrite=NOT overwrite
12120 WHEN 2:PROCcut(mark(0),mark(1),picbuf)
12130 WHEN 3:PROCcopy(mark(0),mark(1),picbuf)
12140 WHEN 4:PROCpaste(text_ptr%,picbuf)
12150 WHEN 5:PROCnext_msg
12160 WHEN 6:PROCprev_msg
12170 WHEN 7:PROCfirst_msg
12180 WHEN 8:PROClast_msg
12190 WHEN 9:PROCgoto_msg(VAL($m_msg%))
12200 WHEN 10
12210 IF item1%>-1 THEN
12220 IF item1%=0 THEN
12230 FOR I%=0 TO maxsw%
12240 switch_vals(I%)=0
12250 NEXT I%
12260 ENDIF
12270 switch_vals(item1%)=VAL($(swdata%+12*(item1%-1)))
12280 IF item1%>switch_vals(0) THEN switch_vals(0)=item1%
12290 REM switch_vals(0) stores the number of switches
12300 ENDIF
12310 WHEN 11
12320 *FX3,10
12330 PROCprint_msg(mptr)
12340 *FX3,0
12350ENDCASE
12360PROCforceR(texthandle)
12370IF changed_msg THEN
12380text_row%=0:text_col%=1
12390PROCcursor(1,0)
12400ENDIF
12410REM claimmenu$=""
12420=0
12430
12440DEF PROCcut(start,end,buf)
12450IF mrk<2 THEN ERROR 1,error$(29)
12460IF end<start THEN SWAP start,end:SWAP col(0),col(1):SWAP row(0),row(1):SWAP asc(0),asc(1)
12470cliplen=end-start+1
12480PROCmove(start,buf,cliplen)
12490REM SYS"Wimp_CloseDown":MODE 12:STOP
12500PROCmove(end+1,start,text_end%-end):REM was +1 until 16.6.89
12510?buf=asc(0):buf?(cliplen-1)=asc(1)
12520text_end%=text_end%-cliplen
12530IF asc(1)=0 THEN text_end%+=1
12540REM Restore end marker if it has been cut
12550IF text_end%<text_block% THEN text_end%=text_block%
12560?text_end%=0
12570last_row%=FNfind_lastrow
12580FOR I%=0 TO last_row%
12590text_rowlen%(I%)=LENFNrow(I%)
12600NEXT
12610mrk=0:mark()=+0
12620IF text_row%>last_row% THEN text_row%=last_row%
12630IF text_col%>text_rowlen%(text_row%) THEN text_col%=text_rowlen%(text_row%)+1
12640PROClocate_ptr:PROCcursor(text_col%,text_row%)
12650data_saved=FALSE:text_ok=FALSE
12660ENDPROC
12670
12680DEF PROCcopy(start,end,buf)
12690IF mrk<2 THEN ERROR 1,error$(29)
12700IF end<start THEN SWAP start,end:SWAP col(0),col(1):SWAP row(0),row(1):SWAP asc(0),asc(1)
12710cliplen=end+1-start
12720PROCmove(start,buf,cliplen)
12730?buf=asc(0):buf?(cliplen-1)=asc(1)
12740?start=asc(0):?end=asc(1):mrk=0:mark()=+0
12750ENDPROC
12760
12770DEF PROCpaste(to,from)
12780IF cliplen=0 THEN ERROR 1,error$(30)
12790PROCmove(to,to+cliplen,text_end%-to+1)
12800PROCmove(from,to,cliplen)
12810text_end%+=cliplen
12820last_row%=FNfind_lastrow
12830FOR I%=0 TO last_row%
12840text_rowlen%(I%)=LENFNrow(I%)
12850NEXT
12860PROClocate_ptr:PROCcursor(text_col%,text_row%)
12870data_saved=FALSE:text_ok=FALSE
12880ENDPROC
12890
12900DEF FNmenuselect_program
12910errflag=FALSE
12920IF item0%>4 AND item0%<9 THEN
12930PROCremove_markers
12940IF NOT text_ok THEN PROCstore_prog
12950prg_sel%=item0%-3
12960text_row%=0:text_col%=1
12970PROCcursor(1,0)
12980ENDIF
12990
13000CASE item0% OF
13010WHEN 0,1:overwrite=NOT overwrite
13020WHEN 2:PROCcut(mark(0),mark(1),picbuf)
13030WHEN 3:PROCcopy(mark(0),mark(1),picbuf)
13040WHEN 4:PROCpaste(text_ptr%,picbuf)
13050WHEN 5:progval$=""
13060WHEN 6:progval$=$proc%
13070WHEN 7:progval$=$def%
13080WHEN 8:progval$=$exit%
13090WHEN 9:PROCprint_prog_seg
13100WHEN 10:PROClisto
13110ENDCASE
13120
13130IF (item0%>4 AND item0%<9) THEN
13140 IF NOT errflag THEN
13150 PROClist(item0%-3,progval$)
13160 PROCforceR(texthandle)
13170 ENDIF
13180ENDIF
13190IF (item0%>1 AND item0%<5) THEN
13200PROCforceR(texthandle)
13210ENDIF
13220IF item0%=10 THEN
13230IF NOT text_ok THEN PROCstore_prog
13240IF NOT errflag THEN
13250text_row%=0:text_col%=1
13260PROCcursor(1,0)
13270PROClist(prg_sel%,progval$)
13280PROCforceR(texthandle)
13290ENDIF
13300ENDIF
13310=0
13320
13330DEF FNmenuselect_vocab
13340REM Make a selection from the vocabulary editor menu
13350CASE item0% OF
13360WHEN 0,1:overwrite=NOT overwrite
13370WHEN 2:PROCcut(mark(0),mark(1),picbuf)
13380WHEN 3:PROCcopy(mark(0),mark(1),picbuf)
13390WHEN 4:PROCpaste(text_ptr%,picbuf)
13400WHEN 5,6,7,8,9,10,11
13410PROCremove_markers:REM Added 23.08.89
13420IF NOT text_ok THEN PROCstore_vocab
13430IF NOT errflag THEN
13440voc_sect%=item0%-4
13450PROClist_vocab(voc_sect%)
13460text_row%=0:text_col%=1
13470PROCcursor(1,0)
13480ENDIF
13490WHEN 12:PROCprint_prog_seg
13500ENDCASE
13510CASE item0% OF
13520WHEN 2,3,4,5,6,7,8,9,10,11
13530PROCforceR(texthandle)
13540ENDCASE
13550REM claimmenu$=""
13560=0
13570
13580DEF FNmenuselect_exitedit
13590xerr%=FALSE
13600IF oldrmicon%<>0 THEN
13610 ptr%=(rdata%+rptr*r_len+oldrmicon%)
13620 flags%=?ptr%
13630 cl_door%=flags% AND &40
13640 op_door%=flags% AND &20
13650 lk_door%=flags% AND &10
13660 unlk_door%=flags% AND &8
13670 IF cl_door% AND item0%=2 THEN xerr%=TRUE
13680 IF op_door% AND item0%=1 THEN xerr%=TRUE
13690 IF op_door% AND item0%=3 THEN xerr%=TRUE
13700 IF unlk_door% AND item0%=3 THEN xerr%=TRUE
13710 IF lk_door% AND item0%=4 THEN xerr%=TRUE
13720 IF lk_door% AND item0%=2 THEN xerr%=TRUE
13730 IF xerr% THEN
13740 VDU 7
13750 ELSE
13760 ?ptr%=?ptr% EOR (&80 >> item0%)
13770 IF NOT lk_door% AND item0%=3 THEN
13780 ?ptr%=?ptr% AND %11011111 OR %01000000
13790 ENDIF
13800 IF lk_door% AND item0%=1 THEN
13810 ?ptr%=?ptr% AND %11101111
13820 ENDIF
13830 ENDIF
13840 data_saved=FALSE
13850ENDIF
13860REM claimmenu$=""
13870=0
13880
13890DEF FNmenuselect_disk35
13900CASE item0% OF
13910 WHEN 0
13920 path$=FNgeticondata(savehandle,2)
13930 SYS "OS_File",5,path$ TO ftype
13940 IF ftype=0 THEN PROCsave_all(path$) ELSE PROCensure(item0%,"This file exists. Do you want to replace it?")
13950 WHEN 1
13960 PROCload_bits(FNgeticondata(setuph,2))
13970 PROCsetup_disk(item0%)
13980ENDCASE
13990icon%(diskicon)=-1:REM claimmenu$=""
14000=0
14010
14020
14030
14040DEF FNmenuselect_objected
14050old_flags%=VAL(FNgeticondata(objhandle,8))
14060new_flags%=old_flags% EOR (&80 >> item0%)
14070PROCchangeicon(objhandle,8,STR$(new_flags%),dummy)
14080REM claimmenu$=""
14090=0
14100
14110DEF FNmenuselect_container
14120CASE item0% OF
14130WHEN 0
14140container=NOT container
14150IF container THEN
14160PROCchangeicon(objhandle,26,"SIZE <C>",dummy)
14170ELSE
14180PROCchangeicon(objhandle,26,"SIZE",dummy)
14190ENDIF
14200WHEN 1
14210cont_room=VAL($controom%)
14220ENDCASE
14230REM data_saved=FALSE
14240REM claimmenu$=""
14250=0
14260
14270DEF FNmenuselect_roomedit
14280old_flags%=VAL(FNgeticondata(roomhandle,34))
14290new_flags%=old_flags% EOR (&80 >> item0%)
14300PROCchangeicon(roomhandle,34,STR$(new_flags%),dummy)
14310REM claimmenu$=""
14320=0
14330
14340DEF FNmenuselect_key
14350CASE item0% OF
14360 WHEN 0:PROCprint_objs
14370 WHEN 1:PROCimport_obj("O."+$import%)
14380ENDCASE
14390REM claimmenu$=""
14400=0
14410
14420DEF FNmenuselect_door
14430CASE item0% OF
14440 WHEN 0:PROCprint_rooms
14450 WHEN 1:PROCimport_rooms("R."+$import%)
14460ENDCASE
14470REM claimmenu$=""
14480=0
14490
14500DEF FNmenuselect_quill
14510CASE item0% OF
14520 WHEN 0:PROCprint_text
14530 WHEN 1:PROCimport_text("T."+$import%)
14540 PROCload_dict("D."+$import%)
14550ENDCASE
14560REM claimmenu$=""
14570=0
14580
14590DEF FNmenuselect_listing
14600CASE item0% OF
14610 WHEN 0:PROCprint_program
14620 WHEN 1:PROCconvert($import%)
14630 WHEN 2:PROCrun
14640ENDCASE
14650REM claimmenu$=""
14660=0
14670
14680DEF FNmenuselect_chardes
14690REM When `menu` is clicked on the `chardes` icon
14700CASE item0% OF
14710WHEN 0:PROCsave_chars("<Users$Resources>."+$filename2%)
14720WHEN 1
14730OSCLI("PRINT <Alps$Resources>."+$filename2%)
14740PROCdisplay_chr(cur_chr%)
14750SYS ForceR,-1,0,0,scrw+1,scrh+1
14760ENDCASE
14770REM claimmenu$=""
14780=0
14790
14800DEF FNmenuselect_chrdef
14810REM When button is clicked on the `SELECT` icon in the char design window
14820chr%=ASC($charnum)
14830IF chr%>31 AND chr%<=max_chr% THEN
14840 cur_chr%=chr%
14850 PROCchangeicon(design,64,CHR$(cur_chr%),icon%)
14860 PROCdisplay_chr(cur_chr%)
14870ENDIF
14880REM claimmenu$=""
14890=0
14900
14910DEF FNmenuselect_vocabulary
14920REM When SELECT pressed in small vocab menu
14930CASE item0% OF
14940WHEN 0:PROCprint_vocab
14950ENDCASE
14960REM claimmenu$=""
14970=0
14980
14990DEF FNmenuselect_actors
15000REM SELECT pressed in small 'face' menu (Actors)
15010CASE item0% OF
15020WHEN 0:PROCprint_actors
15030ENDCASE
15040REM claimmenu$=""
15050=0
15060
15070DEF FNmenuselect_eye
15080REM SELECT pressed in small 'eye' menu (Pictures)
15090CASE item0% OF
15100WHEN 0:PROCprint_pix
15110ENDCASE
15120REM claimmenu$=""
15130=0
15140
15150DEF FNmenuselect_misc
15160CASE item0% OF
15170 WHEN 1: REM quit
15180 PROCquit(4)
15190 ENDCASE
15200icon%(THEmiscicon)=-1
15210=0
15220
15230
15240REM ------ Utility procedures and functions for each editor ------
15250
15260REM ------ Character designer utilities ------
15270
15280DEF PROCwrite_chr(C%)
15290VDU 23,C%
15300FOR row%=0 TO 7
15310row_value=0
15320FOR col%=0 TO 7
15330dummy=VAL(FNgeticondata(design,row%*8+col%))
15340bit=flags% >>> 28
15350IF bit=7 THEN row_value=row_value+2^(7-col%)
15360NEXT col%
15370VDU row_value
15380NEXT row%
15390ENDPROC
15400
15410DEF PROCdisplay_chr(C%)
15420?os_block=C%
15430SYS "OS_Word",&A,os_block
15440FOR R%=1 TO 8
15450row_value=R%?os_block
15460FOR C%=0 TO 7
15470bit=row_value DIV 2^(7-C%)
15480row_value=row_value MOD 2^(7-C%)
15490IF bit>0 PROCset_icon(design,(R%-1)*8+C%,&70000000,&F0000000) ELSE PROCset_icon(design,(R%-1)*8+C%,&20000000,&F0000000)
15500NEXT C%
15510NEXT R%
15520ENDPROC
15530
15540DEF PROCsave_chars(f$)
15550f%=OPENOUT(f$)
15560FOR ch%=32 TO max_chr%
15570BPUT#f%,23:BPUT#f%,ch%
15580?os_block=ch%
15590SYS "OS_Word",&A,os_block
15600FOR I%=1 TO 8
15610BPUT#f%,I%?os_block
15620NEXT I%
15630NEXT ch%
15640CLOSE#f%
15650OSCLI("SETTYPE "+f$+" BBC Font")
15660ENDPROC
15670
15680DEF PROCsave_pal(f$)
15690LOCAL ch%,col1,rgb
15700PROCreadPalette
15710ch%=OPENOUT f$
15720FOR col=0 TO 19
15730FOR rgb=1 TO 3
15740BPUT#ch%,rgb(col,rgb)
15750NEXT rgb
15760NEXT col
15770CLOSE#ch%
15780OSCLI "SETTYPE "+f$+" FED"
15790ENDPROC
15800
15810
15820
15830REM ------ Text editor utilities ------
15840
15850DEF PROCleft
15860IF text_col%<>1 THEN
15870 text_ptr%-=1
15880 text_col%-=1
15890ELSE
15900 IF text_row%<>0 THEN
15910 text_row%-=1
15920 text_col%=text_rowlen%(text_row%)+1
15930 IF text_rowlen%(text_row%)<text_maxllen% THEN text_ptr%-=1
15940 ELSE
15950 VDU 7
15960 ENDIF
15970ENDIF
15980ENDPROC
15990
16000DEF PROCleft_end
16010text_ptr%-=(text_col%-1)
16020text_col%=1
16030ENDPROC
16040
16050DEF PROCright
16060IF text_row%=last_row% AND text_col%=text_rowlen%(text_row%)+1 THEN
16070 VDU 7
16080ELSE
16090 REM This '<' was changed to '<=' on 23.08.89
16100 IF text_col%<=text_maxllen% THEN text_ptr%+=1
16110 text_col%+=1
16120 IF text_col%>text_rowlen%(text_row%)+1 AND text_row%<>last_row% THEN
16130 text_col%=1:text_row%+=1
16140 ENDIF
16150ENDIF
16160ENDPROC
16170
16180DEF PROCright_end
16190text_ptr%+=(text_rowlen%(text_row%)-text_col%)+1
16200text_col%=text_rowlen%(text_row%)+1
16210REM IF text_col%>text_maxllen% text_col%=text_maxllen%
16220ENDPROC
16230
16240DEF PROCdown
16250IF text_row%=text_maxrows% OR text_row%=last_row% THEN
16260 VDU 7
16270ELSE
16280 text_row%+=1
16290 old_col%=text_col%
16300 IF text_rowlen%(text_row%)<text_col% THEN
16310 text_col%=text_rowlen%(text_row%)+1
16320 ENDIF
16330 text_ptr%+=(text_rowlen%(text_row%-1)-old_col%+text_col%)
16340 IF text_rowlen%(text_row%-1)<text_maxllen% text_ptr%+=1
16350ENDIF
16360ENDPROC
16370
16380DEF PROCup
16390IF text_row%<>0 THEN
16400 text_row%-=1
16410 old_col%=text_col%
16420 IF text_rowlen%(text_row%)<text_col% THEN
16430 text_col%=text_rowlen%(text_row%)+1
16440 ENDIF
16450 text_ptr%-=(old_col%+(text_rowlen%(text_row%)-text_col%))
16460 IF text_rowlen%(text_row%)<text_maxllen% text_ptr%-=1
16470ELSE
16480 VDU 7
16490ENDIF
16500ENDPROC
16510
16520DEF PROCnewline
16530old_col%=text_col%
16540PROCinsert_char(13)
16550text_row%+=1
16560text_col%=1
16570PROCupdate(texthandle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%)+chX%,scy%)
16580dummy=FNredraw_text(TRUE)
16590ENDPROC
16600
16610DEF PROCinsert_char(chr%)
16620IF text_ptr%>text_end% THEN FOR I%=text_end% TO text_ptr%:?I%=32:NEXT:text_end%=text_ptr%
16630IF text_ptr%=text_end% OR text_rowlen%(text_row%)<text_maxllen%-1 THEN
16640 redraw_all%=FALSE
16650ELSE
16660 redraw_all%=TRUE
16670ENDIF
16680
16690PROCmove(text_ptr%,text_ptr%+1,text_end%-text_ptr%)
16700IF text_ptr%<mark(0) THEN mark(0)+=1
16710IF text_ptr%<mark(1) THEN mark(1)+=1
16720?text_ptr%=chr%:text_ptr%+=1:text_end%+=1:?text_end%=0
16730
16740IF text_rowlen%(text_row%)<text_maxllen%-1 AND chr%<>13 THEN
16750REM The '-1' above added 29.08.89 to fix bug 8a.
16760text_rowlen%(text_row%)+=1
16770ELSE
16780last_row%=FNfind_lastrow
16790FOR R%=text_row% TO last_row%
16800 text_rowlen%(R%)=LEN FNrow(R%)
16810NEXT
16820ENDIF
16830
16840IF redraw_all% THEN
16850PROCupdate(texthandle,0,-(last_row%+1)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%)*lsY%)
16860ELSE
16870IF text_col%>text_maxllen% THEN
16880PROCupdate(texthandle,0,-(text_row%)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%-1)*lsY%)
16890ELSE
16900PROCupdate(texthandle,chX%*(text_col%-1),-(text_row%+1)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%)*lsY%)
16910ENDIF
16920ENDIF
16930
16940IF text_col%>text_maxllen% THEN
16950text_col%=2:text_row%+=1
16960IF text_row%>last_row% last_row%=text_row%
16970ELSE
16980text_col%+=1
16990IF text_col%>text_maxllen% THEN
17000 text_col%=1:text_row%+=1
17010 IF text_row%>last_row% last_row%=text_row%
17020ENDIF
17030ENDIF
17040
17050dummy=FNredraw_text(redraw_all%)
17060ENDPROC
17070
17080DEF PROCoverwrite_char(chr%)
17090IF text_col%>text_rowlen%(text_row%) THEN PROCinsert_char(chr%):ENDPROC
17100IF text_ptr%=mark(0) THEN SWAP mark(0),mark(1):SWAP asc(0),asc(1):SWAP chr(0),chr(1):mrk-=1:mark(1)=0 ELSE IF text_ptr%=mark(1) THEN mrk-=1:mark(1)=0
17110?text_ptr%=chr%
17120text_ptr%+=1
17130IF text_ptr%>text_end% text_end%=text_ptr%
17140?text_end%=0
17150PROCupdate(texthandle,chX%*(text_col%-1),-(text_row%+1)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%)*lsY%)
17160dummy=FNredraw_text(TRUE)
17170text_col%+=1
17180IF text_col%>text_maxllen% THEN text_col%=1:text_row%+=1
17190
17200last_row%=FNfind_lastrow
17210
17220FOR R%=text_row% TO last_row%
17230 text_rowlen%(R%)=LEN FNrow(R%)
17240NEXT
17250ENDPROC
17260
17270DEF PROCdelete_char
17280IF text_col%=1 AND text_row%=0 VDU 7:ENDPROC
17290IF text_ptr%<mark(0) THEN mark(0)-=1
17300IF text_ptr%<mark(1) THEN mark(1)-=1
17310text_ptr%-=1:text_end%-=1
17320IF text_ptr%=mark(0) THEN SWAP mark(0),mark(1):SWAP asc(0),asc(1):SWAP chr(0),chr(1):mrk-=1:mark(1)=0 ELSE IF text_ptr%=mark(1) THEN mrk-=1:mark(1)=0
17330text_col%-=1:this_row%=text_row%:REM text_rowlen%(text_row%)-=1
17340cr%=FALSE
17350IF text_col%<1 THEN
17360 cr%=TRUE
17370 text_col%=text_rowlen%(text_row%-1)
17380 IF ?text_ptr%=13 text_col%+=1
17390 text_row%-=1
17400ENDIF
17410PROCmove(text_ptr%+1,text_ptr%,text_end%-text_ptr%+1)
17420
17430IF text_rowlen%(this_row%)<text_maxllen% AND NOT cr% THEN
17440text_rowlen%(this_row%)-=1
17450ELSE
17460last_row%=FNfind_lastrow
17470FOR R%=text_row% TO last_row%
17480 text_rowlen%(R%)=LEN FNrow(R%)
17490NEXT
17500ENDIF
17510PROCgetw(texthandle)
17520IF (text_ptr%=text_end% OR text_rowlen%(text_row%)<text_maxllen%-1) AND NOT cr% THEN
17530PROCupdate(texthandle,chX%*(text_col%-1),-(text_row%+1)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%)*lsY%)
17540 C%=text_col%
17550ELSE
17560PROCupdate(texthandle,0,-(last_row%+2)*lsY%,scx%+(x1%-x0%)+chX%,-(text_row%)*lsY%)
17570REM PROCupdate(texthandle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%)+chX%,scy%)
17580ENDIF
17590
17600dummy=FNredraw_text(TRUE)
17610ENDPROC
17620
17630DEF PROCinsert_line
17640IF last_row%=text_maxrows% THEN VDU7:ENDPROC
17650from%=text_ptr%-text_col%+1
17660IF from%<mark(0) THEN mark(0)+=1
17670IF from%<mark(1) THEN mark(1)+=1
17680PROCmove(from%,from%+1,text_end%-from%+1)
17690?from%=13
17700FOR R%=last_row%+1 TO text_row%+1 STEP -1
17710text_rowlen%(R%)=text_rowlen%(R%-1)
17720NEXT
17730text_rowlen%(text_row%)=0
17740text_end%+=1:last_row%+=1
17750text_ptr%-=text_col%-1
17760text_col%=1
17770PROCupdate(texthandle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%)+chX%,scy%-(text_row%)*lsY%)
17780dummy=FNredraw_text(TRUE)
17790ENDPROC
17800
17810DEF PROCdelete_line
17820LOCAL cr%,to%
17830PROCremove_markers
17840next_line%=text_ptr%+text_rowlen%(text_row%)-text_col%+1
17850text_ptr%-=(text_col%-1):to%=text_ptr%
17860IF ?(text_ptr%+text_rowlen%(text_row%))=13 next_line%+=1:cr%=TRUE
17870PROCmove(next_line%,to%,text_end%-next_line%)
17880text_end%-=text_rowlen%(text_row%)
17890IF cr% text_end%-=1
17900IF text_end%<text_block% text_end%=text_block%
17910?text_end%=0
17920text_col%=1
17930last_row%=FNfind_lastrow
17940
17950FOR R%=text_row% TO last_row%
17960 text_rowlen%(R%)=LEN FNrow(R%)
17970NEXT
17980
17990REM PROCupdate(texthandle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%)+chX%,scy%-(text_row%)*lsY%)
18000PROCupdate(texthandle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%)+chX%,scy%)
18010dummy=FNredraw_text(TRUE)
18020ENDPROC
18030
18040DEF PROCinstall_texted
18050text_maxrows%=500
18060text_blocksize%=20000
18070text_original%=TRUE
18080DIM text_rowlen%(text_maxrows%)
18090DIM default_text_block% text_blocksize%+300
18100text_block%=default_text_block%
18110dummy_spc=27:dummy_cr=253
18120VDU23,dummy_spc,0,0,0,0,0,0,0,0
18130VDU23,dummy_cr,0,0,0,0,0,0,0,0
18140text_row%=0
18150text_col%=1
18160last_row%=0
18170text_cur%=TRUE
18180overwrite=FALSE
18190tab_set=5
18200text_ptr%=text_block%
18210text_end%=text_block%
18220?text_block%=0
18230mrk=0:DIM mark(1),row(1),col(1),chr(1),asc(1):chr(0)=254:chr(1)=255:cliplen=0
18240ENDPROC
18250
18260DEF PROCremove_markers
18270LOCAL I%
18280IF mrk>0 THEN
18290mrk-=1
18300FOR I%=0 TO mrk
18310?mark(I%)=asc(I%):mark(I%)=0
18320NEXT
18330mrk=0
18340ENDIF
18350ENDPROC
18360
18370DEF FNfind_lastrow
18380LOCAL A%,B%
18390A%=text_block%:B%=text_end%
18400CALL lastrow
18410=!rowcount
18420
18430DEF FNrow(row%)
18440LOCAL A%,B%
18450A%=text_block%:B%=row%
18460CALL row
18470=$linebuffer
18480
18490
18500REM ------ Object editor utilities ------
18510
18520DEF PROCfirst_obj
18530PROCstore_obj(optr)
18540optr=1
18550PROCrestore_obj(1)
18560ENDPROC
18570
18580DEF PROClast_obj
18590PROCstore_obj(optr)
18600optr=last_object
18610PROCrestore_obj(optr)
18620ENDPROC
18630
18640DEF PROCnext_obj
18650PROCstore_obj(optr)
18660optr+=1
18670IF optr>maxobs optr=maxobs
18680PROCrestore_obj(optr)
18690ENDPROC
18700
18710DEF PROCprev_obj
18720PROCstore_obj(optr)
18730optr-=1
18740IF optr<1 optr=1
18750PROCrestore_obj(optr)
18760ENDPROC
18770
18780DEF PROCfwd_obj(times%)
18790PROCstore_obj(optr)
18800optr+=times%:IF optr>maxobs THEN optr=maxobs
18810PROCrestore_obj(optr)
18820ENDPROC
18830
18840DEF PROCrewind_obj(times%)
18850PROCstore_obj(optr)
18860optr-=times%:IF optr<1 THEN optr=1
18870PROCrestore_obj(optr)
18880ENDPROC
18890
18900DEF PROCstore_obj(o%)
18910REM This reads the object data from the writeable icons in the window
18920REM and stores it in the object data area (odata%...)
18930LOCAL olddata
18940ptr=o%*o_len
18950
18960FOR I%=8 TO 15
18970 icondata=VAL(FNgeticondata(objhandle,I%))
18980 CASE I% OF
18990 WHEN 10,11,12,13
19000 REM The double-byte values
19010 olddata=?(odata%+ptr)+?(odata%+ptr+1)*256
19020 IF icondata<>olddata THEN data_saved=FALSE
19030 ?(odata%+ptr)=icondata MOD 256
19040 ?(odata%+ptr+1)=icondata DIV 256
19050 ptr+=2
19060 WHEN 8,9,14,15
19070 REM The single-byte values
19080 olddata=?(odata%+ptr)
19090 IF olddata<>icondata MOD 256 THEN data_saved=FALSE
19100 ?(odata%+ptr)=icondata MOD 256:ptr+=1
19110 ENDCASE
19120NEXT
19130IF container THEN
19140?(odata%+ptr)=?(odata%+ptr) OR %10000000:ptr+=1:?(odata%+ptr)=cont_room
19150ELSE
19160?(odata%+ptr)=?(odata%+ptr) AND %01111111:ptr+=1:?(odata%+ptr)=0
19170ENDIF
19180ENDPROC
19190
19200DEF PROCrestore_obj(o%)
19210REM This reads the data for object o% from memory and updates the icon
19220REM contents, ensuring the window reflects the new values
19230
19240ptr=o%*o_len
19250PROCchangeicon(objhandle,7,STR$(o%),icon%)
19260FOR I%=8 TO 15
19270 CASE I% OF
19280 WHEN 10,11,12,13:data$=STR$(?(odata%+ptr)+256*?(odata%+ptr+1)):ptr+=2
19290 WHEN 8,9,14,15:data$=STR$(?(odata%+ptr)):ptr+=1
19300 ENDCASE
19310 IF data$="" THEN data$="0"
19320 PROCchangeicon(objhandle,I%,data$,newicon%)
19330NEXT I%
19340
19350store=small_area%:col%=1:row%=0
19360PROCfill(small_area%,small_areasize%,13)
19370print=FALSE
19380PROCpvok(FNfindnoun(o%,void),1,FALSE)
19390PROCchangeicon(objhandle,19,$small_area%,newicon%)
19400IF ((?(odata%+ptr) AND %10000000) DIV 128)>0 THEN container=TRUE ELSE container=FALSE
19410ptr+=1
19420cont_room=?(odata%+ptr):$controom%=STR$(cont_room)
19430IF container PROCchangeicon(objhandle,26,"SIZE <C>",newicon%) ELSE PROCchangeicon(objhandle,26,"SIZE",newicon%)
19440ENDPROC
19450
19460
19470REM ------ Room editor utilities ------
19480
19490DEF PROCfirst_room
19500PROCstore_room(rptr)
19510rptr=1
19520PROCrestore_room(1)
19530ENDPROC
19540
19550DEF PROClast_room
19560PROCstore_room(rptr)
19570rptr=last_room
19580PROCrestore_room(rptr)
19590ENDPROC
19600
19610DEF PROCnext_room
19620PROCstore_room(rptr)
19630rptr+=1
19640IF rptr>maxrms rptr=maxrms
19650PROCrestore_room(rptr)
19660ENDPROC
19670
19680DEF PROCprev_room
19690PROCstore_room(rptr)
19700rptr-=1
19710IF rptr<1 rptr=1
19720PROCrestore_room(rptr)
19730ENDPROC
19740
19750DEF PROCfwd_room(times%)
19760PROCstore_room(rptr)
19770rptr+=times%:IF rptr>maxrms THEN rptr=maxrms
19780PROCrestore_room(rptr)
19790ENDPROC
19800
19810DEF PROCrewind_room(times%)
19820PROCstore_room(rptr)
19830rptr-=times%:IF rptr<1 THEN rptr=1
19840PROCrestore_room(rptr)
19850ENDPROC
19860
19870DEF PROCstore_room(r%)
19880ptr=r%*r_len
19890FOR I%=34 TO 69
19900 icondata=VAL(FNgeticondata(roomhandle,I%))
19910 CASE TRUE OF
19920 WHEN I%>35 AND I%<54
19930 olddata=?(rdata%+ptr)+?(rdata%+ptr+1)*256
19940 IF icondata<>olddata THEN data_saved=FALSE
19950 ?(rdata%+ptr)=icondata MOD 256
19960 ?(rdata%+ptr+1)=icondata DIV 256
19970 ptr+=2
19980 WHEN I%<36 OR I%>53
19990 olddata=?(rdata%+ptr)
20000 IF olddata<>icondata MOD 256 THEN data_saved=FALSE
20010 ?(rdata%+ptr)=icondata MOD 256
20020 ptr+=1
20030 ENDCASE
20040NEXT I%
20050icondata=VAL(FNgeticondata(roomhandle,71))
20060?(rdata%+ptr+16)=icondata MOD 256
20070?(rdata%+ptr+17)=icondata DIV 256
20080ENDPROC
20090
20100DEF PROCrestore_room(r%)
20110ptr=r%*r_len
20120PROCchangeicon(roomhandle,33,STR$(r%),icon%)
20130FOR I%=34 TO 69
20140 CASE TRUE OF
20150 WHEN I%>35 AND I%<54
20160 data$=STR$(?(rdata%+ptr)+256*?(rdata%+ptr+1)):ptr+=2
20170 WHEN I%<36 OR I%>53
20180 data$=STR$(?(rdata%+ptr)):ptr+=1
20190 ENDCASE
20200 IF data$="" THEN data$="0"
20210 PROCchangeicon(roomhandle,I%,data$,newicon%)
20220NEXT I%
20230data$=STR$(?(rdata%+ptr+16)+256*?(rdata%+ptr+17))
20240IF data$="" THEN data$="0"
20250PROCchangeicon(roomhandle,71,data$,newicon%)
20260ENDPROC
20270
20280
20290REM ------ Message editor utilities ------
20300
20310DEF PROCstore_msg
20320errflag=FALSE:PROCremove_markers
20330newlen=text_end%-text_block%
20340diff=newlen-oldlen
20350IF diff+text%!2>maxtext% THEN
20360 PROCerror(13,error$(36))
20370 errflag=TRUE
20380ELSE
20390 to=mstart+newlen-1
20400 from=mend-1
20410 text_end%=text_block%:text_ptr%=text_block%
20420 bytes_to_move=FNtext_end-mend+1
20430 PROCmove(from,to,bytes_to_move)
20440 PROCmove(text_block%,mstart,newlen)
20450 PROCincmsglen(diff)
20460 ns%=switch_vals(0)
20470 IF ns%>0 THEN
20480 ?switch_buf%=ns%:ptr%=1
20490 FOR I%=1 TO ns%
20500 switch_buf%?ptr%=switch_vals(I%)
20510 switch_buf%?(ptr%+1)=switch_vals(I%) DIV 256
20520 ptr%+=2
20530 NEXT
20540 ELSE
20550 PROCfill(switch_buf%,maxsw%*2+1,0)
20560 ENDIF
20570 PROCmove(mstart,swloc+2*ns%+1,FNtext_end-mstart)
20580 PROCmove(switch_buf%,swloc,2*ns%+1)
20590 PROCincmsglen(2*ns%-2*oldsw)
20600ENDIF
20610ENDPROC
20620
20630DEF PROCincmsglen(bytes_to_add)
20640text%!2=text%!2+bytes_to_add
20650ENDPROC
20660
20670DEF FNtext_end
20680=text%+text%!2
20690
20700DEF FNmaxmsg
20710=?text%+256*text%?1
20720
20730DEF PROCincmaxmsg
20740?text%+=1:IF ?text%=0 ?(text%+1)+=1
20750ENDPROC
20760
20770DEF PROCshow_msg(ms%)
20780IF ms%>FNmaxmsg THEN ERROR 4,error$(31)
20790IF ms%<1 ENDPROC
20800PROCfill(text_block%,text_blocksize%,dummy_spc)
20810text_rowlen%()=+0:switch_vals()=+0
20820changed_msg=TRUE
20830A%=ms%:C%=text%+7:ptr%=USR findmsg
20840chr%=?ptr%:ptr%+=1
20850switch_vals(0)=chr%:oldsw=chr%:swloc=ptr%-1
20860IF chr%>0 THEN
20870 FOR I%=1 TO chr%
20880 switch_vals(I%)=?ptr%+256*ptr%?1
20890 ptr%+=2
20900 NEXT
20910ENDIF
20920mstart=ptr%
20930chr%=?ptr%
20940row%=0:text_ptr%=text_block%
20950WHILE chr%>0
20960 col%=1:line$=""
20970 WHILE chr%<>13 AND chr%<>0 AND col%<=text_maxllen%
20980 IF chr%>&7F THEN
20990 tokptr=chr%-&7F
21000 line$+=tok$(tokptr):L%=LEN tok$(tokptr)
21010 FOR I%=1 TO L%
21020 ?(text_ptr%+I%-1)=ASC(MID$(tok$(tokptr),I%,1))
21030 NEXT
21040 text_ptr%+=(L%-1)
21050 ELSE
21060 ?text_ptr%=chr%:line$+=CHR$ chr%
21070 ENDIF
21080 ptr%+=1:text_ptr%+=1:chr%=?ptr%:col%+=1
21090 ENDWHILE
21100 text_rowlen%(row%)=LEN line$
21110 IF col%>text_maxllen% OR chr%=13 row%+=1:col%=1
21120 IF chr%=13 ?text_ptr%=13:text_ptr%+=1:ptr%+=1
21130 chr%=?ptr%:REM ptr%+=1
21140ENDWHILE
21150mend=ptr%:?text_ptr%=chr%
21160text_end%=text_ptr%
21170oldlen=mend-mstart
21180IF oldlen<0 oldlen=0
21190text_ptr%=text_block%
21200last_row%=FNfind_lastrow
21210FOR I%=0 TO last_row%:text_rowlen%(I%)=LEN FNrow(I%):NEXT
21220ENDPROC
21230
21240DEF PROCnext_msg
21250mptr+=1
21260PROCstore_msg:REM save this one first
21270IF mptr>FNmaxmsg THEN ptr=FNtext_end:ptr?0=0:ptr?1=0:PROCincmaxmsg:PROCincmsglen(2)
21280PROCshow_msg(mptr):REM Now load the next one into `texted`
21290ENDPROC
21300
21310DEF PROCprev_msg
21320IF mptr>1 THEN
21330mptr-=1
21340PROCstore_msg
21350PROCshow_msg(mptr)
21360ENDIF
21370ENDPROC
21380
21390DEF PROCgoto_msg(ms%)
21400IF ms%>FNmaxmsg ms%=FNmaxmsg:VDU 7
21410IF ms%<1 ms%=1:VDU 7
21420PROCstore_msg
21430PROCshow_msg(ms%)
21440mptr=ms%
21450ENDPROC
21460
21470DEF PROClast_msg
21480PROCstore_msg
21490mptr=FNmaxmsg
21500PROCshow_msg(mptr)
21510ENDPROC
21520
21530DEF PROCfirst_msg
21540PROCstore_msg
21550mptr=1
21560PROCshow_msg(mptr)
21570ENDPROC
21580
21590
21600REM ------ Program Editor utilities ------
21610
21620DEF PROCstore_prog
21630LOCAL sp_ptr%,line$,chr%
21640REM Use `hourglass` pointer
21650SYS "Hourglass_On"
21660errflag=FALSE:PROCremove_markers
21670sp_ptr%=text_block%
21680chr%=?sp_ptr%
21690prgptr=prgbuf%
21700WHILE sp_ptr%<text_end% AND NOT errflag
21710 line$=""
21720 WHILE (chr%<>13) AND (chr%<>0) AND (chr%<>dummy_spc)
21730 chr%=?sp_ptr%
21740 sp_ptr%+=1
21750 line$+=CHR$(chr%)
21760 ENDWHILE
21770 PROCscan
21780 chr%=?sp_ptr%
21790 WHILE (chr%=13 OR chr%=dummy_spc OR chr%=0) AND (sp_ptr%<text_end%)
21800 sp_ptr%+=1:chr%=?sp_ptr%
21810 ENDWHILE
21820ENDWHILE
21830IF NOT errflag THEN
21840 oldlen%=prgend-pstart:IF oldlen%<>0 oldlen%+=1
21850 bytes_to_move=FNprglen-oldlen%
21860 PROCincprglen(-oldlen%)
21870 newlen%=prgptr-prgbuf%
21880 REM This check for 'No room' was added 2.6.89
21890 IF FNprglen+newlen%>code_size%-4 THEN
21900 PROCincprglen(oldlen%)
21910 PROCerror(13,error$(35))
21920 ELSE
21930 PROCmove(prgend+1,pstart+newlen%,bytes_to_move)
21940 PROCmove(prgbuf%,pstart,newlen%)
21950 PROCincprglen(newlen%)
21960 ?(program%+4+FNprglen)=0:REM restore end of program marker (9/4/89)
21970 text_ok=TRUE
21980 ENDIF
21990ENDIF
22000SYS "Hourglass_Off"
22010ENDPROC
22020
22030DEF FNprglen
22040=!program%
22050
22060DEF PROCincprglen(bytes)
22070!program%=!program%+bytes
22080ENDPROC
22090
22100
22110REM ------ Window `redraw` functions ------
22120
22130
22140DEF FNredraw_text(flag%)
22150REM flag%=TRUE -> redraw WHOLE text window
22160REM else only redraw from the cursor line
22170
22180WHILE more%
22190BR%=(by%-block!32-ypixel%) DIV lsY%
22200IF BR%>last_row% BR%=last_row%
22210TR%=(by%-block!40-ypixel%) DIV lsY%
22220IF TR%>last_row% TR%=last_row%
22230ptr_end%=BR%*text_maxllen%+text_block%
22240CLG
22250FOR I%=TR% TO BR%
22260 MOVE bx%,by%-lsY%*I%-ypixel%
22270 PRINT FNrow(I%);
22280NEXT
22290SYSGetR,0,block TO more%
22300ENDWHILE
22310=0
22320
22330
22340REM ------ General icon handling routines ------
22350
22360DEF PROCht(handle%,icon%,fl$,fc%,bc%)
22370LOCALmask%
22380IFfl$="*"THENfl%=0:mask%=&FF000000 ELSEfl%=EVALfl$:mask%=-1
22390!block=handle%:block!4=icon%:block!8=fl%:block?11=fc%+(bc%<<4):block!12=mask%:SYS SetI,0,block
22400ENDPROC
22410
22420DEF FNgeticondata(handle%,icon%)
22430!block=handle%:block!4=icon%
22440SYS GetI,0,block
22450flags%=block!24
22460IF (flags% AND 256)<>0 THEN data$=$(!(block+28)) ELSE data$=$(block+28)
22470=data$
22480
22490DEF PROCchangeicon(handle%,icon%,new$,RETURN icon%)
22500LOCAL J%
22510dummy$=FNgeticondata(handle%,icon%)
22520IF (flags% AND 256)<>0 THEN $(!(block+28))=new$ ELSE $(block+28)=new$
22530SYS DeleteI,0,block
22540FOR J%=4 TO 28 STEP 4
22550 block!J%=block!(J%+4)
22560NEXT J%
22570!block=handle%:SYS CreateI,0,block TO icon%
22580PROCset_icon(handle%,icon%,0,0):REM ensure it appears updated on screen
22590ENDPROC
22600
22610DEF PROCset_icon(handle%,icon%,eor%,mask%)
22620!block=handle%:block!4=icon%:block!8=eor%:block!12=mask%
22630SYS SetI,0,block
22640ENDPROC
22650
22660
22670REM ------ Menu creation procedures ------
22680
22690REM **** onIconBar = 1 if yes, otherwise 0 **********
22700DEF FNmenuHeight(theMenu%, onIconBar%)
22710= ((96 * onIconBar%) + (theMenu%?30 * 44) + (theMenu%?31 * 24))
22720
22730
22740DEF FNcrmenu
22750IF menufree%+28 > menuend% THEN ERROR 1,error$(32)
22760LOCAL m%,menu$:READ menu$
22770
22780
22790REM ************** the bodge to store the menu height ****************
22800LOCAL menuHiAddr%
22810menuHiAddr% = menufree% + 28 + 2 :REM 2nd last byte in 1st menuitem flags
22820menuItemNum% = 0
22830dashItemNum% = 0
22840
22850
22860IF LEFT$(menu$,1)="=" THEN menu$=EVALMID$(menu$,2)
22870menuptr%=menufree%
22880i%=0:ctr%=0
22890IF LEFT$(menu$,1)="#" THEN i%=1:menutitle$=FNpar(",") ELSE menutitle$=""
22900I%=INSTR(menutitle$,">")
22910IF I%>0 THEN
22920 menuptr%!20=EVAL(MID$(menutitle$,I%+1))
22930 menutitle$=LEFT$(menutitle$,I%-1)
22940ELSE menuptr%!20=44
22950ENDIF
22960$menuptr%=menutitle$
22970menuptr%?12=`tfcol:menuptr%?13=`tbcol:menuptr%?14=`wfcol:menuptr%?15=`wbcol
22980menuptr%!16=196-24:menuptr%!24=0
22990menuptr%+=28:maxx%=LENmenutitle$-3
23000WHILE RIGHT$(menu$,1)="~"
23010 menu$=LEFT$(menu$,LENmenu$-1)
23020 REPEAT item$=FNpar(","):PROCmenuitem(item$):UNTIL item$=""
23030 READ menu$
23040ENDWHILE
23050REPEAT item$=FNpar(","):PROCmenuitem(item$):UNTIL item$=""
23060menuptr%!-24=(menuptr%!-24)OR&80
23070m%=menufree%:m%!16=(maxx%*8+6)*dx%
23080menufree%=menuptr%
23090?menuHiAddr% = menuItemNum% : REM the number of items
23100?(menuHiAddr% +1) = dashItemNum% : REM the number of dashes
23110=m%
23120
23130DEF PROCmenuitem(text$)
23140IF text$="" THEN ENDPROC
23150IF menuptr%+24 > menuend% THEN ERROR 1,error$(32)
23160IF text$="&" THEN
23170 SYS "Font_ListFonts",,q%,ctr% TO ,,ctr%
23180 IF ctr%>=0 THEN text$=$q%+">m_fsize%":i%-=2 ELSE ENDPROC
23190ENDIF
23200LOCALi%,flg%
23210
23220menuItemNum% += 1
23230
23240flg%=&00
23250i%=INSTR(text$,">")
23260IFi%>0THENsubptr%=EVALMID$(text$,i%+1):text$=LEFT$(text$,i%-1)ELSEsubptr%=-1
23270IF RIGHT$(text$,1)="#" THEN text$=LEFT$(text$,LENtext$-1):flg%+=&02:dashItemNum% += 1
23280menuptr%!0=flg%
23290menuptr%!4=subptr%
23300menuptr%!8=&07000021
23310IF LEFT$(text$,1)="?" THEN
23320 menuptr%!8=&0700011A
23330 I%=FNworkspace(LENtext$):$I%=MID$(text$,2)
23340 menuptr%!12=I%:menuptr%!16=systemsprites%:menuptr%!20=LENtext$
23350ELSE
23360 IF LEFT$(text$,1)="$" THEN
23370 !menuptr%+=&04
23380 menuptr%!8+=&100
23390 i%=INSTR(text$,"(")
23400 IFi%>0THENL%=VALMID$(text$,i%+1):text$=LEFT$(text$,i%-1)ELSEL%=12
23410 menuptr%!12=EVAL(MID$(text$,2)):menuptr%!16=-1:menuptr%!20=L%
23420 text$=STRING$(L%," ")
23430 ELSE
23440 IFLENtext$<=12THEN
23450 $(menuptr%+12)=text$
23460 ELSE I%=FNworkspace(LENtext$+1):$I%=text$
23470 menuptr%!12=I%:menuptr%!16=-1:menuptr%!20=LENtext$+1
23480 menuptr%!8=menuptr%!8 OR &100
23490 ENDIF
23500 ENDIF
23510 IFLENtext$>maxx%THENmaxx%=LENtext$
23520ENDIF
23530menuptr%+=24
23540ENDPROC
23550
23560DEF FNpar(sep$)
23570i1%=i%+1:i%=INSTR(menu$+sep$,sep$,i1%)
23580=MID$(menu$,i1%,i%-i1%)
23590
23600DEF FNworkspace(L%)
23610IF curbuff%+L%>buffer%+maxbuf% THEN ERROR 1,error$(33)
23620curbuff%+=L%:=curbuff%-L%
23630
23640
23650REM ------ Procedures to interface with ARM code ------
23660
23670DEF PROCmove(from,to,bytes_to_move)
23680IF bytes_to_move=0 THEN ENDPROC
23690A%=from:B%=to:C%=bytes_to_move
23700CALL move
23710ENDPROC
23720
23730DEF PROCfill(start,bytes,filler)
23740A%=start:B%=bytes:C%=filler
23750CALLfill
23760ENDPROC
23770
23780
23790REM ------ ARM source code ------
23800
23810DEF PROCassemble(addr%)
23820LOCAL pass
23830sp=13:link=14
23840FOR pass=0 TO 2 STEP 2
23850P%=addr%
23860[OPT pass
23870.fill b fill2
23880.move b blockmove
23890
23900.fill2
23910\ r0=start address r1=number of bytes r2=value to fill with
23920\ all registers are preserved
23930stmfd (sp)!,{r0-r3,link}
23940mov r3,r0
23950add r3,r3,r1
23960.fillloop
23970strb r2,[r0],#1
23980cmp r0,r3
23990blt fillloop
24000ldmfd (sp)!,{r0-r3,PC}
24010
24020\ General purpose block move routine (up or down and overlapping)
24030\ r0 = `from` address, r1 = `to` address, r2 = number of bytes to move
24040.blockmove
24050cmp r0,r1
24060blt moveup
24070bal movedown
24080
24090.movedown
24100\ Move memory block down
24110\ r0 = `from` address, r1= `to` address, r2 = number of bytes to move
24120stmfd (sp)!,{r0-r3,link}
24130
24140.movdloop
24150ldrb r3,[r0],#1
24160strb r3,[r1],#1
24170subs r2,r2,#1
24180bne movdloop
24190
24200ldmfd (sp)!,{r0-r3,PC}
24210
24220.moveup
24230\ Move memory block up
24240\ r0 = `from` address, r1= `to` address, r2 = number of bytes to move
24250
24260stmfd (sp)!,{r0-r3,link}
24270sub r2,r2,#1
24280add r0,r0,r2
24290add r1,r1,r2
24300\ Call here if r2 = end address
24310.moveuploop
24320ldrb r3,[r0],#-1
24330strb r3,[r1],#-1
24340subs r2,r2,#1
24350bpl moveuploop
24360ldmfd (sp)!,{r0-r3,PC}
24370
24380.lastrow
24390\ Find last row of text
24400\ Entry - r0 = start address of text (text_block%)
24410\ r1 = end address of text (text_end%)
24420\ Exit - number of last row is in 'rowcount' (rows numbered 0,1,2...)
24430stmfd (sp)!,{r0-r4,link}
24440mov r2,#0
24450mov r3,#0
24460mov r4,#0
24470
24480.while
24490cmp r0,r1
24500beq endwhile
24510ldrb r3,[r0],#1
24520add r4,r4,#1
24530cmp r4,#text_maxllen%
24540addeq r2,r2,#1
24550moveq r4,#0
24560beq while
24570cmp r3,#13
24580addeq r2,r2,#1
24590moveq r4,#0
24600cmp r3,#dummy_cr
24610addeq r2,r2,#1
24620moveq r4,#0
24630bal while
24640
24650.endwhile
24660str r2,rowcount
24670ldmfd (sp)!,{r0-r4,PC}
24680
24690.rowcount EQUD 0
24700
24710.row
24720\ Returns the string of text in the specified row of the text block
24730\ Entry - r0 = start address of text (text_block%)
24740\ r1 = row wanted (0,1,2...)
24750\ Exit - the string is returned in 'linebuffer', terminated by <cr>
24760\ r2 is the current row
24770\ r3 is the current character
24780\ r4 is the length of the current row
24790
24800stmfd (sp)!,{r0-r4,link}
24810mov r2,#0
24820mov r4,#0
24830
24840.while2
24850cmp r2,r1
24860beq endwhile2
24870ldrb r3,[r0],#1
24880add r4,r4,#1
24890cmp r4,#text_maxllen%
24900moveq r4,#0
24910addeq r2,r2,#1
24920beq while2
24930cmp r3,#13
24940moveq r4,#0
24950addeq r2,r2,#1
24960cmp r3,#dummy_cr
24970moveq r4,#0
24980addeq r2,r2,#1
24990bal while2
25000
25010.endwhile2
25020adr r1,linebuffer
25030mov r4,#0
25040
25050.strloop
25060ldrb r3,[r0],#1
25070add r4,r4,#1
25080cmp r3,#0
25090beq lineend
25100cmp r3,#dummy_spc
25110beq lineend
25120cmp r3,#13
25130beq lineend
25140cmp r3,#dummy_cr
25150streqb r3,[r1],#1
25160beq lineend
25170strb r3,[r1],#1
25180cmp r4,#text_maxllen%
25190bne strloop
25200
25210.lineend
25220cmp r3,#0
25230moveq r3,#13
25240cmp r3,#dummy_spc
25250moveq r3,#13
25260cmp r3,#dummy_cr
25270moveq r3,#13
25280cmp r4,#text_maxllen%
25290moveq r3,#13
25300strb r3,[r1],#1
25310ldmfd (sp)!,{r0-r4,PC}
25320
25330.linebuffer EQUS STRING$(text_maxllen%+1,CHR$ dummy_spc)
25340 align
25350
25360.findmsg
25370\Finds start of specified message
25380\Entry - r0 = message number
25390\ - r2 = text start address (MSG#0)
25400\Exit - r0 = start address of message (switches)
25410stmfd (sp)!,{r1-r3,link}
25420cmp r0,#0
25430beq startm
25440
25450.nxtmsg
25460ldrb r1,[r2],#1
25470add r2,r2,r1, lsl #1 \ r2 = r2 + r1*2
25480
25490.readch
25500ldrb r1,[r2],#1
25510cmp r1,#0
25520bne readch
25530subs r0,r0,#1
25540bne nxtmsg
25550
25560.startm
25570mov r0,r2
25580ldmfd (sp)!,{r1-r3,pc}
25590
25600.pvok
25610;Print Verb, Object or Keyword (returns the word string)
25620;Entry - r0 = Number of word to print
25630; r1 = address of required word table
25640;Exit - word is in 'atext' terminated by <cr>
25650stmfd (sp)!,{r0-r5,link}
25660mov r3,r0 \Word number is now in r3
25670mov r4,r2 \r4 is 'all' flag
25680mov r5,#0 \r5 is 'ctr'
25690
25700.LLL1
25710adr r2,atext \r2 points to 'atext'
25720
25730.LLL2
25740ldrb r0,[r1] \Get character from list
25750\orr r0,r0,#32 \Convert to lower case
25760strb r0,[r2] \Put it in 'text'
25770tst r0,#&80 \Is bit 7 set (end of the word)
25780bne endofw \Yes
25790add r2,r2,#1
25800add r1,r1,#1
25810b LLL2
25820
25830.endofw
25840cmp r0,#&FF
25850adreq r2,pvokflag
25860streqb r0,[r2]
25870beq endtbl
25880and r0,r0,#%01111111 ;Clear bit 7
25890strb r0,[r2],#1
25900mov r0,#13
25910strb r0,[r2]
25920add r1,r1,#1
25930ldrb r0,[r1] ;Get the verb/object number from table
25940add r1,r1,#1 ;Skip the number
25950cmp r0,r3 ;Is it the one we want?
25960bne LLL1 ;No - try the next one
25970
25980.endtbl
25990adr r2,address
26000str r1,[r2]
26010ldmfd (sp)!,{r0-r5,pc}
26020
26030.atext EQUS STRING$(80,"*")
26040align
26050.address equd 0
26060.pvokflag equb 0
26070align
26080]
26090NEXT pass
26100ENDPROC
26110
26120
26130REM ------ Some general utility routines ------
26140
26150DEF PROCErrorMsgRead
26160in%=OPENIN("<Alps$Resources>.Errormsgs")
26170INPUT#in%,errors
26180DIM error$(errors)
26190FOR error=0 TO errors-1
26200 INPUT#in%,error$(error)
26210NEXT error
26220CLOSE#in%
26230ENDPROC
26240
26250DEF PROCKeyWordRead
26260REM Reads file of keywords/info bytes
26270REM Keywords are in alphabetical order
26280LOCAL CHN%,I%,J%
26290first_token=&60
26300maxmsg=65535:maxobn=255:maxvbn=255:maxconst=65535
26310chn%=OPENIN "<Alps$Resources>.keywrdlist"
26320INPUT#chn%,keywords
26330DIM keyword$(keywords),info%(keywords,5)
26340
26350REM Set up keyword tables
26360REM keyword$ | token | type/No. params | Max values param 1,2,3 |
26370REM type/No. params gives number of parameters and bit 7 is set if its
26380REM a function, bit 6 set for object keywords, bit 5 for verb keywords
26390
26400FOR I%=1 TO keywords
26410INPUT#chn%,keyword$(I%)
26420FOR J%=0 TO 5
26430INPUT#chn%,info%(I%,J%)
26440NEXT J%
26450NEXT I%
26460CLOSE#chn%
26470
26480FOR I%=1 TO keywords
26490params=info%(info%(I%,2),1) AND %00011111
26500bytes=0
26510IF params>0 THEN
26520FOR K%=3 TO 5
26530maxval=info%(info%(I%,2),K%)
26540IF maxval<256 AND maxval>0 THEN bytes+=1
26550IF maxval>255 AND maxval<65536 THEN bytes+=2
26560IF maxval>65535 THEN bytes+=3
26570NEXT K%
26580ENDIF
26590parambyte=info%(info%(I%,2),1) AND %10000000
26600pbytes?(I%-1)=bytes OR parambyte
26610NEXT
26620ENDPROC
26630
26640
26650REM ------ Printing procedures ------
26660
26670DEF PROCprint_prog_seg
26680LOCAL R%
26690LOCAL ERROR
26700ON ERROR LOCAL:OSCLI("FX3,0"):SYS "Hourglass_Off":ENDPROC
26710*FX3,10
26720FOR R%=0 TO last_row%
26730 PRINT FNrow(R%)
26740NEXT R%
26750*FX3,0
26760ENDPROC
26770
26780DEF PROCprint_program
26790LOCAL ERROR
26800ON ERROR LOCAL:OSCLI("FX3,0"):SYS "Hourglass_Off":ENDPROC
26810PROClist(1,"")
26820ENDPROC
26830
26840DEF PROCprint_text
26850LOCAL st%,end%,M%
26860LOCAL ERROR
26870ON ERROR LOCAL:OSCLI("FX3,0"):SYS "Hourglass_Off":ENDPROC
26880PROCclose(texthandle)
26890*FX3,10
26900st%=VAL $st_msg%
26910end%=VAL $end_msg%
26920IF end%>FNmaxmsg end%=FNmaxmsg
26930FOR M%=st% TO end%
26940 PROCshow_msg(M%)
26950 PROCprint_msg(M%)
26960NEXT M%
26970*FX3,0
26980ENDPROC
26990
27000DEF PROCprint_msg(M%)
27010LOCAL S%,R%
27020PRINT"Message: ";M%;" Switches: ";
27030IF switch_vals(0)=0 THEN
27040 PRINT"None";
27050ELSE
27060 FOR S%=1 TO switch_vals(0)
27070 PRINT"<";switch_vals(S%);">";
27080 NEXT
27090ENDIF
27100PRINT
27110FOR R%=0 TO last_row%
27120 PRINT FNrow(R%)
27130NEXT R%
27140PRINT STRING$(text_maxllen%,"-")
27150ENDPROC
27160
27170DEF PROCprint_objs
27180LOCAL O%,F%,I%,ptr%
27190*FX3,10
27200VDU condensed
27210PRINTpline$
27220PROCprint_flags(o_flags%)
27230PRINTpline$
27240PRINT"Obj Noun Flags 7 6 5 4 3 2 1 0 State Start Describe Short Examine Weight Size Cont. 'Store' Trans. Open"
27250PRINTpline$
27260FOR O%=1 TO last_object
27270PRINT;O%;
27280store=small_area%:col%=1:row%=0
27290PROCfill(small_area%,small_areasize%,13)
27300print=FALSE
27310PROCpvok(FNfindnoun(O%,void),1,FALSE):PRINTTAB(4)$small_area%;TAB(21);
27320ptr%=odata%+O%*o_len
27330FOR F%=7 TO 0 STEP-1
27340IF ?ptr% AND (2^F%) THEN PRINT"* "; ELSE PRINT". ";
27350NEXT
27360PRINTTAB(39);ptr%?1;TAB(43);ptr%?2+256*ptr%?3;TAB(50)ptr%?4+256*ptr%?5;TAB(58);ptr%?6+256*ptr%?7;TAB(65);ptr%?8+256*ptr%?9;TAB(73);ptr%?10;TAB(80);ptr%?11;
27370IF (ptr%?12 AND &80)<>0 THEN PRINTTAB(85)"<C>";TAB(92);ptr%?13;
27380IF (ptr%?12 AND &80)<>0 THEN
27390store_room=ptr%?13
27400rmflags=?(rdata%+store_room*r_len)
27410tr_flag=(rmflags AND %100000)>0
27420op_flag=(rmflags AND %10000)>0
27430IF tr_flag PRINTTAB(100);"Y"; ELSE PRINTTAB(100);"N";
27440IF op_flag PRINTTAB(106);"Y" ELSE PRINTTAB(106);"N"
27450ELSE
27460PRINT
27470ENDIF
27480NEXT
27490PRINTpline$
27500VDU 27,reset
27510*FX3,0
27520ENDPROC
27530
27540DEF PROCprint_rooms
27550LOCAL R%,F%,I%,ptr%
27560*FX3,10
27570VDU condensed
27580PRINTpline$
27590PROCprint_flags(r_flags%)
27600PRINTpline$:PRINTTAB(70);" * DESTINATIONS *"
27610PRINT"Room Flags 76543210 State Desc. Short Pict. N S E W NE NW SE SW Up Down In Out Back Left Righ Jump"
27620PRINTpline$
27630FOR R%=1 TO last_room
27640PRINT;R%;TAB(11);
27650ptr%=rdata%+R%*r_len
27660FOR F%=7 TO 0 STEP-1
27670IF ?ptr% AND (2^F%) THEN PRINT"*"; ELSE PRINT".";
27680NEXT
27690PRINTTAB(20);ptr%?1;TAB(26);ptr%?2+256*ptr%?3;TAB(32);ptr%?4+256*ptr%?5;TAB(38);ptr%?70+256*ptr%?71;
27700FOR I%=6 TO 36 STEP 2
27710PRINTTAB(5*(I% DIV 2-3)+44);ptr%?I%+256*ptr%?(I%+1);
27720NEXT I%
27730PRINT
27740NEXT R%
27750
27760PRINTpline$:PRINTTAB(30);" * EXIT ROUTINES *"
27770PRINT"Room N S E W NE NW SE SW Up Down In Out Back Left Righ Jump"
27780PRINTpline$
27790FOR R%=1 TO last_room
27800PRINT;R%;
27810ptr%=rdata%+R%*r_len
27820FOR I%=38 TO 53
27830PRINTTAB(5*(I%-38)+6);ptr%?I%;
27840NEXT I%
27850PRINT
27860NEXT R%
27870PRINTpline$
27880PRINTTAB(59)"* EXIT FLAGS *"
27890PRINTpline$
27900PRINT"Exit Flag: ";
27910FOR flag=7 TO 0 STEP-1
27920PRINTTAB(11+(7-flag)*15);"|"TAB(20+(7-flag)*15);flag;
27930NEXT
27940PRINTTAB(11+8*15);"|"
27950PRINT"Descript'n";
27960FOR flag=7 TO 0 STEP-1
27970PRINTTAB(10+(7-flag)*15);" | ";exit_flag$(flag);
27980NEXT
27990PRINTTAB(10+8*15);" |"
28000PRINTpline$
28010PRINTTAB(4);" North South East West No'east No'west So'east So'west Up Down In Out Back Left Right Jump "
28020FOR R%=1 TO last_room
28030IF R%=1 OR R% MOD 10=0 THEN PRINTTAB(4)STRING$(16,"|-------")
28040PRINT;R%;
28050ptr%=rdata%+R%*r_len
28060PRINTTAB(4);
28070FOR I%=54 TO 69
28080FOR F%=7 TO 0 STEP-1
28090IF ?(ptr%+I%) AND (2^F%) THEN PRINT"*"; ELSE PRINT".";
28100NEXT F%
28110NEXT I%
28120PRINT
28130NEXT R%
28140PRINTpline$
28150VDU 27,reset
28160*FX3,0
28170ENDPROC
28180
28190DEF PROCprint_flags(mem%)
28200PRINT"Flag: ";
28210FOR flag=7 TO 0 STEP-1
28220PRINTTAB(11+(7-flag)*15);"|"TAB(20+(7-flag)*15);flag;
28230NEXT
28240PRINTTAB(11+8*15);"|"
28250PRINT"Descript'n";
28260FOR flag=7 TO 0 STEP-1
28270PRINTTAB(10+(7-flag)*(maxd%-1+3));" | ";$mem%;
28280mem%+=maxd%
28290NEXT
28300PRINTTAB(10+8*(maxd%-1+3));" |"
28310ENDPROC
28320
28330DEF PROCprint_vocab
28340print=TRUE
28350PROCput(pline2$+CHR$13)
28360PROCput(STRING$(37," ")+"Nouns:"+CHR$13):PROClistnouns
28370PROCput(pline2$+CHR$13)
28380PROCput(STRING$(37," ")+"Verbs:"+CHR$13):PROClistverbs
28390PROCput(pline2$+CHR$13)
28400PROCput(STRING$(34," ")+"Adjectives:"+CHR$13):PROClistadjs
28410PROCput(pline2$+CHR$13)
28420PROCput(STRING$(33," ")+"Conjunctions:"+CHR$13):PROClistconjs
28430PROCput(pline2$+CHR$13)
28440PROCput(STRING$(33," ")+"Prepositions:"+CHR$13):PROClistpreps
28450PROCput(pline2$+CHR$13)
28460PROCput(STRING$(35," ")+"Specials:"+CHR$13):PROClistspecs
28470PROCput(pline2$+CHR$13)
28480PROCput(STRING$(37," ")+"Noise:"+CHR$13):PROClistnoise
28490PROCput(pline2$+CHR$13)
28500print=FALSE
28510ENDPROC
28520
28530DEF PROCprint_pix
28540LOCAL mptr
28550print=TRUE:SYS "Hourglass_On"
28560
28570IF pxn>1 THEN
28580mptr=pixs+3
28590FOR I%=1 TO pxn-1
28600 PROCput(STR$(I%)+"= ")
28610 PROCput($mptr)
28620 mptr+=LEN$mptr+1
28630 PROCput(",<"+pos$(?mptr)+">"+CHR$13)
28640 mptr+=5
28650NEXT
28660ENDIF
28670
28680print=FALSE:SYS "Hourglass_Off"
28690ENDPROC
28700
28710DEF PROCscan
28720oldptr=prgptr:numflag=0
28730ptr=1:len=LEN line$:IF len=0 THEN GOTO 29140
28740REPEAT
28750temp$=""
28760WHILE MID$(line$,ptr,1)<"A" AND ptr<len
28770ptr+=1
28780ENDWHILE
28790vptr=ptr
28800WHILE MID$(line$,ptr,1)>"@" AND ptr<len
28810temp$=temp$+MID$(line$,ptr,1):ptr+=1
28820ENDWHILE
28830IF temp$<>"" THEN
28840PROClookup(temp$,token,info_ptr)
28850IF token=0 PROCerror(0,": "+MID$(line$,vptr,30)):prgptr=oldptr:GOTO 29120
28860IF token=def_token THEN PROCdodefn:GOTO29120
28870?prgptr=token:tokptr=prgptr:prgptr+=1
28880p_info=info%(info%(token-first_token+1,2),1):params=p_info AND %1111
28890ptr+=1
28900IF params <>0 THEN
28910FOR I%=1 TO params
28920 WHILE INSTR(", ",MID$(line$,ptr,1))<>0 AND ptr<len
28930 ptr+=1
28940 ENDWHILE
28950 IF token>=var_token AND I%=1 THEN PROCget_var(ptr,ptr,paramvalue,vptr)
28960 IF token>=var_token AND I%>1 THEN PROCget_num_or_var(ptr,ptr,paramvalue,varflag):IF varflag THEN ?tokptr=?tokptr+&10
28970 IF token<var_token THEN
28980 IF MID$(line$,ptr,1)=CHR$34 PROCdecode_string(line$,ptr,ptr,paramvalue,FNfntype(p_info)) ELSE PROCdecode_parameter(line$,ptr,ptr,paramvalue,vptr)
28990 ENDIF
29000 IF errflag THEN 29120
29010 IF paramvalue>info%(info_ptr,I%+2) PROCerror(2,STR$(info%(info_ptr,I%+2))+" ("+temp$+")"):GOTO29120
29020 IF info%(info_ptr,I%+2)<256 THEN bytes=1
29030 IF info%(info_ptr,I%+2)>255 AND info%(info_ptr,I%+2)<65536 THEN bytes=2
29040 IF info%(info_ptr,I%+2)>65535 THEN bytes=3
29050 FOR J%=0 TO bytes-1
29060 J%?prgptr=paramvalue DIV 256^J%
29070 NEXT J%
29080 prgptr+=bytes
29090NEXT I%
29100ENDIF
29110ENDIF
29120UNTIL ptr>=(len-1) OR token=0 OR errflag
29130IF token=0 OR errflag THEN PROCrestore_end:GOTO29150
29140?prgptr=13:prgptr+=1
29150ENDPROC
29160
29170DEF PROCrestore_end
29180prgptr=oldptr:?prgptr=0
29190ENDPROC
29200
29210DEF PROCerror(err_num,err$)
29220errflag=TRUE
29230null =FNerrorbox(error$(err_num)+" "+err$,err_num,1,-99)
29240ENDPROC
29250
29260DEF PROCfind_token(A$(),search$,RETURN token,RETURN mid)
29270LOCAL first,last,stop_search,found,len
29280len=LEN search$
29290first=1
29300last=DIM(A$(),1)
29310stop_search=FALSE:found=FALSE
29320REPEAT
29330PROCchop
29340UNTIL stop_search
29350IF found THEN token=info%(mid,0) ELSE token=0
29360ENDPROC
29370
29380DEF PROCchop
29390mid=(first+last) DIV 2
29400A$=A$(mid)
29410IF A$=search$ THEN stop_search=TRUE:found=TRUE:ENDPROC
29420IF A$>search$ THEN
29430last=mid-1
29440ELSE
29450first=mid+1
29460ENDIF
29470IF first>last THEN stop_search=TRUE
29480ENDPROC
29490
29500DEF PROClookup(search$,RETURN token,RETURN index)
29510LOCAL I%,found
29520token=0
29530IF search$="" THEN ENDPROC
29540PROCfind_token(keyword$(),search$,token,index)
29550ENDPROC
29560
29570I%=1
29580REPEAT
29590IF INSTR(LEFT$(keyword$(I%),LEN(search$)),search$)<>0 THEN token=info%(I%,0):found=TRUE:index=I%
29600I%+=1
29610UNTIL found OR I%=keywords+1
29620ENDPROC
29630
29640DEF PROCdecode_parameter(line$,place,RETURN place,RETURN value,vptr)
29650LOCAL temp1$
29660WHILE INSTR(" (,",MID$(line$,place,1))<>0 place+=1
29670ENDWHILE
29680WHILE INSTR("0123456789",MID$(line$,place,1))<>0 AND place<=LEN(line$) temp1$=temp1$+MID$(line$,place,1):place+=1
29690ENDWHILE
29700IF INSTR(") ,"+CHR$13,MID$(line$,place,1))=0 THEN
29710PROCerror(1,": "+MID$(line$,vptr,30)):errflag=TRUE
29720ELSE
29730value=VAL(temp1$)
29740ENDIF
29750ENDPROC
29760
29770DEF PROCdecode_string(line$,place,RETURN place,RETURN value,type)
29780LOCAL temp1$,dummy$,vptr
29790vptr=place-1
29800place+=1
29810temp1$=""
29820WHILE (INSTR(CHR$34,MID$(line$,place,1))=0 AND place<LENline$)
29830temp1$+=MID$(line$,place,1)
29840place+=1
29850ENDWHILE
29860IF INSTR(CHR$34,MID$(line$,place,1))<>0 THEN place+=1:REM added 31.5.89
29870IF temp1$="" THEN
29880value=0
29890ELSE
29900CASE type OF
29910WHEN 1
29920PROCgetobn(temp1$,value,dummy$):REM Find the noun number
29930IF value=0 THEN
29940temp1$=": "+temp1$
29950ERROR 1,"Badly formed/Non-existent noun: "+MID$(line$,vptr-LENtemp$,20)
29960ELSE
29970PROCwhich_obj(value,val$,refs):REM Find which object/s it references
29980IF refs=1 THEN value=VAL(val$) ELSE PROCerror(27,temp1$+error$(37))
29990ENDIF
30000WHEN 2:PROCgetvbn(temp1$,value,dummy$)
30010WHEN 3:PROCgetprn(temp1$,value,dummy$)
30020ENDCASE
30030ENDIF
30040ENDPROC
30050
30060DEF PROCget_var(place,RETURN place,RETURN value,vptr)
30070WHILE INSTR(" (,",MID$(line$,place,1))<>0 place+=1
30080ENDWHILE
30090chr$=MID$(line$,place,1)
30100IF chr$<"A" OR chr$>"|" THEN PROCerror(3,": "+MID$(line$,vptr,30)):ENDPROC
30110value=ASC chr$ - ASC"A"
30120place+=1:IF MID$(line$,place,1)<>"%" THEN PROCerror(3,": "+MID$(line$,vptr,30)) ELSE place+=1
30130ENDPROC
30140
30150DEF PROCget_num_or_var(place,RETURN place,RETURN value,RETURN flag)
30160WHILE INSTR(" (,",MID$(line$,place,1))<>0 place+=1
30170ENDWHILE
30180chr$=MID$(line$,place,1)
30190IF INSTR("0123456789",chr$) THEN flag=FALSE:PROCdecode_parameter(line$,place,place,value,vptr):ENDPROC
30200PROCget_var(place,place,value,vptr):flag=TRUE
30210ENDPROC
30220
30230DEF PROCrun
30240LOCAL ERROR
30250SYS "OS_Byte",229,0,0 TO ,oldstate%
30260err_col=11:PROCcol(130):PROCcol(7):SYS "Wimp_SetColour",128+2
30270ON ERROR LOCAL:PROCcol(err_col):IF ERR<>17 PRINT'"Interpreter reports a run-time error: "REPORT$:GOTO 30610 ELSE PRINT'REPORT$:GOTO 30610
30280PROCclose(texthandle):PROCclose(objhandle):PROCclose(roomhandle)
30290!work%=rdata%
30300work%!4=verbs+3
30310work%!8=nouns+3
30320work%!12=program%+4
30330work%!16=text%+7
30340work%!20=dict%+3
30350work%!24=odata%
30360work%!28=adjects+3
30370work%!32=preps+3
30380work%!36=conjs+3
30390work%!40=specs+3
30400work%!44=noise+3
30410work%!48=pixs+3
30420REM work%!52 is reserved
30430work%!56=initsave
30440work%!60=last_room
30450work%!64=last_object+1
30460VDU26,4,12
30470PROCcentre("PLEASE WAIT",0):OFF
30480IF datavalid THEN PROCcopy_from_editor ELSE PROCcopy_to_editor
30490!picbuf=pbsize
30500OSCLI("LOAD <Users$Resources>.Buttons "+STR$~(picbuf+4))
30510REM Read the scale factors and pixel translation table
30520SYS "Wimp_ReadPixTrans",&200,picbuf,picbuf+16,0,0,0,scale,pixtr
30530REM Now PutSpriteScaled
30540SYS "OS_SpriteOp",&234,picbuf,picbuf+16,0,0,8,scale,pixtr
30550VDU 28,0,textrows%-5,textcols%,0,24,0;148;scrw;scrh;
30560PROCcentre(STRING$(11," "),0):PRINT:ON
30570A%=verb_type:B%=nref:C%=aref:D%=ramsave
30580E%=pbytes:F%=work%:G%=picbuf:H%=pbsize
30590cliplen=0
30600CALL run
30610VDU 26:PROCcentre("PLEASE WAIT",26):OFF:PROCswap_data:datavalid=TRUE:PROCcentre(STRING$(11," "),26):PROCreturn(18,0):ON
30620PROCchangeicon(ALPSmain,swapicon,"swap",swapicon)
30630REM The copy/swap routines as used above ensure the data in the editor is
30640REM ALWAYS valid after running a game, even if it wasn't before running it
30650VDU 5
30660SYS ForceR,-1,0,0,scrw+1,scrh+1
30670RESTORE ERROR
30680SYS "OS_Byte",229,oldstate%,0
30690SYS "OS_Byte",124
30700ENDPROC
30710
30720DEF PROCcol(color)
30730SYS "Wimp_TextColour",color
30740ENDPROC
30750
30760DEF PROCfind_section(code%,value%,RETURN found)
30770REM Searches program for a match with code%,value%
30780REM eg DEFPROC(3) --> &86,&03
30790REM Sets `listptr` to the address of the `code%` byte, if found
30800ptr=listptr
30810LOCAL byte1,byte2
30820found=FALSE
30830E%=pbytes:F%=work%:CALL setup:G%=ptr
30840REPEAT
30850A%=code%:ptr=USR findcode
30860IF ?ptr=value% THEN found=TRUE ELSE G%=ptr+1
30870UNTIL found OR ptr=0
30880IF found THEN listptr=ptr-1 ELSE listptr=program%+4+FNprglen+1
30890ENDPROC
30900
30910DEF PROClist(prg_part%,val$)
30920LOCAL col%,row%
30930PROCfill(text_block%,text_blocksize%,dummy_spc)
30940text_rowlen%()=+0
30950SYS "Hourglass_On"
30960listptr=program%+4:line=1:last=65535:first=1
30970col%=1:row%=0
30980store=text_block%
30990existing_verb=FALSE
31000print=FALSE
31010errflag=FALSE
31020
31030CASE prg_part% OF
31040WHEN 1:found=TRUE:end1%=0:end2%=0:print=TRUE:REM Print whole program
31050WHEN 2:found=TRUE:end1%=stop_token:end2%=def_token
31060WHEN 3,4,5:end1%=end_token:end2%=0
31070ENDCASE
31080
31090CASE prg_part% OF
31100WHEN 3
31110PROCfind_section(proc_token,VAL val$,found)
31120token=proc_token
31130WHEN 4
31140existing_verb=TRUE
31150PROCgetvbn(val$,verb,dummy$)
31160PROCfind_section(def_token,verb,found)
31170token=def_token
31180WHEN 5
31190PROCfind_section(exit_token,VAL val$,found)
31200token=exit_token
31210ENDCASE
31220
31230IF NOT found THEN
31240 PROCerror(10,""+FNtoken_to_keyword(token)+"("+val$+")")
31250 listptr-=1:REM Point to end of program
31260 IF token=def_token THEN existing_verb=FALSE
31270ENDIF
31280
31290pstart=listptr:REM Start address of program section
31300byte1=?listptr:found_end=FALSE
31310WHILE byte1<>0 AND NOT found_end
31320eol%=FALSE
31330 WHILE byte1=13
31340 listptr+=1:PROCput(CHR$13):eol%=TRUE
31350 row%+=1
31360 byte1=?listptr
31370 ENDWHILE
31380 IF byte1=0 THEN PROCput(CHR$(0)):GOTO31770
31390 IF (byte1=end1% AND eol%) OR byte1=end2% THEN found_end=TRUE
31400 IF byte1>&BF THEN byte2=byte1-&10 ELSE byte2=byte1
31410 token=byte2:listptr+=1
31420 word$=FNtoken_to_keyword(token)
31430 PROCput(word$)
31440 IF byte2=def_token THEN PROCprtdef:listptr+=1:GOTO31770
31450 p_info=info%(info%(token-first_token+1,2),1):params=p_info AND %1111
31460 IF params=0 AND ?listptr<>13 PROCput(" ")
31470 IF params<>0 THEN
31480 PROCput("(")
31490 FOR I%=1 TO params
31500 maxvalue=info%(info%(token-first_token+1,2),I%+2)
31510 IF maxvalue<256 THEN bytes=1
31520 IF maxvalue>255 AND maxvalue<65536 THEN bytes=2
31530 IF maxvalue>65535 THEN bytes=3
31540 value=0
31550 FOR J%=0 TO bytes-1
31560 value=value+(J%?listptr)*256^J%
31570 NEXT J%
31580 doneit=FALSE
31590 IF I%=1 AND (listoption AND %10)<>0 AND FNfntype(p_info)=1 THEN
31600 PROCprntobj
31610 ELSE
31620 IF I%=1 AND (listoption AND %10)<>0 AND FNfntype(p_info)=2 THEN
31630 PROCprntvrb
31640 ENDIF
31650 ENDIF
31660 IF I%=1 AND (word$="PREP" OR word$="NOTPREP") AND (listoption AND %10)<>0 THEN PROCprintprep
31670 IF I%=2 AND (word$="PUTIN" OR word$="TAKEOUT") AND (listoption AND %10)<>0 THEN PROCprntobj
31680 IF NOT doneit THEN
31690 IF byte1<var_token OR (I%>1 AND byte1<&C0) PROCput(STR$(value)) ELSE PROCput(CHR$(value+ASC"A")+"%")
31700 ENDIF
31710 listptr+=bytes
31720 IF I%<>params THEN PROCput(",")
31730 NEXT I%
31740 PROCput(")")
31750 IF ?listptr<>13 PROCput(" ")
31760 ENDIF
31770 byte1=?listptr
31780ENDWHILE
31790IF found_end PROCput(CHR$13+CHR$0)
31800text_end%=store-1:text_ptr%=text_block%
31810IF text_end%<text_block% text_end%=text_block%
31820prgend=listptr:REM End address of program section
31830last_row%=FNfind_lastrow
31840
31850FOR R%=0 TO last_row%
31860text_rowlen%(R%)=LEN FNrow(R%)
31870NEXT
31880
31890SYS "Hourglass_Off"
31900ENDPROC
31910
31920DEF PROCput(text$)
31930LOCAL I%
31940IF NOT print THEN
31950IF text$<>"" THEN
31960$store=text$
31970store+=LEN text$
31980ENDIF
31990ELSE
32000*FX3,10
32010PRINTtext$;
32020*FX3,0
32030ENDIF
32040ENDPROC
32050
32060DEF PROClist_vocab(voc%)
32070SYS "Hourglass_On"
32080print=FALSE:store=text_block%
32090PROCfill(text_block%,text_blocksize%,dummy_spc)
32100col%=1:row%=0
32110
32120CASE voc% OF
32130WHEN 1: PROClistnouns
32140WHEN 2: PROClistverbs
32150WHEN 3: PROClistadjs
32160WHEN 4: PROClistpreps
32170WHEN 5: PROClistconjs
32180WHEN 6: PROClistspecs
32190WHEN 7: PROClistnoise
32200ENDCASE
32210
32220text_end%=store-1:text_ptr%=text_block%
32230IF text_end%<text_block% text_end%=text_block%
32240last_row%=FNfind_lastrow
32250FOR R%=0 TO last_row%
32260 text_rowlen%(R%)=LEN FNrow(R%)
32270NEXT
32280SYS "Hourglass_Off"
32290ENDPROC
32300
32310DEF PROClist_pix
32320LOCAL mptr
32330SYS "Hourglass_On"
32340print=FALSE:store=text_block%
32350PROCfill(text_block%,text_blocksize%,dummy_spc)
32360col%=1:row%=0
32370
32380IF pxn>1 THEN
32390mptr=pixs+3
32400FOR I%=1 TO pxn-1
32410 PROCput(STR$(I%)+"= ")
32420 PROCput($mptr)
32430 mptr+=LEN$mptr+1
32440 PROCput(",<"+pos$(?mptr)+">"+CHR$13)
32450 mptr+=5
32460NEXT
32470PROCput(CHR$0)
32480ENDIF
32490
32500text_end%=store-1:text_ptr%=text_block%
32510IF text_end%<text_block% text_end%=text_block%
32520last_row%=FNfind_lastrow
32530
32540FOR R%=0 TO last_row%
32550text_rowlen%(R%)=LEN FNrow(R%)
32560NEXT
32570
32580SYS "Hourglass_Off"
32590ENDPROC
32600
32610DEF FNtoken_to_keyword(token)
32620=keyword$(info%(token-first_token+1,2))
32630
32640DEF PROCnew
32650obn=1:vbn=1:adn=1:prn=1:cjn=1:spn=1:nsn=1:pxn=1
32660nxtobj=nouns:?nxtobj=obn:nxtobj?1=3:nxtobj?2=0:nxtobj+=3:?nxtobj=&FF
32670nxtvrb=verbs:?nxtvrb=vbn:nxtvrb?1=3:nxtvrb?2=0:nxtvrb+=3:?nxtvrb=&FF
32680nxtadj=adjects:?nxtadj=adn:nxtadj?1=3:nxtadj?2=0:nxtadj+=3:?nxtadj=&FF
32690nxtprp=preps:?nxtprp=prn:nxtprp?1=3:nxtprp?2=0:nxtprp+=3:?nxtprp=&FF
32700nxtcjn=conjs:?nxtcjn=cjn:nxtcjn?1=3:nxtcjn?2=0:nxtcjn+=3:?nxtcjn=&FF
32710nxtspn=specs:?nxtspn=spn:nxtspn?1=3:nxtspn?2=0:nxtspn+=3:?nxtspn=&FF
32720nxtnsn=noise:?nxtnsn=nsn:nxtnsn?1=3:nxtnsn?2=0:nxtnsn+=3:?nxtnsn=&FF
32730nxtpxn=pixs:?nxtpxn=pxn:nxtpxn?1=3:nxtpxn?2=0:nxtpxn+=3:?nxtpxn=&FF
32740!aref=4:aref?4=0:!nref=4:nref?4=0
32750prev_file$=""
32760ENDPROC
32770
32780DEF PROClvar
32790vars=work%+&88
32800FOR I%=1 TO 2*num_vars STEP 8
32810PRINTTAB(8)CHR$(I% DIV 2 +ASC"A");"% = ";vars?(I%-1)+vars?I%*256;
32820PRINTTAB(24)CHR$(I% DIV 2 +ASC"B");"% = ";vars?(I%+1)+vars?(I%+2)*256;
32830PRINTTAB(40)CHR$(I% DIV 2 +ASC"C");"% = ";vars?(I%+3)+vars?(I%+4)*256;
32840PRINTTAB(56)CHR$(I% DIV 2 +ASC"D");"% = ";vars?(I%+5)+vars?(I%+6)*256
32850NEXT
32860ENDPROC
32870
32880DEF PROClisto
32890LOCAL bitmask$,op$
32900CASE item1% OF
32910WHEN 0: bitmask$="%11111101":op$=" AND "
32920WHEN 1: bitmask$="%00000010":op$=" OR "
32930WHEN 2: bitmask$="%11111011":op$=" AND "
32940WHEN 3: bitmask$="%00000100":op$=" OR "
32950ENDCASE
32960listoption=EVAL(STR$listoption+op$+bitmask$)
32970ENDPROC
32980
32990DEF PROCstatus
33000PRINTTAB(1);"User code address = &";~usercode%;" (";usercode%;" decimal)"
33010PRINTTAB(1);"Program bytes: ";TAB(21);FNprglen;TAB(28);code_size%-FNprglen;" bytes free."
33020PRINTTAB(1)"Messages defined: "TAB(21);FNmaxmsg;TAB(28);(FNtext_end-text%);" characters used. ";maxtext%-(FNtext_end-text%);" characters free."
33030PRINTTAB(1)"Verbs defined: "TAB(21);vbn-1;TAB(28);verb_size-(nxtvrb-verbs);" characters free."
33040PRINTTAB(1)"Nouns defined: "TAB(21);obn-1;TAB(28);noun_size-(nxtobj-nouns);" characters free."
33050PRINTTAB(1)"Adjectives defined: "TAB(21);adn-1;TAB(28);adjc_size-(nxtadj-adjects);" characters free."
33060PRINTTAB(1)"Objects defined: "TAB(21);last_object;TAB(28);maxobs-last_object" object(s) remaining."
33070PRINTTAB(1)"Rooms defined: "TAB(21);last_room;TAB(28);maxrms-last_room" room(s) remaining."
33080PRINTTAB(1)"Screen mode: ";mode%;", File: "CHR$34+loaded$+CHR$34", Data: ";:PROCcol(11):IF data_saved PRINT"Saved" ELSE PRINT"NOT Saved"
33090ENDPROC
33100
33110
33120REM ------ Various Disk Operations ------
33130
33140DEF PROCcreate_dirs(app$,root$)
33150LOCAL t$,l$,r$,I%,rd$,out%
33160SYS "Hourglass_On"
33170IF RIGHT$(root$,1)<>"." THEN root$+="."
33180t$=root$:l$="":I%=0
33190 WHILE INSTR(t$,".")<>0
33200 r$=LEFT$(t$,INSTR(t$,".")-1)
33210 IF I%>0 l$=l$+"."+r$ ELSE l$=r$
33220 I%+=1
33230 OSCLI("CDIR "+l$)
33240 t$=MID$(t$,INSTR(t$,".")+1)
33250 ENDWHILE
33260 IF LEFT$(app$,1)<>"!" THEN app$="!"+app$
33270 app$=LEFT$(app$,10)
33280 ra$=root$+app$:REM path to users 'Alps' file
33290 OSCLI("CDIR "+ra$)
33300 OSCLI("CDIR "+ra$+".ALPS")
33310 OSCLI("CDIR "+ra$+".PICTURES")
33320 OSCLI("CDIR "+ra$+".Resources")
33330 rd$=ra$+".Resources.":REM Resources dir path
33340 OSCLI "SAVE "+rd$+"pbytes "+STR$~pbytes+"+"+STR$~pbyte_size
33350 OSCLI("SAVE "+rd$+"ASIobjcode "+STR$~asicode%+"+"+STR$~codesize)
33360 OSCLI "SAVE "+rd$+"buttons "+STR$~picbuf+"+"+STR$~butlen
33370 OSCLI "SETTYPE "+rd$+"buttons Sprite"
33380 OSCLI "SETTYPE "+rd$+"pbytes Data"
33390 OSCLI "SETTYPE "+rd$+"ASIobjcode Absolute"
33400 OSCLI "SAVE "+ra$+".!RunImage "+STR$~(picbuf+butlen)+"+"+STR$~ldlen
33410 OSCLI "SETTYPE "+ra$+".!RunImage BASIC"
33420 SYS "OS_SpriteOp",256+26,sprld,"!alpsgames",app$:REM Rename Sprite
33430 SYS "OS_SpriteOp",256+12,sprld,ra$+".!Sprites":REM Save it
33440 out%=OPENOUT(ra$+".!Run")
33450 out2%=OPENOUT(ra$+".!Boot")
33460 BPUT#out%,"| !Run file for ALPS games"
33470 BPUT#out2%,"| !Boot file for ALPS games"
33480 BPUT#out%,"|"
33490 BPUT#out%,"SET Alps$NoMouseInput 0"
33500 BPUT#out%,"|"
33510 BPUT#out%,"SET Alps$ShowAddress 0"
33520 BPUT#out%,"|"
33530 BPUT#out2%,"|"
33540 BPUT#out%,"IconSprites <Obey$Dir>.!Sprites"
33550 BPUT#out2%,"IconSprites <Obey$Dir>.!Sprites"
33560 BPUT#out%,"SET AlpsGame$Resources "+rd$
33570 BPUT#out%,"SET AlpsGame$Data "+ra$+".Alps"
33580 BPUT#out%,"SET Alps$Pictures "+ra$+".Pictures."
33590 BPUT#out2%,"SET AlpsGame$Resources "+rd$
33600 BPUT#out2%,"SET AlpsGame$Data "+ra$+".Alps"
33610 BPUT#out2%,"SET Alps$Pictures "+ra$+".Pictures."
33620 BPUT#out%,"Run <Obey$Dir>.!RunImage"
33630 CLOSE#out%:CLOSE#out2%
33640 OSCLI "*SETTYPE "+ra$+".!Run Obey"
33650 OSCLI "*SETTYPE "+ra$+".!Boot Obey"
33660SYS "Hourglass_Off"
33670ENDPROC
33680
33690DEF PROCload_bits(app$)
33700REM Loads 'buttons' sprite and 'Loader' program into picture buffer
33710REM They will then be saved to the user's data disk by PROCcreate_dirs
33720IF LEFT$(app$,1)<>"!" THEN app$="!"+app$
33730bit$="<Alps$Resources>.buttons"
33740SYS "OS_File",5,bit$ TO ftype,,,,butlen
33750OSCLI "LOAD "+bit$+" "+STR$~picbuf
33760SYS "OS_File",5,"<Alps$Resources>.!Runimage" TO ftype,,,,ldlen
33770OSCLI "LOAD <Alps$Resources>.!Runimage "+STR$~(picbuf+butlen)
33780SYS "OS_File",5,"<Alps$Resources>.!Sprites" TO ftype,,,,sprlen
33790DIM sprld sprlen+4:!sprld=sprlen+4
33800sprld!4=0:sprld!8=16:sprld!12=16
33810SYS "OS_SpriteOp",266,sprld,"<Alps$Resources>.!Sprites"
33820cliplen=0
33830ENDPROC
33840
33850DEF PROCconvert(import$)
33860LOCAL in%,I%,V%,ptr,T%
33870SYS "Hourglass_On"
33880!program%=0
33890program%!4=0
33900PROCfill(nref+4,nref_size-4,0)
33910in%=OPENIN import$
33920
33930FOR I%=0 TO &57F
33940 V%=BGET#in%
33950 verbs?I%=V%
33960NEXT I%
33970vbn=?verbs
33980nxtvrb=verbs+(verbs?1+256*(verbs?2))
33990
34000FOR I%=0 TO &57F
34010 V%=BGET#in%
34020 nouns?I%=V%
34030NEXT I%
34040obn=?nouns
34050nxtobj=nouns+(nouns?1+256*(nouns?2))
34060
34070V%=BGET#in%
34080V%=BGET#in%
34090ptr=program%+4
34100
34110REPEAT
34120 T%=BGET#in%
34130 ?ptr=T%:ptr+=1
34140 IF T%>=&C0 THEN T%-=&10
34150 IF T%>=&70 THEN
34160 pb=oldpars?(T%-&70)
34170 IF pb>0 THEN
34180 FOR I%=1 TO pb
34190 V%=BGET#in%
34200 ?ptr=V%:ptr+=1
34210 CASE T% OF
34220 WHEN &A4,&A1,&92,&90,&96,&97,&A6,&9A,&AA,&87,&88,&7B
34230 IF I%=1 THEN ?ptr=0:ptr+=1
34240 WHEN &7A,&A5,&B2,&B3,&B4,&B5,&B6,&B7,&B8
34250 IF I%=2 THEN ?ptr=0:ptr+=1
34260 ENDCASE
34270 NEXT I%
34280 ENDIF
34290ENDIF
34300UNTIL EOF#in%
34310CLOSE#in%
34320PROCincprglen(ptr-5-program%)
34330SYS "Hourglass_Off"
34340ENDPROC
34350
34360DEF PROCimport_text(import$)
34370IF import$="" THEN
34380PROCerror(16,"")
34390ELSE
34400OSCLI "LOAD "+import$+" "+STR$~(text%+2)
34410mptr=1
34420?text%=text%?2:text%?1=text%?3
34430text%!2=(text%?4+256*text%?5)+2
34440text%!6=text%?6
34450ENDIF
34460ENDPROC
34470
34480DEF PROCimport_obj(import$)
34490LOCAL in%,O%,M%,J%,flags,state,room,mlo,mhi
34500M%=odata%
34510in%=OPENIN(import$)
34520IF in%=0 PROCerror(10,""):ENDPROC
34530O%=BGET#in%
34540PTR#in%=0
34550FOR I%=0 TO O%
34560flags=BGET#in%:state=BGET#in%:room=BGET#in%
34570mlo=BGET#in%:mhi=BGET#in%
34580M%?0=flags:M%?1=state
34590M%?2=room:M%?3=0
34600M%?4=mlo:M%?5=mhi
34610FOR J%=6 TO o_len-1
34620M%?J%=0
34630NEXT J%
34640M%+=o_len
34650NEXT I%
34660last_object=O%
34670CLOSE#in%
34680ENDPROC
34690
34700DEF PROCimport_rooms(import$)
34710LOCAL in%,R%,M%,J%
34720M%=rdata%
34730in%=OPENIN(import$)
34740IF in%=0 PROCerror(10,""):ENDPROC
34750R%=BGET#in%
34760PTR#in%=0
34770FOR I%=0 TO R%
34780FOR J%=0 TO 3
34790M%?J%=BGET#in%
34800NEXT J%
34810M%?4=0:M%?5=0
34820FOR J%=6 TO 13 STEP2
34830M%?J%=BGET#in%:M%?(J%+1)=0
34840NEXT J%
34850FOR J%=14 TO 37
34860M%?J%=0
34870NEXT J%
34880M%?22=BGET#in%
34890M%?24=BGET#in%
34900FOR J%=38 TO 73
34910IF (J%<42 OR J%=46 OR J%=47) THEN M%?J%=BGET#in% ELSE M%?J%=0
34920NEXT J%
34930M%+=r_len
34940NEXT I%
34950last_room=R%
34960ENDPROC
34970
34980DEF PROCsave_all(f$)
34990REM f$=full path name
35000IF INSTR(f$,".")=0 THEN ERROR 1,"To save, drag the file icon to a directory viewer in which there is an ALPS directory.":ENDPROC
35010SYS "Hourglass_On"
35020PROCclose(texthandle):PROCclose(objhandle):PROCclose(roomhandle)
35030p$=f$:f$=FNleafname(p$)
35040p$=LEFT$(p$,LEN(p$)-LEN(f$))
35050d$=p$+"Alps."
35060OSCLI("SET Alps$Data "+d$)
35070PROCsave_objs("<Alps$Data>Objects")
35080PROCsave_rooms("<Alps$Data>Rooms")
35090PROCsave_flags("<Alps$Data>Flags")
35100PROCsave_pix("<Alps$Data>Pictures")
35110PROCsave_vocab(f$)
35120PROCsave_program("<Alps$Data>Program")
35130PROCsave_text("<Alps$Data>Text")
35140PROCsave_dict("<Alps$Data>Dict")
35150PROCsave_pal("<Alps$Data>!Palette")
35160PROCsave_chars("<Alps$Data>charset")
35170OSCLI("CREATE "+p$+f$+" 100")
35180OSCLI("SETTYPE "+p$+f$+" "+type$)
35190OSCLI("CREATE <Alps$Data>GameData 100")
35200out%=OPENUP("<Alps$Data>GameData")
35210BPUT#out%,mode%
35220CLOSE#out%
35230data_saved=TRUE:loaded$=f$:$filename%=f$
35240SYS CreateM,,-1
35250SYS "Hourglass_Off"
35260ENDPROC
35270
35280DEF PROCsave_vocab(fi$)
35290IF fi$="" THEN
35300PROCerror(16,"")
35310ELSE
35320PROCsave_nouns("<Alps$Data>Nouns")
35330PROCsave_verbs("<Alps$Data>Verbs")
35340PROCsave_adjects("<Alps$Data>Adjectives")
35350PROCsave_preps("<Alps$Data>Prepos")
35360PROCsave_conj("<Alps$Data>Conjunc")
35370PROCsave_spec("<Alps$Data>Specials")
35380PROCsave_noise("<Alps$Data>Noise")
35390PROCsave_nrefs("<Alps$Data>Nref")
35400PROCsave_arefs("<Alps$Data>Aref")
35410PROCsave_vtypes("<Alps$Data>VerbType")
35420ENDIF
35430ENDPROC
35440
35450DEF PROCsave_nouns(fi$)
35460IF fi$="" THEN
35470PROCerror(16,"")
35480ELSE
35490OSCLI "SAVE "+fi$+" "+STR$~nouns+" "+STR$~(nxtobj+1)
35500OSCLI "SETTYPE "+fi$+" Data"
35510ENDIF
35520ENDPROC
35530
35540DEF PROCsave_verbs(fi$)
35550IF fi$="" THEN
35560PROCerror(16,"")
35570ELSE
35580OSCLI "SAVE "+fi$+" "+STR$~verbs+" "+STR$~(nxtvrb+1)
35590OSCLI "SETTYPE "+fi$+" Data"
35600ENDIF
35610ENDPROC
35620
35630DEF PROCsave_adjects(fi$)
35640IF fi$="" THEN
35650PROCerror(16,"")
35660ELSE
35670OSCLI "SAVE "+fi$+" "+STR$~adjects+" "+STR$~(nxtadj+1)
35680OSCLI "SETTYPE "+fi$+" Data"
35690ENDIF
35700ENDPROC
35710
35720DEF PROCsave_preps(fi$)
35730IF fi$="" THEN
35740PROCerror(16,"")
35750ELSE
35760OSCLI "SAVE "+fi$+" "+STR$~preps+" "+STR$~(nxtprp+1)
35770OSCLI "SETTYPE "+fi$+" Data"
35780ENDIF
35790ENDPROC
35800
35810DEF PROCsave_conj(fi$)
35820IF fi$="" THEN
35830PROCerror(16,"")
35840ELSE
35850OSCLI "SAVE "+fi$+" "+STR$~conjs+" "+STR$~(nxtcjn+1)
35860OSCLI "SETTYPE "+fi$+" Data"
35870ENDIF
35880ENDPROC
35890
35900DEF PROCsave_spec(fi$)
35910IF fi$="" THEN
35920PROCerror(16,"")
35930ELSE
35940OSCLI "SAVE "+fi$+" "+STR$~specs+" "+STR$~(nxtspn+1)
35950OSCLI "SETTYPE "+fi$+" Data"
35960ENDIF
35970ENDPROC
35980
35990DEF PROCsave_noise(fi$)
36000IF fi$="" THEN
36010PROCerror(16,"")
36020ELSE
36030OSCLI "SAVE "+fi$+" "+STR$~noise+" "+STR$~(nxtnsn+1)
36040OSCLI "SETTYPE "+fi$+" Data"
36050ENDIF
36060ENDPROC
36070
36080DEF PROCsave_vtypes(fi$)
36090IF fi$="" THEN
36100PROCerror(16,"")
36110ELSE
36120OSCLI "SAVE "+fi$+" "+STR$~verb_type+"+"+STR$~(2*(maxvbn+1))
36130OSCLI "SETTYPE "+fi$+" Data"
36140ENDIF
36150ENDPROC
36160
36170DEF PROCsave_arefs(fi$)
36180IF fi$="" THEN
36190PROCerror(16,"")
36200ELSE
36210OSCLI "SAVE "+fi$+" "+STR$~aref+"+"+STR$~(!aref+1)
36220OSCLI "SETTYPE "+fi$+" Data"
36230ENDIF
36240ENDPROC
36250
36260DEF PROCsave_nrefs(fi$)
36270IF fi$="" THEN
36280PROCerror(16,"")
36290ELSE
36300OSCLI "SAVE "+fi$+" "+STR$~nref+"+"+STR$~(!nref+1)
36310OSCLI "SETTYPE "+fi$+" Data"
36320ENDIF
36330ENDPROC
36340
36350DEF PROCsave_objs(fi$)
36360IF fi$="" THEN
36370PROCerror(16,"")
36380ELSE
36390IF NOT datavalid PROCswap_data:datavalid=TRUE
36400odata%?14=optr:odata%?15=last_object
36410OSCLI "SAVE "+fi$+" "+STR$~odata%+"+"+STR$~(o_len*(last_object+1))
36420OSCLI "SETTYPE "+fi$+" Data"
36430ENDIF
36440ENDPROC
36450
36460DEF PROCsave_rooms(fi$)
36470IF fi$="" THEN
36480PROCerror(16,"")
36490ELSE
36500IF NOT datavalid PROCswap_data:datavalid=TRUE
36510!rdata%=rptr+(last_room<<16)
36520OSCLI "SAVE "+fi$+" "+STR$~rdata%+"+"+STR$~(r_len*(last_room+1))
36530OSCLI "SETTYPE "+fi$+" Data"
36540ENDIF
36550ENDPROC
36560
36570DEF PROCsave_flags(fi$)
36580IF fi$="" THEN
36590PROCerror(16,"")
36600ELSE
36610chn%=OPENOUT fi$
36620FOR f%=0 TO 7
36630flag$=$(o_flags%+f%*maxd%)
36640PRINT#chn%,flag$
36650NEXT
36660FOR f%=0 TO 7
36670flag$=$(r_flags%+f%*maxd%)
36680PRINT#chn%,flag$
36690NEXT
36700CLOSE#chn%
36710ENDIF
36720ENDPROC
36730
36740DEF PROCsave_pix(fi$)
36750IF fi$="" THEN
36760PROCerror(16,"")
36770ELSE
36780OSCLI "SAVE "+fi$+" "+STR$~pixs+" "+STR$~(nxtpxn+1)
36790OSCLI "SETTYPE "+fi$+" Data"
36800ENDIF
36810ENDPROC
36820
36830DEF PROCsave_program(fi$)
36840IF fi$="" THEN
36850PROCerror(16,"")
36860ELSE
36870OSCLI "SAVE "+fi$+" "+STR$~program%+"+"+STR$~(FNprglen+4+1)
36880OSCLI "SETTYPE "+fi$+" Data"
36890ENDIF
36900ENDPROC
36910
36920DEF PROCsave_text(fi$)
36930IF fi$="" THEN
36940PROCerror(16,"")
36950ELSE
36960OSCLI "SAVE "+fi$+" "+STR$~text%+" "+STR$~FNtext_end
36970OSCLI "SETTYPE "+fi$+" Data"
36980ENDIF
36990ENDPROC
37000
37010DEF PROCsave_dict(fi$)
37020IF fi$="" THEN
37030PROCerror(16,"")
37040ELSE
37050OSCLI "SAVE "+fi$+" "+STR$~dict%+" "+STR$~(dict%+?dict%+256*dict%?1)
37060OSCLI "SETTYPE "+fi$+" Data"
37070ENDIF
37080ENDPROC
37090
37100DEF PROCload_all(f$)
37110REM f$ is the full pathname
37120SYS "Hourglass_On"
37130PROCclose(texthandle):PROCclose(objhandle):PROCclose(roomhandle)
37140p$=f$:f$=FNleafname(p$)
37150p$=LEFT$(p$,LEN(p$)-LEN(f$))
37160d$=p$+"Alps."
37170r$=p$+"Resources"
37180OSCLI("SET Users$Resources "+r$)
37190OSCLI("SET Alps$Pictures "+p$+"Pictures.")
37200OSCLI("SET Alps$Data "+d$)
37210PROCload_objs("<Alps$Data>Objects")
37220PROCload_rooms("<Alps$Data>Rooms")
37230PROCload_flags("<Alps$Data>Flags")
37240PROCload_pix("<Alps$Data>Pictures")
37250PROCload_vocab(f$)
37260PROCload_program("<Alps$Data>Program")
37270PROCload_text("<Alps$Data>Text")
37280PROCload_dict("<Alps$Data>Dict")
37290OSCLI("PRINT <Alps$Data>charset")
37300data_saved=TRUE:loaded$=f$:$filename%=f$
37310SYS "Hourglass_Off"
37320ENDPROC
37330
37340DEF PROCload_vocab(f$)
37350IF f$="" THEN
37360PROCerror(16,"")
37370ELSE
37380PROCload_nouns("<Alps$Data>Nouns")
37390PROCload_verbs("<Alps$Data>Verbs")
37400PROCload_adjects("<Alps$Data>Adjectives")
37410PROCload_preps("<Alps$Data>Prepos")
37420PROCload_conj("<Alps$Data>Conjunc")
37430PROCload_spec("<Alps$Data>Specials")
37440PROCload_noise("<Alps$Data>Noise")
37450PROCload_vtypes("<Alps$Data>VerbType")
37460PROCload_nrefs("<Alps$Data>Nref")
37470PROCload_arefs("<Alps$Data>Aref")
37480ENDIF
37490ENDPROC
37500
37510DEF PROCload_nouns(fi$)
37520IF fi$="" THEN
37530PROCerror(16,"")
37540ELSE
37550OSCLI "LOAD "+fi$+" "+STR$~nouns
37560obn=?nouns
37570nxtobj=nouns+(nouns?1+256*(nouns?2))
37580ENDIF
37590ENDPROC
37600
37610DEF PROCload_verbs(fi$)
37620IF fi$="" THEN
37630PROCerror(16,"")
37640ELSE
37650OSCLI "LOAD "+fi$+" "+STR$~verbs
37660vbn=?verbs
37670nxtvrb=verbs+(verbs?1+256*(verbs?2))
37680ENDIF
37690ENDPROC
37700
37710DEF PROCload_adjects(fi$)
37720IF fi$="" THEN
37730PROCerror(16,"")
37740ELSE
37750OSCLI "LOAD "+fi$+" "+STR$~adjects
37760adn=?adjects
37770nxtadj=adjects+(adjects?1+256*(adjects?2))
37780ENDIF
37790ENDPROC
37800
37810DEF PROCload_preps(fi$)
37820IF fi$="" THEN
37830PROCerror(16,"")
37840ELSE
37850OSCLI "LOAD "+fi$+" "+STR$~preps
37860prn=?preps
37870nxtprp=preps+(preps?1+256*(preps?2))
37880ENDIF
37890ENDPROC
37900
37910DEF PROCload_conj(fi$)
37920IF fi$="" THEN
37930PROCerror(16,"")
37940ELSE
37950OSCLI "LOAD "+fi$+" "+STR$~conjs
37960cjn=?conjs
37970nxtcjn=conjs+(conjs?1+256*(conjs?2))
37980ENDIF
37990ENDPROC
38000
38010DEF PROCload_spec(fi$)
38020IF fi$="" THEN
38030PROCerror(16,"")
38040ELSE
38050OSCLI "LOAD "+fi$+" "+STR$~specs
38060spn=?specs
38070nxtspn=specs+(specs?1+256*(specs?2))
38080ENDIF
38090ENDPROC
38100
38110DEF PROCload_noise(fi$)
38120IF fi$="" THEN
38130PROCerror(16,"")
38140ELSE
38150OSCLI "LOAD "+fi$+" "+STR$~noise
38160nsn=?noise
38170nxtnsn=noise+(noise?1+256*(noise?2))
38180ENDIF
38190ENDPROC
38200
38210DEF PROCload_vtypes(fi$)
38220IF fi$="" THEN
38230PROCerror(16,"")
38240ELSE
38250OSCLI "LOAD "+fi$+" "+STR$~verb_type
38260ENDIF
38270ENDPROC
38280
38290DEF PROCload_arefs(fi$)
38300IF fi$="" THEN
38310PROCerror(16,"")
38320ELSE
38330OSCLI "LOAD "+fi$+" "+STR$~aref
38340ENDIF
38350ENDPROC
38360
38370DEF PROCload_nrefs(fi$)
38380IF fi$="" THEN
38390PROCerror(16,"")
38400ELSE
38410OSCLI "LOAD "+fi$+" "+STR$~nref
38420ENDIF
38430ENDPROC
38440
38450DEF PROCload_objs(fi$)
38460IF fi$="" THEN
38470PROCerror(16,"")
38480ELSE
38490OSCLI "LOAD "+fi$+" "+STR$~odata%
38500optr=odata%?14
38510last_object=odata%?15
38520ENDIF
38530ENDPROC
38540
38550DEF PROCload_rooms(fi$)
38560IF fi$="" THEN
38570PROCerror(16,"")
38580ELSE
38590OSCLI "LOAD "+fi$+" "+STR$~rdata%
38600rptr=!rdata% AND &FFFF
38610last_room=(!rdata% AND &FFFF0000)>>16
38620ENDIF
38630ENDPROC
38640
38650DEF PROCload_flags(fi$)
38660IF fi$="" THEN
38670PROCerror(16,"")
38680ELSE
38690chn%=OPENIN fi$
38700FOR f%=0 TO 7
38710INPUT#chn%,flag$
38720$(o_flags%+f%*maxd%)=flag$
38730NEXT
38740
38750FOR f%=0 TO 7
38760INPUT#chn%,flag$
38770$(r_flags%+f%*maxd%)=flag$
38780NEXT
38790CLOSE#chn%
38800ENDIF
38810ENDPROC
38820
38830DEF PROCload_pix(fi$)
38840IF fi$="" THEN
38850PROCerror(16,"")
38860ELSE
38870OSCLI "LOAD "+fi$+" "+STR$~pixs
38880pxn=?pixs
38890nxtpxn=pixs+(pixs?1+256*(pixs?2))
38900ENDIF
38910ENDPROC
38920
38930DEF PROCload_program(fi$)
38940IF fi$="" THEN
38950PROCerror(16,"")
38960ELSE
38970OSCLI "LOAD "+fi$+" "+STR$~program%
38980ENDIF
38990ENDPROC
39000
39010DEF PROCload_text(fi$)
39020IF fi$="" THEN
39030PROCerror(16,"")
39040ELSE
39050OSCLI "LOAD "+fi$+" "+STR$~text%
39060mptr=1
39070ENDIF
39080ENDPROC
39090
39100DEF PROCload_dict(fi$)
39110LOCAL I%,L%
39120IF fi$="" THEN
39130PROCerror(16,"")
39140ELSE
39150OSCLI "LOAD "+fi$+" "+STR$~dict%
39160tok%=dict%?2:L%=0
39170IF tok%=0 tok%=128 ELSE tok%-=128
39180FOR I%=1 TO tok%
39190tok$(I%)=$(dict%+3+L%)
39200L%+=LENtok$(I%)+1
39210NEXT
39220ENDIF
39230ENDPROC
39240
39250DEF PROCsetup_disk(S%)
39260PROCgetw(setuph):PROCgetpointer
39270PROCopen(setuph,mousex%-64,mousey%,x1%-x0%,y1%-y0%)
39280PROCsys_claiminputfocus(setuph,2,0,0,-1,LEN(FNgeticondata(setuph,2)))
39290PROCgetw(setuph)
39300MOUSE RECTANGLE x0%,y0%,x1%-x0%,y1%-y0%
39310dialogue%=S%
39320ENDPROC
39330
39340DEF PROCquit(S%)
39350IF NOT data_saved THEN
39360ans = FNerrorbox("There is unsaved data in the memory. Do you really want to quit?",0,3,S%)
39370ELSE
39380quit%=TRUE
39390ENDIF
39400ENDPROC
39410
39420DEF PROCensure(S%,T$)
39430dialogue%=FNerrorbox(T$,0,3,S%)
39440ENDPROC
39450
39460
39470REM ------ Vocabulary routines ------
39480
39490DEF PROCgetobn(text$,RETURN num,RETURN found$)
39500sptr=nouns+3:PROCsearch(sptr,text$,num,found$)
39510ENDPROC
39520
39530DEF PROCgetvbn(text$,RETURN num,RETURN found$)
39540sptr=verbs+3:PROCsearch(sptr,text$,num,found$)
39550ENDPROC
39560
39570DEF PROCgetadn(text$,RETURN num,RETURN found$)
39580sptr=adjects+3:PROCsearch(sptr,text$,num,found$)
39590ENDPROC
39600
39610DEF PROCgetprn(text$,RETURN num,RETURN found$)
39620sptr=preps+3:PROCsearch(sptr,text$,num,found$)
39630ENDPROC
39640
39650DEF PROCgetcjn(text$,RETURN num,RETURN found$)
39660sptr=conjs+3:PROCsearch(sptr,text$,num,found$)
39670ENDPROC
39680
39690DEF PROCgetspn(text$,RETURN num,RETURN found$)
39700sptr=specs+3:PROCsearch(sptr,text$,num,found$)
39710ENDPROC
39720
39730DEF PROCgetnsn(text$,RETURN num,RETURN found$)
39740sptr=noise+3:PROCsearch(sptr,text$,num,found$)
39750ENDPROC
39760
39770DEF PROCsearch(sptr,search$,RETURN number,RETURN temp$)
39780LOCAL temp$,found
39790number=0
39800F%=work%:B%=sptr:$(work%+&128)=search$:REM put search string in 'text'
39810CALL search
39820number=!(work%+&148)
39830ENDPROC
39840
39850DEF PROCword(type,line$)
39860REM Add words to the vocabulary or picture list
39870REM word types are - nouns = 1, verbs = 2, adjectives = 3
39880REM prepositions = 4, conjunctions = 5, specials = 6
39890REM picture names = 10
39900LOCAL index,ptr,I%,len,len2,temp$
39910
39920IF line$="" THEN ENDPROC
39930
39940WHILE INSTR("0123456789=",LEFT$(line$,1))<>0
39950line$=MID$(line$,2)
39960ENDWHILE
39970
39980WHILE LEFT$(line$,1)=" "
39990line$=MID$(line$,2)
40000ENDWHILE
40010
40020IF type<4 OR type=10 THEN
40030end=INSTR(line$,"<"):IF end=0 THEN PROCerror(22,""):errflag=TRUE:ENDPROC
40040number$=MID$(line$,end+1):line$=LEFT$(line$,end-1)
40050IF RIGHT$(number$,1)=">" THEN number$=LEFT$(number$,LENnumber$-1)
40060ELSE
40070number$=""
40080ENDIF
40090
40100IF number$="" THEN
40110CASE type OF
40120WHEN 1,3
40130number$=STR$(obn)
40140WHEN 2
40150number$="0":REM Default verb type is zero
40160OTHERWISE
40170number$=""
40180ENDCASE
40190ENDIF
40200
40210index=0
40220ptr=INSTR(line$,",")
40230IF ptr=0 THEN
40240a_list$(index)=LEFT$(line$,maxlen)
40250ELSE
40260WHILE ptr<>0 AND index<11
40270temp$=LEFT$(line$,ptr-1)
40280len=LEN(line$)
40290line$=RIGHT$(line$,len-ptr)
40300a_list$(index)=LEFT$(temp$,maxlen)
40310index+=1
40320ptr=INSTR(line$,",")
40330ENDWHILE
40340a_list$(index)=LEFT$(line$,maxlen)
40350ENDIF
40360
40370CASE type OF
40380
40390WHEN 1
40400IF obn=maxobn THEN
40410PROCerror(17,"at "+a_list$(0)):errflag=TRUE
40420ELSE
40430FOR I%=0 TO index
40440 len2=LEN a_list$(I%)
40450 IF len2>0 THEN
40460 PROCgetobn(a_list$(I%),num,fnd$)
40470 IF num<>0 PROCerror(5,a_list$(I%)):errflag=TRUE
40480 IF nxtobj+len2>noun_end-2 PROCerror(13,error$(38)):errflag=TRUE
40490 IF NOT errflag THEN
40500 $nxtobj=a_list$(I%):?(nxtobj+len2-1)=?(nxtobj+len2-1) OR 128
40510 nxtobj+=len2:?nxtobj=obn:nxtobj+=1:?nxtobj=&FF
40520 ENDIF
40530 ENDIF
40540NEXT I%
40550 IF NOT errflag THEN
40560 obn+=1
40570 ?nouns=obn:nouns?1=(nxtobj-nouns) MOD 256:nouns?2=(nxtobj-nouns) DIV 256
40580 ptr=1:memptr=nref+!nref:svmptr=memptr:refs=0:memptr+=1
40590 REPEAT
40600 PROCdecode_parameter(number$,ptr,ptr,val,0)
40610 IF NOT errflag THEN ?memptr=val:memptr+=1:refs+=1
40620 UNTIL ptr>LENnumber$ OR errflag
40630 ?memptr=0:!nref=!nref+refs+1
40640 ?svmptr=refs
40650 ENDIF
40660ENDIF
40670WHEN 2
40680IF vbn=maxvbn THEN
40690PROCerror(18,"at "+a_list$(0)):errflag=TRUE
40700ELSE
40710FOR I%=0 TO index
40720 len2=LEN a_list$(I%)
40730 IF len2>0 THEN
40740 PROCgetvbn(a_list$(I%),num,fnd$)
40750 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
40760 IF nxtvrb+len2>verb_end-2 PROCerror(13,error$(39)):errflag=TRUE
40770 IF NOT errflag THEN
40780 $nxtvrb=a_list$(I%):?(nxtvrb+len2-1)=?(nxtvrb+len2-1) OR 128
40790 nxtvrb+=len2:?nxtvrb=vbn:nxtvrb+=1:?nxtvrb=&FF
40800 ENDIF
40810 ENDIF
40820NEXT I%
40830IF NOT errflag THEN
40840ptr=1
40850PROCdecode_parameter(number$,ptr,ptr,val,0)
40860IF NOT errflag THEN
40870verb_type?(2*vbn)=val
40880oloc$=MID$(number$,ptr+1):olocflg=0
40890IF INSTR(oloc$,"C")<>0 THEN olocflg=1
40900IF INSTR(oloc$,"P")<>0 THEN olocflg=olocflg OR 2
40910verb_type?(2*vbn+1)=olocflg
40920vbn+=1
40930?verbs=vbn:verbs?1=(nxtvrb-verbs) MOD 256:verbs?2=(nxtvrb-verbs) DIV 256
40940ENDIF
40950ENDIF
40960ENDIF
40970WHEN 3
40980IF adn=maxadj THEN
40990PROCerror(19,"at "+a_list$(0)):errflag=TRUE
41000ELSE
41010FOR I%=0 TO index
41020 len2=LEN a_list$(I%)
41030 IF len2>0 THEN
41040 PROCgetadn(a_list$(I%),num,fnd$)
41050 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
41060 IF nxtadj+len2>adjc_end-2 PROCerror(13,error$(40)):errflag=TRUE
41070 IF NOT errflag THEN
41080 $nxtadj=a_list$(I%):?(nxtadj+len2-1)=?(nxtadj+len2-1) OR 128
41090 nxtadj+=len2:?nxtadj=adn:nxtadj+=1:?nxtadj=&FF
41100 ENDIF
41110 ENDIF
41120NEXT I%
41130 IF NOT errflag THEN
41140adn+=1
41150?adjects=adn:adjects?1=(nxtadj-adjects) MOD 256:adjects?2=(nxtadj-adjects) DIV 256
41160 ptr=1:memptr=aref+!aref:svmptr=memptr:refs=0:memptr+=1
41170 REPEAT
41180 PROCdecode_parameter(number$,ptr,ptr,val,0)
41190 IF NOT errflag THEN ?memptr=val:memptr+=1:refs+=1
41200 UNTIL ptr>LENnumber$ OR errflag
41210 ?memptr=0:!aref=!aref+refs+1
41220 ?svmptr=refs
41230 ENDIF
41240ENDIF
41250WHEN 4
41260IF prn=maxprep THEN
41270PROCerror(20,"at "+a_list$(0)):errflag=TRUE
41280ELSE
41290FOR I%=0 TO index
41300 len2=LEN a_list$(I%)
41310 IF len2>0 THEN
41320 PROCgetprn(a_list$(I%),num,fnd$)
41330 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
41340 IF nxtprp+len2>prep_end-2 PROCerror(13,error$(41)):errflag=TRUE
41350 IF NOT errflag THEN
41360 $nxtprp=a_list$(I%):?(nxtprp+len2-1)=?(nxtprp+len2-1) OR 128
41370 nxtprp+=len2:?nxtprp=prn:nxtprp+=1:?nxtprp=&FF
41380 ENDIF
41390 ENDIF
41400NEXT I%
41410 IF NOT errflag THEN
41420 prn+=1
41430 ?preps=prn:preps?1=(nxtprp-preps) MOD 256:preps?2=(nxtprp-preps) DIV 256
41440 ENDIF
41450ENDIF
41460WHEN 5
41470IF cjn=maxconj THEN
41480PROCerror(21,"at "+a_list$(0)):errflag=TRUE
41490ELSE
41500FOR I%=0 TO index
41510 len2=LEN a_list$(I%)
41520 IF len2>0 THEN
41530 PROCgetcjn(a_list$(I%),num,fnd$)
41540 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
41550 IF nxtcjn+len2>conj_end-2 PROCerror(13,error$(42)):errflag=TRUE
41560 IF NOT errflag THEN
41570 $nxtcjn=a_list$(I%):?(nxtcjn+len2-1)=?(nxtcjn+len2-1) OR 128
41580 nxtcjn+=len2:?nxtcjn=cjn:nxtcjn+=1:?nxtcjn=&FF
41590 ENDIF
41600 ENDIF
41610NEXT I%
41620 IF NOT errflag THEN
41630 cjn+=1
41640 ?conjs=cjn:conjs?1=(nxtcjn-conjs) MOD 256:conjs?2=(nxtcjn-conjs) DIV 256
41650 ENDIF
41660ENDIF
41670WHEN 6
41680IF spn=maxspec THEN
41690PROCerror(24,"at "+a_list$(0)):errflag=TRUE
41700ELSE
41710FOR I%=0 TO index
41720 len2=LEN a_list$(I%)
41730 IF len2>0 THEN
41740 PROCgetspn(a_list$(I%),num,fnd$)
41750 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
41760 IF nxtspn+len2>spec_end-2 PROCerror(13,error$(43)):errflag=TRUE
41770 IF NOT errflag THEN
41780 $nxtspn=a_list$(I%):?(nxtspn+len2-1)=?(nxtspn+len2-1) OR 128
41790 nxtspn+=len2:?nxtspn=spn:nxtspn+=1:?nxtspn=&FF
41800 ENDIF
41810 ENDIF
41820NEXT I%
41830 IF NOT errflag THEN
41840 spn+=1
41850 ?specs=spn:specs?1=(nxtspn-specs) MOD 256:specs?2=(nxtspn-specs) DIV 256
41860 ENDIF
41870ENDIF
41880WHEN 7
41890IF nsn=maxnoise THEN
41900PROCerror(25,"at "+a_list$(0)):errflag=TRUE
41910ELSE
41920FOR I%=0 TO index
41930 len2=LEN a_list$(I%)
41940 IF len2>0 THEN
41950 PROCgetnsn(a_list$(I%),num,fnd$)
41960 IF num<>0 PROCerror(8,a_list$(I%)):errflag=TRUE
41970 IF nxtnsn+len2>noise_end-2 PROCerror(13,error$(44)):errflag=TRUE
41980 IF NOT errflag THEN
41990 $nxtnsn=a_list$(I%):?(nxtnsn+len2-1)=?(nxtnsn+len2-1) OR 128
42000 nxtnsn+=len2:?nxtnsn=nsn:nxtnsn+=1:?nxtnsn=&FF
42010 ENDIF
42020 ENDIF
42030NEXT I%
42040 IF NOT errflag THEN
42050 nsn+=1
42060 ?noise=nsn:noise?1=(nxtnsn-noise) MOD 256:noise?2=(nxtnsn-noise) DIV 256
42070 ENDIF
42080ENDIF
42090WHEN 10
42100IF pxn=maxpix THEN
42110PROCerror(26,"at "+a_list$(0)):errflag=TRUE
42120ELSE
42130FOR I%=0 TO index
42140 len2=LEN a_list$(I%)
42150 IF len2>0 THEN
42160 IF nxtpxn+len2>pix_end-2 PROCerror(13,error$(45)):errflag=TRUE
42170 IF NOT errflag THEN
42180 $nxtpxn=a_list$(I%):REM ?(nxtpxn+len2-1)=?(nxtpxn+len2-1) OR 128
42190 nxtpxn+=len2+1
42200 ENDIF
42210 ENDIF
42220NEXT I%
42230 IF NOT errflag THEN
42240 loc$=MID$(number$,1)
42250 IF loc$<>"" THEN
42260 IF INSTR("TBLR",loc$)<>0 THEN val=INSTR("TBLR",loc$)-1 ELSE val=0
42270 ELSE val=0
42280 ENDIF
42290 ?nxtpxn=val:nxtpxn+=5:?nxtpxn=&FF
42300 pxn+=1
42310 ?pixs=pxn:pixs?1=(nxtpxn-pixs) MOD 256:pixs?2=(nxtpxn-pixs) DIV 256
42320 ENDIF
42330ENDIF
42340ENDCASE
42350ENDPROC
42360
42370DEF PROCgetstr(test$,place,RETURN place,RETURN result$)
42380chr$=MID$(test$,place,1)
42390IF chr$=CHR$13 THEN result$="":ENDPROC
42400WHILE chr$=" " OR chr$="," place+=1
42410chr$=MID$(test$,place,1)
42420ENDWHILE
42430
42440IF chr$<>CHR$ 34 PROCerror(6," : "+line$):result$="":ENDPROC
42450place+=1
42460place2=INSTR(line$,CHR$34,place):IF place2<place PROCerror(6," : "+line$):result$="":ENDPROC
42470
42480result$=MID$(line$,place,place2-place)
42490place=place2+1
42500ENDPROC
42510
42520DEF PROClistnouns
42530LOCAL mptr,I%,J%,refs
42540IF obn=1 THEN ENDPROC
42550mptr=nref+4
42560FOR I%=1 TO obn-1
42570PROCput(STR$(I%)+"= ")
42580PROCpvok(I%,1,TRUE):PROCput(",<")
42590refs=?mptr
42600IF refs>0 THEN
42610FOR J%=1 TO refs
42620PROCput(STR$(J%?mptr))
42630IF J%<refs PROCput(",")
42640NEXT
42650ENDIF
42660mptr+=refs+1
42670PROCput(">"+CHR$13)
42680NEXT
42690PROCput(CHR$0)
42700ENDPROC
42710
42720DEF PROClistverbs
42730IF vbn=1 THEN ENDPROC
42740FOR I%=1 TO vbn-1
42750PROCput(STR$(I%)+"= ")
42760vtype=verb_type?(2*I%)
42770PROCpvok(I%,0,TRUE):PROCput(",<"+STR$(vtype))
42780olflg=verb_type?(2*I%+1):oloc$=""
42790IF vtype>0 THEN
42800IF (olflg AND 1)<>0 THEN oloc$+="C"
42810IF (olflg AND 2)<>0 THEN oloc$+="P"
42820PROCput(",")
42830ENDIF
42840PROCput(oloc$+">"+CHR$13)
42850NEXT
42860PROCput(CHR$0)
42870ENDPROC
42880
42890DEF PROClistadjs
42900LOCAL mptr,I%,J%,refs
42910IF adn=1 THEN ENDPROC
42920mptr=aref+4
42930FOR I%=1 TO adn-1
42940PROCput(STR$(I%)+"= ")
42950PROCpvok(I%,2,TRUE):PROCput(",<")
42960refs=?mptr
42970IF refs>0 THEN
42980FOR J%=1 TO refs
42990PROCput(STR$(J%?mptr))
43000IF J%<refs PROCput(",")
43010NEXT
43020ENDIF
43030mptr+=refs+1
43040PROCput(">"+CHR$13)
43050NEXT
43060PROCput(CHR$0)
43070ENDPROC
43080
43090DEF PROClistpreps
43100LOCAL I%,J%
43110IF prn=1 THEN ENDPROC
43120FOR I%=1 TO prn-1
43130PROCput(STR$(I%)+"= ")
43140PROCpvok(I%,3,TRUE):PROCput(CHR$13)
43150NEXT
43160PROCput(CHR$0)
43170ENDPROC
43180
43190DEF PROClistconjs
43200LOCAL I%,J%
43210IF cjn=1 THEN ENDPROC
43220FOR I%=1 TO cjn-1
43230PROCput(STR$(I%)+"= ")
43240PROCpvok(I%,4,TRUE):PROCput(CHR$13)
43250NEXT
43260PROCput(CHR$0)
43270ENDPROC
43280
43290DEF PROClistspecs
43300LOCAL I%,J%
43310IF spn=1 THEN ENDPROC
43320FOR I%=1 TO spn-1
43330PROCput(STR$(I%)+"= ")
43340PROCpvok(I%,5,TRUE):PROCput(CHR$13)
43350NEXT
43360PROCput(CHR$0)
43370ENDPROC
43380
43390DEF PROClistnoise
43400LOCAL I%,J%
43410IF nsn=1 THEN ENDPROC
43420FOR I%=1 TO nsn-1
43430PROCput(STR$(I%)+"= ")
43440PROCpvok(I%,6,TRUE):PROCput(CHR$13)
43450NEXT
43460PROCput(CHR$0)
43470ENDPROC
43480
43490DEF PROCstore_pix
43500SYS "Hourglass_On"
43510errflag=FALSE
43520pxn=1
43530nxtpxn=pixs:?nxtpxn=pxn:nxtpxn?1=3:nxtpxn?2=0:nxtpxn+=3:?nxtpxn=&FF
43540last%=FNfind_lastrow
43550FOR I%=0 TO last%
43560IF NOT errflag PROCword(10,FNrow(I%))
43570NEXT
43580SYS "Hourglass_Off"
43590
43600ENDPROC
43610
43620DEF PROCstore_vocab
43630SYS "Hourglass_On"
43640errflag=FALSE:PROCremove_markers
43650
43660CASE voc_sect% OF
43670WHEN 1
43680obn=1
43690nxtobj=nouns:?nxtobj=obn:nxtobj?1=3:nxtobj?2=0:nxtobj+=3:?nxtobj=&FF
43700!nref=4
43710WHEN 2
43720vbn=1
43730nxtvrb=verbs:?nxtvrb=vbn:nxtvrb?1=3:nxtvrb?2=0:nxtvrb+=3:?nxtvrb=&FF
43740WHEN 3
43750adn=1
43760nxtadj=adjects:?nxtadj=adn:nxtadj?1=3:nxtadj?2=0:nxtadj+=3:?nxtadj=&FF
43770!aref=4
43780WHEN 4
43790prn=1
43800nxtprp=preps:?nxtprp=prn:nxtprp?1=3:nxtprp?2=0:nxtprp+=3:?nxtprp=&FF
43810WHEN 5
43820cjn=1
43830nxtcjn=conjs:?nxtcjn=cjn:nxtcjn?1=3:nxtcjn?2=0:nxtcjn+=3:?nxtcjn=&FF
43840WHEN 6
43850spn=1
43860nxtspn=specs:?nxtspn=spn:nxtspn?1=3:nxtspn?2=0:nxtspn+=3:?nxtspn=&FF
43870WHEN 7
43880nsn=1
43890nxtnsn=noise:?nxtnsn=nsn:nxtnsn?1=3:nxtnsn?2=0:nxtnsn+=3:?nxtnsn=&FF
43900ENDCASE
43910last%=FNfind_lastrow
43920
43930FOR I%=0 TO last%
43940 IF NOT errflag PROCword(voc_sect%,FNrow(I%))
43950NEXT
43960IF NOT errflag text_ok=TRUE
43970SYS "Hourglass_Off"
43980ENDPROC
43990
44000DEF FNfindnoun(obj,RETURN J%)
44010REM Finds the number of the noun referring to a specified object
44020LOCAL M%,I%,N%,found
44030M%=nref+4
44040WHILE N%<last_object AND NOT found
44050J%=?M%
44060IF J%>0 THEN
44070FOR I%=1 TO J%
44080IF M%?I%=obj THEN found=TRUE
44090NEXT
44100ENDIF
44110M%+=J%+1
44120N%+=1
44130ENDWHILE
44140IF found THEN=N% ELSE=0
44150
44160
44170DEF PROCwhich_obj(N%,RETURN V$,RETURN R%)
44180REM Returns a string containing the objects referenced by noun N%
44190REM R%=number of objects referenced
44200LOCAL M%,found,I%,J%,K%
44210
44220M%=nref+4
44230IF N%>1 THEN
44240FOR K%=1 TO N%-1
44250 J%=?M%
44260 M%+=J%+1
44270NEXT
44280ENDIF
44290J%=?M%
44300R%=J%:V$=""
44310IF J%>0 THEN
44320FOR I%=1 TO J%
44330 V$+=STR$(I%?M%)+","
44340NEXT
44350ENDIF
44360ENDPROC
44370
44380DEF PROCpvok(num,type,all)
44390LOCAL temp$,found,ctr
44400IF num=0 THEN ENDPROC
44410
44420CASE type OF
44430WHEN 0: sptr=verbs+3
44440WHEN 1: sptr=nouns+3
44450WHEN 2: sptr=adjects+3
44460WHEN 3: sptr=preps+3
44470WHEN 4: sptr=conjs+3
44480WHEN 5: sptr=specs+3
44490WHEN 6: sptr=noise+3
44500WHEN 10: sptr=pixs+3
44510ENDCASE
44520
44530A%=num:B%=sptr
44540IF NOT all THEN
44550CALL pvok:temp$=$atext:IF temp$<>"" PROCput(temp$)
44560ELSE
44570?pvokflag=0
44580REPEAT
44590CALL pvok
44600IF ?pvokflag=0 THEN
44610IF ctr>0 THEN PROCput(",")
44620temp$=$atext:IF temp$<>"" PROCput(temp$)
44630ctr+=1:B%=!address
44640ENDIF
44650UNTIL ?pvokflag>0
44660ENDIF
44670ENDPROC
44680
44690DEF PROCnonspc(str$,place,RETURN place,RETURN chr$)
44700WHILE MID$(str$,place,1)=" "
44710 place+=1
44720ENDWHILE
44730chr$=MID$(str$,place,1)
44740ENDPROC
44750
44760DEF PROCdodefn
44770IF vbn=maxvbn PROCerror(11,": "+STR$(maxvbn)+" "+error$(46)):ENDPROC
44780?prgptr=def_token:prgptr+=1
44790
44800PROCgetstr(line$,ptr,ptr,vrb$):index=0
44810IF errflag THEN ENDPROC
44820REM WHILE vrb$<>"" AND index<11
44830a_list$(index)=vrb$:index+=1
44840REM PROCgetstr(line$,ptr,ptr,vrb$)
44850REM ENDWHILE
44860
44870IF vrb$="" PROCerror(1,error$(47)):ENDPROC
44880
44890IF errflag THEN ENDPROC
44900
44910flag=FALSE:index-=1
44920FOR I%=0 TO index
44930 PROCgetvbn(a_list$(I%),num,fnd$)
44940 IF num<>0 AND NOT existing_verb PROCerror(8,a_list$(I%)):flag=TRUE
44950 oldvbn=num
44960NEXT I%
44970
44980IF NOT flag AND NOT existing_verb THEN
44990 FOR I%=0 TO index
45000 len2=LEN a_list$(I%)
45010 $nxtvrb=a_list$(I%):?(nxtvrb+len2-1)=?(nxtvrb+len2-1) OR 128
45020 nxtvrb+=len2:?nxtvrb=vbn:nxtvrb+=1
45030 NEXT I%
45040 ?prgptr=vbn:prgptr+=1:?nxtvrb=&FF:vbn+=1
45050 ?verbs=vbn:verbs?1=(nxtvrb-verbs) MOD 256:verbs?2=(nxtvrb-verbs) DIV 256
45060
45070ELSE
45080IF existing_verb THEN ?prgptr=oldvbn:prgptr+=1
45090ENDIF
45100
45110existing_verb=TRUE
45120ENDPROC
45130
45140DEF PROCprtdef
45150vrbnum=?listptr
45160PROCput(CHR$32+CHR$34):PROCpvok(vrbnum,0,FALSE):PROCput(CHR$34)
45170ENDPROC
45180
45190DEF FNfntype(parm)
45200LOCAL temp
45210IF token=prep_token OR token=notprep_token THEN =3
45220temp=parm AND %01000000:REM check if `object` function
45230IF temp<>0 THEN=1
45240temp=parm AND %00100000:REM check if `verb` function
45250IF temp<>0 THEN=2 ELSE =0
45260
45270DEF PROCprntobj
45280LOCAL num
45290objnum=?listptr
45300IF objnum>last_object THEN ENDPROC
45310num=FNfindnoun(objnum,refs)
45320IF refs=1 THEN
45330PROCput(CHR$34):PROCpvok(num,1,FALSE):PROCput(CHR$34)
45340doneit=TRUE
45350ENDIF
45360ENDPROC
45370
45380DEF PROCprntvrb
45390vrbnum=?listptr
45400IF vrbnum>=vbn THEN ENDPROC
45410PROCput(CHR$34):PROCpvok(vrbnum,0,FALSE):PROCput(CHR$34)
45420doneit=TRUE
45430ENDPROC
45440
45450DEF PROCprintprep
45460LOCAL num
45470num=?listptr
45480IF num>=prn THEN ENDPROC
45490PROCput(CHR$34):PROCpvok(num,3,FALSE):PROCput(CHR$34)
45500doneit=TRUE
45510ENDPROC
45520
45530DEF PROCcopy_from_editor
45540LOCAL ldptr,svptr,O%,I%,R%
45550svptr=initsave
45560FOR O%=last_object TO 0 STEP-1
45570ldptr=odata%+O%*o_len
45580!svptr=!ldptr:svptr+=4
45590?svptr=ldptr?12:svptr+=1
45600?svptr=ldptr?14:svptr+=1
45610?svptr=ldptr?15:svptr+=1
45620NEXT
45630FOR R%=last_room TO 0 STEP-1
45640ldptr=rdata%+R%*r_len
45650?svptr=?ldptr:svptr?1=ldptr?1:svptr+=2
45660FOR I%=54 TO 73 STEP4
45670!svptr=I%!ldptr:svptr+=4
45680NEXT
45690NEXT
45700ENDPROC
45710
45720DEF PROCcopy_to_editor
45730LOCAL ldptr,svptr,O%,I%,R%
45740ldptr=initsave
45750FOR O%=last_object TO 0 STEP-1
45760svptr=odata%+O%*o_len
45770!svptr=!ldptr:ldptr+=4
45780svptr?12=?ldptr:ldptr+=1
45790svptr?14=?ldptr:ldptr+=1
45800svptr?15=?ldptr:ldptr+=1
45810NEXT
45820FOR R%=last_room TO 0 STEP-1
45830svptr=rdata%+R%*r_len
45840?svptr=?ldptr:svptr?1=ldptr?1:ldptr+=2
45850FOR I%=54 TO 73 STEP4
45860I%!svptr=!ldptr:ldptr+=4
45870NEXT
45880NEXT
45890ENDPROC
45900
45910DEF PROCswap_data
45920LOCAL ldptr,svptr,O%,I%,R%,T%
45930ldptr=initsave
45940FOR O%=last_object TO 0 STEP-1
45950svptr=odata%+O%*o_len
45960T%=!svptr
45970!svptr=!ldptr:!ldptr=T%:ldptr+=4
45980T%=svptr?12
45990svptr?12=?ldptr:?ldptr=T%:ldptr+=1
46000T%=svptr?14
46010svptr?14=?ldptr:?ldptr=T%:ldptr+=1
46020T%=svptr?15
46030svptr?15=?ldptr:?ldptr=T%:ldptr+=1
46040NEXT
46050FOR R%=last_room TO 0 STEP-1
46060svptr=rdata%+R%*r_len
46070T%=?svptr:?svptr=?ldptr:?ldptr=T%:T%=svptr?1:svptr?1=ldptr?1:ldptr?1=T%:ldptr+=2
46080FOR I%=54 TO 73 STEP4
46090T%=I%!svptr
46100I%!svptr=!ldptr:!ldptr=T%:ldptr+=4
46110NEXT
46120NEXT
46130ENDPROC
46140
46150DEF FNerrorbox(err$,err%,Errorflags,fromPlace%)
46160SYS CreateM,,-1
46170SYS Poll,,block
46180!mistake = err%
46190IF NOT testing AND err%=29 THEN
46200 err$="Sorry - not implemented in this version": Errorflags=1
46210ENDIF
46220IF testing err$+=" (Error code: "+STR$(ERL)+")"
46230IF (err% AND &FF)=&C7 err$="Disk not formatted. Shall I format it now?":Errorflags=3
46240$(mistake+4) = err$+CHR$(0)
46250IF fromPlace%<>-99 THEN Errorflags=Errorflags OR 16:t$="Message from ALPS" ELSE t$="ALPS"
46260SYS "Wimp_ReportError",mistake,Errorflags,t$ TO ,dialogue%
46270ok = (dialogue%=1)
46280
46290IF (err% AND &FF)=&C7 AND ok THEN
46300 *FORMAT 0 E Y
46310 PROCcreate_dirs(FNgeticondata(setuph,2),FNgeticondata(setuph,5))
46320ENDIF
46330
46340CASE fromPlace% OF
46350WHEN -99: REM *** a proper error ***
46360WHEN 0:IF ok THEN PROCsave_all(path$)
46370WHEN 1:IF ok THEN PROCload_all(path$):PROCopen(ALPSmain,400,800,600,600)
46380WHEN 2:IF ok THEN PROCcreate_dirs
46390WHEN 3:IF ok THEN
46400quit%=TRUE
46410SYS "Wimp_GetCaretPosition",,quitblk+20 :REM Fill up first 5 words
46420quitblk!44=&1FC :REM CTRL-SHIFT-f12
46430!quitblk=48 :REM Size of message block
46440quitblk!12=0
46450quitblk!16=8 :REM Send Key_Pressed message
46460SYS "Wimp_SendMessage",17,quitblk,prequittask%
46470ENDIF
46480WHEN 4:IF ok THEN quit%=TRUE
46490ENDCASE
46500=dialogue%
46510
46520
46530DEF FNOS_Var(V$)
46540SYS "XOS_ReadVarVal",V$,0,-1 TO ,,exists
46550=exists
46560
46570DEF FNReadVarVal(V$)
46580DIM vblk 32
46590SYS "XOS_ReadVarVal",V$,vblk,32,,0,3 TO ,,N%
46600vblk?N%=13
46610=$vblk
46620
46630DEF FNiconbar(sprBlk, spname$, xx,yy)
46640!qBlk%=-1
46650qBlk%!4=0:qBlk%!8=0:qBlk%!12=xx*2:qBlk%!16=yy*4
46660qBlk%!20=&2102
46670DIM qBlk%!24 (LENspname$+1):$(qBlk%!24)=spname$
46680qBlk%!28=sprBlk
46690qBlk%!32=LENspname$+1
46700SYS "Wimp_CreateIcon",,qBlk% TO theIc%
46710=theIc%
46720
46730
46740DEF PROCreceive(block)
46750ref%=block!8
46760CASE block!16 OF
46770 WHEN 0 :quit%=TRUE
46780 WHEN 2 :REM SaveAck from Filer/another app.
46790 path$=FNname(block+44)
46800 PROCsave_all(path$)
46810 !block=64:block!12=block!8:block!16=3
46820 SYS "Wimp_SendMessage",17,block,block!20,block!24
46830 WHEN 3,5 :PROCload(block)
46840 WHEN 8 :REM PreQuit
46850 IF NOT data_saved THEN
46860 prequittask%=block!4
46870 bytes=!block
46880 FOR I%=0 TO bytes
46890 quitblk!I%=block!I%
46900 NEXT
46910 quitblk!12=quitblk!8
46920 block!12=block!8
46930 SYS "Wimp_SendMessage",19,block
46940 ans = FNerrorbox("There is unsaved data in the memory. Do you really want to quit?",0,3,3)
46950 ENDIF
46960 WHEN &502:PROChelp(block!32,block!36,block)
46970 WHEN &400C1:REM mode change
46980 mode%=MODE
46990 PROCgetmodeinfo
47000 PROCassemble(armcode%):REM Need to allow for different screen size
47010 IF scrnsize>oldsize THEN null=FNerrorbox("Warning! It may not be possible to display pictures in this mode due to memory restrictions. To display pictures quit ALPS and restart in this mode.",0,1,5)
47020ENDCASE
47030ENDPROC
47040
47050DEF PROCload(b)
47060ourtype=EVAL("&"+type$)
47070IF b!40 = ourtype THEN
47080 path$=FNname(b+44)
47090 IF NOT data_saved THEN
47100 PROCLoadAck
47110 PROCensure(1,"Unsaved data in memory. Please confirm that you want to load this file.")
47120 ELSE
47130 PROCload_all(path$)
47140 PROCLoadAck
47150 PROCopen(ALPSmain,400,800,600,600)
47160 ENDIF
47170ENDIF
47180ENDPROC
47190
47200DEF PROCLoadAck
47210block!12=block!8:block!16=4:!block=64
47220SYS "Wimp_SendMessage",17,block,block!4
47230ENDPROC
47240
47250DEF PROCsave
47260path$=FNgeticondata(savehandle,2)
47270PROCgetpointer
47280block!20=64:block!32=0:block!36=1:REM DataSave MSG
47290block!40=handle%:block!44=icon%:block!48=mousex%:block!52=mousey%
47300block!56=10000:REM Estimated size of data???
47310block!60=EVAL("&"+type$):REM File type
47320$(block+64)=FNleafname(path$)+CHR$0
47330SYS "Wimp_SendMessage",17,block+20,handle%,icon%
47340ENDPROC
47350
47360DEF FNname(indx)
47370LOCAL f$,g$,p,i
47380
47390WHILE ?indx<>0
47400f$+=CHR$(?indx):indx+=1
47410ENDWHILE
47420=f$
47430
47440DEF FNleafname(f$)
47450p=1
47460REPEAT
47470i=INSTR(f$,"."):IF i<>0 p=i+1:MID$(f$,i,1)="#"
47480UNTIL i=0
47490f$=MID$(f$,p)
47500=f$
47510
47520DEF FNtick_objected
47530flags%=VAL(FNgeticondata(objhandle,8))
47540FOR fl%=7 TO 0 STEP -1
47550 flag%=flags% DIV 2^fl%
47560 flags%=flags% MOD 2^fl%
47570 ptr=(m_objflag+28+(7-fl%)*24)
47580 IF flag%=1 THEN
47590 ?ptr=?ptr OR 1
47600 ELSE ?ptr=?ptr AND %11111110
47610 ENDIF
47620NEXT fl%
47630=0
47640
47650DEF FNtick_message
47660 ptr=0
47670 FOR I%=1 TO maxsw%
47680 $(swdata%+ptr)=STR$(switch_vals(I%))
47690 ptr+=12
47700 IF I%>switch_vals(0) THEN
47710 ?(m_switch%+28+24*I%)=(?(m_switch%+28+24*I%) AND &FE)
47720 ELSE
47730 ?(m_switch%+28+24*I%)=(?(m_switch%+28+24*I%) OR 1)
47740 ENDIF
47750 NEXT
47760 $(m_text%+5)=STR$(mptr)
47770 IF switch_vals(0)<>0 THEN ?(m_switch%+28)=(?(m_switch%+28) AND &FE) ELSE ?(m_switch%+28)=(?(m_switch%+28) OR 1)
47780 IF overwrite THEN
47790 ?(m_text%+28+24)=?(m_text%+28+24) OR 1
47800 ?(m_text%+28)=?(m_text%+28) AND &FE
47810 ELSE
47820 ?(m_text%+28+24)=?(m_text%+28+24) AND &FE
47830 ?(m_text%+28)=?(m_text%+28) OR 1
47840 ENDIF
47850=0
47860
47870DEF FNtick_program
47880 IF overwrite THEN
47890 ?(m_prog%+28+24)=?(m_prog%+28+24) OR 1
47900 ?(m_prog%+28)=?(m_prog%+28) AND &FE
47910 ELSE
47920 ?(m_prog%+28+24)=?(m_prog%+28+24) AND &FE
47930 ?(m_prog%+28)=?(m_prog%+28) OR 1
47940 ENDIF
47950 IF (listoption AND %10)<>0 THEN
47960 ?(m_listopts+28+24)=?(m_listopts+28+24) OR 1
47970 ?(m_listopts+28)=?(m_listopts+28) AND &FE
47980 ELSE
47990 ?(m_listopts+28+24)=?(m_listopts+28+24) AND &FE
48000 ?(m_listopts+28)=?(m_listopts+28) OR 1
48010 ENDIF
48020=0
48030
48040DEF FNtick_vocab
48050 IF overwrite THEN
48060 ?(m_vocab%+28+24)=?(m_vocab%+28+24) OR 1
48070 ?(m_vocab%+28)=?(m_vocab%+28) AND &FE
48080 ELSE
48090 ?(m_vocab%+28+24)=?(m_vocab%+28+24) AND &FE
48100 ?(m_vocab%+28)=?(m_vocab%+28) OR 1
48110 ENDIF
48120 FOR I%=1 TO 7
48130 IF I%=voc_sect% THEN
48140 ?(m_vocab%+28+24*(I%+4))=?(m_vocab%+28+24*(I%+4)) OR 1
48150 ELSE
48160 ?(m_vocab%+28+24*(I%+4))=?(m_vocab%+28+24*(I%+4)) AND &FE
48170 ENDIF
48180 NEXT I%
48190=0
48200
48210
48220DEF FNtick_
48230=0
48240
48250
48260DEF FNtick_roomedit
48270REM First set the 'tick' bits for each menu item
48280flags%=VAL(FNgeticondata(roomhandle,34))
48290FOR fl%=7 TO 0 STEP -1
48300 flag%=flags% DIV 2^fl%
48310 flags%=flags% MOD 2^fl%
48320 ptr=(m_rmflag+28+(7-fl%)*24)
48330 IF flag%=1 THEN
48340 ?ptr=?ptr OR 1
48350 ELSE ?ptr=?ptr AND %11111110
48360 ENDIF
48370NEXT fl%
48380=0
48390
48400
48410DEF FNtick_exitedit
48420REM First set the 'tick' bits for each menu item
48430flags%=?(rdata%+rptr*r_len+oldrmicon%)
48440FOR fl%=7 TO 0 STEP -1
48450 flag%=flags% DIV 2^fl%
48460 flags%=flags% MOD 2^fl%
48470 ptr=(m_exitf+28+(7-fl%)*24)
48480 IF flag%=1 THEN
48490 ?ptr=?ptr OR 1
48500 ELSE ?ptr=?ptr AND %11111110
48510 ENDIF
48520NEXT fl%
48530=0
48540
48550
48560DEF FNbutton_misc
48570icon%(THEmiscicon)=-1
48580=0
48590
48600
48610DEF FNtick_misc
48620 ptr=(miscmenu+28+48)
48630 IF datavalid THEN
48640 ?ptr = ?ptr OR 1
48650 ELSE
48660 ?ptr = ?ptr AND %11111110
48670 ENDIF
48680=0
48690
48700
48710DEF PROChelp(w,h,b)
48720LOCAL help$
48730CASE w OF
48740WHEN -2:help$="This is the ALPS icon.|MClick SELECT to choose an editor.|MClick MENU to quit.|MDrag an 'Alps' file icon to the ALPS icon to load it."
48750WHEN ALPSmain
48760help$="Click SELECT to open the "
48770CASE h OF
48780WHEN 0:help$="Click SELECT to Save files or Set up a disk for use with ALPS."
48790WHEN 1:help$="Click SELECT to display the ALPS variables and status."
48800WHEN 2:help$+="Room Editor and enter your map details.|MClick MENU Print the room data or Import BBC room data."
48810WHEN 3:help$+="Object Editor and enter your object details.|MClick MENU to Print the objects data or Import BBC objects data."
48820WHEN 4:help$+="Message Editor.|MClick MENU to Print the messages or Import BBC messages."
48830WHEN 5:help$="This is the Alpine Software logo. It has no effect."
48840WHEN 6:help$+="Program Editor and enter the game's logic.|MClick MENU to Print the program, Import a BBC program or Run the game."
48850WHEN 7:help$+="Character Designer.|MDouble-click a 'BBC font' file to Load a character set.|MCurrent character set is saved with your game."
48860WHEN 8:help$+="Vocabulary Editor and enter nouns, verbs, adjectives etc.|MClick MENU to Print the vocabulary."
48870WHEN 9:help$="Click SELECT to swap the original data in the editors with the data values obtained during a run of the game.|MA "+CHR$128+" indicates data is original. An X indicates post-run data."
48880WHEN 10:help$+="Picture Editor and edit the picture filenames.|MClick MENU to Print the Picture list."
48890OTHERWISE help$="Click SELECT to choose an editor.|MTo load an 'Alps' file, drag its icon to this window."
48900ENDCASE
48910WHEN roomhandle
48920help$="Click SELECT to "
48930CASE h OF
48940 WHEN 1:help$+="edit the room's flags."
48950 WHEN 5:help$+="display the first room's data."
48960 WHEN 6:help$+="display the last room's data."
48970 WHEN 7:help$+="display the next room's data."
48980 WHEN 8:help$+="display the previous room's data."
48990 WHEN 9:help$+="move forward 10 rooms."
49000 WHEN 10:help$+="move back 10 rooms."
49010 WHEN 11:help$+="enter the displayed data."
49020 WHEN 12:help$+="make this the last room."
49030 WHEN 54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69:help$="Click MENU to edit the exit flags."
49040 OTHERWISE help$=""
49050ENDCASE
49060WHEN objhandle
49070 help$="Click SELECT to "
49080 CASE h OF
49090 WHEN 0:help$+="edit the object's flags."
49100 WHEN 5:help$+="display the first object's data."
49110 WHEN 6:help$+="display the last object's data."
49120 WHEN 27:help$+="display the next object's data."
49130 WHEN 16:help$+="display the previous object's data."
49140 WHEN 20:help$+="move forward 10 objects."
49150 WHEN 21:help$+="move back 10 objects."
49160 WHEN 17:help$+="enter the displayed data."
49170 WHEN 22:help$+="make this the last object."
49180 WHEN 26:help$+="create a container."
49190 OTHERWISE help$=""
49200 ENDCASE
49210WHEN texthandle
49220help$="Click SELECT to position the caret.|MClick MENU to pop up a menu.|MClick ADJUST to insert a marker."
49230WHEN design
49240help$="Click SELECT to "
49250CASE TRUE OF
49260 WHEN h=66:help$+="display next character."
49270 WHEN h=67:help$+="display previous character."
49280 WHEN h=68:help$+="choose a different character."
49290 WHEN h=64:help$="This shows the character actual size."
49300 WHEN (h>=0 AND h<64):help$+="toggle this block."
49310 OTHERWISE help$="This is the Character Designer."
49320ENDCASE
49330ENDCASE
49340b!16=&503:REM Send a message
49350b!12=ref%
49360$(b+20)=help$
49370b!0=(((20+LEN(help$)+1)DIV4)*4)+4
49380$(b+21+LEN(help$))=CHR$(0)
49390SYS "Wimp_SendMessage",17,b
49400ENDPROC
49410
49420DEF PROCreadPalette
49430FOR col=0 TO 15
49440PROCreadpal(col,16)
49450rgb(col,1)=r%:rgb(col,2)=g%:rgb(col,3)=b%
49460NEXT
49470PROCreadpal(16,24)
49480rgb(16,1)=r%:rgb(16,2)=g%:rgb(16,3)=b%
49490FOR col=17 TO 19
49500PROCreadpal(col-16,25)
49510rgb(col,1)=r%:rgb(col,2)=g%:rgb(col,3)=b%
49520NEXT
49530ENDPROC
49540
49550DEF PROCreadpal(l%,p%)
49560REM Read the rgb values for logical/physical colour l%,p%
49570SYS ReadPal,l%,p% TO R0,R1,palette%
49580r%=(palette%>> 8)AND&FF
49590g%=(palette%>>16)AND&FF
49600b%=(palette%>>24)AND&FF
49610ENDPROC
� >$.!ALPS.!RunImage
5� Copyright Alpine Software/Philip Hawthorne 1989
*� With modifications by Keith McAlpine
(!version$="5.08C, 22-Nov-1989"
2
<(� block &200,mistake 300,quitblk 100
F
P-� � � 0:� �$:� ":";�:ș"Wimp_CloseDown":�
Z
d@%=&10:ctr%=0
nmode%=�
x
testing=�
�Aresources_ok=�OS_Var("Alps$Resources") � �OS_Var("Alps$Data")
�
�ș "OS_GetEnv" � Env$
�I%=�Env$,�34,�Env$,�34)+1)
�ef$=�Env$,I%+1)
�ȕ �ef$,1)=" "
�ef$=�ef$,2)
��
�
�theLastMenu = 0 : tick$=""
�
�type$="CF8"
�
� tempBlk 4
$tempBlk = "TASK"
5ș "Wimp_Initialise",200,!tempBlk,"ALPS" � ,task%
"
,�� � resources_ok � � 1,"The ALPS resources are not available. Open up the directory viewer with !ALPS in it.":ș "Wimp_CloseDown",task%,!tempBlk:�
6�install_texted
@
�init2
J+� � dialog=�errorbox(�$,�,1,-99):� �dtA
T�new
^�assemble(armcode%)
h0�fill(text_block%,text_blocksize%,dummy_spc)
r#�fill(verb_type,2*(maxvbn+1),0)
|�fill(nref+4,nref_size-4,0)
��fill(aref+4,aref_size-4,0)
�
�clear
�'claimpoll$="":claimmenu$="":quit%=�
�
�
path$=ef$
�� ef$<>"" �
�$filename%=�leafname(ef$)
��load_all(ef$)
�#�open(ALPSmain,400,800,600,600)
��
�
��
�ș Poll,,block � reason
Ȏ reason �
� 1: �redraw(!block)
� 2: ș OpenW,,block
& � 3: �close(!block)
0H � 6: �checkmouse(!block,block!4,block!8,block!12,block!16,block!20)
:E � 7: �save:� User has dragged 'Alps' file icon to another window
D2 � 8: �userkeypressed(!block,block!4,block!24)
N% � 9: �menuselect(!block,block!4)
X � 17,18: �receive(block)
b �
l� quit%
vNș "Wimp_CloseDown",task%,!tempBlk:� testing � �("FX4"):�:�" at line ";�:�
��
�
�� �init2
�!�getmodeinfo:oldsize=scrnsize
�data_saved=�:loaded$=""
�� a_list$(10)
�small_areasize%=30
�!� small_area% small_areasize%
�
�(� D%(3),shade%(15),scale 15,pixtr 15
�'� ---------------------------------
�'� Manifest constants for the system
�
2maxrms=1000:maxobs=255:maxsw%=10:maxtokens=128
listoption=2:� Default LISTO
*
� pos$(3)
4� I%=0 � 3:� pos$(I%):�
>
� T,B,L,R
H
R� oldpars 73
\� I%=0 � 72
f� B%:oldpars?I%=B% � &F
p�
z
�� 0,0,0,0,0,1,161,193
�� 161,193,2,1,0,128,128,0
�� 128,0,0,128,0,1,1,1
�� 1,65,1,0,0,0,65,0
�%� 130,194,130,194,193,193,129,129
�#� 193,193,131,195,1,130,128,128
�� 2,2,66,0,1,66,3,67
�� 0,1,1,65,65,65,3,0
�� 1,1,130,130,130,2,130,2
�� 2
�
�1maxlen=10:� Maximum word length in vocabulary
�
3� Room and object data block lengths (in bytes)
r_len=74:o_len=16
$*num_vars=60:� Number of ALPS variables
..var_size=num_vars*2:� 2 bytes per variable
8
B5maxmsg=65535:maxobn=255:maxvbn=255:maxconst=65535
LEmaxadj=255:maxprep=50:maxconj=10:maxspec=30:maxnoise=50:maxpix=50
V
`noun_size=3000
jverb_size=3000
tadjc_size=2000
~-prep_size=400:� Size of prepositions list
�,conj_size=50:� size of conjunctions list
�;spec_size=100:� size of 'specials' list (IT, THEM, ALL)
�4noise_size=200:� size of 'noise' list (THE,A,AN)
�=aref_size=2000:� size of adjective object reference table
�9nref_size=2000:� size of nouns object reference table
�-pix_size=1000:� size of pix filename list
�
Ά� nouns noun_size,verbs verb_size,adjects adjc_size,preps prep_size,conjs conj_size,specs spec_size,noise noise_size,pixs pix_size
�
�:� aref aref_size,nref nref_size,verb_type 2*(maxvbn+1)
�
�5noun_end=nouns+noun_size:verb_end=verbs+verb_size
�adjc_end=adjects+adjc_size:prep_end=preps+prep_size:conj_end=conjs+conj_size:spec_end=specs+spec_size:noise_end=noise+noise_size
Iaref_end=aref+aref_size:nref_end=nref+nref_size:pix_end=pixs+pix_size
� Printer codes etc
(condensed=15:reset=64
2pline$=�132,"-")
<pline2$=�79,"-")
F
PK� ------- Set up data areas for rooms and objects and clear them ------
ZB� rdata% (maxrms+1)*r_len,odata% (maxobs+1)*o_len,controom% 12
d
n� Set up the save buffers
x+initareasize=7*(maxobs+1)+22*(maxrms+1)
�=� initsave initareasize,ramsave initareasize+var_size+128
�*$controom%="0":cont_room=0:container=�
�
�+rptr=1:optr=1:last_room=1:last_object=1
�
�&� areas to store flag descriptions
�maxd%=13
�'� o_flags% maxd%*8,r_flags% maxd%*8
�
�� Set the flag descriptions
�� I%=7 � 0 �-1
�� flag$
�($(o_flags%+I%*maxd%)=�flag$,maxd%-1)
�
� I%=7 � 0 �-1
"� flag$
,($(r_flags%+I%*maxd%)=�flag$,maxd%-1)
6�
@
J� Object Flag descriptions
TG� "","",Being worn,Wearable,Scenery,Invisible,Takeable,Light source
^
h� Room flag descriptions
r%� "","","","","","",Visited,Light
|
�!� Room Exit flag descriptions
�X� Invisible,Closed door,Open door,Locked door,Unl'ked door,Blocked,Reserved,Reserved
�
�� exit_flag$(7)
�)� flag=7 � 0 �-1:� exit_flag$(flag):�
�
�� proc% 12,exit% 12,def% 12
� $proc%="":$def%="":$exit%=""
�
�8� prg_sel% = Section of program selected for editing
�1� 2=Main, 3=Proc, 4=Define, 5=Exit
�K� progval$ = STR$ value of proc or exit number or name of selected verb
�
prg_sel%=2:progval$=""
<� voc_sect% = Section of vocabulary selected for editing
&"� 1=Nouns, 2=Verbs
0voc_sect%=1
:
D6pbsize=(scrnsize � 2)+400:� size of picture buffer
N
X� picbuf pbsize
b
lprgbsize=&1000
v� prgbuf% prgbsize
�
�?� ------- Some constants for the character designer -------
�
�cur_chr%=�"A":max_chr%=125
�� charnum 12
�$charnum=""
�
�7� ------- Dimension the other arrays needed -------
�ucsize=500
�Dș "OS_File",5,"<ALPS$Resources>.ASIobjcode" � ftype,,,,codesize
�pbyte_size=148
�F� armcode% 1000,pbytes pbyte_size,work% &1100,asicode% codesize+10
�� usercode% ucsize
Lrun=asicode%:printmsg=asicode%+4:search=asicode%+12:findcode=asicode%+16
setup=asicode%+20
5�("LOAD <ALPS$Resources>.ASIobjcode "+�~asicode%)
� pal%(2)
*� q% &2000,erroraddr%(4)
4� indexdata% 32*24+20
>maxbuf%=&3000
H&� buffer% maxbuf%:curbuff%=buffer%
Rnh%=32:ni%=11
\,� handle%(nh%+1),wident$(nh%),wptr%(nh%)
f>� I%=0�nh%:handle%(I%)=I%-1:wident$(I%)="":�:handleSP%=nh%
p � icon%(ni%+1),iconbar$(ni%)
z.� I%=0 � ni%:icon%(I%)=-1:� iconbar$(I%):�
�icon%(ni%+1)=-1
�oldicon%=0:oldrmicon%=0
�
�8� ------ Names of icons (sprites) on icon bar ------
�L� disk35,arclogo,door,key,quill,info,listing,chardes,vocab,swap,eye,face
�
�0diskicon=0:texticon=4:progicon=6:staricon=99
�0vocabicon=8:faceicon=99:arcicon=1:swapicon=9
�%alpsicon=5:helpicon=13:eyeicon=10
�7THEkeyicon=3:THEdooricon=2:texticon=4:THEcharicon=7
�
�.� menufree% &1800:menuend%=menufree%+&1800
�� menulist% &100
� qBlk% 256
+dx%=2:lsY%=40:ypixel%=4:chX%=16:chY%=32
%currentwindow%=-1:currenticon%=-1
$spritef$=""
.9� mb_wident% 12,filename% 64,filename2% 64,import% 64
86� testing $filename%="demo" � $filename%="starter"
B%$filename2%="charset":$import%=""
L(� start(20),sys_b2% &300,os_block 50
V
`�KeyWordRead
j�ErrorMsgRead
t
~9� ----- Define the "Wimp" and "OS" SYS numbers ------
�Wimp=&400C0
�CreateW=Wimp+1
�CreateI=Wimp+2
�DeleteW=Wimp+3
�DeleteI=Wimp+4
�OpenW=Wimp+5
�CloseW=Wimp+6
�Poll=Wimp+7
�RedrawW=Wimp+8
�UpdateW=Wimp+9
�GetW=Wimp+11
�GetWI=Wimp+&C
SetCaret=Wimp+&12
GetCaret=Wimp+&13
GetR=Wimp+&A
SetI=Wimp+&D
(GetI=Wimp+&E
2GetP=Wimp+&F
<Drag=Wimp+&10
FForceR=Wimp+&11
PCreateM=Wimp+&14
ZSetP=Wimp+&18
dReadPal=&2F
n
xF� ------ Set up our own sprite area and read the sprites in ------
�Aș "OS_File",5,"<ALPS$Resources>.AlpsSprite" � ,,,,spritesize
�spritesize+=4
�� spritearea% spritesize
�!spritearea%=spritesize
�Bș "OS_SpriteOp",266,spritearea%,"<Alps$Resources>.AlpsSprite"
�#� fontcounts% 255,mb_wident% 24
�
�6� ------ Set up the wimps and their handles ------
�
��rgb(19,3)
�+�loadtemplates("<Alps$Resources>.ALPS")
�
�+� ------ Name the window handles ------
.objhandle=handle%(�matchident("objected"))
/roomhandle=handle%(�matchident("roomedit"))
-texthandle=handle%(�matchident("texted"))
",design=handle%(�matchident("chrdesign"))
,+infohandle=handle%(�matchident("info"))
6-savehandle=handle%(�matchident("saveas"))
@8ALPSmain=handle%(�matchident("iconbar")):dialogue%=0
J(setuph=handle%(�matchident("Setup"))
Tdesticon=47:exitprogicon=48
^
hiconbar% = -2
rwindowindex%=nh%+1
|
�,�changeicon(infohandle,7,version$,dummy)
�
�;firstIconBarIcon% = �iconbar(spritearea%, "face",31,19)
�!THEmiscicon=firstIconBarIcon%
�
�
�&� ------ Define the colours ------
�barfgcol=11:barbgcol=3
�'`wbcol=0:`tbcol=2:`sco=&3:`mbcol=&B
�(`wfcol=7:`tfcol=7:`sci=&D:`tbcol2=&C
�
�cur_pal%=7:phys_col%=16
�
0first_token=&30:� Lowest keyword token value
W�find_token(keyword$(),"INC",var_token,dummy):� Tokens from here up allow variables
4�find_token(keyword$(),"DEFINE",def_token,dummy)
&3�find_token(keyword$(),"STOP",stop_token,dummy)
01�find_token(keyword$(),"END",end_token,dummy)
:3�find_token(keyword$(),"EXIT",exit_token,dummy)
D6�find_token(keyword$(),"DEFPROC",proc_token,dummy)
N3�find_token(keyword$(),"PREP",prep_token,dummy)
X9�find_token(keyword$(),"NOTPREP",notprep_token,dummy)
b
l)� ------ Set up the dictionary ------
vdict_size=1000
�%� dict% dict_size,tok$(maxtokens)
�!dict%=3:dict%?2=&80
�
�-� ------ Find the available memory ------
�memfree=(�-�)-50000
�l� memfree<0 � null=�errorbox("Not enough memory available in 'Next' slot",0,1,-99):ș "Wimp_CloseDown":�
�maxtext%=0.83*memfree
�code_size%=0.17*memfree
�
�@� ------ Areas for storing messages, switch info etc; ------
�D� text% maxtext%,swdata% 12*maxsw%,switch_vals(maxsw%),m_msg% 12
�� switch_buf% 2*maxsw%+1
�'$swdata%=�12*maxsw%,�13):$m_msg%=""
,� ------ Initialise the text area ------
,!text%=1:text%!2=&B:text%!6=0:text%!10=0
� st_msg% 12,end_msg% 12
*$st_msg%="1":$end_msg%="1"
4'mptr=1:� The current message number
>Etext_owner$="":� The current owner of any text in the text editor
H
Rdatavalid=�
\
f+� ------ Set up the program area ------
p� program% code_size%
z!program%=0
�program%!4=0
�
errflag=�
�
�-� ------ Set up the menu structure ------
�m_controom%=�crmenu
�� "#Number,$controom%(5)"
�m_contain=�crmenu
�&� "Container,Use room>m_controom%"
�m_chardes%=�crmenu
�� "#CHANGE TO?,$charnum(2)"
�char_fname%=�crmenu
�"� "#Filename:,$filename2%(11)"
�menu_fname%=�crmenu
!� "#Filename:,$filename%(11)"
m_gotomsg%=�crmenu
� "$m_msg%(12)"
$m_proc%=�crmenu
.� "#Number:,$proc%(4)"
8m_def%=�crmenu
B� "#Verb:,$def%(12)"
Lm_exit%=�crmenu
V� "#Number:,$exit%(4)"
`m_listopts=�crmenu
j=� "#Display:,Vocabulary as numbers,Vocabulary as strings"
tm_import%=�crmenu
~� "#Filename:,$import%(11)"
� sw1=�crmenu:nxtsw=swdata%+12
�� "#Value:,$swdata%(12)"
�sw2=�crmenu:nxtsw=nxtsw+12
�� "#Value:,$nxtsw"
�sw3=�crmenu:nxtsw=nxtsw+12
�� "#Value:,$nxtsw"
�sw4=�crmenu:nxtsw=nxtsw+12
�� "#Value:,$nxtsw"
�sw5=�crmenu:nxtsw=nxtsw+12
�� "#Value:,$nxtsw"
�sw6=�crmenu:nxtsw=nxtsw+12
�� "#Value:,$nxtsw"
sw7=�crmenu:nxtsw=nxtsw+12
� "#Value:,$nxtsw"
sw8=�crmenu:nxtsw=nxtsw+12
� "#Value:,$nxtsw"
(sw9=�crmenu:nxtsw=nxtsw+12
2� "#Value:,$nxtsw"
<sw10=�crmenu:nxtsw=nxtsw+12
F� "#Value:,$nxtsw"
Pm_switch%=�crmenu
ZY� "#Switch,No switches,1>sw1,2>sw2,3>sw3,4>sw4,5>sw5,6>sw6,7>sw7,8>sw8,9>sw9,10>sw10"
dm_text%=�crmenu
n�� "#MSG: nnnnn,Insert,Overtype#,Cut,Copy,Paste#,Next,Previous,First,Last,Goto msg#>m_gotomsg%,Edit switch#>m_switch%,Print this"
xm_prog%=�crmenu
��� "#Program Editor,Insert,Overtype#,Cut,Copy,Paste#,Main,Procedure>m_proc%,Define>m_def%,Exit routine#>m_exit%,Print this,List options>m_listopts"
�m_vocab%=�crmenu
��� "#Vocabulary,Insert,Overtype#,Cut,Copy,Paste#,Nouns,Verbs,Adjectives,Prepositions,Conjunctions,Specials,Noise#,Print this"
�pixmenu=�crmenu
�� "#Pictures,Print"
�progmenu=�crmenu
�,� "#Program,Print,Import#>m_import%,Run"
�charmenu=�crmenu
�2� "#CharSet,Save>char_fname%,Load>char_fname%"
�vocabmenu=�crmenu
�� "#Vocabulary,Print"
�diskmenu=�crmenu
�-� "#Files,Save all>savehandle,Setup disk"
facemenu=�crmenu
� "#Actors,Print"
miscmenu=�crmenu
""� "#ALPS,Info>infohandle,Quit"
,msg2%=�crmenu
6� "$st_msg%(6)"
@msg3%=�crmenu
J� "$end_msg%(6)"
Tmsg1%=�crmenu
^/� "#From/To?,Start msg>msg2%,End msg>msg3%"
htextmenu=�crmenu
r*� "#Text,Print>msg1%,Import>m_import%"
|objmenu=�crmenu
�'� "#Objects,Print,Import>m_import%"
�*mo_user5=�crmenu:ofl%=o_flags%+maxd%*3
�#� "#Description:,$o_flags%(13)"
�$mo_user4=�crmenu:ofl%=ofl%+maxd%
�� "#Description:,$ofl%(13)"
�$mo_user3=�crmenu:ofl%=ofl%+maxd%
�� "#Description:,$ofl%(13)"
�$mo_user2=�crmenu:ofl%=ofl%+maxd%
�� "#Description:,$ofl%(13)"
�$mo_user1=�crmenu:ofl%=ofl%+maxd%
�� "#Description:,$ofl%(13)"
�$mo_user0=�crmenu:ofl%=ofl%+maxd%
�� "#Description:,$ofl%(13)"
m_objflag=�crmenu
�� "#Flags,7 Light source,6 Takeable,5 Invisible,4 Scenery,3 Wearable,2 Being worn,1 User flag>mo_user1,0 User flag>mo_user0"
roommenu=�crmenu
&%� "#Rooms,Print,Import>m_import%"
0*mr_user6=�crmenu:rfl%=r_flags%+maxd%*2
:#� "#Description:,$r_flags%(13)"
D$mr_user5=�crmenu:rfl%=rfl%+maxd%
N� "#Description:,$rfl%(13)"
X$mr_user4=�crmenu:rfl%=rfl%+maxd%
b� "#Description:,$rfl%(13)"
l$mr_user3=�crmenu:rfl%=rfl%+maxd%
v� "#Description:,$rfl%(13)"
�$mr_user2=�crmenu:rfl%=rfl%+maxd%
�� "#Description:,$rfl%(13)"
�$mr_user1=�crmenu:rfl%=rfl%+maxd%
�� "#Description:,$rfl%(13)"
�$mr_user0=�crmenu:rfl%=rfl%+maxd%
�� "#Description:,$rfl%(13)"
�m_rmflag=�crmenu
ƣ� "#Flags,7 Light,6 Visited,5 User (Trans)>mr_user5,4 User (Open)>mr_user4,3 User flag>mr_user3,2 User flag>mr_user2,1 User flag>mr_user1,0 User flag>mr_user0"
�m_exitf=�crmenu
�|� "#Flags,7 Invisible exit,6 Closed door,5 Open door,4 Locked door,3 Unlocked door,2 Blocked exit,1 Reserved,0 Reserved"
�
��
�
>� ------ Now we have the Procedures and Functions!! ------
� �getmodeinfo
� x,y,xeig,yeig,cols
*
mode=�
4
>1ș "OS_ReadModeVariable",mode,1 � ,,textcols%
H1ș "OS_ReadModeVariable",mode,2 � ,,textrows%
Rtext_maxllen%=textcols%-2
\,ș "OS_ReadModeVariable",mode,3 � ,,cols
f,ș "OS_ReadModeVariable",mode,4 � ,,xeig
p,ș "OS_ReadModeVariable",mode,5 � ,,yeig
z0ș "OS_ReadModeVariable",mode,7 � ,,scrnsize
�*ș "OS_ReadModeVariable",mode,11 � ,,x
�*ș "OS_ReadModeVariable",mode,12 � ,,y
�-scrw=((x+1)<<xeig)-1:scrh=((y+1)<<yeig)-1
��
�
�� �clear
�$�fill(odata%,(maxobs+1)*o_len,0)
�$�fill(rdata%,(maxrms+1)*r_len,0)
�%�fill(program%+4,code_size%-20,0)
�'� PROCfill(initsave,initareasize,0)
��
�
�
� �return(x%,y%)
�col(128+12):�col(7)
>�centre(" Hit any key/button to return to the editor ",y%)
$�
.ȗ X%,Y%,B%
8
� B%=0
B
L�
Vany=�(0)
`ȗ X%,Y%,B%
j� any>0 � B%>0
t�
~
�� �centre(t$,r)
�#�(textcols%-� t$+1) � 2,r);t$;
��
�
�4� ------ General window handling routines ------
�
�� �deletewindow(I%)
�!q%=handle%(I%)
�&handle%(I%)=handleSP%:handleSP%=I%
�ș DeleteW,,q%
�wident$(I%)=""
��
� �loadtemplates(tfile$)
tmp%=0
"ș "Wimp_OpenTemplate",,tfile$
(tf_index%=0:�
2$mb_wident%="*"
<tș "Wimp_LoadTemplate",,q%+4,curbuff%,buffer%+maxbuf%,fontcounts%,mb_wident%,tf_index% � ,,curbuff%,,,,tf_index%
F+� tf_index%<>0 � �loadtemp($mb_wident%)
P� tf_index%=0
Zș "Wimp_CloseTemplate"
d�
n
x� �loadtemp(wident$)
�8I%=�matchident(wident$):� I%<>-1 � �deletewindow(I%)
�-q%!68=spritearea% : � user sprite area
��crwindow(q%+4,wident$)
��
�
�� �highlight(I%)
��
�-ș SetCaret,handle%(I%),-1,0,0,&2000000,0
��
�
�+� �retitle(handle%,newtitle$,� handle%)
�index%=windowindex%
��
1 index%-=1: �index%<0 � 255,"Invalid window"
� handle%(index%)=handle%
!q%=handle%
"ș GetWI,,q%
,ș DeleteW,,q%
6$(q%+76)=�newtitle$,11)
@ș CreateW,,q%+4 � handle%
Jhandle%(index%)=handle%
T�
^
h� �crwindow(q%,wident$)
rș CreateW,,q% � handle%
|Am%=handleSP%:handleSP%=handle%(handleSP%):handle%(m%)=handle%
�!q%=handle%
�ș GetW,,q%
�)currentwindow%=m%:wident$(m%)=wident$
�currenticon%=-1
��highlight(m%)
��
�
�� �close(wind)
�i%=ni%+1
�
Ȏ wind �
�? � objhandle:i%=THEkeyicon:� icon%(i%)<>-1 �store_obj(optr)
�C � roomhandle: i%=THEdooricon:� icon%(i%)<>-1 �store_room(rptr)
� � texthandle
i%=texticon
�remove_markers
Ȏ text_owner$ �
& � "texted" : �store_msg
00 � "program" : � � text_ok � �store_prog
:/ � "vocab" : � � text_ok � �store_vocab
D � "pix" : �store_pix
N �
X � � errflag �
b4 text_owner$="":� release Text Editor window
l5 �fill(text_block%,text_blocksize%,dummy_spc)
v �
� � design: i%=THEcharicon
��
��� (text_owner$="program" � errflag � wind=texthandle) � (text_owner$="vocab" � errflag � wind=texthandle) � (text_owner$="pix" � errflag � wind=texthandle) � (text_owner$="texted" � errflag � wind=texthandle) �
��
� icon%(i%)=-1
� !block=wind
� ș CloseW,,block
��
��
�
�� �open(handle,x,y,w,d)
�!block=handle
�block!4=x:block!8=y-d
block!12=x+w:block!16=y
block!20=0:block!24=0
block!28=-1
ș OpenW,,block
*�
4
>� �redraw(handle)
Hblock!0=handle
Rș RedrawW,0,block � more%
\�info(block+4)
f/� handle=texthandle � dummy=�redraw_text(�)
p�
z
�� �forceR(handle)
�/� Force the given window ONLY to be redrawn
��getw(handle)
�<ș ForceR,handle,scx%,scy%-(y1%-y0%),scx%+(x1%-x0%),scy%
��
�
�� �matchident(A$)
�� A$="" � =-1
�� I%
�*I%=nh%+1:�I%=I%-1:�A$=wident$(I%)�I%=0
��A$=wident$(I%)�=I%�=-1
�
�� �getw(handle%)
� handle%=iconbar% �
!!block=handle%:șGetW,0,block
4�info(block+4):bhandle%=block!28:flags%=block!32
$ontop=flags% � &20000
.�
8
B� �info(b)
L7x0%=!b:y0%=b!4:x1%=b!8:y1%=b!12:scx%=b!16:scy%=b!20
Vbx%=x0%-scx%:by%=y1%-scy%
`/gwxl%=b!24:gwyb%=b!28:gwxr%=b!32:gwyt%=b!36
j�
t
~� �getpointer
�șGetP,0,block
�Zmousex%=!block:mousey%=block!4:b%=block!8:handle%=block!12:icon%=block!16:ob%=block!20
��
�
�F� �sys_claiminputfocus(window%,icon%,xofst%,yofst%,height%,index%)
�:șSetCaret, window%,icon%,xofst%,yofst%,height%,index%
��
�
�R� �sys_getcaretposition(� window%,� icon%,� xofst%,� yofst%,� height%,� indx%)
�șGetCaret,0,b
�dwindow%=!block: icon%=block!4: xofst%=block!8: yofst%=block!12: height%=block!16: indx%=block!20
��
� �cursor(x%,y%)
^�sys_claiminputfocus(texthandle,-1,(x%-1)*chX%,-y%*lsY%-9*ypixel%,&1000000 �10*ypixel%,-1)
�
(
2� �text_menubox
<Ȏ text_owner$ �
F� "texted"
P tick$="message"
Z null = �tick_message
dB ș CreateM,0,m_text%,mousex%-64,mousey%:claimmenu$="message"
n theLastMenu = m_text%
x
�� "program"
� tick$="program"
� null = �tick_program
�B ș CreateM,0,m_prog%,mousex%-64,mousey%:claimmenu$="program"
� theLastMenu = m_prog%
�
�
� "vocab"
� tick$="vocab"
� null = �tick_vocab
�A ș CreateM,0,m_vocab%,mousex%-64,mousey%:claimmenu$="vocab"
� theLastMenu = m_vocab%
�
��
�
"<� �checkmouse(mousex%,mousey%,button%,handle%,icon%,ob%)
,�handle%=-1 � �
6�getw(handle%)
@�handle%=ALPSmain �
J �icon%<>-1 �
T#� icon% -= firstIconBarIcon%
^
Ȏ� �
h0 �(button%�1)=1 : � adjust does nothing
r< �(button%�2)=2 : void=�("FNmenu_"+iconbar$(icon%))
|) �(button%�4)=4 : �openup(icon%)
� �
� �
��
� � handle%=iconbar% �
� � The RISC OS icon bar
� Ȏ � �
�) � (button%�2)=2 : void=�menu_misc
� � (button%�4)=4
�C � icon%=firstIconBarIcon% � �open(ALPSmain,400,800,600,600)
� �
� �
� index%=windowindex%
�
�
5 index%-=1: �index%<0 � 255,"Invalid window"
" � handle%(index%)=handle%
+ void=�("FNbutton_"+wident$(index%))
& �
0�
:�
D
N)� �userkeypressed(handle%,icon%,key%)
X�getw(handle%)
b�index%
lindex%=windowindex%
v�
�index%-=1: �index%<0 � �
��handle%(index%)=handle%
�)void=�("FNkeypress_"+wident$(index%))
��
�
� � �menuselect(item0%,item1%)
�#ș "Wimp_GetPointerInfo",,block
�buTTon = block!8
�&void=�("FNmenuselect_"+claimmenu$)
�� buTTon=1 �
�: � *** ADJUST pressed so keep the menu structure ***
� null = �("FNtick_"+tick$)
�# ș CreateM,0,theLastMenu,0,0
�
claimmenu$=""
�
�
*
4*� �update(handle%,ux0%,uy0%,ux1%,uy1%)
>H!block=handle%:block!4=ux0%:block!8=uy0%:block!12=ux1%:block!16=uy1%
H-ș UpdateW,0,block � more%:�info(block+4)
R�
\
f� �openup(icon%)
p� icon%(icon%)=-1 �
z� � icon%<>diskicon � icon%<>texticon � icon%<>arcicon � icon%<>swapicon � icon%<>progicon � icon%<>vocabicon � icon%<>eyeicon � icon%(icon%)=icon%
� Ȏ icon% �
� � diskicon:
�6 ș CreateM,0,diskmenu,mousex%-64,mousey%
�6 � loaded$<>"" � f$=path$ � f$="AlpsFile"
�/ �changeicon(savehandle,2,f$,void)
�? claimmenu$="disk35":theLastMenu=diskmenu:tick$=""
� � WHEN THEmiscicon:
�< � *********** do nothing for this icon *******
� � texticon:
� � text_owner$="" �
�: �retitle(texthandle,"MESSAGES",texthandle)
�1 �open(texthandle,0,1000,scrw,400)
�. text_owner$="texted":text_ok=�
�show_msg(mptr)
�
� 7
$ �
. � THEdooricon:
8E �open(handle%(�matchident("roomedit")),0,720,1280,1040)
B! �restore_room(rptr)
L � THEkeyicon:
VE �open(handle%(�matchident("objected")),850,560,800,680)
` �restore_obj(optr)
j � progicon:
t � text_owner$="" �
~9 �retitle(texthandle,"PROGRAM",texthandle)
�1 �open(texthandle,0,1000,scrw,400)
�/ text_owner$="program":text_ok=�
�( �list(prg_sel%,progval$)
� �
� � 7
� �
� � THEcharicon:
�E �open(handle%(�matchident("chrdesign")),0,560,1280,860)
�$ �display_chr(cur_chr%)
�6 �changeicon(design,64,�(cur_chr%),dummy)
� � vocabicon:
� � text_owner$="" �
< �retitle(texthandle,"VOCABULARY",texthandle)
1 �open(texthandle,0,1000,scrw,400)
- text_owner$="vocab":text_ok=�
& �list_vocab(voc_sect%)
( �
2 � 7
< �
F � helpicon:
P? �open(handle%(�matchident("HELP")),0,500,960,400)
Z � eyeicon:
d � text_owner$="" �
n: �retitle(texthandle,"PICTURES",texthandle)
x1 �open(texthandle,0,1000,scrw,400)
�+ text_owner$="pix":text_ok=�
� �list_pix
� �
� � 7
� �
�) � arcicon:dummy=�keypress_status
� � swapicon
�- datavalid=� datavalid:� 7:�swap_data
� � datavalid �
�8 �changeicon(ALPSmain,swapicon,"swap",swapicon)
�
�
�: �changeicon(ALPSmain,swapicon,"swap_x",swapicon)
�
�
�forceR(ALPSmain)
�
�
"�
,
6
@J� ------ `button` routines to deal with clicks in given window ------
J
T� �button_texted
^�mx%,my%
h� button%<>2 �
r�getpointer
|)mx%=(mousex%-bx%+chX%�4) �(�(chX%-1))
�-my%=(mousey%-by%) - ((mousey%-by%) �lsY%)
�text_col%=1+mx% �chX%
�$text_row%=-((mousey%-by%) �lsY%)
�-� text_row%>last_row% text_row%=last_row%
�K� text_col%>text_rowlen%(text_row%) text_col%=text_rowlen%(text_row%)+1
�� text_col%<1 text_col%=1
��
�
�Ȏ button% �
�� 2
��text_menubox
�� 4
��locate_ptr
�cursor(text_col%,text_row%)
� 1
� text_owner$<>"pix" �
&�locate_ptr
0
� mrk<2 �
:mark(mrk)=text_ptr%
D)col(mrk)=text_col%:row(mrk)=text_row%
Nasc(mrk)=?text_ptr%
X/� asc(mrk)=13 � �23,dummy_cr � �23,chr(mrk)
b?os_block=asc(mrk)
lș "OS_Word",&A,os_block
v� R%=1 � 8
�row_value=R%?os_block
�� row_value � &FF
��
�=� asc(mrk)=13 � ?text_ptr%=dummy_cr � ?text_ptr%=chr(mrk)
�h�update(texthandle,chX%*(text_col%-1),-(text_row%+1)*lsY%,chX%*(text_col%-1)+chX%,-(text_row%)*lsY%)
�dummy=�redraw_text(�)
�
mrk+=1
� �cursor(text_col%,text_row%)
��
��
��
�=0
�
!� �locate_ptr
!text_ptr%=text_block%
!� text_row%>0 �
! � R%=0 � text_row%-1
!*# text_ptr%+=text_rowlen%(R%)
!47 � text_rowlen%(R%)<text_maxllen% � text_ptr%+=1
!> �
!H�
!Rtext_ptr%+=text_col%-1
!\/� text_ptr%>text_end% � text_ptr%=text_end%
!f�
!p
!z� �button_objected
!�Ȏ icon% �
!�� 0:
!�
!�2� First set the 'tick' bits for each menu item
!�null = �tick_objected
!�Cș CreateM,0,m_objflag,mousex%-64,mousey%:claimmenu$="objected"
!�tick$="objected"
!�theLastMenu = m_objflag
!�
!�� 5:�first_obj
!�� 6:�last_obj
!�� 27:�next_obj
!�� 16:�prev_obj
"� 20:�fwd_obj(10)
"� 21:�rewind_obj(10)
"� 17
"$�store_obj(optr)
".%optr=�(�geticondata(objhandle,7))
"8� optr<1 � optr=1
"B� optr>maxobs � optr=maxobs
"L�restore_obj(optr)
"V� 22:last_object=optr
"` � 26:
"jDș CreateM,0,m_contain,mousex%-64,mousey%:claimmenu$="container"
"ttick$=""
"~theLastMenu = m_contain
"�
"��
"�4� optr>last_object last_object=optr:data_saved=�
"�=0
"�
"�� �button_roomedit
"�Ȏ icon% �
"�� 1:
"�tick$="roomedit"
"�null = �tick_roomedit
"�Bș CreateM,0,m_rmflag,mousex%-64,mousey%:claimmenu$="roomedit"
"�theLastMenu = m_rmflag
#
#
� 5:�first_room
#� 6:�last_room
#� 7:�next_room
#(� 8:�prev_room
#2� 9:�fwd_room(10)
#<� 10:�rewind_room(10)
#F� 11
#P�store_room(rptr)
#Z'rptr=�(�geticondata(roomhandle,33))
#d� rptr<1 � rptr=1
#n� rptr>maxrms � rptr=maxrms
#x�restore_room(rptr)
#�
#�� 12:last_room=rptr
#��
#�0� rptr>last_room last_room=rptr:data_saved=�
#�
#�8� Now check for clicking menu on selected EXITR icon
#�
#�
Ȏ � �
#�
#�� icon%>53 � icon%<70
#�
#�oldrmicon%=icon%
#�null = �tick_exitedit
$tick$="exitedit"
$Aș CreateM,0,m_exitf,mousex%-64,mousey%:claimmenu$="exitedit"
$theLastMenu = m_exitf
$"
$,�
$6=0
$@
$J� �button_chrdesign
$T
Ȏ � �
$^� icon%>=0 � icon%<64
$h) �set_icon(design,icon%,&50000000,0)
$r �write_chr(cur_chr%)
$| �set_icon(design,64,0,0)
$�� icon%=66
$� cur_chr%+=1
$�+ � cur_chr%>max_chr% cur_chr%=max_chr%
$�. �changeicon(design,64,�(cur_chr%),icon%)
$� �display_chr(cur_chr%)
$�� icon%=67
$� cur_chr%-=1
$� � cur_chr%<32 cur_chr%=32
$�. �changeicon(design,64,�(cur_chr%),icon%)
$� �display_chr(cur_chr%)
$�� icon%=68
$�D ș CreateM,0,m_chardes%,mousex%-64,mousey%:claimmenu$="chrdef"
$�' theLastMenu = m_chardes%:tick$=""
%�
%=0
%
%&
%0� �button_info
%:� icon%=5 �
%D�close(infohandle)
%N�
%X=0
%b
%l� �button_saveas
%vȎ icon% �
%�/� 0 : �save_all(�geticondata(savehandle,2))
%�� 1 : �getw(savehandle)
%�. dummy$=�geticondata(savehandle,1)
%�* block!4=5:block!8=block!8+bx%
%�" block!12=block!12+by%
%�" block!16=block!16+bx%
%�" block!20=block!20+by%
%�B block!24=0:block!28=0:block!32=scrw+1:block!36=scrh+1
%�% ș "Wimp_DragBox",,block
%��
%�=0
%�
%�� �button_Setup
&Ȏ icon% �
&� 0
&C� 1:�create_dirs(�geticondata(setuph,2),�geticondata(setuph,5))
& �
&*�close(setuph)
&4ȗ ȓ 0,0,scrw,scrh
&>=0
&H
&RK� ------ `keypress` routines deal with pressing key `key%` in a window
&\
&f� �keypress_texted
&p
Ȏ � �
&z-� key%=13:�newline:data_saved=�:text_ok=�
&�� key%=&18F:�up
&�� key%=&18E:�down
&�� key%=&18D:�right
&�)� key%=&18A:� I%=1 � tab_set:�right:�
&�(� key%=&19A:� I%=1 � tab_set:�left:�
&�� key%=&18C:�left
&�3� key%=&1AB:�delete_line:data_saved=�:text_ok=�
&�3� key%=&1ED:�insert_line:data_saved=�:text_ok=�
&�� key%=&1AC:�left_end
&�� key%=&1AD:�right_end
&�:� key%=&18B:�right:�delete_char:data_saved=�:text_ok=�
&�%� key%=&1CD:overwrite=� overwrite
&�2� key%=127:�delete_char:data_saved=�:text_ok=�
'� (key%>31) � (key%<126)
'<� overwrite � �overwrite_char(key%) � �insert_char(key%)
'data_saved=�:text_ok=�
'$ ș "Wimp_ProcessKey",key%
'.�
'8
'B �cursor(text_col%,text_row%)
'L=0
'V
'`� �keypress_saveas
'jQ� key%=13 � �save_all(�geticondata(savehandle,2)) � ș "Wimp_ProcessKey",key%
'~=0
'�
'�� �keypress_objected
'�� key%=13 � icon%=7 �
'� �store_obj(optr)
'�+ optr=�(�geticondata(objhandle,icon%))
'� � optr<1 � optr=1
'�! � optr>maxobs � optr=maxobs
'� �restore_obj(optr)
'��
'�
'�
Ȏ key% �
'�$� 13,&18E:� Return or down arrow
( � icon%<15 �
(
icon%+=1
(�
(
icon%=7
((�
(2� &18F:� Up arrow
(<� icon%>7 �
(F icon%-=1
(P�
(Z icon%=15
(d�
(n ș "Wimp_ProcessKey",key%
(x�
(�Q�sys_claiminputfocus(objhandle,icon%,0,0,-1,�(�geticondata(objhandle,icon%)))
(�=0
(�
(�� �keypress_roomedit
(�
Ȏ key% �
(�� 13,&18E,&18F
(�
(�� key%=13 � icon%=33 �
(� �store_room(rptr)
(�, rptr=�(�geticondata(roomhandle,icon%))
(� � rptr<1 � rptr=1
(�! � rptr>maxrms � rptr=maxrms
(� �restore_room(rptr)
)�
)
)� key%=13 � key%=&18E �
)"
Ȏ � �
),� icon%=37:newicon%=71
)6� icon%=71:newicon%=38
)@� icon%=69:newicon%=33
)J� icon%<37:newicon%=icon%+1
)T-� (icon%>37 � icon%<54):newicon%=icon%+16
)^-� (icon%>53 � icon%<69):newicon%=icon%-15
)h�
)r�
)|
)�� key%=&18F �
)�
Ȏ � �
)�� icon%=71:newicon%=37
)�� icon%=38:newicon%=71
)�� icon%=33:newicon%=69
)�� icon%>33:newicon%=icon%-1
)�-� (icon%>37 � icon%<54):newicon%=icon%-16
)�-� (icon%>53 � icon%<69):newicon%=icon%+15
)��
)��
)�
)� ș "Wimp_ProcessKey",key%
)��
)�Y�sys_claiminputfocus(roomhandle,newicon%,0,0,-1,�(�geticondata(roomhandle,newicon%)))
*=0
*
*� �keypress_status
*&�col(128+2)
*0
� 26,4,12
*:�col(9):�col(128+7)
*D<�centre(�27," ")+"System Status Information"+�28," "),0)
*N�col(128+2):�col(7)
*X�status
*b�col(128+7):�col(9)
*l5�centre(�31," ")+"Integer Variables"+�32," "),10)
*v�col(128+2):�col(7)
*� �lvar
*��:�return(18,31):�
*�
� 26,5
*�"ș ForceR,-1,0,0,scrw+1,scrh+1
*�=0
*�
*�� �keypress_chrdef
*�� key%=13 � icon%=64 �
*�*cur_chr%=�(�geticondata(design,icon%))
*��display_chr(cur_chr%)
*�,�changeicon(design,64,�(cur_chr%),icon%)
*��
*�*� key%<>13 � ș "Wimp_ProcessKey",key%
*��
*�=0
*�
+� �keypress_Setup
+0� key%=&18E � key%=13 � icon%=2 � newicon%=5
+7� key%=13 � icon%=5 � icon%=1:void=�button_Setup:=0
+ &� key%=&18E � icon%=5 � newicon%=2
+*&� key%=&18F � icon%=5 � newicon%=2
+4&� key%=&18F � icon%=2 � newicon%=5
+5D� key%<>13 � key%<>&18E � key%<>&18F � ș "Wimp_ProcessKey",key%
+>Q�sys_claiminputfocus(setuph,newicon%,0,0,-1,�(�geticondata(setuph,newicon%)))
+H=0
+R
+\A� ------ The `menu` routines to open the selected menu ------
+f
+p� �menu_
+z=0
+�
+�� �menu_swap
+�=0
+�
+�� �menu_arclogo
+�=0
+�
+�� �menu_info
+�=0
+�
+�
+�� �menu_disk35
+�,ș CreateM,0,diskmenu,mousex%-64,mousey%
,,� loaded$<>"" � f$=path$ � f$="AlpsFile"
,%�changeicon(savehandle,2,f$,void)
,theLastMenu= diskmenu
,$ claimmenu$="disk35":tick$=""
,.=0
,8
,B
,L� �menu_key
,V+ș CreateM,0,objmenu,mousex%-64,mousey%
,`theLastMenu = objmenu
,jclaimmenu$="key":tick$=""
,t=0
,~
,�� �menu_door
,�,ș CreateM,0,roommenu,mousex%-64,mousey%
,�theLastMenu = roommenu
,�claimmenu$="door":tick$=""
,�=0
,�
,�� �menu_quill
,�$end_msg%=�(�maxmsg)
,�,ș CreateM,0,textmenu,mousex%-64,mousey%
,�theLastMenu = textmenu
,�claimmenu$="quill":tick$=""
,�=0
-
-
-� �menu_listing
-,ș CreateM,0,progmenu,mousex%-64,mousey%
-(theLastMenu = progmenu
-2!claimmenu$="listing":tick$=""
-<=0
-F
-P
-Z� �menu_chardes
-d=0
-n,ș CreateM,0,charmenu,mousex%-64,mousey%
-xtheLastMenu = charmenu
-�!claimmenu$="chardes":tick$=""
-�=0
-�
-�� �menu_vocab
-�-ș CreateM,0,vocabmenu,mousex%-64,mousey%
-�theLastMenu = vocabmenu
-�$claimmenu$="vocabulary":tick$=""
-�=0
-�
-�� �menu_face
-�,ș CreateM,0,facemenu,mousex%-64,mousey%
-�theLastMenu = facemenu
-� claimmenu$="actors":tick$=""
.=0
.
.� �menu_misc
."null = �tick_misc
.,<ș CreateM,0,miscmenu,mousex%-64,�menuHeight(miscmenu,1)
.6theLastMenu = miscmenu
.@"claimmenu$="misc":tick$="misc"
.J=0
.T
.^� �menu_help
.h=0
.r
.|
.�� �menu_eye
.�+ș CreateM,0,pixmenu,mousex%-64,mousey%
.�theLastMenu = pixmenu
.�claimmenu$="eye":tick$=""
.�=0
.�
.�
.�J� `menuselect` functions - called when a selection is made from a menu
.�D� `item0%` is the number of selection from first menu (0,1,2...)
.�E� `item1%` is the number of selection from second menu (0,1,2...)
.�
.�� �menuselect_
.�=0
/
/
/� �menuselect_message
/&� changed_msg
/0
/:Ȏ item0% �
/D
� -1
/N! � 0,1:overwrite=� overwrite
/X& � 2:�cut(mark(0),mark(1),picbuf)
/b' � 3:�copy(mark(0),mark(1),picbuf)
/l" � 4:�paste(text_ptr%,picbuf)
/v � 5:�next_msg
/� � 6:�prev_msg
/� � 7:�first_msg
/� � 8:�last_msg
/� � 9:�goto_msg(�($m_msg%))
/�
� 10
/� � item1%>-1 �
/� � item1%=0 �
/� � I%=0 � maxsw%
/� switch_vals(I%)=0
/� � I%
/� �
/�7 switch_vals(item1%)=�($(swdata%+12*(item1%-1)))
/�7 � item1%>switch_vals(0) � switch_vals(0)=item1%
06 � switch_vals(0) stores the number of switches
0 �
0
� 11
0
*FX3,10
0* �print_msg(mptr)
04 *FX3,0
0>�
0H�forceR(texthandle)
0R� changed_msg �
0\text_row%=0:text_col%=1
0f�cursor(1,0)
0p�
0z� claimmenu$=""
0�=0
0�
0�� �cut(start,end,buf)
0�� mrk<2 � � 1,error$(29)
0�Q� end<start � Ȕ start,end:Ȕ col(0),col(1):Ȕ row(0),row(1):Ȕ asc(0),asc(1)
0�cliplen=end-start+1
0��move(start,buf,cliplen)
0�&� SYS"Wimp_CloseDown":MODE 12:STOP
0�;�move(end+1,start,text_end%-end):� was +1 until 16.6.89
0�&?buf=asc(0):buf?(cliplen-1)=asc(1)
0�text_end%=text_end%-cliplen
0�� asc(1)=0 � text_end%+=1
0�+� Restore end marker if it has been cut
13� text_end%<text_block% � text_end%=text_block%
1?text_end%=0
1last_row%=�find_lastrow
1$� I%=0 � last_row%
1.text_rowlen%(I%)=��row(I%)
18�
1Bmrk=0:mark()=+0
1L/� text_row%>last_row% � text_row%=last_row%
1VM� text_col%>text_rowlen%(text_row%) � text_col%=text_rowlen%(text_row%)+1
1`,�locate_ptr:�cursor(text_col%,text_row%)
1jdata_saved=�:text_ok=�
1t�
1~
1�� �copy(start,end,buf)
1�� mrk<2 � � 1,error$(29)
1�Q� end<start � Ȕ start,end:Ȕ col(0),col(1):Ȕ row(0),row(1):Ȕ asc(0),asc(1)
1�cliplen=end+1-start
1��move(start,buf,cliplen)
1�&?buf=asc(0):buf?(cliplen-1)=asc(1)
1�-?start=asc(0):?end=asc(1):mrk=0:mark()=+0
1��
1�
1�� �paste(to,from)
1� � cliplen=0 � � 1,error$(30)
1�'�move(to,to+cliplen,text_end%-to+1)
2 �move(from,to,cliplen)
2
text_end%+=cliplen
2last_row%=�find_lastrow
2� I%=0 � last_row%
2(text_rowlen%(I%)=��row(I%)
22�
2<,�locate_ptr:�cursor(text_col%,text_row%)
2Fdata_saved=�:text_ok=�
2P�
2Z
2d� �menuselect_program
2n
errflag=�
2x� item0%>4 � item0%<9 �
2��remove_markers
2�� � text_ok � �store_prog
2�prg_sel%=item0%-3
2�text_row%=0:text_col%=1
2��cursor(1,0)
2��
2�
2�Ȏ item0% �
2�� 0,1:overwrite=� overwrite
2�$� 2:�cut(mark(0),mark(1),picbuf)
2�%� 3:�copy(mark(0),mark(1),picbuf)
2� � 4:�paste(text_ptr%,picbuf)
2�� 5:progval$=""
3� 6:progval$=$proc%
3� 7:progval$=$def%
3� 8:progval$=$exit%
3"� 9:�print_prog_seg
3,� 10:�listo
36�
3@
3J� (item0%>4 � item0%<9) �
3T � � errflag �
3^ �list(item0%-3,progval$)
3h �forceR(texthandle)
3r �
3|�
3�� (item0%>1 � item0%<5) �
3��forceR(texthandle)
3��
3�� item0%=10 �
3�� � text_ok � �store_prog
3�� � errflag �
3�text_row%=0:text_col%=1
3��cursor(1,0)
3��list(prg_sel%,progval$)
3��forceR(texthandle)
3��
3��
3�=0
4
4� �menuselect_vocab
46� Make a selection from the vocabulary editor menu
4&Ȏ item0% �
40� 0,1:overwrite=� overwrite
4:$� 2:�cut(mark(0),mark(1),picbuf)
4D%� 3:�copy(mark(0),mark(1),picbuf)
4N � 4:�paste(text_ptr%,picbuf)
4X� 5,6,7,8,9,10,11
4b$�remove_markers:� Added 23.08.89
4l� � text_ok � �store_vocab
4v� � errflag �
4�voc_sect%=item0%-4
4��list_vocab(voc_sect%)
4�text_row%=0:text_col%=1
4��cursor(1,0)
4��
4�� 12:�print_prog_seg
4��
4�Ȏ item0% �
4�� 2,3,4,5,6,7,8,9,10,11
4��forceR(texthandle)
4��
4�� claimmenu$=""
4�=0
5
5� �menuselect_exitedit
5xerr%=�
5 � oldrmicon%<>0 �
5*) ptr%=(rdata%+rptr*r_len+oldrmicon%)
54 flags%=?ptr%
5> cl_door%=flags% � &40
5H op_door%=flags% � &20
5R lk_door%=flags% � &10
5\ unlk_door%=flags% � &8
5f% � cl_door% � item0%=2 � xerr%=�
5p% � op_door% � item0%=1 � xerr%=�
5z% � op_door% � item0%=3 � xerr%=�
5�' � unlk_door% � item0%=3 � xerr%=�
5�% � lk_door% � item0%=4 � xerr%=�
5�% � lk_door% � item0%=2 � xerr%=�
5� � xerr% �
5� � 7
5� �
5�# ?ptr%=?ptr% � (&80 >> item0%)
5� � � lk_door% � item0%=3 �
5�+ ?ptr%=?ptr% � %11011111 � %01000000
5� �
5� � lk_door% � item0%=1 �
5� ?ptr%=?ptr% � %11101111
5� �
6 �
6 data_saved=�
6�
6$� claimmenu$=""
6.=0
68
6B� �menuselect_disk35
6LȎ item0% �
6V � 0
6`( path$=�geticondata(savehandle,2)
6j$ ș "OS_File",5,path$ � ftype
6te � ftype=0 � �save_all(path$) � �ensure(item0%,"This file exists. Do you want to replace it?")
6~ � 1
6�* �load_bits(�geticondata(setuph,2))
6� �setup_disk(item0%)
6��
6�&icon%(diskicon)=-1:� claimmenu$=""
6�=0
6�
6�
6�
6�� �menuselect_objected
6�+old_flags%=�(�geticondata(objhandle,8))
6�+new_flags%=old_flags% � (&80 >> item0%)
6�0�changeicon(objhandle,8,�(new_flags%),dummy)
7 � claimmenu$=""
7
=0
7
7� �menuselect_container
7(Ȏ item0% �
72� 0
7<container=� container
7F� container �
7P.�changeicon(objhandle,26,"SIZE <C>",dummy)
7Z�
7d*�changeicon(objhandle,26,"SIZE",dummy)
7n�
7x� 1
7�cont_room=�($controom%)
7��
7�� data_saved=FALSE
7�� claimmenu$=""
7�=0
7�
7�� �menuselect_roomedit
7�-old_flags%=�(�geticondata(roomhandle,34))
7�+new_flags%=old_flags% � (&80 >> item0%)
7�2�changeicon(roomhandle,34,�(new_flags%),dummy)
7�� claimmenu$=""
7�=0
7�
8� �menuselect_key
8Ȏ item0% �
8 � 0:�print_objs
8"$ � 1:�import_obj("O."+$import%)
8,�
86� claimmenu$=""
8@=0
8J
8T� �menuselect_door
8^Ȏ item0% �
8h � 0:�print_rooms
8r& � 1:�import_rooms("R."+$import%)
8|�
8�� claimmenu$=""
8�=0
8�
8�� �menuselect_quill
8�Ȏ item0% �
8� � 0:�print_text
8�% � 1:�import_text("T."+$import%)
8�& �load_dict("D."+$import%)
8��
8�� claimmenu$=""
8�=0
8�
8�� �menuselect_listing
9Ȏ item0% �
9 � 0:�print_program
9 � 1:�convert($import%)
9& � 2:�run
90�
9:� claimmenu$=""
9D=0
9N
9X� �menuselect_chardes
9b2� When `menu` is clicked on the `chardes` icon
9lȎ item0% �
9v5� 0:�save_chars("<Users$Resources>."+$filename2%)
9�� 1
9�,�("PRINT <Alps$Resources>."+$filename2%)
9��display_chr(cur_chr%)
9�"ș ForceR,-1,0,0,scrw+1,scrh+1
9��
9�� claimmenu$=""
9�=0
9�
9�� �menuselect_chrdef
9�K� When button is clicked on the `SELECT` icon in the char design window
9�chr%=�($charnum)
9� � chr%>31 � chr%<=max_chr% �
9� cur_chr%=chr%
:. �changeicon(design,64,�(cur_chr%),icon%)
: �display_chr(cur_chr%)
:�
: � claimmenu$=""
:*=0
:4
:>� �menuselect_vocabulary
:H-� When SELECT pressed in small vocab menu
:RȎ item0% �
:\� 0:�print_vocab
:f�
:p� claimmenu$=""
:z=0
:�
:�� �menuselect_actors
:�2� SELECT pressed in small 'face' menu (Actors)
:�Ȏ item0% �
:�� 0:�print_actors
:��
:�� claimmenu$=""
:�=0
:�
:�� �menuselect_eye
:�3� SELECT pressed in small 'eye' menu (Pictures)
:�Ȏ item0% �
:�� 0:�print_pix
;�
;� claimmenu$=""
;=0
;$
;.� �menuselect_misc
;8Ȏ item0% �
;B � 1: � quit
;L �quit(4)
;V �
;`icon%(THEmiscicon)=-1
;j=0
;t
;~
;�D� ------ Utility procedures and functions for each editor ------
;�
;�0� ------ Character designer utilities ------
;�
;�� �write_chr(C%)
;�� 23,C%
;�� row%=0 � 7
;�row_value=0
;�� col%=0 � 7
;�-dummy=�(�geticondata(design,row%*8+col%))
;�bit=flags% >>> 28
;�,� bit=7 � row_value=row_value+2^(7-col%)
<