alphaman-src/CREALTER.BAS.txt
Jamie Bainbridge 01f7ee57e9 Initial commit
2021-04-04 15:15:18 +10:00

86 lines
3.1 KiB
Plaintext

' Copyright (c) 1995 Jeffrey R. Olson
'
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to deal
' in the Software without restriction, including without limitation the rights
' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
' copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in all
' copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
' SOFTWARE.
DECLARE SUB randum ()
DECLARE SUB modcreat (c$, cn$)
DEFINT A-Z
DIM SHARED att(5), btt(5), typ(5), str(5), tohit(5), rng(5)
DIM SHARED hd, mov, ac, sym, fc, defense, expr, creat$
OPEN "alpha.cre" FOR INPUT AS #1
OPEN "alphaman.2" FOR RANDOM AS #2 LEN = 50
OPEN "crelist" FOR OUTPUT AS #3
FIELD #2, 20 AS nam$, 2 AS a$, 2 AS b$, 2 AS c$, 2 AS d$, 2 AS e$, 2 AS a1$, 2 AS b1$, 2 AS a2$, 2 AS b2$, 2 AS a3$, 2 AS b3$, 2 AS a4$, 2 AS b4$, 2 AS a5$, 2 AS b5$
numcre = 0: CLS
crecount = 1
WHILE NOT EOF(1)
INPUT #1, creat$
PRINT #3, creat$; : crecount = crecount + 1
IF crecount = 5 THEN
crecount = 1: PRINT #3,
ELSE
PRINT #3, TAB(20 * (crecount - 1));
END IF
IF LEFT$(LTRIM$(creat$), 1) = CHR$(39) THEN GOTO fin
CALL modcreat(creat$, creatnew$)
LSET nam$ = creatnew$
numcre = numcre + 1: PRINT creat$; " ";
INPUT #1, a, defense, c, susc, expr
IF defense AND susc AND (1 + 2 + 4 + 8 + 16 + 32 + 64 + 512 + 1024) THEN
COLOR 12: PRINT "error?": COLOR 7
END IF
LSET a$ = MKI$(a): LSET b$ = MKI$(defense): LSET c$ = MKI$(c)
LSET d$ = MKI$(susc): LSET e$ = MKI$(expr)
FOR i = 1 TO 5: INPUT #1, att(i), btt(i): NEXT i
LSET a1$ = MKI$(att(1)): LSET b1$ = MKI$(btt(1))
LSET a2$ = MKI$(att(2)): LSET b2$ = MKI$(btt(2))
LSET a3$ = MKI$(att(3)): LSET b3$ = MKI$(btt(3))
LSET a4$ = MKI$(att(4)): LSET b4$ = MKI$(btt(4))
LSET a5$ = MKI$(att(5)): LSET b5$ = MKI$(btt(5))
PUT #2, numcre
hd = INT(a / 10) MOD 1000: mov = INT(a / 10000)
ac = a MOD 10
sym = c MOD 1000: fc = INT(c / 1000)
IF fc = 0 THEN bc = 1 ELSE bc = 0
FOR i = 1 TO 5
tohit(i) = att(i) MOD 100: str(i) = INT(att(i) / 100)
rng(i) = btt(i) MOD 100: typ(i) = INT(btt(i) / 100)
NEXT i
WEND
CLOSE
fin:
END
SUB modcreat (c$, cn$)
cn$ = SPACE$(20)
FOR k = 1 TO LEN(c$)
aa = ASC(MID$(c$, k, 1)): aa = aa XOR k * 6
MID$(cn$, k, 1) = CHR$(aa MOD 256)
NEXT
MID$(cn$, LEN(c$) + 1, 1) = CHR$(242)
FOR k = LEN(c$) + 2 TO 20
MID$(cn$, k, 1) = CHR$(INT(RND * 256))
NEXT
END SUB