geos_one/mystic-theme
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Mario Fetka
2024-04-29 20:44:47 +02:00
parent bfa91cbe29
commit 47818eed57
125 changed files with 17197 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

99
dbp/scripts/apply_sample.mps Normal file
View File

@@ -0,0 +1,99 @@
// ==========================================================================
// NEWUSERAPP.MPS : Sample new user process MPL program
//
// If newuserapp.mpx exists in the theme's script directory, it will be ran
// instead of the normal New User process. You must make sure you scan for
// duplicate user names, and other things like that which the BBS would
// normally do during this process. At the start of the program, you must
// call GetThisUser to load the new user data into the USER variables.
// Before exiting the program, you must call PutThisUser to store the USER
// variables back into the new user data.
//
// Note: To use this program, you must rename it to newuserapp.mps and
// compile it with MIDE or MPLC.
// ==========================================================================
Uses
User
Procedure GetAlias;
Var
Str : String[30];
Begin
Repeat
Write ('Enter your alias: ');
Str := StripLow(StripB(Input(30, 30, 11, ''), ' '));
If (Str = '') or (Str2Int(Str) > 0) Then
WriteLn ('Invalid user name')
Else
If IsUser(Str) Then
WriteLn ('Account already exists')
Else
Break;
Until False;
UserAlias := Str;
End;
Procedure GetRealName;
Var
Str : String[30];
Begin
Repeat
Write ('Enter your real name: ');
Str := StripLow(StripB(Input(30, 30, 11, ''), ' '));
If (Pos(' ', Str) = 0) or (Str2Int(Str) > 0) Then
WriteLn ('Enter first AND last name')
Else
If IsUser(Str) Then
WriteLn ('Account already exists')
Else
Break;
Until False;
UserName := Str;
End;
Procedure GetPassword;
Var
Str1 : String[25];
Str2 : String[25];
Begin
Repeat
Repeat
Write ('Enter your password: ');
Str1 := Input(25, 25, 16, '');
If ValidPW(Str1) <> 0 Then
WriteLn ('Password violates password policy')
Else
Break;
Until False;
Write ('Verify your password: ');
Str2 := Input(25, 25, 16, '');
If Str1 <> Str2 Then
WriteLn ('Passwords do not match.')
Else
Break;
Until False;
SetPW (Str1);
End;
Begin
GetThisUser;
GetAlias;
GetRealName;
GetPassword;
PutThisUser;
End.

57
dbp/scripts/autocreate.mps Normal file
View File

@@ -0,0 +1,57 @@
// Auto create MPL for RLOGIN auto-creation example
// ================================================
//
// This would be renamed to connect.mps which is executed as soon as a
// connection comes in, even before graphics detection.
//
// By default this script will create a user automatically if AutoCreate is
// set to TRUE below, or just push them immediately through to the new user
// application if set to FALSE.
//
// Security below defines the level used for the created user. Ideally you
// would probably want to create them with a specific security level and then
// you could redirect them to their own menu system which would be completely
// independant from the BBS.
Const
EnableRLOGIN = True; // If True, process RLOGIN users for autocreate
EnableSSH = False; // If True, process SSH users for autocreate
AutoCreate = True; // Set True to autocreate or False to send to new
// user application.
StartMenu = ''; // Menu to start users at (Blank for default)
Security = 0; // Security level to use for created users or 0
// to use the default new user security level
Begin
If ((ServerType = 1 and EnableRLOGIN) or (ServerType = 2 and EnableSSH)) and
(UserLoginName <> '') and (UserLoginPW <> '') Then Begin
// This is connection from RLOGIN or SSH, so lets see if the user exists.
// Other manipulation or validation of the User ID or password could be
// done here too as needed.
If Not IsUser(UserLoginName) Then Begin
// User does not exist, so we can either set "UserLoginNew" to true to
// push the user directly to the new user application, or we could
// create the user and automatically push them through.
If AutoCreate Then Begin
Var Cmd : String = 'mystic -newuser handle="' + UserLoginName + '" "pass=' + UserLoginPW + '"';
If (Security > 0) and (Security < 250) Then
Cmd := Cmd + ' level=' + Int2Str(Security);
If StartMenu <> '' Then
Cmd := Cmd + ' menu=' + StartMenu;
If OSType = 1 or OSType = 2 Then
Cmd := './' + Cmd + ' /dev/null 2>&1';
SysopLog ('Auto creating user via RLOGIN: ' + UserLoginName);
MenuCmd('DD', Cmd);
End Else
UserLoginNew := True;
End;
End;
End.

184
dbp/scripts/automessage.mps Normal file
View File

@@ -0,0 +1,184 @@
// AUTOMESSAGE : Basic auto-message MPL for Mystic BBS
// ===================================================
//
// Options: <NONE> Show message and prompt to change message
// SHOW Only show message, then show a pause prompt
// SHOWNOPAUSE Same as SHOW but does not send PausePrompt
// CHANGE Only change message and nothing else
//
// The auto message has been designed so that you can just execute it with no
// options, and it will display and allow the user to change the message. It
// also gives you the show and change options separately, so you can build
// your own Automessage menu with the menu system, if you choose to, and that
// will give you some additional security options and display options.
//
// Example:
//
// Menu Command: GX (Execute MPL)
// Optional Data: automessage show
//
// Prompts can be changed below. The header prompt can have &1 = Msg by,
// &2 = Msg date, &3 = Msg time.
Uses
USER;
Const
MaxLines = 6; // up to 25
MaxColumns = 79; // up to 79
// Sent as the auto message header
HeaderPrompt = '|16|CL|11Auto-Message by |15|&1 |11on |15|&2:|CR|03';
// Sent before each line of text of the actual auto message
MiddlePrompt = '';
// Sent when there is no defined auto message yet
NonePrompt = 'An auto message has not been set yet.';
// Used as the prompt prompt when using the SHOW command
PausePrompt = '|CR|PA';
// Prompt used to give option to change the message or continue
ChangePrompt = '|CR|01[|11C|01]|09hange Message, or |01[|11ENTER|01]|09 to Continue: ';
// If its the User who wrote the auto message, they can edit this prompt
// be be displayed instead of ChangePrompt
OwnerPrompt = '|CR|01[|11C|01]|09hange Message, |01[|11E|01]|09dit or |01[|11ENTER|01]|09 to Continue: ';
/////////////////////////////////////////////////////////////////////////////
// DO NOT EDIT EXCEPT FOR THE VALUES ABOVE //
/////////////////////////////////////////////////////////////////////////////
Var
Text : Array[1..25] of String[79];
TextDate : String[8];
TextTime : String[8];
TextFrom : String[40];
TextLines : Byte;
Procedure ReadData;
Var
F : File;
Begin
fAssign (F, JustPath(ProgName) + 'automessage.dat', 66);
fReset (F);
TextFrom := 'Unknown';
TextDate := DateStr(DateTime, 1);
TextTime := TimeStr(DateTime, False);
TextLines := 0;
If IoResult = 0 Then Begin
For TextLines := 1 to 25 Do
Text[TextLines] := '';
TextLines := 0;
fReadLn(F, TextFrom);
fReadLn(F, TextDate);
fReadLn(F, TextTime);
While Not fEOF(F) Do Begin
TextLines := TextLines + 1;
fReadLn (F, Text[TextLines]);
End;
fClose(F);
End;
SetPromptInfo(1, TextFrom);
SetPromptInfo(2, TextDate);
SetPromptInfo(3, TextTime);
End;
Procedure Show (DoPause: Boolean);
Var
Count : Byte;
Begin
WriteLn (HeaderPrompt);
If TextLines = 0 Then
WriteLn(NonePrompt)
Else
For Count := 1 to TextLines Do
WriteLn (MiddlePrompt + Text[Count]);
If DoPause Then
Write(PausePrompt);
End;
Procedure Change;
Var
Prompt : String;
Cmds : String;
Ch : Char;
Lines : Integer;
Subject : String = 'Auto-Message';
Count : Word;
F : File;
Begin
GetThisUser;
If Upper(TextFrom) <> 'ANONYMOUS' and Upper(TextFrom) <> 'UNKNOWN' and TextFrom = UserAlias Then Begin
Prompt := OwnerPrompt;
Cmds := 'CQE' + #13;
End Else Begin
Prompt := ChangePrompt
Cmds := 'CQ' + #13;
End;
Repeat
Write (Prompt);
Ch := OneKey(Cmds, True);
Case Ch of
'Q',
#13 : Break;
'E',
'C' : Begin
If Ch = 'E' Then Begin
For Count := 1 to TextLines Do
MsgEditSet (Count, Text[Count]);
Lines := TextLines;
End Else
Lines := 0;
SetPromptInfo(1, Subject);
If MsgEditor (0, Lines, MaxColumns, MaxLines, False, 'msg_editor', Subject) Then Begin
fAssign (F, JustPath(ProgName) + 'automessage.dat', 66);
fReWrite (F);
fWriteLn (F, UserAlias);
fWriteLn (F, DateStr(DateTime, 1));
fWriteLn (F, TimeStr(DateTime, False));
For Count := 1 to Lines Do
fWriteLn (F, MsgEditGet(Count));
fClose (F);
End;
ReadData;
Show(False);
End;
End;
Until False;
End;
Begin
ReadData;
Case Upper(ParamStr(1)) of
'SHOWNOPAUSE' : Show(False);
'SHOW' : Show(True);
'CHANGE' : Change;
Else
Show(False);
Change;
End;
End.

154
dbp/scripts/bbslist.mps Normal file
View File

@@ -0,0 +1,154 @@
// -------------------------------------------------------------------------
// BBSLIST.MPS : BBS list creator for Mystic BBS software v1.07+
// -------------------------------------------------------------------------
// This program will export the BBS list data to a text file, and allow the
// user to download the created text file.
//
// The command line option specifies the base name of the BBS list to go along
// with the same parameters of the BBS list menu commands:
//
// bbslist [bbslist name] IE "bbslist bbslist"
//
// -------------------------------------------------------------------------
Uses
CFG,
USER
Var
ListFile : File;
ListName : String
OutFile : File;
OutName : String
bbs_cType : Byte
bbs_Phone : String
bbs_Telnet : String
bbs_Name : String
bbs_Location : String
bbs_Sysop : String
bbs_Baud : String
bbs_Software : String
bbs_Deleted : Boolean
bbs_AddedBy : String
bbs_Verified : LongInt
bbs_Extra1 : LongInt
bbs_Extra2 : Integer
Total : Integer
Temp : String
Begin
If ParamCount <> 1 Then Begin
WriteLn ('Invalid command line option.');
WriteLn ('');
WriteLn ('Usage: BBSLIST [bbs list id]');
WriteLn ('|CR|PA');
Halt
End
GetThisUser
ListName := CfgDataPath + ParamStr(1) + '.bbi';
OutName := CfgSysPath + 'temp' + Int2Str(NodeNum) + PathChar + 'bbslist.txt';
If Not FileExist(ListName) Then Begin
WriteLn ('|CR|12There are no entries in the BBS list.');
Halt;
End;
If Not InputYN('|CR|12Download the BBS list? ') Then
Halt
Write ('|CR|14Creating BBS list ... ')
fAssign (ListFile, ListName, 66);
fReset (ListFile);
If IoResult <> 0 Then Begin
WriteLn('Unable to find BBS list data');
Halt;
End;
fAssign (OutFile, OutName, 66);
fReWrite (OutFile);
fWriteLn (OutFile, '')
fWriteLn (OutFile, '.-------------------------------------------.')
fWriteLn (OutFile, '| BBS listing created on ' + DateStr(DateTime, UserDateType) + ' at ' + TimeStr(DateTime, True) + ' |')
fWriteLn (OutFile, '`-------------------------------------------''')
fWriteLn (OutFile, '')
Total := 0;
While Not fEof(ListFile) Do Begin
fRead (ListFile, bbs_cType, 1)
fRead (ListFile, bbs_Phone, 16)
fRead (ListFile, bbs_Telnet, 41)
fRead (ListFile, bbs_Name, 31)
fRead (ListFile, bbs_Location, 26)
fRead (ListFile, bbs_Sysop, 31)
fRead (ListFile, bbs_Baud, 7)
fRead (ListFile, bbs_Software, 11)
fRead (ListFile, bbs_Deleted, 1)
fRead (ListFile, bbs_AddedBy, 31)
fRead (ListFile, bbs_Verified, 4)
fRead (ListFile, bbs_Extra1, 4)
fRead (ListFile, bbs_Extra2, 2)
If Not bbs_Deleted Then Begin
Total := Total + 1
fWriteLn (OutFile, ' BBS Name: ' + bbs_Name)
If bbs_cType = 0 Then Begin
fWriteLn (OutFile, ' Accessible By: Dialup')
fWriteLn (OutFile, ' Phone Number: ' + bbs_Phone)
fWriteLn (OutFile, ' Max Baud Rate: ' + bbs_Baud)
End
If bbs_cType = 1 Then Begin
fWriteLn (OutFile, ' Accessible By: Telnet')
fWriteLn (OutFile, ' Telnet: ' + bbs_Telnet)
End
If bbs_cType = 2 Then Begin
fWriteLn (OutFile, ' Accessible By: Dialup & Telnet')
fWriteLn (OutFile, ' Phone Number: ' + bbs_Phone)
fWriteLn (OutFile, ' Max Baud Rate: ' + bbs_Baud)
fWriteLn (OutFile, ' Telnet: ' + bbs_Telnet)
End
fWriteLn (OutFile, ' Sysop Name: ' + bbs_Sysop)
fWriteLn (OutFile, ' Location: ' + bbs_Location)
fWriteLn (OutFile, ' BBS Software: ' + bbs_Software)
fWriteLn (OutFile, ' Last Verified: ' + DateStr(bbs_Verified, UserDateType))
fWriteLn (OutFile, '')
fWriteLn (OutFile, '----------------------------------------------------------')
fWriteLn (OutFile, '')
End
End;
fWriteLn (OutFile, 'Total BBSes listed: ' + Int2Str(Total))
fClose (ListFile)
fClose (OutFile)
WriteLn ('Done.')
If Local Then Begin
If InputYN ('|CR|12Local mode: Save list to file? |11') Then Begin
Write ('|CR|03Enter full path and filename for BBS list|CR|09:')
Temp := Input (60, 60, 12, CfgSysPath + 'bbslist.txt')
If Temp <> '' Then Begin
Write ('|CR|14Saving: |15' + Temp + '|14: ')
If FileCopy(OutName, Temp) Then
WriteLn ('OK')
Else
WriteLn ('ERROR')
End
End
End Else
MenuCmd ('F3', OutName)
FileErase (OutName)
End;

22
dbp/scripts/blackjack.ans Normal file
View File

@@ -0,0 +1,22 @@
<32><32><32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><>ܰ<30> <30><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD> <30>
<EFBFBD>M <20><> <20><>۰<EFBFBD>۰ ޲<><DEB2> <20><><EFBFBD> <20>۰<EFBFBD><DBB0> <20><><30> <32><6D><EFBFBD> <20><><EFBFBD><EFBFBD> <30><32><6D> <20>۰<EFBFBD><DBB0> <20>۱<EFBFBD>gj!<30>
 Y <20><> <20><><EFBFBD><EFBFBD><EFBFBD> <20><> <20><31><32><6D> <20><> ޲<><DEB2><EFBFBD> <20><><EFBFBD> <20><> <20><><EFBFBD> <20><><EFBFBD><EFBFBD> <20><> <20>۰<EFBFBD><DBB0> <20><><31> <32>
 S <20><> <20><><EFBFBD> <20><> <20><><EFBFBD><EFBFBD> <20><> <20><> <20><> <20><> <20><> <20><><EFBFBD> <20><><EFBFBD> <20><> <20><> <20><> <20><> <20><> <20><> <20><><EFBFBD> <20>
 T <20><> <20><><EFBFBD> <20> <20>ݱ <20><> <20><> <20><> <20> <20><> <20><><EFBFBD> <20><> <20><><EFBFBD> <20><> <20><> <20>۰ <20> <20><> <20><><EFBFBD> <20>
 I ޲<30> <30><32><6D><EFBFBD> <20><> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><30><32><31> <32><6D> <20>۰ <31><32><6D> <20><> <20><><EFBFBD><EFBFBD>۱<EFBFBD><DBB1><EFBFBD><EFBFBD>ݱ<EFBFBD><DDB1> <20><> ޲ <20><><31> <32>
 C <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20>۲<EFBFBD><DBB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20>
 <31> <32><6D><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20>
 <32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ļ <32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ļ 
 <32> <30><32> <30><32> <30><32> <30><32> <30><32> <32><30><6D><EFBFBD> Dealer:<32><43><EFBFBD><32><30>
 <32> <30><32> <30><32> <30><32> <30><32> <30><32> <32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ļ<30>
 <31> <30><32> <30><32> <30><32> <30><32> <30><32> <32><6D><EFBFBD><33><43><EFBFBD>
 <31><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ļ <32><6D><35><43>
 <30><6D><35><43>
 <30><32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><30> <30><6D><EFBFBD><33><43><EFBFBD>
 <30><36><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ļ<32> <37><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ļ<30>
 <30><36><36>ݳ<36>ݳ<36>ݳ<36>ݳ<36>ݳ<32> <37><30><6D><EFBFBD> You:<32><43><EFBFBD><32><30>
 <20><36><36>ݳ<36>ݳ<36>ݳ<36>ݳ<36>ݳ<32> <37><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>͹<30>
 <20><36><36>ݳ<36>ݳ<36>ݳ<36>ݳ<36>ݳ<32> <37><34><6D><EFBFBD> Cash $ <34><6D><EFBFBD><32><30>
 <20><36><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ļ<32> <37><34><6D><EFBFBD> Wager : <34><6D><EFBFBD><32><30>
<32><6D><32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><30><6D><32><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ļ<30>
<20> <30>

629
dbp/scripts/blackjack.mps Normal file
View File

