' ============================================================================== ' ******************** ' *** X32_SONG.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 SONG-PLAYER","4 September 1993",26) ' ' ------------------------------------------------------------------------------ ' *** Main Program *** ' e$="*.X32" ! default extension IF EXIST(default.path$+e$) ! are the songs here? path$=default.path$+e$ ELSE IF EXIST(default.path$+"*.INL") ! perhaps available as INLINE-files? e$="*.INL" path$=default.path$+e$ ELSE IF EXIST("I:\DATA\SONGS.X32\"+e$) ! my path path$="I:\DATA\SONGS.X32\"+e$ ELSE IF EXIST("A:\XBIOS_32\SONGS\*.INL")! probably your path e$="*.INL" path$="A:\XBIOS_32\SONGS\"+e$ ELSE path$=default.path$+e$ ! fall back to default extension ENDIF ' DO ' CLS txt$="Choose song =Quit" @fileselect(txt$,path$,"",file$) ! choose a song EXIT IF file$="" OR RIGHT$(file$)="\" LET name$=@file_name$(file$) path$=@file_path$(file$)+e$ ' IF RIGHT$(file$,4)=".X32" OR RIGHT$(file$,4)=".INL" ! check extension CLS PRINT AT(1,12);@center$("Loading "+name$+" ...") @file_load(file$,song|(),song%) ! load the song CLS @song_play(song%) ! play the song CLS PRINT AT(1,2);@center$("*** Xbios 32 Song-Player ***") PRINT AT(1,12);@center$(" Playing "+@rev$(" "+name$+" ")+" ...") PRINT AT(1,24);@center$("Press any key to stop song") {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer WHILE MOUSEK ! all buttons released? WEND REPEAT adr%=XBIOS(32,L:-1) ! 0 = end of song UNTIL adr%=0 OR LEN(INKEY$) OR MOUSEK @song_stop ENDIF LOOP ' @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 *** ' ' *** FILENAME.LST *** 2nd GFA-Manual, page 11-25 ' *** Return filename (without path), e.g. "CHESS.GFA" DEFFN file_name$(file$)=RIGHT$(file$,LEN(file$)-RINSTR(file$,"\")) ' *** ' ' *** FILEPATH.LST *** 2nd GFA-Manual, page 11-25 ' *** Return path (without filename), e.g. "A:\GAMES\" DEFFN file_path$(file$)=LEFT$(file$,RINSTR(file$,"\")) ' *** ' ' ------------------------------------------------------------------------------ ' *** Procedures *** ' ' *** FILE_SEL.LST *** 2nd GFA-Manual, page 11-21 > PROCEDURE fileselect(text$,path$,default$,VAR file$) ' ' *** Universal Fileselector with comment-line (title) for all TOS-versions ' *** If TOS-version from 1.4, command FILESELECT shows comment-line ' *** For earlier TOS-versions the comment-line is shown by this Procedure ' *** The comment-line must not exceed 30 characters ' ' *** Standard: high.res! med.res! low.res! col.max& char.width& char.height& ' LOCAL box$ IF LEN(txt$)>30 OUT 2,7 ! bell txt$=LEFT$(txt$,30) ENDIF IF DPEEK(ADD(LPEEK(&H4F2),2))>=&H104 ! examine TOS-version FILESELECT #text$,path$,default$,file$ ELSE IF high.res! DEFTEXT ,0,0,13 ELSE DEFTEXT ,0,0,6 ENDIF GET 0,0,x.max,4*char.height,box$ ! save background GRAPHMODE 1 DEFFILL 1,0 BOUNDARY 1 IF high.res! PBOX 157,20,482,54 ! outer box DEFFILL 1,1 BOUNDARY 0 PBOX 159,22,480,52 ! black inner box ELSE IF med.res! PBOX 157,6,482,27 DEFFILL 1,1 BOUNDARY 0 PBOX 160,8,479,24 ELSE IF low.res! PBOX 0,12,319,27 DEFFILL 1,1 BOUNDARY 0 PBOX 2,14,317,24 ENDIF GRAPHMODE 3 ! white letters on black box IF low.res! TEXT MUL(DIV(SUB(col.max,LEN(text$)),2),char.width),SUB(MUL(3,char.height),2),text$ ELSE IF med.res! TEXT MUL(DIV(SUB(col.max,LEN(text$)),2),char.width),SUB(MUL(3,char.height),5),text$ ELSE IF high.res! TEXT MUL(DIV(SUB(col.max,LEN(text$)),2),char.width),SUB(MUL(3,char.height),8),text$ ENDIF BOUNDARY 1 GRAPHMODE 1 FILESELECT path$,default$,file$ PUT 0,0,box$ ! restore background ENDIF RETURN ' ********* ' ' *** FILELOAD.LST *** 2nd GFA-Manual, page 11-21 > PROCEDURE file_load(file$,VAR array|(),adr%) ' ' *** Load file$ into byte-array ' *** Return address of loaded file in adr% (0 if loading not succesful) ' *** Procedure refuses to load if less than 2000 bytes would remain free ' *** WARNING: after an ERASE adr% is not correct anymore! ' ' *** Procedure: Program_exit ' LOCAL bytes%,free%,m$,k IF EXIST(file$) bytes%={FGETDTA()+26} ! file-length free%=FRE()-2000 ! free RAM (leave at least 2000 bytes) IF free%>bytes% IF DIM?(array|())>0 ERASE array|() ENDIF DIM array|(PRED(bytes%)) ! byte-array for file adr%=V:array|(0) BLOAD file$,adr% ! load file here ELSE m$=" *** Error ***|Not enough memory |available for loading |" m$=m$+"file "+RIGHT$(file$,LEN(file$)-RINSTR(file$,"\")) ALERT 3,m$,1,"Continue|Quit",k IF k=1 adr%=0 ELSE @program_exit ENDIF ENDIF ELSE m$=" *** Error ***| |File "+RIGHT$(file$,LEN(file$)-RINSTR(file$,"\")) m$=m$+"|not found" ALERT 3,m$,1,"Continue|Quit",k IF k=1 adr%=0 ELSE @program_exit ENDIF ENDIF RETURN ' ********* ' ' *** SONGPLAY.LST *** 2nd GFA-Manual, page 16-13 > PROCEDURE song_play(adr%) ' ' *** Play a XBIOS 32 song ' *** Address of song (in byte-array or INLINE-line) is adr% ' *** Key-click is temporarily off ' ' *** Global: song.adr% [for Song_restart and Song_continue] ' song.adr%=adr% SPOKE &H484,BCLR(PEEK(&H484),0) ! key-click off ~XBIOS(32,L:song.adr%) ! start the song RETURN ' ********* ' ' *** SONGSTOP.LST *** 2nd GFA-Manual, page 16-13 > PROCEDURE song_stop ' ' *** Stop the song and switch key-click on again ' WAVE 0,0 SPOKE &H484,BSET(PEEK(&H484),0) ! key-click on 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 End *** ' ==============================================================================