' ============================================================================== ' *** INLINE *** ' *** WARNING: Editing between INLINE-lines will destroy INLINE-data *** ' INLINE boing3%,38 INLINE boing4%,36 INLINE boing5%,36 INLINE boing6%,36 INLINE clock%,30 INLINE ding%,30 INLINE dingdong%,60 INLINE dlink%,66 INLINE explosn1%,30 INLINE explosn2%,36 INLINE fft%,30 INLINE gong1%,30 INLINE gong2%,30 INLINE gong3%,32 INLINE heli%,30 INLINE jingle%,150 INLINE keyclick%,30 INLINE laser%,38 INLINE piew%,36 INLINE ploink%,66 INLINE poing%,36 INLINE pompom%,384 INLINE shot%,60 INLINE siren2%,36 INLINE steam%,60 INLINE surf%,30 INLINE thrill%,66 INLINE ting2%,30 INLINE tingel1%,38 INLINE tingel2%,36 INLINE toing%,30 INLINE zap%,66 ' ' *** WARNING: Editing above this line will destroy INLINE-data *** ' ------------------------------------------------------------------------------ ' ******************** ' *** SOUND_FX.GFA *** GFA-Basic 3.07 ' ******************** ' *** This program runs in resolution High: yes Medium: yes Low: no ' ' ------------------------------------------------------------------------------ ' *** Initiation *** ' DEFWRD "a-z" ! word variables (-32768 to +32767) default OPTION BASE 0 ! first element of array has index 0 ' @program_init ! initialise Standard Globals ' ON ERROR GOSUB program_error ON BREAK GOSUB program_break @program_resolution("High|Medium") @program_title("XBIOS 32 SOUND-EFFECTS","4 September 1993",26) ' ' ------------------------------------------------------------------------------ ' *** Main Program *** ' RESTORE sound.names DIM name$(32) FOR i=1 TO 32 READ name$(i) NEXT i ' ' *** Draw screen PRINT PRINT @center$("*** Xbios 32 Sound-Effects ***") columns=4 rows=8 x.start=20 y.start=3*char.height box.width=15*char.width box.height=1.5*char.height column.width=box.width+32 column.height=box.height+char.height snd.x1=x.start snd.x2=x.start+(columns-1)*column.width+box.width snd.y1=y.start snd.y2=y.start+(rows-1)*column.height+box.height DEFTEXT black,0,0,13 FOR column=1 TO columns x1=x.start+(column-1)*column.width x2=x1+box.width FOR line=1 TO rows y1=y.start+(line-1)*column.height y2=y1+box.height n=(column-1)*rows+line TEXT x1,y1+(y2-y1)/2+6,x2-x1," "+name$(n)+" " BOX x1,y1,x2,y2 NEXT line NEXT column x1.quit=x.start+1.5*column.width x2.quit=x1.quit+box.width y1.quit=y.start+rows*column.height y2.quit=y1.quit+box.height DEFTEXT black,1,0,13 TEXT x1.quit,y1.quit+(y2.quit-y1.quit)/2+6,x2.quit-x1.quit," QUIT " BOX x1.quit,y1.quit,x2.quit,y2.quit ' ' *** Process user-action SHOWM DEFMOUSE 3 REPEAT ' REPEAT MOUSE x,y,k UNTIL k=1 ' IF y>y1.quit AND x>x1.quit AND xsnd.x2 OR ysnd.y2) AND NOT quit! OUT 2,7 ! bell ELSE IF NOT quit! column=(x-x.start)/column.width+1 line=(y-y.start)/column.height+1 n=(column-1)*rows+line IF n>=1 AND n<=32 x1=x.start+(column-1)*column.width x2=x1+box.width y1=y.start+(line-1)*column.height y2=y1+box.height @box_reverse(x1,y1,x2,y2) HIDEM @sound PAUSE 50 @box_reverse(x1,y1,x2,y2) SHOWM ENDIF ENDIF ' UNTIL quit! DEFMOUSE 0 WAVE 0,0 ' ' @program_exit ' ' ------------------------------------------------------------------------------ ' *** Standard Procedures *** ' > PROCEDURE program_resolution(res$) ' ' *** Test for correct resolution and abort program if wrong resolution ' *** This Procedure checks for High (2), Medium (1) and Low (0) ST-resolution ' *** Res$ is examined for the letters H, M and L and the digits 2, 1 and 0 ' *** Examples of correct format (upper case also permitted): ' *** "10" "2/1/0" "hml" "high|low" "med,low" "high;med;low" ' ' *** Procedure: Program_exit ' LOCAL p,alert$,t$ res$=UPPER$(res$) ! convert to upper case p=INSTR(res$,"MIDDLE") IF p MID$(res$,p)="MEDIUM" ! "L" in "Middle" recognized as Low ENDIF IF INSTR(res$,"L") OR INSTR(res$,"0") t$=t$+"0" ENDIF IF INSTR(res$,"M") OR INSTR(res$,"1") t$=t$+"1" ENDIF IF INSTR(res$,"H") OR INSTR(res$,"2") t$=t$+"2" ENDIF res$=t$ ! res$ is now combination of 0,1 and 2 ' IF INSTR(res$,STR$(XBIOS(4)))=0 ! check resolution ' *** wrong resolution: warn user and abort program IF res$="01" OR res$="10" t$="Medium and Low |" ELSE IF res$="12" OR res$="21" t$="Medium and High |" ELSE IF res$="02" OR res$="20" t$="Low and High |" ELSE IF res$="0" t$="Low" ELSE IF res$="1" t$="Medium" ELSE IF res$="2" t$="High" ENDIF alert$="[3][ *** Wrong resolution *** | | This program runs in" alert$=alert$+" | "+t$+" resolution! ][ Sorry ]" OUT 2,7 ! warning-bell ~FORM_ALERT(1,alert$) ! inform user about correct resolution @program_exit ! abort program ' ENDIF ' ' *** resolution all right, continue with program ' RETURN ' ********* ' > PROCEDURE program_init ' ' *** Initialise Global Standards ' ' *** Functions: Print_ink$ Print_paper$ ' LOCAL i,w,h,rgb$,res ' CLS ! clear TOS-screen HIDEM ! start with invisible mouse DEFMOUSE 0 ! arrow as default ' interpreter$="\GFABASIC.PRG" ! <<< change path if necessary >>> run.only$="\GFABASRO.PRG" ! <<< Run-Only Interpreter >>> start.gfa$="\START.GFA" ! <<< 'shell' for GFA-programs >>> start.prg$="\GFASTART.PRG" ! <<< 'shell' for compiled GFA-programs >>> ' ' *** WARNING: use CHDIR before calling this program (*.GFA), otherwise ' *** the path of the interpreter is returned as default.path$ ' *** (after compiling the path is correct) default.path$=CHR$(GEMDOS(&H19)+65)+":"+DIR$(GEMDOS(&H19)+1)+"\" ' palet.max=WORK_OUT(39) ! number of colours in palette color.max=WORK_OUT(13) ! number of colours on screen FOR i=0 TO PRED(palet.max) ! save old palette in string old.palet$=old.palet$+MKI$(XBIOS(7,i,-1)) NEXT i ' kbd.state=PEEK(&H484) ! current keyboard-state ' physbase%=XBIOS(2) ! physical screen logbase%=XBIOS(3) ! logical screen ' white=0 ! default colours black=1 red=2 green=3 blue=4 ! (colours 5-15 not defined as Standard Globals) ' x.max=WORK_OUT(0) ! maximal screen-coordinates y.max=WORK_OUT(1) ' ~GRAF_HANDLE(char.width,char.height,w,h) ! character-width and -height ' col.max=DIV(SUCC(x.max),char.width) ! last column/line for PRINT lin.max=DIV(SUCC(y.max),char.height) ' ' *** use setcolor&() to convert a VDI colour-index into a SETCOLOR-index ' *** ('unused' colours in current resolution are defined as black) res=XBIOS(4) ! current resolution DIM setcolor(15) IF res=2 ! High RESTORE col.index.high ELSE IF res=1 ! Medium RESTORE col.index.med ELSE IF res=0 ! Low RESTORE col.index.low ENDIF FOR i=0 TO 15 READ setcolor(i) ! fill array with SETCOLOR-indices from DATA NEXT i ' SELECT res ! examine current resolution (High/Medium/Low) ' CASE 2 high.res!=TRUE ! High resolution VSETCOLOR 1,0 ! white background red=black green=black blue=black DEFTEXT black,0,0,13 ! black 8x16 letters ' CASE 1 med.res!=TRUE ! Medium resolution RESTORE stand.med.col ! Standard Medium palette FOR i=0 TO 3 READ rgb$ SETCOLOR setcolor(i),VAL("&H"+rgb$) NEXT i blue=black DEFTEXT black,0,0,6 ! black 8x8 letters ' CASE 0 low.res!=TRUE ! Low resolution RESTORE stand.low.col ! Standard Low palette FOR i=0 TO 15 READ rgb$ SETCOLOR setcolor(i),VAL("&H"+rgb$) NEXT i DEFTEXT black,0,0,6 ! black 8x8 letters ' ENDSELECT ' FOR i=0 TO PRED(palet.max) standard.palet$=standard.palet$+MKI$(XBIOS(7,i,-1)) ! save Standard palette NEXT i ' PRINT @print_ink$(black); ! black letters PRINT @print_paper$(white); ! on white screen (for PRINT) PRINT CHR$(27);"v"; ! wrap on ' on!=TRUE ! switches off!=FALSE ' return$=CHR$(13) ! define three important keys esc$=CHR$(27) help$=CHR$(0)+CHR$(98) ' RETURN ' *** Standard Globals *** ' ________________________________________________________________________ ' | interpreter$ x.max& high.res! white& | ' | run.only$ y.max& med.res! black& | ' | start.gfa$ char.width& low.res! red& | ' | start.prg$ char.height& green& | ' | col.max& on! blue& | ' | old.palet$ lin.max& off! | ' | standard.palet$ ! ' | | ' | palet.max& physbase% kbd.state& return$ | ' | color.max& logbase% esc$ | ' | help$ | ' | setcolor&() default.path$ | ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ ' ********* ' > PROCEDURE program_title(title$,datum$,height) ' ' *** My title-screen, not very sophisticated ' ' *** Standard: x.max& y.max& high.res! med.res! low.res! ' *** black& red& blue& col.max& lin.max& char.height& ' LOCAL x,y,col,lin,name$,x1,y1,x2,y2,i CLS HIDEM x=(x.max-LEN(title$)*height/2)/2 y=y.max/2 IF high.res! DEFTEXT black,8,0,height ! black in High ELSE IF med.res! DEFTEXT red,8,0,height ! red in Medium ELSE IF low.res! DEFTEXT blue,8,0,height ! blue in Low ENDIF TEXT x,y,title$ IF high.res! DEFTEXT black,0,0,13 ELSE DEFTEXT black,0,0,6 ENDIF LET name$="© Han Kempen" ! that's me col=(col.max-12)/2 lin=lin.max/2+6 PRINT AT(col,lin);name$ x1=(col-2)*8 y1=(lin-1)*char.height-4 x2=x1+LEN(name$)*8+16 y2=y1+char.height+8 BOX x1,y1,x2,y2 DEFLINE 1,3 DRAW x1+3,y2+2 TO x2+2,y2+2 TO x2+2,y1+3 LINE x1+3,y2+1,x2+2,y2+1 col=(col.max-LEN(datum$))/2+1 PRINT AT(col,lin+2);datum$ REPEAT UNTIL LEN(INKEY$) OR MOUSEK ! wait for mouse- or key-click COLOR black DEFLINE 1,1 FOR i=0 TO y BOX i,i,x.max-i,y.max-i NEXT i COLOR white FOR i=y DOWNTO 0 BOX i,i,x.max-i,y.max-i NEXT i COLOR black {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer CLS RETURN ' ********* ' > PROCEDURE program_error ' ' *** Activate in program with: ON ERROR GOSUB program_error ' *** Show error and abort program or restart ' *** Do not use this Procedure in a compiled program ' ' *** Procedure: Program_exit Program_restore ' LOCAL no,m$,alert$ ' no=ERR {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer m$="ERROR, program aborted (sorry)|" IF no>=102 AND no<=109 m$=m$+" | *** "+STR$(no-100)+" bombs ***| " ELSE IF no>=0 AND no<=93 m$=m$+" | *** GFA-error No. "+STR$(no)+" ***| " ELSE IF no<=-1 m$=m$+" | *** TOS-error No. "+STR$(no)+" ***| " ELSE m$=m$+" | *** Error No. "+STR$(no)+" (?) ***| " ENDIF m$=m$+"|Quit program or try a Restart?" alert$="[3]["+m$+"][Quit|Restart]" OUT 2,7 ! warning-bell k=FORM_ALERT(1,alert$) ! inform user about error IF k=1 @program_exit ! abort program ELSE @program_restore RUN ! restart program ENDIF RETURN ' ********* ' > PROCEDURE program_break ' ' *** Activate in program with: ON BREAK GOSUB program_break ' *** User can continue program, restart program, or abort program ' *** After continuing program, user can freeze screen (e.g. for screendump) ' *** Pressing the 'Break'-keys after continuing results in a true Break ' *** Do not use this Procedure in a compiled program ' ' *** Procedure: Program_exit Program_restore ' LOCAL m$,k ON BREAK CONT m$=" *** Break *** | Continue program,| Restart program|" m$=m$+" or Quit program? " ALERT 3,m$,1,"Continue|Restart|Quit",k SELECT k CASE 1 ON BREAK ! true break possible for emergency m$="|Freeze |current |screen ?" ALERT 2,m$,2,"Yes|No",k IF k=1 m$="|Press any key| |to continue program" ALERT 1,m$,1," Ok ",k HIDEM REPEAT ! screendump now possible UNTIL LEN(INKEY$) OR MOUSEK ENDIF ON BREAK GOSUB program_break CASE 2 @program_restore RUN CASE 3 @program_exit ENDSELECT RETURN ' ********* ' > PROCEDURE program_exit ' ' *** Exit program after restoring a few things ' *** Procedure tries to locate the 'Shell'-program start.gfa$ or start.prg$ ' *** Also examines if run from (Run Only) interpreter or as compiled program ' ' *** Standard: interpreter$ run.only$ start.gfa$ start.prg$ ' *** Procedure: Program_restore ' LOCAL interp!,runonl!,m$,k ' @program_restore ' interp!=(RIGHT$(CHAR{LONG{LONG{LONG{BASEPAGE+36}+124}+54}},12)="GFABASIC.PRG") runonl!=(RIGHT$(CHAR{LONG{LONG{LONG{BASEPAGE+36}+124}+54}},12)="GFABASRO.PRG") ' IF interp! ! (1) program run from interpreter IF EXIST(start.gfa$) ! (1a) Shell-program available m$=" *** The End ***|" m$=" Run Shell-program, | go to GFA-editor | or quit to Desktop?" ALERT 2,m$,1,"Shell|Edit|Desk",k IF k=1 CHAIN start.gfa$ ! to the Shell-program ELSE IF k=2 EDIT ! to the interpreter ELSE SYSTEM ! to the desktop ENDIF ELSE ! (1b) no Shell-program found m$=" *** The End ***| |" m$=" Go to GFA-editor | or quit to Desktop?" ALERT 2,m$,1,"Edit|Desk",k IF k=1 EDIT ! to the interpreter ELSE SYSTEM ! to the desktop ENDIF ENDIF ' ELSE IF runonl! ! (2) program run from Run-Only interpreter IF EXIST(start.gfa$) ! (2a) Shell-program available m$=" *** The End ***|" m$=" Run Shell-program, | use Run-Only interpreter | or quit to Desktop?" ALERT 2,m$,1,"Shell|RunOnly|Desk",k IF k=1 CHAIN start.gfa$ ! to the Shell-program ELSE IF k=2 EDIT ! to the Run-Only interpreter ELSE SYSTEM ! to the desktop ENDIF ELSE ! (2b) no Shell-program found m$=" *** The End ***| |" m$=" Use Run-Only interpreter | or quit to Desktop?" ALERT 2,m$,1,"RunOnly|Desk",k IF k=1 EDIT ! to the Run-Only interpreter ELSE SYSTEM ! to the desktop ENDIF ENDIF ' ELSE IF EXIST(start.prg$) ! (3a) compiled program, Shell-program available m$=" *** The End ***|" m$=" Run Shell-program | or quit to Desktop?" ALERT 2,m$,1,"Shell|Desk",k IF k=1 CHAIN start.prg$ ! to the Shell-program ELSE SYSTEM ! to the desktop ENDIF ' ELSE ! (3b) compiled program, no Shell-program found SYSTEM ! to the desktop ENDIF ' RETURN ' ********* ' > PROCEDURE program_restore ' ' *** Restore a few things... ' ' *** Standard: old.palet$ black& white& physbase% kbd.state& ' *** Function: Print_ink$ Print_paper$ ' ~XBIOS(6,L:V:old.palet$) ! restore original palette PRINT @print_ink$(black); ! black letters PRINT @print_paper$(white); ! white screen ~XBIOS(5,L:logbase%,L:physbase%,-1) ! restore original screen CLS ~RSRC_FREE() ! restore reserved Resource-memory IF GDOS? ~VST_UNLOAD_FONTS(0) ! remove GDOS-fonts ENDIF RESERVE ! restore reserved memory CLOSE ! close all channels IF (RIGHT$(CHAR{LONG{LONG{LONG{BASEPAGE+36}+124}+54}},12)="GFABASIC.PRG") CLOSEW 0 ! only in interpreter ENDIF DEFMOUSE 0 ! default mouse-arrow SPOKE &H484,kbd.state ! restore keyboard-state RETURN ' ********* ' ' ------------------------------------------------------------------------------ ' *** Standard Functions *** ' DEFFN center$(text$)=SPACE$(DIV(MAX(0,SUB(col.max,LEN(text$))),2))+text$ DEFFN rev$(text$)=CHR$(27)+"p"+text$+CHR$(27)+"q" DEFFN print_ink$(color)=CHR$(27)+"b"+CHR$(setcolor(color)) DEFFN print_paper$(color)=CHR$(27)+"c"+CHR$(setcolor(color)) ' ' ------------------------------------------------------------------------------ ' *** Functions *** ' ' ' ------------------------------------------------------------------------------ ' *** Procedures *** ' ' *** BOX_REV.LST *** 2nd GFA-Manual, page 20-24 > PROCEDURE box_reverse(x1,y1,x2,y2) ' ' *** Invert box (e.g. to tell user that option has been chosen) ' *** Call Procedure again (with same parameters) to restore original box ' GRAPHMODE 3 DEFFILL 1,1 BOUNDARY 0 PBOX x1,y1,x2,y2 BOUNDARY 1 GRAPHMODE 1 RETURN ' ********* ' ' *** DOSOUND.LST *** 2nd GFA-Manual, page 16-11 > PROCEDURE dosound(adr%) ' ' *** Play XBIOS 32 sound-string (at address adr%) ' ~XBIOS(32,L:adr%) RETURN ' ********* ' > PROCEDURE sound ' *** Let's hear the sound-effect SELECT n CASE 1 @dosound(boing3%) CASE 2 @dosound(boing4%) CASE 3 @dosound(boing5%) CASE 4 @dosound(boing6%) CASE 5 @dosound(clock%) CASE 6 @dosound(ding%) CASE 7 @dosound(dingdong%) CASE 8 @dosound(dlink%) CASE 9 @dosound(explosn1%) CASE 10 @dosound(explosn2%) CASE 11 @dosound(fft%) CASE 12 @dosound(gong1%) CASE 13 @dosound(gong2%) CASE 14 @dosound(gong3%) CASE 15 @dosound(heli%) CASE 16 @dosound(jingle%) CASE 17 @dosound(keyclick%) CASE 18 @dosound(laser%) CASE 19 @dosound(piew%) CASE 20 @dosound(ploink%) CASE 21 @dosound(poing%) CASE 22 @dosound(pompom%) CASE 23 @dosound(shot%) CASE 24 @dosound(siren2%) CASE 25 @dosound(steam%) CASE 26 @dosound(surf%) CASE 27 @dosound(thrill%) CASE 28 @dosound(ting2%) CASE 29 @dosound(tingel1%) CASE 30 @dosound(tingel2%) CASE 31 @dosound(toing%) CASE 32 @dosound(zap%) ENDSELECT RETURN ' ********* ' ' ------------------------------------------------------------------------------ ' *** Data *** ' stand.med.col: DATA 777,000,700,060 ' stand.low.col: DATA 777,000,700,060,007,005,520,050,555,111,077,053,707,505,550,770 ' col.index.high: DATA 0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 ' col.index.med: DATA 0,3,1,2,3,3,3,3,3,3,3,3,3,3,3,3 ' col.index.low: DATA 0,15,1,2,4,6,3,5,7,8,9,10,12,14,11,13 ' ' *** The names of the 32 Xbios 32 sound-effects sound.names: DATA BOING3,BOING4,BOING5,BOING6,CLOCK,DING,DINGDONG,DLINK DATA EXPLOSN1,EXPLOSN2,FFT,GONG1,GONG2,GONG3,HELI,JINGLE DATA KEYCLICK,LASER,PIEW,PLOINK,POING,POMPOM,SHOT,SIREN2 DATA STEAM,SURF,THRILL,TING2,TINGEL1,TINGEL2,TOING,ZAP ' ' ------------------------------------------------------------------------------ ' *** The End *** ' ==============================================================================