@@ -0,0 +1,629 @@
// ==========================================================================
// BLACKJACK.MPS
//
// This is a simple BlackJack game that I wrote to test out MPL features
// about a year or two ago. I decided to port it to the later MPL version
// for the same purposes.
//
// Changelog:
// - Added an improved AI for the dealer. He's a lot less predictable and
// makes more logical decisions now.
// - When the player busts, the dealers hidden card is now shown. This is
// just for people curious if they would have won by standing.
// - Fixed a few display bugs
// - Now saves your money between sessions
// - Added Top 10 list
// - Added command line option RESET to reset scores
// - Added command line option TOP10 to show top 10 and exit
// - No longer allows negative numbers to be a Wager.
// ==========================================================================
Uses
User;
Const
Version = '1.4';
CashStart = 1000;
CardJack = 11;
CardQueen = 12;
CardKing = 13;
CardAce = 14;
SuitClub = 1;
SuitSpade = 2;
SuitHeart = 3;
SuitDiamond = 4;
Type
PlayerRec = Record
UserID : LongInt;
Name : String[30];
Cash : LongInt;
LastOn : LongInt;
End;
Type
TopTenRec = Record
User : String[35];
Cash : LongInt;
Date : LongInt;
End;
Type
CardRec = Record
Suit : Byte;
Card : Byte;
End;
Var
DataPath : String;
Deck : Array[1..52] of CardRec;
Player : PlayerRec;
PlayerNumber : LongInt = -1;
Wager : LongInt;
Player_Score : Byte;
Player_Cards : Byte;
Dealer_Score : Byte;
Dealer_Hidden : Byte;
Dealer_Cards : Byte;
Dealer_Aces : Byte;
Procedure LoadPlayer;
Var
F : File;
T : PlayerRec;
Begin
GetThisUser;
PlayerNumber := -1;
Player.UserID := UserIndex;
Player.Cash := CashStart;
fAssign (F, DataPath + 'blackjack.ply', 66);
fReset (F);
If IoResult <> 0 Then fReWrite(F);
While Not fEof(F) Do Begin
fReadRec (F, T);
If T.UserID = UserIndex Then Begin
Player := T;
PlayerNumber := fPos(F) / SizeOf(Player);
Break;
End;
End;
fClose (F);
Player.LastOn := DateTime;
Player.Name := UserAlias;
End;
Procedure SavePlayer;
Var
F : File;
Begin
fAssign (F, DataPath + 'blackjack.ply', 66);
fReset (F);
If PlayerNumber <> -1 Then
fSeek (F, SizeOf(Player) * (PlayerNumber - 1));
Else
fSeek (F, fSize(F));
fWriteRec (F, Player);
fClose (F);
End;
Procedure ExecuteTopTen;
Var
TopList : Array[1..10] of TopTenRec;
Count1 : Byte;
Count2 : Byte;
Count3 : Byte;
F : File;
OnePerson : PlayerRec;
Begin
Write ('|16|CL|10Sorting top scores...');
For Count1 := 1 to 10 Do Begin
TopList[Count1].User := 'None';
TopList[Count1].Cash := 0;
TopList[Count1].Date := 0;
End;
fAssign (F, DataPath + 'blackjack.ply', 66);
fReset (F);
If IoResult = 0 Then
While Not fEof(F) Do Begin
fReadRec (F, OnePerson);
For Count2 := 1 to 10 Do
If TopList[Count2].Cash <= OnePerson.Cash Then Begin
For Count3 := 10 DownTo Count2 + 1 Do
TopList[Count3] := TopList[Count3 - 1]
TopList[Count2].Cash := OnePerson.Cash;
TopList[Count2].User := OnePerson.Name;
TopList[Count2].Date := OnePerson.LastOn;
Break;
End;
End;
ClrScr;
GotoXY (21, 3);
Write ('|07Mystic BlackJack - Top 10 Money Holders');
GotoXY (5, 6);
Write ('## User Date Cash');
GotoXY (5, 7);
Write ('|02' + strRep(#196, 68) + '|10');
For Count1 := 1 to 10 Do Begin
GotoXY (5, 7 + Count1);
Write (PadLT(Int2Str(Count1), 2, ' '));
GotoXY (9, 7 + Count1);
Write (TopList[Count1].User);
GotoXY (42, 7 + Count1);
Write (DateStr(TopList[Count1].Date, 1));
GotoXY (53, 7 + Count1);
Write (PadLT(strComma(TopList[Count1].Cash), 20, ' '));
End;
GotoXY (5, 18);
Write ('|02' + strRep(#196, 68));
GotoXY (26, 20);
Write ('|02Press |08[|15ENTER|08] |02to continue|PN');
End;
Procedure DeckCreate;
Var
Suits,
Numbers,
Index : Byte;
Begin
Index := 1;
For Suits := 1 to 4 Do
For Numbers := 2 to CardAce Do Begin
Deck[Index].Suit := Suits;
Deck[Index].Card := Numbers;
Index := Index + 1;
End;
End;
Procedure DeckShuffle;
Var
OneCard : CardRec;
Shuffle,
CardNum1,
CardNum2 : Byte;
Begin
For Shuffle := 1 to 200 Do Begin
CardNum1 := Random(51) + 1;
CardNum2 := Random(51) + 1;
OneCard := Deck[CardNum1];
Deck[CardNum1] := Deck[CardNum2];
Deck[CardNum2] := OneCard;
End;
End;
Function GetCardNumber (Num: Byte) : String;
Var
Res,
Color : String[3];
Begin
Case Deck[Num].Card of
1..10 : Res := PadLT(Int2Str(Deck[Num].Card), 2, ' ');
CardJack : Res := ' J';
CardQueen : Res := ' Q';
CardKing : Res := ' K';
CardAce : Res := ' A';
End;
Case Deck[Num].Suit of
SuitClub : GetCardNumber := '|08' + Res + #05;
SuitSpade : GetCardNumber := '|08' + Res + #06;
SuitHeart : GetCardNumber := '|04' + Res + #03;
SuitDiamond : GetCardNumber := '|04' + Res + #04;
End
End
Procedure DrawCard (X, Y, Showing, Num: Byte);
Var
Str : String;
Begin
If Y = 1 Then Y := 17 Else Y := 10;
X := (X - 1) * 9 + 5;
Str := GetCardNumber(Num);
Case Showing of
1 : Begin
GotoXY (X, Y);
Write ('|23' + Str + ' ');
GotoXY (X, Y + 1);
Write (' ');
GotoXY (X, Y + 2);
Write (' ' + Str + '|16');
End;
2 : Begin
GotoXY (X, Y);
Write ('|07|20<32> <20><> <20>');
GotoXY (X, Y + 1);
Write ('<27> <20><> <20>');
GotoXY (X, Y + 2);
Write ('<27> <20><> <20>|16');
End;
Else
GotoXY (X, Y);
Write ('|00|16 ');
GotoXY (X, Y + 1);
Write (' ');
GotoXY (X, Y + 2);
Write (' |07');
End;
End;
Procedure Print (Str1, Str2: String);
Begin
GotoXY (54, 13);
Write (strRep(' ', 23));
GotoXY (54, 13);
Write (Str1);
GotoXY (54, 14);
Write (strRep(' ', 23));
GotoXY (54, 14);
Write (Str2);
End
Procedure GetNewCard (Dealer: Boolean);
Var
Count,
Value,
Aces : Byte;
Begin
Aces := 0;
Dealer_Aces := 0;
If Dealer Then Begin
Dealer_Score := 0;
Dealer_Cards := Dealer_Cards + 1;
DrawCard (Dealer_Cards, 2, 1, Dealer_Cards + 5);
For Count := 1 to Dealer_Cards Do Begin
Value := Deck[Count + 5].Card;
If Value = CardAce Then Begin
Value := 11;
Dealer_Aces := Dealer_Aces + 1;
End Else
If Value > 10 Then
Value := 10;
Dealer_Score := Dealer_Score + Value;
End;
If Dealer_Score > 21 And Dealer_Aces > 0 Then Begin
Repeat
Dealer_Score := Dealer_Score - 10;
Dealer_Aces := Dealer_Aces - 1;
Until Dealer_Score < 22 or Dealer_Aces = 0;
If Deck[6].Card = CardAce And Dealer_Aces = 0 Then
Dealer_Hidden := 1;
End;
End Else Begin
Player_Score := 0;
Player_Cards := Player_Cards + 1;
DrawCard (Player_Cards, 1, 1, Player_Cards);
For Count := 1 to Player_Cards Do Begin
Value := Deck[Count].Card;
If Value = CardAce Then Begin
Value := 11;
Aces := Aces + 1;
End Else
If Value > 10 Then
Value := 10;
Player_Score := Player_Score + Value;
End;
If Player_Score > 21 Then
While Player_Score > 21 And Aces > 0 Do Begin
Player_Score := Player_Score - 10;
Aces := Aces - 1;
End;
End;
End;
Procedure DrawCash
Begin
GotoXY (64, 19);
Write ('|15|17' + PadRT(strComma(Player.Cash), 10, ' ') + '|16');
End;
Procedure UpdateScores;
Begin
GotoXY (65, 10);
Write ('|15' + Int2Str(Dealer_Score - Dealer_Hidden));
GotoXY (65, 17);
Write (Int2Str(Player_Score));
End
Procedure Initialize;
Procedure EraseInput;
Begin
GotoXY (64, 20);
Write ('|17 |16');
GotoXY (64, 20);
End;
Var
X,
Y : Byte;
Begin
If Player.Cash = 0 Then Begin
Print ('|15No cash|07? |10House loans ya', '|07$|15' + strComma(CashStart) + '|07. |12Press a key');
Player.Cash := CashStart;
ReadKey;
End;
Print (' |12|16Shuffling deck...', '');
DeckShuffle;
For Y := 1 to 2 Do
For X := 1 to 5 Do
DrawCard(X, Y, 3, 1);
GotoXY (65, 10);
Write (' ');
GotoXY (65, 17);
Write (' ');
DrawCash;
Print (' |15|16Enter your wager:', ' |02(|14$|15' + Int2Str(Player.Cash) + ' |14max|02)|14|17');
EraseInput;
Write('|17');
Wager := Abs(Str2Int(Input(10, 10, 1, '')));
If Wager > Player.Cash Then Wager := 0;
If Wager = 0 Then Begin
EraseInput;
Exit;
End;
Dealer_Cards := 1;
Player_Cards := 0;
Dealer_Hidden := Deck[6].Card;
If Dealer_Hidden = CardAce Then
Dealer_Hidden := 11
Else
If Dealer_Hidden > 10 Then
Dealer_Hidden := 10
DrawCard(1, 2, 2, 6)
GetNewCard(False);
GetNewCard(False);
GetNewCard(True);
UpdateScores;
End;
Procedure AdjustScore (Mode: Byte);
Begin
Case Mode of
0 : Begin
Player.Cash := Player.Cash - Wager;
If Player.Cash < 0 Then Player.Cash := 0;
End;
1 : Begin
Player.Cash := Player.Cash + Wager;
If Player.Cash > 99999999 Then Player.Cash := 99999999;
End;
End;
DrawCash;
End;
Var
Ch : Char;
GoForIt : Boolean;
Begin
ClrScr;
If Graphics = 0 Then Begin
WriteLn ('Sorry, this game requires ANSI graphics.|CR|PA');
Halt;
End;
DataPath := JustPath(ProgName);
If Upper(ParamStr(1)) = 'TOP10' Then Begin
ExecuteTopTen;
Halt;
End;
If Upper(ParamStr(1)) = 'RESET' Then Begin
If InputYN('|CR|12Reset blackjack scores? ') Then Begin
FileErase(DataPath + 'blackjack.ply');
WriteLn ('|CRScores have been reset|CR|CR|PA');
End;
Halt;
End;
Randomize;
DeckCreate;
LoadPlayer;
DispFile (DataPath + 'blackjack')
WriteXY (12, 23, 8, 'Mystic BlackJack v' + Version + ' Code: g00r00 Art: Grymmjack');
DrawCash;
Repeat
Print (' |15Want to play a game?', ' |10(|14Y|02/|14N|10)|08: |07')
If OneKey('YN', False) = 'N' Then Break;
Initialize;
If Wager = 0 Then Continue;
If Dealer_Score = 21 Then
If Deck[6].Card = CardJack or Deck[7].Card = CardJack Then
If Deck[6].Suit = SuitClub or Deck[7].Suit = SuitClub or Deck[6].Suit = SuitSpade or Deck[7].Suit = SuitSpade Then Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
AdjustScore(0);
UpdateScores;
Print (' |12Dealer has Black Jack', ' Press any key.');
ReadKey
Continue;
End
If Player_Score = 21 Then
If Deck[1].Card = CardJack or Deck[2].Card = CardJack Then
If Deck[1].Suit = SuitClub or Deck[2].Suit = SuitClub or Deck[1].Suit = SuitSpade or Deck[2].Suit = SuitSpade Then Begin
Print (' |12Player has Black Jack', ' Press any key.');
AdjustScore(1);
ReadKey;
Continue;
End;
Repeat
If Player_Cards < 5 Then Begin
Print ('|10[|14H|10]|07it, |10[|14S|10]|07tand, |10[|14Q|10]|07uit', '|08: |07');
Ch := OneKey('HSQ', False);
End Else
Ch := 'S'
Case Ch of
'Q' : Begin
AdjustScore(0);
Break;
End;
'H' : Begin
GetNewCard(False);
UpdateScores;
If Player_Score > 21 Then Begin
AdjustScore(0);
DrawCard(1,2,1,6); // show dealer hidden card
Print (' |12Player busted', ' Press a key.');
ReadKey;
Break;
End;
// Dealer AI Rules for Hit
// <16 = 100%
// 16 = 50% (100 with ace as 1)
// 17 = 25% ( 50 with ace as 1)
// 18 = 10% ( 25 with ace as 1)
// >18 = 0%
Case Dealer_Score of
1..
15 : GoForIt := True;
16 : If Dealer_Aces = 0 Then
GoForIt := Random(1) = 0
Else
GoForIt := True;
17 : If Dealer_Aces = 0 Then
GoForIt := Random(3) = 0
Else
GoForIt := Random(1) = 0;
18 : If Dealer_Aces = 0 Then
GoForIt := Random(9) = 0
Else
GoForIt := Random(3) = 0;
Else
GoForIt := False; // Dealer decides to stand
End;
If GoForIt Then Begin
GetNewCard(True);
UpdateScores;
If Dealer_Score > 21 Then Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
AdjustScore(1);
UpdateScores;
Print(' |12Dealer busted', ' Press a key.');
ReadKey;
Break;
End;
End;
End;
'S' : Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
UpdateScores;
While Dealer_Score < Player_Score and Dealer_Score < 22 and Dealer_Cards < 5 Do Begin
GetNewCard(True);
UpdateScores;
End
If Dealer_Score > 21 Then Begin
AdjustScore(1);
Print(' |12Dealer busted', ' Press a key.');
ReadKey;
End Else
If Player_Score > 21 Then Begin
AdjustScore(0);
Print(' |12Player busted', ' Press a key.');
ReadKey;
End Else
If Player_Score > Dealer_Score Then Begin
AdjustScore(1);
Print(' |12Player wins!', ' Press a key.');
ReadKey;
End Else
If Dealer_Score > Player_Score Then Begin
AdjustScore(0);
Print(' |12Dealer wins!', ' Press a key.');
ReadKey;
End Else Begin
AdjustScore(2);
Print(' |12Push. No winner.', ' Press a key.');
ReadKey;
End;
Break;
End;
End;
Until False;
Until False;
SavePlayer;
ExecuteTopTen;
End.

611
dbp/scripts/blackjack.ms Normal file
View File

@@ -0,0 +1,611 @@
Const
Version = '1.4';
CashStart = 1000;
CardJack = 11;
CardQueen = 12;
CardKing = 13;
CardAce = 14;
SuitClub = 1;
SuitSpade = 2;
SuitHeart = 3;
SuitDiamond = 4;
Type
PlayerRec = Record
UserID : LongInt;
Name : String[40];
Cash : LongInt;
LastOn : LongInt;
End;
Type
TopTenRec = Record
User : String[35];
Cash : LongInt;
Date : LongInt;
End;
Type
CardRec = Record
Suit : Byte;
Card : Byte;
End;
Var
DataPath : String;
Deck : Array[1..52] of CardRec;
Player : PlayerRec;
PlayerNumber : LongInt = -1;
Wager : LongInt;
Player_Score : Byte;
Player_Cards : Byte;
Dealer_Score : Byte;
Dealer_Hidden : Byte;
Dealer_Cards : Byte;
Dealer_Aces : Byte;
Procedure LoadPlayer;
Var
// F : File;
T : PlayerRec;
Begin
//GetThisUser;
PlayerNumber := -1;
Player.UserID := 1; // UserIndex;
Player.Cash := CashStart;
//fAssign (F, DataPath + 'blackjack.ply', 66);
//fReset (F);
//If IoResult <> 0 Then fReWrite(F);
// While Not fEof(F) Do Begin
//fReadRec (F, T);
//If T.UserID = UserIndex Then Begin
// Player := T;
// PlayerNumber := fPos(F) / SizeOf(Player);
//Break;
//End;
//End;
// fClose (F);
//Player.LastOn := DateTime;
Player.Name := 'Test User'; //UserAlias;
End;
Procedure SavePlayer;
//Var
// F : File;
Begin
(*
fAssign (F, DataPath + 'blackjack.ply', 66);
fReset (F);
If PlayerNumber <> -1 Then
fSeek (F, SizeOf(Player) * (PlayerNumber - 1));
Else
fSeek (F, fSize(F));
fWriteRec (F, Player);
fClose (F);
*)
End;
(*
Procedure ExecuteTopTen;
Var
TopList : Array[1..10] of TopTenRec;
Count1 : Byte;
Count2 : Byte;
Count3 : Byte;
F : File;
OnePerson : PlayerRec;
Begin
Write ('|16|CL|10Sorting top scores...');
For Count1 := 1 to 10 Do Begin
TopList[Count1].User := 'None';
TopList[Count1].Cash := 0;
TopList[Count1].Date := 0;
End;
fAssign (F, DataPath + 'blackjack.ply', 66);
fReset (F);
If IoResult = 0 Then
While Not fEof(F) Do Begin
fReadRec (F, OnePerson);
For Count2 := 1 to 10 Do
If TopList[Count2].Cash <= OnePerson.Cash Then Begin
For Count3 := 10 DownTo Count2 + 1 Do
TopList[Count3] := TopList[Count3 - 1]
TopList[Count2].Cash := OnePerson.Cash;
TopList[Count2].User := OnePerson.Name;
TopList[Count2].Date := OnePerson.LastOn;
Break;
End;
End;
ClrScr;
GotoXY (21, 3);
Write ('|07Mystic BlackJack - Top 10 Money Holders');
GotoXY (5, 6);
Write ('## User Date Cash');
GotoXY (5, 7);
Write ('|02' + strRep(#196, 68) + '|10');
For Count1 := 1 to 10 Do Begin
GotoXY (5, 7 + Count1);
Write (PadLT(Int2Str(Count1), 2, ' '));
GotoXY (9, 7 + Count1);
Write (TopList[Count1].User);
GotoXY (42, 7 + Count1);
Write (DateStr(TopList[Count1].Date, 1));
GotoXY (53, 7 + Count1);
Write (PadLT(strComma(TopList[Count1].Cash), 20, ' '));
End;
GotoXY (5, 18);
Write ('|02' + strRep(#196, 68));
GotoXY (26, 20);
Write ('|02Press |08[|15ENTER|08] |02to continue|PN');
End;
*)
Procedure DeckCreate;
Var
Suits,
Numbers,
Index : Byte;
Begin
Index := 1;
For Suits := 1 to 4 Do
For Numbers := 2 to CardAce Do Begin
Deck[Index].Suit := Suits;
Deck[Index].Card := Numbers;
Index := Index + 1;
End;
End;
Procedure DeckShuffle;
Var
OneCard : CardRec;
Shuffle,
CardNum1,
CardNum2 : Byte;
Begin
For Shuffle := 1 to 200 Do Begin
CardNum1 := Random(51) + 1;
CardNum2 := Random(51) + 1;
OneCard := Deck[CardNum1];
Deck[CardNum1] := Deck[CardNum2];
Deck[CardNum2] := OneCard;
End;
End;
Function GetCardNumber (Num: Byte) : String;
Var
Res,
Color : String[3];
Begin
Case Deck[Num].Card of
1..10 : Res := PadLeft(Int2Str(Deck[Num].Card), 2, ' ');
CardJack : Res := ' J';
CardQueen : Res := ' Q';
CardKing : Res := ' K';
CardAce : Res := ' A';
End;
Case Deck[Num].Suit of
SuitClub : Result := '|08' + Res + #05;
SuitSpade : Result := '|08' + Res + #06;
SuitHeart : Result := '|04' + Res + #03;
SuitDiamond : Result := '|04' + Res + #04;
End;
End;
Procedure DrawCard (X, Y, Showing, Num: Byte);
Var
Str : String;
Begin
If Y = 1 Then Y := 17 Else Y := 10;
X := (X - 1) * 9 + 5;
Str := GetCardNumber(Num);
Case Showing of
1 : Begin
GotoXY (X, Y);
Write ('|23' + Str + ' ');
GotoXY (X, Y + 1);
Write (' ');
GotoXY (X, Y + 2);
Write (' ' + Str + '|16');
End;
2 : Begin
GotoXY (X, Y);
Write ('|07|20<32> <20><> <20>');
GotoXY (X, Y + 1);
Write ('<27> <20><> <20>');
GotoXY (X, Y + 2);
Write ('<27> <20><> <20>|16');
End;
Else
Begin
GotoXY (X, Y);
Write ('|00|16 ');
GotoXY (X, Y + 1);
Write (' ');
GotoXY (X, Y + 2);
Write (' |07');
End;
End;
End;
Procedure PrintInfo (Str1, Str2: String);
Begin
GotoXY (54, 13);
Write (strRep(' ', 23));
GotoXY (54, 13);
Write (Str1);
GotoXY (54, 14);
Write (strRep(' ', 23));
GotoXY (54, 14);
Write (Str2);
End;
Procedure GetNewCard (Dealer: Boolean);
Var
Count,
Value,
Aces : Byte;
Begin
Aces := 0;
Dealer_Aces := 0;
If Dealer Then Begin
Dealer_Score := 0;
Dealer_Cards := Dealer_Cards + 1;
DrawCard (Dealer_Cards, 2, 1, Dealer_Cards + 5);
For Count := 1 to Dealer_Cards Do Begin
Value := Deck[Count + 5].Card;
If Value = CardAce Then Begin
Value := 11;
Dealer_Aces := Dealer_Aces + 1;
End Else
If Value > 10 Then
Value := 10;
Dealer_Score := Dealer_Score + Value;
End;
If (Dealer_Score > 21) and (Dealer_Aces > 0) Then Begin
Repeat
Dealer_Score := Dealer_Score - 10;
Dealer_Aces := Dealer_Aces - 1;
Until (Dealer_Score < 22) or (Dealer_Aces = 0);
If (Deck[6].Card = CardAce) And (Dealer_Aces = 0) Then
Dealer_Hidden := 1;
End;
End Else Begin
Player_Score := 0;
Player_Cards := Player_Cards + 1;
DrawCard (Player_Cards, 1, 1, Player_Cards);
For Count := 1 to Player_Cards Do Begin
Value := Deck[Count].Card;
If Value = CardAce Then Begin
Value := 11;
Aces := Aces + 1;
End Else
If Value > 10 Then
Value := 10;
Player_Score := Player_Score + Value;
End;
If Player_Score > 21 Then
While (Player_Score > 21) And (Aces > 0) Do Begin
Player_Score := Player_Score - 10;
Aces := Aces - 1;
End;
End;
End;
Procedure DrawCash;
Begin
GotoXY (64, 19);
Write ('|15|17' + PadRight(Comma(Player.Cash), 10, ' ') + '|16');
End;
Procedure UpdateScores;
Begin
GotoXY (65, 10);
Write ('|15' + Int2Str(Dealer_Score - Dealer_Hidden));
GotoXY (65, 17);
Write (Int2Str(Player_Score));
End;
Procedure Initialize;
Procedure EraseInput;
Begin
GotoXY (64, 20);
Write ('|17 |16');
GotoXY (64, 20);
End;
Var
X,
Y : Byte;
Begin
If Player.Cash = 0 Then Begin
PrintInfo ('|15No cash|07? |10House loans ya', '|07$|15' + Comma(CashStart) + '|07. |12Press a key');
Player.Cash := CashStart;
ReadKey;
End;
PrintInfo (' |12|16Shuffling deck...', '');
DeckShuffle;
For Y := 1 to 2 Do
For X := 1 to 5 Do
DrawCard(X, Y, 3, 1);
GotoXY (65, 10);
Write (' ');
GotoXY (65, 17);
Write (' ');
DrawCash;
PrintInfo (' |15|16Enter your wager:', ' |02(|14$|15' + Int2Str(Player.Cash) + ' |14max|02)|14|17');
EraseInput;
Write('|17');
Wager := Abs(Str2Int(Input(10, 10, 1, '')));
If Wager > Player.Cash Then Wager := 0;
If Wager = 0 Then Begin
EraseInput;
Exit;
End;
Dealer_Cards := 1;
Player_Cards := 0;
Dealer_Hidden := Deck[6].Card;
If Dealer_Hidden = CardAce Then
Dealer_Hidden := 11
Else
If Dealer_Hidden > 10 Then
Dealer_Hidden := 10;
DrawCard(1, 2, 2, 6);
GetNewCard(False);
GetNewCard(False);
GetNewCard(True);
UpdateScores;
End;
Procedure AdjustScore (Mode: Byte);
Begin
Case Mode of
0 : Begin
Player.Cash := Player.Cash - Wager;
If Player.Cash < 0 Then Player.Cash := 0;
End;
1 : Begin
Player.Cash := Player.Cash + Wager;
If Player.Cash > 99999999 Then Player.Cash := 99999999;
End;
End;
DrawCash;
End;
Var
Ch : Char;
GoForIt : Boolean;
Begin
ClrScr;
If Graphics = 0 Then Begin
WriteLn ('Sorry, this game requires ANSI graphics.|CR|PA');
Halt;
End;
DataPath := ExtractPath(ScriptName);
(*
If Upper(ParamStr(1)) = 'TOP10' Then Begin
ExecuteTopTen;
Halt;
End;
*)
(*
If Upper(ParamStr(1)) = 'RESET' Then Begin
If InputYN('|CR|12Reset blackjack scores? ') Then Begin
FileErase(DataPath + 'blackjack.ply');
WriteLn ('|CRScores have been reset|CR|CR|PA');
End;
Halt;
End;
*)
Randomize;
DeckCreate;
LoadPlayer;
ShowFile (DataPath + 'blackjack');
WriteXY (12, 23, 8, 'Mystic BlackJack v' + Version + ' Code: g00r00 Art: Grymmjack');
DrawCash;
Repeat
PrintInfo (' |15Want to play a game?', ' |10(|14Y|02/|14N|10)|08: |07');
If OneKey('YN', '', False) = 'N' Then Break;
Initialize;
If Wager = 0 Then Continue;
If Dealer_Score = 21 Then
If (Deck[6].Card = CardJack) or (Deck[7].Card = CardJack) Then
If (Deck[6].Suit = SuitClub) or (Deck[7].Suit = SuitClub) or (Deck[6].Suit = SuitSpade) or (Deck[7].Suit = SuitSpade) Then Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
AdjustScore(0);
UpdateScores;
PrintInfo (' |12Dealer has Black Jack', ' Press any key.');
ReadKey;
Continue;
End;
If Player_Score = 21 Then
If (Deck[1].Card = CardJack) or (Deck[2].Card = CardJack) Then
If (Deck[1].Suit = SuitClub) or (Deck[2].Suit = SuitClub) or (Deck[1].Suit = SuitSpade) or (Deck[2].Suit = SuitSpade) Then Begin
PrintInfo (' |12Player has Black Jack', ' Press any key.');
AdjustScore(1);
ReadKey;
Continue;
End;
Repeat
If Player_Cards < 5 Then Begin
PrintInfo ('|10[|14H|10]|07it, |10[|14S|10]|07tand, |10[|14Q|10]|07uit', '|08: |07');
Ch := OneKey('HSQ', '', False);
End Else
Ch := 'S';
Case Ch of
'Q' : Begin
AdjustScore(0);
Break;
End;
'H' : Begin
GetNewCard(False);
UpdateScores;
If Player_Score > 21 Then Begin
AdjustScore(0);
DrawCard(1,2,1,6); // show dealer hidden card
PrintInfo (' |12Player busted', ' Press a key.');
ReadKey;
Break;
End;
// Dealer AI Rules for Hit
// <16 = 100%
// 16 = 50% (100 with ace as 1)
// 17 = 25% ( 50 with ace as 1)
// 18 = 10% ( 25 with ace as 1)
// >18 = 0%
Case Dealer_Score of
1..
15 : GoForIt := True;
16 : If Dealer_Aces = 0 Then
GoForIt := Random(1) = 0
Else
GoForIt := True;
17 : If Dealer_Aces = 0 Then
GoForIt := Random(3) = 0
Else
GoForIt := Random(1) = 0;
18 : If Dealer_Aces = 0 Then
GoForIt := Random(9) = 0
Else
GoForIt := Random(3) = 0;
Else
GoForIt := False; // Dealer decides to stand
End;
If GoForIt Then Begin
GetNewCard(True);
UpdateScores;
If Dealer_Score > 21 Then Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
AdjustScore(1);
UpdateScores;
PrintInfo (' |12Dealer busted', ' Press a key.');
ReadKey;
Break;
End;
End;
End;
'S' : Begin
DrawCard (1, 2, 1, 6);
Dealer_Hidden := 0;
UpdateScores;
While (Dealer_Score < Player_Score) and (Dealer_Score < 22) and (Dealer_Cards < 5) Do Begin
GetNewCard(True);
UpdateScores;
End;
If Dealer_Score > 21 Then Begin
AdjustScore(1);
PrintInfo (' |12Dealer busted', ' Press a key.');
ReadKey;
End Else
If Player_Score > 21 Then Begin
AdjustScore(0);
PrintInfo (' |12Player busted', ' Press a key.');
ReadKey;
End Else
If Player_Score > Dealer_Score Then Begin
AdjustScore(1);
PrintInfo (' |12Player wins!', ' Press a key.');
ReadKey;
End Else
If Dealer_Score > Player_Score Then Begin
AdjustScore(0);
PrintInfo (' |12Dealer wins!', ' Press a key.');
ReadKey;
End Else Begin
AdjustScore(2);
PrintInfo (' |12Push. No winner.', ' Press a key.');
ReadKey;
End;
Break;
End;
End;
Until Shutdown;
Until Shutdown;
SavePlayer;
//ExecuteTopTen;
End.

128
dbp/scripts/bulletin.mps Normal file
View File

@@ -0,0 +1,128 @@
// ---------------------------------------------------------------------------
// BULLETIN.MPS: Bulletin Menu Script for Mystic BBS v1.12+
// ---------------------------------------------------------------------------
// This MPL program creates a simple bulletin menu. The following parameters
// must be passed when running this script:
//
// BULLETIN [menu name] [base bulletin name] [check]
//
// The first option [menu name] passes the name of the bulletin menu to
// display. For example, if the text "BULLETIN" is passed, the script will
// display the display file "BULLETIN.XXX" as the menu.
//
// The second option [base bulletin name] is the base bulletin name for each
// actual bulletin. This can be no longer than 6 characters in length. For
// example, if "BULLET" was passed as the base bulletin name, when the user
// types in "1" and hits enter, the script will display BULLET1.XXX
//
// The next command line is optional. If you supply the option "CHECK", the
// script will check for updated bulletins since the user's last call, then
// prompt them to read the bulletins if there are new bulletins available.
// This is handy to put as an FIRSTCMD command during the login somewhere,
// as the default Mystic BBS installation does.
//
// Feel free to make any modifications to this code that you want!
//
// ---------------------------------------------------------------------------
Uses CFG
Uses USER
Var
CheckNew : Boolean
MenuName : String
Prefix : String
Done : Boolean
InStr : String
NewNum : Byte
NewStr : String
Procedure Scan_New_Bulletins (Root: String)
Begin
NewStr := '';
NewNum := 0;
FindFirst (Root + PreFix + '*.*', 63);
While DosError = 0 Do Begin
If DirTime > UserLastOn And Upper(Copy(DirName, 1, Pos('.', DirName) - 1)) <> 'BULLETIN' Then Begin
InStr := Copy(DirName, 7, Pos('.', DirName) - 7) + ' '
If Pos(InStr, NewStr) = 0 Then Begin
NewStr := NewStr + InStr;
NewNum := NewNum + 1;
End
End
FindNext;
End;
FindClose;
End;
Begin
If ParamCount < 2 Then Begin
WriteLn ('|CRERROR (BULLETIN.MPS): Invalid command line');
Halt;
End;
GetThisUser;
MenuName := ParamStr(1);
Prefix := ParamStr(2);
CheckNew := False;
Done := False;
If ParamCount > 2 Then
If Upper(ParamStr(3)) = 'CHECK' Then
CheckNew := True
// Scan in theme's text directory for new bulletins
Scan_New_Bulletins(CfgTextPath);
// If theme has a configured fallback theme, scan that theme for new
// bulletins too
If CfgTextFB <> '' Then
Scan_New_Bulletins(CfgThemePath + CfgTextFB + PathChar + 'text' + PathChar);
// If theme is configured to fallback to default configured theme, scan that
// directory for new bulletins
If CfgTFallBack Then
Scan_New_Bulletins(cfgThemePath + CfgDefTheme + PathChar + 'text' + PathChar);
If NewNum = 0 Then
NewStr := 'None'
If CheckNew Then Begin
If NewNum = 0 Then Begin
WriteLn ('|CL|01[|10<31>|01] |09There are no new bulletins.')
Halt
End Else
If Not InputYN('|CL|01[|10<31>|01] |09New bulletins: |15' + Int2Str(NewNum) + '|09 Read them now? ') Then
Halt
End;
DispFile (MenuName)
Repeat
WriteLn ('|CR|09New Bulletins |08-> |07' + NewStr)
Write ('|09Command (?/List) |08-> |07')
InStr := Input(4, 4, 12, '')
If InStr = '?' Then
DispFile (MenuName)
Else
If InStr = 'Q' Then
Done := True
Else
If InStr = '' Then
DispFile (MenuName)
Else
If Not DispFile (PreFix + InStr) Then
WriteLn ('|CRERROR: Bulletin not found.')
Until Done
End

59
dbp/scripts/dayinhistory.mpy Normal file
View File

@@ -0,0 +1,59 @@
# ------------------------------------------
# Phenom Productions Presents...
# mod: Day In History v1.0
# author: Smooth <Phenom>
# date created: May 24, 2022
# ------------------------------------------
import mystic_bbs as bbs;
from mystic_bbs import *
from bs4 import BeautifulSoup
import requests
from unidecode import unidecode
from datetime import date
import time
dataSrc = requests.get('https://www.timeanddate.com/on-this-day/')
soup = BeautifulSoup(dataSrc.content, 'html.parser')
today = date.today()
def getNumEnding():
dayStr = today.strftime('%d')
if dayStr[-1] == '1' and len(dayStr)==1:
return 'st'
elif dayStr[-1] == '2':
return 'nd'
elif dayStr[-1] == '3':
return 'rd'
else:
return 'th'
def generateEventList():
writeln('|CL')
writeln(' |08-|03---|10-|03--|10-|03-|10--------- ------------------------------------ ------ -- - ')
writeln(' |18|15>> |10Day In History v1.0 |00>>|16|02>> |15by |11Smooth |03<|15PHEN0M|03>')
writeln(' |08-|03--|10--|03---|10-|03-|10----- --- -------------------------------- ------ -- - ')
writeln(' |20|00>>|16 |13On |14THIS DAY|13, These |14EVENTS |13Happened... |04:: |14' + today.strftime('%B') + ' ' + today.strftime('%d') + getNumEnding() + '|04 ::')
writeln(' |08-|03--|10--|03---|10-|03-|10--|03--- |10--- ---------------------------- ------ -- - ')
writeln('')
index = 1
events = soup.find_all("h3", class_="otd-title")
for event in events:
writeln(' |11' +event.text.strip()[0:4] + ' |03<|08:|03> |15' + unidecode(event.text.strip()[5::]))
writeln('')
if index == 5:
break
index += 1
writeln(' |08-|03---|10-|03--|10-|03-|10-----|03-|10--------------------------------------- --- --- -- - ')
writeln(' |20|00>>|16 |15Generated on ' + today.strftime('%B %d|07,|15 %Y') + ' at ' + time.strftime('%I|07:|15%M %p'))
writeln(' |08-|03---|10-|03--|10-|03-|10-----|03-|10--------------------------------------- --- --- -- - ')
writeln('|PA')
if __name__ == '__main__':
generateEventList()

118
dbp/scripts/filelist.mpy Normal file
View File

@@ -0,0 +1,118 @@
###################################################
# Simple File Listing Example using Mystic Python #
###################################################
# List files in the user's current file base
from mystic_bbs import *
# filelist flags
file_offline = int("01")
file_invalid = int("02")
file_deleted = int("04")
file_failed = int("08")
file_free = int("10")
file_hatched = int("20")
# Load the current user and then load their current file base
# but fail if they have not selected a file base
user = getuser(0)
fbase = getfbaseid(user["fbase"])
if fbase is None:
writeln ("|CRYou have not selected a file base yet!|CR|CR|PA")
quit()
# Open the file list then check to make sure its open before reading
# data from it
flist = fl_open(fbase["filename"]);
if flist is None:
writeln("Cannot open file listing. Press a key|PN")
quit()
done = False
# Seek to the first file in the list and loop while a file is found calling
# next after each file so the next one will be loaded. Seek should always be
# called before cycling through the list
fl_seek(flist, 0, True)
while fl_found(flist) and not done and not shutdown():
# Load the file information into a dictionary and then get the file
# description
fileinfo = fl_getfile(flist)
filedesc = fl_getdesc(flist)
# Show the file
writeln("|CL|14File #" + str(fileinfo["number"]) + " of " + str(fileinfo["total"]))
writeln("")
writeln("|09File: |11" + fileinfo["filename"])
writeln("|09Date: " + datestr(dated2u(fileinfo["date"]), "NNN DD YYYY HH:II:SS"))
writeln("Size: " + str(fileinfo["size"]))
writeln("DLs : " + str(fileinfo["dls"]))
writeln("ULer: " + fileinfo["ulname"])
flags = ""
if fileinfo["flags"] & file_offline:
flags = flags + "OFFLINE "
if fileinfo["flags"] & file_invalid:
flags = flags + "INVALID "
if fileinfo["flags"] & file_deleted:
flags = flags + "DELETED "
if fileinfo["flags"] & file_failed:
flags = flags + "FAILED "
if fileinfo["flags"] & file_free:
flags = flags + "FREE "
if fileinfo["flags"] & file_hatched:
flags = flags + "HATCHED "
if flags == "":
flags = "NONE"
writeln("Flag: |13" + flags)
writeln("")
writeln("|14Description (" + str(fileinfo["lines"]) + " lines):")
writeln("|03")
# only print up to the first 10 lines so we can fit it on the screen
for line in range(min(fileinfo["lines"], 10)):
writeln(filedesc[line])
writeln("")
write("|16|09File List: (|11A|09)gain, (|11P|09)revious, (|11ENTER|09) Next, (|11Q|09) to Quit: |14")
ch = onekey(chr(13) + 'APQ', True);
if ch == 'A':
# do nothing here so it redisplays the same file
pass
elif ch == 'P':
fl_prev(flist)
elif ch == 'Q':
done = True
break
else:
fl_next(flist);
# Close the file list and report that we're done
fl_close(flist)
writeln("|CR|12Program complete: Press a key|PN");

9
dbp/scripts/mailread.mps Normal file
View File

@@ -0,0 +1,9 @@
// Very basic MPL program to execute from command line.
//
// This loads the ANSI message reader for you, and then will log off after,
// allowing Mystic to be used similar to something like GoldEd.
Begin
MenuCmd('MI', '');
End.

12
dbp/scripts/menucmd.mps Normal file
View File

@@ -0,0 +1,12 @@
// Very basic MPL program designed to execute a menu command from a prompt
// or from command line.
Var
Cmd : String[2];
Data : String;
Begin
Cmd := Upper(Copy(ProgParams, 1, 2));
Data := Copy(ProgParams, 4, Length(ProgParams));
MenuCmd(Cmd, Data);
End.

289
dbp/scripts/mpldemo.mps Normal file
View File

@@ -0,0 +1,289 @@
// ---------------------------------------------------------------------------
// MPLDEMO.MPS : Mystic Programming Language (MPL) Demonstration Program
// ---------------------------------------------------------------------------
// Written by g00r00 for Mystic BBS Version 1.07. Feel free to do whatever
// you want with this source code! This is just something quick I put
// together. Updated for Mystic 1.10
// ---------------------------------------------------------------------------
USES CFG;
USES USER;
Procedure FadeWrite (X, Y: Byte; S: String);
Begin
GotoXY (X, Y);
Write ('|08' + S);
BufFlush;
Delay (250);
GotoXY (X, Y);
Write ('|07' + S);
BufFlush;
Delay (250);
GotoXY (X, Y);
Write ('|15' + S);
BufFlush;
Delay (250);
GotoXY (X, Y);
Write ('|07' + S);
BufFlush;
End;
Procedure Draw_M (X: Byte);
Begin
GotoXY (X - 1, 9);
Write (' |17|09<30>|16|01<30><31><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>');
GotoXY (X - 1, 10);
Write (' |17|09<30>|16|01<30><31><EFBFBD> <20>');
GotoXY (X - 1, 11);
Write (' |01<30><31><EFBFBD><EFBFBD> <20>');
BufFlush;
End;
Procedure Draw_P (Y: Byte)
Begin
GotoXY (39, Y - 1);
Write (' ');
GotoXY (39, Y);
Write ('|09|17<31>|01|16<31><36><EFBFBD><EFBFBD><EFBFBD>');
GotoXY (39, Y + 1);
Write ('|09|17<31>|01|16<31><36><EFBFBD><EFBFBD><EFBFBD>');
GotoXY (39, Y + 2);
Write ('<27><><EFBFBD><EFBFBD>');
BufFlush;
End;
Procedure Draw_L (X : Byte)
Begin
GotoXY (X, 9);
Write ('|09|17<31>|01|16<31><36><EFBFBD> ');
GotoXY (X, 10);
Write ('|09|17<31>|01|16<31><36><EFBFBD> ');
GotoXY (X, 11);
Write ('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> ');
BufFlush;
End;
Procedure Draw_Animated_Intro;
Var
Count : Byte;
Begin
ClrScr;
For Count := 2 to 30 Do Begin
Draw_M(Count);
Delay(5);
End;
For Count := 1 to 9 Do Begin
Draw_P(Count);
Delay(20);
End;
For Count := 74 DownTo 46 Do Begin
Draw_L(Count);
Delay(5);
End;
FadeWrite (24, 13, 'The Mystic BBS Programming Language');
FadeWrite (34, 15, 'Press Any Key');
Write ('|PN');
End;
Procedure DrawHeader;
Begin
WriteLn ('|CL');
WriteLn (' |09|17<31>|01|16<31><36><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> |09|17<31>|01|16<31><36><EFBFBD><EFBFBD><EFBFBD> |09|17<31>|01|16<31><36><EFBFBD>');
WriteLn (' |09|17<31>|01|16<31><36><EFBFBD> <20> |09|17<31>|01|16<31><36><EFBFBD><EFBFBD><EFBFBD> |09|17<31>|01|16<31><36><EFBFBD>');
WriteLn (' <20><><EFBFBD><EFBFBD> <20> |11y s t i c |01<30><31><EFBFBD><EFBFBD> |11r o g r a m m i n g |01<30><31><EFBFBD><EFBFBD><EFBFBD><EFBFBD> |11a n g u a g e');
WriteLn (' |09<30><39><EFBFBD><EFBFBD><EFBFBD><EFBFBD> |01<30> |09<30><39><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>|07');
WriteLn ('');
End;
Procedure InputDemo;
Var
Str : String;
Begin
DrawHeader;
WriteLn (' This demonstrates some of the types of input functions which');
WriteLn (' are available within the Mystic Programming Language.|CR');
Write (' |09Regular input ') Str := Input(30, 30, 11, '');
Write (' |09Caps input ') Str := Input(30, 30, 12, '');
Write (' |09Proper input ') Str := Input(30, 30, 13, '');
Write (' |09Phone input ') Str := Input(12, 12, 14, '');
Write (' |09Date input ') Str := Input(8, 8, 15, '');
Write (' |09Password input ') Str := Input(20, 20, 16, '');
WriteLn ('|CR |07Text can also be pushed into the input buffer:|CR');
Write ('|09 Regular Input ') Str := Input(30, 30, 11, 'Default Text');
WriteLn ('|CR |07Input can be used without the input field:|CR');
Write ('|09 Regular Input |11') Str := Input(30, 30, 1, 'Default Text');
DrawHeader;
WriteLn ('|07 The input functions also make full use of ANSI editing. Arrow');
WriteLn (' keys can be used to move around the field, as well as the HOME,');
WriteLn (' END, DEL, and CTRL-Y keys. Up arrow restores previously entered text!');
WriteLn ('|CR Text longer than the input box can be entered in both ANSI and');
WriteLn (' non-ansi terminal modes. For example: Type more than 30 characters');
WriteLn (' below, while experimenting with the other ANSI editing functions');
WriteLn (' mentioned above.');
Write ('|CR |09Scroll Input ') Str := Input(30, 255, 11, '');
Write ('|CR |PA');
End;
Procedure UserListingHeader;
Begin
DrawHeader;
WriteLn (' User Name Location SecLev Sex');
WriteLn (' ------------------------------------------------------------------');
End;
Procedure UserListing;
Var
Count : Word = 1;
Begin
UserListingHeader;
While GetUser(Count) Do Begin
WriteLn (' ' + PadRT(UserAlias, 25, ' ') + ' ' + PadRT(UserAddress, 25, ' ') + ' ' +
PadLT(Int2Str(UserSec), 6, ' ') + ' ' + UserSex);
If Count % 10 = 0 Then Begin
Write (' Continue? (Y/N): ');
Case OneKey('YN', True) of
'Y' : UserListingHeader;
'N' : Break;
End;
End;
Count := Count + 1;
End;
WriteLn ('|CR Total of |15' + Int2Str(Count - 1) + ' |07users listed.|CR');
Write (' |PA');
End;
Procedure PlayNumberGame;
Var
GuessNum : Byte;
Answer,
Temp : Integer;
Begin
DrawHeader;
WriteLn (' |12Choose a number between 1 and 1000. You have 10 guesses.')
GuessNum := 0;
Answer := Random(999) + 1;
Repeat
GuessNum := GuessNum + 1;
Write ('|CR|03 Guess #' + Int2Str(GuessNum) + ': ');
Temp := Str2Int(Input(4, 4, 12, ''))
If Temp > Answer Then
WriteLn ('|CR |07The number is less than ' + Int2Str(Temp))
Else
If Temp < Answer Then
WriteLn ('|CR |07The number is greater than ' + Int2Str(Temp))
Else
GuessNum := 10;
Until GuessNum = 10;
If Temp = Answer Then
WriteLn ('|CR |12You won! The number was: ' + Int2Str(Answer))
Else
WriteLn ('|CR |12You lost. The number was: ' + Int2Str(Answer));
Write ('|CR |PA');
End;
Function MainMenu : Byte;
Var
Ch : Char;
Done : Boolean = False;
Bar : Byte = 1;
Ops : Array[1..4] of String[20];
Begin
DrawHeader;
WriteLn (' The Mystic BBS Programming Language (MPL for short) allows for the');
WriteLn (' ultimate in flexibility. With it''s Pascal-like syntax, the MPL');
WriteLn (' provides an easy and flexible way to modify internal Mystic BBS');
WriteLn (' functions, or even create your own online games! Check it out!');
WriteLn ('|09|CR |$D66<36>|CR');
WriteLn (' |09(|101|09) |03Input demo |08-> |07See some example input functions');
WriteLn (' |09(|102|09) |03User listing |08-> |07See a list of user accounts');
WriteLn (' |09(|103|09) |03Number game |08-> |07Play a simple number game');
WriteLn (' |09(|10Q|09) |03Quit Demo |08-> |07Return to the BBS menu');
WriteLn ('|09|CR |$D66<36>');
Write (' |07Select an option with arrow keys, or enter option number ');
Ops[1] := 'Input demo';
Ops[2] := 'User listing';
Ops[3] := 'Number game';
Ops[4] := 'Quit Demo';
Repeat
If Graphics > 0 Then Begin
GotoXY (12, 13 + Bar);
Write ('|01|23 ' + Ops[Bar] + ' |16');
End;
Ch := ReadKey;
If Graphics > 0 and IsArrow Then Begin
GotoXY (12, 13 + Bar);
Write ('|03 ' + Ops[Bar] + ' ');
Case Ch of
#72 : If Bar > 1 Then Bar := Bar - 1;
#80 : If Bar < 4 Then Bar := Bar + 1;
End;
End Else
Case Upper(Ch) of
#13 : If Graphics > 0 Then Begin
MainMenu := Bar;
Done := True;
End;
'Q' : Begin
MainMenu := 4;
Done := True;
End;
Else
If Str2Int(Ch) > 0 And Str2Int(Ch) < 4 Then Begin
MainMenu := Str2Int(Ch);
Done := True;
End;
End;
Until Done;
End;
Begin
Draw_Animated_Intro;
Repeat
Case MainMenu of
1 : InputDemo;
2 : UserListing;
3 : PlayNumberGame;
4 : Break;
End;
Until False;
GotoXY (1, 20);
End.

475
dbp/scripts/mpltest.mps Normal file
View File

@@ -0,0 +1,475 @@
// Comment test
/*
Comment test! /* comments */ (* comments *)
// more comments
*/
(*
comment test (* embedded comments *) /* embedded comments */
// more comments
*)
procedure testcase;
var
number : longint;
num2 : longint;
num3 : longint;
num4 : real;
ch1 : char;
str1 : string[20];
begin
write ('Testing CASE statement... ')
number := 73;
num2 := 13;
num3 := -1;
num4 := 12.12;
ch1 := 'A';
str1 := 'hello';
case number of
68 : begin
writeln('number is 68!');
end
69 : writeln('number is 69!');
70, 71 : writeln('number is 70 or 71');
72..80 : begin
case num2 of
10 : writeln('num2 = 10');
11 : begin
writeln('num2 = 11');
end;
13 : case num3 of
-1: begin
case num4 of
12.12: begin
case ch1 of
'A' : case str1 of
'hello' : writeln('PASSED');
end;
end;
end;
end;
end;
end;
else
writeln('num2 is something else');
end;
end;
else
writeln('number is not found!');
end;
end;
procedure testnumbers;
var
num1,
num2 : longint;
num3 : array[1..10] of byte;
num4 : array[1..10, 1..10, 1..10] of byte;
num5 : longint;
begin
write ('Testing NUMBERS... ');
num1 := 2 + 12 * 2;
num2 := -10;
num3[1] := 50;
num4[1,1,1] := (6 - 1) + 5 * 4;
num5 := 10 % 2 ^ 3; // 2 to 3rd is 8, 10 modulus 8 = 2
// floating point, mods, powers, PEDMAS, etc...
if (num2 = -10) and (num1 = 26) and (num2 = -10) and (num3[1] = 50) and
(num4[1,1,1] = 25) and (num5 = 2) then
writeln('PASSED')
else
writeln('FAILED');
end;
procedure testrecords;
type
testrec = record // total 502 bytes:
x : byte;
y : byte;
d : array[1..10,1..5] of string[9];
end;
var
test : array[1..2] of testrec;
test1 : testrec;
test2 : testrec;
passed : boolean = false;
begin
Write ('Testing RECORDS... ');
test[1].d[10,5] := 'test1';
test[2].x := 1;
test[2].y := 2;
test[2].d[1,1] := 'hi';
test[2].d[2,1] := 'hello'
if (test[1].d[10,5][1] = 't') and (test[2].x = 1) and (test[2].y = 2) and
(test[2].d[1,1] = 'hi') and (test[2].d[2,1] = 'hello') then
passed := true;
if passed then begin
test1.x := 1;
test1.y := 2;
test1.d[1,1] := 'hi';
test1.d[2,1] := 'hello';
test2 := test1;
test[1] := test2;
passed := (test1.x = test2.x) and (test1.y = test2.y) and
(test1.d[1,1] = test2.d[1,1]) and (test1.d[2,1] = test2.d[2,1]) and
(test[1].x = test2.x) and (test[1].y = test2.y);
end;
if passed then
writeln ('PASSED')
else
writeln ('FAILED');
end;
procedure testprocedures;
procedure testproc1;
procedure testproc2
begin
WriteLn ('PASSED')
end;
begin
testproc2
end;
begin
Write ('Testing PROCEDURES... ');
testproc1;
end;
procedure testrecursive (loop:byte)
begin
If loop = 255 then
write('Testing RECURSIVE...');
loop := loop - 1;
if loop > 1 then
testrecursive(loop)
else
writeln('PASSED')
end;
procedure testfunctions;
function testfunc1 (p1,p2:byte; p3:string) : byte;
begin
if (p1 <> 10) or (p2 <> 5) or (p3 <> 'hello') then
testfunc1 := 5
else
testfunc1 := 10;
end;
{$syntax iplc}
func testfunc2 : string {
testfunc2 = "ok"
}
{$syntax pascal}
begin
Write ('Testing FUNCTIONS... ');
if (testfunc1(10, 5, 'hello') = 10) and (testfunc2 = 'ok') then
writeln ('PASSED')
else
writeln ('FAILED')
end;
procedure testvarpassing;
procedure testit (var str: string);
begin
str := str + ' world';
end;
var
str : string;
begin
write ('Testing VARPASSING... ');
str := 'hello';
testit(str);
if str = 'hello world' then
writeln ('PASSED')
else
writeln ('FAILED');
end;
procedure teststringindex;
var
str : string;
begin
write ('Testing STRING IDX...');
str := 'hello world';
str[6] := #33;
if (str[1] = str[1]) and (str[2] = #101) and (str[6] = '!') then
writeln ('PASSED')
else
writeln ('FAILED')
end;
procedure testloops;
var
count1 : byte;
count2 : byte;
count3 : byte;
count4 : byte;
count5 : byte;
loop1 : byte;
loop2 : byte;
begin
Write ('Testing LOOPS...');
count1 := 0;
while count1 < 100 do begin
count1 := count1 + 1;
if count1 < 5 then continue;
if count1 < 5 then writeln('FAIL');
if count1 = 10 then break;
end;
count2 := 0;
repeat
count2 := count2 + 1;
if count2 < 5 then continue;
if count2 < 5 then writeln('FAIL');
if count2 = 10 then break;
until count2 = 100;
for count3 := 1 to 100 do begin
if count3 < 5 then continue;
if count3 < 5 then writeln('FAIL');
if count3 = 10 then break;
end;
loop1 := 0;
for count4 := 1 to 10 do begin
count4 := 10;
loop1 := loop1 + 1;
end;
loop2 := 0;
for count5 := 10 downto 1 do begin
count5 := 1;
loop2 := loop2 + 1;
end;
if (count1 = 10) and (count2 = 10) and (count3 = 10) and (count4 = 10) and
(loop1 = 1) and (count5 = 1) and (loop2 = 1) then
writeln ('PASSED')
else
writeln ('FAILED');
end;
procedure testconsts;
const
const1 = 'hello';
const2 = true;
const3 = 555;
const4 = 'A';
var
str1 : string;
bol1 : boolean;
ch1 : char;
num1 : longint;
ok1 : boolean;
ok2 : boolean;
ok3 : boolean;
ok4 : boolean;
begin
write ('Testing CONSTS...');
ok1 := false;
ok2 := false;
ok3 := false;
ok4 := false;
str1 := 'hello';
bol1 := true;
num1 := 555;
ch1 := 'A'
case str1 of
const1 : ok1 := true;
end;
case bol1 of
const2 : ok2 := true;
end;
case num1 of
const3 : ok3 := true;
end;
case ch1 of
const4 : ok4 := true;
end;
if ok1 and ok2 and ok3 and ok4 then
writeln ('PASSED')
else
writeln ('FAILED')
end;
procedure testsyntaxparsing;
{$syntax iplc} // Iniquity-like syntax for the oldskool or maybe C-heads
// been thinking about moving it to be closer to javascript
// than IPL?
proc testiplc {
@ byte test1, test2, test3 = 10;
write ("PASS");
@ string anywhere = "we can do this wherever..."
}
{$syntax pascal}
procedure testpascal;
var
test1, test2, test3 : byte = 10; // not a pascal standard!
begin
writeln('ED');
var anywhere : string = 'wait! pascal doesn''t allow this!';
end;
begin
write ('Testing SYNTAX... ');
testiplc;
testpascal;
end;
procedure testfileio;
const
fmReadWriteDenyNone = 66;
var
f : file;
b : array[1..11] of Char;
s : string[20];
l : longint;
begin
write ('Testing FILEIO... ');
// file IO is completely random. no text/file crap like in pascal
// but it operates very close to pascal, just easier. splitting the
// fOpen into fassign/frewrite/freset allows us to not have to open
// and close files constantly to reset or recreate it as in MPL 1.
// And doing away with raw numbers and adding a File type makes things
// much more manageable (and gives us virtually unlimited files)
fassign (f, 'testmps.dat', fmReadWriteDenyNone);
frewrite (f);
fwriteln (f, 'Hello world');
freset (f);
fread (f, b[1], 11);
freset (f);
freadln (f, s);
freset (f);
fseek (f, fsize(f));
if not feof(f) or fpos(f) <> fsize(f) then begin
writeln('FAILED');
fclose(f);
exit;
end;
fclose (f);
if fileexist('testmps.dat') then fileerase('testmps.dat');
if ioresult <> 0 or fileexist('testmps.dat') then begin
writeln('FAILED');
exit;
end;
// we can read data directly in to char arrays or strings as if it were
// a char array. no problems with reading non-pascal structs.
if b[1] = 'H' and b[2] = 'e' and b[3] = 'l' and s = 'Hello world' then
writeln('PASSED')
else
writeln('FAILED');
end;
procedure testrecordfileIO;
type
myuserrecord = record
username : string[30];
somevalue : array[1..5] of byte;
end;
var
f : file;
u : myuserrecord;
a : byte;
begin
Write ('Testing RECORDFILEIO... ');
u.username := 'testuser';
for a := 1 to 5 do
u.somevalue[a] := 1;
fassign (f, 'testmps.dat', 66);
frewrite (f);
fwriterec (f, u);
fillchar(u, sizeof(u), #0);
freset (f);
freadrec (f, u);
fclose (f);
if fileexist('testmps.dat') then fileerase('testmps.dat');
if (u.username = 'testuser') and (u.somevalue[1] = 1) and (u.somevalue[2] = 1) and
(u.somevalue[3] = 1) and (u.somevalue[4] = 1) and (u.somevalue[5] = 1) then
writeln('PASSED')
else
writeln('FAILED');
end;
begin
writeln ('|07|16|CLMystic BBS Programming Language Test Module');
writeln ('');
testcase;
testnumbers;
testrecords;
testprocedures;
testfunctions;
testrecursive(255);
testvarpassing;
teststringindex;
testloops;
testconsts;
testsyntaxparsing;
testfileio;
testrecordfileio;
writeln('|CRAll tests complete. Press a key.|PN');
end

1674
dbp/scripts/mrc_client.mps Normal file
View File

File diff suppressed because it is too large Load Diff

112
dbp/scripts/mrc_stat1.mps Normal file
View File

@@ -0,0 +1,112 @@
// ::::: __________________________________________________________________ :::::
// : ____\ ._ ____ _____ __. ____ ___ _______ .__ ______ .__ _____ .__ _. /____ :
// __\ .___! _\__/__ / _|__ / _/_____ __| \ gRK __|_ \ __ |_ \ !___. /__
// \ ! ___/ |/ /___/ | \__\ ._/ __\/ \ \___/ |/ \/ \_./ \___ ! /
// /__ (___ /\____\____|\ ____| / /___|\ ______. ____\|\ ___) __\
// /____ \_/ ___________ \_/ __ |__/ _______ \_/ ____ |___/ _____ \_/ ____\
// : /________________________________________________________________\ :
// ::::: + p H E N O M p R O D U C T I O N S + :::::
// ==============================================================================
//
// -----------------------------------------
// - modName: mrcstatus applet sample -
// - majorVersion: 1 -
// - minorVersion: 1 -
// - author: StackFault -
// - publisher: Phenom Productions -
// - website: https://www.phenomprod.com -
// - email: stackfault@bottomlessabyss.net -
// - bbs: bbs.bottomlessabyss.net:2023 -
// -----------------------------------------
//
// **********************************************************************
// Sample applet for MRC stats to use in the BBS
// This is a bit more advanced and will require some modding knowledge
// **********************************************************************
//
// Displays the status of the server to the users and some other stats
// Requires mrc_client.py v1.2.9
//
// You can play with the ansi file provided to give it the look you want
// It's just an example so you know how to integrate it together
//
// The applet does not PAUSE since it can be used to overlay on an existing
// menu, so if you want to use it as a distinct menu item, you will have to
// add a pause after executing it.
//
// To display this applet in your menu:
// 1. Add a new menu entry to your desired menu.
// 2. Set Hotkey to 'AFTER' by pressing CTRL-L on the Hotkey field
// 3. Set your menu command to 'GX' and use 'mrc_stat1' as data
//
// NOTE: The sample applet will display at X1, Y1 by default, to change that
// you will have to edit the ANSI file and the *LocAttr variables below.
//
// Your new applet should now be shown on your menu screen.
//
Uses Cfg
Var SvrQueuePath : String = CfgDataPath + 'mrc' // Align with mrc_client.py config
// Location of each items
Var StateLocAttr : String = '|[X03|[Y03|16' // Location of State text
Var BBSesLocAttr : String = '|[X02|[Y05|16|15' // Location of BBSes count
Var RoomsLocAttr : String = '|[X08|[Y05|16|15' // Location of Rooms count
Var UsersLocAttr : String = '|[X14|[Y05|16|15' // Location of Users count
Var LevelLocAttr : String = '|[X21|[Y05|16|15' // Location of Activity Level
// Activity Level Strings
Var ActivityBar : Array[1..4] of String[6]
// Look of the state text
Var Offline : String = '|20|15 OFFLINE |16' // Text for offline status
Var Online : String = '|18|01 ON-LINE |16' // Text for online status
Var State : String = Offline
Var BBSes, Rooms, Users, Level : Integer = 0
Begin
Var F1:File
Var F:String = SvrQueuePath + PathChar + 'mrcstats.dat'
Var L:String = ''
// Activity Meter display
// Now allows to display completely different string/level
ActivityBar[1] := '|08NUL' // No Activity
ActivityBar[2] := '|14LOW' // Low
ActivityBar[3] := '|10MED' // Moderate
ActivityBar[4] := '|12HI ' // High
// Read the stats file from mrc_client.py
// Do not read if older than 120 seconds
FindFirst(F, 66)
If DirTime + 120 > DateTime Then
Begin
FAssign(F1, F, 66)
FReset(F1)
FReadLn (F1, L)
FClose(F1)
End
FindClose
// Fetch the stats from the file
If Length(L) > 0 and WordCount(L, ' ') > 3 Then
Begin
BBSes := Str2Int(WordGet(1, L, ' '))
Rooms := Str2Int(WordGet(2, L, ' '))
Users := Str2Int(WordGet(3, L, ' '))
Level := Str2Int(WordGet(4, L, ' '))
If BBSes > 0 Then
State := Online
End
// Draw the applet
Write('|[X01|[Y01|16|DFmrcstat.ans|')
Write(StateLocAttr+State)
Write(BBSesLocAttr+PadCT(Int2Str(BBSes) ,5, ' '))
Write(RoomsLocAttr+PadCT(Int2Str(Rooms), 5, ' '))
Write(UsersLocAttr+PadCT(Int2Str(Users), 5, ' '))
Write(LevelLocAttr+ActivityBar[Level+1])
Write('|[X01|[Y24')
End

109
dbp/scripts/mrc_stat2.mps Normal file
View File

@@ -0,0 +1,109 @@
// ::::: __________________________________________________________________ :::::
// : ____\ ._ ____ _____ __. ____ ___ _______ .__ ______ .__ _____ .__ _. /____ :
// __\ .___! _\__/__ / _|__ / _/_____ __| \ gRK __|_ \ __ |_ \ !___. /__
// \ ! ___/ |/ /___/ | \__\ ._/ __\/ \ \___/ |/ \/ \_./ \___ ! /
// /__ (___ /\____\____|\ ____| / /___|\ ______. ____\|\ ___) __\
// /____ \_/ ___________ \_/ __ |__/ _______ \_/ ____ |___/ _____ \_/ ____\
// : /________________________________________________________________\ :
// ::::: + p H E N O M p R O D U C T I O N S + :::::
// ==============================================================================
//
// -----------------------------------------
// - modName: mrcstatus bar sample -
// - majorVersion: 1 -
// - minorVersion: 1 -
// - author: StackFault -
// - publisher: Phenom Productions -
// - website: https://www.phenomprod.com -
// - email: stackfault@bottomlessabyss.net -
// - bbs: bbs.bottomlessabyss.net:2023 -
// -----------------------------------------
//
// **********************************************************************
// Sample applet for MRC stats to use in the BBS
// This is a bit more advanced and will require some modding knowledge
// **********************************************************************
//
// Displays the status of the server to the users and some other stats.
// Requires mrc_client.py v1.2.7
//
// To display this applet in your menu:
// 1. Add a new menu entry to your desired menu.
// 2. Set Hotkey to 'AFTER' by pressing CTRL-L on the Hotkey field
// 3. Set your menu command to 'GX' and use 'mrc_stat2' as data
//
// Your new applet should now be shown on your menu screen.
Uses Cfg
Var SvrQueuePath : String = CfgDataPath + 'mrc' // Align with mrc_client.py config
// Location of each items
Var BarLocAttr : String = '|[X32|[Y02|16' // Location of Bar text
Var StateLocAttr : String = '|[X36|[Y02|16' // Location of State text
Var BBSesLocAttr : String = '|[X49|[Y02|16|15' // Location of BBSes count
Var RoomsLocAttr : String = '|[X58|[Y02|16|15' // Location of Rooms count
Var UsersLocAttr : String = '|[X67|[Y02|16|15' // Location of Users count
Var LevelLocAttr : String = '|[X76|[Y02|16|15' // Location of Activity Level
// Define the Bar look and text
Var BarText : String = '|15M|11RC|08[ ] ' +
'|15B|11BS|03|08[ ] ' +
'|15R|11ms|08[ ] ' +
'|15U|11sr|08[ ] ' +
'|15A|11ct|08[ ]|07'
// Activity Level Strings
Var ActivityBar : Array[1..4] of String[6]
// Look of the state text
Var Offline : String = '|12OFFLINE|16' // Text for offline status
Var Online : String = '|10ON-LINE|16' // Text for online status
Var State : String = Offline
Var BBSes, Rooms, Users, Level : Integer = 0
Begin
Var F1:File
Var F:String = SvrQueuePath + PathChar + 'mrcstats.dat'
Var L:String = ''
// Activity Meter display
// Now allows to display completely different string/level
ActivityBar[1] := '|07NUL' // No Activity
ActivityBar[2] := '|14LOW' // Low
ActivityBar[3] := '|10MED' // Moderate
ActivityBar[4] := '|12HI ' // High
// Read the stats file from mrc_client.py
// Do not read if older than 120 seconds
FindFirst(F, 66)
If DirTime + 120 > DateTime Then
Begin
FAssign(F1, F, 66)
FReset(F1)
FReadLn (F1, L)
FClose(F1)
End
FindClose
// Fetch the stats from the file
If Length(L) > 0 and WordCount(L, ' ') > 3 Then
Begin
BBSes := Str2Int(WordGet(1, L, ' '))
Rooms := Str2Int(WordGet(2, L, ' '))
Users := Str2Int(WordGet(3, L, ' '))
Level := Str2Int(WordGet(4, L, ' '))
If BBSes > 0 Then
State := Online
End
// Draw the applet
Write(BarLocAttr+BarText)
Write(StateLocAttr+State)
Write(BBSesLocAttr+PadCT(Int2Str(BBSes) ,3, ' '))
Write(RoomsLocAttr+PadCT(Int2Str(Rooms), 3, ' '))
Write(UsersLocAttr+PadCT(Int2Str(Users), 3, ' '))
Write(LevelLocAttr+ActivityBar[Level+1])
Write('|[X01|[Y24')
End

114
dbp/scripts/msgread.mpy Normal file
View File

@@ -0,0 +1,114 @@
#####################################################
# Simple Message Reader Example using Mystic Python #
#####################################################
# Reads messages in the user's current message base
# With a pause prompt and basic navigation
from mystic_bbs import *
# Load the current user and then load their current message base
# but fail if they have not selected a message base
user = getuser(0)
mbase = getmbaseid(user["mbase"])
if mbase is None:
writeln ("|CRYou have not selected a message base yet!|CR|CR|PA")
quit()
# Open the message base then check to make sure its open before reading
# data from it
msg = msg_open(mbase["path"] + mbase["filename"]);
if msg is None:
quit()
done = False
# Seek to the first message in the base and loop while a message
# is found, calling msg_next after each message so the next one
# will be loaded. Seek must be called first even if reading
# from the first message.
msg_seek(msg, 0)
while msg_found(msg) and not done and not shutdown():
# Load the message header information into a dictionary
# and the message text into a list. The message header
# must be loaded before the message text will be accessible
msghdr = msg_gethdr(msg)
msgtext = msg_gettxt(msg)
# Show the message header, setting a line counter that can
# be used to pause the screen
writeln("|16|CL|15Msg#: " + str(msghdr["number"]) + " of " + str(msghdr["highmsg"]))
writeln("|14From: " + msghdr["from"]);
writeln("|13 To: " + msghdr["to"]);
writeln("|11Subj: " + msghdr["subj"]);
writeln("|09-------------------------------------------------------------------------------|07");
pausecount = 4
# loop through each line in the message (list) and pause when
# we get more than 23 lines
for line in msgtext:
# before printing a line check if we need to pause
if pausecount >= 23:
pausecount = 1
write("|14*PAUSE* Continue? (|15Y|14)es, (|15N|14)o, (|15Q|14)uit: |07")
ch = onekey(chr(13) + 'YNQ', False)
# after getting input, erase the pause prompt then process the input
backspace(wherex(), True)
if ch == 'Q':
done = True
break
elif ch == 'N':
break
# increase pause counter and send a line of message text
# unless it is a kludge line:
if (line == "") or (line != "" and line[0] != chr(1)):
pausecount += 1
writeln(line)
# At end of message, so lets give a prompt if we didn't get a quit
# from the pause prompt:
if not done:
write("|CR|16|09MSG READER: (|11A|09)gain, (|11P|09)revious, (|11ENTER|09) Next, (|11Q|09) to Quit: ")
ch = onekey(chr(13) + 'APQ', True);
if ch == 'A':
# do nothing here so it redisplays the same msg
pass
elif ch == 'P':
if msghdr["number"] != 1:
msg_prev(msg)
elif ch == 'Q':
done = True
break
else:
msg_next(msg);
# Close the message base and report that we're done
msg_close(msg)
writeln("|CR|12Program complete: Press a key|PN");

37
dbp/scripts/onlyonce.mps Normal file
View File

@@ -0,0 +1,37 @@
// ONLYONCE.MPS: Display a file only if it has been updated since the users
// last login. Written by g00r00
// Usage:
// Menu command: GX
// Data: onlyonce myfile
//
// The above example will display myfile.XXX from current text directory
// only if it has been updated since the users last login
Uses
CFG,
USER;
Var
FN : String;
Begin
GetThisUser;
FN := JustFileName(ParamStr(1));
If Pos(PathChar, ParamStr(1)) = 0 Then
FN := CfgTextPath + FN;
FindFirst (FN + '.*', 0);
While DosError = 0 Do Begin
If DirTime > DateU2D(UserLastOn) Then Begin
DispFile(FN);
Break;
End;
FindNext
End;
FindClose;
End.

144
dbp/scripts/rumors.mps Normal file
View File

@@ -0,0 +1,144 @@
// ==========================================================================
// File: RUMORS.MPS
// Desc: Rumors engine for Mystic BBS v1.10
// Author: g00r00
// ==========================================================================
//
// INSTALLATION:
//
// 1) Copy RUMORS.MPS into its own directory or your scripts path and
// compile it with MPLC or MIDE
//
// 2) For each menu you want to display rumors on, you must edit with the
// MCFG -> Menu Editor and add the following menu command:
//
// HotKey: EVERY
// Command: GX (Execute MPL)
// Data: rumors show
//
// Note that if you have it in a path other than the scripts path, then
// you will have to specify that in the Data field above. For example
// <path>rumors show
//
// This MPL will create a rumors.dat file in the same directory where
// you have located the compiled MPX.
//
// 3) When rumors show is ran, it generates a rumor and stores it into
// the &1 MCI code. Therefore, you will need to edit your menu prompt
// or ANSI to include |&1 into it where you want it to display the rumor
//
// If for some reason to are auto executing other functions which use
// PromptInfo MCI codes (specially &1) you will want to add your EVERY
// execution of this MPL program AFTER those, so that the last value
// assigned to the MCI code was done by the rumor engine.
//
// 4) There are options in addition to the SHOW command in which you can
// use to add other functionality to your BBS. They are:
//
// ADD : Allows adding of a rumor to the rumor database. The database
// keeps the 50 most currently added rumors.
//
// EXAMPLE:
//
// Hotkey: A
// Command: GX (Execute MPL)
// Data: rumors add
//
// CUSTOMIZATION:
//
// If you wish to customize the prompts used in the Rumors, you can do
// so by changing the PromptAdd and PromptSave values set below. Do
// whatever you want with this. It was developed to demonstration IPLC
// which is one of MPL's alternative syntax options.
//
// ==========================================================================
{$syntax iplc}
const
// Prompts used
PromptAdd = "|CR|15E|07n|08ter |07y|08our |07r|08umor|CR:|07"
PromptSave = "|CR|15S|07a|08ve |07t|08his |07r|08umor? |XX"
// max number of characters for a rumor
rumorSize = 78;
proc rumoradd {
@ string str
@ string(50) data
@ byte datasize, count
@ file f
write(promptadd)
str = input(rumorSize, rumorSize, 1, "")
if str == "" exit
if !inputyn(promptsave) exit
fassign (f, justpath(progname) + "rumors.dat", 2)
freset (f);
if ioresult != 0 frewrite(f);
while !feof(f) && datasize < 50 {
datasize = datasize + 1
freadln(f, data(datasize))
}
fclose(f)
if datasize == 50 {
for count = 1 to 49
data(count) = data(count+1)
} else
datasize = datasize + 1
data(datasize) = str
frewrite(f)
for count = 1 to datasize
fwriteln(f, data(count));
fclose(f)
}
proc rumorshow {
@ string(50) data
@ byte datasize, count
@ file f
fassign (f, justpath(progname) + "rumors.dat", 2)
freset (f)
if ioresult != 0 exit
while !feof(f) && datasize < 50 {
datasize = datasize + 1
freadln(f, data(datasize))
}
count = random(datasize) + 1
datasize = 0
freset(f)
while datasize != count {
datasize = datasize + 1
freadln(f, data(datasize))
}
fclose(f)
setpromptinfo(1, data(datasize))
}
{
@ string options = upper(progparams);
if pos("ADD", options) > 0
rumoradd()
else
if pos("SHOW", options) > 0
rumorshow()
else
writeln("RUMORS: Invalid option: press a key|PN")
}

90
dbp/scripts/testbox.mps Normal file
View File

@@ -0,0 +1,90 @@
// =========================================================================
// TESTBOX.MPS : MPL example of using the ANSI box class functions
// =========================================================================
Procedure SetBoxDefaults (Handle: LongInt; Header: String);
Begin
// Mystic boxes default to the grey 3D style boxes used in the
// configuration, but you can change all aspects of them if you want
// to using the functions below.
If Header <> '' Then
BoxHeader (Handle, // Box class handle
0, // Header justify (0=center, 1=left, 2=right)
31, // Header attribute
Header); // Header text
// Available Box Frame types:
//
// 1 = <20>Ŀ<EFBFBD><C4BF><EFBFBD><EFBFBD><EFBFBD>
// 2 = <20>ͻ<EFBFBD><CDBB><EFBFBD>ͼ
// 3 = <20>ķ<EFBFBD><C4B7><EFBFBD>Ľ
// 4 = <20>͸<EFBFBD><CDB8><EFBFBD>;
// 5 = <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
// 6 = <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
// 7 =
// 8 = .-.||`-'
// Box shadows (if enabled) will actually read the characters under them
// and shade them using the shadow attribute.
BoxOptions (Handle, // Box class handle
2, // Box frame type (1-8)
False, // Use "3D" box shading effect
8, // Box attribute
8, // Box 3D effect attr1 (if on)
8, // Box 3D effect attr2 (if on)
8, // Box 3D effect attr3 (if on)
True, // Use box shadowing
112); // Box shadow attribute
End;
Var
BoxHandle : LongInt;
Begin
PurgeInput;
ClrScr;
WriteXY (20, 5, 12, 'This is a line of text that will have a window');
WriteXY (20, 6, 12, 'drawn over top of it. Press a key to draw a box');
ReadKey;
ClassCreate (BoxHandle, 'box');
BoxOpen (BoxHandle, // Box class handle
20, // top X corner of box
5, // top Y corner of box
60, // bottom X corner of box
10); // bottom Y corner of box
WriteXY (1, 1, 15, 'Press any key to close the box');
WriteXY (1, 2, 15, 'The screen contents under the box will be restored!');
ReadKey;
// Closing a box will restore what was "under" it on the screen before the
// box was created. You do not HAVE to close boxes if you dont want to.
BoxClose (BoxHandle);
WriteXY (1, 11, 11, 'Now lets change the box values. Press a key');
ReadKey;
// Now lets change the defaults to the box and open another one
SetBoxDefaults (BoxHandle, ' My Window Header ');
BoxOpen (BoxHandle, 20, 5, 60, 10);
ReadKey;
BoxClose (BoxHandle);
ClassFree (BoxHandle);
WriteXY (1, 14, 10, 'Pretty cool huh? Press a key to exit.');
ReadKey;
End.

54
dbp/scripts/testinput.mps Normal file
View File

@@ -0,0 +1,54 @@
// =========================================================================
// TESTINPUT : MPL example of using the ANSI input and box classes
// =========================================================================
Var
Box : LongInt;
In : LongInt;
InPos : Byte = 1;
Str : String = 'Input default';
Str2 : String = '';
Num : LongInt = 1;
Begin
PurgeInput;
ClassCreate (Box, 'box');
ClassCreate (In, 'input');
BoxHeader (Box, 0, 31, ' Input Demo ');
InputOptions (In, // Input class handle
31, // Attribute of inputted text
25, // Attribute to use for field input filler
#176, // Character to use for field input filler
#9, // Input will exit on these "low" ascii characters
// TAB
#72 + #80, // Exit on these extended characters
'*'); // Password input echo character
BoxOpen (Box, 20, 5, 60, 12);
Repeat
WriteXY (22, 7, 112, 'String Input > ' + PadRT(Str, 22, ' '));
WriteXY (22, 8, 112, 'Number Input > ' + PadRT(Int2Str(Num), 5, ' '));
WriteXY (22, 9, 112, 'Password > ' + PadRT(strRep('*', Length(Str2)), 22, ' '));
WriteXY (37, 11, 112, ' DONE ');
Case InPos of
1 : Str := InputString (In, 37, 7, 22, 22, 1, Str);
2 : Num := InputNumber (In, 37, 8, 5, 5, 1, 65000, Num);
3 : Str2 := InputString (In, 37, 9, 22, 22, 4, Str2);
4 : If InputEnter (In, 37, 11, 6, ' DONE ') Then Break;
End;
Case InputExit(In) of
#09,
#80 : If InPos < 4 Then InPos := InPos + 1 Else InPos := 1;
#72 : If InPos > 1 Then InPos := InPos - 1 Else InPos := 4;
End;
Until False;
BoxClose (Box);
ClassFree (Box);
ClassFree (In);
End.

15
dbp/scripts/testparams.mpy Normal file
View File

@@ -0,0 +1,15 @@
import mystic_bbs as bbs;
bbs.writeln ("Number of parameters..: " + str(bbs.param_count()))
bbs.writeln ("Full command line.....: " + bbs.param_str())
bbs.writeln ("Script name...........: " + bbs.param_str(0))
bbs.writeln ("|CRParameters (param_str):|CR")
count = 0
while count <= bbs.param_count():
bbs.writeln (" Param #" + str(count) + ": " + bbs.param_str(count))
count = count + 1
bbs.writeln("|CR|PA")

5
dbp/scripts/testpy3.mpy Normal file
View File

@@ -0,0 +1,5 @@
import mystic_bbs as bbs
import sqlite3
bbs.writeln("Hello from Python 3")
bbs.writeln("|PA")

142
dbp/scripts/testpython.mpy Normal file
View File

@@ -0,0 +1,142 @@
##############################################################
## INITIALIZE BBS FUNCTIONS AND DEFINE ANY GLOBAL VARIABLES ##
##############################################################
from mystic_bbs import *
KEY_UP = chr(72) # Some keyboard code defines returned by input functions
KEY_DOWN = chr(80)
KEY_ESCAPE = chr(27)
KEY_ENTER = chr(13)
KEY_TAB = chr(9)
KEY_LEFT = chr(75)
KEY_RIGHT = chr(77)
user_deleted = int("00000004") # user deleted flag from records.pas
thisuser = getuser(0); # read the currently logged in user into thisuser
################################
## CUSTOM FUNCTION: USER LIST ##
################################
def show_user_list():
writeln("|15|16|CL|17 Python Demonstration Program > User Listing|$X79 |16|CR")
count = 1
user = getuser(count)
shown = 0
while not user is None:
if not user["flags"] & user_deleted:
writeln(user["handle"])
shown = shown + 1
count = count + 1
user = getuser(count)
write("|CR|14Listed |15" + str(shown) + " |14user(s)|CR|CR|PA")
################################
## CUSTOM FUNCTION: BOX DEMO ##
################################
def do_box_demo():
box = box_options()
box["header"] = " Demo Box "
box["restore"] = False
writeln(str(box["attr1"]) + "|PN")
#box_open (box, 20, 3, 60, 9)
#box_close (box)
#################################
## CUSTOM FUNCTION: INPUT DEMO ##
#################################
def do_input_demo():
writeln("|15|16|CL|17 Python Demonstration Program > Input Demo|$X79 |16")
write('|CR|09Type a string: ');
input = getstr(11, 40, 120, "Default");
writeln("|CR|13Enter characters and press |05[|15ESCAPE|15|05] |13when done:|07|CR")
while not shutdown():
char, extended = getkey();
if extended:
if char == KEY_UP:
writeln("you pressed up arrow");
elif char == KEY_DOWN:
writeln("you pressed down arrow");
elif char == KEY_LEFT:
writeln("you pressed left arrow");
elif char == KEY_RIGHT:
writeln("you pressed right arrow");
else:
writeln("You pressed extended key #" + str(ord(char)))
else:
if char == KEY_ESCAPE:
writeln("you pressed ESCAPE");
break;
elif char == KEY_ENTER:
writeln("you pressed enter");
elif char == KEY_TAB:
writeln("you pressed tab");
else:
writeln("you pressed character " + char);
################################
## CUSTOM FUNCTION: MAIN MENU ##
################################
def show_main_menu():
while not shutdown():
writeln("|15|16|CL|17 Python Demonstration Program > Main Menu|$X79 |16")
writeln("|CR|15Hello, |14" + thisuser["handle"] + " #" + str(thisuser["id"]) + "|15! Please select one of the following options:|CR")
writeln(" |09(|11I|09) Input Demo")
writeln(" |09(|11U|09) User List")
write ("|CREnter option (|11Q|09/|11Quit|09): |11")
# get one character input using defined list of valid keys
char = onekey("IQU", True)
if char == "I":
do_input_demo()
if char == "Q":
break
if char == "U":
show_user_list()
###################################
## PROGRAM EXECUTION BEGINS HERE ##
###################################
show_main_menu()
writeln("|CR|14Demo complete! |PA");

23
dbp/scripts/tetris.ans Normal file
View File

@@ -0,0 +1,23 @@
<34><34><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34><6D><EFBFBD><EFBFBD>߲<EFBFBD><DFB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>۲<EFBFBD><DBB2><EFBFBD><EFBFBD><EFBFBD>۲<EFBFBD>
<EFBFBD><34><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲߲۲<DFB2><DBB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲<EFBFBD><DFB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲<EFBFBD><DFB2><34><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34><6D><34><34><6D> <34>߲<EFBFBD>۲<EFBFBD><DBB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲<34>۲
<EFBFBD> <20><34><34><34> <20> <30><6D><EFBFBD><34><6D> <20><> <30><37><6D><EFBFBD><30>۲ ݲ<34><34><34> <20> <30><6D><EFBFBD><34><6D> <20><><30><37><6D><EFBFBD><30><6D><EFBFBD><37><30> <34><6D><34><37><34>۲<6D> <20><> <20><><34><34><6D><34><34><6D><34> <34><6D><EFBFBD>
۱<EFBFBD><34><34> <20><><EFBFBD> <30> <20><34> <37><37><30>ܲ<6D><DCB2> <34><6D><34><34> <20><><EFBFBD> <30> <20><34> <20><37><6D><30><30><37>߲ <37><30> <34><6D> <30><6D>ܲ <34> <34><37><34><6D><EFBFBD> <30><6D><EFBFBD> <34><6D><EFBFBD>
۲<EFBFBD><EFBFBD><EFBFBD> <30><30><30><6D> <34><6D><30><34><6D><EFBFBD>  <30><6D><EFBFBD>߱ <34><6D> <20><> <30><30><30><6D> <34><6D><30><34><6D><EFBFBD> <37><6D><EFBFBD><30> <20><37><30><34> <30><6D><37><6D><30><6D> <34><34><30><34><30><30>ܲ<6D><DCB2> ܲ<6D><DCB2>
<EFBFBD><EFBFBD><EFBFBD>۲<EFBFBD><30><37><30><6D> <34><6D><EFBFBD>۲<EFBFBD> <30><34>ܲ<EFBFBD><DCB2><34><6D> <30><34>޲<EFBFBD><30><37><30><6D> <34><6D><EFBFBD>۲<EFBFBD> <37><30><37><30>߲<6D><DFB2>ܱ <30><37><37><30><6D><30><6D><34><6D> <30><30><31><6D><37><30><6D>۲ <34><6D><EFBFBD>
<EFBFBD><EFBFBD>۲<EFBFBD> <30><37><6D><EFBFBD><30> <34><6D><EFBFBD>۲ <34><37><6D><34> <20> <30><34> <20> <30><37><6D><EFBFBD><30> <34><6D><EFBFBD>۲ <30><37><6D><30> <34> <20> <34> <30><37><6D><30><6D><34><6D> <30>ܲ<6D><DCB2><30><37><30><6D><EFBFBD> <34><6D><EFBFBD>
<EFBFBD><EFBFBD><EFBFBD><EFBFBD>۲<EFBFBD> ߲ <34>۲<EFBFBD><DBB2>۲ <31><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> ܲ۲<DCB2> ߲ <34>۲<EFBFBD><DBB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ܲ<EFBFBD> <34><37><34><30> <34> <20><><EFBFBD>ܲ<EFBFBD><DCB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ܲ<EFBFBD><DCB2><34>
<34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34><6D>ܲ<EFBFBD><DCB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34><6D>۲<34><34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><34><34>ܲ<EFBFBD><DCB2><EFBFBD><EFBFBD><EFBFBD>۲<EFBFBD><DBB2>۲۲ <34><37><34><6D> <34><6D><34><34><6D><EFBFBD><EFBFBD><EFBFBD><34><34><6D>fi<30><6D><34><34><6D><EFBFBD><EFBFBD><EFBFBD><34><6D>
<EFBFBD>  <30><34> <34> <34><6D><31><6D><34>ܲ <30><6D> <30>
 <34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲߲ <20><>߲ <34><6D><32><34>  <20>
<20><34>level<37> <20> <30><34>޲   move block
<34> <34><32>   drop block
 lines <30> <34><32> z x  rotate block
<34> score<33> <34>޲  
<34><6D><37> <34><32> esc exit tetris 
۲<6D><DBB2><EFBFBD><EFBFBD><EFBFBD><34> <34> <34><6D><EFBFBD><EFBFBD>۲<EFBFBD><DBB2><EFBFBD> <34><32><34>  
<20><34><32>  
<34> <34><32>
<34><32>
<30> <30><34>޲
<30> <20> <30><34><32><43>
<34><6D><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>߲<EFBFBD><DFB2><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>

644
dbp/scripts/tetris.ms Normal file
View File

@@ -0,0 +1,644 @@
// Ported from Iniquity's Turbo Pascal source code to Mystic Script
// Original code by Mike Fricker port by g00r00 as proof of concept for Mystic Script
Program Tetris;
Const
maxGridY = 50;
maxGridX = 40;
maxPlayer = 2;
maxPtY = 5;
maxPtX = 5;
maxShape = 7;
maxLevel = 18;
Type
PGrid = ^TGrid;
TGrid = Array[1..MaxGridY] of Array[1..MaxGridX] of Byte;
TPlayer = Record
Local : Boolean;
Name : String[36];
Grid : pGrid;
Idx : array[1..maxGridY] of Byte;
gXp : Byte;
gYp : Byte;
gXs : Byte;
gYs : Byte;
gYl : Byte;
curB : Byte;
curF : Byte;
bX : Integer;
bY : Integer;
Lines : Word;
Level : Byte;
Score : LongInt;
nShape : Byte;
lastM : Double;
End;
TShape = Array[1..4] of Array[1..maxPtY] of Array[1..maxPtX] of Byte;
Const
sPts : Array[1..maxShape] of Byte = [4,6,6,5,6,5,5];
S : Array[1..maxShape] of TShape =
[[[[0,0,1,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,0,0], { <20> }
[0,0,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,1,1,1,1], { <20><><EFBFBD><EFBFBD> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,0,0], { <20> }
[0,0,1,0,0], { <20> }
[0,0,1,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[1,1,1,1,0], { <20><><EFBFBD><EFBFBD> }
[0,0,0,0,0], { }
[0,0,0,0,0]]],
[[[0,0,1,0,0],
[0,0,1,0,0], { <20> }
[0,1,1,0,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,1,1], { <20><><EFBFBD> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,0,1,1,0], { <20><> }
[0,0,1,0,0], { <20> }
[0,0,1,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[1,1,1,0,0], { <20><><EFBFBD> }
[0,0,1,0,0], { }
[0,0,0,0,0]]],
[[[0,0,1,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,1,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,0,1,1,1], { <20><><EFBFBD> }
[0,0,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,1,1,0,0], { <20><> }
[0,0,1,0,0], { <20> }
[0,0,1,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[1,1,1,0,0], { <20><><EFBFBD> }
[0,0,0,0,0], { }
[0,0,0,0,0]]],
[[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,1,1,1,0], { <20><><EFBFBD> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,1,0], { <20><> }
[0,0,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,1,1,1,0], { <20><><EFBFBD> }
[0,0,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,1,1,0,0], { <20><> }
[0,0,1,0,0], { }
[0,0,0,0,0]]],
[[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,1,1,0,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,1,1,0,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,1,1,0,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,1,1,0,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]]],
[[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,0,1,1,0], { <20><> }
[0,0,0,1,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,0,1,1,0], { <20><><EFBFBD> }
[0,1,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,0,0,0], { <20> }
[0,1,1,0,0], { <20><> }
[0,0,1,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,0,0,0], { }
[0,0,1,1,0], { <20><><EFBFBD> }
[0,1,1,0,0], { }
[0,0,0,0,0]]],
[[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,1,1,0,0], { <20><> }
[0,1,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,0,1,1,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,0,1,0,0], { <20> }
[0,1,1,0,0], { <20><> }
[0,1,0,0,0], { }
[0,0,0,0,0]],
[[0,0,0,0,0],
[0,1,1,0,0], { <20><> }
[0,0,1,1,0], { <20><> }
[0,0,0,0,0], { }
[0,0,0,0,0]]]];
Lev : Array[1..maxLevel] of Record T: Single; L: Word; End =
[[0.60,0],
[0.55,10],
[0.50,20],
[0.45,30],
[0.40,40],
[0.32,50],
[0.30,60],
[0.27,70],
[0.23,80],
[0.20,90],
[0.18,100],
[0.15,110],
[0.13,120],
[0.10,130],
[0.08,150],
[0.05,160],
[0.04,175],
[0.02,200]];
function dtTimer : Single;
var
year,
month,
day,
yr,
dayofweek,
hour,
minute,
second,
sec100 : Word;
begin
GetDate(year, month, day, dayofweek);
GetTime(hour, minute, second, sec100);
result := (day*24*60*60) + ((hour*60*60) + (minute*60) + (second) + (sec100 * 0.01));
end;
function dtRealDiff(before, after : Single) : Single;
begin
if after > before then
result := after-before
else
result := 0;
end;
type
tColorRec = record
Fore : Byte;
Back : Byte;
Blink : Boolean;
end;
var
P : array[1..maxPlayer] of tPlayer;
numP, q : Byte;
itdone, Ans : Boolean;
iCh : Char;
sfPos, sfPos2: array[1..30] of record
Ok : Boolean;
X, Y : Byte;
C : tColorRec;
end;
procedure itWriteScore(n : Byte);
begin
GotoXY (11, 15);
Write('|11' + Comma(P[n].Score) + '|09');
end;
procedure itWriteLines(n : Byte);
begin
GotoXY (11, 14);
Write('|11' + int2str(P[n].Lines) + '|09');
end;
procedure itWriteLevel(n : Byte);
begin
GotoXY(11, 12);
Write('|11' + int2str(P[n].Level) + '|09');
end;
procedure itDrawBlock(n : Byte; Erase : Boolean);
var z, x, y, yp : Integer; top : Boolean; ch : Char;
begin
//oSetColRec(sfPos[1].C);
with P[n] do
begin
for x := 1 to maxPtX do for y := 1 to maxPtY do if s[curB,curF,y,x] = 1 then
begin
yp := Idx[bY+y-1];
top := Odd(bY+y-1);
GotoXY(gXp+bX+x-2,gYp+yp-1);
if Erase then Grid^[bY+y-1,bX+x-1] := 0 else
begin
if Grid^[bY+y-1,bX+x-1] = 1 then itDone := True;
Grid^[bY+y-1,bX+x-1] := 1;
end;
if top then
begin
if (Grid^[bY+y-1,bX+x-1] = 1) and (Grid^[bY+y,bX+x-1] = 1) then ch := '<27>' else
if (Grid^[bY+y-1,bX+x-1] = 1) and (Grid^[bY+y,bX+x-1] = 0) then ch := '<27>' else
if (Grid^[bY+y-1,bX+x-1] = 0) and (Grid^[bY+y,bX+x-1] = 1) then ch := '<27>' else
ch := ' ';
end else
begin
if (Grid^[bY+y-2,bX+x-1] = 1) and (Grid^[bY+y-1,bX+x-1] = 1) then ch := '<27>' else
if (Grid^[bY+y-2,bX+x-1] = 1) and (Grid^[bY+y-1,bX+x-1] = 0) then ch := '<27>' else
if (Grid^[bY+y-2,bX+x-1] = 0) and (Grid^[bY+y-1,bX+x-1] = 1) then ch := '<27>' else
ch := ' ';
end;
WriteRaw(Ch);
end;
end;
flush;
end;
procedure itUpdateLine(n, l : Byte);
var x : Integer; top : Boolean; ch : Char;
begin
//oSetColRec(sfPos[1].C);
top := Odd(l);
with P[n] do
begin
GotoXY(gXp,gYp+Idx[l]-1);
for x := 1 to gXs do
begin
if top then
begin
if (Grid^[l,x] = 1) and (Grid^[l+1,x] = 1) then ch := '<27>' else
if (Grid^[l,x] = 1) and (Grid^[l+1,x] = 0) then ch := '<27>' else
if (Grid^[l,x] = 0) and (Grid^[l+1,x] = 1) then ch := '<27>' else
ch := ' ';
end else
begin
if (Grid^[l-1,x] = 1) and (Grid^[l,x] = 1) then ch := '<27>' else
if (Grid^[l-1,x] = 1) and (Grid^[l,x] = 0) then ch := '<27>' else
if (Grid^[l-1,x] = 0) and (Grid^[l,x] = 1) then ch := '<27>' else
ch := ' ';
end;
WriteRaw(Ch);
end;
end;
flush;
end;
procedure itNewBlock(n : Byte);
begin
with P[n] do
begin
curB := nShape;
nShape := Random(maxShape)+1;
curF := Random(4)+1;
bX := Random(gXs-4)+1;
bY := 1;
lastM := dtTimer;
end;
itDrawBlock(n,False);
end;
function itZapLine(n, l : Byte) : Boolean;
var ok : Boolean; z : Byte;
begin
result := False;
if (l < 1) or (l > P[n].gYs) then Exit;
ok := True;
for z := 1 to P[n].gXs do if P[n].Grid^[l,z] = 0 then ok := False;
result := ok;
end;
function itLineEmpty(n, l : Byte) : Boolean;
var ok : Boolean; z : Byte;
begin
result := False;
if (l < 1) or (l > P[n].gYs) then Exit;
ok := True;
for z := 1 to P[n].gXs do if P[n].Grid^[l,z] = 1 then ok := False;
result := ok;
end;
procedure itCheckLines(n : Byte);
var y, x, b, l : Byte;
begin
with P[n] do
begin
Inc(Score,sPts[curB]);
itWriteScore(n);
l := 0;
for y := 1 to maxPtY do if itZapLine(n,bY+y-1) then
begin
Inc(l);
for b := bY+y-1 downto 2 do Grid^[b] := Grid^[b-1];
for x := 1 to gXs do Grid^[1,x] := 0;
b := bY+y-1;
Inc(Lines);
itWriteLines(n);
end;
if l > 0 then
begin
for y := 1 to b do itUpdateLine(n,y);
Inc(Score,(l*l)*Level*100);
//oBeep;
itWriteScore(n);
if (Level < maxLevel) and (Lines >= Lev[Level+1].l) then
begin
Inc(Level);
itWriteLevel(n);
//oBeep;
//oBeep;
end;
end;
end;
end;
procedure itMoveDown(n : Byte);
var ny, x, y : Integer; stop : boolean;
begin
with P[n] do
begin
ny := bY+1;
stop := False;
for x := 1 to maxPtX do for y := 1 to maxPtY do
if (s[curB,curF,y,x] <> 0) and
(((Grid^[ny+y-1,bX+x-1] = 1) and
(not ((y < 5) and (S[curB,curF,y+1,x] = 1)))) or
(ny+y-1 > gYs)) then stop := True;
if not stop then
begin
itDrawBlock(n,True);
bY := bY+1;
itDrawBlock(n,False);
end else
begin
itCheckLines(n);
itNewBlock(n);
end;
end;
end;
procedure itFastDown(n : Byte);
var ny, x, y, oy : Integer; stop : boolean;
begin
with P[n] do
begin
stop := False;
oy := bY;
repeat
ny := oY+1;
for x := 1 to maxPtX do for y := 1 to maxPtY do
if (s[curB,curF,y,x] <> 0) and
(((Grid^[ny+y-1,bX+x-1] = 1) and
(not ((y < 5) and (S[curB,curF,y+1,x] = 1)))) or
(ny+y-1 > gYs)) then stop := True;
if not Stop then oY := oY+1;
until stop;
itDrawBlock(n,True);
bY := oY;
itDrawBlock(n,False);
itCheckLines(n);
itNewBlock(n);
end;
end;
procedure itMoveRight(n : Byte);
var nx, x, y : Integer; ok : Boolean;
begin
with P[n] do
begin
nx := bX+1;
ok := True;
for x := 1 to maxPtX do for y := 1 to maxPtY do
if (s[curB,curF,y,x] <> 0) and
(((Grid^[bY+y-1,nx+x-1] = 1) and
(not ((x < 5) and (S[curB,curF,y,x+1] = 1)))) or
(nx+x-1 > gXs)) then ok := False;
if ok then
begin
itDrawBlock(n,True);
bX := bX+1;
itDrawBlock(n,False);
end;
end;
end;
procedure itMoveLeft(n : Byte);
var nx, x, y : Integer; ok : Boolean;
begin
with P[n] do
begin
nx := bX-1;
ok := True;
for x := 1 to maxPtX do
for y := 1 to maxPtY do
if (s[curB,curF,y,x] <> 0) and ((nx+x-1 < 1) or ((Grid^[bY+y-1,nx+x-1] = 1) and (not ((x > 1) and (S[curB,curF,y,x-1] = 1))))) then
ok := False;
if ok then begin
itDrawBlock(n,True);
bX := bX-1;
itDrawBlock(n,False);
end;
end;
end;
procedure itRotate(n : Byte; add : Integer);
var nf, x, y : Integer; ok : Boolean;
begin
with P[n] do
begin
nf := curF+add;
if nf < 1 then nf := 4 else if nf > 4 then nf := 1;
ok := True;
for x := 1 to maxPtX do for y := 1 to maxPtY do
if (s[curB,nf,y,x] <> 0) and
((bX+x-1 < 1) or
(bX+x-1 > gXs) or (bY+y-1 > gYs) or
((Grid^[bY+y-1,bX+x-1] = 1) and
(not (S[curB,curF,y,x] = 1)))) then ok := False;
if ok then
begin
itDrawBlock(n,True);
curF := nf;
itDrawBlock(n,False);
end;
end;
end;
procedure itPlayTetris;
begin
Write('|[0');
ans := showfile(extractpath(scriptname) + 'tetris');
sfpos[1].x := 29;
sfpos[1].y := 11;
sfpos[2].x := 50;
sfpos[2].y := 22;
FillChar(P,SizeOf(P),#0);
itDone := False;
numP := 1;
with P[1] do begin
Name := 'Test user';
New(Grid);
FillChar(Grid^,SizeOf(Grid^),#0);
gYl := 0;
gXp := sfPos[1].X;
gYp := sfPos[1].Y;
gXs := sfPos[2].X-gXp+1;
gYs := sfPos[2].Y-gYp+1;
gYs := gYs*2;
if Odd(gYs) then
Dec(gYs);
Local := True;
for q := 1 to gYs do begin
if Local then Inc(gYl);
Local := not Local;
Idx[q] := gYl;
end;
curB := 1;
curF := 1;
bX := 1;
bY := 1;
Lines := 0;
Score := 0;
Level := 1;
nShape := Random(maxShape)+1;
Local := True;
end;
itWriteLevel(1);
itWriteLines(1);
itWriteScore(1);
itNewBlock(1);
repeat
iCh := InKey(25);
If iCh <> #255 Then Begin
if isExtended then begin
case iCh of
keyDown : itFastDown(1);
keyLeft : itMoveLeft(1);
keyRight: itMoveRight(1);
keyUp : itRotate(1,1);
end;
end else
case UpCase(iCh) of
' ','W','X','5' : itRotate(1,1);
#13,'2','S' : itFastDown(1);
'Z' : itRotate(1,-1);
'4','A' : itMoveLeft(1);
'6','D' : itMoveRight(1);
'0' : itMoveDown(1);
#27 : itDone := True;
end;
end;
for q := 1 to numP do with P[q] do begin
if dtRealDiff(lastM,dtTimer) > Lev[Level].t then begin
itMoveDown(q);
lastM := dtTimer;
end;
end;
until (Shutdown) or (itDone);
Write('|[1');
with P[1] do begin
Dispose(Grid);
end;
//sfGotoPos(maxPos);
//logWrite('Played Tetris ['+St(P[1].Lines)+' lines, '+Stc(P[1].Score)+
//' points; level '+St(P[1].Level)+']');
//itAddHiScore;
End;
begin
itPlayTetris;
end.

561
dbp/scripts/to-prmpt.mps Normal file
View File

@@ -0,0 +1,561 @@
// .-------------------------.
// | TO-PRMPT.MPS : UPDATE 3 |===============================================
// `-------------------------'
//
// This mod is a lightbar prompt replacement for standard message reading,
// standard file listing, standard e-mail reader, and the pause y/n/c
// prompt.
//
// See installation section for more details.
//
// -------------------------------------------------------------------------
// BACKGROUND
// -------------------------------------------------------------------------
//
// This mod is was originally written for use with Mystic BBS v1.07.3 by
// Testoverride, based on some demo MPL code written by g00r00.
//
// It has been updated for Mystic BBS 1.10+ by g00r00, and released without
// Testoverride's assistance. This is not an intentional thing, but TO has
// been missing lately, so given the circumstances that it was based off of
// g00r00's code, we feel it's okay to go forward with this release.
//
// You are free to modify and do whatever you'd like to with this code, but
// please if you do make significant changes please let the original authors
// know so that we can include it into our release if it is worthwhile.
//
// The original authors contact info follows:
//
// Testoverride - testoverride@comcast.net (unconfirmed)
// g00r00 - mysticbbs@gmail.com
//
// --------------------------------------------------------------------------
// INSTALLATION
// --------------------------------------------------------------------------
//
// Replace the following prompts with the following data if you want to
// replace them with TO-PRMPT lightbar prompt functionality (exclude quotes):
//
// Message reading prompts: Set Prompt #116 to "!to-prmpt MESSAGE"
// Set Prompt #213 to "!to-prmpt MESSAGE"
// E-mail reading prompt : Set Prompt #115 to "!to-prmpt EMAIL"
// File Listing prompt : Set Prompt #044 to "!to-prmpt FILE"
// YNC Pause prompt : Set Prompt #132 to "!to-prmpt PAUSE"
// Msg Editor prompt : Set Prompt #354 to "!to-prmpt EDITOR"
//
// When you have changed the prompts, you must compile them again with
// MAKETHEME, or if you changed them inside the internal prompt editor, the
// theme prompts file will usually be compiled for you.
//
// --------------------------------------------------------------------------
// New updates for 1.10:
// --------------------------------------------------------------------------
//
// - Converted to new MPL 1.10
// - Changed the s255 ACS check to use the message owner MCI code instead
// - Added the 'H' command to the message reader prompt (set lastread)
// - Added the 'M' command to the message reader prompt (move message)
// - Added the 'F' command to the message reader prompt (forward)
// - Added the FS editor prompt option
// - Some conversions of IF statements to CASE statements for code clarity
//
// ===========================================================================
Var
Selection : Byte;
Function EditPromptMenu : Byte
Var
Ch : Char;
Done : Boolean;
Bar : Byte;
Cmd : Array[1..7] of String[80];
Xpos : Array[1..7] of String[80];
Begin
Done := False
Bar := 1
Xpos[1] := '|[X14'
Xpos[2] := '|[X20'
Xpos[3] := '|[X27'
Xpos[4] := '|[X34'
Xpos[5] := '|[X44'
Xpos[6] := '|[X52'
Xpos[7] := '|[X59'
Cmd[1] := ' |15S|07ave '
Cmd[2] := ' |15Q|07uote '
Cmd[3] := ' |15A|07bort '
Cmd[4] := ' |15C|07ontinue '
Cmd[5] := ' |15U|07pload '
Cmd[6] := ' |15T|07itle '
Cmd[7] := ' |15H|07elp '
Repeat
If Graphics > 0 Then
Write ('|15|17' + Xpos[Bar]+stripmci(Cmd[Bar]) + '|00|16');
Ch := ReadKey
If Graphics > 0 and IsArrow Then Begin
Write (Xpos[bar] + Cmd[Bar] + '|00|16');
If Ord(Ch) = 75 Then Begin
If Bar > 1 Then
Bar := Bar - 1
End Else
If Ord(Ch) = 77 Then Begin
If Bar < 7 Then
Bar := Bar + 1
End
End Else
If Ch = #13 and Graphics > 0 Then Begin
EditPromptMenu := Bar
Done := True
End Else
If Upper(Ch) = 'S' Then Begin
EditPromptMenu := 1
Done := True
End Else
If Upper(Ch) = 'Q' Then Begin
EditPromptMenu := 2
Done := True
End Else
If Upper(Ch) = 'A' Then Begin
EditPromptMenu := 3
Done := True
End Else
If Upper(Ch) = 'C' Then Begin
EditPromptMenu := 4
Done := True
End Else
If Upper(Ch) = 'U' Then Begin
EditPromptMenu := 5
Done := True
End Else
If Upper(Ch) = 'T' Then Begin
EditPromptMenu := 6
Done := True
End Else
If Upper(Ch) = 'H' Then Begin
EditPromptMenu := 7
Done := True
End
Until Done
End
Function FPromptMenu : Byte
Var
Ch : Char;
Done : Boolean;
Bar : Byte;
Cmd : Array[1..5] of String[80];
Xpos : Array[1..5] of String[80];
Begin
Done := False
Bar := 1
Xpos[1] := '|[X38'
Xpos[2] := '|[X44'
Xpos[3] := '|[X54'
Xpos[4] := '|[X60'
Xpos[5] := '|[X66'
Cmd[1] := ' |15N|07ext '
Cmd[2] := ' |15P|07revious '
Cmd[3] := ' |15F|07lag '
Cmd[4] := ' |15V|07iew '
Cmd[5] := ' |15Q|07uit '
Repeat
If Graphics > 0 Then
Write ('|15|17' + Xpos[Bar]+stripmci(Cmd[Bar]) + '|00|16');
Ch := ReadKey
If Graphics > 0 and IsArrow Then Begin
Write (Xpos[bar] + Cmd[Bar] + '|00|16');
If Ord(Ch) = 75 Then Begin
If Bar > 1 Then
Bar := Bar - 1
End Else
If Ord(Ch) = 77 Then Begin
If Bar < 5 Then
Bar := Bar + 1
End
End Else
If Ch = #13 and Graphics > 0 Then Begin
FPromptMenu := Bar
Done := True
End Else
If Upper(Ch) = 'N' Then Begin
FPromptMenu := 1
Done := True
End Else
If Upper(Ch) = 'P' Then Begin
FPromptMenu := 2
Done := True
End Else
If Upper(Ch) = 'F' Then Begin
FPromptMenu := 3
Done := True
End Else
If Upper(Ch) = 'V' Then Begin
FPromptMenu := 4
Done := True
End Else
If Upper(Ch) = 'Q' Then Begin
FPromptMenu := 5
Done := True
End
Until Done
End
Function EPromptMenu : Byte
Var
Ch : Char;
Done : Boolean;
Bar : Byte;
Cmd : Array[1..7] of String[80];
Xpos : Array[1..7] of String[80];
Begin
Done := False
Bar := 1
Xpos[1] := '|[X22'
Xpos[2] := '|[X28'
Xpos[3] := '|[X38'
Xpos[4] := '|[X45'
Xpos[5] := '|[X52'
Xpos[6] := '|[X58'
Xpos[7] := '|[X66'
Cmd[1] := ' |15N|07ext '
Cmd[2] := ' |15P|07revious '
Cmd[3] := ' |15A|07gain '
Cmd[4] := ' |15R|07eply '
Cmd[5] := ' |15J|07ump '
Cmd[6] := ' |15D|07elete '
Cmd[7] := ' |15Q|07uit '
Repeat
If Graphics > 0 Then
Write ('|15|17' + Xpos[bar]+stripmci(Cmd[Bar]) + '|00|16')
Ch := ReadKey
If Graphics > 0 and IsArrow Then Begin
Write (Xpos[bar]+Cmd[Bar] + '|00|16')
If Ord(Ch) = 75 Then Begin
If Bar > 1 Then Bar := Bar - 1
End Else
If Ord(Ch) = 77 Then Begin
If Bar < 7 Then Bar := Bar + 1
End
End Else Begin
If Ch = Chr(13) and Graphics > 0 Then Begin
EPromptMenu := Bar
Done := True
End Else
If Upper(Ch) = 'N' Then Begin
EPromptMenu := 1
Done := True
End Else
If Upper(Ch) = 'P' Then Begin
EPromptMenu := 2
Done := True
End Else
If Upper(Ch) = 'A' Then Begin
EPromptMenu := 3
Done := True
End Else
If Upper(Ch) = 'R' Then Begin
EPromptMenu := 4
Done := True
End Else
If Upper(Ch) = 'J' Then Begin
EPromptMenu := 5
Done := True
End Else
If Upper(Ch) = 'D' Then Begin
EPromptMenu := 6
Done := True
End Else
If Upper(Ch) = 'Q' Then Begin
EPromptMenu := 7
Done := True
End Else
If Upper(Ch) = 'X' Then Begin
stuffkey(ch)
Done := True
End Else
If Upper(Ch) = '?' Then Begin
stuffkey(ch)
Done := True
End Else
If Upper(Ch) = 'L' Then Begin
stuffkey(ch)
Done := True
End
End
Until Done
End
Function MPromptMenu : Byte;
Var
Done : Boolean;
Ch : Char
Bar : Byte
Cmd : Array[1..6] of String[80]
Xpos : Array[1..6] of String[80]
Begin
Bar := 1;
Xpos[1] := '|[X36'
Xpos[2] := '|[X42'
Xpos[3] := '|[X52'
Xpos[4] := '|[X59'
Xpos[5] := '|[X66'
Xpos[6] := '|[X72'
Cmd[1] := ' |15N|07ext|00|16 '
Cmd[2] := ' |15P|07revious|00|16 '
Cmd[3] := ' |15A|07gain|00|16 '
Cmd[4] := ' |15R|07eply|00|16 '
Cmd[5] := ' |15J|07ump|00|16 '
Cmd[6] := ' |15Q|07uit|00|16 '
Repeat
If Graphics > 0 Then
Write ('|15|17' + Xpos[bar]+stripmci(Cmd[Bar]) + '|00|16');
Ch := Upper(ReadKey);
If Graphics > 0 and IsArrow Then Begin
Write (Xpos[bar]+Cmd[Bar] + '|00|16');
Case Ch of
#75 : If Bar > 1 Then Bar := Bar - 1;
#77 : If Bar < 6 Then Bar := Bar + 1;
End
End Else Begin
Case Ch of
#13 : If Graphics > 0 Then Begin
MPromptMenu := Bar;
Done := True;
End;
'N' : Begin
MPromptMenu := 1;
Done := True;
End;
'P' : Begin
MPromptMenu := 2;
Done := True;
End;
'A' : Begin
MPromptMenu := 3;
Done := True;
End;
'R' : Begin
MPromptMenu := 4;
Done := True;
End;
'J' : Begin
MPromptMenu := 5;
Done := True;
End;
'Q' : Begin
MPromptMenu := 6;
Done := True;
End;
Else
If (Pos(Ch, 'MEFD') > 0 And ACS('OM')) OR (Pos(Ch, 'X?[]HITGL') > 0) Then Begin
StuffKey(Ch);
Break;
End;
End;
End;
Until Done;
End;
Function PPromptMenu : Byte
Var
Ch : Char
Done : Boolean
Bar : Byte
Cmd : Array[1..3] of String[80];
Xpos : Array[1..3] of String[80];
Begin
Done := False
Bar := 1
Xpos[1] := '|[X21'
Xpos[2] := '|[X26'
Xpos[3] := '|[X30'
Cmd[1] := ' |15Y|07es '
Cmd[2] := ' |15N|07o '
Cmd[3] := ' |15C|07ontinuous '
Repeat
If Graphics > 0 Then
Write ('|15|17' + XPos[Bar] + StripMCI(Cmd[Bar]) + '|00|16')
Ch := ReadKey
If Graphics > 0 and IsArrow Then Begin
Write (XPos[Bar] + Cmd[Bar] + '|00|16')
If Ord(Ch) = 75 Then Begin
If Bar > 1 Then Bar := Bar - 1
End Else
If Ord(Ch) = 77 Then Begin
If Bar < 3 Then Bar := Bar + 1
End
End Else
If Ch = #13 and Graphics > 0 Then Begin
PPromptMenu := Bar
Done := True
End Else
If Upper(Ch) = 'Y' Then Begin
PPromptMenu := 1
Done := True
End Else
If Upper(Ch) = 'N' Then Begin
PPromptMenu := 2
Done := True
End Else
If Upper(Ch) = 'C' Then Begin
PPromptMenu := 3
Done := True
End
Until Done
End
Procedure MESSAGE
Begin
Write ('|CR|08>>|07 Reading messages |15|$L04|&5 |07of |15|$R04|&6 |08// |15N|09ext |15P|07revious |15A|07gain |15R|07eply |15J|07ump |15Q|07uit |00')
Selection := MPromptMenu
MoveX(1);
TextColor(7);
ClrEOL;
Case Selection of
1 : stuffkey('N');
2 : stuffkey('P');
3 : stuffkey('A');
4 : stuffkey('R');
5 : stuffkey('J');
6 : stuffkey('Q');
End;
End
Procedure DOPAUSE
Var
SavedX : Byte;
Begin
Write ('|08>> |07Paused |08- |07More|08 // |15Y|09es |15N|07o |15C|07ontinuous |00');
SavedX := WhereX;
Selection := PPromptMenu
If Selection = 1 Then
stuffkey('Y')
Else
If Selection = 2 Then
stuffkey('N')
Else
If Selection = 3 Then
stuffkey('C')
Write('|[X' + PadLT(Int2Str(SavedX), 2, '0'));
End
Procedure Email
Begin
Write ('|CR|08>> |07Reading e-mail |08// |15N|09ext |15P|07revious |15A|07gain |15R|07eply |15J|07ump |15D|07elete |15Q|07uit |00')
Selection := EPromptMenu
If Selection = 1 Then
stuffkey('N')
Else
If Selection = 2 Then
stuffkey('P')
Else
If Selection = 3 Then
stuffkey('A')
Else
If Selection = 4 Then
stuffkey('R')
Else
If Selection = 5 Then
stuffkey('J')
Else
If Selection = 6 Then
stuffkey('D')
Else
If Selection = 7 Then
stuffkey('Q')
End
Procedure Editor;
Begin
Write ('|CR|08<< |07Editor |08// |15S|07ave |15Q|07uote |15A|07bort |15C|07ontinue |15U|07pload |15T|07itle |15H|07elp |08>>');
Case EditPromptMenu of
1 : stuffKey('S');
2 : stuffKey('Q');
3 : stuffKey('A');
4 : stuffKey('C');
5 : stuffKey('U');
6 : stuffKey('T');
7 : stuffKey('H');
End;
End;
Procedure File
Begin
Write ('|CR|08[|07|$R31|FB|08] |08// |15N|07ext |15P|07revious |15F|07lag |15V|07iew |15Q|07uit |08>>')
Selection := FPromptMenu
If Selection = 1 Then
stuffkey('N')
Else
If Selection = 2 Then
stuffkey('P')
Else
If Selection = 3 Then
stuffkey('F')
Else
If Selection = 4 Then
stuffkey('V')
Else
If Selection = 5 Then
stuffkey('Q')
End
Const
FailStr = '|CRUSAGE: to-prmpt [ MESSAGE | FILE | EMAIL | PAUSE | EDITOR ]|CR|CR|PA';
Begin
AllowArrow := True;
If ParamCount < 1 Then
WriteLn(FailStr)
Else
Case Upper(ParamStr(1)) of
'MESSAGE': MESSAGE;
'FILE' : FILE;
'EMAIL' : EMAIL;
'PAUSE' : DOPAUSE;
'EDITOR' : EDITOR;
Else
WriteLn(FailStr);
End;
End.

264
dbp/scripts/usage.mps Normal file
View File

@@ -0,0 +1,264 @@
// ==========================================================================
// USAGE.MPS : On the fly usage graph calculation for Mystic BBS v1.10+
// Author : g00r00
// Version : 1.1
// License : Part of with Mystic BBS distribution / GPL repository
// --------------------------------------------------------------------------
//
// This MPL calculates a monthly, weekly and hourly usage graph based on the
// BBS history datafile. Simply copy it to the scripts directory, compile it
// and execute it from your menu with the GX menu command (optional data
// 'usage').
//
// If the MPL program is executed without any optional data, it will allow
// the user to tab through the different graphs. Additionally, the following
// optional command data options can be used:
//
// MONTHLY - Display monthly graph and exit immediately
// WEEKLY - Display weekly graph and exit immediately
// HOURLY - Display hourly graph and exit immediately
//
// Example:
//
// Menu Command: GX (Execute MPL Program)
// Optional Data: usage weekly
//
// ==========================================================================
Uses CFG
Const
fmRWDN = 66;
Type
RecHistory = Record // From records.pas 1.10
Date : LongInt;
Emails : Word;
Posts : Word;
Downloads : Word;
Uploads : Word;
DownloadKB : LongInt;
UploadKB : LongInt;
Calls : LongInt;
NewUsers : Word;
Telnet : Word;
FTP : Word;
POP3 : Word;
SMTP : Word;
NNTP : Word;
HTTP : Word;
Hourly : Array[1..24] of Byte;
Reserved : Array[1..2] of Byte;
End;
Var
Days : LongInt;
Calls : LongInt;
Month : Array[1..12] of Cardinal;
Week : Array[1..7] of Cardinal;
Hour : Array[1..24] of Cardinal;
Procedure DrawBar (XPos, bSize, Value: Byte);
Var
Temp : Byte;
Begin
For Temp := 1 to Value Do
WriteXY (XPos, 18 - Temp, 1, strRep(#219, bSize));
End;
Procedure DisplayMonthly;
Var
Count : Byte;
Count2 : Byte;
Begin
WriteLn ('|CL|09|17 ' + #176 + ' |15Monthly Usage Graph ' + PadLT(strComma(Days) + '|07 days, |15' + strComma(Calls) + ' |07calls ', 63, ' ') + '|09' + #176 + ' |16');
GotoXY (6, 18);
For Count := 1 to 12 Do
Write ('|08' + #196 + #196 + #196 + ' ');
WriteXY (6, 19, 14, 'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec');
WriteXY (2, 21, 08, strRep(#196, 78));
For Count := 1 to 12 Do
For Count2 := 15 DownTo 1 Do Begin
GotoXY (Count * 6, 2 + Count2);
Write (#250 + #250 + #250);
End;
For Count := 1 to 12 Do
DrawBar (6 * Count, 3, Month[Count]);
End;
Procedure DisplayWeekly;
Var
Count : Byte;
Count2 : Byte;
Begin
WriteLn ('|CL|09|17 ' + #176 + ' |15Weekly Usage Graph ' + PadLT(strComma(Days) + '|07 days, |15' + strComma(Calls) + ' |07calls ', 64, ' ') + '|09' + #176 + ' |16');
For Count := 0 to 6 Do Begin
GotoXY (4 + (Count * 11), 18);
Write ('|08' + strRep(#196, 8));
End;
WriteXY ( 4, 19, 14, ' Sunday Monday Tuesday Wednesday Thursday Friday Saturday');
WriteXY ( 2, 21, 08, strRep(#196, 78));
For Count := 0 to 6 Do
For Count2 := 15 DownTo 1 Do Begin
GotoXY (4 + (Count * 11), 2 + Count2);
Write (strRep(#250, 8));
End;
For Count := 1 to 7 Do
DrawBar (4 + ((Count - 1) * 11), 8, Week[Count]);
End;
Procedure DisplayHourly;
Var
Count : Integer;
Count2 : Integer;
Begin
WriteLn ('|CL|09|17 ' + #176 + ' |15Hourly Usage Graph ' + PadLT(strComma(Days) + '|07 days, |15' + strComma(Calls) + ' |07calls ', 64, ' ') + '|09' + #176 + ' |16');
GotoXY (5, 18);
For Count := 1 to 24 Do
Write ('|08' + #196 + #196 + ' ');
WriteXY ( 5, 19, 14, '12 01 02 03 04 05 06 07 08 09 10 11 12 01 02 03 04 05 06 07 08 09 10 11');
WriteXY ( 5, 20, 09, 'AM');
WriteXY (41, 20, 09, 'PM');
WriteXY ( 2, 21, 08, strRep(#196, 78));
For Count := 1 to 24 Do
For Count2 := 15 DownTo 1 Do Begin
GotoXY (5 + ((Count - 1) * 3), Count2 + 2);
Write ('|08' + #250 + #250);
End;
For Count := 1 to 24 Do
DrawBar (5 + ((Count - 1) * 3), 2, Hour[Count]);
End;
Procedure CalculateHistory;
Var
HistFile : LongInt;
OneDay : RecHistory;
TempLong : Cardinal;
TempReal : Real;
Count : LongInt;
Highest : Cardinal;
Begin
ClassCreate(HistFile, 'File');
If Not FileOpen(HistFile, CfgDataPath + 'history.dat', SizeOf(OneDay), 1, 66) Then Begin
ClassFree(HistFile);
Exit;
End;
If FileSize(HistFile) = 0 Then Begin
ClassFree(HistFile);
WriteLn ('|CRNo BBS history to calculate|CR|CR|PA');
Halt;
End;
Days := FileSize(HistFile);
WriteLn ('|16|CL|15Calculating usage for last ' + strComma(Days) + ' days...');
While Not FileEOF(HistFile) Do Begin
FileRead (Histfile, OneDay);
Calls := Calls + OneDay.Calls;
TempLong := Str2Int(Copy(DateStr(OneDay.Date, 1), 1, 2));
Month[TempLong] := Month[TempLong] + OneDay.Calls;
TempLong := DayOfWeek(OneDay.Date) + 1;
Week[TempLong] := Week[TempLong] + OneDay.Calls;
For Count := 1 to 24 Do
Hour[Count] := Hour[Count] + OneDay.Hourly[Count];
End;
ClassFree(HistFile);
Highest := 0;
For Count := 1 to 12 Do
If Month[Count] > Highest Then
Highest := Month[Count];
For Count := 1 to 12 Do
If Month[Count] > 0 Then Begin
TempReal := (Month[Count] / Highest * 100);
Month[Count] := TempReal / 7 + 1;
End;
Highest := 0;
For Count := 1 to 7 Do
If Week[Count] > Highest Then
Highest := Week[Count];
For Count := 1 to 7 Do
If Week[Count] > 0 Then Begin
TempReal := (Week[Count] / Highest * 100);
Week[Count] := TempReal / 7 + 1;
End;
Highest := 0;
For Count := 1 to 24 Do
If Hour[Count] > Highest Then
Highest := Hour[Count];
For Count := 1 to 24 Do
If Hour[Count] > 0 Then Begin
TempReal := (Hour[Count] / Highest * 100);
Hour[Count] := TempReal / 7 + 1;
End;
End;
Var
ShowMode : Byte;
Begin
If Graphics = 0 Then Begin
WriteLn ('|CRSorry, usage graphs require ANSI graphics|CR|CR|PA');
Exit;
End;
CalculateHistory;
If ParamCount > 0 Then Begin
Case Upper(ParamStr(1)) of
'MONTHLY' : DisplayMonthly;
'WEEKLY' : DisplayWeekly;
'HOURLY' : DisplayHourly;
Else
WriteLn ('USAGE.MPS: Invalid command line option.|PN');
End;
End Else Begin
ShowMode := 1;
Repeat
Case ShowMode of
1 : DisplayHourly;
2 : DisplayWeekly;
3 : DisplayMonthly;
End;
WriteXYPipe (22, 23, 7, 0, 'Press |08[|15TAB|08] |07for more or |08[|15ENTER|08] |07to Quit');
Case OneKey(#09 + #13 + #27, False) of
#09 : If ShowMode < 3 Then ShowMode := ShowMode + 1 Else ShowMode := 1;
#13,
#27 : Break;
End;
Until False;
End;
End