'===========================================================================
' Subject: BBS DICE DOOR GAME                Date: Year of 1993           
' Author:  David Colston                     Code: QB, PDS                
' Origin:  FidoNet QUIK_BAS Echo           Packet: MODEM.ABC
'===========================================================================
'A local sysop wanted a door to roll dice for a dungeons and dragons
'game. I thought you might like to see it. Some of the code might look
'familar<g>. Not all of the fossil routines are used, but are offered
'for completeness.

DECLARE SUB Delay (X!)
DECLARE SUB CheckPortStatus (Port%, Info%, Reg AS ANY)
DECLARE SUB FossInit (Port%, Present%, Reg AS ANY)
DECLARE SUB GetChar (Port%, Good%, InBound$, Present%, Reg AS ANY)
DECLARE SUB PrintCon (A$, Reg AS ANY)
DECLARE SUB SendChar (Port%, Sent%, Present%, Outbound$, Reg AS ANY)
' $INCLUDE: 'QBX.BI'
' Include Data Types for IN
DEFINT A-Z
'$STATIC
DIM Reg AS RegType                ' Used for INTERRUPT calls
A# = TIMER + 120 'Allow only two minute in this door
					 'This saves us from constantly monitoring
					 'carrier detect.
ON TIMER(A#) GOSUB Quit
ON KEY(10) GOSUB Quit'Allow local bail out by sysop
TIMER ON
KEY(10) ON
Port = VAL(LTRIM$(RTRIM$(COMMAND$)))' Port =0 is port 1, etc.
Start:
DIM Rolls(1000)
FossInit Port, Present, Reg 'Find out if fossil is present or
					   'if we're just looking on a PC.
Bits = 8   'Defaults for almost all boards!
Stops = 1
Parity$ = "N"
SendChar Port, Sent, Present, CHR$(12), Reg 'Just in case they
														    
'have
X$ = CHR$(27) + "[2J   Dice Door 1.0 By David Colston (c) 1993"
X$ = X$ + CHR$(13) + CHR$(10)
'Send ansii clear screen and return; line feed
 
X$ = X$ + "   Enter your character name:"
FOR I = 1 TO LEN(X$)
	SendChar Port, Sent, Present, MID$(X$, I, 1), Reg
	PrintCon MID$(X$, I, 1), Reg'Echo to board consol.
NEXT
DO
	GetChar Port, Good, InBound$, Present, Reg
	IF Good THEN
	    IF InBound$ <> CHR$(13) THEN User$ = User$ + InBound$
	    SendChar Port, Sent, Present, InBound$, Reg
	    PrintCon InBound$, Reg
	END IF
LOOP UNTIL InBound$ = CHR$(13)
DiceSides:
X$ = CHR$(13) + CHR$(10) + "   Enter Number of Dice Sides:"
FOR I = 1 TO LEN(X$)
	SendChar Port, Sent, Present, MID$(X$, I, 1), Reg
	PrintCon MID$(X$, I, 1), Reg
NEXT
Sides$ = ""
DO
	GetChar Port, Good, InBound$, Present, Reg
	IF Good THEN
		IF INSTR(1, "1234567890", InBound$) > 0 THEN
			 Sides$ = Sides$ + InBound$
			 SendChar Port, Sent, Present, InBound$, Reg
		 END IF
		 PrintCon InBound$, Reg
	 END IF
LOOP UNTIL InBound$ = CHR$(13)
IF VAL(Sides$) < 2 OR VAL(Sides$) > 100 THEN GOTO DiceSides
Dice:
X$ = CHR$(13) + CHR$(10) + "   Enter Number of Dice      :"
FOR I = 1 TO LEN(X$)
	SendChar Port, Sent, Present, MID$(X$, I, 1), Reg
	PrintCon MID$(X$, I, 1), Reg
NEXT
Dice$ = ""
DO
	 GetChar Port, Good, InBound$, Present, Reg
	 IF Good THEN
		 IF INSTR(1, "1234567890", InBound$) > 0 THEN
			 Dice$ = Dice$ + InBound$
			 SendChar Port, Sent, Present, InBound$, Reg
		 END IF
		 PrintCon InBound$, Reg
	  END IF
LOOP UNTIL InBound$ = CHR$(13)
IF VAL(Dice$) < 2 OR VAL(Dice$) > 100 THEN GOTO Dice
Grey = FREEFILE
OPEN "Greyhawk.rol" FOR APPEND AS Grey' Output for game bulletin
PRINT #Grey, "On "; DATE$; " "; User$; " had the following roll."
PRINT #Grey, "# Dice = "; Dice$; " # Sides = "; Sides$
RANDOMIZE TIMER
TotalRoll = 0
FOR I = 1 TO VAL(Dice$)
    Roll = INT(RND(1) * VAL(Sides$)) + 1
    X$ = CHR$(13) + CHR$(10) + "   Die" + STR$(I) + " Showed" + STR$(Roll)
    TotalRoll = TotalRoll + Roll
    FOR J = 1 TO LEN(X$)
	   SendChar Port, Sent, Present, MID$(X$, J, 1), Reg
	   PrintCon MID$(X$, J, 1), Reg
    NEXT
    PRINT #Grey, RIGHT$(X$, LEN(X$) - 2)
NEXT
X$ = CHR$(13) + CHR$(10) + "   Total Rolled Was" + STR$(TotalRoll)
PRINT #Grey, RIGHT$(X$, LEN(X$) - 2)
PRINT #Grey, SPACE$(10)
FOR J = 1 TO LEN(X$)
	 SendChar Port, Sent, Present, MID$(X$, J, 1), Reg
	 PrintCon MID$(X$, J, 1), Reg
NEXT
SendChar Port, Sent, Present, CHR$(13), Reg
X$ = CHR$(13) + CHR$(10) + "  Press any key."
FOR J = 1 TO LEN(X$)
	 SendChar Port, Sent, Present, MID$(X$, J, 1), Reg
	 PrintCon MID$(X$, J, 1), Reg
NEXT
DO
	 GetChar Port, Good, InBound$, Present, Reg
	 IF Good THEN PrintCon InBound$, Reg
LOOP UNTIL Good

Quit:
END
 
'This door in not error trapped one of you guys might do better!

SUB CheckPortStatus (Port, Info, Reg AS RegType)
 
' ah = &H03     Fossil Function Number - Status
' al = &H00     Place Holder
' dx = Communications port number       (0-3)
Reg.dx = Port
Reg.ax = &H300
INTERRUPT &H14, Reg, Reg
 
IF (Reg.ax AND &H80) <> 0 THEN Info = (Info OR &H1)
' carrier detect present ?
IF (Reg.ax AND &H100) <> 0 THEN Info = (Info OR &H2)
' buffer has data?
IF (Reg.ax AND &H200) <> 0 THEN Info = (Info OR &H4)
' Was buffer overun?
IF (Reg.ax AND &H4000) = 0 THEN Info = (Info OR &H8)
' output buffer data ?
IF (Reg.ax AND &H2000) = 0 THEN Info = (Info OR &H10)
' Is output buffer overrun?
END SUB

SUB CtrlBreak (Port, Present)
SELECT CASE Port
	CASE 0
	address = &H3F8
	CASE 1
	address = &H2F8
	CASE 2
	address = &H3E8
	CASE ELSE
	address = &H2E8
END SELECT
Old1 = INP(address + 1)
OUT address + 1, 0
Old2 = INP(address + 3)
SetLow = Old2 OR &H40
A# = TIMER
OUT address + 3, SetLow
Delay .5
OUT address + 3, Old2 'Set it back the way it was!
OUT address + 1, Old1
END SUB

DEFSNG A-Z
SUB Delay (X!) STATIC
CheckTime! = TIMER
WHILE TIMER < CheckTime! + X!
WEND
END SUB

DEFINT A-Z
SUB ErrorMessage (A$, X) STATIC
A$ = ""
SELECT CASE X
 
   CASE 3
	  A$ = "Return with out GOSUB."
   CASE 4
   A$ = "Out of Data."
   CASE 5
			 A$ = "Illegal Function Call."
   CASE 6
			 A$ = "Math Overflow."
   CASE 7
			 A$ = "Out of Memory."
   CASE 9
			 A$ = "Subscript out of range."
   CASE 11
			 A$ = "Division by Zero."
   CASE 14
			 A$ = "Out of String Space."
   CASE 16
			 A$ = "String Formula Too Complex."
   CASE 19
			 A$ = "No RESUME."
   CASE 20
			 A$ = "RESUME without error."
   CASE 24
			 A$ = "Device TimeOut."
   CASE 25
			 A$ = "Device Fault."
   CASE 27
			 A$ = "Out of Paper."
   CASE 39
			 A$ = "Case Else Expected."
   CASE 40
			 A$ = "Variable Required."
   CASE 50
			 A$ = "Field OverFlow."
   CASE 51
			 A$ = "Internal Error."
   CASE 52
			 A$ = "Bad File Name or Number."
   CASE 53
			 A$ = "File Not Found."
   CASE 54
			 A$ = "Bad File Mode."
   CASE 55
			 A$ = "File Already Open."
   CASE 56
			 A$ = "Field Statement Active."
   CASE 57
			 A$ = "Device I/O Error."
   CASE 58
			 A$ = "File Already exists."
   CASE 59
			 A$ = "Bad Record Length."
   CASE 61
			 A$ = "Disk Full."
   CASE 62
			 A$ = "Input past end of file."
   CASE 63
			 A$ = "Bad Record Number."
   CASE 64
			 A$ = "Bad File Name."
   CASE 67
			 A$ = "Too many files."
   CASE 68
			 A$ = "Device Unavailable."
   CASE 69
			 A$ = "Communications Buffer OverFlow."
   CASE 70
			 A$ = "Access Denied."
   CASE 71
			 A$ = "Disk or Drive Not Ready."
   CASE 72
			 A$ = "Disk Media Error. (Bad Disk!)"
   CASE 75
			 A$ = "Path/File access error."
   CASE 76
			 A$ = "Path not Found."
   CASE ELSE
			 A$ = "Unknown Error #" + STR$(X)
 
END SELECT
 
END SUB

SUB FossDeinit (Port, Reg AS RegType)
' Release the FOSSIL device driver
Reg.ax = &H500
Reg.dx = Port
INTERRUPT &H14, Reg, Reg
END SUB

SUB FossInit (Port, Present, Reg AS RegType)
Present = -1
 
' Initialize the FOSSIL device driver
'
' dx = Communications port number (0-3)
' ah = &H04    Fossil Function Number - Initialize FOSSIL driver
'                                       (Raises DTR in the porcess)
 
Reg.dx = Port
Reg.ax = &H400
INTERRUPT &H14, Reg, Reg
IF Reg.ax <> &H1954 THEN
   Present = 0 'Fossil Not Found
END IF
 
END SUB

SUB GetChar (Port, Good, InBound$, Present, Reg AS RegType)
CheckPortStatus Port, Info, Reg ' Test for space in OUTPUT buffer
IF NOT Present THEN
			 InBound$ = INKEY$
			 IF InBound$ > "" THEN
				    Good = -1
			 ELSE
				    Good = 0
			 END IF
			 EXIT SUB
END IF
IF (Info AND &H4) = 0 THEN
	   IF (Info AND &H2) = &H2 THEN
			 Reg.ax = &H200
			 Reg.dx = Port
			 INTERRUPT &H14, Reg, Reg
			 InBound$ = CHR$(Reg.ax)
			 Good = -1
	   ELSE
			 Good = 0' No Characters in input buffer
			 InBound$ = INKEY$
			 IF InBound$ > "" THEN Good = -1
	   END IF
ELSE ' Input buffer over-run
	   Good = 0
	   Reg.ax = &HA00
	   Reg.dx = Port
	   INTERRUPT &H14, Reg, Reg
	   BEEP
END IF
END SUB

SUB PrintCon (A$, Reg AS RegType) STATIC
IF A$ = "" THEN EXIT SUB
	   Reg.ax = &H600
	   Reg.dx = ASC(A$)
	   INTERRUPT &H21, Reg, Reg
	   IF A$ = CHR$(13) THEN
			 Reg.ax = &H600
			 Reg.dx = 10
			 INTERRUPT &H21, Reg, Reg
	   END IF
END SUB

SUB SendChar (Port, Sent, Present, Outbound$, Reg AS RegType)
A! = TIMER
IF NOT Present THEN
	   Sent = 0
	   EXIT SUB
END IF
DO
	   CheckPortStatus Port, Info, Reg ' room in buffer ?
	   IF (Reg.ax AND &H80) = 0 THEN
			 Sent = -1
			 EXIT DO
	   END IF
    IF (Info AND &H10) = 0 THEN
		 Reg.dx = Port
		 Reg.ax = &H100 + ASC(Outbound$)
		 INTERRUPT &H14, Reg, Reg
		 Sent = -1
	   END IF
LOOP WHILE NOT Sent AND TIMER - A! < 2
IF Sent = 0 AND Reg.ax AND &H80 <> 0 THEN
    Sent = 0 ' Output buffer full
    Reg.ax = &H900
    Reg.dx = Port
    INTERRUPT &H14, Reg, Reg
END IF
END SUB

SUB SetDtr (Port, DtrStatus$, Reg AS RegType)
Reg.dx = Port 'Set carrier detect low or high
SELECT CASE UCASE$(DtrStatus$)
    CASE "L"
    Reg.ax = &H600
    CASE "H"
    Reg.ax = &H601
    CASE ELSE
    Reg.ax = &H600
    BEEP
END SELECT
INTERRUPT &H14, Reg, Reg
END SUB

SUB SetHandShake (Port, HandShake, Reg AS RegType)
Reg.dx = Port
IF HandShake > &HF THEN
    HandShake = &H2
    'Set handshake to RTS/CTS.
    BEEP
END IF
Reg.ax = &HF00 + HandShake
INTERRUPT &H14, Reg, Reg
Reg.ax = &H1000
Reg.dx = Port
INTERRUPT &H14, Reg, Reg
END SUB

SUB SetPortParams (Port, Baud$, Bits, Stops, Parity$, Reg AS RegType)
Reg.dx = Port
Reg.ax = 0
SELECT CASE Baud$
    CASE "300"
    Reg.ax = (Reg.ax OR &H40)
    CASE "600"
    Reg.ax = (Reg.ax OR &H60)
    CASE "1200"
    Reg.ax = (Reg.ax OR &H80)
    CASE "2400"
    Reg.ax = (Reg.ax OR &HA0)
    CASE "4800"
    Reg.ax = (Reg.ax OR &HC0)
    CASE "9600"
    Reg.ax = (Reg.ax OR &HE0)
    CASE "19200"
    Reg.ax = (Reg.ax OR &H0)
    CASE "38400"
    Reg.ax = (Reg.ax OR &H20)
    CASE ELSE
    Reg.ax = (Reg.ax OR &HA0)
    'Default to 2400 baud
END SELECT
 
SELECT CASE Bits
    CASE 5
    Reg.ax = (Reg.ax OR &H0)
    CASE 6
    Reg.ax = (Reg.ax OR &H1)
    CASE 7
    Reg.ax = (Reg.ax OR &H2)
    CASE 8
    Reg.ax = (Reg.ax OR &H3)
    CASE ELSE
    Reg.ax = (Reg.ax OR &H3)
    'Default to 8 bits
END SELECT
 
SELECT CASE Stops
    CASE 1
    Reg.ax = (Reg.ax OR &H0)
    CASE 2
    Reg.ax = (Reg.ax OR &H4)
    CASE ELSE
    Reg.ax = (Reg.ax OR &H0)
    'Default to 1 stop bit
END SELECT

SELECT CASE UCASE$(Parity$)
    CASE "N"
    Reg.ax = (Reg.ax OR &H0)
    CASE "O"
    Reg.ax = (Reg.ax OR &H8)
    CASE "E"
    Reg.ax = (Reg.ax OR &H18)
    CASE ELSE
    Reg.ax = (Reg.ax OR &H0)
    ' Default to no parity
END SELECT
Reg.dx = Port
INTERRUPT &H14, Reg, Reg   'Set it up!
END SUB