home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ST-Computer Leser 2002 January
/
STC_CD_01_2002.iso
/
GAMES
/
DR_WHO
/
SOURCE
/
USERWORK.LST
< prev
Wrap
File List
|
2002-01-16
|
20KB
|
708 lines
> FUNCTION zeilenzaehler(dat$)
IF EXIST(dat$)
ERASE dummy$()
DIM dummy$(50)
OPEN "I",#1,dat$
anz_zeilen%=0
RECALL #1,dummy$(),-1,z%
WHILE z%
ADD anz_zeilen%,z%
RECALL #1,dummy$(),-1,z%
WEND
CLOSE #1
RETURN anz_zeilen%
ELSE
RETURN 0
ENDIF
ENDFUNC
> PROCEDURE questions
fragen:
' num_q%=67
' dat_q%=@zeilenzaehler$(program_path$)
DIM temp$(200)
OPEN "I",#1,program_path$+"QUESTION.WHO"
RECALL #1,temp$(),200,len%
CLOSE #1
num_q%=len%
DIM p$(num_q%),typ$(num_q%),t$(num_q%),answ$(num_q%),r$(num_q%),h%(num_q%),d$(num_q%)
FOR i%=1 TO num_q%
a$=temp$(i%)
p$(i%)=@teil$(CHR$(9),a$)
typ$(i%)=@teil$(CHR$(9),a$)
t$(i%)=@teil$(CHR$(9),a$)
answ$(i%)=@teil$(CHR$(9),a$)
r$(i%)=@teil$(CHR$(9),a$)
d$(i%)=@teil$(CHR$(9),a$)
NEXT i%
ERASE temp$()
RETURN
> FUNCTION teil$(sep$,VAR a$)
LOCAL b$,a&
a&=INSTR(a$,sep$)
IF a&
b$=LEFT$(a$,PRED(a&))
a$=MID$(a$,SUCC(a&))
ELSE
b$=a$
a$=""
ENDIF
RETURN b$
ENDFUNC
> PROCEDURE dialog_aufbauen
INC frage%
IF frage%=12
@finish
ENDIF
@additional
@zufall
ausgang!=FALSE
c$=answ$(auswahl%)
FOR i&=whoansw1& TO whoansw3&
@rsc_ob_hide(multiple&,i&,FALSE)
d$=@teil$("|",c$)
@rsc_set_text2(multiple&,i&,d$)
NEXT i&
c$=t$(auswahl%)
FOR i&=textl1& TO textl4&
@rsc_set_text2(multiple&,i&,@teil$("|",c$))
NEXT i&
@rsc_set_text2(multiple&,right&,STR$(richtig%))
@rsc_set_text2(multiple&,wrong&,STR$(falsch%))
p$=p$(auswahl%)
IF p$(auswahl%)="RND"
i%=INT(RND(1)*8)+1
p$=STR$(i%)
ENDIF
SELECT p$
CASE "COY","1"
icon&=icon2&
CASE "ACE","2"
icon&=icon1&
CASE "DR1","3"
icon&=icon3&
CASE "DR3","4"
icon&=icon4&
CASE "DR4","5"
icon&=icon5&
CASE "PLA","6"
icon&=world&
CASE "BRI","7"
icon&=brigadier&
CASE "TAR","8"
icon&=tardis&
CASE "DAL","9"
icon&=dalek&
DEFAULT
icon&=icon_who&
ENDSELECT
tree%=@xrsrc_gaddr(0,multiple&)
tree2%=@xrsrc_gaddr(0,whoicons&)
OB_TYPE(tree%,picbox&)=OB_TYPE(tree2%,icon&)
OB_SPEC(tree%,picbox&)=OB_SPEC(tree2%,icon&)
RETURN
> PROCEDURE zufall
auswahl%=INT(RND(1)*num_q%)+1
IF h%(auswahl%)>klein%
FOR i%=1 TO 10
auswahl%=INT(RND(1)*num_q%)+1
EXIT IF h%(auswahl%)=klein%
NEXT i%
IF i%=10
FOR i%=1 TO num_q%
EXIT IF h%(i%)=klein%
NEXT i%
IF i%=num_q% AND h%(num_q%)>klein%
INC klein%
ELSE
auswahl%=i%
ENDIF
ENDIF
ENDIF
ADD h%(auswahl%),1
RETURN
> PROCEDURE finish
@win_close(multiple_dialog&)
@rsc_set_text(whofinish&,ranswer&,STR$(richtig%))
@rsc_set_text(whofinish&,wanswer&,STR$(falsch%))
finish_dialog&=@win_open_dialog(2,whofinish&,icfyicon&)
RETURN
> PROCEDURE additional
IF LEFT$(d$(auswahl%),1)="#"
e$=RIGHT$(d$(auswahl%),LEN(d$(auswahl%))-1)
IF ausgang!=FALSE
CLR e$
ENDIF
ELSE
e$=d$(auswahl%)
ENDIF
f$=@teil$("|",e$)
@rsc_set_text(multiple&,addinfo1&,f$)
@rsc_ob_reset(multiple&,addinfo1&)
@rsc_set_text(multiple&,addinfo2&,e$)
@rsc_ob_reset(multiple&,addinfo2&)
RETURN
> PROCEDURE cab_show(a$)
cabid&=APPL_FIND("CAB ")
IF cabid&>-1
' LOCAL b$
adr%=@mxalloc_global(255)
CHAR{adr%}=a$+CHR$(0)
DIM msg&(7)
msg&(0)=WORD(&HCAB3)
msg&(1)=ap_id&
msg&(2)=0
msg&(3)=WORD(SWAP(adr%))
msg&(4)=WORD(adr%)
msg&(5)=0
msg&(6)=0
msg&(7)=0
~APPL_WRITE(cabid&,16,msg&(0))
~EVNT_TIMER(50)
~MFREE(adr%)
ERASE msg&()
ELSE
cabid&=APPL_FIND("ADAMAS ")
adr%=@mxalloc_global(255)
CHAR{adr%}=a$+CHR$(0)
DIM msg&(7)
msg&(0)=&H4711
msg&(1)=ap_id&
msg&(2)=0
msg&(3)=WORD(SWAP(adr%))
msg&(4)=WORD(adr%)
msg&(5)=0
msg&(6)=0
msg&(7)=0
~APPL_WRITE(cabid&,16,msg&(0))
~EVNT_TIMER(50)
~MFREE(adr%)
ERASE msg&()
ENDIF
RETURN
> PROCEDURE mouse(VAR mx&,my&,mk&)
LOCAL void&
'
~WIND_UPDATE(3)
~GRAF_MKSTATE(mx&,my&,mk&,void&)
~WIND_UPDATE(2)
'
SUB mx&,WORD{WINDTAB+64}
SUB my&,WORD{WINDTAB+66}
RETURN
> FUNCTION lang$(a&)
RETURN @rsc_get_text$(language&,a&)
ENDFUNC
> FUNCTION bitplanes
$F%
'
RETURN INT{{GB+4}+20}
ENDFUNC
> FUNCTION environment$(such$)
a=SHEL_ENVRN(a%,UPPER$(such$))
IF a%>0
a$=CHAR{a%}
IF INSTR(a$,"=")>0
a=INSTR(a$,"=")
env$=RIGHT$(a$,LEN(a$)-a)
ELSE
env$=a$
ENDIF
RETURN env$
ELSE
RETURN ""
ENDIF
ENDFUNC
> FUNCTION name$(file$)
LOCAL backslash&,punkt&,a$
'
LET backslash&=RINSTR(file$,"\")
IF backslash&
LET file$=MID$(file$,SUCC(backslash&))
ELSE
LET doppelpunkt&=INSTR(file$,":")
LET file$=MID$(file$,SUCC(doppelpunkt&))
ENDIF
'
LET punkt&=INSTR(file$,".")
IF punkt&
a$=LEFT$(file$,PRED(punkt&))
ELSE
a$=file$
ENDIF
IF LEN(a$)<8
n$=UPPER$(a$)+STRING$(8-LEN(a$)," ")
ELSE
n$=UPPER$(a$)
ENDIF
RETURN n$
'
ENDFUNC
> PROCEDURE rsc_set_text2(tree&,object&,string$)
@rsc_set_text(tree&,object&,string$)
@rsc_ob_reset(tree&,object&)
RETURN
> FUNCTION rsc_get_text$(tree&,object&) !call
LOCAL tree%,obspec%
tree%=@xrsrc_gaddr(0,tree&)
obspec%=ADD(faceval_sys%,INT{ADD(faceval_sys%,18)})
RETURN CHAR{C:obspec%(L:tree%,object&)}
ENDFUNC
'
' ------------------------------------------------------------------------
' USER PROCEDURES AND FUNCTIONS: These are for you to fill in...
'
> PROCEDURE user_var_index
'
' ---------------------------------------------------------------------------
' Objektbaum-Namen:
' system& : Dialog
' whointro& : Dialog
' fvt_alst& : Dialog
' fvt_alic& : Dialog
' fvt_altr& : Dialog
' icfyicon& : Dialog
' menu& : Menü
' multiple& : Dialog
' whofinish& : Dialog
' fvt_asci& : Dialog
' language& : Dialog
' whoicons& : Dialog
' ---------------------------------------------------------------------------
' Objekt-Namen:
' whostart& : Objekt im Baum whointro&
' about& : Objekt im Baum menu&
' quizstart& : Objekt im Baum menu&
' quizquit& : Objekt im Baum menu&
' help& : Objekt im Baum menu&
' netwho& : Objekt im Baum menu&
' picbox& : Objekt im Baum multiple&
' whoibox2& : Objekt im Baum multiple&
' whoansw1& : Objekt im Baum multiple&
' whoansw2& : Objekt im Baum multiple&
' whoansw3& : Objekt im Baum multiple&
' whoibox1& : Objekt im Baum multiple&
' textl1& : Objekt im Baum multiple&
' textl2& : Objekt im Baum multiple&
' textl3& : Objekt im Baum multiple&
' textl4& : Objekt im Baum multiple&
' whohelp& : Objekt im Baum multiple&
' right& : Objekt im Baum multiple&
' wrong& : Objekt im Baum multiple&
' addinfo1& : Objekt im Baum multiple&
' addinfo2& : Objekt im Baum multiple&
' ranswer& : Objekt im Baum whofinish&
' wanswer& : Objekt im Baum whofinish&
' finok& : Objekt im Baum whofinish&
' brigadier& : Objekt im Baum whoicons&
' tardis& : Objekt im Baum whoicons&
' dalek& : Objekt im Baum whoicons&
' icon_who& : Objekt im Baum whoicons&
' world& : Objekt im Baum whoicons&
' icon5& : Objekt im Baum whoicons&
' icon4& : Objekt im Baum whoicons&
' icon3& : Objekt im Baum whoicons&
' icon2& : Objekt im Baum whoicons&
' icon1& : Objekt im Baum whoicons&
'
' ---------------------------------------------------------------------------
' Status-Variablen: (Details in der Prozedur user_rsc_var_init)
'
'
'
' ---------------------------------------------------------------------------
'
' ΩΩwsnippetΩΩ - Wrinkle-Code: (dieses Flag nicht löschen oder verändern)
' gemscriptcmd_par_% : internal (GEMScriptCMD-wrinkle) !ΩΩFVW:GEMScriptCMDΩΩ
' gemscriptcmd_senders_$ : internal (GEMScriptCMD-wrinkle) !ΩΩFVW:GEMScriptCMDΩΩ
' ΩΩwsnippetΩΩ - Ende des Wrinkle-Codes: (dieses Flag nicht löschen oder verändern)
'
RETURN
> PROCEDURE user_rsc_var_init
'
' You MUST set these variables (and DIMension any listbox arrays here).
' This is read ONCE, at startup, and the corresponding dialog objects
' will be set accordingly.
'
current_menubar&=menu& !set this to the menu bar tree index
'
' snap_windows!=TRUE
'
LET whoanswer_var$="" ! Max lenght: 0 - tree: multiple&
'
@questions
RETURN
PROCEDURE user_rsc_interact(index&,tree&,object&,mc&,sub_me&)
'
' <index&> is the index of this window in window_array&(index&,x)
' If the object tree is the normal menu bar, <index&>=-1
' <tree&> is the object tree number
' <object&> is the object that was selected (clicked on OR shortcut)
' <mc&> is the number of clicks (1=normal/2=double clicked/1 if shortcut)
' <sub_me&> is the chosen menuitem in a popup menu
'
SELECT tree&
'
' ------------------------------------------------------------------------
'
CASE whointro&
SELECT object&
CASE whostart&
@win_close(intro_dialog&)
ENDSELECT
'
' ------------------------------------------------------------------------
'
CASE menu&
SELECT object&
CASE about&
intro_dialog&=@win_open_dialog(2,whointro&,icfyicon&)
CASE quizstart&
CLR frage%,klein%,richtig%,falsch%
@dialog_aufbauen
multiple_dialog&=@win_open_dialog(2,multiple&,icfyicon&)
CASE quizquit&
exit_program!=TRUE
CASE netwho&
@cab_show("http://www.mypenguin.de/prg/")
CASE help&
@user_rsc_context_help(tree&)
ENDSELECT
'
' ------------------------------------------------------------------------
'
CASE multiple&
SELECT object&
CASE whoansw1&
IF r$(auswahl%)="1"
INC richtig%
ausgang!=TRUE
ELSE
INC falsch%
ENDIF
dialog_aufbauen
CASE whoansw2&
IF r$(auswahl%)="2"
INC richtig%
ausgang!=TRUE
ELSE
INC falsch%
ENDIF
dialog_aufbauen
CASE whoansw3&
IF r$(auswahl%)="3"
INC richtig%
ausgang!=TRUE
ELSE
INC falsch%
ENDIF
@dialog_aufbauen
CASE whohelp&
@user_rsc_context_help(tree&)
'
CASE whoquit&
IF typ$(auswahl%)="S"
c$=answ$(auswahl%)
ausgang!=FALSE
DO
e$=@teil$("|",c$)
IF UPPER$(@rsc_get_text$(multiple&,whoanswer&))=UPPER$(e$) AND e$<>""
INC richtig%
ausgang!=TRUE
ENDIF
LOOP UNTIL e$="" OR ausgang!=TRUE
IF ausgang!=FALSE
INC falsch%
ENDIF
dialog_aufbauen
ENDIF
'
ENDSELECT
'
' ------------------------------------------------------------------------
'
CASE whofinish&
SELECT object&
CASE finok&
@win_close(finish_dialog&)
ENDSELECT
'
' ------------------------------------------------------------------------
'
CASE fvt_altr&
alert_result&=SUB(object&,7)
@win_close(@find_handle_from_tree(fvt_altr&))
exit_alert_loop!=TRUE
'
' ------------------------------------------------------------------------
'
ENDSELECT
RETURN
> PROCEDURE user_rsc_draw_extra(userhandle&,index&,tree&,tree%,cx&,cy&,cw&,ch&)
LOCAL x&,y&,w&,h&
~GRAF_MOUSE(256,0) !hidem - to avoid "mousedroppings"
'
' This procedure is here if you need to draw anything in the dialog that
' cannot be in the RSC-file. The clipping rectangle is already set
' for this procedure (walking the rectangle tree) MUST NOT BE ALTERED!!!
' Else you may find yourself drawing over other objects, or even windows!
'
' <userhandle&> is the userhandle you gave when opening the window
' or -1 if it is a dialog window
' <index&> is the index of this window in window_array&(index&,x)
' <tree&> is the object tree number of the dialog or toolstrip/bar
' <tree%> is the object tree adress of the dialog or toolstrip/bar
' <cx&>,<cy&>,<cw&>,<ch&> is the clipping rectangle set
'
' You should limit your drawing/blitting commands to the size and
' location of an IBOX/BOX object. The BOX will give you a backround,
' the IBOX will not. The location and width/height of the IBOX/BOX
' are found by calling:
'
' @rsc_ob_xywh(tree%,object&,x&,y&,w&,h&)
'
' <tree%> is the object tree adress
' <object&> is the object number
' <x&> is the x-coordinate
' <y&> is the y-coordinate
' <w&> is the width
' <h&> is the height
'
' So you might set up a SELECT/CASE structure that looks
' something like this example:
'
SELECT tree&
CASE multiple&
@rsc_ob_xywh(tree%,whoibox2&,x&,y&,w&,h&)
minus%=0
FOR i%=50 TO 55
COLOR i%
BOX x&+minus%,y&+minus%,PRED(ADD(x&,w&))-minus%,PRED(ADD(y&,h&))-minus%
INC minus%
NEXT i%
@rsc_ob_xywh(tree%,whoibox1&,x&,y&,w&,h&)
minus%=0
FOR i%=100 TO 110
COLOR i%
BOX x&+minus%,y&+minus%,PRED(ADD(x&,w&))-minus%,PRED(ADD(y&,h&))-minus%
INC minus%
NEXT i%
ENDSELECT
'
~GRAF_MOUSE(257,0) !showm - display pointer again
RETURN
> PROCEDURE user_on_open
'
' This procedure is called when the program is run, after the RSC is
' loaded and just before the main loop. You can open program windows,
' toolboxes etc. here, or init things for your program like
' loading an *.INF or .DAT file.
'
' If run as an accessory, this procedure is called EVERY TIME
' THE ACCESSORY IS OPENED. If you need to do anything just ONCE,
' like disable menu-entries spesific to PROGRAM execution, set a global
' flag here to avoid doing things EVERY time the accessory is opened.
'
RETURN
> PROCEDURE user_on_exit
'
' This procedure is called when you exit the program. If you need to
' release memory, restore the original desktop or do other
' "cleaning up" tasks, do it here.
'
' If run as an accessory, this procedure is called EVERY TIME
' THE ACCESSORY IS CLOSED. (Remember: An accessory is NEVER exited)
'
RETURN
> FUNCTION user_quit_ok
$F%
exit_program!=FALSE
IF acc&
RETURN TRUE
ELSE
'
' User wants to quit
' Return value: TRUE to quit
' FALSE to ignore
'
' The following SELECT-CASE-ENDSELECT structure is just an example.
' If you want to use an alert, you may (should?:-) want to use
' a windowed alert...
'
' The rest of the code in this function should *NOT* be altered!
'
SELECT @alert_wind(1,4,"")
CASE 1
RETURN TRUE
CASE 2
RETURN FALSE
ENDSELECT
'
ENDIF
ENDFUNC
> FUNCTION user_systemcheck
$F%
'
' This function is called immediately when the program is started,
' and only if the requirements in the system procedure 'SYSTEMCHECK'
' is met. Remember: The RSC is NOT YET LOADED! If you need to check
' anything special (like a cookie) before allowing the program to load
' and run, do it here.
'
' To continue, return TRUE
' To abort the program, return FALSE
'
' If you abort the program, use an alert to tell the user WHY the program
' is aborted.
'
' If you have no need to check anything, just leave this function empty,
' except of course for the 'RETURN TRUE' line below.
'
RETURN TRUE
ENDFUNC
> PROCEDURE user_gem_messages(mx&,my&,ks&,m0&,m1&,m2&,m3&,m4&,m5&,m6&,m7&)
'
' Any message the Face Value engine do not understand, goes to this proc.
' Here, you are free to implement your own communication protocols, or
' to ignore unknown messages completly and leave it empty.
'
' <mx&> and <my&> are the mouse coordinates at the time of the message
' <ks&> is the keyboard state at the time of the message
' <m0&> to <m7&> are the actual words in the message
'
IF m0&=&H4711
@user_rsc_interact(-1,menu&,quizstart&,1,-1)
ENDIF
RETURN
> PROCEDURE user_win_close_all
'
' This procedure is called when the WIN_CLOSE_ALL procedure of the FV engine
' is called, and before the windows are closed and the window arrays erased.
'
' If you have any resources attatched to each window, you can clean them
' up here. (releasing memory etc.)
'
RETURN
'
> FUNCTION user_rsc_bubble_help$(tree&,object&)
LOCAL help_str$
help_str$=""
'
' Hier können die Texte für die BubbleGEM-Hilfen eingetragen werden:
' help_str$="Mein Hilfetext"
'
' Beispiel:
' SELECT tree&
' CASE my_dialog&
' SELECT object&
' CASE my_object&
' help_str$="Hier ist mein Beispiel-Hilfetext...!"
' ENDSELECT
' ENDSELECT
'
' faceVALUE kann Unterscheiden, ob die Hilfeblase geöffnet wird, weil
' mit der Maus geklicked wurde, oder weil die Maus eine gewisse Zeit
' über dem Objekt verweilt hat (sog. Dämon-Hilfe).
'
' Soll eine Blase bei der Dämon-Hilfe nicht erscheinen, so kann dem Text
' ein "#" vorangestellt werden:
'
' help_str$="#Dieser Text wird nur bei Mausklick gezeigt!"
'
'
SELECT tree&
' ----------------------------------------------------------------------------
CASE multiple&
SELECT object&
CASE picbox&
help_str$=""
CASE whoibox2&
help_str$=""
CASE whoansw1&,whoansw2&,whoansw3&
help_str$=@lang$(2)
CASE 3 TO 12
a$=@lang$(INT(RND(1)*3)+4)
CASE whohelp&
help_str$=""
ENDSELECT
'
' ----------------------------------------------------------------------------
CASE whofinish&
SELECT object&
CASE ranswer&
help_str$=""
CASE wanswer&
help_str$=""
CASE finok&
help_str$=""
ENDSELECT
'
' ----------------------------------------------------------------------------
'
' ΩΩwsnippetΩΩ - Wrinkle-Code: (dieses Flag nicht löschen oder verändern)
' ΩΩwsnippetΩΩ - Ende des Wrinkle-Codes: (dieses Flag nicht löschen oder verändern)
'
' ----------------------------------------------------------------------------
ENDSELECT
IF help_str$=""
help_str$="#Für dieses Objekt ist keine Kontext-Hilfe verfügbar." !***if no bubble help
ENDIF
RETURN help_str$
ENDFUNC
> FUNCTION user_gemscriptcmd_command(cmd$)
$F%
' -----------------------------------------------------------------------------
' GEMScript Command-Receive V1.0 ╜1998 by Holger Herzog
'
'
' This procedure is called, when a gemscript-command
' is received. The command is stored in cmd$ (Upper-Case!).
'
' You can get the first parameter by using:
'
' par_exist!=@gemscriptcmd_par(par$)
'
' If there's no parameter, par_exist! will be FALSE.
' The value of the parameter will be stored in par$.
' Get the next par using the same call, untill the
' function returns FALSE.
'
' For some commands, the sender should additionaly return
' a string-value. You can set this value by calling
' the procedure @gemscriptcmd_return(string$).
'
' Set the return-value!
' RETURN 0 Command ok (executed)
' RETURN 2 Command failed (an error occuderd)
' RETURN 3 Command unknown
'
' Example:
'
IF cmd$="APPGETLONGNAME"
@gemscriptcmd_return(CHAR{faceval_sys%+2854}) ! get long AppName
RETURN 0
ELSE IF cmd$="QUIT"
LET exit_program!=TRUE
RETURN 0
'
ENDIF
'
' ΩΩwsnippetΩΩ - Wrinkle-Code: (dieses Flag nicht löschen oder verändern)
' ΩΩwsnippetΩΩ - Ende des Wrinkle-Codes: (dieses Flag nicht löschen oder verändern)
'
RETURN 1 ! command unknown
ENDFUNC
> PROCEDURE user_rsc_context_help(tree&)
'
' Von hier aus wird der ST-Guide aufgerufen. Bitte die Namen
' der entsprechenden Hilfeseiten eintragen:
'
SELECT tree&
CASE multiple&
@call_st_guide("DR_WHO.hyp","The Dr.Who-Quiz!")
' ΩΩwsnippetΩΩ - Wrinkle-Code: (dieses Flag nicht löschen oder verändern)
' ΩΩwsnippetΩΩ - Ende des Wrinkle-Codes: (dieses Flag nicht löschen oder verändern)
DEFAULT
@call_st_guide("DR_WHO.hyp","")
ENDSELECT
RETURN