' *** STANDARD.GFA *** <<< delete line 0 and 1 >>> 26 November 1993 ' *** This is the full-blown version of the standard program-structure ' ============================================================================== ' *** INLINE *** ' ' *** WARNING: Editing above this line will destroy INLINE-data *** ' ------------------------------------------------------------------------------ ' ******************** ' *** .GFA *** GFA-Basic 3.07 ' ******************** ' *** Program runs in resolution ST-High: yes ST-Medium: yes ST-Low: yes ' ' ------------------------------------------------------------------------------ ' *** Initiation *** ' DEFWRD "a-z" ! word variables (-32768 to +32767) default OPTION BASE 0 ! first element of array has index 0 CLS ! clear TOS-screen HIDEM ! start with invisible mouse DEFMOUSE 0 ! arrow as default ' start.gfa$="\START.GFA" ! <<< 'shell' for GFA-programs >>> ' @program_init ! initialise Standard Globals ' ON ERROR GOSUB edit_error ! <<< use this while developing program >>> ON BREAK GOSUB edit_break ! <<< use this while developing program >>> ' ' *** Do not use ON ERROR or ON BREAK in a compiled program, only in interpreter IF interpreter! ' ON ERROR GOSUB program_error ! <<< activate in finished program >>> ' ON BREAK GOSUB program_break ! <<< activate in finished program >>> ENDIF ' ' @program_resolution("High|Medium|Low") ! <<< activate in finished program >>> ' @program_title("TITLE","date",26) ! <<< activate in finished program >>> ' ' ------------------------------------------------------------------------------ ' *** Main Program *** ' ' @edit_exit ! <<< use this while developing program >>> ' @program_exit ! <<< use this in finished program >>> ' ' ------------------------------------------------------------------------------ ' *** Standard Procedures *** ' > PROCEDURE program_init ' ' *** Initialise Standard Globals ' ' *** Functions: Print_ink$ Print_paper$ ' LOCAL i,w,h,rgb$,res ' IF RIGHT$(CHAR{LONG{LONG{LONG{BASEPAGE+36}+124}+54}},12)="GFABASIC.PRG" interpreter!=TRUE ELSE IF RIGHT$(CHAR{LONG{LONG{LONG{BASEPAGE+36}+124}+54}},12)="GFABASRO.PRG" LET run.only!=TRUE ENDIF ' ' *** 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) ! address of physical screen (monitor) logbase%=XBIOS(3) ! address of logical screen (graphical output) ' white=0 ! default colours (VDI colour-index) black=1 red=2 green=3 blue=4 ! (colours 5-14 not defined as Standard Globals) yellow=15 ' 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 are converted to same index as VDI-colour no. 1) 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 ! 'impossible' colours defined as black green=black blue=black yellow=black DEFTEXT black,0,0,13 ! black 8x16 TEXT-letters ' CASE 1 med.res!=TRUE ! Medium resolution RESTORE stand.med.col ! default Medium palette in DATA-line FOR i=0 TO 3 READ rgb$ SETCOLOR setcolor(i),VAL("&H"+rgb$) NEXT i blue=black ! 'impossible' colours defined as black yellow=black DEFTEXT black,0,0,6 ! black 8x8 TEXT-letters ' CASE 0 low.res!=TRUE ! Low resolution RESTORE stand.low.col ! default Low palette in DATA-line FOR i=0 TO 15 READ rgb$ SETCOLOR setcolor(i),VAL("&H"+rgb$) NEXT i DEFTEXT black,0,0,6 ! black 8x8 TEXT-letters ' ENDSELECT ' FOR i=0 TO PRED(palet.max) standard.palet$=standard.palet$+MKI$(XBIOS(7,i,-1)) ! save default palette NEXT i ' PRINT @print_ink$(black); ! black letters (for PRINT) PRINT @print_paper$(white); ! on white screen (for PRINT) PRINT CHR$(27);"v"; ! wrap on (for PRINT) ' on!=TRUE ! on/off switches off!=FALSE ' return$=CHR$(13) ! define three important keys esc$=CHR$(27) help$=CHR$(0)+CHR$(98) ' RETURN ' *** Standard Globals *** ' ________________________________________________________________________ ' | start.gfa$ x.max& high.res! white& | ' | default.path$ y.max& med.res! black& | ' | interpreter! char.width& low.res! red& | ' | run.only! char.height& green& | ' | col.max& return$ blue& | ' | old.palet$ lin.max& esc$ yellow& | ' | standard.palet$ help$ | ' | palet.max& physbase% on! | ' | color.max&) logbase% kbd.state& off! | ' | setcolor&() | ' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ ' ********* ' > 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$,k,gfa$ ' no=ERR {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer OUT 2,7 ! warning-bell 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]" k=FORM_ALERT(1,alert$) ! inform user about error IF k=1 IF no>=0 AND no<=93 gfa$=ERR$(no) m$=MID$(gfa$,4,LEN(gfa$)-11) m$="The programmer left a bug:|"+m$ ! this will never happen ALERT 3,m$,1,"Oops",k ENDIF @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) ' *** Do not use this Procedure in a compiled program ' ' *** Procedure: Program_break Program_restore Program_exit ' 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 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,"Freeze",k HIDEM {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer WHILE MOUSEK ! mousebuttons released? WEND REPEAT ! screendump now possible UNTIL LEN(INKEY$) OR MOUSEK ENDIF ON BREAK GOSUB program_break ! continue where break occurred CASE 2 @program_restore RUN ! start all over again CASE 3 @program_exit ! abort program ENDSELECT RETURN ' ********* ' > 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_title(title$,datum$,height) ' ' *** My title-screen, not very sophisticated ' *** Shows title (using height&), date and my name ' ' *** 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 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 ~VQT_EXTENT(title$) ! title-width in PTSOUT(2) x=(x.max-PTSOUT(2))/2 y=y.max/2 TEXT x,y,title$ ! centered 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$ ! print my 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 ! draw a box around my name DEFLINE 1,3 DRAW x1+3,y2+2 TO x2+2,y2+2 TO x2+2,y1+3 ! add a shadow-effect LINE x1+3,y2+1,x2+2,y2+1 col=(col.max-LEN(datum$))/2+1 PRINT AT(col,lin+2);datum$ ! print the date {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer WHILE MOUSEK ! mousebuttons released? WEND 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 ! clear screen with black zoom-effect NEXT i COLOR white FOR i=y DOWNTO 0 BOX i,i,x.max-i,y.max-i ! white zoom-effect and we're ready NEXT i COLOR black {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer RETURN ' ********* ' > PROCEDURE program_exit ' ' *** Exit program after restoring a few things ' *** Test if run from (Run Only) interpreter or as compiled program ' *** Procedure tries to locate the 'Shell'-program start.gfa$ ' ' *** Standard: interpreter! run.only! start.gfa$ ' *** Procedure: Program_restore ' LOCAL m$,k ' @program_restore ' IF interpreter! ! (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 runonly! ! (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 ! (3) compiled program SYSTEM ! to the desktop ENDIF ' RETURN ' ********* ' > PROCEDURE program_restore ' ' *** Restore a few things... ' ' *** Standard: old.palet$ black& white& logbase% physbase% kbd.state& ' *** interpreter! ' *** Function: Print_ink$ Print_paper$ ' ~XBIOS(6,L:V:old.palet$) ! restore original palette PRINT @print_ink$(black); ! black PRINT-letters PRINT @print_paper$(white); ! white PRINT-background ~XBIOS(5,L:logbase%,L:physbase%,-1) ! restore original screen CLS ! and clear it ~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 interpreter! CLOSEW 0 ! only in interpreter ENDIF DEFMOUSE 0 ! default mouse-arrow SPOKE &H484,kbd.state ! restore keyboard-state RETURN ' ********* ' ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ' *** <<< delete Edit-Procedures after debugging the finished program >>> ' > PROCEDURE edit_error ' ' *** Show error and abort program or restart ' ' *** Procedure: Edit_exit Program_restore ' LOCAL no,m$,alert$,k,gfa$ ' no=ERR {ADD(XBIOS(14,1),6)}=0 ! clear keyboard-buffer OUT 2,7 ! warning-bell m$="ERROR, program aborted |" 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]" k=FORM_ALERT(1,alert$) ! inform user about error IF k=1 IF no>=0 AND no<=93 gfa$=ERR$(no) m$=MID$(gfa$,4,LEN(gfa$)-11) m$="GFA-Basic complains:|"+m$ ALERT 3,m$,1,"Stupid",k ! kill that bug, stupid ENDIF @edit_exit ! abort program ELSE @program_restore RUN ! restart program ENDIF RETURN ' ********* ' > PROCEDURE edit_break ' ' *** Restore a few things after a break ' ' *** Procedure: Edit_exit ' ON BREAK CONT @edit_exit RETURN ' ********* ' > PROCEDURE edit_exit ' ' *** Exit program after restoring a few things ' ' *** Procedure: Program_restore ' @program_restore EDIT ' 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)) ' ' ------------------------------------------------------------------------------ ' *** Procedures *** ' ' ' ------------------------------------------------------------------------------ ' *** Functions *** ' ' ' ------------------------------------------------------------------------------ ' *** 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 *** ' ==============================================================================