Some work, some don't. Some are finished, but old or of limited use. Some are unfinished, abandoned midway. Some were experiments or concepts, soon abandoned.
All of these programs are released into the public domain.
I have copied them from backups of my old hard disks, and from several floppy disks (back from the days when I programmed on a 486 with no hard drive.) I believe all of the ones I am posting now are my own work, but, as I saved other peoples' programs from these forums to my computers also, there is a tiny chance that not all are mine. I should recognize any such as I'm posting...
Regards,
Michael
P.S. I don't usually preserve whitespace when posting programs, but some of these programs were written with whitespace in string literals, so I will be converting spaces to nbsps as I post.
This message has been edited by MCalkins on Feb 23, 2011 2:15 AM This message has been edited by MCalkins on Feb 23, 2011 12:59 AM
DECLARE SUB timerl (tdly#)
DECLARE SUB cmp (ply%)
DECLARE SUB chk ()
DECLARE FUNCTION total% (ply%)
DECLARE FUNCTION vl% (n%)
DECLARE SUB hmn ()
DECLARE SUB deal ()
DECLARE SUB drwscr (n%)
DECLARE FUNCTION disp$ (n%)
DECLARE SUB game ()
DECLARE SUB shuffle ()
DECLARE SUB sads ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB c (cm%)
DIM SHARED mon$
DIM SHARED deck%(0 TO 51)
DIM SHARED dind%
DIM SHARED buff%(0 TO 51)
DIM SHARED bind%
DIM SHARED p%(0 TO 1, 0 TO 12)
DIM SHARED pind%(0 TO 1)
DIM SHARED bet%
DIM SHARED pmon%(0 TO 1)
DIM SHARED snd$
DIM SHARED gm%
DIM SHARED tally%
sads
RANDOMIZE TIMER
c 0
PRINT "Welcome to Black Jack."
gm$ = choice$("0 for human vs. comp. 1 for comp. vs. comp. (0/1)", "0", "1", CHR$(27), "", "", "", "", "", "", "")
IF gm$ = CHR$(27) THEN c 0: PRINT "Goodbye.": SYSTEM
gm% = VAL(gm$)
game
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
sadserr:
mon$ = "M"
RESUME NEXT
SUB c (cm%)
IF mon$ = "M" AND cm% > 0 THEN COLOR 7, 0: EXIT SUB
IF cm% < 0 OR cm% > 6 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 14, 1
CASE 2: COLOR 4, 7
CASE 3: COLOR 0, 7
CASE 4: COLOR 10, 0
CASE 5: COLOR 14, 0
CASE 6: COLOR 12, 0
END SELECT
END SUB
SUB chk
a% = ABS(total%(0))
b% = ABS(total%(1))
IF (a% < 22 AND a% > b%) OR (a% < 22 AND b% > 21) THEN cc% = 1
IF (b% < 22 AND b% > a%) OR (b% < 22 AND a% > 21) THEN cc% = -1
pmon%(0) = pmon%(0) + cc% * bet%
pmon%(1) = pmon%(1) + (0 - cc%) * bet%
drwscr 1
SELECT CASE cc%
CASE -1: c 4: LOCATE 1, 11: PRINT "Wins!"
c 6: LOCATE 7, 11: PRINT "Looses!"
IF snd$ = "Y" THEN PLAY "mbo1l8mlb-a-e-d-<l4mnb-"
CASE 0: c 5: LOCATE 1, 11: PRINT "Draw."
c 5: LOCATE 7, 11: PRINT "Draw."
IF snd$ = "Y" THEN PLAY "mbo1l8a.l16al4a."
CASE 1: c 4: LOCATE 7, 11: PRINT "Wins!"
c 6: LOCATE 1, 11: PRINT "Looses!"
IF snd$ = "Y" THEN PLAY "mbo2l8mlf+>c+f+g+>l4mnc+"
END SELECT
timerl 3
FOR i% = 0 TO pind%(0)
bind% = bind% + 1
buff%(bind%) = p%(0, i%)
NEXT i%
FOR i% = 0 TO pind%(1)
bind% = bind% + 1
buff%(bind%) = p%(1, i%)
NEXT i%
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
LOCATE CSRLIN, POS(0), 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE CSRLIN, POS(0), 0
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB cmp (ply%)
c 1
DO
timerl .5
key$ = INKEY$
SELECT CASE key$
CASE CHR$(27): c 0: PRINT "Thanks for playing Black Jack, a BASIC program by Michael Calkins.": SYSTEM
CASE "B", "b": LOCATE 16, 59: LINE INPUT "? "; a$
bet% = VAL(a$): CLS : drwscr ply%
CASE "S", "s"
IF snd$ = "Y" THEN
snd$ = "N"
ELSE
snd$ = "Y"
END IF
drwscr ply%
CASE "T", "t": tally% = 1 - tally%: LOCATE 2, 1: PRINT " ": LOCATE 6, 1: PRINT " ": drwscr 0
END SELECT
a% = total%(ply%)
IF a% < -18 OR a% > 15 THEN EXIT DO
pind%(ply%) = pind%(ply%) + 1
p%(ply%, pind%(ply%)) = deck%(0)
FOR i% = 0 TO dind% - 1
deck%(i%) = deck%(i% + 1)
NEXT i%
dind% = dind% - 1
drwscr ply%
IF snd$ = "Y" THEN PLAY "mbo1l32bl64b-."
IF total%(ply%) > 21 THEN
c 6: LOCATE 5 - (ply% * 2), 6 * pind%(ply%) + 7: PRINT "Over!"
IF snd$ = "Y" THEN PLAY "mbmll64o3d-cd-cd-cd-cd-cd-cd-cd-cd-cd-cd-cd-mnc"
EXIT SUB
END IF
LOOP
IF snd$ = "Y" THEN PLAY "mbo2l16f+l32a+.p4"
END SUB
SUB deal
p%(0, 0) = deck%(0)
p%(0, 1) = deck%(1)
p%(1, 0) = deck%(2)
p%(1, 1) = deck%(3)
FOR i% = 0 TO dind% - 4
deck%(i%) = deck%(i% + 4)
NEXT i%
dind% = dind% - 4
pind%(0) = 1
pind%(1) = 1
c 1: CLS
drwscr 0
END SUB
FUNCTION disp$ (n%)
SELECT CASE n% \ 13
CASE 0: a$ = "3"
CASE 1: a$ = "2"
CASE 2: a$ = "3"
CASE 3: a$ = "2"
END SELECT
b$ = a$
SELECT CASE n% MOD 13
CASE 0 TO 8: a$ = LTRIM$(STR$(n% MOD 13 + 2))
CASE 9: a$ = "J"
CASE 10: a$ = "Q"
CASE 11: a$ = "K"
CASE 12: a$ = "A"
END SELECT
disp$ = b$ + a$
END FUNCTION
SUB drwscr (n%)
c 1
LOCATE 1, 1: PRINT "Computer:"
LOCATE 1, 60: PRINT "$"; LTRIM$(STR$(pmon%(1))); SPACE$(80 - POS(0))
FOR i% = 0 TO pind%(1)
IF i% = 0 AND n% = 0 THEN
c 2: LOCATE 3, 1: PRINT " ";
ELSE
a$ = disp$(p%(1, i%))
c VAL(LEFT$(a$, 1)): LOCATE 3, i% * 6 + 1: PRINT " "; RIGHT$(a$, LEN(a$) - 1); " "; SPACE$(4 - LEN(a$));
END IF
NEXT i%
FOR i% = 0 TO pind%(0)
a$ = disp$(p%(0, i%))
c VAL(LEFT$(a$, 1)): LOCATE 5, i% * 6 + 1: PRINT " "; RIGHT$(a$, LEN(a$) - 1); " "; SPACE$(4 - LEN(a$));
NEXT i%
c 1
IF tally% = 1 THEN
IF n% = 1 THEN LOCATE 2, 1: PRINT ABS(total%(1))
LOCATE 6, 1: PRINT ABS(total%(0))
END IF
IF gm% = 0 THEN
LOCATE 7, 1: PRINT "Human:"
ELSE
LOCATE 7, 1: PRINT "Computer:"
END IF
LOCATE 7, 60: PRINT "$"; LTRIM$(STR$(pmon%(0))); SPACE$(80 - POS(0))
LOCATE 15, 51: PRINT "Bet: $"; LTRIM$(STR$(bet%)); SPACE$(80 - POS(0))
LOCATE 17, 51: PRINT "Sound: "; snd$
END SUB
SUB game
'IF mon$ = "C" THEN WIDTH 40
c 1: CLS
FOR i% = 0 TO 51
buff%(i%) = i%
NEXT i%
dind% = -1
bind% = 51
pind%(0) = -1
pind%(1) = -1
bet% = 1
pmon%(0) = 0
pmon%(1) = 0
snd$ = "Y"
tally% = 0
shuffle
DO
deal
IF dind% < 20 THEN shuffle
IF gm% = 0 THEN
hmn
ELSE
cmp 0
END IF
IF dind% < 20 THEN shuffle
drwscr 1
cmp 1
IF dind% < 20 THEN shuffle
chk
LOOP
END SUB
SUB hmn
c 1
WHILE INKEY$ <> "": WEND
LOCATE 22, 1: PRINT "'SPACE': hit, 'ENTER': stay, 'ESC': exit, 'B': set bet, 'S': toggle sound,"
PRINT "'T': toggle tally.";
DO
key$ = INKEY$
SELECT CASE key$
CASE " "
pind%(0) = pind%(0) + 1
p%(0, pind%(0)) = deck%(0)
FOR i% = 0 TO dind% - 1
deck%(i%) = deck%(i% + 1)
NEXT i%
dind% = dind% - 1
drwscr 0
IF snd$ = "Y" THEN PLAY "mbo1l32bl64b-."
IF total%(0) > 21 THEN
c 6: LOCATE 5, 6 * pind%(0) + 7: PRINT "Over!"
IF snd$ = "Y" THEN PLAY "mbmll64o3d-cd-cd-cd-cd-cd-cd-cd-cd-cd-cd-cd-mnc"
EXIT SUB
END IF
CASE CHR$(13): drwscr 1: EXIT DO
CASE CHR$(27): c 0: PRINT "Thanks for playing Black Jack, a BASIC program by Michael Calkins.": SYSTEM
CASE "B", "b": LOCATE 16, 59: LINE INPUT "? "; a$
bet% = VAL(a$): CLS : drwscr 0
CASE "S", "s"
IF snd$ = "Y" THEN
snd$ = "N"
ELSE
snd$ = "Y"
END IF
drwscr 0
CASE "T", "t": tally% = 1 - tally%: LOCATE 2, 1: PRINT " ": LOCATE 6, 1: PRINT " ": drwscr 0
END SELECT
LOOP
LOCATE 22, 1: PRINT " "
PRINT " ";
IF snd$ = "Y" THEN PLAY "mbo2l16f+l32a+.p4"
END SUB
SUB sads
mon$ = "C"
ON ERROR GOTO sadserr
SCREEN 1
ON ERROR GOTO term
IF mon$ = "C" THEN SCREEN 0: WIDTH 80
END SUB
SUB shuffle
c 1
LOCATE 24, 1: PRINT "Shuffling";
a1% = dind% + 1
a2% = a1% + bind%
FOR a% = a1% TO a2%
b% = INT(RND * (bind% + 1))
deck%(a%) = buff%(b%)
FOR cc% = b% TO bind% - 1
buff%(cc%) = buff%(cc% + 1)
NEXT cc%
dind% = dind% + 1
bind% = bind% - 1
NEXT a%
LOCATE 24, 1: PRINT " ";
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
FUNCTION total% (ply%)
FOR i% = 0 TO pind%(ply%)
a% = vl%(p%(ply%, i%))
b% = b% + a%
IF a% = 11 THEN cc% = cc% + 1
NEXT i%
DO
IF b% < 22 OR cc% = 0 THEN EXIT DO
b% = b% - 10
cc% = cc% - 1
LOOP
IF cc% > 0 THEN b% = 0 - b%
total% = b%
END FUNCTION
FUNCTION vl% (n%)
SELECT CASE n% MOD 13
CASE 0 TO 7: a% = n% MOD 13 + 2
CASE 8 TO 11: a% = 10
CASE 12: a% = 11
END SELECT
vl% = a%
END FUNCTION
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
' ON ERROR GOTO term
' $DYNAMIC
DIM SHARED nexis%
DIM SHARED nyear AS STRING * 4
DIM SHARED start%
DIM SHARED leap%
DIM SHARED path$
DIM SHARED ds%(1 TO 12)
TYPE tyear
day AS INTEGER
month AS INTEGER
date AS INTEGER
END TYPE
FOR i% = 1 TO 12
READ ds%(i%)
NEXT i%
ent$ = CHR$(&HD) + CHR$(&HA)
PRINT "Welcome to this calandar generater."
PRINT "1 - Create and print new calandar"
PRINT "2 - Print existing calandar"
a% = VAL(choice$("", "1", "2", "1", "1", "1", "1", "1", "1", "1", "1"))
INPUT "(4 didgets please) Year"; nyear
INPUT "Path of calandar file"; path$
IF a% = 2 THEN GOTO 1
leap$ = UCASE$(choice$("Is " + nyear + " a leap year", "Y", "N", "y", "n", "Y", "Y", "Y", "Y", "Y", "Y"))
leap% = 0
IF leap$ = "Y" THEN leap% = 1
PRINT "01-01-"; nyear; " falls on a"
PRINT "1-Su 2-Mo 3-Tu 4-We 5-Th 6-Fr 7-Sa"
start% = VAL(choice$("", "1", "2", "3", "4", "5", "6", "7", "1", "1", "1"))
DIM SHARED year(0 TO leap% + 365) AS tyear
IF leap% = 1 THEN ds%(2) = 30
x% = start%
y% = 1
z% = 1
OPEN path$ + "\cal-" + nyear + ".dat" FOR OUTPUT AS 1
PRINT #1, leap%
FOR w% = 1 TO 365 + leap%
year(w%).day = x%
year(w%).month = y%
year(w%).date = z%
x% = x% + 1
z% = z% + 1
IF x% = 8 THEN x% = 1
IF z% = ds%(y%) THEN z% = 1: y% = y% + 1
PRINT #1, year(w%).day; ","; year(w%).month; ","; year(w%).date
NEXT w%
CLOSE
1 IF a% = 2 THEN
OPEN path$ + "\cal-" + nyear + ".dat" FOR INPUT AS 1
LINE INPUT #1, leap$
leap% = VAL(leap$)
DIM SHARED year(0 TO leap% + 365) AS tyear
IF leap% = 1 THEN ds%(2) = 30
FOR w% = 1 TO 365 + leap%
INPUT #1, year(w%).day, year(w%).month, year(w%).date
NEXT w%
CLOSE
END IF
DIM SHARED mon$(1 TO 28)
DIM SHARED slot(1 TO 7 * 7) AS STRING * 2
LINE INPUT "Output file/device? "; out$
OPEN out$ FOR BINARY AS 1
FOR i% = 1 TO 12
SELECT CASE i%
CASE 1: m$ = "January": s% = 1
CASE 2: m$ = "February": s% = 32
CASE 3: m$ = "March": s% = 60 + leap%
CASE 4: m$ = "April": s% = 91 + leap%
CASE 5: m$ = "May": s% = 121 + leap%
CASE 6: m$ = "June": s% = 152 + leap%
CASE 7: m$ = "July": s% = 182 + leap%
CASE 8: m$ = "August": s% = 213 + leap%
CASE 9: m$ = "September": s% = 244 + leap%
CASE 10: m$ = "October": s% = 274 + leap%
CASE 11: m$ = "November": s% = 305 + leap%
CASE 12: m$ = "December": s% = 335 + leap%
END SELECT
mon$(2) = SPACE$(40 - (LEN(m$) + 5) \ 2) + m$ + " " + nyear
mon$(3) = " Sunday Monday Tuesday Wednesday Thursday Friday Saturday "
mon$(4) = "ÚÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄ¿"
FOR b% = 1 TO 49
slot(b%) = ""
NEXT b%
FOR b% = 1 TO ds%(i%) - 1
slot(b% + year(s%).day - 1) = LTRIM$(STR$(year(s% + b% - 1).date))
NEXT b%
c% = 1
FOR b% = 5 TO 23 STEP 3
mon$(b%) = "³" + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b%) = mon$(b%) + slot(c%) + " ³"
c% = c% + 1
mon$(b% + 1) = "³ ³ ³ ³ ³ ³ ³ ³"
mon$(b% + 2) = "ÃÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄ´"
NEXT b%
mon$(25) = "ÀÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÙ"
mon$(28) = ""
IF i% \ 2 = i% / 2 THEN mon$(28) = CHR$(12)
IF i% = 12 THEN mon$(26) = nyear + " Calandar (Starting day:" + STR$(year(1).day) + " Leap year:" + STR$(leap%) + ")": mon$(27) = "Generated by Mike's calandar generater. I hope you found this program useful."
FOR b% = 1 TO 28
PUT 1, , mon$(b%)
PUT 1, , ent$
NEXT b%
NEXT i%
CLOSE
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
DATA 32,29,32,31,32,31,32,32,31,32,31,32
REM $STATIC
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
' work with ln$
DECLARE SUB graph2d ()
DECLARE SUB geom ()
DECLARE SUB sad ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE SUB c (CM%)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED Monitor$
DIM SHARED SadMode%
DIM SHARED smono%
DIM SHARED SpH%
DIM SHARED SpO%
DIM SHARED SM%
DIM SHARED GoodEga%
DIM SHARED pi#
pi# = 4 * ATN(1) ' old: 3.141592654#
DIM SHARED letters$(1 TO 23)
FOR i% = 1 TO 23
READ letters$(i%)
NEXT i%
sad
mode$ = "Degrees"
DO
LOCATE 1, 1
b# = VAL(mem$)
PRINT "Memory:"; VAL(mem$); " Op: "; last$; " Trig function input: "; mode$; " "
PRINT
a# = VAL(dis$)
PRINT a#; " "
PRINT
PRINT "0 thru 9 = 0 thru 9"
PRINT ". = . + = + - = - * = ù / = ö = = = ^ = n1 ^ n2 \ = Int div"
PRINT "% = %"
PRINT "F1 = SIN(n)"
PRINT "F2 = COS(n)"
PRINT "F3 = TAN(n)"
PRINT "F4 = LOG(n)"
PRINT "F5 = eü"
PRINT "F6 = û"
PRINT "F7 = 1 ö n"
PRINT "F8 = +/-"
PRINT "F9 = Toggle between Dec and Rad."
PRINT "F10 = Goto speciel menu."
PRINT "PgUp = M+ PgDn = M- Home = RM End = CM C = C E = CE Esc = Off"
key$ = ""
WHILE key$ = ""
key$ = UCASE$(INKEY$)
WEND
IF key$ = "." OR key$ = "1" OR key$ = "2" OR key$ = "3" OR key$ = "4" OR key$ = "5" OR key$ = "6" OR key$ = "7" OR key$ = "8" OR key$ = "9" OR key$ = "0" THEN
IF clrit% = 2 THEN last$ = "": clrit% = 1
IF clrit% = 1 THEN ent$ = "": clrit% = 0
END IF
IF key$ = "+" OR key$ = "-" OR key$ = "*" OR key$ = "/" OR key$ = "\" OR key$ = "^" OR key$ = "%" THEN
IF lk$ <> "" THEN ent$ = ""
END IF
lk$ = ""
SELECT CASE key$
CASE CHR$(27):
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
CASE ".": ent$ = ent$ + ".": dis$ = ent$
CASE "0": ent$ = ent$ + "0": dis$ = ent$
CASE "1": ent$ = ent$ + "1": dis$ = ent$
CASE "2": ent$ = ent$ + "2": dis$ = ent$
CASE "3": ent$ = ent$ + "3": dis$ = ent$
CASE "4": ent$ = ent$ + "4": dis$ = ent$
CASE "5": ent$ = ent$ + "5": dis$ = ent$
CASE "6": ent$ = ent$ + "6": dis$ = ent$
CASE "7": ent$ = ent$ + "7": dis$ = ent$
CASE "8": ent$ = ent$ + "8": dis$ = ent$
CASE "9": ent$ = ent$ + "9": dis$ = ent$
CASE "=": GOSUB eql: clrit% = 2
CASE "+": GOSUB eql: last$ = "+": lk$ = " "
CASE "-": GOSUB eql: last$ = "-": lk$ = " "
CASE "*": GOSUB eql: last$ = "ù": lk$ = " "
CASE "/": GOSUB eql: last$ = "ö": lk$ = " "
CASE "\": GOSUB eql: last$ = "\": lk$ = " "
CASE "^": GOSUB eql: last$ = "ü": lk$ = " "
CASE "%": lk$ = ""
SELECT CASE last$
CASE "+": total$ = STR$(VAL(total$) + ((VAL(ent$) / 100) * VAL(total$)))
CASE "-": total$ = STR$(VAL(total$) - ((VAL(ent$) / 100) * VAL(total$)))
CASE "ù": total$ = STR$((VAL(ent$) / 100) * VAL(total$))
CASE "ö": total$ = STR$(VAL(total$) / ((VAL(ent$) / 100) * VAL(total$)))
CASE "\": total$ = STR$(VAL(total$) \ ((VAL(ent$) / 100) * VAL(total$)))
CASE "ü": total$ = STR$(VAL(total$) ^ ((VAL(ent$) / 100) * VAL(total$)))
CASE ELSE: total$ = "": dis$ = "": ent$ = ""
END SELECT
last$ = ""
dis$ = total$
clrit% = 1
ent$ = total$
CASE CHR$(0) + CHR$(59): clrit% = 1
SELECT CASE mode$
CASE "Degrees": ent$ = STR$(SIN(VAL(ent$) * (pi# / 180)))
CASE "Radians": ent$ = STR$(SIN(VAL(ent$)))
END SELECT
dis$ = ent$
CASE CHR$(0) + CHR$(60): clrit% = 1
SELECT CASE mode$
CASE "Degrees": ent$ = STR$(COS(VAL(ent$) * (pi# / 180)))
CASE "Radians": ent$ = STR$(COS(VAL(ent$)))
END SELECT
dis$ = ent$
CASE CHR$(0) + CHR$(61): clrit% = 1
SELECT CASE mode$
CASE "Degrees": ent$ = STR$(TAN(VAL(ent$) * (pi# / 180)))
CASE "Radians": ent$ = STR$(TAN(VAL(ent$)))
END SELECT
dis$ = ent$
CASE CHR$(0) + CHR$(62): clrit% = 1: ent$ = STR$(LOG(VAL(ent$))): dis$ = ent$
CASE CHR$(0) + CHR$(63): clrit% = 1: ent$ = STR$(EXP(VAL(ent$))): dis$ = ent$
CASE CHR$(0) + CHR$(64): clrit% = 1: ent$ = STR$(SQR(VAL(ent$))): dis$ = ent$
CASE CHR$(0) + CHR$(65): clrit% = 1: ent$ = STR$(1 / VAL(ent$)): dis$ = ent$
CASE CHR$(0) + CHR$(66): clrit% = 1: ent$ = STR$(0 - VAL(ent$)): dis$ = ent$
CASE CHR$(0) + CHR$(67):
SELECT CASE mode$
CASE "Degrees": mode$ = "Radians"
CASE "Radians": mode$ = "Degrees"
END SELECT
CASE CHR$(0) + CHR$(68): GOSUB menu
CASE "C": dis$ = "": ent$ = "": total$ = "": lk$ = "": clrit% = 0: last$ = "":
CASE "E": dis$ = total$: ent$ = "": lk$ = "": clrit% = 0
CASE CHR$(0) + CHR$(73): GOSUB eql: mem$ = STR$(VAL(mem$) + VAL(total$))
CASE CHR$(0) + CHR$(81): GOSUB eql: mem$ = STR$(VAL(mem$) - VAL(total$))
CASE CHR$(0) + CHR$(79): mem$ = ""
CASE CHR$(0) + CHR$(71): clrit% = 1: ent$ = mem$: dis$ = ent$
END SELECT
WHILE INKEY$ <> "": WEND
LOOP
eql:
'IF lk$ = "" THEN ent$ = ln$
SELECT CASE last$
CASE "+": total$ = STR$(VAL(total$) + VAL(ent$))
CASE "-": total$ = STR$(VAL(total$) - VAL(ent$))
CASE "ù": total$ = STR$(VAL(total$) * VAL(ent$))
CASE "ö": total$ = STR$(VAL(total$) / VAL(ent$))
CASE "\": total$ = STR$(VAL(total$) \ VAL(ent$))
CASE "ü": total$ = STR$(VAL(total$) ^ VAL(ent$))
CASE ELSE: total$ = ent$
END SELECT
dis$ = total$
clrit% = 1
lk$ = ""
ent$ = total$
RETURN
menu:
DO
c 0
PRINT "-----MENU-----"
PRINT "1 - 2D Graph. (Video card capable of graphics is req.)"
PRINT "2 - Geometry Fomula Runner."
PRINT "3 - Return to calculator."
menuop$ = choice$("", "1", "2", "3", "1", "1", "1", "1", "1", "1", "1")
c 0
SELECT CASE menuop$
CASE "1": graph2d
CASE "2": geom
CASE "3": RETURN
END SELECT
LOOP
term:
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
errsad:
SELECT CASE SadMode%
CASE 12: SadMode% = 13: RESUME
CASE 13: SadMode% = 9: RESUME
CASE 9: SadMode% = 1: RESUME
CASE 1: SadMode% = 0: RESUME NEXT
END SELECT
errsad2:
IF SM% = 4 THEN SpO% = 0
RESUME NEXT
errsad3:
IF SM% = 3 THEN SpH% = 0
RESUME NEXT
errsad4:
GoodEga% = 0
RESUME NEXT
DATA "A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W"
SUB c (CM%)
IF smono% = 1 AND CM% <> 0 AND CM% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND CM% = 4 THEN COLOR 2, 0: EXIT SUB
IF CM% < 0 OR CM% > 4 THEN EXIT SUB
SELECT CASE CM%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = CM%
END SUB
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
'c 3
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
'IF cp% > 0 THEN c cp%
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB geom
PRINT "Not availible yet."
SLEEP
WHILE INKEY$ <> "": WEND
END SUB
SUB graph2d
PRINT "Monitor: "; Monitor$
SELECT CASE Monitor$
CASE "Monochrome": PRINT "A video card capible of graphics is required. If you have a Hercules card,": PRINT "please load the Hercules driver 'MSHERC.COM'": SLEEP: WHILE INKEY$ <> "": WEND
CASE "VGA": sc% = 9
CASE "Monochrome (Hercules)": sc% = 3
CASE ELSE: sc% = 1
END SELECT
1
PRINT "1 - Load exising formula"
PRINT "2 - Create new formula"
PRINT "3 - Back"
wht$ = choice$("", "1", "2", "3", "1", "1", "1", "1", "1", "1", "1")
SELECT CASE wht$
CASE "1": LINE INPUT "Location? "; loc$
IF Exist%(loc$) = 0 THEN PRINT "File not found.": GOTO 1
CASE "2":
PRINT "In your formula, have 'x' = the x axis and 'y' = the y axis. Use 'a' thru 'w'"
PRINT "use 'a' thru 'w' as varibles."
PRINT "Examples: 'y = (x * a) + b', 'y = SIN(x) * a', and 'y = (x ^ 3) * a."
LINE INPUT "Formula? "; form$
LINE INPUT "How many varibles (besides 'x' and 'y') did you use? "; num$
num% = VAL(num$)
IF num% > 23 THEN num% = 23
2
LINE INPUT "Location to save to? "; loc$
IF Exist%(loc$) = 1 THEN
over$ = UCASE$(choice$("File exist. Overwrite", "Y", "y", "N", "n", "Y", "Y", "Y", "Y", "Y", "Y"))
IF over$ = "N" THEN GOTO 2
KILL loc$
END IF
LINE INPUT "('C:') Path of 'CALC.BAS'? "; pat$
IF pat$ = "" THEN pat$ = "C:"
c 0
OPEN loc$ FOR OUTPUT AS #1
PRINT #1, "' QBASIC program generated by 2D Graph in CALC.BAS at "; DATE$; " "; TIME$
PRINT #1, "' Formula: "; form$
PRINT #1, "' File: "; loc$
PRINT #1, "' Path of CALC.BAS: "; pat$
PRINT #1, "' Number of varibles to prompt for:"; num%
PRINT #1, "Print "; CHR$(34); form$; CHR$(34)
PRINT #1, "on error goto term"
IF num% > 0 THEN
FOR i% = 1 TO num%
PRINT #1, "Line input "; CHR$(34); "Value of '"; letters$(i%); "'? "; CHR$(34); "; "; letters$(i%); "$: "; letters$(i%); " = VAL("; letters$(i%); "$)"
NEXT i%
END IF
PRINT #1, "screen "; sc%
PRINT #1, "Line (100,0)-(100,200), 1"
PRINT #1, "Line (0,100)-(200,100), 1"
PRINT #1, "for x = -20 to 20 step .2"
PRINT #1, " "; form$
PRINT #1, " pset((x+20)*5,(y+20)*5)"
PRINT #1, "Next x"
PRINT #1, "sleep"
PRINT #1, "1 screen 0"
PRINT #1, "width 80,25"
PRINT #1, "while inkey$<>"; CHR$(34); CHR$(34); ":wend"
PRINT #1, "Run "; CHR$(34); pat$ + "\calc"; CHR$(34)
PRINT #1, "system"
PRINT #1, "term:"
PRINT #1, "print "; CHR$(34); "Error "; CHR$(34); "err"
PRINT #1, "sleep"
PRINT #1, "resume 1"
CLOSE
CASE "3": EXIT SUB
END SELECT
RUN loc$
END SUB
SUB sad
SadMode% = 12
ON ERROR GOTO errsad
SCREEN SadMode%
ON ERROR GOTO term
smono% = 0
SELECT CASE SadMode%
CASE 12: Monitor$ = "VGA"
CASE 13: Monitor$ = "MCGA"
CASE 9: Monitor$ = "EGA"
CASE 1: Monitor$ = "CGA"
CASE 0: Monitor$ = "Monochrome": smono% = 1
END SELECT
SpH% = 1
SpO% = 1
SM% = 4
ON ERROR GOTO errsad2
SCREEN SM%
ON ERROR GOTO term
SM% = 3
ON ERROR GOTO errsad3
SCREEN SM%
ON ERROR GOTO term
IF SpH% = 1 THEN Monitor$ = Monitor$ + " (Hercules)"
IF SpO% = 1 THEN Monitor$ = Monitor$ + " (Olivetti / AT&T)"
IF SadMode% = 9 THEN
GoodEga% = 1
ON ERROR GOTO errsad4
PALETTE 4, 0
ON ERROR GOTO term
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "> 64K " + Monitor$
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "<= 64K " + Monitor$
END IF
IF SadMode% <> 0 OR SM% <> 0 THEN SCREEN 0: WIDTH 80, 25
c 0
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
This message has been edited by MCalkins on Feb 23, 2011 1:11 AM
This program doesn't work. For a checkers program that actually runs, try Chk.
DECLARE SUB drwfld (hx%, hy%)
' add comments. debug, test.
' Tic Tac Toe, by Michael Calkins. This is a freeware computer game written in
' Beginer's All-Purpose Simbolic Intsruction Code (BASIC).
' To run the game from QBASIC, press "SHIFT" + "F5". To get help on how to use
' QBASIC, press "SHIFT" + "F1" from QBASIC.
' I have added remarks through out the program. They are preceded by single
' quote marks ('). Of course, not all of these necessarily indicate a remark.
' These are sub procedure and function declarations. Sub procedures are sections
' of the program that can be run from other parts of the program. To access
' these subs and functions from QBASIC, press "F2".
DECLARE FUNCTION dmfw2% (ply$, x%, y%)
DECLARE SUB help ()
DECLARE SUB timerl (tdly#)
DECLARE FUNCTION dmfw% (ply$, x%, y%)
DECLARE FUNCTION ifwin$ (hlt%)
DECLARE SUB getmove ()
DECLARE SUB gover ()
DECLARE SUB cmp ()
DECLARE SUB hmn ()
DECLARE SUB game (play$)
DECLARE SUB sads ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB c (cm%)
' These are shared variables. Unlike most variables, their values are shared
' with and can be changed by all parts of the program. They are usefull for
' letting different parts of the program communicate with each other.
DIM SHARED mon$
DIM SHARED fld(7, 7) AS STRING * 1
DIM SHARED bfld(3, 7) AS STRING * 1
DIM SHARED main%
DIM SHARED turn%
DIM SHARED sx%
DIM SHARED sy%
DIM SHARED who%
DIM SHARED de%
DIM SHARED loopcmp$
TYPE otype ' a user-defined data type.
x AS INTEGER
y AS INTEGER
END TYPE
DIM SHARED order(8) AS otype ' This is used only by "getmove".
RANDOMIZE TIMER
sads
IF mon$ = "M" THEN PRINT "This game requires an EGA or better graphics card.": SYSTEM
1 c 0
PRINT "Welcome to Checkers, a computer game written in BASIC."
PRINT "0 - Human vs. human"
PRINT "1 - Human vs. computer"
PRINT "2 - Computer vs. computer"
PRINT "3 or F1 - Help"
PRINT "4 or ESC - Exit"
play$ = choice$("Your choice is", "0", "1", "2", "3", CHR$(0) + CHR$(59), "4", CHR$(27), "", "", "")
IF play$ = "4" OR play$ = CHR$(27) THEN ' CHR$(27) is 'ESC'.
c 0
PRINT "Thanks for playing this game. Please report any errors to me (see Help)."
SYSTEM
END IF
IF play$ = "3" OR play$ = CHR$(0) + CHR$(59) THEN ' CHR$(0) + CHR$(59) is 'F1'.
help
GOTO 1
END IF
IF play$ = "1" THEN
who$ = choice$("(0 (black), 1 (red)) Which player will be the human", "0", "1", CHR$(27), "", "", "", "", "", "", "")
IF who$ = CHR$(27) THEN GOTO 1
who% = VAL(who$)
END IF
IF play$ <> "0" THEN c 0: GOTO 1
IF play$ = "2" THEN loopcmp$ = choice$("Loop game", "Y", "N", CHR$(27), "", "", "", "", "", "", "")
IF loopcmp$ = CHR$(27) THEN GOTO 1
game play$
GOTO 1
' error trapping subroutines. If an error occurs, whether expected or not,
' program flow will branch to one of these.
term: ' I use this one for unexpected errors. It displays the run-time error code and terminates the program. If this ever happens, please notify me.
PRINT "Error"; ERR; "after marker"; ERL
SYSTEM
sadserr:
mon$ = "M"
RESUME NEXT
' I use "sadserr" in my detection of the graphics card. An error will occur if
' the graphics card can not handle the CGA mode. If so, this subroutine will
' change the shared variable "mon$" to indicate so, after which, program flow
' resumes on the next line after the error (the use of the CGA screen mode).
' This sub changes the color to one of a set used in this game.
SUB c (cm%)
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS ' white, black; also clears screen
CASE 1: COLOR 7, 0 ' white, black
CASE 2: COLOR 15, 4 ' br white, red
CASE 3: COLOR 15, 1 ' br white, blue
CASE 4: COLOR 12, 0 ' br red, black
CASE 5: COLOR 9, 0 ' br blue, black
CASE ELSE: EXIT SUB
END SELECT
IF mon$ = "M" THEN ' if monocrome
COLOR 2, 0 ' white, black
IF cm% = 2 OR cm% = 3 THEN COLOR 9, 0 ' br white underlined, black
END IF
END SUB
' This function asks the user a question waits for the 1 key answer. "pr$" is
' the prompt or question. ("? " is added automaticly.) The other 10 parameters
' are the possible 1 key answers (usually 1 byte, but sometimes 2). To avoid
' case-sensitivity all of the parameters (except "pr$") and the keyboard input
' are made upper case. Any possible answer that equals "" is made a copy of
' "c1$". (Otherwise, the function would terminate immediatly with no keyboard
' input.) I use this function in many of my programs. Use it in yours if your
' want to.
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
WHILE INKEY$ <> "": WEND
c 1
IF mon$ = "C" THEN c 3
PRINT pr$; "? ";
LOCATE CSRLIN, POS(0), 1 ' displays the cursor.
DO ' this area will loop until desirable input is obtained.
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE CSRLIN, POS(0), 0 ' hides the cursor.
PRINT sl$
c 1
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
' This sub procedure makes the move chosen by "getmove".
SUB cmp
ply$ = "O": cl% = 2
IF turn% = 1 THEN ply$ = "X": cl% = 3
c cl%
getmove ' choses a move. The coordinates of the move are stored in the shared variables "sx%" and "sy%".
IF tmdly# > 0 THEN ' if there is a set time delay between choice and the making of the move (so you can have time to see), lights up sqaure and waits.
c cl%
LOCATE sy% * 2 + 1, sx% * 2 + 1
PRINT " "
timerl tmdly#
END IF
fld(sx%, sy%) = ply$ ' writes new move to playing field array.
c cl% + 2
LOCATE sy% * 2 + 1, sx% * 2 + 1
PRINT ply$ ' writes new move to screen.
c 1
END SUB
' This function counts how many winning moves are possible on the player's next
' move if the player makes a certain move; the enemy's move is not considered
' (unless it the player's 1st move and enemy's move were already made, and this
' sub is being used to test a previous move. Whatever the case, the rest of the
' program will use "dmfw%" in the way specifically needed for the situation.).
' If the number is MORE than 1, a player could force a win in 1 move. (The enemy
' can block one or the other, but not both.) "dmfw%" (which stands for "does
' move force win") is used by "getmove" and "dmfw2%" in evaluation of both a
' players and an enemy moves. It is also used by "hmn". The "ply$" parameter
' tells which player to evaluate for. If "ply$" has an extra byte, "dmfw%"
' supresses message displaying. "x%" and "y%" tell the coordinates to test as a
' first move.
FUNCTION dmfw% (ply$, x%, y%)
tmp$ = fld(x%, y%) ' That square is not necessarily blank.
fld(x%, y%) = RTRIM$(ply$) ' players 1st move
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN
fld(x1%, y1%) = RTRIM$(ply$) ' players second move, (enemy move not necessarily made yet.)
IF ifwin$(0) <> "" THEN pw% = pw% + 1
fld(x1%, y1%) = " "
END IF
NEXT y1%
NEXT x1%
fld(x%, y%) = tmp$
IF pw% > 1 AND LEN(ply$) = 1 THEN LOCATE 8, 1: PRINT "Player"; turn%; "("; ply$; ") will win in 1 move."; : c 1: PRINT " ": de% = 1
dmfw% = pw%
END FUNCTION
' This function determines if a move forces a win in 2 moves, returning 1 if
' yes, 0 if no. It is used by "getmove" and "hmn". The pararmeters serve the
' same purposes as those of "dmfw%".
FUNCTION dmfw2% (ply$, x%, y%)
hd% = LEN(ply$)
ply$ = RTRIM$(ply$)
SELECT CASE ply$
CASE "O": enm$ = "X"
CASE "X": enm$ = "O"
END SELECT
tmp$ = fld(x%, y%)
fld(x%, y%) = " "
' counts empty squares, etc.
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN cnt% = cnt% + 1
IF fld(x1%, y1%) = enm$ THEN ex% = x1%: ey% = y1%
IF fld(x1%, y1%) = ply$ THEN px% = x1%: py% = y1%
NEXT y1%
NEXT x1%
IF cnt% < 3 THEN fld(x%, y%) = tmp$: EXIT FUNCTION' If less than 3 squares remain, no "win in 2" can take place.
fld(x%, y%) = ply$ ' "ply$"'s move.
pw% = 0
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN
good% = 0
fld(x1%, y1%) = enm$ ' "enm$"'s move.
FOR x2% = 0 TO 2
FOR y2% = 0 TO 2
IF fld(x2%, y2%) = " " THEN
fld(x2%, y2%) = ply$ ' "ply$"'s next move.
' if, after next move, "enm$" can't win, and "ply$" can win on the move after next, then it's a good outcome.
IF dmfw%(enm$ + " ", x1%, y1%) = 0 AND dmfw%(ply$ + " ", x2%, y2%) = 2 THEN good% = 1
' if "ply$"'s next move is a win, then it's a good outcome.
IF ifwin$(0) <> "" THEN good% = 1
fld(x2%, y2%) = " "
END IF
NEXT y2%
NEXT x2%
fld(x1%, y1%) = " "
' if outcome is good, then count it.
pw% = pw% + good%
END IF
NEXT y1%
NEXT x1%
fld(x%, y%) = tmp$
' If count of good outcomes equals the number of empty spaces (after "ply$"'s move), the move "x%", "y%" forces a win in 2.
' If good outcomes = empty spaces (after move), that means that every "enm$" move resulted in eventual "ply$" victory.
IF pw% = cnt% - 1 THEN tmp% = 1
IF hd% = tmp% THEN LOCATE 8, 1: PRINT "Player"; turn%; "("; ply$; ") will win in 2 moves.": de% = 1
dmfw2% = tmp%
END FUNCTION
SUB drwfld (hx%, hy%)
FOR x% = 0 TO 7
FOR y% = 0 TO 7
IF x% MOD 2 <> y% MOD 2 THEN ' if black sqaure:
px% = 6 + x% * 20
py% = 6 + y% * 20
IF hx% = x% AND hy% = y% THEN
LINE (px%, py%)-(px% + 19, py% + 19), 14, B
ELSE
LINE (px%, py%)-(px% + 19, py% + 19), 0, B
END IF
IF fld(x%, y%) <> bfld(x% \ 2, y%) THEN ' if square has changed:
LINE (px% + 1, py% + 1)-(px% + 18, py% + 18), 0, BF
SELECT CASE UCASE$(fld(x%, y%))
CASE "R": CIRCLE (px% + 9, py% + 9), 8, 15: PAINT (px% + 9, py% + 9), 4, 15
CASE "B": CIRCLE (px% + 9, py% + 9), 8, 15: PAINT (px% + 9, py% + 9), 0, 15
END SELECT
IF UCASE$(fld(x%, y%)) = fld(x%, y%) AND fld(x%, y%) <> " " THEN ' if king:
' crown:
LINE (px% + 6, py% + 12)-(px% + 12, py% + 12), 15
LINE (px% + 6, py% + 10)-(px% + 6, py% + 11), 15
LINE (px% + 12, py% + 10)-(px% + 12, py% + 11), 15
PSET (px% + 5, py% + 9), 15: PSET (px% + 13, py% + 9), 15
LINE (px% + 7, py% + 9)-(px% + 9, py% + 7), 15
LINE (px% + 11, py% + 9)-(px% + 9, py% + 7), 15
LINE (px% + 9, py% + 6)-(px% + 9, py% + 4), 15
LINE (px% + 8, py% + 5)-(px% + 10, py% + 5), 15
PSET (px% + 9, py% + 9), 15
END IF
bfld(x% \ 2, y%) = fld(x%, y%)
END IF
END IF
NEXT y%
NEXT x%
END SUB
' This sub procedure draws the field lines and calls "cmp" and "hmn" in turn,
' depending on game type ("play$").
SUB game (play$)
7 main% = 0
' clears playing field array.
FOR a% = 0 TO 7
FOR B% = 0 TO 7
fld(a%, B%) = ""
IF a% < 4 THEN bfld(a%, B%) = "X"
NEXT B%
NEXT a%
SCREEN 7 ' uses EGA graphics mode
COLOR 14
LINE (0, 0)-(639, 479), 1, BF
LINE (2, 2)-(168, 168), 0, BF
LINE (4, 4)-(167, 167), 7, B
LINE (5, 5)-(166, 166), 0, B
LINE (6, 6)-(165, 165), 4, BF
drwfld -1, -1
a% = 3
FOR i% = 1 TO 8
LOCATE a%, 22: PRINT LTRIM$(STR$(i%))
a% = a% + (3 - i% MOD 2)
NEXT i%
DO ' This area loops until the individual game is done.
FOR turn% = 0 TO 1
SELECT CASE play$
CASE "0": hmn ' hmn vs. hmn.
CASE "1" ' hmn vs. cmp.
IF turn% = who% THEN
hmn
ELSE
cmp
END IF
CASE "2": cmp ' cmp vs. cmp.
END SELECT
gover ' determines if the game has ended.
' if so, and the game wasn't set to loop, then pause and goto main menu. If "ESC" was pressed, then goto main menu.
IF main% = 2 THEN CLS : WIDTH 80: EXIT SUB
IF (main% = 1 AND (play$ <> "2" OR loopcmp$ = "N")) THEN SLEEP: WHILE INKEY$ <> "": WEND: CLS : WIDTH 80: EXIT SUB
' if game is over, and game was set to loop:
IF main% = 1 THEN
main% = 0: timerl 1.5: CLS ' wait
IF main% = 2 THEN WIDTH 80: EXIT SUB ' if, during wait, "ESC" was pressed, goto main menu.
GOTO 7 ' start new game
END IF
NEXT turn%
LOOP
END SUB
' This sub procedure determines the computers moves. It is used by "cmp" and,
' for hints, by "hmn". The determined coordinates are stored in the shared
' variables "sx%" and "sy%".
SUB getmove
SELECT CASE turn% ' based on whose turn it is, identifies the player and enemy.
CASE 0: ply$ = "O": enm$ = "X"
CASE 1: ply$ = "X": enm$ = "O"
END SELECT
' counts empty squares, etc.
FOR x% = 0 TO 2
FOR y% = 0 TO 2
IF fld(x%, y%) = " " THEN cnt% = cnt% + 1 ' empty square counter.
IF fld(x%, y%) = enm$ THEN ex% = x%: ey% = y% ' stores the position of one of the enemy's moves.
IF fld(x%, y%) = ply$ THEN px% = x%: py% = y% ' stores the position of one of the player's moves.
NEXT y%
NEXT x%
' The following makes a list of the squares in a random order. The squares will be tested in that order. This is done so that the computers moves will have variety.
FOR i% = 0 TO 8: order(i%).x = -1: NEXT i% ' erases previous order.
FOR x% = 0 TO 2
FOR y% = 0 TO 2
IF fld(x%, y%) = " " THEN
8 i% = INT(RND * cnt%)
IF order(i%).x > -1 THEN GOTO 8 ' loops until a blank slot is found
order(i%).x = x%: order(i%).y = y%
END IF
NEXT y%
NEXT x%
IF cnt% > 7 THEN GOTO 4 ' a time saver.
sx1% = -1: sy1% = -1
' more time savers.
IF dmfw%(ply$ + " ", px%, py%) > 0 THEN skp% = 1 ' if a win is possible, look for nothing but it.
IF dmfw%(enm$ + " ", ex%, ey%) > 0 THEN skp1% = 1 ' if the enemy can win, look for nothing but the way to block it, unless, of course, a win is possible.
IF dmfw%(enm$ + " ", ex%, ey%) = 2 THEN GOTO 6 ' if an immediate defeat is unavoidible, chooses random.
FOR i% = 0 TO cnt% - 1
x% = order(i%).x
y% = order(i%).y
IF skp% = 1 THEN
' wins if can:
fld(x%, y%) = ply$
IF ifwin$(0) <> "" THEN fld(x%, y%) = " ": sx% = x%: sy% = y%: EXIT SUB
fld(x%, y%) = " "
ELSE ' if not:
IF skp1% = 1 THEN
' blocks enemy win if can:
fld(x%, y%) = enm$
IF ifwin$(0) <> "" THEN fld(x%, y%) = " ": sx1% = x%: sy1% = y%
fld(x%, y%) = " "
ELSE ' if not:
' forces win on next move if can:
fld(x%, y%) = ply$
IF dmfw%(enm$ + " ", ex%, ey%) = 0 THEN
fld(x%, y%) = " "
IF dmfw%(ply$, x%, y%) > 1 THEN sx% = x%: sy% = y%: EXIT SUB
END IF
fld(x%, y%) = " "
' forces a win in 2 if can:
fld(x%, y%) = ply$
IF dmfw%(enm$ + " ", ex%, ey%) = 0 THEN
fld(x%, y%) = " "
IF dmfw2%(ply$, x%, y%) = 1 THEN sx% = x%: sy% = y%: EXIT SUB
END IF
fld(x%, y%) = " "
END IF
END IF
NEXT i%
IF sx1% > -1 THEN
sx% = sx1%: sy% = sy1%
' displays appropriate message in case a blocked win is also a "win in ..."
fld(sx%, sy%) = ply$
IF dmfw%(enm$ + " ", ex%, ey%) = 0 THEN
fld(sx%, sy%) = " "
IF dmfw%(ply$, sx%, sy%) < 2 THEN ' displays message if "win in 1" is true.
junk% = dmfw2%(ply$, sx%, sy%) ' displays message if "win in 1" is false but "win in 2" is true.
END IF
END IF
fld(sx%, sy%) = " "
EXIT SUB
END IF
4 ' random move section
IF cnt% = 9 THEN GOTO 6 ' a time saver.
' blocks enemy's win in 1 or 2 if can.
FOR i% = 0 TO cnt% - 1
x% = order(i%).x
y% = order(i%).y
' blocks the enemy's win in 1.
IF fld(x%, y%) = " " THEN
fld(x%, y%) = ply$ ' player's move.
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN
fld(x1%, y1%) = enm$ ' enemy's move.
IF dmfw%(ply$ + " ", x%, y%) = 0 AND dmfw%(enm$ + " ", x1%, y1%) > 1 THEN fld(x%, y%) = " ": fld(x1%, y1%) = " ": GOTO 5
' if the player can not win on the next move and the enemy can win on his next move, then the player's move fails to block a "win in 1", so try a different move.
fld(x1%, y1%) = " "
END IF
NEXT y1%
NEXT x1%
fld(x%, y%) = " "
use% = 1: sx1% = x%: sy1% = y% ' this move is marked so that even if it fails to stop a win in 2, it can be used. (If you are gonna lose, might as well delay your defeat.)
' this part is reached only if a move passes the 'block a win in 1' test.
' blocks the enemy's win in 2. essentially the same principal as the previous test.
fld(x%, y%) = ply$ ' player's move
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN
fld(x1%, y1%) = enm$ ' enemy's move
IF dmfw%(ply$ + " ", x%, y%) = 0 AND dmfw2%(enm$ + " ", x1%, y1%) = 1 THEN fld(x%, y%) = " ": fld(x1%, y1%) = " ": GOTO 5
' if the player can not win on the next move and the enemy can win on his 2nd next move, then the player's move fails to block a "win in 2", so try a different move.
fld(x1%, y1%) = " "
END IF
NEXT y1%
NEXT x1%
fld(x%, y%) = " "
' this part is reached only if a move passes both tests.
sx% = x%: sy% = y%: EXIT SUB
END IF
5
NEXT i%
IF use% = 1 THEN sx% = sx1%: sy% = sy1%: EXIT SUB ' blocks a "win in 1" even if a "win in 2" is unavoidable.
6 ' completely random choice. used for the first move or for a situation where defeat on the next move or immediate defeat is unavoidible.
sx% = INT(RND * 3): sy% = INT(RND * 3)
IF fld(sx%, sy%) <> " " THEN GOTO 6
END SUB
' This subprocedure is used to determine if a game has ended. If so, it displays
' the appropriate message, and sets the shared variable "main%" to 1.
SUB gover
' $DYNAMIC
DIM bx%(1) ' arrays for storing first 2 empty squares.
DIM by%(1)
FOR x% = 0 TO 2
FOR y% = 0 TO 2
IF fld(x%, y%) = " " THEN
cnt% = cnt% + 1 ' counts empty squares.
IF cnt% < 3 THEN bx%(cnt% - 1) = x%: by%(cnt% - 1) = y% ' stores first two empty squares.
END IF
NEXT y%
NEXT x%
SELECT CASE first% ' based on who the first player was, identifies the first player and second player.
CASE 0: use$ = "O": enm$ = "X"
CASE 1: use$ = "X": enm$ = "O"
END SELECT
IF cnt% < 3 THEN dr% = 1 ' if less than 2 squares remain, temporarily assumes there is a draw.
IF cnt% = 2 THEN ' test for draw when 2 moves remain.
FOR i% = 0 TO 1
fld(bx%(i%), by%(i%)) = use$ ' 1st ply simulated on an empty square.
IF ifwin$(0) <> "" THEN dr% = 0 ' if 1st's move to an empty square is a win, cancel the assumption that a draw exists.
fld(bx%(1 - i%), by%(1 - i%)) = enm$ ' 2nd ply simulated on remaining square.
IF ifwin$(0) <> "" THEN dr% = 0 ' if 2nd's move to remaining square is a win, cancel the assumption that a draw exists.
fld(bx%(i%), by%(i%)) = " "
fld(bx%(1 - i%), by%(1 - i%)) = " "
NEXT i%
END IF
IF cnt% = 1 THEN ' test for draw when 1 move remains.
fld(bx%(0), by%(0)) = use$ ' the 1st player is simulated on the empty square.
IF ifwin$(0) <> "" THEN dr% = 0 ' if 1st's move to the empty square is a win, cancel the assumption that a draw exists.
fld(bx%(0), by%(0)) = " "
END IF
ERASE bx%
ERASE by%
IF dr% = 1 OR cnt% = 0 THEN s% = 1: cl% = 1: ms$ = "This game ended in a draw." ' if there are 1 or 2 empty squares and the assumption remains, a draw does indeed exist. If no empty squares remain, assume that a draw exists.
SELECT CASE ifwin$(1) ' if there is a win, select message. (overrides any draw assumption created in the previous line made because all the squares are full.)
CASE "O": s% = 1: cl% = 2: ms$ = "Player 0 (O) won!"
CASE "X": s% = 1: cl% = 3: ms$ = "Player 1 (X) won!"
END SELECT
IF s% = 1 THEN ' if game is over:
c 1: LOCATE 8, 1: PRINT SPACE$(40); ' clears any previous message.
c cl%: LOCATE 8, 1: PRINT ms$ ' displays selected message.
c 1
main% = 1 ' informs "game" that the game is over.
END IF
END SUB
REM $STATIC
' This is the help screen. It is run when you chose "Help" at the main menu.
SUB help
c 0
PRINT "Welcome to Tic Tac Toe, a computer game written in BASIC."
PRINT
PRINT " At the main menu, you have a choice of a human vs. human, human vs."
PRINT "computer player, or a computer vs. computer game. Player 0 is 'O' and player 1"
PRINT "is 'X'. In a human vs. computer game, you have the choice of which the human"
PRINT "will be. In each case, you have the choice of which player ('O' or 'X') goes"
PRINT "first."
PRINT " In the game, press 'ESC' at any time to return to the main menu. In a game";
PRINT "where humans play, the human can use the arrow keys to move the cursor. To get"
PRINT "a hint from the computer player, press 'H', and your cursor will move to the"
PRINT "recommended square. (Pressing 'H' repeatedly may help you see other options."
PRINT "Sometimes, when there is no particuler move obvious to the computer, the hint"
PRINT "will be as good as random (In which case, the repeated pressing of 'h' would"
PRINT "eventually show all availible squres. This ought to mean that each squre is just"
PRINT "as good as another.)) Press 'ENTER' to select a square. If a move forces"
PRINT "a win on the next move or second next move, a message will be displayed. The"
PRINT "'dmfw%' function evaluates 'win in 1's and the 'dmfw2%' function evaluates 'win";
PRINT "in 2's"
PRINT " The computer player has the following capabilites, in the order of"
PRINT "priority: winning, blocking an enemy win (unless it's hopeless), forcing a win"
PRINT "in 1, forcing a win in 2, blocking the enemy's forced win in 2 AND forced win"
PRINT
PRINT "--- More ---": SLEEP: WHILE INKEY$ <> "": WEND
PRINT
PRINT "in 1, and blocking enemy's forced win in 1. I think this almost makes the"
PRINT "computer player a virtual expert! I think this much is certain: if it can win,"
PRINT "it will. It will never lose. (Although if a human plays badly and then uses a"
PRINT "hint, the hint might not save him from defeat, but you can't blame that on the"
PRINT "computer player, can you? In such a situation, it should delay defeat as long"
PRINT "as possible. If the computer makes a real mistake, please inform me.)"
PRINT " It is interesting that in tic tac toe, if both players are experts and"
PRINT "play their best, the game will always end in a draw. That thakes the fun out"
PRINT "of tic tac toe, doesn't it?"
PRINT
PRINT "Written by:"
PRINT " Michael Calkins"
PRINT " 826 SH 97 E"
PRINT " Floresville TX 78114"
PRINT
PRINT " (830) 393-4866"
PRINT
PRINT " Thank you for playing this game. Please tell me about any mistakes. This"
PRINT "program is freeware. Fill free to use it as long as you like and to pass it on"
PRINT "to others. Also if you know the BASIC language, why not take a look at the"
PRINT "program? It is not copyrighted; copy out anything you want."
SLEEP: WHILE INKEY$ <> "": WEND
CLS
END SUB
' This sub procedure allows the human to choose his move and then makes that
' move.
SUB hmn
de% = 0
' selects correct symbol and color based on whose turn it is.
ply$ = "b": cl% = 2: enm$ = "r"
IF turn% = 1 THEN ply$ = "r": cl% = 3: enm$ = "b"
x% = 0
y% = 7
DO ' This area will loop until the human's turn is over because either "ESC" or "ENTER" was pressed.
drwfld x%, y%
key$ = INKEY$
IF key$ <> "" THEN
px% = x%
py% = y%
SELECT CASE key$
CASE CHR$(27): main% = 2: EXIT SUB ' sets the shared variable "main%" to 2, telling "game" to exit without delay. CHR$(27) is "ESC".
CASE CHR$(0) + CHR$(72): y% = y% - 1 ' up
CASE CHR$(0) + CHR$(75): x% = x% - 1 ' left
CASE CHR$(0) + CHR$(77): x% = x% + 1 ' right
CASE CHR$(0) + CHR$(80): y% = y% + 1 ' down
CASE "H", "h": LOCATE py% * 2 + 1, px% * 2 + 1
SELECT CASE fld(px%, py%) ' choses color based on character. To erase the cursor, the character is drawn over it with normal colors.
CASE " ": c 1
CASE "O": c 4
CASE "X": c 5
END SELECT
' erases cursor and uses "getmove" to obtain the hint.
PRINT fld(px%, py%): c cl%: getmove: x% = sx%: y% = sy%: de% = 1
CASE CHR$(13) ' "ENTER"
IF fld(x%, y%) = " " THEN ' you can choose a square only if it is blank.
fld(x%, y%) = ply$ ' makes move.
c cl% + 2
LOCATE y% * 2 + 1, x% * 2 + 1
PRINT ply$ ' draws move.
c cl%
' Erases the current player's previous move's "will win" message (if there
' is one). In case the human makes a mistake, the message won't stay. If
' the human plays good, another will be displayed.
' If [your choice doesn't match the hint OR no hint was given] AND the message was with regard to the current player, then erase the message.
IF (x% <> sx% OR y% <> sy% OR de% = 0) AND CHR$(SCREEN(8, 11)) = ply$ THEN c 1: LOCATE 8, 1: PRINT SPACE$(40);
' checks if the enemy can win immediatly (i.e., on his next move):
FOR x1% = 0 TO 2
FOR y1% = 0 TO 2
IF fld(x1%, y1%) = " " THEN
fld(x1%, y1%) = enm$
IF ifwin$(0) <> "" THEN dd% = 1 ' counts a possible enemy win regardless of whether it can be blocked or not.
fld(x1%, y1%) = " "
END IF
NEXT y1%
NEXT x1%
' checks for forced win. If there is one, an appropriate message will be displayed.
IF dd% = 0 THEN ' If the enemy can't win immediatly, then:
IF ifwin$(0) = "" THEN ' If the player didn't win, then:
IF dmfw%(ply$, x%, y%) < 2 THEN ' Tests for "win in 1".
junk% = dmfw2%(ply$, x%, y%) ' If there is no "win in 1", tests for a "win in 2".
END IF
END IF
END IF
c 1
EXIT SUB
END IF
END SELECT
' If the new cursor is moved off the board, place it on the opposite side. (e.g., the cursor moves off the left side, it appears on the right side.)
IF x% < 0 THEN x% = 2
IF x% > 2 THEN x% = 0
IF y% < 0 THEN y% = 2
IF y% > 2 THEN y% = 0
LOCATE py% * 2 + 1, px% * 2 + 1
SELECT CASE fld(px%, py%) ' the same process as described for erasing the cursor if a hint is requested
CASE " ": c 1
CASE "O": c 4
CASE "X": c 5
END SELECT
PRINT fld(px%, py%) ' erases the cursor from the old square.
c cl%
LOCATE y% * 2 + 1, x% * 2 + 1
PRINT fld(x%, y%) ' draws it on the new square.
END IF
LOOP
END SUB
' This function determines whether a board situation is a victory for a player.
' It is used by the "gover" sub to determine if the game is over, beacuse of a
' victory, and if so display a message. It is used by the "getmove" sub and the
' "dmfw%" function in evaluating possible moves. (The "fld" array, the array
' that stores the playing field, is temporarily changed, and "ifwin$" is called
' to determine if the hypothetical situation is a victory for either side.) The
' "hlt%" parameter enables or disables highlighting of the winning squares. 1 is
' enabled, 0 is disabled. Only 1 line in "gover" calls "ifwin$" with "hlt%"
' equaling 1. (It wouldn't be a good idea to enable highlighting when
' evaluating.) "Ifwin$" returns "O" if "O" won, "X" if "X" won, and "" if nobody
' won.
FUNCTION ifwin$ (hlt%)
' $DYNAMIC
s$ = ""
DIM bx%(2) ' these arrays store the coordinates of the winning squares so that they can be highlighted.
DIM by%(2)
FOR x% = 0 TO 2 ' tests for a win along the verticle axis
IF fld(x%, 0) = fld(x%, 1) AND fld(x%, 0) = fld(x%, 2) AND fld(x%, 0) <> " " THEN s$ = fld(x%, 0): bx%(0) = x%: bx%(1) = x%: bx%(2) = x%: by%(0) = 0: by%(1) = 1: by%(2) = 2
NEXT x%
FOR y% = 0 TO 2 ' tests for a win along the horizontal axis
IF fld(0, y%) = fld(1, y%) AND fld(0, y%) = fld(2, y%) AND fld(0, y%) <> " " THEN s$ = fld(0, y%): bx%(0) = 0: bx%(1) = 1: bx%(2) = 2: by%(0) = y%: by%(1) = y%: by%(2) = y%
NEXT y%
' tests for a win along the diagonals
IF fld(0, 0) = fld(1, 1) AND fld(0, 0) = fld(2, 2) AND fld(0, 0) <> " " THEN s$ = fld(0, 0): bx%(0) = 0: bx%(1) = 1: bx%(2) = 2: by%(0) = 0: by%(1) = 1: by%(2) = 2
IF fld(2, 0) = fld(1, 1) AND fld(2, 0) = fld(0, 2) AND fld(2, 0) <> " " THEN s$ = fld(2, 0): bx%(0) = 2: bx%(1) = 1: bx%(2) = 0: by%(0) = 0: by%(1) = 1: by%(2) = 2
IF hlt% = 1 AND s$ <> "" THEN
SELECT CASE s$
CASE "O": c 2
CASE "X": c 3
END SELECT
FOR i% = 0 TO 2
LOCATE by%(i%) * 2 + 1, bx%(i%) * 2 + 1
PRINT s$ ' redraws the sqaures using the cursor colors for highlighting
NEXT i%
END IF
ERASE bx%
ERASE by%
ifwin$ = s$
END FUNCTION
REM $STATIC
' A simple test to determine if the graphics card can handle an EGA graphics
' mode. If so, my program assumes that the monitor is color. The program uses
' this knoledge in its choice of color sets (see the "c" sub procedure), and in
' setting the width of the screen, in characters per line, for game play.
SUB sads
mon$ = "E"
ON ERROR GOTO sadserr
SCREEN 7 ' trys to change the graphics mode. If it can't, an error will result, and the "sadserror" subroutine will run, changing the shared variable "mon$".
ON ERROR GOTO 0'term
IF mon$ = "E" THEN SCREEN 0: WIDTH 80 ' If the mode was changed, this changes it back to the normal text mode.
END SUB
' This sub procedure is a simple time delay. the "tdly#" parameter specifies the
' number of seconds to wait. In some situations, this is better than the "SLEEP"
' statement because decimal intervals are allowed.
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO ' if the elapsed interval is greater or equal to the desired delay, then exit the loop.
key$ = INKEY$
IF key$ = CHR$(27) THEN main% = 2 ' If "ESC" is pressed, "timerl" terminates after changing the shared variable "main%" to 2 so that "game" go to the main menu without delay.
IF key$ <> "" THEN EXIT DO ' If any other key is pressed, "timerl" terminates.
LOOP
END SUB
Checkers game with computer game engine. I don't remember how well the computer player plays. Moves are entered as 4 digits: the starting x, the starting y, the ending x, the ending y, with 00 being the bottom left. So, for example "0213" is a valid first move.
This program is public domain.
DECLARE FUNCTION numleg% (ply%)
DECLARE SUB cmp (ply%)
DECLARE FUNCTION eval& (bd%, ply%)
DECLARE SUB expi (bd%, pt%, m%, xl%, xc%, x%)
DECLARE FUNCTION mj% (ply%, bd%)
DECLARE FUNCTION legal% (ply%, bd%, m$, m%)
DECLARE SUB quit (v%)
DECLARE SUB mv (m$, bd%)
DECLARE SUB hmn (ply%)
DECLARE FUNCTION gover% (bd%, ply%)
DECLARE SUB graph (act%, img%, x%, y%)
DECLARE SUB inigrph ()
DECLARE SUB dwf (bd%)
DIM SHARED leg% 'legal
DIM SHARED tar% 'tar depth
DIM SHARED mtar%
mtar% = 10
DIM SHARED fld(0 TO 2 + mtar%, 0 TO 7, 0 TO 7) AS STRING * 1
TYPE pst
xl AS INTEGER
xc AS INTEGER
x AS INTEGER
lib AS INTEGER
dep AS INTEGER
END TYPE
DIM SHARED psn(0 TO 1, 0 TO mtar% - 1) AS pst
DIM SHARED sco&(0 TO 1, 0 TO mtar% - 1)
TYPE blt
xl AS INTEGER
xc AS INTEGER
x AS INTEGER
END TYPE
DIM SHARED bl(0 TO mtar% - 1, 0 TO mtar% - 1) AS blt
DIM SHARED at&(0 TO mtar% - 1)
DIM SHARED cdp% 'cur depth
DIM SHARED des%
DIM SHARED pi#
pi# = 4 * ATN(1)
DIM SHARED images%
images% = 6
DIM SHARED mode%
DIM SHARED bx%
DIM SHARED aply%
DIM SHARED res%
DIM SHARED pe&
DIM SHARED dbk%
DIM SHARED drk%
DIM SHARED db%
DIM SHARED dr%
DIM SHARED pls$(0 TO 1)
pls$(0) = "B"
pls$(1) = "R"
'DIM SHARED tr%(0 TO mtar% - 1)
mode% = 12
SELECT CASE mode%
'CASE 1: SCREEN 1: bpppp% = 2: plns% = 1: hr% = 320: bx% = 16
CASE 7: SCREEN 7: bpppp% = 1: plns% = 4: hr% = 320: bx% = 16
CASE 12: SCREEN 12: bpppp% = 1: plns% = 4: hr% = 640: bx% = 32
END SELECT
DIM SHARED size%
size% = 4 + INT((bx% * bpppp% + 7) / 8) * plns% * bx%
DIM SHARED graphics%(0 TO size% * images% - 1)
inigrph
COLOR 7
FOR l% = 0 TO 7
FOR c% = 0 TO 7
fld(0, l%, c%) = " "
IF (c% + (l% MOD 2)) MOD 2 > 0 THEN
IF l% < 3 THEN
fld(0, l%, c%) = "r"
END IF
IF l% > 4 THEN
fld(0, l%, c%) = "b"
END IF
END IF
NEXT c%
NEXT l%
des% = 0
db% = des%
dr% = 7 - des%
dbk% = 5
drk% = 2
turn% = 0
tar% = 4
DO
'IF turn% < 50 THEN tar% = 5
'IF turn% < 40 THEN tar% = 3
'IF tar% > mtar% THEN tar% = mtar%
dwf 0
'SLEEP 1
won% = gover%(0, turn% MOD 2)
IF won% > -1 THEN EXIT DO
leg% = numleg%(turn% MOD 2)
SELECT CASE turn% MOD 2
CASE 0
SELECT CASE 0
CASE 0: hmn turn% MOD 2
CASE 1: cmp turn% MOD 2
END SELECT
CASE 1
SELECT CASE 1
CASE 0: hmn turn% MOD 2
CASE 1: cmp turn% MOD 2
END SELECT
END SELECT
turn% = turn% + 1
LOOP
quit won%
SUB cmp (ply%)
SELECT CASE ply%
CASE 0: p$ = "Black"
CASE 1: p$ = " Red"
END SELECT
LOCATE 21, 1: PRINT SPACE$(80);
LOCATE 21, 1: PRINT p$; ":"; TAB(40); "Legal moves:"; leg%;
colm% = POS(0)
FOR i% = 1 TO (mtar% \ 2) + 1
LOCATE i%, 40
PRINT SPACE$(40);
NEXT i%
pe& = 0
aply% = ply%
FOR a% = 0 TO 1
FOR b% = 0 TO tar% - 1
psn(a%, b%).xl = 0
psn(a%, b%).xc = 0
psn(a%, b%).x = 0
psn(a%, b%).lib = 0
psn(a%, b%).dep = 0
sco&(a%, b%) = -1000
'tr%(b%) = 0
NEXT b%
NEXT a%
cdp% = 0
res% = 0
sam% = 0
4
pt% = ply% + cdp%
bd% = 2 + cdp%
IF sam% = 0 THEN
sc% = bd% - 1
IF sc% = 1 THEN sc% = 0
FOR l% = 0 TO 7 'reset brd
FOR c% = 0 TO 7
fld(bd%, l%, c%) = fld(sc%, l%, c%)
NEXT c%
NEXT l%
m% = mj%(pt% MOD 2, bd%): sam% = 1
IF res% = 1 THEN
res% = 0
GOTO 7
END IF
res% = 0
END IF
IF UCASE$(fld(bd%, psn(0, cdp%).xl, psn(0, cdp%).xc)) = pls$(pt% MOD 2) THEN
IF m% = 0 THEN psn(0, cdp%).x = 4
DO
expi bd%, pt%, m%, psn(0, cdp%).xl, psn(0, cdp%).xc, psn(0, cdp%).x
IF res% > 0 THEN
IF leg% > 1 THEN
sam% = 0: GOTO 4
ELSE
GOTO 8
END IF
END IF
7 psn(0, cdp%).x = psn(0, cdp%).x + 1
IF psn(0, cdp%).x > 7 THEN psn(0, cdp%).x = 0: EXIT DO
LOOP
END IF
k$ = INKEY$
IF k$ = CHR$(27) THEN
LOCATE 22, 30:
INPUT "Q"; c$
IF c$ = "y" OR c$ = "Y" THEN
quit -1
ELSE
k$ = ""
END IF
LOCATE 22, 30: PRINT SPACE$(10)
END IF
IF k$ <> "" THEN
LOCATE 22, 30:
INPUT f$
WHILE INKEY$ <> "": WEND
IF f$ <> "" THEN
ftr% = VAL(f$)
IF ftr% > mtar% THEN ftr% = mtar%
IF ftr% < 2 THEN ftr% = 0: GOTO 5
END IF
LOCATE 22, 30: PRINT SPACE$(10)
END IF
psn(0, cdp%).xc = psn(0, cdp%).xc + 1
IF psn(0, cdp%).xc > 7 THEN psn(0, cdp%).xc = 0: psn(0, cdp%).xl = psn(0, cdp%).xl + 1
IF psn(0, cdp%).xl > 7 THEN
sam% = 0
IF psn(0, cdp%).lib = 0 AND cdp% < tar% - 1 THEN
sco&(0, cdp%) = eval&(bd%, pt% MOD 2)
'q% = 0
'IF sco&(1, cdp%) = sco&(0, cdp%) OR ABS(sco&(0, cdp%) > 99999) THEN
' IF sco&(0, cdp%) > 0 THEN
' q% = psn(1, cdp%).dep - cdp%
' ELSE
' q% = cdp% - psn(1, cdp%).dep
' END IF
'END IF 'took out from 'if'
IF sco&(1, cdp%) = -1000 OR ((cdp% MOD 2) = 0 AND sco&(0, cdp%) > sco&(1, cdp%)) OR ((cdp% MOD 2) = 1 AND sco&(0, cdp%) < sco&(1, cdp%)) THEN
sco&(1, cdp%) = sco&(0, cdp%)
psn(1, cdp%).xl = psn(0, cdp%).xl
psn(1, cdp%).xc = psn(0, cdp%).xc
psn(1, cdp%).x = psn(0, cdp%).x
psn(1, cdp%).dep = cdp%
' unnecessary?
'FOR z% = cdp% + 1 TO tar% - 1
' psn(1, z%).xl = 0
' psn(1, z%).xc = 0
' psn(1, z%).x = 0
' psn(1, z%).dep = 0
' sco&(1, z%) = -1000
'NEXT z%
FOR i% = 0 TO cdp%
bl(cdp%, i%).xl = psn(0, i%).xl
bl(cdp%, i%).xc = psn(0, i%).xc
bl(cdp%, i%).x = psn(0, i%).x
NEXT i%
' need reset >cdp% ?
at&(cdp%) = pe&
END IF
END IF
IF cdp% = 0 THEN GOTO 5
IF cdp% = 1 THEN
me% = me% + 1: LOCATE 21, colm%: PRINT "("; me%; "examined)"
END IF
'q% = 0
' doesn't allow for wise enemy move.
'IF sco&(1, cdp% - 1) = sco&(1, cdp%) OR ABS(sco&(1, cdp%) > 99999) THEN
' IF sco&(1, cdp%) > 0 THEN
' q% = psn(1, cdp% - 1).dep - psn(1, cdp%).dep
' ELSE
' q% = psn(1, cdp%).dep - psn(1, cdp% - 1).dep
' END IF
'END IF
IF sco&(1, cdp% - 1) = -1000 OR ((cdp% MOD 2) = 0 AND sco&(1, cdp%) < sco&(1, cdp% - 1)) OR ((cdp% MOD 2) = 1 AND sco&(1, cdp%) > sco&(1, cdp% - 1)) THEN
sco&(1, cdp% - 1) = sco&(1, cdp%)
psn(1, cdp% - 1).xl = psn(0, cdp% - 1).xl
psn(1, cdp% - 1).xc = psn(0, cdp% - 1).xc
psn(1, cdp% - 1).x = psn(0, cdp% - 1).x
psn(1, cdp% - 1).dep = psn(1, cdp%).dep
sco&(1, cdp%) = -1000
FOR i% = 0 TO psn(1, cdp%).dep
bl(cdp% - 1, i%).xl = bl(cdp%, i%).xl
bl(cdp% - 1, i%).xc = bl(cdp%, i%).xc
bl(cdp% - 1, i%).x = bl(cdp%, i%).x
NEXT i%
at&(cdp% - 1) = at&(cdp%)
IF cdp% = 1 THEN
8 FOR i% = 1 TO (mtar% \ 2) + 1
LOCATE i%, 40
PRINT SPACE$(40);
NEXT i%
LOCATE 1, 40: PRINT "best by"; pe&; "@"; at&(0); ":"; sco&(1, 0); SPACE$(10)
FOR i% = 0 TO psn(1, 0).dep
oc% = (ply% + i%) MOD 2
ol% = (ply% + i%) \ 2
LOCATE 2 + ol%, 40 + oc% * 6
SELECT CASE bl(0, i%).x
CASE 0: xxl% = bl(0, i%).xl - 2: xxc% = bl(0, i%).xc - 2
CASE 1: xxl% = bl(0, i%).xl + 2: xxc% = bl(0, i%).xc - 2
CASE 2: xxl% = bl(0, i%).xl - 2: xxc% = bl(0, i%).xc + 2
CASE 3: xxl% = bl(0, i%).xl + 2: xxc% = bl(0, i%).xc + 2
CASE 4: xxl% = bl(0, i%).xl - 1: xxc% = bl(0, i%).xc - 1
CASE 5: xxl% = bl(0, i%).xl + 1: xxc% = bl(0, i%).xc - 1
CASE 6: xxl% = bl(0, i%).xl - 1: xxc% = bl(0, i%).xc + 1
CASE 7: xxl% = bl(0, i%).xl + 1: xxc% = bl(0, i%).xc + 1
END SELECT
m$ = LTRIM$(STR$(bl(0, i%).xc)) + LTRIM$(STR$(7 - bl(0, i%).xl)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
PRINT m$
NEXT i%
IF leg% = 1 THEN GOTO 5
END IF
END IF
psn(0, cdp%).xl = 0
psn(0, cdp%).xc = 0
psn(0, cdp%).x = 0
psn(0, cdp%).dep = 0
sco&(0, cdp%) = -1000
sco&(1, cdp%) = -1000
'tr%(cdp%) = 0
cdp% = cdp% - 1
sam% = 0
res% = 1
'done with segment of branch
END IF
GOTO 4
5 'done
SELECT CASE psn(1, 0).x
CASE 0: xxl% = psn(1, 0).xl - 2: xxc% = psn(1, 0).xc - 2
CASE 1: xxl% = psn(1, 0).xl + 2: xxc% = psn(1, 0).xc - 2
CASE 2: xxl% = psn(1, 0).xl - 2: xxc% = psn(1, 0).xc + 2
CASE 3: xxl% = psn(1, 0).xl + 2: xxc% = psn(1, 0).xc + 2
CASE 4: xxl% = psn(1, 0).xl - 1: xxc% = psn(1, 0).xc - 1
CASE 5: xxl% = psn(1, 0).xl + 1: xxc% = psn(1, 0).xc - 1
CASE 6: xxl% = psn(1, 0).xl - 1: xxc% = psn(1, 0).xc + 1
CASE 7: xxl% = psn(1, 0).xl + 1: xxc% = psn(1, 0).xc + 1
END SELECT
m$ = LTRIM$(STR$(psn(1, 0).xc)) + LTRIM$(STR$(7 - psn(1, 0).xl)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
LOCATE 23, 1: PRINT tar%; pe&; sco&(1, 0); m$; SPACE$(40)
mv m$, 0
IF ftr% > 1 THEN tar% = ftr%
END SUB
SUB dwf (bd%)
FOR l% = 0 TO 7
FOR c% = 0 TO 7
IF fld(bd%, l%, c%) <> fld(1, l%, c%) THEN
fld(1, l%, c%) = fld(bd%, l%, c%)
IF (c% + (l% MOD 2)) MOD 2 = 0 THEN
graph 1, 0, c% * bx%, l% * bx%
ELSE
SELECT CASE fld(bd%, l%, c%)
CASE " ": i% = 1
CASE "r": i% = 2
CASE "R": i% = 3
CASE "b": i% = 4
CASE "B": i% = 5
END SELECT
graph 1, i%, c% * bx%, l% * bx%
END IF
END IF
NEXT c%
NEXT l%
END SUB
' old way:
' IF fld(bd%, l%, c%) = "B" THEN b& = b& + 3000 + (dbk% - ABS(dbk% - l%) + ABS(3.5 - (3.5 - c%)))
' IF fld(bd%, l%, c%) = "R" THEN r& = r& + 3000 + 3 + (drk% - ABS(drk% - l%) + ABS(3.5 - (3.5 - c%)))
FUNCTION eval& (bd%, ply%)
IF pe& < 2147483647 AND pe& > -1 THEN
pe& = pe& + 1
IF pe& MOD 20 = 0 THEN
LOCATE 21, 8: PRINT pe&; SPACE$(20)
END IF
ELSE
pe& = -1
END IF
bln% = -1
rl% = -1
bi% = 0
ri% = 0
FOR l% = 0 TO 7
FOR c% = 0 TO 7
IF fld(0, l%, c%) = "B" THEN bln% = l%: bc% = c%: bi% = bi% + 1
IF fld(0, l%, c%) = "R" THEN rl% = l%: rc% = c%: ri% = ri% + 1
IF fld(0, l%, c%) = "b" THEN
bi% = bi% + 1
IF bln% = -1 THEN bln% = l%: bc% = c%
END IF
IF fld(0, l%, c%) = "r" THEN
ri% = ri% + 1
IF rl% = -1 THEN rl% = l%: rc% = c%
END IF
NEXT c%
NEXT l%
IF bi% = 1 AND ri% > 1 THEN
bln% = 0: bc% = 1
IF bln% > 3 AND bc% > 3 THEN bln% = 7: bc% = 6
END IF
IF ri% = 1 AND bi% > 1 THEN
rl% = 7: rc% = 6
IF rl% < 4 AND rc% < 4 THEN rl% = 0: rc% = 1
END IF
FOR l% = 0 TO 7
FOR c% = 0 TO 7
IF fld(0, l%, c%) = "B" THEN b& = b& - 3000 - 3 * (10 - (ABS(bln% - l%) ^ 2 + ABS(bc% - c%) ^ 2) ^ .5)
IF fld(0, l%, c%) = "R" THEN r& = r& - 3000 - 3 * (10 - (ABS(rl% - l%) ^ 2 + ABS(rc% - c%) ^ 2) ^ .5)
IF fld(0, l%, c%) = "b" THEN b& = b& - 1000 - ABS(db% - l%) ^ 2
IF fld(0, l%, c%) = "r" THEN r& = r& - 1000 - ABS(dr% - -l%) ^ 2
IF fld(bd%, l%, c%) = "B" THEN b& = b& + 3000 + 3 * (10 - (ABS(bln% - l%) ^ 2 + ABS(bc% - c%) ^ 2) ^ .5)
IF fld(bd%, l%, c%) = "R" THEN r& = r& + 3000 + 3 * (10 - (ABS(rl% - l%) ^ 2 + ABS(rc% - c%) ^ 2) ^ .5)
IF fld(bd%, l%, c%) = "b" THEN b& = b& + 1000 + ABS(db% - l%) ^ 2
IF fld(bd%, l%, c%) = "r" THEN r& = r& + 1000 + ABS(dr% - -l%) ^ 2
NEXT c%
NEXT l%
d& = b& - r&
g% = gover%(bd%, 1 - ply%)
IF g% = 0 THEN d& = d& + 100000
IF g% = 1 THEN d& = d& - 100000
IF aply% = 1 THEN d& = 0 - d&
eval& = d&
END FUNCTION
SUB expi (bd%, pt%, m%, xl%, xc%, x%)
IF pe& = 3 THEN
END IF
SELECT CASE x%
CASE 0: xxl% = xl% - 2: xxc% = xc% - 2
CASE 1: xxl% = xl% + 2: xxc% = xc% - 2
CASE 2: xxl% = xl% - 2: xxc% = xc% + 2
CASE 3: xxl% = xl% + 2: xxc% = xc% + 2
CASE 4: xxl% = xl% - 1: xxc% = xc% - 1
CASE 5: xxl% = xl% + 1: xxc% = xc% - 1
CASE 6: xxl% = xl% - 1: xxc% = xc% + 1
CASE 7: xxl% = xl% + 1: xxc% = xc% + 1
END SELECT
a$ = fld(bd%, xl%, xc%)
l% = 1
IF xxc% < 0 OR xxc% > 7 OR xxl% < 0 OR xxl% > 7 THEN l% = -8: GOTO 6
IF fld(bd%, xxl%, xxc%) <> " " THEN l% = -2: GOTO 6 'chk target
IF a$ = LCASE$(a$) THEN 'chk dir
d% = des%
IF pt% MOD 2 = 1 THEN d% = 7 - d%
IF SGN(xxl% - xl%) <> SGN(d% - xl%) THEN l% = -3: GOTO 6
END IF
cc% = xxc% - xc%
cl% = xxl% - xl%
IF ABS(cc%) > 1 THEN 'chk jump
IF UCASE$(fld(bd%, xl% + cl% / 2, xc% + cc% / 2)) <> pls$(1 - (pt% MOD 2)) THEN l% = -5: GOTO 6
ELSE
IF m% = 1 THEN l% = -7: GOTO 6
END IF
6
IF l% < 1 THEN EXIT SUB
m$ = LTRIM$(STR$(xc%)) + LTRIM$(STR$(7 - xl%)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
IF m$ = "7766" THEN
END IF
mv m$, bd%
psn(0, cdp%).lib = 1
IF cdp% < tar% - 1 AND leg% > 1 THEN
cdp% = cdp% + 1
psn(0, cdp%).lib = 0
res% = 2
ELSE
res% = 1
sco&(0, cdp%) = eval&(bd%, pt% MOD 2)
IF sco&(1, cdp%) = -1000 OR ((cdp% MOD 2) = 0 AND sco&(0, cdp%) > sco&(1, cdp%)) OR ((cdp% MOD 2) = 1 AND sco&(0, cdp%) < sco&(1, cdp%)) THEN
sco&(1, cdp%) = sco&(0, cdp%)
psn(1, cdp%).xl = psn(0, cdp%).xl
psn(1, cdp%).xc = psn(0, cdp%).xc
psn(1, cdp%).x = psn(0, cdp%).x
psn(1, cdp%).dep = cdp%
FOR i% = 0 TO cdp%
bl(cdp%, i%).xl = psn(0, i%).xl
bl(cdp%, i%).xc = psn(0, i%).xc
bl(cdp%, i%).x = psn(0, i%).x
NEXT i%
at&(cdp%) = pe&
END IF
END IF
END SUB
FUNCTION gover% (bd%, ply%)
IF ply% = 0 THEN rm% = 1
IF ply% = 1 THEN bm% = 1
m% = mj%(ply%, bd%)
FOR l% = 0 TO 7
FOR c% = 0 TO 7
IF UCASE$(fld(bd%, l%, c%)) = "B" THEN
b% = b% + 1
IF bm% = 0 THEN
FOR x% = 0 TO 7
SELECT CASE x%
CASE 0: xxl% = l% - 2: xxc% = c% - 2
CASE 1: xxl% = l% + 2: xxc% = c% - 2
CASE 2: xxl% = l% - 2: xxc% = c% + 2
CASE 3: xxl% = l% + 2: xxc% = c% + 2
CASE 4: xxl% = l% - 1: xxc% = c% - 1
CASE 5: xxl% = l% + 1: xxc% = c% - 1
CASE 6: xxl% = l% - 1: xxc% = c% + 1
CASE 7: xxl% = l% + 1: xxc% = c% + 1
END SELECT
m$ = LTRIM$(STR$(c%)) + LTRIM$(STR$(7 - l%)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
IF legal%(ply%, bd%, m$, m%) = 1 THEN bm% = 1
NEXT x%
END IF
END IF
IF UCASE$(fld(bd%, l%, c%)) = "R" THEN
r% = r% + 1
IF rm% = 0 THEN
FOR x% = 0 TO 7
SELECT CASE x%
CASE 0: xxl% = l% - 2: xxc% = c% - 2
CASE 1: xxl% = l% + 2: xxc% = c% - 2
CASE 2: xxl% = l% - 2: xxc% = c% + 2
CASE 3: xxl% = l% + 2: xxc% = c% + 2
CASE 4: xxl% = l% - 1: xxc% = c% - 1
CASE 5: xxl% = l% + 1: xxc% = c% - 1
CASE 6: xxl% = l% - 1: xxc% = c% + 1
CASE 7: xxl% = l% + 1: xxc% = c% + 1
END SELECT
m$ = LTRIM$(STR$(c%)) + LTRIM$(STR$(7 - l%)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
IF legal%(ply% MOD 2, bd%, m$, m%) = 1 THEN rm% = 1
NEXT x%
END IF
END IF
NEXT c%
NEXT l%
w% = -1
IF b% = 0 OR bm% = 0 THEN w% = 1
IF r% = 0 OR rm% = 0 THEN w% = 0
gover% = w%
END FUNCTION
SUB graph (act%, img%, x%, y%)
IF act% = 0 THEN
GET (x%, y%)-(x% + bx%, y% + bx%), graphics%(size% * img%)
ELSE
PUT (x%, y%), graphics%(size% * img%), PSET
END IF
END SUB
SUB hmn (ply%)
SELECT CASE ply%
CASE 0: p$ = "Black"
CASE 1: p$ = " Red"
END SELECT
DO
LOCATE 21, 1: PRINT SPACE$(80);
LOCATE 21, 1: PRINT p$; TAB(40); "Legal moves:"; leg%
LOCATE 21, 6:
LINE INPUT "? "; move$
move$ = LTRIM$(RTRIM$(UCASE$(move$)))
IF move$ = "Q" THEN quit -1
m% = mj%(ply%, 0)
SELECT CASE legal%(ply%, 0, move$, m%)
CASE 1: EXIT DO
CASE -8: m$ = "Chk format"
CASE -1: m$ = "Chk piece"
CASE -2: m$ = "Chk target"
CASE -3: m$ = "Chk direction"
CASE -4: m$ = "Chk square"
CASE -6: m$ = "Chk distance"
CASE -5: m$ = "Chk jump"
CASE -7: m$ = "Must jump"
END SELECT
LOCATE 22, 1: PRINT SPACE$(40);
COLOR 15: LOCATE 22, 1: PRINT m$: COLOR 7
LOOP
LOCATE 22, 1: PRINT SPACE$(40);
mv move$, 0
END SUB
SUB inigrph
SELECT CASE mode%
CASE 7, 12
LINE (0, 0)-(bx% - 1, bx% - 1), 4, BF
graph 0, 0, 0, 0
LINE (0, 0)-(bx% - 1, bx% - 1), 0, BF
graph 0, 1, 0, 0
FUNCTION legal% (ply%, bd%, m$, m%)
IF LEN(m$) <> 4 THEN l% = -8: GOTO 1
fc% = VAL(LEFT$(m$, 1))
fl% = 7 - VAL(MID$(m$, 2, 1))
tc% = VAL(MID$(m$, 3, 1))
tl% = 7 - VAL(RIGHT$(m$, 1))
IF fc% < 0 OR fc% > 7 OR fl% < 0 OR fl% > 7 OR tc% < 0 OR tc% > 7 OR tl% < 0 OR tl% > 7 THEN l% = -8: GOTO 1
a$ = fld(bd%, fl%, fc%)
l% = 1
IF UCASE$(a$) <> pls$(ply%) THEN l% = -1: GOTO 1 'chk piece
IF fld(bd%, tl%, tc%) <> " " THEN l% = -2: GOTO 1 'chk target
IF a$ = LCASE$(a$) THEN 'chk dir
d% = des%
IF ply% = 1 THEN d% = 7 - d%
IF SGN(tl% - fl%) <> SGN(d% - fl%) THEN l% = -3: GOTO 1
END IF
IF (tc% + (tl% MOD 2)) MOD 2 = 0 THEN l% = -4: GOTO 1 'chk red
cc% = tc% - fc%
cl% = tl% - fl%
IF ABS(cc%) > 2 OR ABS(cl%) > 2 OR ABS(cc%) <> ABS(cl%) THEN l% = -6: GOTO 1 'chk dist
IF ABS(cc%) > 1 THEN 'chk jump
IF UCASE$(fld(bd%, fl% + cl% / 2, fc% + cc% / 2)) <> pls$(1 - ply%) THEN l% = -5: GOTO 1
ELSE
IF m% = 1 THEN l% = -7: GOTO 1
END IF
1 legal% = l%
END FUNCTION
FUNCTION mj% (ply%, bd%)
FOR xl% = 0 TO 7
FOR xc% = 0 TO 7
IF UCASE$(fld(bd%, xl%, xc%)) = pls$(ply%) THEN
FOR x% = 0 TO 3
SELECT CASE x%
CASE 0: xxl% = xl% - 2: xxc% = xc% - 2
CASE 1: xxl% = xl% + 2: xxc% = xc% - 2
CASE 2: xxl% = xl% - 2: xxc% = xc% + 2
CASE 3: xxl% = xl% + 2: xxc% = xc% + 2
END SELECT
IF xxc% < 0 OR xxc% > 7 OR xxl% < 0 OR xxl% > 7 THEN GOTO 2
IF fld(bd%, xxl%, xxc%) <> " " THEN GOTO 2
IF fld(bd%, xl%, xc%) = LCASE$(fld(bd%, xl%, xc%)) THEN
d% = des%
IF ply% = 1 THEN d% = 7 - d%
IF SGN(xxl% - xl%) <> SGN(d% - xl%) THEN GOTO 2
END IF
cxc% = xxc% - xc%
cxl% = xxl% - xl%
IF UCASE$(fld(bd%, xl% + cxl% / 2, xc% + cxc% / 2)) = pls$(1 - ply%) THEN l% = 1: GOTO 3
2 NEXT x%
END IF
NEXT xc%
NEXT xl%
3 mj% = l%
END FUNCTION
SUB mv (m$, bd%)
fc% = VAL(LEFT$(m$, 1))
fl% = 7 - VAL(MID$(m$, 2, 1))
tc% = VAL(MID$(m$, 3, 1))
tl% = 7 - VAL(RIGHT$(m$, 1))
a$ = fld(bd%, fl%, fc%)
fld(bd%, fl%, fc%) = " "
IF (tl% = des% AND a$ = "b") OR (tl% = 7 - des% AND a$ = "r") THEN a$ = UCASE$(a$)
fld(bd%, tl%, tc%) = a$
cc% = tc% - fc%
cl% = tl% - fl%
IF ABS(cc%) > 1 THEN
fld(bd%, fl% + cl% / 2, fc% + cc% / 2) = " "
END IF
END SUB
FUNCTION numleg% (ply%)
IF ply% = 0 THEN rm% = -1
IF ply% = 1 THEN bm% = -1
m% = mj%(ply%, 0)
FOR l% = 0 TO 7
FOR c% = 0 TO 7
IF UCASE$(fld(bd%, l%, c%)) = "B" AND bm% > -1 THEN
FOR x% = 0 TO 7
SELECT CASE x%
CASE 0: xxl% = l% - 2: xxc% = c% - 2
CASE 1: xxl% = l% + 2: xxc% = c% - 2
CASE 2: xxl% = l% - 2: xxc% = c% + 2
CASE 3: xxl% = l% + 2: xxc% = c% + 2
CASE 4: xxl% = l% - 1: xxc% = c% - 1
CASE 5: xxl% = l% + 1: xxc% = c% - 1
CASE 6: xxl% = l% - 1: xxc% = c% + 1
CASE 7: xxl% = l% + 1: xxc% = c% + 1
END SELECT
m$ = LTRIM$(STR$(c%)) + LTRIM$(STR$(7 - l%)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
IF legal%(ply%, bd%, m$, m%) = 1 THEN bm% = bm% + 1
NEXT x%
END IF
IF UCASE$(fld(bd%, l%, c%)) = "R" AND rm% > -1 THEN
FOR x% = 0 TO 7
SELECT CASE x%
CASE 0: xxl% = l% - 2: xxc% = c% - 2
CASE 1: xxl% = l% + 2: xxc% = c% - 2
CASE 2: xxl% = l% - 2: xxc% = c% + 2
CASE 3: xxl% = l% + 2: xxc% = c% + 2
CASE 4: xxl% = l% - 1: xxc% = c% - 1
CASE 5: xxl% = l% + 1: xxc% = c% - 1
CASE 6: xxl% = l% - 1: xxc% = c% + 1
CASE 7: xxl% = l% + 1: xxc% = c% + 1
END SELECT
m$ = LTRIM$(STR$(c%)) + LTRIM$(STR$(7 - l%)) + LTRIM$(STR$(xxc%)) + LTRIM$(STR$(7 - xxl%))
IF legal%(ply% MOD 2, bd%, m$, m%) = 1 THEN rm% = rm% + 1
NEXT x%
END IF
NEXT c%
NEXT l%
numleg% = bm% + rm% + 1
END FUNCTION
SUB quit (v%)
SELECT CASE v%
CASE -1: m$ = "No win."
CASE 0: m$ = "Black won!"
CASE 1: m$ = "Red won!"
END SELECT
LOCATE 24, 1
PRINT m$;
SLEEP
SCREEN 0
WIDTH 80
SYSTEM
END SUB
DECLARE SUB tar (d!, r%)
DECLARE FUNCTION h12$ (t$)
DECLARE SUB center (lin%, text$, col%)
DIM SHARED pi#
DIM SHARED cx%
DIM SHARED cy%
DIM SHARED x!
DIM SHARED y!
TYPE armt
x AS SINGLE
y AS SINGLE
px AS SINGLE
py AS SINGLE
r AS INTEGER
c AS INTEGER
i AS SINGLE
END TYPE
DIM arm(0 TO 2) AS armt
tim$ = "09:45:00" ' Alarm time. "" for none. Format: "hh:mm:ss"
tout% = 10 ' Limit of alarm ring in seconds.
tone% = 1 ' Quarterly hour tone: 0 = off, 1 = on
tick% = 1 ' Tick: 0 = off, 1 = on
tickfrec% = 100 ' Frequency of tick in hertz. Default: 100
ON ERROR GOTO term ' For error handling.
WHILE INKEY$ <> "": WEND
COLOR 7, 0
CLS
SCREEN 12 ' VGA mode: 640 x 480, 16 color
FOR i% = 0 TO 59
d! = 360 * i% / 60
a! = d!
tar a!, 190
x1! = x!: y1! = y!
tar d!, 200
LINE (x1!, y1!)-(x!, y!), 12 + (-3 * (i% MOD 5 = 0))
NEXT i%
tt$ = TIME$ ' So that it won't tick as soon as the program starts.
DO ' Begining of loop area.
' Displays date and time:
IF tt$ <> TIME$ THEN
center 27, "Date: " + DATE$, 80
center 28, "Time: " + TIME$, 80
'center 28, "Time: " + h12$(TIME$), 80
FOR i% = 2 TO 0 STEP -1
SELECT CASE i%
CASE 0: arm(i%).i = (VAL(LEFT$(TIME$, 2)) + arm(1).i) / 12: d! = arm(i%).i * 360
CASE 1: arm(i%).i = (VAL(MID$(TIME$, 4, 2)) + arm(2).i) / 60: d! = arm(i%).i * 360
CASE 2: arm(i%).i = VAL(RIGHT$(TIME$, 2)) / 60: d! = arm(i%).i * 360
END SELECT
tar d!, arm(i%).r
arm(i%).x = x!
arm(i%).y = y!
LINE (cx%, cy%)-(arm(i%).px, arm(i%).py), 0
LINE (cx%, cy%)-(arm(i%).x, arm(i%).y), arm(i%).c
arm(i%).px = arm(i%).x: arm(i%).py = arm(i%).y
NEXT i%
' For ticks:
IF tick% = 1 THEN SOUND tickfreq%, .05
tt$ = TIME$
END IF
' For the alarm:
IF tim$ = TIME$ THEN s# = TIMER: COLOR 12 ' Starts counting.
IF s# <> 0 AND TIMER - s# < tout% THEN PLAY "L16O4A": COLOR 12 ' Beeps.
IF s# <> 0 AND TIMER - s# > tout% THEN s# = 0: COLOR 15 ' Stops alarm.
' For quarterly hourly tone:
IF tone% = 1 AND alr% = 0 AND (RIGHT$(TIME$, 5) = "00:00" OR RIGHT$(TIME$, 5) = "15:00" OR RIGHT$(TIME$, 5) = "30:00" OR RIGHT$(TIME$, 5) = "45:00") THEN alr% = 1: PLAY "L8O2C": t$ = TIME$: COLOR 11
IF alr% = 1 AND t$ <> TIME$ THEN alr% = 0: COLOR 15
IF INKEY$ <> "" THEN ' If a button is pressed and ...
IF s# = 0 THEN ' the alarm isn't ringing then ...
EXIT DO ' exit the loop.
ELSE ' If alarm is ringing ...
s# = TIMER - (tout% + 1) ' allow alarm to quit ringing early.
END IF
END IF
LOOP ' End of loop area.
WIDTH 80 ' Restores text to normal size.
CLS
SYSTEM ' Ends the program.
' Subroutine that will be run in case of an error:
term:
SCREEN 0
PRINT "Error"; ERR ' Tells user the error code.
SYSTEM ' Ends the program.
' center is a sub procedeure for centering text on the screen.
'
SUB center (lin%, text$, col%)
LOCATE lin%, col% / 2 - INT(LEN(text$) / 2 + .5)
PRINT text$
END SUB
' Converts 24 hour time to 12 hour time.
'
FUNCTION h12$ (t$)
w$ = "AM"
hour% = VAL(LEFT$(t$, 2))
IF hour% > 12 THEN hour% = hour% - 12: w$ = "PM"
IF hour% = 0 THEN hour% = hour% - 12
return$ = LTRIM$(STR$(hour%)) + RIGHT$(t$, 6) + " " + w$
IF LEN(return$) = 10 THEN return$ = "0" + return$
h12$ = return$
END FUNCTION
SUB tar (d!, r%)
d! = d! * pi# / 180
x! = 1
y! = 1
IF d! > 90 AND d! < 270 THEN x! = -1
IF d! < 180 THEN y! = -1
x! = x! * r% * SIN(d!) + cx%
y! = y! * r% * COS(d!) + cy%
END SUB
I include this one for humor. It was an utter failure. For some reason, I believed that BSAVE was an awesome compression mechanism.
' big waste of time. it don't compress. you just that it did cause you only
' saw fraction of output charactors.
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
DIM SHARED nexis%
1 PRINT "---Main Menu---"
PRINT "1-Compress"
PRINT "2-Decompress"
PRINT "3-Exit"
a$ = choice$("", "1", "2", "3", "1", "1", "1", "1", "1", "1", "1")
IF a$ = "3" THEN GOTO 2
LINE INPUT "From? "; b$
IF Exist%(b$) = 0 THEN PRINT "File not found.": PRINT : GOTO 1
LINE INPUT "To? ", c$
IF Exist%(c$) = 1 THEN
d$ = UCASE$(choice$("File exist. Overwrite", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF d$ = "N" THEN PRINT : GOTO 1
KILL c$
END IF
SELECT CASE a$
CASE "1": OPEN b$ FOR BINARY AS 1
a! = LOF(1)
DIM dat AS STRING * 1
i! = 0
e$ = STRING$(a!, " ")
DO
dat = ""
GET 1, , dat
IF EOF(1) THEN EXIT DO
MID$(e$, i! + 1, 1) = dat
i! = i! + 1
LOOP
CLOSE
DEF SEG = VARSEG(e$)
BSAVE "c:\compress.dat", VARPTR(e$), a!
DEF SEG
OPEN "c:\compress.dat" FOR BINARY AS 1
GET 1, , f$
CLOSE
OPEN c$ FOR BINARY AS 1
g$ = STR$(a!)
PUT 1, , g$
PUT 1, , f$
CLOSE
KILL "c:\compress.dat"
CASE "2":
OPEN b$ FOR INPUT AS 1
LINE INPUT aa$
CLOSE
OPEN b$ FOR BINARY AS 1
GET 1, LEN(aa$) + 1, f$
CLOSE
OPEN "c:\compress.dat" FOR BINARY AS 1
PUT 1, , f$
CLOSE
a! = VAL(aa$)
e$ = STRING$(a!, " ")
DEF SEG = VARSEG(e$)
BLOAD "c:\compress.dat", VARPTR(e$)
DEF SEG
OPEN c$ FOR BINARY AS 1
PUT 1, 1, e$
CLOSE
KILL "c:\compress.dat"
END SELECT
PRINT
GOTO 1
2 PRINT
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
'c3
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
'IF cp% > 0 THEN c cp%
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
DEFDBL A-Z
DECLARE FUNCTION ar$ (n, l%)
CLS
pi# = 4 * ATN(1)
r = 7927 / 2 ' 7927 -- the diameter through the equator
PRINT "This program inputs the coordinates of two points that are between 0øN and 90øW"
PRINT "and between 0øW and 180øW."
PRINT "This program assumes that Earth is a perfect sphere with a radius of"
PRINT r; "miles."
PRINT
TYPE pt
n AS DOUBLE 'north lat
w AS DOUBLE 'west lon
dn AS DOUBLE 'dist north
dw AS DOUBLE 'dist west
END TYPE
DIM p(0 TO 1) AS pt
FOR i% = 0 TO 1
PRINT "Point"; i%
INPUT "(deg,mins) North latitude"; p(i%).n, mins
p(i%).n = p(i%).n + mins / 60
p(i%).dn = p(i%).n * r * 2 * pi# / 360
INPUT "(deg,mins) West longitude"; p(i%).w, mins
p(i%).w = p(i%).w + mins / 60
p(i%).dw = p(i%).w * (pi# * 2 * (r ^ 2 - (r * SIN(p(i%).n * pi# / 180)) ^ 2) ^ .5) / 360
PRINT
NEXT i%
d = (ABS(p(0).dn - p(1).dn) ^ 2 + ABS(p(0).dw - p(1).dw) ^ 2) ^ .5
PRINT "Surface distance between the two points:"
PRINT ar$(d, 40); " miles."
PRINT ar$(d * 5280, 40); " feet."
d2 = d * 5280 * .3048
PRINT ar$(d2 / 1000, 40); " kilometers."
PRINT ar$(d2, 40); " meters."
FUNCTION ar$ (n, l%)
n$ = LTRIM$(STR$(n))
ar$ = SPACE$(l% - LEN(n$)) + n$
END FUNCTION
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DIM SHARED nexis%
pi# = 4 * ATN(1)
rad2deg# = pi# / 180
sm% = 9
mx% = 640
my% = 350
mc% = 16
lin% = 43
col% = 80
boxx% = 8
boxy% = 8
DIM tile$(1 TO 32)
RESTORE tiles
FOR i% = 1 TO 32
READ tile$(i%)
NEXT i%
SCREEN sm%
WIDTH col%, lin%
COLOR 7
DO
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: PRINT "1-Pixil, 2-Line/Box, 3-Circle/Arc, 4-Fill, 5-Exit ";
in$ = choice$("Your choice", "1", "2", "3", "4", "5", "", "", "", "", "")
SELECT CASE in$
CASE "1"
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: INPUT ; "(x,y,color) Dim"; x$, y$, c$
PSET (VAL(x$), VAL(y$)), VAL(c$)
CASE "2"
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: PRINT "1-Line, 2-Box, 3-Filled box, 4-Back ";
in$ = choice$("Your choice", "1", "2", "3", "4", "", "", "", "", "", "")
IF in$ <> "4" THEN
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: INPUT ; "(x1,y1,x2,y2,color) Dim"; x$, y$, x2$, y2$, c$
SELECT CASE in$
CASE "1"
LINE (VAL(x$), VAL(y$))-(VAL(x2$), VAL(y2$)), VAL(c$)
CASE "2"
LINE (VAL(x$), VAL(y$))-(VAL(x2$), VAL(y2$)), VAL(c$), B
CASE "3"
LINE (VAL(x$), VAL(y$))-(VAL(x2$), VAL(y2$)), VAL(c$), BF
END SELECT
END IF
CASE "3"
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: PRINT "1-Circle, 2-Elipse, 3-Arc, 4-Eliptical arc, 5-Back ";
in$ = choice$("Your choice", "1", "2", "3", "4", "5", "", "", "", "", "")
IF in$ <> "5" THEN
LOCATE lin%, 1: PRINT SPACE$(col%);
SELECT CASE in$
CASE "1"
LOCATE lin%, 1: INPUT ; "(x,y,radius,color) Dim"; x$, y$, r$, c$
CIRCLE (VAL(x$), VAL(y$)), VAL(r$), VAL(c$)
CASE "2"
LOCATE lin%, 1: INPUT ; "(x,y,radius,color,ratio of width to hight) Dim"; x$, y$, r$, c$, a$
CIRCLE (VAL(x$), VAL(y$)), VAL(r$), VAL(c$), , , VAL(a$)
CASE "3"
LOCATE lin%, 1: INPUT ; "(x,y,radius,color,start(deg),end(deg)) Dim"; x$, y$, r$, c$, s$, e$
CIRCLE (VAL(x$), VAL(y$)), VAL(r$), VAL(c$), VAL(s$) * rad2deg#, VAL(e$) * rad2deg#
CASE "4"
LOCATE lin%, 1: INPUT ; "(x,y,r,c,start(deg),end(deg),ratio of width to hight) Dim"; x$, y$, r$, c$, s$, e$, a$
CIRCLE (VAL(x$), VAL(y$)), VAL(r$), VAL(c$), VAL(s$) * rad2deg#, VAL(e$) * rad2deg#, VAL(a$)
END SELECT
END IF
CASE "4"
LOCATE lin%, 1: PRINT SPACE$(col%);
LOCATE lin%, 1: PRINT "1-Solid, 2-Tile, 3-Tile(b), 4-Back ";
in$ = choice$("Your choice", "1", "2", "3", "4", "", "", "", "", "", "")
IF in$ <> "4" THEN
LOCATE lin%, 1: PRINT SPACE$(col%);
SELECT CASE in$
CASE "1"
LOCATE lin%, 1: INPUT ; "(x,y,color,border) Dim"; x$, y$, c$, b$
PAINT (VAL(x$), VAL(y$)), VAL(c$), VAL(b$)
CASE "2"
LOCATE lin%, 1: INPUT ; "(x,y,tile number,border) Dim"; x$, y$, c$, b$
PAINT (VAL(x$), VAL(y$)), tile$(VAL(c$)), VAL(b$)
CASE "3"
LOCATE lin%, 1: INPUT ; "(x,y,tile number,border,background(asc)) Dim"; x$, y$, c$, b$, b2$
PAINT (VAL(x$), VAL(y$)), tile$(VAL(c$)), VAL(b$), CHR$(VAL(b2$))
END SELECT
END IF
CASE "5": SCREEN 0: WIDTH 80, 25: PRINT "Thanks for using my primitive drawing system.": SYSTEM
END SELECT
LOOP
SYSTEM
term:
SCREEN 0: WIDTH 80, 25
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
tiles:
DATA "","","","","","","","","","","","","","","","","","","","","","","","","","","","","","","",""
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
LOCATE CSRLIN, POS(0), 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE CSRLIN, POS(0), 0
PRINT sl$;
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
This one looks like it was abandonded while being written. Commenting out a few lines allows it to run.
This program is public domain.
DECLARE SUB load ()
DECLARE FUNCTION ask% ()
DECLARE FUNCTION openf% ()
' make saveas a function (ask needs it to be)
DECLARE SUB save ()
DECLARE SUB saveas ()
DECLARE SUB printf ()
' test minput$
DECLARE SUB menusys ()
DECLARE FUNCTION exist% (efile$)
DECLARE SUB action (code%)
DECLARE SUB drwmenu ()
DECLARE SUB box (sl%, sc%, el%, ec%, all%)
DECLARE FUNCTION minput$ (de$, lin%, lb%, rb%, max%)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB sad ()
DECLARE SUB c (cm%)
DIM SHARED nexis%
DIM SHARED mon$
DIM SHARED filen$
DIM SHARED changes%
DIM SHARED act%
DIM SHARED leng$
CLEAR , , 750
CLS
CONST maxwidth = 128
CONST maxlins% = 256
TYPE linedat
lin AS STRING * maxwidth
leng AS INTEGER
END TYPE
TYPE menudat
ni AS INTEGER
text AS STRING * 16
END TYPE
TYPE itemdat
text AS STRING * 14
code AS INTEGER
END TYPE
DIM SHARED file(1 TO maxlins%) AS linedat
filen$ = "\\\untitled"
2 FOR i% = 1 TO maxlins%
file(i%).lin = ""
file(i%).leng = 0
NEXT i%
leng% = 1
lin% = 1
place% = 1
voffset% = 0
offset% = 0
over% = 1: start% = 0: LOCATE CSRLIN, POS(0), 1, start%, 31
IF filen$ = "\\\untitled" THEN GOTO 4
3 load
4 GOSUB update
DO
key$ = INKEY$
SELECT CASE LEN(key$)
CASE 0
CASE 1
SELECT CASE ASC(key$)
CASE IS > 31 AND (ASC(key$) < 127): place% = place% + 1
b% = 0
IF place% = maxwidth + 2 THEN palce% = place% - 1: b% = 1
a% = file(lin%).leng - (place% - (2 - (over% OR ABS(file(lin%).leng = maxwidth)))): IF a% < 0 THEN a% = 0
file(lin%).lin = LEFT$(file(lin%).lin, place% - 2) + key$ + MID$(file(lin%).lin, (file(lin%).leng - a%) + ABS(0 = file(lin%).leng - a%) + 1, a%)
IF place% > maxwidth THEN place% = maxwidth
a% = place% - (1 - b%)
IF a% < file(lin%).leng THEN a% = file(lin%).leng + (1 - over%)
file(lin%).leng = a%
IF lin% = leng% AND leng% < maxlins% THEN leng% = leng% + 1
IF file(lin%).leng > maxwidth THEN file(lin%).leng = maxwidth
GOSUB update
changes% = 1
CASE 8
IF place% > 1 THEN
b$ = ""
IF place% - 1 <= file(lin%).leng THEN
IF place% - 1 < file(lin%).leng THEN b$ = MID$(file(lin%).lin, place%, file(lin%).leng - (place% - 1))
file(lin%).lin = LEFT$(file(lin%).lin, place% - 2) + b$
file(lin%).leng = file(lin%).leng - 1
END IF
place% = place% - 1
GOSUB update
ELSE
IF lin% > 1 THEN
lin% = lin% - 1
place% = file(lin%).leng + 1
GOSUB lineback
GOSUB update
END IF
END IF
changes% = 1
CASE 13
IF leng% < maxlins% THEN
GOSUB linefoward: GOSUB update
ELSE
IF lin% < maxlins% THEN place% = 1: lin% = lin% + 1
END IF
changes% = 1
CASE 27: LOCATE 1, 1, 0, 31, 31: COLOR 7, 0: CLS : SYSTEM
' $DYNAMIC
DIM SHARED nummenus%
DIM SHARED p1%
DIM SHARED p2%
DIM SHARED md%
DIM SHARED pp%
nummenus% = 2
DIM SHARED menu(1 TO nummenus%) AS menudat
DIM SHARED items(1 TO nummenus%, 1 TO 20) AS itemdat
DIM SHARED shortcut$(-20 TO -1)
RESTORE Short
FOR i% = -1 TO -20 STEP -1
READ shortcut$(i%)
NEXT i%
RESTORE Menudata
FOR i% = 1 TO nummenus%
READ menu(i%).text
READ menu(i%).ni
NEXT i%
RESTORE M1
FOR i% = 1 TO menu(1).ni
READ items(1, i%).text
READ items(1, i%).code
NEXT i%
RESTORE M2
FOR i% = 1 TO menu(2).ni
READ items(2, i%).text
READ items(2, i%).code
NEXT i%
c 0
menusys
nummenus% = 0
p1% = 0
p2% = 0
md% = 0
pp% = 0
ERASE menu
ERASE items
ERASE shortcut$
c 0
IF act% = 1 THEN act% = 0: GOTO 2
IF act% = 2 THEN act% = 0: GOTO 3
GOSUB update
END SELECT
CASE 2
SELECT CASE ASC(RIGHT$(key$, 1))
CASE 82: over% = 1 - over%: start% = 30 - (over% * 30): GOSUB update
CASE 75: IF place% > 1 THEN place% = place% - 1: GOSUB update
CASE 77: IF place% < maxwidth THEN place% = place% + 1: GOSUB update
CASE 71: place% = 1: GOSUB update
CASE 79: place% = file(lin%).leng + 1
IF place% > maxwidth THEN place% = maxwidth
GOSUB update
CASE 83
IF place% < 1 + file(lin%).leng THEN
file(lin%).lin = LEFT$(file(lin%).lin, place% - 1) + MID$(file(lin%).lin, place% + 1, file(lin%).leng - place%)
file(lin%).leng = file(lin%).leng - 1
GOSUB update
ELSE
IF lin% + 1 < leng% OR (file(lin%).leng = 0 AND lin% < leng%) THEN GOSUB lineback
GOSUB update
END IF
changes% = 1
CASE 72: IF lin% > 1 THEN lin% = lin% - 1: GOSUB update
CASE 80: IF lin% < leng% THEN lin% = lin% + 1: GOSUB update
CASE 73: lin% = lin% - 24: IF lin% < 1 THEN lin% = 1
GOSUB update
CASE 81: lin% = lin% + 24: IF lin% > leng% THEN lin% = leng%
GOSUB update
CASE 132: a% = place%
offset% = a% - 81
place% = a% - 80: IF place% < 1 THEN place% = 1
GOSUB update
CASE 118: a% = place%
offset% = a% - 1
place% = a% + 80: IF place% > maxwidth THEN place% = maxwidth
GOSUB update
CASE 119: lin% = 1: GOSUB update
CASE 117: lin% = leng%: GOSUB update
END SELECT
END SELECT
LOOP
LOCATE CSRLIN, POS(0), 0, 31, 31
update:
IF place% <= offset% OR place% - 80 > offset% THEN
IF place% - 80 > offset% THEN
offset% = place% - 80
ELSE
offset% = place% - 1
END IF
END IF
IF offset% < 0 THEN offset% = 0
IF offset% > maxwidth - 80 THEN offset% = maxwidth - 80
IF lin% <= voffset% OR lin% - 23 > voffset% THEN
IF lin% - 23 > voffset% THEN
voffset% = lin% - 23
ELSE
voffset% = lin% - 1
END IF
END IF
FOR i% = voffset% + 1 TO voffset% + 23
cc% = 80
IF cc% + offset% > file(i%).leng THEN cc% = file(i%).leng - offset%
IF cc% < 0 THEN cc% = 0
LOCATE i% - voffset%, 1, 0: COLOR 7, 4: PRINT MID$(file(i%).lin, 1 + ABS(cc% > 0) * offset%, ABS(cc% > 0 AND offset% > 0)); : COLOR 7, 1: PRINT MID$(file(i%).lin, offset% + ABS(offset% > 0) + 1, (cc% - ABS(offset% > 0 AND cc% > 0)) - ABS(file(i%).leng - offset% > 80 AND cc% > ABS(offset% > 0 AND cc% > 0))); : COLOR 7, 4: PRINT MID$(file(i%).lin, 1 + ABS(file(i%).leng - offset% > 80) * offset% + 80, ABS(file(i%).leng - offset% > 80)); : COLOR 7, 0: PRINT SPACE$(81 - POS(0));
NEXT i%
a$ = UCASE$(filen$)
IF LEFT$(a$, 3) = "\\\" THEN a$ = "Untitled"
IF LEN(a$) > 47 THEN a$ = "..." + RIGHT$(a$, 44)
IF LEN(a$) < 47 THEN a$ = SPACE$(47 - LEN(a$)) + a$
b$ = "Over": IF over% = 0 THEN b$ = "Push"
cc$ = LTRIM$(STR$(INT((lin% / leng% * 100) + .5))) + "%) C:": cc$ = SPACE$(8 - LEN(cc$)) + cc$
d$ = LTRIM$(STR$(lin%)): d$ = SPACE$(5 - LEN(d$)) + d$
e$ = LTRIM$(STR$(leng%)): e$ = SPACE$(5 - LEN(e$)) + e$
f$ = LTRIM$(STR$(place%)): f$ = SPACE$(3 - LEN(f$)) + f$
LOCATE 24, 1: COLOR 0, 3: PRINT b$; " L:"; d$; "/"; e$; " ("; cc$; f$; " "; a$;
a$ = "": b$ = "": cc$ = "": d$ = "": e$ = "": f$ = ""
LOCATE lin% - voffset%, place% - offset%, 1, start%, 31
RETURN
lineback:
a% = file(lin% + 1).leng: b% = 0: d% = a%
cc% = file(lin%).leng
IF (place% - 1) + file(lin% + 1).leng% > maxwidth THEN a% = maxwidth - (place% - 1): b% = 1
file(lin%).lin = LEFT$(file(lin%).lin, place% - 1) + LEFT$(file(lin% + 1).lin, a%)
file(lin%).leng = cc% + a%
file(lin% + 1).lin = MID$(file(lin% + 1).lin, (file(lin%).leng - ((file(lin% + 1).leng - a%) * b%)) + 1, (file(lin% + 1).leng - a%) * b%)
file(lin% + 1).leng = d% - a%
IF b% = 0 THEN
FOR i% = lin% + ABS(file(lin%).leng > 0) TO leng% - 1
file(i%).lin = file(i% + 1).lin
file(i%).leng = file(i% + 1).leng
NEXT i%
leng% = leng% - 1
END IF
RETURN
linefoward:
FOR i% = leng% TO lin% + 2 STEP -1
file(i%).lin = file(i% - 1).lin
file(i%).leng = file(i% - 1).leng
NEXT i%
leng% = leng% + 1
IF leng% > maxlins% THEN leng% = maxlins%
file(lin% + 1).lin = MID$(file(lin%).lin, place%, file(lin%).leng - (place% - 1) * ABS(file(lin%).leng >= place%))
a% = place% - 1: IF a% > file(lin%).leng THEN a% = file(lin%).leng
b% = file(lin%).leng - a%
file(lin%).lin = LEFT$(file(lin%).lin, a%)
file(lin%).leng = a%
file(lin% + 1).leng = b%
lin% = lin% + 1
place% = 1
RETURN
sadserr:
mon$ = "M"
RESUME NEXT
term:
PRINT "Error"; ERR; "at"; ERL
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
Menudata:
DATA "File",6,"Help",1
M1:
DATA "New",1,"Open...",2,"Save",3,"Save As...",4,"Print...",5,"Exit",6
M2:
DATA "About",7
Short:
DATA "C","","","","","","","","","","","","","","","","","","",""
REM $STATIC
SUB action (code%)
drwmenu
1
SELECT CASE code%
CASE 1
IF changes% = 1 THEN
IF ask% = 0 THEN EXIT SUB
END IF
act% = 1: filen$ = "\\\untitled"
CASE 2
IF changes% = 1 THEN
IF ask% = 0 THEN EXIT SUB
END IF
IF openf% = 1 THEN act% = 2
CASE 3
IF filen$ = "\\\untitled" THEN filen$ = ""
saveas
ELSE
save
END IF
CASE 4: IF filen$ = "\\\untitled" THEN filen$ = "": saveas
CASE 5: printf
CASE 6
IF changes% = 1 THEN
IF ask% = 0 THEN EXIT SUB
END IF
COLOR 7, 0: CLS : SYSTEM
CASE 7: box 10, 1, 13, 20, 1: LOCATE 11, 2: PRINT "File Editor": LOCATE 12, 2: PRINT "By Michael Calkins"
SLEEP: WHILE INKEY$ <> "": WEND
END SELECT
END SUB
FUNCTION ask%
box 1, 1, 3, 36, 1: LOCATE 2, 2: PRINT "Save changes? <Y>es <N>o <C>ancel"
DO
SELECT CASE UCASE$(minput$("", 2, 35, 35, 1))
CASE "C": a% = 0: EXIT DO
CASE "Y": a% = 1
IF filen$ = "\\\untitled" THEN filen$ = ""
saveas
ELSE
save
END IF
EXIT DO
CASE "N": a% = 1: EXIT DO
END SELECT
LOOP
ask% = a%
END FUNCTION
SUB box (sl%, sc%, el%, ec%, all%)
LOCATE sl%, sc%: PRINT "Ú"; STRING$((ec% - sc%) - 1, "Ä"); "¿"
IF all% = 1 THEN
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³"; SPACE$((ec% - sc%) - 1); "³"
NEXT i%
ELSE
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³": LOCATE i%, ec%: PRINT "³"
NEXT i%
END IF
LOCATE el%, sc%: PRINT "À"; STRING$((ec% - sc%) - 1, "Ä"); "Ù"
END SUB
SUB c (cm%)
IF smono% = 1 AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 4 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = cm%
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
LOCATE CSRLIN, POS(0), 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE CSRLIN, POS(0), 0
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB drwmenu
LOCATE 1, 1
FOR i% = 1 TO nummenus%
IF i% = p1% THEN COLOR 0, 7
PRINT menu(i%).text;
COLOR 7, 0
NEXT i%
IF p1% <> pp% THEN COLOR 0, 0: box 2, ((pp% - 1) * 16) + 1, menu(pp%).ni + 3, ((pp% - 1) * 16) + 17, 1: COLOR 7, 0: pp% = p1%
IF md% = 1 THEN
box 2, ((p1% - 1) * 16) + 1, menu(p1%).ni + 3, ((p1% - 1) * 16) + 17, 0
FOR i% = 1 TO menu(p1%).ni
LOCATE i% + 2, ((p1% - 1) * 16) + 2
IF i% = p2% THEN COLOR 0, 7
PRINT items(p1%, i%).text
COLOR 7, 0
NEXT i%
END IF
PRINT
END SUB
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB load
END SUB
SUB menusys
p1% = 1
p2% = 0
md% = 0
pp% = 1
DO
drwmenu
key$ = INKEY$
SELECT CASE key$
CASE "":
CASE CHR$(0) + CHR$(80): md% = 1: p2% = p2% + 1
IF p2% > menu(p1%).ni THEN p2% = 1
CASE CHR$(0) + CHR$(72): md% = 1: p2% = p2% - 1
IF p2% < 1 THEN p2% = menu(p1%).ni
CASE CHR$(0) + CHR$(75): pp% = p1%: p1% = p1% - 1: p2% = md%
IF p1% < 1 THEN p1% = nummenus%
CASE CHR$(0) + CHR$(77): pp% = p1%: p1% = p1% + 1: p2% = md%
IF p1% > nummenus% THEN p1% = 1
CASE CHR$(27): pp% = p1%: md% = 0: p2% = 0: tp% = p1%: p1% = 0: drwmenu: p1% = tp%: pp% = tp%
CASE CHR$(13), " ":
IF md% = 0 THEN
md% = 1: p2% = 1
ELSE
t1% = p1%: t2% = p2%
md% = 0: p1% = 0: p2% = 0
action items(t1%, t2%).code
p1% = 1: pp% = 1
END IF
CASE ELSE
FOR i% = -20 TO -1
IF UCASE$(key$) = UCASE$(shortcut$(i%)) THEN action i%
NEXT i%
END SELECT
LOOP
' up 72 left 75 right 77 down 80 lf 10
END SUB
FUNCTION minput$ (de$, lin%, lb%, rb%, max%)
a$ = de$
IF lb% < 1 OR rb% > 80 OR lin% < 1 OR lin% > 24 OR rb% - lb% < 0 OR max% < 1 OR max% > 32757 THEN EXIT FUNCTION
over% = 1: start% = 0: LOCATE CSRLIN, POS(0), 1, start%, 31
place% = LEN(a$) + 1
IF place% > max% THEN place% = max%
GOSUB update2
DO
key$ = INKEY$
SELECT CASE LEN(key$)
CASE 0
CASE 1
SELECT CASE ASC(key$)
CASE IS > 31 AND (ASC(key$) < 127): place% = place% + 1
'IF place% - 2 = LEN(a$) THEN
' a$ = a$ + key$
'ELSE
' a$ = LEFT$(a$, place% - 2) + key$ + RIGHT$(a$, LEN(a$) - (place% - (2 - over%)))
'END IF
'IF place% > max% THEN place% = max%
b% = 0
IF place% = max% + 2 THEN palce% = place% - 1: b% = 1
a% = LEN(a$) - (place% - (2 - (over% OR ABS(LEN(a$) = max%)))): IF a% < 0 THEN a% = 0
a$ = LEFT$(a$, place% - 2) + key$ + RIGHT$(a$, a%)
IF place% > max% THEN place% = max%
GOSUB update2
CASE 8
IF place% > 1 THEN
b$ = ""
IF place% - 1 < LEN(a$) THEN b$ = RIGHT$(a$, LEN(a$) - (place% - 1))
a$ = LEFT$(a$, place% - 2) + b$
place% = place% - 1
GOSUB update2
END IF
CASE 13: EXIT DO
END SELECT
CASE 2
SELECT CASE ASC(RIGHT$(key$, 1))
CASE 82: over% = 1 - over%: start% = 30 - (over% * 30): LOCATE CSRLIN, POS(0), 1, start%, 31
CASE 75
IF place% > 1 THEN
place% = place% - 1
GOSUB update2
END IF
CASE 77
IF place% <= LEN(a$) THEN
place% = place% + 1
IF place% > max% THEN place% = max%
GOSUB update2
END IF
CASE 71: place% = 1: GOSUB update2
CASE 79: place% = LEN(a$) + 1
IF place% > max% THEN place% = max%
GOSUB update2
CASE 83
IF place% <= LEN(a$) THEN
a$ = LEFT$(a$, place% - 1) + RIGHT$(a$, LEN(a$) - place%)
GOSUB update2
END IF
END SELECT
END SELECT
LOOP
LOCATE CSRLIN, POS(0), 0, 31, 31
PRINT
minput$ = a$
EXIT FUNCTION
update2:
IF place% <= offset% OR (place% - (1 + rb% - lb%)) > offset% THEN
IF (place% - (1 + rb% - lb%)) > offset% THEN
offset% = (place% - (1 + rb% - lb%))
ELSE
offset% = place% - 1
END IF
END IF
cc% = (rb% - lb%) + 1
IF cc% + offset% > LEN(a$) THEN : cc% = LEN(a$) - offset%') + 1
IF cc% < 0 THEN cc% = 0
LOCATE lin%, lb%, 0: COLOR 7, 4: PRINT MID$(a$, 1 + ABS(cc% > 0) * offset%, ABS(cc% > 0 AND offset% > 0)); : COLOR 7, 1: PRINT MID$(a$, offset% + ABS(offset% > 0) + 1, (cc% - ABS(offset% > 0 AND cc% > 0)) - ABS(LEN(a$) - offset% > 1 + rb% - lb% AND cc% > ABS(offset% > 0 AND cc% > 0))); : COLOR 7, 4: PRINT MID$(a$, ABS(LEN(a$) - offset% > 1 + rb% - lb%) * offset% + 1 + rb% - lb%, ABS(LEN(a$) - offset% > 1 + rb% - lb%)); : COLOR 7, 0: PRINT SPACE$((rb% + 1) - POS(0));
LOCATE lin%, (place% - offset%) + lb% + -1, 1, start%, 31
RETURN
END FUNCTION
FUNCTION openf%
a% = 0
c 0
box 1, 1, 5, 80, 1: LOCATE 2, 2: PRINT "Open file:"
b$ = filen$
IF LEFT$(b$, 3) = "\\\" THEN b$ = ""
5 a$ = minput$(b$, 2, 2, 79, 78)
IF a$ <> "" THEN
IF exist%(a$) = 0 THEN LOCATE 4, 1: PRINT "File not found.": GOTO 5
filen$ = a$
a% = 1
END IF
openf% = a%
END FUNCTION
SUB printf
END SUB
SUB sads
mon$ = "C"
ON ERROR GOTO sadserr
SCREEN 1
ON ERROR GOTO term
IF mon$ = "C" THEN SCREEN 0: WIDTH 80
END SUB
SUB save
END SUB
SUB saveas
a% = 0
c 0
box 1, 1, 5, 80, 1: LOCATE 2, 2: PRINT "Save file as:"
b$ = filen$
IF LEFT$(b$, 3) = "\\\" THEN b$ = ""
6 a$ = minput$(b$, 2, 2, 79, 78)
IF a$ <> "" THEN
' insert test
IF exist%(a$) = 0 THEN LOCATE 4, 1: PRINT "File not found.": GOTO 5
This is stuff I did back when someone on these forums mentioned the RSA challenge.
These programs are public domain.
cpu 8086
org 0x0100
mov cx,0xffff
mov si, _num0
mov di, _num0
_loop
push si
push cx
call _inc256
pop cx
pop si
loop _loop
xor ah,ah
int 0x21
align 0x100
_inc256 ;proc near
;increments block at SI, storing result in block at DI
;it is your responsibility to not allow overflow beyond 255 digits
;destroys AX, CX, SI, carry flag. sets direction flag
;base 256 only
mov ah,[si]
test ah,ah
jnz _inc256c
mov byte [di+0xff],1 ;number was 0, becomes 1
mov byte [di],1
ret
_inc256c ;number wasn't 0, continue
xor cx,cx
push di ;di is saved for later
std
add si,0xff
add di,0xff
_inc256l ;loop area
inc cl ;length so far
cmp cl,ah
ja _inc256e ;exceeded previous length? yes --> extend
lodsb ;no --> continue
inc al
stosb
jz _inc256l ;carry? yes --> loop
mov al,ah
xchg ah,cl
sub cl,ah ;number of bytes to copy
jz _inc256d ;zero? yes --> done
clc
rcr cl,1
jnc _inc256w ;even?
movsb ;no --> make it so
_inc256w
jz _inc256d
_inc256wl
movsw
loop _inc256wl
_inc256d
pop di
mov [di],al
ret
_inc256e
inc ah
mov byte [di],1
pop di
mov [di],ah
ret
_cmp ;proc near
;compares blocks at SI and DI
;destroys SI, DI, CX, AX. clears direction flag
;sets/clears status flags based on comparison
;results to be used as if unsigned
;both bases
cld
cmpsb
jnz _cmpdone
mov cl,[si-1]
test cl,cl
jz _cmpdone
mov ch,0xff
xor ax,ax
sub ah,cl
add si,ax
add di,ax
xor ch,ch
repz cmpsb
_cmpdone
ret
align 0x100
_num0
db 1
resb 0xfe
db 0xff
_num1
resb 0x100
'B = carry
'AE = not carry
'E = zero
'BE = carry OR zero
'A = NOT carry AND NOT zero
DEFINT A-Z
DECLARE SUB inc (t0 AS INTEGER, t1 AS INTEGER)
DECLARE SUB show (t0 AS INTEGER)
DECLARE SUB ae (t0 AS INTEGER, t1 AS INTEGER)
DECLARE SUB format (t0 AS INTEGER, n AS LONG)
DIM SHARED st(0 TO 31) AS STRING * 255
DIM SHARED ln(0 TO 31) AS INTEGER
DIM SHARED aeres AS INTEGER
DIM SHARED isprime AS INTEGER
DIM SHARED flags AS INTEGER
CLS
format 0, 0
FOR i = 0 TO 111
inc 0, 0
show 0
NEXT i
SUB add (t0 AS INTEGER, t1 AS INTEGER, t2 AS INTEGER)
IF ln(t0) > ln(t1) THEN
li = t0
si = t1
ELSE
li = t1
si = t0
END IF
carry = 0
FOR i = 255 TO 256 - ln(si) STEP -1
t = ASC(MID$(st(t0), i, 1)) + ASC(MID$(st(t1), i, 1)) + carry
IF t > 9 THEN
t = t - 10
carry = 1
ELSE
carry = 0
END IF
MID$(st(t2), i, 1) = CHR$(t)
NEXT i
FOR i = i TO 256 - ln(li) STEP -1
t = ASC(MID$(st(li), i, 1))
IF carry THEN
t = t + 1
IF t < 10 THEN carry = 0 ELSE t = 0
END IF
MID$(st(t2), i, 1) = CHR$(t)
NEXT i
IF carry THEN
MID$(st(t2), i, 1) = CHR$(1)
ln(t2) = ln(li) + 1
ELSE
ln(t2) = ln(li)
END IF
END SUB
'safe for t0=t1
SUB cmp (t0 AS INTEGER, t1 AS INTEGER)
SELECT CASE ln(t0)
CASE IS < ln(t1): aeres = 0: EXIT SUB
CASE IS > ln(t1): aeres = -1: EXIT SUB
END SELECT
FOR i = 256 - ln(t0) TO 255
t = ASC(MID$(st(t1), i, 1))
SELECT CASE ASC(MID$(st(t0), i, 1))
CASE IS < t: aeres = 0: EXIT SUB
CASE IS > t: aeres = -1: EXIT SUB
END SELECT
NEXT i
aeres = -1
END SUB
SUB cop (t0, t1)
st(t1) = st(t0)
ln(t1) = ln(t0)
END SUB
SUB dec2b256 (t0, t1)
END SUB
SUB div (t0 AS INTEGER, t1 AS INTEGER, t2 AS INTEGER)
END SUB
SUB fastp (t0 AS INTEGER)
END SUB
SUB format (t0 AS INTEGER, n AS LONG)
DIM n1 AS LONG
n1 = n
i = 255
DO WHILE n1 > 0
z = n1 MOD 10
MID$(st(t0), i, 1) = CHR$(z)
n1 = n1 \ 10
i = i - 1
LOOP
ln(t0) = 255 - i
END SUB
'safe for t0=t1
SUB inc (t0 AS INTEGER, t1 AS INTEGER)
carry = 1
FOR i = 255 TO 256 - ln(t0) STEP -1
t = ASC(MID$(st(t0), i, 1))
IF carry THEN
t = t + 1
IF t < 10 THEN carry = 0 ELSE t = 0
END IF
MID$(st(t1), i, 1) = CHR$(t)
NEXT i
IF carry THEN
MID$(st(t1), i, 1) = CHR$(1)
ln(t1) = ln(t0) + 1
ELSE
ln(t1) = ln(t0)
END IF
END SUB
SUB show (t0 AS INTEGER)
PRINT "'";
FOR i = 256 - ln(t0) TO 255
PRINT CHR$(ASC(MID$(st(t0), i, 1)) + &H30);
NEXT i
PRINT "'"
END SUB
SUB slowp (t0 AS INTEGER)
END SUB
SUB subt (t0 AS INTEGER, t1 AS INTEGER, t2 AS INTEGER)
This is one I'm actually proud of. There was a time when my primary computer, the one I had in my room for programming and game playing, was an IBM 486DX2, with ATI VGA, Creative SoundBlaster, a CD-ROM drive, 8MB of RAM, a floppy drive, and a broken hard drive. I would boot off of Windows 95 DOS Mode floppies, create a RAM drive, and load my files into the RAM drive.
I had a "Game Empire" CD-ROM with hundreds of DOS and old Windows freeware and shareware games. The CD-ROM had scratches on it, so if you tried listing certain directories, it would take a long time, and then fail.
For whatever reason, XTPro was not ideal, and the DOS command prompt was cumbersome.
This program is my solution. It is FB, that is, File Browser. It is a quick file manager, that lets you quickly navigate a file system.
It was meant to be run from a specially designed Batch file, which I forgot to copy over. It would allow it to unload itself, execute a specified program, and then restart itself. The Batch file would run this program. When this program terminated, the batch file would check for fb-tmp.bat. If it existed, it would run it with call, and then rerun fb-tmp.bat. If it didn't exist, then the batch file would terminate back to the command prompt.
This program is public domain.
DECLARE FUNCTION tdid$ (n%)
DECLARE SUB prep ()
DECLARE SUB lt ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE FUNCTION exist% (efile$)
DECLARE SUB st ()
DECLARE SUB tu ()
DECLARE SUB su ()
DECLARE SUB getasc ()
DECLARE SUB exe (cm%)
DECLARE SUB upd ()
DECLARE SUB hlt (n%)
DECLARE SUB drw ()
DECLARE FUNCTION fln% (fl%, fc%)
DECLARE SUB ldr ()
DECLARE SUB getpath ()
DECLARE SUB getvar ()
DIM SHARED nexis%
DIM SHARED tmp$
DIM SHARED path$
DIM SHARED fls%
DIM SHARED maxf%
DIM SHARED maxa%
DIM SHARED maxt%
maxf% = 1024
maxa% = 5
maxt% = 32
DIM SHARED f$(0 TO maxf% - 1)
TYPE att
s AS LONG
t AS STRING * 1
END TYPE
DIM SHARED at(0 TO maxf% - 1) AS att
DIM SHARED asc$(0 TO maxa% - 1, 0 TO 2)
DIM SHARED bnd%
DIM SHARED c%, oc%
DIM SHARED offs%
DIM SHARED tf%
DIM SHARED sav%
DIM SHARED lst$(0 TO maxt% - 1)
DIM SHARED ord$
ord$ = "n"
getvar
getasc
IF exist%(tmp$ + "fb-tmp.bat") THEN KILL tmp$ + "fb-tmp.bat"
IF exist%(tmp$ + "fb-t.dat") THEN
OPEN tmp$ + "fb-t.dat" FOR INPUT AS 1
LINE INPUT #1, sav$
sav% = VAL(sav$)
sav$ = ""
FOR i% = 0 TO sav%
LINE INPUT #1, lst$(i%)
NEXT i%
CLOSE
KILL tmp$ + "fb-t.dat"
ELSE
FOR i% = 0 TO maxt% - 1
IF exist%(tmp$ + "fb-t." + tdid$(i%)) THEN KILL tmp$ + "fb-t." + tdid$(i%)
NEXT i%
END IF
GOTO 3
1 st
3 WIDTH 80: COLOR 7, 0: CLS
ldr
lt
c% = 0
offs% = 0
drw
DO
DO
k$ = INKEY$
IF k$ <> "" THEN EXIT DO
LOOP
a% = 0
oc% = c%
IF LEN(k$) = 1 THEN
SELECT CASE ASC(k$)
CASE 27: COLOR 7, 0: CLS : SYSTEM 'esc quit
CASE 8: IF LEN(path$) > 3 THEN SHELL "cd ..": GOTO 1 'bksp up level
CASE 13: 'enter execute/cd
IF fls% > 0 THEN
IF c% < bnd% THEN
SHELL "cd " + f$(c%)
ELSE
exe 1
END IF
GOTO 1
END IF
CASE 10
IF fls% > 0 THEN
IF c% < bnd% THEN
SHELL "cd " + f$(c%)
ELSE
exe 2
END IF
GOTO 1
END IF
CASE 127 '^bksp ch drv
COLOR 7, 0
LOCATE 19, 1: PRINT "Drive?"
LOCATE 19, 1
DO
d$ = UCASE$(INKEY$)
IF LEN(d$) = 1 THEN
SELECT CASE ASC(d$)
CASE 27: PRINT " ": EXIT DO
CASE 65 TO 90: PRINT " ": SHELL d$ + ":": GOTO 1
END SELECT
END IF
LOOP
CASE 65 TO 90 'LETTERS jump to letter
IF fls% > 0 THEN
FOR z% = 0 TO fls% - 1
y% = z% + c% + 1
IF y% >= fls% THEN y% = y% - fls%
IF UCASE$(LEFT$(f$(y%), 1)) = k$ THEN c% = y%: EXIT FOR
NEXT z%
a% = 1
END IF
CASE 116: IF c% >= bnd% THEN at(c%).t = "": tu: a% = 1 't tag
CASE 117: at(c%).t = " ": tu: a% = 1 'u untag
CASE 20 '^t tag all
FOR i% = bnd% TO fls% - 1
at(i%).t = ""
NEXT i%
a% = 2
CASE 21 '^u untag all
FOR i% = 0 TO fls% - 1
at(i%).t = " "
NEXT i%
a% = 2
CASE 105 'i invert all
FOR i% = bnd% TO fls% - 1
IF at(i%).t = " " THEN
at(i%).t = ""
ELSE
at(i%).t = " "
END IF
NEXT i%
a% = 2
CASE 114 'r rename
IF fls% > 0 THEN
COLOR 7, 0: LOCATE 19, 1
LINE INPUT "New name? "; a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
IF c% < bnd% THEN
SHELL "move /-y " + f$(c%) + " " + a$
ELSE
SHELL "ren " + f$(c%) + " " + a$
END IF
SHELL "pause"
GOTO 1
END IF
END IF
CASE 100 'd delete
IF fls% > 0 THEN
COLOR 7, 0
IF c% < bnd% THEN
LOCATE 19, 1
IF choice$("RD", "y", "n", CHR$(27), "", "", "", "", "", "", "") = "Y" THEN
SHELL "rd " + f$(c%)
CLS
SHELL "pause"
GOTO 1
END IF
LOCATE 19, 1: PRINT SPACE$(6)
ELSE
CLS
SHELL "del " + f$(c%) + " /p"
SHELL "pause"
GOTO 1
END IF
END IF
CASE 120 'x command prompt
COLOR 7, 0: CLS
PRINT "QBASIC is still in memory."
SHELL
SHELL "pause"
GOTO 1
CASE 110 'n new dir
COLOR 7, 0: LOCATE 19, 1
LINE INPUT "New dir? "; a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
SHELL "md " + a$
SHELL "pause"
GOTO 1
END IF
CASE 99 'c copy
IF fls% > 0 AND c% >= bnd% THEN
COLOR 7, 0: LOCATE 19, 1
PRINT "'copy /-y /b "; f$(c%); "' ? ";
LINE INPUT a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
SHELL "copy /-y /b " + f$(c%) + " " + a$
SHELL "pause"
GOTO 1
END IF
END IF
CASE 3 '^c copy tag
IF tf% > 0 THEN
COLOR 7, 0: LOCATE 19, 1
LINE INPUT "'copy /-y /b ' ... ' ' ? "; a$
CLS
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
FOR i% = bnd% TO fls%
IF at(i%).t <> " " THEN
b$ = choice$(f$(i%), "y", "n", CHR$(27), "", "", "", "", "", "", "")
IF b$ = CHR$(27) THEN EXIT FOR
IF b$ = "Y" THEN
SHELL "copy /-y /b " + f$(i%) + " " + a$
END IF
END IF
NEXT i%
SHELL "pause"
GOTO 1
END IF
END IF
CASE 111 'o order
LOCATE 19, 1
b$ = choice$("Sort order", CHR$(27), "n", "e", "s", "d", "", "", "", "", "")
IF b$ <> CHR$(27) THEN
ord$ = b$
GOTO 1
END IF
LOCATE 19, 1: PRINT SPACE$(13)
CASE 4 '^d del tag
IF tf% > 0 THEN
COLOR 7, 0: CLS
FOR i% = bnd% TO fls%
IF at(i%).t <> " " THEN
SHELL "del " + f$(i%) + " /p"
END IF
NEXT i%
SHELL "pause"
GOTO 1
END IF
CASE 97 'a attrib
IF fls% > 0 THEN
COLOR 7, 0: LOCATE 19, 1
PRINT "'attrib ' ? '"; f$(c%); "' ? ";
LINE INPUT a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
SHELL "attrib " + a$ + " " + f$(c%)
SHELL "pause"
GOTO 1
END IF
END IF
CASE 1 '^a attrib tag
IF tf% > 0 THEN
COLOR 7, 0: LOCATE 19, 1
LINE INPUT "'attrib ' ? ' ' ... ? "; a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
FOR i% = bnd% TO fls%
IF at(i%).t <> " " THEN
SHELL "attrib " + a$ + " " + f$(i%)
END IF
NEXT i%
SHELL "pause"
GOTO 1
END IF
END IF
CASE 118: 'v view
CLS
SHELL "type " + f$(c%) + " |more"
SHELL "pause"
CLS
a% = 2
CASE 122: 'z move
IF fls% > 0 AND c% >= bnd% THEN
COLOR 7, 0: LOCATE 19, 1
PRINT "'move /-y "; f$(c%); "' ? ";
LINE INPUT a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
SHELL "move /-y " + f$(c%) + " " + a$
SHELL "pause"
GOTO 1
END IF
END IF
CASE 26: '^z move tag
IF tf% > 0 THEN
COLOR 7, 0: LOCATE 19, 1
LINE INPUT "'move /-y ' ... ' ' ? "; a$
IF LTRIM$(a$) = "" THEN
a% = 2
ELSE
CLS
FOR i% = bnd% TO fls%
IF at(i%).t <> " " THEN
z$ = z$ + f$(i%) + ","
END IF
NEXT i%
z$ = LEFT$(z$, LEN(z$) - 1)
SHELL "move /-y " + z$ + " " + a$
SHELL "pause"
GOTO 1
END IF
END IF
CASE 102
LOCATE 19, 1
b$ = choice$("ASCII or Binary", CHR$(27), "a", "b", "", "", "", "", "", "", "")
IF b$ <> CHR$(27) THEN
LOCATE 19, 1: PRINT SPACE$(19)
LOCATE 19, 1
SELECT CASE b$
CASE "A": PRINT "'fc /l /n /t /1 ' ? ";
CASE "B": PRINT "'fc /b ' ? ";
END SELECT
LINE INPUT a$
IF LTRIM$(a$) <> "" THEN
CLS
SELECT CASE b$
CASE "A": SHELL "fc /l /n /t /1 " + a$ + " |more"
CASE "B": PRINT "fc /b " + a$ + " |more"
END SELECT
SHELL "pause"
END IF
END IF
CLS
a% = 2
END SELECT
ELSE
IF LEN(k$) = 2 THEN
SELECT CASE ASC(RIGHT$(k$, 1))
CASE 72: c% = c% - 5
CASE 75: c% = c% - 1
CASE 77: c% = c% + 1
CASE 80: c% = c% + 5
CASE 73: offs% = offs% - 15: c% = c% - 75: a% = 2
CASE 81: offs% = offs% + 15: c% = c% + 75: a% = 2
CASE 71: c% = 0
CASE 79: c% = fls% - 1
'CASE 59: exe 3: GOTO 1
'CASE 60: exe 4: GOTO 1
END SELECT
END IF
IF a% = 0 THEN a% = 1
END IF
IF c% >= fls% THEN c% = fls% - 1
IF c% < 0 THEN c% = 0
oof% = offs%
IF offs% > (c% \ 5) THEN offs% = (c% \ 5)
IF offs% > ((fls% - 1) \ 5) - 14 THEN offs% = ((fls% - 1) \ 5) - 14
IF offs% < ((c% - 1) \ 5) - 14 THEN offs% = ((c% - 1) \ 5) - 14
IF offs% < 0 THEN offs% = 0
IF offs% <> oof% THEN a% = 2
IF a% = 1 THEN upd
IF a% = 2 THEN drw
a% = 0
LOOP
exis:
nexis% = 0
RESUME NEXT
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 4
PRINT pr$; "? ";
LOCATE , , 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE , , 0
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB drw
LOCATE 1, 1
COLOR 11, 1
PRINT path$; SPACE$(81 - POS(0));
COLOR 7, 1
PRINT STRING$(80, "Ä");
FOR i% = 0 TO 74
hlt i% + offs% * 5
NEXT i%
COLOR 11, 1
PRINT STRING$(80, "Ä");
COLOR 7, 1
su
tu
LOCATE 21, 1: PRINT "Dirs:"; bnd%; " Files:"; fls% - bnd%; TAB(79); " ";
END SUB
SUB exe (cm%)
fl$ = f$(c%)
IF cm% < 3 THEN
a% = INSTR(fl$, ".")
IF a% > 0 THEN et$ = UCASE$(RIGHT$(fl$, LEN(fl$) - a%))
a% = 0
FOR i% = 0 TO maxa% - 1
IF UCASE$(asc$(i%, 0)) = et$ THEN a% = i%
NEXT i%
END IF
IF cm% > 2 THEN cm% = cm% - 2
ln$ = asc$(a%, cm%)
et$ = ""
a% = 0
IF LEFT$(ln$, 1) = "%" THEN a% = 1
FOR i% = 1 + a% TO LEN(ln$)
n$ = MID$(ln$, i%, 1)
IF n$ = "$" THEN
IF i% < LEN(ln$) THEN
IF MID$(ln$, i% + 1, 1) = "$" THEN
et$ = et$ + n$
i% = i% + 1
GOTO 2
END IF
END IF
et$ = et$ + fl$
ELSE
et$ = et$ + n$
END IF
2 NEXT i%
IF a% = 0 THEN
COLOR 7, 0: CLS
PRINT "QBASIC is still in memory."
SHELL et$
SHELL "pause"
ELSE
OPEN tmp$ + "fb-tmp.bat" FOR OUTPUT AS 1
PRINT #1, "@echo off"
PRINT #1, et$
CLOSE
IF sav% > 0 THEN prep
COLOR 7, 0: CLS : SYSTEM
END IF
END SUB
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO 0'term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB getpath
SHELL "cd > " + tmp$ + "fb-1.tmp"
OPEN tmp$ + "fb-1.tmp" FOR INPUT AS 1
LINE INPUT #1, path$
CLOSE
KILL tmp$ + "fb-1.tmp"
END SUB
SUB getvar
tmp$ = ENVIRON$("TEMP")
IF RIGHT$(tmp$, 1) <> "\" THEN tmp$ = tmp$ + "\"
END SUB
SUB hlt (i%)
COLOR 14, 0
n% = i% - offs% * 5
nl% = (n% \ 5) + 3
nc% = (n% MOD 5) * 16 + 1
LOCATE nl%, nc%
IF i% >= fls% THEN
PRINT " ";
COLOR 7, 1
PRINT SPACE$(15)
ELSE
PRINT at(i%).t;
COLOR 7, 1
a$ = " "
IF i% = c% THEN
COLOR 15, 4
IF i% < bnd% THEN COLOR 14, 4: a$ = "fd "
ELSE
IF i% < bnd% THEN COLOR 11, 1: a$ = "fd "
END IF
PRINT a$; f$(i%); SPACE$(12 - LEN(f$(i%)))
COLOR 7, 1
END IF
COLOR 7, 0
END SUB
SUB ldr
getpath
FOR a% = 0 TO maxf% - 1
at(a%).t = " "
NEXT a%
SHELL "dir /a:d /o:" + ord$ + " /b > " + tmp$ + "fb-2.tmp"
OPEN tmp$ + "fb-2.tmp" FOR INPUT AS 1
i% = 0
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, f$(i%)
f$(i%) = RIGHT$(f$(i%), 12)
at(i%).s = -1
i% = i% + 1
LOOP
CLOSE
KILL tmp$ + "fb-2.tmp"
bnd% = i%
SHELL "dir /a:-d /o:" + ord$ + " /b > " + tmp$ + "fb-3.tmp"
OPEN tmp$ + "fb-3.tmp" FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, f$(i%)
f$(i%) = RIGHT$(f$(i%), 12)
OPEN f$(i%) FOR BINARY AS 2
at(i%).s = LOF(2)
CLOSE 2
i% = i% + 1
LOOP
CLOSE
KILL tmp$ + "fb-3.tmp"
FOR a% = i% TO maxf% - 1
f$(a%) = ""
at(i%).s = 0
NEXT a%
fls% = i%
END SUB
SUB lt
a% = -1
FOR i% = 0 TO maxt% - 1
IF path$ = lst$(i%) THEN a% = i%: EXIT FOR
NEXT i%
IF a% = -1 THEN EXIT SUB
OPEN tmp$ + "fb-t." + tdid$(a%) FOR INPUT AS 1
LINE INPUT #1, p$
IF p$ <> path$ THEN
CLOSE
lst$(a%) = ""
IF exist%(tmp$ + "fb-t." + tdid$(a%)) THEN KILL tmp$ + "fb-t." + tdid$(a%)
EXIT SUB
END IF
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, t$
FOR i% = bnd% TO fls% - 1
IF t$ = f$(i%) THEN at(i%).t = ""
NEXT i%
LOOP
CLOSE
sav% = 0
FOR i% = 0 TO maxt% - 1
IF lst$(i%) <> "" THEN sav% = sav% + 1
NEXT i%
END SUB
SUB prep
OPEN tmp$ + "fb-t.dat" FOR OUTPUT AS 1
PRINT #1, sav%
FOR i% = 0 TO sav%
PRINT #1, lst$(i%)
NEXT i%
END SUB
SUB st
a% = -1
FOR i% = 0 TO maxt% - 1
IF path$ = lst$(i%) THEN a% = i%: EXIT FOR
NEXT i%
IF a% = -1 THEN
FOR i% = 0 TO maxt% - 1
IF "" = lst$(i%) THEN a% = i%: EXIT FOR
NEXT i%
END IF
IF tf% > 0 THEN
IF a% = -1 THEN
LOCATE 19, 1: COLOR 7, 0
b$ = choice$("Tagged list full. Clear list", "y", "n", "", "", "", "", "", "", "", "")
LOCATE 19, 1: PRINT SPACE$(80);
IF b$ = "Y" THEN
FOR i% = 0 TO maxt% - 1
lst$(i%) = ""
IF exist%(tmp$ + "fb-t." + tdid$(i%)) THEN KILL tmp$ + "fb-t." + tdid$(i%)
NEXT i%
a% = 0
ELSE
EXIT SUB
END IF
END IF
lst$(a%) = path$
OPEN tmp$ + "fb-t." + tdid$(a%) FOR OUTPUT AS 1
PRINT #1, path$
FOR i% = bnd% TO fls% - 1
IF at(i%).t <> " " THEN PRINT #1, f$(i%)
NEXT i%
CLOSE
ELSE
IF a% > -1 THEN
IF lst$(a%) <> "" THEN
lst$(a%) = ""
IF exist%(tmp$ + "fb-t." + tdid$(a%)) THEN KILL tmp$ + "fb-t." + tdid$(a%)
END IF
END IF
END IF
sav% = 0
FOR i% = 0 TO maxt% - 1
IF lst$(i%) <> "" THEN sav% = sav% + 1
NEXT i%
END SUB
SUB su
COLOR 7, 0
LOCATE 20, 1
IF c% >= bnd% THEN
PRINT "File size:"; at(c%).s; TAB(39); " "
ELSE
PRINT SPACE$(40)
END IF
END SUB
FUNCTION tdid$ (n%)
n$ = LTRIM$(STR$(n%))
n$ = STRING$(3 - LEN(n$), "0") + n$
tdid$ = n$
END FUNCTION
SUB tu
tf% = 0
COLOR 7, 0
LOCATE 20, 41
FOR i% = bnd% TO fls% - 1
IF at(i%).t <> " " THEN tf% = tf% + 1: ts& = ts& + at(i%).s
NEXT i%
PRINT "TF:"; tf%; "B:"; ts&; "Lst Fds:"; sav%; TAB(79); " ";
END SUB
I don't remember this one very well. This program has a menu interface, and was probably one of my usages of such an interface.
DECLARE SUB nent ()
DECLARE SUB opne ()
DECLARE FUNCTION wt$ (n%)
DECLARE SUB loadent ()
DECLARE SUB saveent ()
DECLARE FUNCTION trim$ (a$, a%)
' $DYNAMIC
DECLARE SUB cbox (hight%, wid%, title$)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB action (code%)
DECLARE SUB box (sl%, sc%, el%, ec%, all%)
DECLARE SUB drwmenu ()
DECLARE SUB menusys ()
DECLARE SUB c (cm%)
DECLARE FUNCTION exist% (efile$)
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED nummenus%
DIM SHARED p1%
DIM SHARED p2%
DIM SHARED md%
DIM SHARED pp%
DIM SHARED tl%
DIM SHARED tc%
DIM SHARED prn$
DIM SHARED ent$
DIM SHARED Mon$
TYPE compt
file AS STRING * 64
nam AS STRING * 32
typ AS INTEGER
ind AS LONG
END TYPE
DIM SHARED comp(-1 TO 19) AS compt
DIM SHARED entnam AS STRING * 32
DIM SHARED path$
prn$ = "PRN"
IF exist%("fin-per.dat") = 1 THEN
OPEN "fin-per.dat" FOR INPUT AS 1
LINE INPUT #1, prn$
LINE INPUT #1, ent$
CLOSE
IF exist%(ent$) = 0 THEN
2 SELECT CASE choice$("<N>ew entity, <O>pen entity, or <E>xit", "N", "O", "E", "", "", "", "", "", "", "")
CASE "N": nent
CASE "O": opne
CASE "E": c 0: SYSTEM
END SELECT
IF ent$ = "" THEN GOTO 2
END IF
END IF
OPEN "fin-per.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
nummenus% = 3
TYPE menudat
ni AS INTEGER
text AS STRING * 16
END TYPE
TYPE itemdat
text AS STRING * 14
code AS INTEGER
END TYPE
DIM SHARED menu(1 TO nummenus%) AS menudat
DIM SHARED items(1 TO nummenus%, 1 TO 20) AS itemdat
DIM SHARED shortcut$(-20 TO -1)
RESTORE Short
FOR i% = -1 TO -20 STEP -1
READ shortcut$(i%)
NEXT i%
RESTORE Menudata
FOR i% = 1 TO nummenus%
READ menu(i%).text
READ menu(i%).ni
NEXT i%
RESTORE M1
FOR i% = 1 TO menu(1).ni
READ items(1, i%).text
READ items(1, i%).code
NEXT i%
RESTORE M2
FOR i% = 1 TO menu(2).ni
READ items(2, i%).text
READ items(2, i%).code
NEXT i%
RESTORE M3
FOR i% = 1 TO menu(3).ni
READ items(3, i%).text
READ items(3, i%).code
NEXT i%
c 1: CLS
menusys
SYSTEM
term:
c 0
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
Menudata:
DATA "File",6,"Accounts",3,"Reports",3
M1:
DATA "Open...",1,"New...",2,"Edit...",3,"Backup",4,"Options...",5,"Exit",6
M2:
DATA "Reg...",7,"Edit...",8,"New...",9
M3:
DATA "Net Worth...",10,"Income...",11,"Expense...",12
Short:
DATA "","","","","","","","","","","","","","","","","","","",""
sadserr:
Mon$ = "M"
RESUME NEXT
REM $STATIC
SUB action (code%)
drwmenu
1
SELECT CASE code%
CASE 1: opne
OPEN "fin-per.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
CASE 2: nent
CASE 3:
DO
c 3: CLS : c 4: PRINT "---Edit Entity---"
c 3
PRINT "-1 "; entnam
FOR i% = 0 TO 19
LOCATE i% + 3, 1
PRINT LTRIM$(STR$(i%)); " "; RTRIM$(comp(i%).file); " "; trim$(RTRIM$(comp(i%).file), 65 - POS(0)); " "; TAB(70); wt$(comp(a%).typ)
NEXT i%
LINE INPUT "('' to cancel.) Item to change? "; a$
a$ = LTRIM$(a$)
IF a$ = "" THEN CLS : EXIT SUB
a% = VAL(a$)
IF a% = -1 THEN
CLS : PRINT "---Edit Entity---"
PRINT "Current:"
PRINT entnam
LINE INPUT "New name? "; entnam: saveent
END IF
IF a% > -1 AND a% < 20 THEN
CLS : PRINT "---Edit Entity---"
PRINT "Current:"
PRINT a%
PRINT comp(a%).file
PRINT comp(a%).nam
PRINT wt$(comp(a%).typ)
a$ = comp(a%).file
LINE INPUT "('' for no component.) New component file? "; comp(a%).file
comp(a%).file = LTRIM$(RTRIM$(UCASE$(comp(a%).file)))
IF exist%(comp(a%).file) = 0 THEN
PRINT "File not found.": comp(a%).file = a$: SLEEP 2
ELSE
OPEN comp(a%).file FOR INPUT AS 1
LINE INPUT #1, b$
CLOSE
IF b$ <> "Valid Fin-Per Component file." THEN
PRINT "Not a Fin-Per Component file.": comp(a%).file = a$: CLOSE : SLEEP 2
ELSE
saveent
END IF
END IF
END IF
LOOP
CASE 4
CASE 5: c 3: CLS : c 4: PRINT "---Options---"
c 3
PRINT "Current printer device: "; prn$
a$ = prn$
LINE INPUT "New device? "; prn$
prn$ = LTRIM$(RTRIM$(prn$))
IF prn$ = "" THEN prn$ = a$
OPEN "fin-per.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
CLS
CASE 6: c 0: SYSTEM
CASE 8: c 3: CLS : c 4: PRINT "---New Componant---"
c 3
a% = -1
FOR i% = 0 TO 19
IF LTRIM$(comp(i%).file) = "" THEN a% = i%
NEXT i%
IF a% = -1 THEN
PRINT "The new component will be created but will not added to the current entity."
ELSE
PRINT "The new component will become component"; a%; "in the current entity."
END IF
DO
LINE INPUT "('' to cancel.) Component file? "; comp(i%).file
'>>> ent$ = LTRIM$(RTRIM$(comp(i%).file))
IF comp(i%).file = "" THEN comp(i%).file = be$: CLS : EXIT SUB
IF exist%(comp(i%).file) = 1 THEN
PRINT "File already exists."
ELSE
LINE INPUT "Component name? "; comp(i%).nam
DO
PRINT "Component types:"
PRINT "1-Savings Account, 2-Checking Account, 3-Liabillity Account."
INPUT "Component type"; comp(i%).typ
IF comp(i%).typ > 0 AND comp(i%) < 4 THEN EXIT DO
LOOP
'saveent
CLS
EXIT SUB
END IF
LOOP
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
LINE INPUT " To? "; to$
LOCATE tl% + 2, tc%
IF exist%(to$) = 1 THEN
IF choice$("File already exists. Overwrite", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN : CLS : EXIT SUB
KILL to$
END IF
'copy from$, to$, 1, tl% + 3
CLS
CASE 6: cbox 4, 77, "Move": LOCATE tl%, tc%
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
LINE INPUT " To? "; to$
LOCATE tl% + 2, tc%
IF exist%(to$) = 1 THEN
IF choice$("File already exists. Overwrite", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN : CLS : EXIT SUB
KILL to$
END IF
'copy from$, to$, 1, tl% + 3
'compare from$, to$, tl% + 3
KILL from$
CLS
CASE 7: cbox 3, 77, "Compare": LOCATE tl%, tc%
LINE INPUT "File1? "; from$
LOCATE tl% + 1, tc%
IF exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
LINE INPUT "File2? "; to$
LOCATE tl% + 2, tc%
IF exist%(to$) = 0 THEN PRINT "File '"; to$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
'compare from$, to$, tl% + 2
SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
CASE 8: cbox 2, 77, "Erase": LOCATE tl%, tc%
LINE INPUT "File? "; from$
LOCATE tl% + 1, tc%
IF exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
IF choice$("Are you sure", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN KILL from$
CLS
CASE 9: cbox 2, 77, "Rename": LOCATE tl%, tc%
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
LINE INPUT " To? "; to$
NAME from$ AS to$
SLEEP: WHILE INKEY$ <> "": WEND: CLS : EXIT SUB
CASE -1: code% = 3: GOTO 1
CASE 10: cbox 1, 77, "File List": LOCATE tl%, tc%: LINE INPUT "In directory? "; from$: CLS : FILES from$: SLEEP: WHILE INKEY$ <> "": WEND: CLS
CASE 11: cbox 1, 77, "Change Directory": LOCATE tl%, tc%: LINE INPUT "Dir? "; from$: CLS : CHDIR from$
CASE 12: cbox 1, 77, "Make Directory": LOCATE tl%, tc%: LINE INPUT "New directory? "; from$: CLS : MKDIR from$
CASE 13: cbox 2, 80, "Remove Directory": LOCATE tl%, tc%
LINE INPUT "Dir? "; from$
LOCATE tl% + 1, tc%
IF choice$("Are you sure", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN RMDIR from$
CLS
CASE 14: cbox 1, 77, "Printer Setup"
LOCATE tl%, tc%: PRINT "Current device is '"; prn$; "'. "; : LINE INPUT "Device associated with printer? "; prn$
IF prn$ = "" THEN prn$ = "PRN"
OPEN "c:\menu.dat" FOR OUTPUT AS #1
PRINT #1, prn$
CLOSE
CLS
END SELECT
CLS
END SUB
SUB box (sl%, sc%, el%, ec%, all%)
LOCATE sl%, sc%: PRINT "Ú"; STRING$((ec% - sc%) - 1, "Ä"); "¿"
IF all% = 1 THEN
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³"; SPACE$((ec% - sc%) - 1); "³"
NEXT i%
ELSE
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³": LOCATE i%, ec%: PRINT "³"
NEXT i%
END IF
LOCATE el%, sc%: PRINT "À"; STRING$((ec% - sc%) - 1, "Ä"); "Ù"
END SUB
SUB c (cm%)
IF Mon$ = "M" THEN
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 1, 0 'menu high underl, black
CASE 2: COLOR 0, 10 'menu norm black, high white
CASE 3: COLOR 7, 0 'text norm white, black
CASE 4: COLOR 10, 0 'text high high white, black
CASE 5: COLOR 9, 0 'text red high underl, black
CASE 6: COLOR 1, 0 'text other underl, black
END SELECT
ELSE
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 11, 0 'menu high br cyan, black
CASE 2: COLOR 11, 1 'menu norm br cyan, blue
CASE 3: COLOR 7, 1 'text norm white, blue
CASE 4: COLOR 15, 1 'text high br white, blue
CASE 5: COLOR 12, 1 'text red br red, blue
CASE 6: COLOR 10, 1 'text other br greed, blue
END SELECT
END IF
cp% = cc%
cc% = cm%
END SUB
SUB cbox (hight%, wid%, title$)
IF hight% > 20 THEN hight% = 20
IF wid% > 77 THEN wid% = 77
zhight% = hight%
IF hight% \ 2 = hight% / 2 THEN zhight% = hight% - 1
sl% = INT(11.5 - INT(zhight% / 2 + .5))
IF hight% \ 2 = hight% / 2 THEN zhight% = hight% + 1
el% = INT(11.5 + INT(zhight% / 2 + .5))
zwid% = wid%
IF wid% / 2 <> wid% \ 2 THEN zwid% = wid% - 1
sc% = 39 - INT(zwid% / 2 + .5)
IF wid% / 2 <> wid% \ 2 THEN zwid% = wid% + 1
ec% = 41 + INT(zwid% / 2 - .5)
box sl%, sc%, el%, ec%, 1
LOCATE sl%, 40 - INT(LEN(title$) / 2 + .5): PRINT title$
tl% = sl% + 1
tc% = sc% + 1
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
c 1
IF Mon$ = "C" THEN c 4
PRINT pr$; "? ";
LOCATE , , 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE , , 0
PRINT sl$
c 1
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB drwmenu
LOCATE 1, 1
FOR i% = 1 TO nummenus%
IF i% = p1% THEN c 2
PRINT menu(i%).text;
c 1
NEXT i%
IF p1% <> pp% THEN COLOR 0, 0: box 2, ((pp% - 1) * 16) + 1, menu(pp%).ni + 3, ((pp% - 1) * 16) + 17, 1: c 1: pp% = p1%
IF md% = 1 THEN
box 2, ((p1% - 1) * 16) + 1, menu(p1%).ni + 3, ((p1% - 1) * 16) + 17, 0
FOR i% = 1 TO menu(p1%).ni
LOCATE i% + 2, ((p1% - 1) * 16) + 2
IF i% = p2% THEN c 2
PRINT items(p1%, i%).text
c 1
NEXT i%
END IF
PRINT
END SUB
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB getpath
SHELL "cd > " + ENVIRON$("TEMP") + "\fin-per.tmp"
OPEN ENVIRON$("TEMP") + "\fin-per.tmp" FOR INPUT AS 1
LINE INPUT #1, path$
CLOSE
KILL ENVIRON$("TEMP") + "\fin-per.tmp"
IF RIGHT$(path$, 1) <> "\" THEN path$ = path$ + "\"
END SUB
SUB loadent
OPEN ent$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, entnam
FOR i% = 0 TO 19
LINE INPUT #1, comp(i%).file
NEXT i%
CLOSE
FOR i% = 0 TO 19
3 a% = 0
IF comp(i%).file <> "" THEN
IF exist%(comp(a%).file) = 0 THEN
CLS : PRINT "File '"; RTRIM$(comp(i%).file); "' not found.": a% = 1
ELSE
OPEN comp(i%).file FOR INPUT AS 1
LINE INPUT #1, a$
IF a$ <> "Valid Fin-Per Component file." THEN CLOSE : CLS : PRINT "'"; RTRIM$(comp(i%).file); "'Not a Fin-Per Component file.": a% = 1
IF a% = 1 THEN
CLOSE
LINE INPUT "('' for no component.) New component file? "; comp(a%).file
GOTO 3
END IF
LINE INPUT #1, comp(i%).nam
INPUT #1, comp(i%).typ
END IF
ELSE
comp(i%).nam = ""
comp(i%).typ = 0
END IF
NEXT i%
END SUB
SUB menusys
p1% = 1
p2% = 0
md% = 0
pp% = 1
DO
drwmenu
key$ = INKEY$
SELECT CASE key$
CASE "":
CASE CHR$(0) + CHR$(80): md% = 1: p2% = p2% + 1
IF p2% > menu(p1%).ni THEN p2% = 1
CASE CHR$(0) + CHR$(72): md% = 1: p2% = p2% - 1
IF p2% < 1 THEN p2% = menu(p1%).ni
CASE CHR$(0) + CHR$(75): pp% = p1%: p1% = p1% - 1: p2% = md%
IF p1% < 1 THEN p1% = nummenus%
CASE CHR$(0) + CHR$(77): pp% = p1%: p1% = p1% + 1: p2% = md%
IF p1% > nummenus% THEN p1% = 1
CASE CHR$(27): pp% = p1%: md% = 0: p2% = 0: tp% = p1%: p1% = 0: drwmenu: p1% = tp%: pp% = tp%
CASE CHR$(13), " ":
IF md% = 0 THEN
md% = 1: p2% = 1
ELSE
t1% = p1%: t2% = p2%
md% = 0: p1% = 0: p2% = 0
action items(t1%, t2%).code
p1% = 1: pp% = 1
END IF
CASE ELSE
FOR i% = -20 TO -1
IF UCASE$(key$) = UCASE$(shortcut$(i%)) THEN action i%
NEXT i%
END SELECT
LOOP
' up 72 left 75 right 77 down 80 lf 10
END SUB
SUB nent
c 3: CLS : c 4: PRINT "---New Entity---"
c 3
be$ = ent$
DO
LINE INPUT "('' to cancel.) Entity file? "; ent$
ent$ = LTRIM$(RTRIM$(ent$))
IF ent$ = "" THEN ent$ = be$: CLS : EXIT SUB
IF exist%(ent$) = 1 THEN
PRINT "File already exists."
ELSE
LINE INPUT "Entity name? "; entnam
FOR i% = 0 TO 19
comp(i%).file = ""
NEXT i%
saveent
CLS
EXIT SUB
END IF
LOOP
END SUB
SUB opne
be$ = ent$
CLS
PRINT "---Open Entity---"
DO
PRINT
SHELL "dir /w | more"
SHELL "cd"
LINE INPUT "('' to cancel, dir name to change path.) Open entity? "; ent$
ent$ = LTRIM$(RTRIM$(ent$))
IF ent$ = "" THEN ent$ = be$: CLS : EXIT SUB
IF exist%(ent$ + "\nul") = 1 THEN
SHELL "cd " + ent$
ELSEIF exist%(ent$) = 1 THEN
OPEN ent$ FOR INPUT AS 1
a% = 0
IF EOF(1) THEN
a% = 1
ELSE
LINE INPUT #1, a$
IF a$ <> "Valid Fin-Per Entity file." THEN a% = 1
END IF
CLOSE
IF a% = 1 THEN
PRINT "Not a valid Fin-Per entity file."
ELSE
loadent
CLS
EXIT SUB
END IF
ELSE
PRINT "File not found."
END IF
LOOP
END SUB
SUB sads
Mon$ = "C"
ON ERROR GOTO sadserr
SCREEN 1
ON ERROR GOTO term
IF Mon$ = "C" THEN SCREEN 0: WIDTH 80
END SUB
SUB saveent
OPEN ent$ FOR OUTPUT AS 1
PRINT #1, "Valid Fin-Per Entity file."
PRINT #1, entnam
FOR i% = 0 TO 19
PRINT #1, comp(i%).file
NEXT i%
CLOSE
loadent
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
FUNCTION trim$ (a$, a%)
IF LEN(a$) > a% THEN a$ = LEFT$(a$, a%)
trim$ = a$
END FUNCTION
FUNCTION wt$ (n%)
END FUNCTION
This message has been edited by MCalkins on Feb 23, 2011 2:07 AM
' Now us MS-DOS users can see fish too. Windows 98 has lost its monopoly.
DECLARE FUNCTION correct% (n%)
delay& = 4000 ' The bigger the number, the slower the fish.
' Use to adjust speed for different computers.
music% = 0 ' 1 is enabled. 0 is disabled. 2 is use noise.
upDown% = 1 ' For enabling or disabling variation of y. 1 is enabled. 0 is disabled.
screenMode% = 9 ' For CGA, use 1. For VGA or EGA, use 9. For Herc., use 3.
music$ = "mlmbo5p2l16ababl4g.dec.p4l16ababl4g.de>c.<p2" ' My guess at the notes of The Good, Bad, and Ugly.
ON ERROR GOTO term
IF music% = 1 THEN ON PLAY(2) GOSUB playbackground
DIM SHARED dir%
oSM% = screenMode%
1 ON ERROR GOTO term
SELECT CASE screenMode%
CASE 1 ' Will work on CGA, EGA, and VGA cards.
totalX% = 320
totalY% = 200
totalC% = 3
mag% = 1
CASE 9 ' Will work on VGA. I think it will work on EGA as well.
totalX% = 640
totalY% = 350
totalC% = 15
mag% = 2
CASE 3 ' Will work on Hercules.
totalX% = 720
totalY% = 348
totalC% = 1
mag% = 2
CASE ELSE
PRINT "Why don't you like the choices I gave you? If you really want to use that mode,"
PRINT "modify the program. Press any key to detect a usable screen mode."
screenMode% = -1
SLEEP: WHILE INKEY$ <> "": WEND
END SELECT
ON ERROR GOTO videoCard
SCREEN screenMode%
ON ERROR GOTO term
RANDOMIZE TIMER
oMag% = mag%
IF music% = 1 THEN PLAY ON
IF music% = 1 THEN PLAY music$
DO
mag% = oMag% * (RND * 1.5 + .25) ' Choses a random size.
oriY% = INT(RND * (totalY% - 55 * mag% * 2)) + 55 * mag% ' Choses a random y location.
var1Y% = INT(RND * 6) ' Choses a random variation of y (var. = var1Y * SIN(x / 10)).
var2Y% = INT(RND * 26) ' Choses a random variation of y (var. = var2Y * SIN(x / divisor)).
divisor% = INT(RND * 20) + 80 ' Choses a random divisor for big sine wave.
var1Y% = var1Y% * upDown% ' Enables or disables variation of y.
var2Y% = var2Y% * upDown%
c% = INT(RND * totalC%) + 1 ' Choses a random color.
s! = ((INT(RND * 4) + 2) / 2) * mag% ' Choses a random fish speed (the number of pixels jumped per loop).
dir% = INT(RND * 2) ' Choses a random direction.
IF dir% = 1 THEN ' 1 is left to right.
f1% = -50 * mag%
f2% = totalX% + 1
f3! = 1 * s!
ELSE ' 0 is right to left.
f1% = totalX% + 1
f2% = -50 * mag%
f3! = -1 * s!
END IF
IF screenMode% = 1 THEN
COLOR 0, INT(RND * 2) ' For screen mode 1, choses random palette.
END IF
FOR x! = f1% TO f2% STEP f3!
LINE (x! + 1, y% + 1)-(x! + 50 * mag%, y% + 50 * mag%), 0, BF ' Clears old fish.
y% = oriY% + SIN(x! / 10) * var1Y% + SIN(x! / divisor%) * var2Y%
IF music% = 2 THEN SOUND (y% - oriY%) * 10 + 300, .182
' Draws new fish:
' body:
CIRCLE (x! + correct%(30) * mag%, y% + 25 * mag%), 15 * mag%, c%, , , .5
' tail:
LINE (x! + correct%(5) * mag%, y% + 20 * mag%)-(x! + correct%(15) * mag%, y% + 25 * mag%), c%
LINE (x! + correct%(5) * mag%, y% + 30 * mag%)-(x! + correct%(15) * mag%, y% + 25 * mag%), c%
LINE (x! + correct%(5) * mag%, y% + 20 * mag%)-(x! + correct%(9) * mag%, y% + 25 * mag%), c%
LINE (x! + correct%(5) * mag%, y% + 30 * mag%)-(x! + correct%(9) * mag%, y% + 25 * mag%), c%
' eye:
CIRCLE (x! + correct%(40) * mag%, y% + 23 * mag%), 1 * mag%, c%
' fins:
LINE (x! + correct%(28) * mag%, y% + 17 * mag%)-(x! + correct%(26) * mag%, y% + 11 * mag%), c%
LINE (x! + correct%(32) * mag%, y% + 17 * mag%)-(x! + correct%(26) * mag%, y% + 11 * mag%), c%
LINE (x! + correct%(28) * mag%, y% + 33 * mag%)-(x! + correct%(26) * mag%, y% + 39 * mag%), c%
LINE (x! + correct%(32) * mag%, y% + 33 * mag%)-(x! + correct%(26) * mag%, y% + 39 * mag%), c%
IF INKEY$ <> "" THEN PLAY OFF: SCREEN 0: WIDTH 80, 25: SYSTEM
FOR i& = 1 TO delay&: NEXT i& ' Time delay
NEXT x!
LOOP
playbackground: ' Subroutine for music event-trapping.
PLAY music$
RETURN
term: ' Subroutine for error event-trapping.
PLAY OFF
SCREEN 0: WIDTH 80, 25
PRINT "Error"; ERR
SYSTEM
videoCard: ' Subroutine for error event-trapping. To determine best screen mode.
SELECT CASE screenMode%
CASE 9
PRINT "Video card is not VGA or EGA. Testing for CGA."
screenMode% = 1
CASE 1
PRINT "Video card is not CGA. Testing for Hercules."
screenMode% = 3
CASE 3
IF msherc% = 0 THEN
PRINT "Fish could not use screen mode 3. Fish will try to load MSHERC.COM."
PRINT
msherc% = 1
SHELL "msherc > c:\fish.tmp"
SHELL "type c:\fish.tmp"
OPEN "c:\fish.tmp" FOR INPUT AS #1
LINE INPUT #1, t$
CLOSE
KILL "c:\fish.tmp"
IF t$ = "Bad command or file name" THEN
PRINT
PRINT "MSHERC could not be found. Try running it manually and then run Fish again."
SYSTEM
END IF
PRINT
RESUME
ELSE
PRINT "Video card not Hercules. "
IF oSM% = 3 THEN SLEEP 3: GOTO 2
PRINT "Sorry, you need a video card capable of graphics to run Fish."
PRINT
SYSTEM
END IF
CASE ELSE
2 screenMode% = 9
PRINT "Testing for VGA or EGA."
END SELECT
SLEEP 3
RESUME 1
' This function inverts the x axis on fish traveling right to left.
FUNCTION correct% (n%)
IF dir% = 1 THEN
t% = n%
ELSE
t% = 50 - n%
END IF
correct% = t%
END FUNCTION
' Magnification factor; < 1 for zoomed out, 1 for normal, > 1 for zoomed in:
mag! = 2
' Note: A factor greater than 1 takes longer to plot (when using method 1) and
' results in slight discrepencies (e.g., a broken line instead of a solid
' line).
' Minor line intravel:
inc0! = 10
' Major line intravel:
inc1! = 100
' Method; 0 for simple, 1 for complex (see info. below):
method% = 1
' Note: Method 0 only works if the variable 'y' is the only thing left of the
' equal sign in your equation. If not use method 1.
' Number of variables (besides 'x' and 'y'):
nv% = 0
' Note: In your equation, use variables like this: "var(1)", "var(2)",
' "var(3)", etc.
' Example: "y = EXP(LOG(ABS(x) + (1 AND x = 0)) / var(1)) * ABS(x > 0)"
' Graphics screen mode:
mon% = 12
' Note: Use 1 for CGA, 3 for Herc, 4 for Ovilette, 9 for >64K EGA, 12 for VGA.
IF nv% > 0 THEN DIM var(1 TO nv%)
'DEFINT A-Z
GOTO 4
Equation0: ' corresponds to method 0.
y = x ^ 3 / 10000 + SIN(x) * 5
' Example: "y = x ^ 3 / 10000 + SIN(x) * 5"
RETURN 2
Equation1: ' corresponds to method 1.
IF x >= 0 AND y >= 0 AND y <= 100 THEN
IF x = 0 AND y = 100 THEN DrawDot% = 1
IF x = 15 AND near%(96.73203, y) THEN DrawDot% = 1
IF x = 30 AND near%(85.62092, y) THEN DrawDot% = 1
IF x = 45 AND near%(70.58823, y) THEN DrawDot% = 1
IF x = 60 AND near%(49.6732, y) THEN DrawDot% = 1
IF x = 75 AND near%(26.14379, y) THEN DrawDot% = 1
IF x = 90 AND 0 = y THEN DrawDot% = 1
IF near%(y, (pi# * 2 * (100 ^ 2 - (100 * SIN(x * pi# / 180)) ^ 2) ^ .5) / (pi# * 2)) THEN DrawDot% = 1
END IF
' Note: For method 1, precede your equation with "IF " and succede it with
' " THEN DrawDot% = 1".
' Example: "IF y * 5 MOD 3 = 0 AND x MOD 5 = 0 THEN DrawDot% = 1"
' Example: "IF y MOD 50 = 0 OR x MOD 25 = 0 THEN DrawDot% = 1"
' Example: "IF (ABS(y) <= 5 AND (x <= -100 OR x >= 100) AND x MOD 10 = 0) OR (x >= -100 AND x <= 100 AND (SQR(y ^ 2 + ABS(100 - ABS(x)) ^ 2) * mag! \ mag! = 2 * ABS(100 - ABS(x)) OR y = 0)) THEN DrawDot% = 1"
' Example: "IF ABS(ABS(x) - ABS(y)) MOD var(1) = var(3) OR (ABS(x) + ABS(y)) MOD var(2) = var(4) THEN DrawDot% = 1"
RETURN 3
4 ON ERROR GOTO term
pi# = 4 * ATN(1)
RANDOMIZE TIMER
'a = .1
SELECT CASE mon%
CASE 1: my% = 200: c1% = 3: c2% = 1: c3% = 2: c4% = 0: col% = 26: lin% = 24: ml% = 25
CASE 3: my% = 348: c1% = 1: c2% = 1: c3% = 1: c4% = 0: col% = 60: lin% = 24: ml% = 25
CASE 4: my% = 400: c1% = 1: c2% = 1: c3% = 1: c4% = 0: col% = 60: lin% = 24: ml% = 25
CASE 9: my% = 350: c1% = 15: c2% = 10: c3% = 9: c4% = 1: col% = 60: lin% = 24: ml% = 43
CASE 12: my% = 480: c1% = 15: c2% = 10: c3% = 9: c4% = 1: col% = 62: lin% = 29: ml% = 60
CASE ELSE: PRINT "Sorry, I don't support the graphics mode you chose.": SYSTEM
END SELECT
IF nv% > 0 THEN
CLS
PRINT "Prompting for"; nv%; "variables."
FOR i% = 1 TO nv%
PRINT "Value of var("; LTRIM$(STR$(i%)); ")";
LINE INPUT "? "; a$: var(i%) = VAL(a$)
NEXT i%
END IF
SCREEN mon%
IF nv% + 4 > lin% THEN WIDTH , ml%: lin% = ml% - 1
LOCATE 1, col%: PRINT "Mag:"; mag!
LOCATE 2, col%: PRINT "Minor inc:"; inc0!
LOCATE 3, col%: PRINT "Major inc:"; inc1!
LOCATE lin%, col%: PRINT "Please wait.";
IF nv% > 0 THEN
LOCATE 4, col% + 2: PRINT "Variables:"
FOR i% = 1 TO nv%
IF i% + 4 = lin% THEN EXIT FOR
LOCATE i% + 4, col%: PRINT "V"; LTRIM$(STR$(i%)); ":"; STR$(var(i%));
NEXT i%
END IF
IF c4% = 0 THEN GOTO 8
7 FOR i! = my% / 2 - inc0! * mag! TO 0 STEP 0 - inc0! * mag!
IF ABS(i! - my% / 2) MOD inc1! * mag! <> 0 THEN LINE (i!, 0)-(i!, my%), c4%
IF ABS(i! - my% / 2) MOD inc1! * mag! <> 0 THEN LINE (0, i!)-(my%, i!), c4%
NEXT i!
FOR i! = my% / 2 + inc0! * mag! TO my% STEP inc0! * mag!
IF ABS(i! - my% / 2) MOD inc1! * mag! <> 0 THEN LINE (i!, 0)-(i!, my%), c4%
IF ABS(i! - my% / 2) MOD inc1! * mag! <> 0 THEN LINE (0, i!)-(my%, i!), c4%
NEXT i!
IF c4% = 0 THEN GOTO 9
8 FOR i! = my% / 2 - inc1! * mag! TO 0 STEP 0 - inc1! * mag!
LINE (i!, 0)-(i!, my%), c3%
LINE (0, i!)-(my%, i!), c3%
NEXT i!
FOR i! = my% / 2 + inc1! * mag! TO my% STEP inc1! * mag!
LINE (i!, 0)-(i!, my%), c3%
LINE (0, i!)-(my%, i!), c3%
NEXT i!
LINE (my% / 2, 0)-(my% / 2, my%), c2%
LINE (0, my% / 2)-(my%, my% / 2), c2%
IF c4% = 0 THEN GOTO 7
9 WHILE INKEY$ <> "": WEND
FOR x = -my% / 2 / mag! TO my% / 2 / mag! STEP 1 / mag!
IF mag! > 1 THEN
'a = x * mag!
'b = a \ 1
'IF STR$(b) <> STR$(a) THEN x = INT(a + .5) / mag! ' Thanks to stupidly inprecise data types.
y = INT(y * mag! + .5) / mag!
END IF
IF method% = 0 THEN
IF INKEY$ <> "" THEN GOTO 5
GOSUB Equation0
2 IF y > 32767 THEN y = 32767
IF y < -32768 THEN y = -32768
IF use% = 0 THEN lx = x: ly = y
LINE (lx * mag! + my% / 2, 0 - ly * mag! + my% / 2)-(x * mag! + my% / 2, 0 - y * mag! + my% / 2), c1%
lx = x: ly = y
use% = 1
ELSE
FOR y = -my% / 2 / mag! TO my% / 2 / mag! STEP 1 / mag!
IF INKEY$ <> "" THEN GOTO 5
IF mag! > 1 THEN
' a = y * mag!
' b = a \ 1
' IF STR$(b) <> STR$(a) THEN : y = INT(a + .5) / mag!
y = INT(y * mag! + .5) / mag!
END IF
DrawDot% = 0
GOSUB Equation1
3 IF DrawDot% = 1 THEN PSET (x * mag! + my% / 2, 0 - y * mag! + my% / 2), c1%
NEXT y
END IF
NEXT x
LOCATE lin%, col%: PRINT " ";
GOTO 6
5 LOCATE lin%, col%: PRINT "Terminated. ";
6 SLEEP
1 SCREEN 0
WIDTH 80, 25
WHILE INKEY$ <> "": WEND
SYSTEM
term:
PRINT "Error "; ERR
SLEEP
RESUME 1
' This function returns -1 if 'n1' and 'n2' are within half a pixle of each
' other. Ex (assumes that 'mag!' = 1): near%(1, 2) = 0; near%(1, 1.5) = -1;
' near%(1, 1.6) = 0
FUNCTION near% (n1, n2)
a% = 0
IF ABS(n1 - n2) <= (1 / mag!) / 2 THEN a% = -1
near% = a%
END FUNCTION
DECLARE SUB drw ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
ON ERROR GOTO term
DIM SHARED board$(1 TO 6, 1 TO 6)
DIM SHARED ov%
4 COLOR 7, 0
CLS
RANDOMIZE TIMER
PRINT " 1 2 3 4 5 6 X"
FOR a% = 1 TO 6
PRINT LTRIM$(STR$(a%));
FOR b% = 1 TO 6
PRINT " ù";
board$(b%, a%) = "ù"
NEXT b%
PRINT
NEXT a%
PRINT "Y"
PRINT
ov% = 0
1 INPUT "(x,y) Where do you want to hide"; youx%, youy%
drw
IF youx% > 6 OR youy% > 6 OR youx% < 1 OR youy% < 1 THEN BEEP: GOTO 1
LOCATE youy% + 1, youx% * 2 + 1: PRINT "": LOCATE 10, 1: board$(youx%, youy%) = ""
2 cmpx% = INT(RND * 6) + 1
cmpy% = INT(RND * 6) + 1
IF cmpx% = youx% AND cmpy% = youy% THEN GOTO 2
PRINT "The computer has hidden."
SLEEP 1
DO
drw
3 INPUT "(x,y) Your guess"; gx%, gy%
IF gx% > 6 OR gy% > 6 OR gx% < 1 OR gy% < 1 THEN BEEP: GOTO 3
PLAY "L16O1C"
drw
IF gx% = cmpx% AND gy% = cmpy% THEN
COLOR 23, 0
LOCATE gy% + 1, gx% * 2 + 1: PRINT "": COLOR 7, 0: board$(gx%, gy%) = ""
LOCATE 10, 1: PRINT "You won!": PLAY "L16O4CP16CL8E"
agn$ = UCASE$(choice$("(Y/N) Again", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF agn$ = "Y" THEN GOTO 4
GOTO 5
ELSE
IF gx% = youx% AND gy% = youy% THEN
COLOR 23, 0
LOCATE gy% + 1, gx% * 2 + 1: PRINT "": COLOR 7, 0: board$(gx%, gy%) = "": ov% = 1
LOCATE 10, 1: PRINT "You lose!": PLAY "L16O1BAGFEDC": PRINT "The computer was hiding at:"; STR$(cmpx%); ","; cmpy%
agn$ = UCASE$(choice$("(Y/N) Again", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF agn$ = "Y" THEN GOTO 4
GOTO 5
ELSE
LOCATE gy% + 1, gx% * 2 + 1: PRINT "þ": LOCATE 10, 1: board$(gx%, gy%) = "þ"
END IF
END IF
6 gx% = INT(RND * 6) + 1
gy% = INT(RND * 6) + 1
IF gx% = cmpx% AND gy% = cmpy% THEN GOTO 6
IF board$(gx%, gy%) = "þ" THEN GOTO 6
SLEEP 1
PRINT "The computer's guess:"; STR$(gx%); ","; gy%
PLAY "L16O1C"
IF gx% = youx% AND gy% = youy% THEN
drw
COLOR 23, 0
LOCATE gy% + 1, gx% * 2 + 1: PRINT "": COLOR 7, 0: board$(gx%, gy%) = "": ov% = 1
LOCATE 10, 1: PRINT "You lose!": PLAY "L16O1BAGFEDC": PRINT "The computer was hiding at:"; STR$(cmpx%); ","; cmpy%
agn$ = UCASE$(choice$("(Y/N) Again", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF agn$ = "Y" THEN GOTO 4
GOTO 5
ELSE
LOCATE gy% + 1, gx% * 2 + 1: PRINT "þ": LOCATE 10, 1: board$(gx%, gy%) = "þ"
END IF
SLEEP 1
drw
LOOP
5 PRINT : PLAY "L4O4": SYSTEM
term:
PRINT
PRINT
PRINT "Error"; ERR
RESUME 5
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
choice$ = cky$
END FUNCTION
SUB drw
CLS
PRINT " 1 2 3 4 5 6 X"
FOR y% = 1 TO 6
PRINT LTRIM$(STR$(y%));
FOR x% = 1 TO 6
COLOR 7, 0
IF (board$(x%, y%) = "" AND ov% = 1) OR board$(x%, y%) = "" THEN COLOR 23, 0
PRINT " "; board$(x%, y%);
COLOR 7, 0
NEXT x%
PRINT
NEXT y%
PRINT "Y"
PRINT
END SUB
This is one of several programs I wrote specifically for Jehovah's Witnesses. I edited the help file to remove names for privacy reasons.
Literature Mass Order Form Creator is a BASIC program by Michael Calkins.
It is designed to create forms for the literature servant in a congregation of
Jehovah's Witnesses. The forms list then names of people or families in the
congregation and are convenient for mass ordering annual literature such as
the daily text, bound volumes, year books, and indexes.
There are a number of spaces on the form. 'Individual/Family' is where the
program inserts the names of congregation members. 'Date' is where the date
on which the person ordered can be written. That may be helpful in deciding who
gets his or her literature first. Optionally, 'Type' can be used to specify
language. 'Qty' is the number of publications ordered from each type. 'Rcvd' can
be used to keep track of who has or has not received his or her books.
The program was easy to write and is even easier to use. At the main menu,
you have the choice of printing a form, editing the name list, alphabetizing,
changing the options, etc. It is all fairly obvious, but if you want to waste
your time reading my lengthy chatter, here it is.
---'Options'---
Let us start with 'Options'. Once you customize this correctly, it
probably will not need to be changed. I have provided default settings that
just might work for you. The options are stored in 'lmofc.dat', in the current
directory.
- 'Hole positions' -
First on the menu are hole positions. I assume that you will be
punching 3 holes on the left side of the form, so I have provided the
ability to indent 6 lines. The line numbers of which can be set here. The
very first line on the form is considered line 1. You can use -1 to indicate
no line. (Suppose you agreed with the defaults except that you did not want
to indent line 58. You could change the settings to 6, 8, 32, 34, 56, -1.)
Once you choose 'Hole positions' from the menu, you go to another menu where
you can change the positions individually.
- 'Columns skipped' -
But when you do indent, how much do you want to? That is what you set
in 'Columns skipped. 4 is what I gave as a default, but you might want
something different. On unindented lines, names can be up to 18 characters
long. On indented lines, this limit is shortened by the number of columns
skipped.
- 'Folder with LMOFC files' -
I like it when my program knows where to read and write its files. That
is what this setting is for. The default is 'c:\lmofc', where I assume you
installed my program. (Actually, 'lmofc.bas' and its files can be in
different directories, but why be disorganized?) This setting tells LMOFC
where it can find 'view4.bas' and 'lmofc.txt', which is the name list, and
where it can write and delete 'lmofc.tmp', a temporary file. If you specify
a new path, do not add a backslash to the end. (ex: 'd:\lit-form', not
'd:\litform\'.)
- 'Text editor' -
Whichever ASCII plain-text editor you prefer. I assume you use Windows,
so the default is 'notepad'. Put the path if it needs it.
If you have DOS, though, there is something you ought to know about
MS-DOS Editor ver 1.1. This version is actually a part of QBASIC. My program
is run by QBASIC, and it seems I cannot get Edit ver 1.1 to run at the same
time. My personal favorite is MS-DOS Editor ver 2.0.026, which comes with
Windows 95, and which works perfectly at the same time as QBASIC is loaded.
- 'Printer device' -
This is the device or file to which you want to send output forms.
'PRN' is the default and is the same as 'LPT1'. Other devices include
'COM1', 'COM2', 'CON' (the screen), etc. If, for some weird reason, you
wanted to output to a file, you could do that too. Just do not overwrite
anything important.
- 'Restore defaults' -
This is the easy way to restore my defaults. I cannot think of a good
reason to unless you messed up the settings and do not know how to fix them.
But your smarter than that, right? Just kidding, no offense.
---'Edit name list'---
Now that you have chosen a plain-text editor, you are ready to start
typing names. Selecting 'Edit name list' from the menu opens 'lmofc.txt' with
your editor. Then enter the names last name first in a simple list with one
name to a line. Here is an example (shortened, of course. Good thing too.):
-Example begins on the next line-
(Removed for privacy reasons)
-Example ended on the previous line-
After you exit the editor, control returns to the program, which
automatically puts the names in alphabetical order. (See the next section for
more information.)
---'Alphabetize name list'---
After you select 'Edit name list', this is done automatically, but if you
edit 'lmofc.txt' on your own, from outside of my program, then you will almost
certainly want to select this option.
The names are arranged in alphabetical order based on the ASCII values of
their component characters. Except that case is not important; it is all upper
case to this part of the program. (Not that the output will all be in upper
case; it will be in the case in which you typed it.)
Besides simple alphabetizing, 'lmofc.txt' is 'cleaned up' too, just in
case you left it 'untidy'. Blank lines are omitted from the output file, and
blank spaces are removed from before and after the names. Nice of me, huh?
Keeps your forms from looking like a wreck even if you were a bit sloppy.
Oops, no offense intended. Saves hard disk space too, just so I can waste it
with this file.
---'Print form'---
Finally, the moment we have all been waiting for: Time to print the
forms. You are prompted for a title which will be placed in the 'Item: '
section at the top of the form. This is intended for the name of the
publication and the year. Leave it blank if you want; you can easily write it
in later. Next, you are asked the number of copies you want to print of that
specific form. The form is then compiled and copied to the printing device.
---'Help'---
Opens this plain-text file, 'LMOFC.HLP', in my file viewer, also a BASIC
program. If the file does not exist in the directory that you specified in
'Options', it will be created there.
This file contains some useful information and a bunch of irrelevant
junk, as you have probably seen. But I like to be detailed, and if you are
short on time, maybe you can skip to the important areas. If the grammar and
spelling are not always right, well, it is kind of late at night.
---'Exit'---
Gets you out of the program.
---About my programs---
'lmofc.bas' and 'view4.bas' are freeware. Please distribute them to your
friends, if you want to. They are not copyrighted, so you can copy parts of them
or even the whole things into your own programs. You could even modify them, but
I would appreciate it if you left SOME credit to me.
Questions, comments? Want to report a programing mistake?
Michael Calkins
4523 FM 541 W
Floresville, TX 78114
830-484-9060
'lmofc.bas' was mainly written in late August and early September of 2002.
Thanks for using my programs. I have had my File Viewer 2.0 for some time, but
updated it into ver 2.1 for distribution with LMOFC.
I do not think I responsible for any damage or loss resulting from the use
or installation of LMOFC or File Viewer 2.1. At least I hope not. I do not think
that there is any warranty, either expressed or implied, for either program. I
do not know if this means anything legally, but it was fun to write anyway.
DECLARE SUB hlp ()
DECLARE FUNCTION ind$ (n$, I%)
DECLARE SUB loadop ()
DECLARE SUB saveop ()
DECLARE SUB res ()
DECLARE FUNCTION after% (n1$, n2$)
DECLARE SUB alph ()
DECLARE SUB sads ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB c (cm%)
DECLARE FUNCTION exist% (efile$)
COMMON transfer$
DIM SHARED nexis%
DIM SHARED mon$
DIM SHARED form(0 TO 63) AS STRING * 80
DIM SHARED nam(0 TO 57) AS STRING * 18
DIM SHARED lin%(0 TO 5)
DIM SHARED skp%
DIM SHARED dir$
DIM SHARED ed$
DIM SHARED prn$
sads
loadop
RESTORE formdata
FOR I% = 0 TO 63
IF (I% >= 0 AND I% <= 5) OR I% >= 62 THEN
READ form(I%)
ELSE
form(I%) = form(4 + (I% MOD 2))
END IF
NEXT I%
DO
c 0
PRINT "Welcome to Literature Mass Order Form Creator."
c 3
PRINT "---Main Menu---"
c 5
PRINT "0 - Print form"
PRINT "1 - Edit name list"
PRINT "2 - Alphabetize name list"
PRINT "3 - Options"
PRINT "4 - Help"
PRINT "5 - Exit"
SELECT CASE VAL(choice$("Your choice", "0", "1", "2", "3", "4", "5", "", "", "", ""))
CASE 0: c 0
LINE INPUT "Title? "; title$
title$ = LEFT$(title$, 60)
LINE INPUT "Number of copies? "; n$
cop% = VAL(n$)
PRINT "Creating form. ... ";
OPEN dir$ + "\lmofc.txt" FOR INPUT AS 1
OPEN dir$ + "\lmofc.tmp" FOR OUTPUT AS 2
page% = 0
DO
page% = page% + 1
FOR I% = 0 TO 57
nam(I%) = ""
IF NOT EOF(1) THEN
LINE INPUT #1, n$
nam(I%) = n$
END IF
NEXT I%
FOR I% = 0 TO 63
n$ = form(I%)
IF I% = 1 THEN
MID$(n$, 9, LEN(title$)) = title$
n1$ = STR$(page%)
MID$(n$, 75, LEN(n1$)) = n1$
END IF
IF I% > 4 AND I% < 62 AND (I% - 5) MOD 2 = 0 THEN
MID$(n$, 2, 18) = ind$(nam((I% - 5) / 2), I% + 1)
MID$(n$, 42, 18) = nam((I% + 53) / 2)
END IF
PRINT #2, n$
NEXT I%
PRINT #2, CHR$(12);
IF EOF(1) THEN EXIT DO
LOOP
CLOSE
PRINT "Done."
PRINT "Printing. ... "
FOR I% = 1 TO cop%
SHELL "copy " + dir$ + "\lmofc.tmp " + prn$ + " > nul"
NEXT I%
KILL dir$ + "\lmofc.tmp"
PRINT "Done. Press any key to continue."
SLEEP: WHILE INKEY$ <> "": WEND
CASE 1: c 0: SHELL ed$ + " " + dir$ + "\lmofc.txt": alph
CASE 2: alph
CASE 3
DO
c 0
c 3
PRINT "---LMOFC Options--- (Options file is saved in the current directory.)"
c 5
PRINT "0 - Hole positions "; lin%(0); lin%(1); lin%(2); lin%(3); lin%(4); lin%(5)
PRINT "1 - Columbs skipped "; skp%
PRINT "2 - Folder with LMOFC flles "; dir$
PRINT "3 - Text editor "; ed$
PRINT "4 - Printer device "; prn$
PRINT "5 - Restore defaults "
PRINT "6 - Main menu"
SELECT CASE VAL(choice$("Well", "0", "1", "2", "3", "4", "5", "6", "", "", ""))
CASE 0: PRINT
DO
c 0
PRINT "The lines on which holes will be punched. The first line of the page is line 1."
c 3
PRINT "---Hole posititions---"
c 5
PRINT "0 - Position 0 "; lin%(0)
PRINT "1 - Position 1 "; lin%(1)
PRINT "2 - Position 2 "; lin%(2)
PRINT "3 - Position 3 "; lin%(3)
PRINT "4 - Position 4 "; lin%(4)
PRINT "5 - Position 5 "; lin%(5)
PRINT "6 - Options menu"
I% = VAL(choice$("Which will it be", "0", "1", "2", "3", "4", "5", "6", "", "", ""))
IF I% = 6 THEN EXIT DO
PRINT
PRINT "Old:"; STR$(lin%(I%)); ". ": INPUT "(-1 for none) New"; n$
lin%(I%) = VAL(n$)
LOOP
CASE 1: PRINT
PRINT "The number of columbs to skip on the lines where the holes will be."
PRINT "Old:"; STR$(skp%); ". ": INPUT "New"; n$
skp% = VAL(n$)
CASE 2: PRINT
PRINT "The folder where LMOFC.TXT can be found and where temporary files can be made."
PRINT "Old: '"; dir$; "'"
LINE INPUT "New? "; dir$
CASE 3: PRINT
PRINT "The text editor that you want to use to edit the name list. Path is optional."
PRINT "Old: '"; ed$; "'"
LINE INPUT "New? "; ed$
CASE 4: PRINT
PRINT "The device or file to which the form should be sent, usually 'PRN'."
PRINT "Old: '"; prn$; "'"
LINE INPUT "New? "; prn$
CASE 5: PRINT : IF choice$("Are you sure you want to restore the default settings", "Y", "N", "", "", "", "", "", "", "") = "Y" THEN res
CASE 6: saveop: EXIT DO
END SELECT
LOOP
CASE 4: hlp
CASE 5: c 0
PRINT "Thanks for using LMOFC. If you find any errors, please contact me."
PRINT
PRINT "Michael Calkins"
PRINT "4523 FM 541 W"
PRINT "Floresville, TX 78114"
PRINT
PRINT "830-484-9060"
PRINT
SYSTEM
END SELECT
LOOP
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
sadserr:
mon$ = "M"
RESUME NEXT
formdata:
DATA "ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿"
DATA "³ Item: Page: ³"
DATA "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄÂÄÄÄÄ´"
DATA "³Individual/Family ³Date³Type³Qty ³Rcvd³³Individual/Family ³Date³Type³Qty ³Rcvd³"
DATA "ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄÅÄÄÄÄ´"
DATA "³ ³ ³ ³ ³ ³³ ³ ³ ³ ³ ³"
DATA "ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÁÄÄÄÄÙ"
DATA "Created using LMOFC, by Michael Calkins, Floresville, TX, Ph# 830-484-9060."
hlpdata:
DATA " Literature Mass Order Form Creator is a BASIC program by Michael Calkins."
DATA "It is designed to create forms for the literature servant in a congregation of"
DATA "Jehovah's Witnesses. The forms list then names of people or families in the"
DATA "congregation and are convenient for mass ordering annual literature such as"
DATA "the daily text, bound volumes, and indexes."
DATA ""
DATA " There are a number of spaces on the form. 'Individual/Family' is where the"
DATA "program inserts the names of congregation members. 'Date' is where the date"
DATA "on which the person ordered can be written. That may be helpful in deciding who"
DATA "gets his or her literature first. Optionally, 'Type' can be used to specify"
DATA "language. 'Qty' is the number of publications ordered from each type. 'Rcvd' can"
DATA "be used to keep track of who has or has not received his or her books."
DATA ""
DATA " The program was easy to write and is even easier to use. At the main menu,"
DATA "you have the choice of printing a form, editing the name list, alphabetizing,"
DATA "changing the options, etc. It is all fairly obvious, but if you want to waste"
DATA "your time reading my lengthy chatter, here it is."
DATA ""
DATA "---'Options'---"
DATA ""
DATA " Let us start with 'Options'. Once you customize this correctly, it"
DATA " probably will not need to be changed. I have provided default settings that"
DATA " just might work for you. The options are stored in 'lmofc.dat', in the current"
DATA " directory."
DATA ""
DATA " - 'Hole positions' -"
DATA " First on the menu are hole positions. I assume that you will be"
DATA " punching 3 holes on the left side of the form, so I have provided the"
DATA " ability to indent 6 lines. The line numbers of which can be set here. The"
DATA " very first line on the form is considered line 1. You can use -1 to indicate"
DATA " no line. (Suppose you agreed with the defaults except that you did not want"
DATA " to indent line 58. You could change the settings to 6, 8, 32, 34, 56, -1.)"
DATA " Once you choose 'Hole positions' from the menu, you go to another menu"
DATA " where you can change the positions individually."
DATA ""
DATA " - 'Columns skipped' -"
DATA " But when you do indent, how much do you want to? That is what you set"
DATA " in 'Columns skipped'. 4 is what I gave as a default, but you might want"
DATA " something different. On unindented lines, names can be up to 18 characters"
DATA " long. On indented lines, this limit is shortened by the number of columns"
DATA " skipped."
DATA ""
DATA " - 'Folder with LMOFC files' -"
DATA " I like it when my program knows where to read and write its files. That"
DATA " is what this setting is for. The default is 'c:\lmofc', where I assume you"
DATA " installed my program. (Actually, 'lmofc.bas' and its files can be in"
DATA " different directories, but why be disorganized?) This setting tells LMOFC"
DATA " where it can find 'view4.bas' and 'lmofc.txt', which is the name list, and"
DATA " where it can write and delete 'lmofc.tmp', a temporary file. If you specify"
DATA " a new path, do not add a backslash to the end. (ex: 'd:\lit-form', not"
DATA " 'd:\litform\'.)"
DATA ""
DATA " - 'Text editor' -"
DATA " Whichever ASCII plain-text editor you prefer. I assume you use Windows,"
DATA " so the default is 'notepad'. Put the path if it needs it."
DATA " If you have DOS, though, there is something you ought to know about"
DATA " MS-DOS Editor ver 1.1. This version is actually a part of QBASIC. My program"
DATA " is run by QBASIC, and it seems I cannot get Edit ver 1.1 to run at the same"
DATA " time. My personal favorite is MS-DOS Editor ver 2.0.026, which comes with"
DATA " Windows 95, and which works perfectly at the same time as QBASIC is loaded."
DATA ""
DATA " - 'Printer device' -"
DATA " This is the device or file to which you want to send output forms."
DATA " 'PRN' is the default and is the same as 'LPT1'. Other devices include"
DATA " 'COM1', 'COM2', 'CON' (the screen), etc. If, for some weird reason, you"
DATA " wanted to output to a file, you could do that too. Just do not overwrite"
DATA " anything important."
DATA ""
DATA " - 'Restore defaults' -"
DATA " This is the easy way to restore my defaults. I cannot think of a good"
DATA " reason to unless you messed up the settings and do not know how to fix them."
DATA " But your smarter than that, right? Just kidding, no offense."
DATA ""
DATA "---'Edit name list'---"
DATA ""
DATA " Now that you have chosen a plain-text editor, you are ready to start"
DATA " typing names. Selecting 'Edit name list' from the menu opens 'lmofc.txt' with"
DATA " your editor. Then enter the names last name first in a simple list with one"
DATA " name to a line. Here is an example (shortened, of course. Good thing too.):"
DATA "-Example begins on the next line-"
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA ""
DATA "-Example ended on the previous line-"
DATA " After you exit the editor, control returns to the program, which"
DATA " automatically puts the names in alphabetical order. (See the next section for"
DATA " more information.)"
DATA ""
DATA "---'Alphabetize name list'---"
DATA ""
DATA " After you select 'Edit name list', this is done automatically, but if you"
DATA " edit 'lmofc.txt' on your own, from outside of my program, then you will almost"
DATA " certainly want to select this option."
DATA " The names are arranged in alphabetical order based on the ASCII values of"
DATA " their component characters. Except that case is not important; it is all upper"
DATA " case to this part of the program. (Not that the output will all be in upper"
DATA " case; it will be in the case in which you typed it.)"
DATA " Besides simple alphabetizing, 'lmofc.txt' is 'cleaned up' too, just in"
DATA " case you left it 'untidy'. Blank lines are omitted from the output file, and"
DATA " blank spaces are removed from before and after the names. Nice of me, huh?"
DATA " Keeps your forms from looking like a wreck even if you were a bit sloppy."
DATA " Oops, no offense intended. Saves hard disk space too, just so I can waste it"
DATA " with this file."
DATA ""
DATA "---'Print form'---"
DATA ""
DATA " Finally, the moment we have all been waiting for: Time to print the"
DATA " forms. You are prompted for a title which will be placed in the 'Item: '"
DATA " section at the top of the form. This is intended for the name of the"
DATA " publication and the year. Leave it blank if you want; you can easily write it"
DATA " in later. Next, you are asked the number of copies you want to print of that"
DATA " specific form. The form is then compiled and copied to the printing device."
DATA ""
DATA "---'Help'---"
DATA ""
DATA " Opens this plain-text file, 'LMOFC.HLP', in my file viewer, also a BASIC"
DATA " program. If the file does not exist in the directory that you specified in"
DATA " 'Options', it will be created there."
DATA " This file contains some useful information and a bunch of irrelevant"
DATA " junk, as you have probably seen. But I like to be detailed, and if you are"
DATA " short on time, maybe you can skip to the important areas. If the grammar and"
DATA " spelling are not always right, well, it is kind of late at night."
DATA ""
DATA "---'Exit'---"
DATA ""
DATA " Gets you out of the program."
DATA ""
DATA ""
DATA "---About my programs---"
DATA ""
DATA " 'lmofc.bas' and 'view4.bas' are freeware. Please distribute them to your"
DATA "friends, if you want to. They are not copyrighted, so you can copy parts of them"
DATA "or even the whole things into your own programs. You could even modify them, but"
DATA "I would appreciate it if you left SOME credit to me."
DATA ""
DATA "Questions, comments? Want to report a programing mistake?"
DATA ""
DATA "Michael Calkins"
DATA "4523 FM 541 W"
DATA "Floresville, TX 78114"
DATA ""
DATA "830-484-9060"
DATA ""
DATA " 'lmofc.bas' was mainly written in late August and early September of 2002."
DATA "Thanks for using my programs. I have had my File Viewer 2.0 for some time, but"
DATA "updated it into ver 2.1 for distribution with LMOFC."
DATA ""
DATA " I do not think I responsible for any damage or loss resulting from the use"
DATA "or installation of LMOFC or File Viewer 2.1. At least I hope not. I do not think"
DATA "that there is a warranty, either expressed or implied, for either program. I do"
DATA "not know if this means anything legally, but it was fun to write anyway."
FUNCTION after% (a1$, a2$)
n1$ = UCASE$(a1$)
n2$ = UCASE$(a2$)
IF n2$ = "" THEN
r% = 1
ELSE
IF n1$ = "" THEN
r% = 0
ELSE
IF n1$ = n2$ THEN
r% = 2
ELSE
cn% = 0
DO
cn% = cn% + 1
IF cn% > LEN(n1$) AND cn% <= LEN(n2$) THEN r% = 1: EXIT DO
IF cn% > LEN(n2$) AND cn% <= LEN(n1$) THEN r% = 0: EXIT DO
e1$ = MID$(n1$, cn%, 1)
e2$ = MID$(n2$, cn%, 1)
IF ASC(e1$) > ASC(e2$) THEN r% = 1: EXIT DO
IF ASC(e1$) < ASC(e2$) THEN r% = 0: EXIT DO
LOOP
END IF
END IF
END IF
after% = r%
END FUNCTION
' problem: gets "z"est word?, doesn't quit?
SUB alph
c 0
PRINT "Please wait, alphabetizing list. ... ";
SHELL "copy " + dir$ + "\lmofc.txt " + dir$ + "\lmofc.tmp > nul"
ll% = -1
OPEN dir$ + "\lmofc.txt" FOR OUTPUT AS 2
DO
OPEN dir$ + "\lmofc.tmp" FOR INPUT AS 1
cn% = 0
gl% = ll%
good$ = last$
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, n1$
n1$ = LTRIM$(RTRIM$(n1$))
IF n1$ <> "" THEN
e% = after%(n1$, good$)
e2% = after%(n1$, last$)
IF (e2% = 1 OR (e2% = 2 AND cn% > ll%)) AND (e% = 0 OR gl% = ll%) THEN
good$ = n1$
gl% = cn%
END IF
END IF
cn% = cn% + 1
LOOP
IF gl% <> ll% THEN
PRINT #2, good$
ll% = gl%
last$ = good$
ELSE
IF EOF(1) THEN EXIT DO
END IF
CLOSE 1
LOOP
1 CLOSE
KILL dir$ + "\lmofc.tmp"
PRINT "Done. Press any key to continue."
SLEEP: WHILE INKEY$ <> "": WEND
END SUB
SUB c (cm%)
IF mon$ <> "C" AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF mon$ <> "C" AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 5 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
CASE 5: COLOR 7, 0
END SELECT
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
LOCATE , , 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE , , 0
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO 0'term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
' Probably write this to a file.
SUB hlp
c 0
IF exist%(dir$ + "\lmofc.hlp") = 0 THEN
PRINT "Creating help file. ...";
RESTORE hlpdata
for
PRINT " Literature Mass Order Form Creator is a BASIC program by Michael Calkins."
PRINT "It is designed to create forms for the literature servant in a congregation of"
PRINT "Jehovah's Witnesses. The forms list then names of people or familys in the"
PRINT "congregation and are convienient for mass ordering annual literature such as"
PRINT "the daily text, bound volumes, and indexs."
PRINT
PRINT " There are a number of spaces on the form. 'Individual/Family' is where the"
PRINT "program inserts the names of congregation members. 'Date' is where the date"
PRINT "on which the person ordered can be written. That may be helpful in deciding who"
PRINT "gets his or her literature first. Optionally, 'Type' can be used to specify"
PRINT "language. 'Qty' is the number of publications ordered from each type. 'Rcvd' can"
PRINT "be used to keep track of who has or has not received his or her books."
PRINT
PRINT " The program was easy to write and is even easier to use. At the main menu,"
PRINT "you have the choice of printing a form, editing the name list, alphabetizing,"
PRINT "changing the options, etc."
PRINT " Let us start with 'Options'. Once you customize this correctly, it probably"
PRINT "will not need to be changed. I have provided default settings that just might"
PRINT "work for you. First on the menu are hole positions. I assume that you will be"
PRINT "punching 3 holes on the left side of the form, so I have provided the ability to"
PRINT "indent 6 lines. The line numbers of which can be set here. The very first line"
PRINT "on the form is considered line 1. You can use -1 to indicate no line. (Suppose"
PRINT "you agreed with the defaults except that you did not want to indent line 58. You"
PRINT "could change the settings to 6, 8, 32, 34, 56, -1.)"
END SUB
FUNCTION ind$ (n$, I%)
a$ = n$
FOR a% = 0 TO 5
IF lin%(a%) = I% THEN a$ = SPACE$(skp%) + a$
NEXT a%
ind$ = a$
END FUNCTION
SUB loadop
IF exist%("lmofc.dat") = 1 THEN
PRINT "Loading saved options. ... ";
OPEN "lmofc.dat" FOR INPUT AS 1
FOR I% = 0 TO 5
INPUT #1, lin%(I%)
NEXT I%
INPUT #1, skp%
LINE INPUT #1, dir$
LINE INPUT #1, ed$
LINE INPUT #1, prn$
CLOSE
PRINT "Done."
ELSE
PRINT "Creating a data file with default options. ... ";
res
saveop
PRINT "Done."
END IF
END SUB
SUB res
lin%(0) = 6
lin%(1) = 8
lin%(2) = 32
lin%(3) = 34
lin%(4) = 56
lin%(5) = 58
skp% = 4
dir$ = "c:\lmofc"
ed$ = "notepad"
prn$ = "PRN"
END SUB
SUB sads
mon$ = "C"
ON ERROR GOTO sadserr
SCREEN 1
ON ERROR GOTO term
IF mon$ = "C" THEN SCREEN 0: WIDTH 80
END SUB
SUB saveop
OPEN "lmofc.dat" FOR OUTPUT AS 1
FOR I% = 0 TO 5
PRINT #1, lin%(I%)
NEXT I%
PRINT #1, skp%
PRINT #1, dir$
PRINT #1, ed$
PRINT #1, prn$
CLOSE
END SUB
This message has been edited by MCalkins on Feb 23, 2011 2:29 AM This message has been edited by MCalkins on Feb 23, 2011 2:23 AM
DECLARE SUB timerl (tdly#)
DECLARE SUB load (filename$)
DECLARE SUB conv ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
DIM SHARED num%
DIM SHARED maze(1 TO 23) AS STRING * 80
DIM SHARED one AS STRING * 1
DIM SHARED sl%
DIM SHARED sc%
DIM SHARED el%
DIM SHARED ec%
ON ERROR GOTO term
LINE INPUT "Maze list file? "; file$
IF Exist%(file$) = 0 THEN PRINT "File '"; file$; "' not found.": SYSTEM
OPEN file$ FOR INPUT AS 1
LINE INPUT #1, num$
num% = VAL(num$)
DIM SHARED mazelist$(1 TO num%)
FOR i% = 1 TO num%
LINE INPUT #1, mazelist$(i%)
IF Exist%(mazelist$(i%)) = 0 THEN PRINT "Maze '"; mazelist$(i%); "' not found.": SYSTEM
NEXT i%
CLOSE
FOR level% = 1 TO num%
load mazelist$(level%)
COLOR 7, 0: CLS
COLOR 7, 1
FOR i% = 1 TO 23
PRINT maze(i%)
NEXT i%
COLOR 7, 2 + 8: LOCATE sl%, sc%: PRINT " "
COLOR 7, 4 + 8: LOCATE el%, ec%: PRINT " "
COLOR 7, 1
l% = sl%
c% = sc%
DO
IF l% = sl% AND c% = sc% THEN COLOR 7, 2 + 8
IF l% = el% AND c% = ec% THEN COLOR 7, 4 + 8
LOCATE l%, c%: PRINT CHR$(1)
COLOR 7, 1
IF l% = el% AND c% = ec% THEN
timerl 1
COLOR 7, 0
CLS
IF level% < num% THEN
PRINT "Good! Press any key to go to level"; STR$(level% + 1); "."
ELSE
PRINT "You win! You have completed all"; num%; "levels!"
END IF
SLEEP
EXIT DO
END IF
key$ = INKEY$
a% = 0
b% = 0
SELECT CASE key$
CASE CHR$(0) + CHR$(72)
a% = -1
CASE CHR$(0) + CHR$(75)
b% = -1
CASE CHR$(0) + CHR$(77)
b% = 1
CASE CHR$(0) + CHR$(80)
a% = 1
CASE CHR$(27): COLOR 7, 0: CLS : SYSTEM
CASE ELSE
END SELECT
tl% = l% + a%
tc% = c% + b%
IF (tl% <> l% OR tc% <> c%) AND tl% > 0 AND tl% < 24 AND tc% > 0 AND tc% < 81 THEN
IF MID$(maze(tl%), tc%, 1) <> CHR$(219) THEN
IF l% = sl% AND c% = sc% THEN COLOR 7, 2 + 8
LOCATE l%, c%: PRINT " ": l% = tl%: c% = tc%
COLOR 7, 1
END IF
END IF
LOOP
NEXT level%
SYSTEM
term:
CLS
PRINT "Error"; ERR; "at"; ERL;
SYSTEM
exis:
nexis% = 0
RESUME NEXT
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
choice$ = cky$
END FUNCTION
SUB conv
FOR a% = 1 TO 23
FOR b% = 1 TO 80
IF MID$(maze(a%), b%, 1) = "*" THEN MID$(maze(a%), b%, 1) = CHR$(219)
NEXT b%
NEXT a%
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO 0'term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB load (filename$)
OPEN filename$ FOR BINARY AS 1
FOR a% = 1 TO 23
FOR b% = 0 TO 9
GET 1, , one
FOR c% = 1 TO 8
d% = ASC(one) AND 2 ^ (c% - 1)
d$ = " "
IF d% > 0 THEN d$ = "*"
MID$(maze(a%), b% * 8 + c%, 1) = d$
NEXT c%
NEXT b%
NEXT a%
GET 1, , one
sl% = ASC(one)
GET 1, , one
sc% = ASC(one)
GET 1, , one
el% = ASC(one)
GET 1, , one
ec% = ASC(one)
CLOSE
conv
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
------------------------------------
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
PRINT "This is a program for compressing maze files so that the maze game can use them."
PRINT "This allows you to make your own mazes."
PRINT "The maze in the input file should be 80 columbs wide and 23 lines long."
PRINT "Use '*' for walls and ' ' (space bar) for empty areas."
PRINT "Immediatly after the maze, on line 24, write the start line, start columb, end"
PRINT "line, and end columb. These should be on the same line and seperated by commas."
PRINT "Example: '1,5,23,60'"
PRINT
LINE INPUT "Input file for maze? "; in$
IF Exist%(in$) = 0 THEN PRINT "File '"; in$; "' not found.": SYSTEM
LINE INPUT "Output file for compressed maze? "; out$
IF Exist%(out$) = 1 THEN PRINT "File '"; out$; "' already exists.": SYSTEM
OPEN in$ FOR INPUT AS 1
OPEN out$ FOR BINARY AS 2
DIM one AS STRING * 1
DIM maze(1 TO 23) AS STRING * 80
FOR a% = 1 TO 23
LINE INPUT #1, maze(a%)
FOR b% = 0 TO 9
d% = 0
FOR c% = 1 TO 8
d$ = MID$(maze$(a%), b% * 8 + c%, 1)
IF d$ = "*" THEN d% = d% + 2 ^ (c% - 1)
NEXT c%
d$ = CHR$(d%)
PUT 2, , d$
NEXT b%
NEXT a%
INPUT #1, sl$, sc$, el$, ec$
sl$ = CHR$(VAL(sl$))
PUT 2, , sl$
sc$ = CHR$(VAL(sc$))
PUT 2, , sc$
el$ = CHR$(VAL(el$))
PUT 2, , el$
ec$ = CHR$(VAL(ec$))
PUT 2, , ec$
CLOSE
PRINT "Compression complete."
PRINT "For your information, the compressed maze file will be 234 bytes long. The first"
PRINT "230 bytes are the maze. If these bytes are arranged in 23 rows of 10 bytes each"
PRINT "and converted into binary, the 1s will stand for walls, and the 0s will stand"
PRINT "for empty spaces. the ASCII values for the last 4 bytes are the start line,"
PRINT "start columb, end line and end columb."
PRINT "You may wish to add your new maze to an existing maze list file or create a new"
PRINT "maze list file. Either way, you will need to know the format for these files. On"
PRINT "the first line is the number of levels. On each following line is the name of"
PRINT "a maze file. These names are in the order that they will be played."
SYSTEM
exis:
nexis% = 0
RESUME NEXT
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO 0
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
DECLARE SUB drwclock (n%)
' $DYNAMIC
DECLARE SUB timerl (tdly#)
DECLARE SUB scrnsave ()
DECLARE SUB save (n%)
DECLARE SUB cbox (hight%, wid%, title$)
DECLARE SUB compare (from$, to$, ln%)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB action (code%)
DECLARE SUB box (sl%, sc%, el%, ec%, all%)
DECLARE SUB drwmenu ()
DECLARE SUB menusys ()
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
DIM SHARED nummenus%
DIM SHARED p1%
DIM SHARED p2%
DIM SHARED md%
DIM SHARED pp%
DIM SHARED tl%
DIM SHARED tc%
DIM SHARED prn$
DIM SHARED edit$
DIM SHARED min!
DIM SHARED text$
DIM SHARED mode%
DIM SHARED speed!
RANDOMIZE TIMER
nummenus% = 4
TYPE menudat
ni AS INTEGER
text AS STRING * 16
END TYPE
TYPE itemdat
text AS STRING * 14
code AS INTEGER
END TYPE
DIM SHARED menu(1 TO nummenus%) AS menudat
DIM SHARED items(1 TO nummenus%, 1 TO 20) AS itemdat
DIM SHARED shortcut$(-20 TO -1)
RESTORE Short
FOR i% = -1 TO -20 STEP -1
READ shortcut$(i%)
NEXT i%
RESTORE Menudata
FOR i% = 1 TO nummenus%
READ menu(i%).text
READ menu(i%).ni
NEXT i%
RESTORE M1
FOR i% = 1 TO menu(1).ni
READ items(1, i%).text
READ items(1, i%).code
NEXT i%
RESTORE M2
FOR i% = 1 TO menu(2).ni
READ items(2, i%).text
READ items(2, i%).code
NEXT i%
RESTORE M3
FOR i% = 1 TO menu(3).ni
READ items(3, i%).text
READ items(3, i%).code
NEXT i%
RESTORE M4
FOR i% = 1 TO menu(4).ni
READ items(4, i%).text
READ items(4, i%).code
NEXT i%
' Note to self. when you add more, update 'printer setup'.
IF Exist%("c:\menu2.dat") = 1 THEN
OPEN "c:\menu2.dat" FOR INPUT AS #1
LINE INPUT #1, prn$
LINE INPUT #1, edit$
LINE INPUT #1, min$
LINE INPUT #1, text$
LINE INPUT #1, mode$
LINE INPUT #1, speed$
CLOSE
min! = VAL(min$)
mode% = VAL(mode$)
speed! = VAL(speed$)
ELSE
save 1
END IF
menusys
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
runbas:
LOCATE tl% + 1, tc%: PRINT "Couldn't run BASIC program."
RESUME NEXT
Menudata:
DATA "Menu Program",3,"File",10,"Directory",3,"Prg Settings",4
M1:
DATA "Run Basic",1,"About",2,"Exit",3
M2:
DATA "Print",4,"Copy",5,"Move",6,"Compare",7,"Erase",8,"Rename",9,"Edit",17,"List",10,"Command Prompt",15,"Execute",20
M3:
DATA "Ch Dir",11,"Mk Dir",12,"Rm Dir",13
M4:
DATA "Printer",14,"Editor",16,"Screen Saver",18,"Defaults",19
Short:
DATA "X","","","","","","","","","","","","","","","","","","",""
REM $STATIC
SUB action (code%)
drwmenu
drwclock 0
1
COLOR 7, 1
SELECT CASE code%
CASE 1: cbox 2, 78, "Run": LOCATE tl%, tc%
LINE INPUT "BASIC program to run? "; prog$
ON ERROR GOTO runbas
RUN prog$
ON ERROR GOTO term
SLEEP: WHILE INKEY$ <> "": WEND
CASE 2: cbox 5, 50, "About": LOCATE tl%, tc%: PRINT "Menu Program 2. By Michael Calkins."
LOCATE tl% + 2, tc%: PRINT "Largest creatible non-string array: "; FRE(-1)
LOCATE tl% + 3, tc%: PRINT "Free stack space: "; FRE(-2)
LOCATE tl% + 4, tc%: PRINT "Free string space: "; FRE("")
SLEEP: WHILE INKEY$ <> "": WEND
CASE 3: COLOR 7, 0: CLS : SYSTEM
CASE 4: cbox 2, 78, "Print": LOCATE tl%, tc%
LINE INPUT "File? "; from$
LOCATE tl% + 1, tc%
IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
SHELL "copy " + from$ + " " + prn$ + " > menu2.jnk"
KILL "menu2.jnk"
CASE 5: cbox 3, 78, "Copy": LOCATE tl%, tc%
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
LINE INPUT " To? "; to$
LOCATE tl% + 2, tc%
IF Exist%(to$) = 1 THEN
IF choice$("File already exists. Overwrite", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN : EXIT SUB
KILL to$
END IF
SHELL "copy " + from$ + " " + to$ + " > menu2.jnk"
KILL "menu2.jnk"
CASE 6: cbox 4, 78, "Move": LOCATE tl%, tc%
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
LINE INPUT " To? "; to$
LOCATE tl% + 2, tc%
IF Exist%(to$) = 1 THEN
IF choice$("File already exists. Overwrite", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN : EXIT SUB
KILL to$
END IF
SHELL "copy " + from$ + " " + to$ + " > menu2.jnk"
KILL "menu2.jnk"
' CASE 7: cbox 3, 78, "Compare": LOCATE tl%, tc%
' LINE INPUT "File1? "; from$
' LOCATE tl% + 1, tc%
' IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
' LINE INPUT "File2? "; to$
' LOCATE tl% + 2, tc%
' IF Exist%(to$) = 0 THEN PRINT "File '"; to$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
' compare from$, to$, tl% + 2
' SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
CASE 7: cbox 1, 78, "Compare": LOCATE tl%, tc%
LINE INPUT "Parameters? "; par$
COLOR 7, 0: CLS
SHELL "fc " + par$
SHELL "pause"
CASE 8: cbox 2, 78, "Erase": LOCATE tl%, tc%
LINE INPUT "File? "; from$
LOCATE tl% + 1, tc%
IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
IF choice$("Are you sure", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN KILL from$
CASE 9: cbox 2, 78, "Rename": LOCATE tl%, tc%
LINE INPUT "From? "; from$
LOCATE tl% + 1, tc%
IF Exist%(from$) = 0 THEN PRINT "File '"; from$; "' not found.": SLEEP: WHILE INKEY$ <> "": WEND: EXIT SUB
LINE INPUT " To? "; to$
NAME from$ AS to$
CASE -1: code% = 3: GOTO 1
CASE 10: cbox 1, 78, "File List": LOCATE tl%, tc%: LINE INPUT "Parameters? "; par$: COLOR 7, 0: CLS : SHELL "dir " + par$: SHELL "pause"
CASE 11: cbox 1, 78, "Change Directory": LOCATE tl%, tc%: LINE INPUT "Dir? "; from$: CHDIR from$
CASE 12: cbox 1, 78, "Make Directory": LOCATE tl%, tc%: LINE INPUT "New directory? "; from$: MKDIR from$
CASE 13: cbox 2, 80, "Remove Directory": LOCATE tl%, tc%
LINE INPUT "Dir? "; from$
LOCATE tl% + 1, tc%
IF choice$("Are you sure", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN RMDIR from$
CASE 14: cbox 1, 78, "Printer Setup"
LOCATE tl%, tc%: PRINT "Current device is '"; prn$; "'. "; : LINE INPUT "Device associated with printer? "; t$
IF t$ <> "" THEN prn$ = t$: save 0
CASE 15
COLOR 7, 0
CLS
PRINT "A new copy of the command intrperator, "; ENVIRON$("COMSPEC"); ", is running. Don't"
PRINT "forget that QBASIC and Menu 2 are still in memory."
PRINT "Type 'exit' to ruturn to Menu 2."
SHELL
COLOR 7, 0: CLS
CASE 16: cbox 1, 78, "Editor Setup"
LOCATE tl%, tc%: PRINT "Current editor is '"; edit$; "'. "; : LINE INPUT "New editor? "; t$
IF t$ <> "" THEN edit$ = t$: save 0
CASE 17: cbox 1, 78, "Edit"
LOCATE tl%, tc%: LINE INPUT "File(s)? ", from$
COLOR 7, 0: CLS
SHELL edit$ + " " + from$
CASE 18: cbox 5, 78, "Screen Savor Setup"
LOCATE tl%, tc%: PRINT "Current delay is"; min!; "minutes. "; : LINE INPUT "(0 to disable) New delay? "; t$
IF t$ <> "" THEN min! = VAL(t$)
LOCATE tl% + 1, tc%: PRINT "Current text is '"; text$; "'. "; : LINE INPUT "New text? "; t$
IF t$ <> "" THEN text$ = t$
LOCATE tl% + 2, tc%: PRINT "(0-blank, 1-random location, 2-moving, 3-scrolling, 4-scroll. + moving.)"
LOCATE tl% + 3, tc%: PRINT "Current mode is"; STR$(mode%); ". "; : LINE INPUT "New mode? "; t$
IF t$ <> "" THEN mode% = VAL(t$)
LOCATE tl% + 4, tc%: PRINT "Current speed is"; speed!; "seconds. "; : LINE INPUT "New speed? "; t$
IF t$ <> "" THEN speed! = VAL(t$)
save 0
CASE 19: cbox 1, 27, "Restore default settings."
LOCATE tl%, tc%: IF choice$("Are you sure", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN save 1
CASE 20: cbox 2, 78, "Execute"
LOCATE tl%, tc%: LINE INPUT "Command line? "; par$
LOCATE tl% + 1, tc%
IF choice$("Temporarily exit QBASIC and Menu 2 to provide more availible memory", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN
OPEN "c:\menu2tmp.bat" FOR OUTPUT AS 1
PRINT #1, "@echo off"
PRINT #1, par$
PRINT #1, "pause"
CLOSE
COLOR 7, 0: CLS
SYSTEM
END IF
COLOR 7, 0: CLS
SHELL par$
SHELL "pause"
COLOR 7, 0: CLS
END SELECT
'COLOR 7, 0: CLS
END SUB
SUB box (sl%, sc%, el%, ec%, all%)
LOCATE sl%, sc%: PRINT "Ú"; STRING$((ec% - sc%) - 1, "Ä"); "¿"
IF all% = 1 THEN
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³"; SPACE$((ec% - sc%) - 1); "³"
NEXT i%
ELSE
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³": LOCATE i%, ec%: PRINT "³"
NEXT i%
END IF
LOCATE el%, sc%: PRINT "À"; STRING$((ec% - sc%) - 1, "Ä"); "Ù"
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
LOCATE CSRLIN, POS(0), 1
PRINT pr$; "? ";
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE CSRLIN, POS(0), 0
PRINT sl$
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB compare (from$, to$, ln%)
OPEN from$ FOR BINARY AS 1
OPEN to$ FOR BINARY AS 2
IF LOF(1) <> LOF(2) THEN LOCATE ln%, tc%: PRINT "Files are different sizes.": CLOSE : EXIT SUB
DIM one AS STRING * 1
DIM two AS STRING * 1
i# = 0
DO
IF EOF(1) THEN EXIT DO
GET 1, , one
GET 2, , two
i# = i# + 1
LOCATE ln%, tc%: PRINT "Checking byte"; i#
IF one <> two THEN LOCATE ln%, tc%: PRINT "Files are not the same. First difference in byte"; i#: CLOSE : EXIT SUB
LOOP
CLOSE
LOCATE ln%, tc%: PRINT "Files are identical."
END SUB
SUB drwclock (n%)
LOCATE 24, 73
IF n% = 1 THEN
COLOR 11, 1
PRINT TIME$;
ELSE
COLOR 3, 3
PRINT TIME$;
END IF
COLOR 3, 3
END SUB
SUB drwmenu
LOCATE 1, 1
COLOR 11, 1
FOR i% = 1 TO nummenus%
IF i% = p1% THEN COLOR 11, 5
PRINT menu(i%).text;
COLOR 11, 1
NEXT i%
PRINT SPACE$(81 - POS(0));
IF p1% <> pp% THEN COLOR 3, 3: box 2, ((pp% - 1) * 16) + 1, menu(pp%).ni + 3, ((pp% - 1) * 16) + 16, 1: COLOR 3, 3: pp% = p1%
IF md% = 1 THEN
COLOR 11, 1
box 2, ((p1% - 1) * 16) + 1, menu(p1%).ni + 3, ((p1% - 1) * 16) + 16, 0
FOR i% = 1 TO menu(p1%).ni
LOCATE i% + 2, ((p1% - 1) * 16) + 2
IF i% = p2% THEN COLOR 11, 5
PRINT items(p1%, i%).text
COLOR 11, 1
NEXT i%
END IF
PRINT
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB menusys
p1% = 1
p2% = 0
md% = 0
pp% = 1
4 COLOR 3, 3
FOR i% = 2 TO 24
LOCATE i%, 1: PRINT SPACE$(80);
NEXT i%
DO
drwmenu
drwclock 1
key$ = INKEY$
IF min! > 0 THEN
IF count% = 0 THEN
IF key$ = "" THEN s! = TIMER: count% = 1
ELSE
IF key$ <> "" THEN
count% = 0
ELSE
IF (TIMER - s!) / 60 > min! THEN scrnsave: count% = 0: GOTO 4
END IF
END IF
END IF
SELECT CASE key$
CASE "":
CASE CHR$(0) + CHR$(80): md% = 1: p2% = p2% + 1
IF p2% > menu(p1%).ni THEN p2% = 1
CASE CHR$(0) + CHR$(72): md% = 1: p2% = p2% - 1
IF p2% < 1 THEN p2% = menu(p1%).ni
CASE CHR$(0) + CHR$(75): pp% = p1%: p1% = p1% - 1: p2% = md%
IF p1% < 1 THEN p1% = nummenus%
CASE CHR$(0) + CHR$(77): pp% = p1%: p1% = p1% + 1: p2% = md%
IF p1% > nummenus% THEN p1% = 1
CASE CHR$(27): pp% = p1%: md% = 0: p2% = 0: tp% = p1%: p1% = 0: drwmenu: p1% = tp%: pp% = tp%
CASE CHR$(13), " ":
IF md% = 0 THEN
md% = 1: p2% = 1
ELSE
t1% = p1%: t2% = p2%
md% = 0: p1% = 0: p2% = 0
action items(t1%, t2%).code
p1% = 1: pp% = 1
COLOR 3, 3
FOR i% = 2 TO 24
LOCATE i%, 1: PRINT SPACE$(80);
NEXT i%
END IF
CASE ELSE
FOR i% = -20 TO -1
IF UCASE$(key$) = UCASE$(shortcut$(i%)) THEN action i%
NEXT i%
END SELECT
LOOP
' up 72 left 75 right 77 down 80 lf 10
END SUB
SUB save (n%)
IF n% = 1 THEN
prn$ = "PRN"
edit$ = "EDIT"
min! = 5
text$ = "Menu 2, by Michael Calkins. Written in BASIC. Press any key to continue."
mode% = 3
speed! = .2
END IF
OPEN "c:\menu2.dat" FOR OUTPUT AS #1
PRINT #1, prn$
PRINT #1, edit$
PRINT #1, min!
PRINT #1, text$
PRINT #1, mode%
PRINT #1, speed!
CLOSE
END SUB
' I have combined my previous screen saver program (modes 0 to 2) with my
' scrolling text screen saver (modes 3, 4), removed monocrome suport, and
' modified them for this Menu 2 program.
SUB scrnsave
COLOR 7, 0: CLS
IF mode% < 0 OR mode% > 4 THEN era% = 1
IF mode% < 3 AND LEN(text$) > 80 THEN erc% = 1
IF speed! > 5 THEN erd% = 1
IF era% = 1 OR erb% = 1 OR erc% = 1 OR erd% = 1 THEN GOTO 3
SELECT CASE mode%
CASE 0: COLOR 0, 0: CLS : SLEEP: COLOR 7, 0: CLS
CASE 1
WHILE INKEY$ = ""
a% = INT(RND * 23) + 1: b% = INT(RND * (80 - LEN(text$))) + 1
C% = INT(RND * 15) + 1
LOCATE a%, b%: COLOR C%, 0: PRINT text$
SLEEP speed!
COLOR 7, 0: CLS
WEND
CASE 2: a% = INT(RND * 23) + 1: b% = INT(RND * (80 - LEN(text$))) + 1: d% = INT(RND * 4)
C% = INT(RND * 15) + 1
WHILE INKEY$ = ""
LOCATE a%, b%: COLOR C%, 0: PRINT text$
SLEEP speed!
COLOR 7, 0: CLS
SELECT CASE d%
CASE 0: a% = a% - 1: b% = b% - 1
CASE 1: a% = a% - 1: b% = b% + 1
CASE 2: a% = a% + 1: b% = b% + 1
CASE 3: a% = a% + 1: b% = b% - 1
END SELECT
IF a% = 0 AND d% = 0 THEN a% = 1: d% = 3
IF a% = 0 AND d% = 1 THEN a% = 1: d% = 2
IF a% = 24 AND d% = 2 THEN a% = 23: d% = 1
IF a% = 24 AND d% = 3 THEN a% = 23: d% = 0
IF b% = 0 AND d% = 0 THEN b% = 1: d% = 1
IF b% = 0 AND d% = 3 THEN b% = 1: d% = 2
IF b% = 81 - LEN(text$) AND d% = 1 THEN b% = 80 - LEN(text$): d% = 0
IF b% = 81 - LEN(text$) AND d% = 2 THEN b% = 80 - LEN(text$): d% = 3
C% = C% + 1
IF C% = 16 THEN C% = 1
WEND
CASE 3, 4
WIDTH 40
textb$ = SPACE$(40) + text$ + SPACE$(40)
l% = INT(RND * 23) + 1
dir% = -1
clr% = INT(RND * 15) + 1
DO
IF mode% = 3 THEN l% = INT(RND * 23) + 1: clr% = INT(RND * 15) + 1
FOR i% = 1 TO LEN(textb$) - 39
COLOR clr%, 0
IF l% < 1 THEN l% = 1: dir% = 1
IF l% > 23 THEN l% = 23: dir% = -1
LOCATE l%, 1: PRINT MID$(textb$, i%, 40)
IF INKEY$ <> "" THEN WIDTH 80: COLOR 7, 0: CLS : GOTO 2
timerl .2
LOCATE l%, 1: PRINT SPACE$(40)
IF mode% = 4 AND i% MOD 2 = 0 THEN l% = l% + dir%
IF mode% = 4 AND i% MOD 5 = 0 THEN clr% = clr% + 1: IF clr% > 15 THEN clr% = 1
NEXT i%
LOOP
END SELECT
2 WHILE INKEY$ <> "": WEND
EXIT SUB
3 PRINT "Screen saver error."
IF era% = 1 THEN PRINT "Invalid configuration: mode must be 0 to 4."
IF erc% = 1 THEN PRINT "Invalid configuration: length of text message for this mode must be less than 80": PRINT "characters."
IF erd% = 1 THEN PRINT "Invalid configuration: speed must be 5 or less."
GOTO 2
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
'place mines
FOR i = 1 TO nmines
DO
x = INT(RND * xsize)
y = INT(RND * ysize)
LOOP WHILE grid(x, y) OR (x = cx AND y = cy)
grid(x, y) = -1
NEXT i
'place nums
FOR x = 0 TO xsize - 1
FOR y = 0 TO ysize - 1
IF grid(x, y) <> -1 THEN
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF grid(ix, iy) = -1 THEN grid(x, y) = grid(x, y) + 1
END IF
NEXT i
END IF
wgrid(x, y) = -2
NEXT y
NEXT x
'solve
wgrid(cx, cy) = grid(cx, cy)
DO
IF LEN(INKEY$) THEN EXIT DO
FOR x = 0 TO xsize - 1
FOR y = 0 TO ysize - 1
IF grid(x, y) > 0 THEN
n = 0
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF wgrid(ix, iy) = -2 THEN n = n + 1
END IF
NEXT i
IF n = wgrid(x, y) THEN
'all mines
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF wgrid(ix, iy) = -2 THEN flag ix, iy
END IF
NEXT i
END IF
st = -1
ELSEIF grid(x, y) = 0 THEN
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF wgrid(ix, iy) = -2 THEN ch ix, iy
END IF
NEXT i
st = -1
END IF
IF st THEN EXIT FOR
NEXT y
IF st THEN EXIT FOR
NEXT x
IF NOT st THEN
'next method
STOP
END IF
st = 0
LOOP
SYSTEM
SUB ch (x, y)
wgrid(x, y) = grid(x, y)
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF wgrid(ix, iy) = -1 THEN wgrid(x, y) = wgrid(x, y) - 1
END IF
NEXT i
END SUB
SUB disp
CLS
FOR y = ysize - 1 TO 0 STEP -1
FOR x = 0 TO xsize - 1
SELECT CASE wgrid(x, y)
CASE -1: PRINT "X";
CASE 0: PRINT " ";
CASE ELSE: PRINT CHR$(grid(x, y) + &H30);
END SELECT
NEXT x
PRINT
NEXT y
END SUB
SUB flag (x, y)
nrem = nrem - 1
wgrid(x, y) = -1
ix = x - 1
iy = y - 1
FOR i = 0 TO 7
SELECT CASE i
CASE IS < 2: ix = ix + 1
CASE 2, 3: iy = iy + 1
CASE 4, 5: ix = ix - 1
CASE IS > 5: iy = iy - 1
END SELECT
IF (ix >= 0) AND (ix < xsize) AND (iy >= 0) AND (iy < ysize) THEN
IF wgrid(ix, iy) > 0 THEN wgrid(ix, iy) = wgrid(ix, iy) - 1
END IF
NEXT i
t = LCASE$(t)
FOR i = 1 TO LEN(t)
SELECT CASE MID$(t, i, 1)
CASE "a": s = s + ".-"
CASE "b": s = s + "-..."
CASE "c": s = s + "-.-."
CASE "d": s = s + "-.."
CASE "e": s = s + "."
CASE "f": s = s + "..-."
CASE "g": s = s + "--."
CASE "h": s = s + "...."
CASE "i": s = s + ".."
CASE "j": s = s + ".---"
CASE "k": s = s + "-.-"
CASE "l": s = s + ".-.."
CASE "m": s = s + "--"
CASE "n": s = s + "-."
CASE "o": s = s + "---"
CASE "p": s = s + ".--."
CASE "q": s = s + "--.-"
CASE "r": s = s + ".-."
CASE "s": s = s + "..."
CASE "t": s = s + "-"
CASE "u": s = s + "..-"
CASE "v": s = s + "...-"
CASE "w": s = s + ".--"
CASE "x": s = s + "-..-"
CASE "y": s = s + "-.--"
CASE "z": s = s + "--.."
CASE "0": s = s + "-----"
CASE "1": s = s + ".----"
CASE "2": s = s + "..---"
CASE "3": s = s + "...--"
CASE "4": s = s + "....-"
CASE "5": s = s + "....."
CASE "6": s = s + "-...."
CASE "7": s = s + "--..."
CASE "8": s = s + "---.."
CASE "9": s = s + "----."
CASE ".": s = s + ".-.-.-"
CASE ",": s = s + "--..--"
CASE "?": s = s + "..--.."
CASE "'": s = s + ".----."
CASE "!": s = s + "-.-.--"
CASE "/": s = s + "-..-."
CASE "(": s = s + "-.--."
CASE ")": s = s + "-.--.-"
CASE "&": s = s + ".-..."
CASE ":": s = s + "---..."
CASE ";": s = s + "-.-.-."
CASE "=": s = s + "-...-"
CASE "+": s = s + ".-.-."
CASE "-": s = s + "-....-"
CASE "_": s = s + "..--.-"
CASE CHR$(&H22): s = s + ".-..-."
CASE "$": s = s + "...-..-"
CASE "@": s = s + ".--.-."
CASE " ": s = s + " "
END SELECT
s = s + " "
NEXT i
PRINT t
PRINT s
PLAY "t120o3"
FOR i = 1 TO LEN(s)
SELECT CASE MID$(s, i, 1)
CASE ".": PLAY "l32e"
CASE "-": PLAY "l16e."
CASE " ": PLAY "l16n0"
END SELECT
PLAY "l32n0"
NEXT i
One of my goals for a long time as a programmer has been to write a working chess engine. This is my best attempt so far. However, there is some sort of bug in the way the computer evaluates or decides a move. It contains code derived from my contribution to kreigspiel referee.
'current work file c:\q\newchess.bas
'this project is partially derived from:
'my portion of kref (legal move and game over logic)
'my new tic tac toe (computer player logic)
'fixed a few bugs (hopefully unique to this instead of in kref also)
'check Kriegspiel to make sure isthreatened checks for king
'check Kriegspiel to verify that source and dest can't be same
'check Kriegspeil legal to check that during en passant, Y must be correct
'check Kriegspeil to check whether nonlinear bishop and queen moves are possible
'check Kriegspiel block function DO UNTIL (x = dx) OR (y = dy)
DEFINT A-Z
DECLARE FUNCTION nt$ (sx%, sy%, dx%, dy%)
DECLARE FUNCTION over% (br%, me%)
DECLARE FUNCTION block% (br%, sx%, sy%, dx%, dy%)
DECLARE SUB copyb (s%, d%)
DECLARE SUB disp (hmn%, sx%, sy%, dx%, dy%)
DECLARE SUB initgame ()
DECLARE FUNCTION legal% (br%, me%, sx%, sy%, dx%, dy%)
DECLARE FUNCTION mvalue% (piece%)
DECLARE FUNCTION threat% (br%, me%, x%, y%)
DECLARE FUNCTION vinp% (min$)
CLEAR , , 8000
CONST pawn = 2 'note these are not the material values. see mvalue for that
CONST bishop = 4
CONST knight = 8
CONST rook = 16
CONST queen = 32
CONST king = 64
CONST maxdepth = 8
DIM SHARED brd(0 TO maxdepth, 0 TO 7, 0 TO 7)
DIM SHARED flags(0 TO maxdepth)
'bit meaning
'0-3 if bit 8, then X pos of pawn that moved 2 squares
'4 white king and kingside rook not moved
'5 white king and queenside rook not moved
'6 black king and kingside rook not moved
'7 black king and queenside rook not moved
'8 pawn moved 2 squares in last move; bits 0-3 become meaningful
DIM SHARED mat(0 TO maxdepth, 0 TO 1)
DIM SHARED kingx(0 TO maxdepth, 0 TO 1)
DIM SHARED kingy(0 TO maxdepth, 0 TO 1)
DIM turn
TYPE lstt
sx AS INTEGER
sy AS INTEGER
dx AS INTEGER
dy AS INTEGER
END TYPE
DIM SHARED lst(0 TO 1023) AS lstt
DIM best(0 TO maxdepth - 1)
DIM bm(0 TO maxdepth - 1) AS lstt
'DIM bms(0 TO maxdepth - 1) AS lstt
DIM vi(0 TO maxdepth - 1)
DIM eval AS LONG
targetdepth = 6
PALETTE 6, 56
initgame
sx = -1: sy = -1: dx = -1: dy = -1
DO
me = turn AND 1
IF me THEN mel$ = "Black" ELSE mel$ = "White"
disp 0, sx, sy, dx, dy
gover = over(0, me)
IF gover < 1 THEN
IF gover THEN
PRINT "checkmate"
ELSE
PRINT "draw"
END IF
SYSTEM
END IF
PRINT mel$; " to move: "
SELECT CASE me
CASE 0: GOSUB human
CASE 1: GOSUB computer
END SELECT
lst(turn).sx = sx: lst(turn).sy = sy: lst(turn).dx = dx: lst(turn).dy = dy
copyb 1, 0
turn = turn + 1
LOOP
SYSTEM
human:
DO
DO
DO
LOCATE 15, 1
PRINT SPACE$(80);
LOCATE 15, 1
LINE INPUT "Move? "; mv$
mv$ = LCASE$(mv$)
IF mv$ = "q" THEN SYSTEM
LOOP UNTIL vinp(mv$)
sx = ASC(LEFT$(mv$, 1)) - &H61
sy = ASC(MID$(mv$, 2, 1)) - &H31
dx = ASC(MID$(mv$, 3, 1)) - &H61
dy = ASC(RIGHT$(mv$, 1)) - &H31
LOOP UNTIL brd(0, sx, sy) AND ((brd(0, sx, sy) AND 1) = me)
LOOP UNTIL legal(0, me, sx, sy, dx, dy)
RETURN
computer:
'note: eventually, this code might be made so that state can be preserved
'between moves, and that the computer's loops can be interrupted. When it
'is the human's turn, this loop will be run while waiting for human input.
'in either human vs cmp, or cmp vs cmp, there will be one computer thought
'state. when a move is made, the arrays and state will be advanced one move.
'in the case of human vs cmp, if the human makes an unexpected move, the
'state will be flushed. Otherwise, it will resume where it left off. In the
'case of cmp vs cmp play, when a move is made, or in hmn vs cmp play, when an
'expected move is made, or in the case of the target search being reached
'before the timer expires (in the case of a cmp), or before the human moves,
'then the search will continue, using the best move so far as the start.
'the above is the plan for the future, but will not be implemented now. it
'might be gradually implemented.
'note that currently, the bm() array does not describe a sequence of moves,
'but is used to track the best move independantly at each given depth, during
'the search.
PRINT "Target depth:"; targetdepth
PRINT "Moves seen:"
PRINT "Current eval:"
PRINT "Best move list:"
PRINT "Best score:"
depth = 0
vme = me
dir = 1 OR (me = 1) '1 or -1
eval = 0
deeper:
best(depth) = &H7FFF
sx = 0
DO
sy = 0
DO
SELECT CASE brd(depth, sx, sy) XOR vme
CASE pawn
dx = sx: dy = sy + dir
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
IF dy = 3 + vme THEN
dx = sx: dy = sy + dir + dir
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
IF sx < 7 THEN
dx = sx + 1: dy = sy + dir
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
IF sx > 0 THEN
dx = sx - 1: dy = sy + dir
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
CASE bishop
FOR i = 0 TO 3
SELECT CASE i
CASE 0: ix = -1: iy = 1
CASE 1: ix = 1: iy = 1
CASE 2: ix = 1: iy = -1
CASE 3: ix = -1: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(depth, dx, dy) > 0) AND ((brd(depth, dx, dy) AND 1) = vme) THEN EXIT DO
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
IF brd(depth, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE knight
FOR i = 0 TO 7
SELECT CASE i
CASE 0: dx = sx - 1: dy = sy - 2
CASE 1: dx = sx - 2: dy = sy - 1
CASE 2: dx = sx - 1: dy = sy + 2
CASE 3: dx = sx - 2: dy = sy + 1
CASE 4: dx = sx + 1: dy = sy - 2
CASE 5: dx = sx + 2: dy = sy - 1
CASE 6: dx = sx + 1: dy = sy + 2
CASE 7: dx = sx + 2: dy = sy + 1
END SELECT
IF (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7) THEN
IF (brd(depth, dx, dy) = 0) OR ((brd(depth, dx, dy) AND 1) <> vme) THEN
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
END IF
NEXT i
CASE rook
FOR i = 0 TO 3
SELECT CASE i
CASE 0: ix = -1: iy = 0
CASE 1: ix = 0: iy = 1
CASE 2: ix = 1: iy = 0
CASE 3: ix = 0: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(depth, dx, dy) > 0) AND ((brd(depth, dx, dy) AND 1) = vme) THEN EXIT DO
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
IF brd(depth, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE queen
FOR i = 0 TO 7
SELECT CASE i
CASE 0: ix = -1: iy = 0
CASE 1: ix = -1: iy = 1
CASE 2: ix = 0: iy = 1
CASE 3: ix = 1: iy = 1
CASE 4: ix = 1: iy = 0
CASE 5: ix = 1: iy = -1
CASE 6: ix = 0: iy = -1
CASE 7: ix = -1: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(depth, dx, dy) > 0) AND ((brd(depth, dx, dy) AND 1) = vme) THEN EXIT DO
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
IF brd(depth, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE king
FOR i = 0 TO 7
SELECT CASE i
CASE 0: dx = sx - 1: dy = sy
CASE 1: dx = sx - 1: dy = sy + 1
CASE 2: dx = sx: dy = sy + 1
CASE 3: dx = sx + 1: dy = sy + 1
CASE 4: dx = sx + 1: dy = sy
CASE 5: dx = sx + 1: dy = sy - 1
CASE 6: dx = sx: dy = sy - 1
CASE 7: dx = sx - 1: dy = sy - 1
END SELECT
IF (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7) THEN
IF (brd(depth, dx, dy) = 0) OR ((brd(depth, dx, dy) AND 1) <> vme) THEN
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
END IF
NEXT i
dy = sy
dx = sx - 2
IF (dx >= 0) AND (dx <= 7) THEN
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
dy = sy
dx = sx + 2
IF (dx >= 0) AND (dx <= 7) THEN
IF legal(depth, vme, sx, sy, dx, dy) THEN GOSUB hand
END IF
END SELECT
sy = sy + 1
LOOP UNTIL sy = 8
sx = sx + 1
LOOP UNTIL sx = 8
IF FRE(-2) < 2000 THEN PRINT "stack space low": SYSTEM
IF depth THEN RETURN
sx = bm(0).sx
sy = bm(0).sy
dx = bm(0).dx
dy = bm(0).dy
o = legal(0, vme, sx, sy, dx, dy) 'to set up board 1
RETURN
hand:
eval = eval + 1
IF depth <= targetdepth - 3 THEN
LOCATE 16, 19: PRINT eval
LOCATE 17, 20 + (depth * 5)
PRINT nt$(sx, sy, dx, dy); SPACE$(5)
END IF
o = over(depth + 1, vme)
IF o <= 0 THEN
IF o = 0 THEN
score = -1 'draw will have score of -1
ELSE
IF depth AND 1 THEN
score = -30000 + depth'loss will have score of 1000 - num of moves
ELSE
score = 30000 - depth 'win will have score of 1000 - num of moves
END IF
END IF
ELSE
IF depth + 1 = targetdepth THEN
score = mat(depth + 1, me) - mat(depth + 1, me XOR 1)
'add strategic tests here
ELSE
lst(depth + turn).sx = sx
lst(depth + turn).sy = sy
lst(depth + turn).dx = dx
lst(depth + turn).dy = dy
vi(depth) = i
depth = depth + 1
vme = vme XOR 1
dir = 0 - dir
GOSUB deeper
vme = vme XOR 1
dir = 0 - dir
score = best(depth)
depth = depth - 1
sx = lst(depth + turn).sx
sy = lst(depth + turn).sy
dx = lst(depth + turn).dx
dy = lst(depth + turn).dy
i = vi(depth)
END IF
END IF
IF best(depth) = &H7FFF THEN
best(depth) = score
bm(depth).sx = sx
bm(depth).sy = sy
bm(depth).dx = dx
bm(depth).dy = dy
IF depth = 0 THEN GOSUB newbest
ELSE
IF depth AND 1 THEN
IF score < best(depth) THEN
best(depth) = score
bm(depth).sx = sx
bm(depth).sy = sy
bm(depth).dx = dx
bm(depth).dy = dy
END IF
ELSE
IF score > best(depth) THEN
best(depth) = score
bm(depth).sx = sx
bm(depth).sy = sy
bm(depth).dx = dx
bm(depth).dy = dy
IF depth = 0 THEN GOSUB newbest
END IF
END IF
END IF
RETURN
FUNCTION block (br, sx, sy, dx, dy)
ix = SGN(dx - sx): iy = SGN(dy - sy)
x = sx + ix: y = sy + iy
DO UNTIL (x = dx) AND (y = dy)
IF brd(br, x, y) THEN block = -1: EXIT FUNCTION
x = x + ix: y = y + iy
LOOP
block = 0
END FUNCTION
SUB copyb (s, d)
FOR x = 0 TO 7
FOR y = 0 TO 7
brd(d, x, y) = brd(s, x, y)
NEXT y
NEXT x
flags(d) = flags(s)
mat(d, 0) = mat(s, 0)
mat(d, 1) = mat(s, 1)
kingx(d, 0) = kingx(s, 0)
kingy(d, 0) = kingy(s, 0)
kingx(d, 1) = kingx(s, 1)
kingy(d, 1) = kingy(s, 1)
END SUB
SUB disp (hmn, sx, sy, dx, dy)
CLS
PRINT "White material:"; mat(0, 0), "Black material: "; mat(0, 1)
PRINT
IF hmn = 1 THEN n = 7
FOR y = 7 - n TO n - 0 STEP 1 OR (hmn = 0)
FOR x = n - 0 TO 7 - n STEP 1 OR (hmn = 1)
COLOR , ((x + y) AND 1) * 6
IF ((x = sx) AND (y = sy)) OR ((x = dx) AND (y = dy)) THEN
COLOR 14: PRINT CHR$(26);
ELSE
PRINT " ";
END IF
COLOR 15 - ((brd(0, x, y) AND 1) * 5)
SELECT CASE brd(0, x, y) AND &HFFFE
CASE pawn: PRINT "P";
CASE bishop: PRINT "B";
CASE knight: PRINT "N";
CASE rook: PRINT "R";
CASE queen: PRINT "Q";
CASE king: PRINT "K";
CASE ELSE: PRINT " ";
END SELECT
NEXT x
COLOR 5, 0
PRINT y + 1
NEXT y
IF me THEN PRINT " h g f e d c b a" ELSE PRINT " a b c d e f g h"
PRINT
COLOR 7
PRINT
END SUB
SUB initgame
mat(0, 0) = 3900
mat(0, 1) = 3900
kingx(0, 0) = 4
kingx(0, 1) = 4
kingy(0, 0) = 0
kingy(0, 1) = 7
flags(0) = &HF0
FOR i = 0 TO 7
brd(0, i, 1) = pawn
brd(0, i, 6) = 1 OR pawn
NEXT i
brd(0, 0, 0) = rook
brd(0, 7, 0) = rook
brd(0, 1, 0) = knight
brd(0, 6, 0) = knight
brd(0, 2, 0) = bishop
brd(0, 5, 0) = bishop
brd(0, 3, 0) = queen
brd(0, 4, 0) = king
brd(0, 0, 7) = 1 OR rook
brd(0, 7, 7) = 1 OR rook
brd(0, 1, 7) = 1 OR knight
brd(0, 6, 7) = 1 OR knight
brd(0, 2, 7) = 1 OR bishop
brd(0, 5, 7) = 1 OR bishop
brd(0, 3, 7) = 1 OR queen
brd(0, 4, 7) = 1 OR king
turn = 0
END SUB
FUNCTION legal (br, me, sx, sy, dx, dy)
'!!! calling code responsible for source X,Y not being enemy piece or empty.
'!!!
'can't capture own piece
IF brd(br, dx, dy) THEN
IF (brd(br, dx, dy) AND 1) = me THEN legal = 0: EXIT FUNCTION
END IF
'must be a move
IF (sx = dx) AND (sy = dy) THEN legal = 0: EXIT FUNCTION
FOR x = 0 TO 7
FOR y = 0 TO 7
brd(br + 1, x, y) = brd(br, x, y)
NEXT y
NEXT x
flags(br + 1) = flags(br) AND &HF0
mat(br + 1, 0) = mat(br, 0)
mat(br + 1, 1) = mat(br, 1)
IF brd(br, dx, dy) THEN mat(br + 1, me XOR 1) = mat(br + 1, me XOR 1) - mvalue(brd(br, dx, dy))
notpromote = -1
SELECT CASE brd(br, sx, sy) XOR me
CASE pawn
SELECT CASE ABS(dx - sx)
CASE 0
IF brd(br, dx, dy) THEN legal = 0: EXIT FUNCTION
dir = 1 OR (me = 1)
SELECT CASE dy - sy
CASE dir
CASE dir + dir
IF dy <> (3 + me) THEN legal = 0: EXIT FUNCTION
flags(br + 1) = flags(br + 1) OR &H100 OR dx
CASE ELSE: legal = 0: EXIT FUNCTION
END SELECT
CASE 1
IF dy <> (sy + (1 OR (me = 1))) THEN legal = 0: EXIT FUNCTION
IF 0 = brd(br, dx, dy) THEN
IF flags(br) AND &H100 THEN
IF (flags(br) AND &HF) <> dx THEN legal = 0: EXIT FUNCTION
IF sy <> (4 - me) THEN legal = 0: EXIT FUNCTION
brd(br + 1, dx, sy) = 0
mat(br + 1, me XOR 1) = mat(br + 1, me XOR 1) - mvalue(pawn)
ELSE
legal = 0: EXIT FUNCTION
END IF
END IF
CASE ELSE: legal = 0: EXIT FUNCTION
END SELECT
IF me THEN
IF dy = 0 THEN notpromote = 0: brd(br + 1, dx, 0) = queen OR me
ELSE
IF dy = 7 THEN notpromote = 0: brd(br + 1, dx, 7) = queen
END IF
CASE bishop
'must be diagnol
IF (sx = dx) OR (sy = dy) THEN legal = 0: EXIT FUNCTION
IF ABS(dx - sx) <> ABS(dy - sy) THEN legal = 0: EXIT FUNCTION
'can't jump
IF block(br, sx, sy, dx, dy) THEN legal = 0: EXIT FUNCTION
CASE knight
'must be correct
IF (sx = dx) OR (sy = dy) OR ((ABS(dx - sx) + ABS(dy - sy)) <> 3) THEN legal = 0: EXIT FUNCTION
CASE rook
'can't diagnol
IF (sx <> dx) AND (sy <> dy) THEN legal = 0: EXIT FUNCTION
'can't jump
IF block(br, sx, sy, dx, dy) THEN legal = 0: EXIT FUNCTION
CASE queen
IF (sx <> dx) AND (sy <> dy) THEN
IF ABS(dx - sx) <> ABS(dy - sy) THEN legal = 0: EXIT FUNCTION
END IF
IF block(br, sx, sy, dx, dy) THEN legal = 0: EXIT FUNCTION
CASE king
IF (ABS(dx - sx) > 1) OR (ABS(dy - sy) > 1) THEN
IF me THEN
IF dy < 7 THEN legal = 0: EXIT FUNCTION
SELECT CASE dx
CASE 2
IF (flags(br) AND &H80) = 0 THEN legal = 0: EXIT FUNCTION
IF brd(br, 1, 7) THEN legal = 0: EXIT FUNCTION
IF brd(br, 2, 7) THEN legal = 0: EXIT FUNCTION
IF brd(br, 3, 7) THEN legal = 0: EXIT FUNCTION
IF threat(br, me, 3, 7) THEN legal = 0: EXIT FUNCTION
brd(br + 1, 0, 7) = 0
brd(br + 1, 3, 7) = rook OR me
CASE 6
IF (flags(br) AND &H40) = 0 THEN legal = 0: EXIT FUNCTION
IF brd(br, 5, 7) THEN legal = 0: EXIT FUNCTION
IF brd(br, 6, 7) THEN legal = 0: EXIT FUNCTION
IF threat(br, me, 5, 7) THEN legal = 0: EXIT FUNCTION
brd(br + 1, 7, 7) = 0
brd(br + 1, 5, 7) = rook OR me
CASE ELSE: legal = 0: EXIT FUNCTION
END SELECT
ELSE
IF dy > 0 THEN legal = 0: EXIT FUNCTION
SELECT CASE dx
CASE 2
IF (flags(br) AND &H80) = 0 THEN legal = 0: EXIT FUNCTION
IF brd(br, 1, 0) THEN legal = 0: EXIT FUNCTION
IF brd(br, 2, 0) THEN legal = 0: EXIT FUNCTION
IF brd(br, 3, 0) THEN legal = 0: EXIT FUNCTION
IF threat(br, me, 3, 0) THEN legal = 0: EXIT FUNCTION
brd(br + 1, 0, 0) = 0
brd(br + 1, 3, 0) = rook
CASE 6
IF (flags(br) AND &H40) = 0 THEN legal = 0: EXIT FUNCTION
IF brd(br, 5, 0) THEN legal = 0: EXIT FUNCTION
IF brd(br, 6, 0) THEN legal = 0: EXIT FUNCTION
IF threat(br, me, 5, 0) THEN legal = 0: EXIT FUNCTION
brd(br + 1, 0, 0) = 0
brd(br + 1, 5, 0) = rook
CASE ELSE: legal = 0: EXIT FUNCTION
END SELECT
END IF
END IF
IF me THEN
flags(br + 1) = flags(br + 1) AND &H13F
ELSE
flags(br + 1) = flags(br + 1) AND &H1CF
END IF
kingx(br + 1, me) = dx
kingy(br + 1, me) = dy
END SELECT
IF sy = 0 THEN
IF sx = 0 THEN flags(br + 1) = flags(br + 1) AND &H1DF
IF sx = 7 THEN flags(br + 1) = flags(br + 1) AND &H1EF
END IF
IF sy = 7 THEN
IF sx = 0 THEN flags(br + 1) = flags(br + 1) AND &H17F
IF sx = 7 THEN flags(br + 1) = flags(br + 1) AND &H1BF
END IF
IF dy = 0 THEN
IF dx = 0 THEN flags(br + 1) = flags(br + 1) AND &H1DF
IF dx = 7 THEN flags(br + 1) = flags(br + 1) AND &H1EF
END IF
IF dy = 7 THEN
IF dx = 0 THEN flags(br + 1) = flags(br + 1) AND &H17F
IF dx = 7 THEN flags(br + 1) = flags(br + 1) AND &H1BF
END IF
IF notpromote THEN brd(br + 1, dx, dy) = brd(br, sx, sy)
brd(br + 1, sx, sy) = 0
'must not remain in/enter check
IF threat(br + 1, me, kingx(br + 1, me), kingy(br + 1, me)) THEN legal = 0: EXIT FUNCTION
legal = -1
END FUNCTION
FUNCTION mvalue (piece)
SELECT CASE piece AND &H7E
CASE pawn: mvalue = 100
CASE bishop: mvalue = 300
CASE knight: mvalue = 300
CASE rook: mvalue = 500
CASE queen: mvalue = 900
END SELECT
END FUNCTION
FUNCTION nt$ (sx, sy, dx, dy)
nt$ = CHR$(sx + &H61) + CHR$(sy + &H31) + CHR$(dx + &H61) + CHR$(dy + &H31)
END FUNCTION
FUNCTION over (br, me)
'returns 0 if draw, -1 if me checkmated
'otherwise returns # of legal moves of me
dir = 1 OR (me = 1) '1 or -1
FOR sx = 0 TO 7
FOR sy = 0 TO 7
SELECT CASE brd(br, sx, sy) XOR me
CASE pawn
dx = sx: dy = sy + dir
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
IF dy = 3 + me THEN
dx = sx: dy = sy + dir + dir
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
IF sx < 7 THEN
dx = sx + 1: dy = sy + dir
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
IF sx > 0 THEN
dx = sx - 1: dy = sy + dir
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
CASE bishop
FOR i = 0 TO 3
SELECT CASE i
CASE 0: ix = -1: iy = 1
CASE 1: ix = 1: iy = 1
CASE 2: ix = 1: iy = -1
CASE 3: ix = -1: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(br, dx, dy) > 0) AND ((brd(br, dx, dy) AND 1) = me) THEN EXIT DO
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
IF brd(br, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE knight
FOR i = 0 TO 7
SELECT CASE i
CASE 0: dx = sx - 1: dy = sy - 2
CASE 1: dx = sx - 2: dy = sy - 1
CASE 2: dx = sx - 1: dy = sy + 2
CASE 3: dx = sx - 2: dy = sy + 1
CASE 4: dx = sx + 1: dy = sy - 2
CASE 5: dx = sx + 2: dy = sy - 1
CASE 6: dx = sx + 1: dy = sy + 2
CASE 7: dx = sx + 2: dy = sy + 1
END SELECT
IF (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7) THEN
IF (brd(br, dx, dy) = 0) OR ((brd(br, dx, dy) AND 1) <> me) THEN
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
END IF
NEXT i
CASE rook
FOR i = 0 TO 3
SELECT CASE i
CASE 0: ix = -1: iy = 0
CASE 1: ix = 0: iy = 1
CASE 2: ix = 1: iy = 0
CASE 3: ix = 0: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(br, dx, dy) > 0) AND ((brd(br, dx, dy) AND 1) = me) THEN EXIT DO
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
IF brd(br, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE queen
FOR i = 0 TO 7
SELECT CASE i
CASE 0: ix = -1: iy = 0
CASE 1: ix = -1: iy = 1
CASE 2: ix = 0: iy = 1
CASE 3: ix = 1: iy = 1
CASE 4: ix = 1: iy = 0
CASE 5: ix = 1: iy = -1
CASE 6: ix = 0: iy = -1
CASE 7: ix = -1: iy = -1
END SELECT
dx = sx + ix: dy = sy + iy
DO WHILE (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7)
IF (brd(br, dx, dy) > 0) AND ((brd(br, dx, dy) AND 1) = me) THEN EXIT DO
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
IF brd(br, dx, dy) THEN EXIT DO
dx = dx + ix: dy = dy + iy
LOOP
NEXT i
CASE king
FOR i = 0 TO 7
SELECT CASE i
CASE 0: dx = sx - 1: dy = sy
CASE 1: dx = sx - 1: dy = sy + 1
CASE 2: dx = sx: dy = sy + 1
CASE 3: dx = sx + 1: dy = sy + 1
CASE 4: dx = sx + 1: dy = sy
CASE 5: dx = sx + 1: dy = sy - 1
CASE 6: dx = sx: dy = sy - 1
CASE 7: dx = sx - 1: dy = sy - 1
END SELECT
IF (dx >= 0) AND (dx <= 7) AND (dy >= 0) AND (dy <= 7) THEN
IF (brd(br, dx, dy) = 0) OR ((brd(br, dx, dy) AND 1) <> me) THEN
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
END IF
NEXT i
dy = sy
dx = sx - 2
IF (dx >= 0) AND (dx <= 7) THEN
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
dy = sy
dx = sx + 2
IF (dx >= 0) AND (dx <= 7) THEN
IF legal(br, me, sx, sy, dx, dy) THEN lmc = lmc + 1: GOTO haslegalmove
END IF
END SELECT
NEXT sy
NEXT sx
IF lmc = 0 THEN
IF threat(br, me, kingx(br, me), kingy(br, me)) THEN lmc = -1
ELSE
haslegalmove:
'check movelist
END IF
over = lmc
END FUNCTION
FUNCTION threat (br, me, x, y)
dir = 1 OR (me = 1)
FOR i = 0 TO 7
SELECT CASE i
CASE 0: sx = x - 1: sy = y - 2
CASE 1: sx = x - 2: sy = y - 1
CASE 2: sx = x - 1: sy = y + 2
CASE 3: sx = x - 2: sy = y + 1
CASE 4: sx = x + 1: sy = y - 2
CASE 5: sx = x + 2: sy = y - 1
CASE 6: sx = x + 1: sy = y + 2
CASE 7: sx = x + 2: sy = y + 1
END SELECT
IF (sx >= 0) AND (sx <= 7) AND (sy >= 0) AND (sy <= 7) THEN
IF (brd(br, sx, sy) XOR me XOR 1) = knight THEN threat = -1: EXIT FUNCTION
END IF
NEXT i
FOR i = 0 TO 7
SELECT CASE i
CASE 0: ix = -1: iy = 0
CASE 1: ix = -1: iy = 1
CASE 2: ix = 0: iy = 1
CASE 3: ix = 1: iy = 1
CASE 4: ix = 1: iy = 0
CASE 5: ix = 1: iy = -1
CASE 6: ix = 0: iy = -1
CASE 7: ix = -1: iy = -1
END SELECT
sx = x + ix: sy = y + iy
DO WHILE (sx >= 0) AND (sx <= 7) AND (sy >= 0) AND (sy <= 7)
IF (brd(br, sx, sy) > 0) AND ((brd(br, sx, sy) AND 1) = me) THEN EXIT DO
SELECT CASE brd(br, sx, sy) AND &H7E
CASE pawn
IF (ABS(x - sx) = 1) AND (sy = y + dir) THEN threat = -1: EXIT FUNCTION
EXIT DO
CASE bishop
IF i AND 1 THEN threat = -1: EXIT FUNCTION
EXIT DO
CASE rook
IF (i AND 1) = 0 THEN threat = -1: EXIT FUNCTION
EXIT DO
CASE queen: threat = -1: EXIT FUNCTION
CASE king
IF (ABS(x - sx) <= 1) AND (ABS(y - sy) <= 1) THEN threat = -1: EXIT FUNCTION
EXIT DO
END SELECT
sx = sx + ix: sy = sy + iy
LOOP
NEXT i
threat = 0
END FUNCTION
FUNCTION vinp (min$)
IF LEN(min$) <> 4 THEN vinp = 0: EXIT FUNCTION
FOR i = 1 TO 4
SELECT CASE (ASC(MID$(min$, i, 1)) - &H31) - (&H30 AND ((i AND 1) = 1))
CASE IS < 0, IS > 7: vinp = 0: EXIT FUNCTION
END SELECT
NEXT i
vinp = -1
END FUNCTION
DECLARE FUNCTION prgbar$ (per%)
DECLARE FUNCTION lst& (n1&, n2&)
' test
' left off at ABS. Add varibles for remaining procede space. write ABS and
' REMOVE, and write a procede defrag sub.
DECLARE SUB ers ()
DECLARE FUNCTION modif$ (var$)
DECLARE FUNCTION dif& (e1&, e2&)
DECLARE FUNCTION compare& (f1$, f2$)
DECLARE FUNCTION choic% (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE FUNCTION nexw$ (strng$)
DECLARE FUNCTION nexc$ ()
DECLARE FUNCTION size$ (fil$)
DECLARE SUB copy2 (from$, to$)
DECLARE FUNCTION gt$ (prmpt$)
DECLARE SUB sad ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE SUB C (cm%)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
4 CLEAR
' $DYNAMIC
forseg% = 1
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED Monitor$
DIM SHARED SadMode%
DIM SHARED smono%
DIM SHARED SpH%
DIM SHARED SpO%
DIM SHARED SM%
DIM SHARED GoodEga%
DIM SHARED opn%
DIM SHARED numf%
DIM SHARED numt%
DIM SHARED nexcn%
DIM SHARED start%
DIM SHARED strngbu$
DIM SHARED cmp1%
DIM SHARED cmp2%
DIM SHARED fils$
DIM SHARED copydat AS STRING * 1
DIM SHARED nexcdat$(7)
DIM SHARED dat1 AS STRING * 1
DIM SHARED dat2 AS STRING * 1
DIM SHARED mproc%
mproc% = 64
DIM SHARED procede AS STRING * 2048
TYPE pldata:
pn AS STRING * 8
start AS INTEGER
leng AS INTEGER
END TYPE
DIM SHARED pl(1 TO mproc) AS pldata
DIM SHARED pseg#
DIM SHARED poff#
pseg# = VARSEG(procede)
poff# = VARPTR(procede)
DIM SHARED nproc%
dim shared
ON ERROR GOTO term
'sad
PRINT
PRINT
PRINT "Welcome to Mike's Program runner."
copydat = ""
RESTORE
FOR i% = 0 TO 7
READ nexcdat$(i%)
NEXT i%
ech$ = "on"
PRINT "Searching for data file. ";
5
drv$ = ""
IF Exist%("c:\PRGRUN2.dat") = 1 THEN drv$ = "C:"
IF Exist%("a:\PRGRUN2.dat") = 1 THEN drv$ = "A:"
datloc$ = drv$ + "\PRGRUN2.dat"
1
IF Exist%(datloc$) = 1 THEN
PRINT "<done>"
ELSE
PRINT "<failed>"
SELECT CASE UCASE$(choice$("Specify location or Create new data file(S/C)", "S", "s", "C", "c", "s", "s", "s", "s", "s", "s"))
CASE "S": LINE INPUT "Location? (drv:\...\file.ext) "; datloc$: PRINT "Searching for data file. "; : GOTO 1
CASE "C": PRINT : PRINT "Enter for default."
LINE INPUT "('C:\PRGRUN2.DAT') Data file location? "; loc$
LINE INPUT "('C:\PRGRUN2') Path of files? "; path$
LINE INPUT "('20') Max num of open PRGs? "; fils$
IF loc$ = "" THEN loc$ = "C:\PRGRUN2.DAT"
IF path$ = "" THEN path$ = "C:\PRGRUN2"
IF fils$ = "" THEN fils$ = "20"
PRINT "Creating data file. ";
OPEN loc$ FOR OUTPUT AS #1
PRINT #1, loc$
PRINT #1, path$
PRINT #1, VAL(fils$)
PRINT #1, ""
CLOSE
PRINT "<done>"
PRINT "Searching for data file. "; : GOTO 5
END SELECT
END IF
PRINT "Processing data. ";
ON ERROR GOTO cor1
OPEN datloc$ FOR INPUT AS #1
LINE INPUT #1, loc$
LINE INPUT #1, path$
LINE INPUT #1, fils$
LINE INPUT #1, auto$
CLOSE
ON ERROR GOTO term
al% = VAL(al$)
DIM SHARED openfil$(1 TO VAL(fils$))
DIM SHARED parems$(1 TO VAL(fils$), 1 TO 9)
OPEN datloc$ FOR OUTPUT AS #1
PRINT #1, loc$
PRINT #1, path$
PRINT #1, fils$
PRINT #1, ""
CLOSE
IF auto$ <> "" THEN
nam$ = nexw$(auto$)
IF Exist%(nam$ + ".PRG") = 1 AND Exist%(nam$) = 0 THEN nam$ = nam$ + ".prg"
IF Exist%(nam$) = 0 THEN GOTO 8
opn% = 1
OPEN nam$ FOR INPUT AS #1
openfil$(opn%) = nam$
FOR i% = 1 TO 9
parems$(1, i%) = nexw$(auto$)
NEXT i%
END IF
8 PRINT "<done>"
PRINT
2 ON ERROR GOTO term
IF ech$ = "on" THEN com$ = gt$("COMMAND? ")
IF ech$ = "off" THEN com$ = gt$("")
3 strngbu$ = ""
SELECT CASE nexw$(UCASE$(com$))
CASE "":
CASE "EXIT": SYSTEM
CASE "CLS": C 0: PRINT : level& = 0
CASE "PAUSE": PRINT "Press any key to continue.": SLEEP: WHILE INKEY$ <> "": WEND: PRINT : level& = 0
CASE "VER":
PRINT "PRGRUN ver 1.1"
PRINT
level& = 0
CASE "DOS":
IF UCASE$(RTRIM$(LTRIM$(com$))) <> "DOS" THEN
PRINT ENVIRON$(UCASE$(nexw$(com$)))
ELSE
i% = 1
DO
IF ENVIRON$(i%) = "" THEN
EXIT DO
ELSE
PRINT ENVIRON$(i%)
END IF
i% = i% + 1
LOOP
END IF
level& = 0
PRINT
CASE "DATE":
PRINT "Date is "; DATE$
nd$ = gt$("New date? ")
IF nd$ <> "" THEN DATE$ = nd$
PRINT
level& = 0
CASE "TIME":
PRINT "Time is "; TIME$
nt$ = gt$("New time? ")
IF nt$ <> "" THEN TIME$ = nt$
PRINT
level& = 0
CASE "MEM":
PRINT
PRINT "Free string space: "; FRE("")
PRINT "Free non-string array space: "; FRE(-2)
PRINT "Free stack space: "; FRE(-1)
PRINT "Number of open PRG files: "; opn%
PRINT "Max num of open PRG files: "; VAL(fils$)
PRINT "Number of loaded procedures: "; nproc%
PRINT "Max num of procedures: "; mproc%
PRINT
IF UCASE$(nexw$(com$)) = "/D" THEN
PRINT "Segment of is "; VARSEG(forseg%)
PRINT
PRINT "Open PRGs:"
opnf% = 1
DO
IF opnf% > VAL(fils$) THEN EXIT DO
IF openfil$(opnf%) <> "" THEN
PRINT " "; openfil$(opnf%)
FOR i% = 1 TO 9
PRINT parems$(opnf%, i%);
NEXT i%
PRINT
END IF
opnf% = opnf% + 1
LOOP
SLEEP
PRINT
PRINT "Procedures start at seg"; pseg%; "off"; poff%; ". Procedeures:"
PRINT "Name Length", "Start location", "off"
FOR i% = 1 TO nproc%
PRINT pl(i%).pn; pl(i%).leng, pl(i%).start, (pl(i%).start - 1) + poff%
NEXT i%
PRINT
END IF
level& = opn%
CASE "RESTART": GOTO 4
CASE "CHOICE": cpr$ = nexw$(com$)
cca$ = UCASE$(nexw$(com$)): IF cca$ = "" THEN cca$ = "Y"
ccb$ = UCASE$(nexw$(com$)): IF ccb$ = "" THEN ccb$ = "N"
ccc$ = UCASE$(nexw$(com$)): IF ccc$ = "" THEN ccc$ = cca$
ccd$ = UCASE$(nexw$(com$)): IF ccd$ = "" THEN ccd$ = cca$
cce$ = UCASE$(nexw$(com$)): IF cce$ = "" THEN cce$ = cca$
ccf$ = UCASE$(nexw$(com$)): IF ccf$ = "" THEN ccf$ = cca$
ccg$ = UCASE$(nexw$(com$)): IF ccg$ = "" THEN ccg$ = cca$
cch$ = UCASE$(nexw$(com$)): IF cch$ = "" THEN cch$ = cca$
cci$ = UCASE$(nexw$(com$)): IF cci$ = "" THEN cci$ = cca$
ccj$ = UCASE$(nexw$(com$)): IF ccj$ = "" THEN ccj$ = cca$
level& = choic%(cpr$, cca$, ccb$, ccc$, ccd$, cce$, ccf$, ccg$, cch$, cci$, ccj$)
CASE "REM":
CASE "TYPE": file$ = nexw$(com$)
IF Exist%(file$) = 0 THEN PRINT "File not found.": PRINT : level& = 1: GOTO 2
level& = 0
ON ERROR GOTO typ
PRINT
typ1% = opn% + 1
OPEN file$ FOR INPUT AS typ1%
DO
IF EOF(typ1%) THEN EXIT DO
LINE INPUT #typ1%, typ1$
PRINT typ1$
LOOP
CLOSE typ1%
PRINT
CASE "ECHO":
SELECT CASE UCASE$(LTRIM$(RTRIM$(com$)))
CASE "ECHO": PRINT "ECHO is "; ech$; ".": PRINT
CASE "ECHO ON": ech$ = "on": level& = 1
CASE "ECHO OFF": ech$ = "off": level& = 0
CASE ELSE: level& = 0
locof% = INSTR(1, com$, ">")
IF locof% <> 0 THEN
locof2% = INSTR(1, com$, ">>")
IF locof2% = 0 THEN
disf% = FREEFILE
sbu% = start%
start% = locof% + 1
OPEN nexw$(com$) FOR OUTPUT AS disf%
PRINT #disf%, MID$(com$, 6, locof% - 6)
CLOSE disf%
start% = sbu%
ELSE
disf% = FREEFILE
sbu% = start%
start% = locof% + 2
OPEN nexw$(com$) FOR APPEND AS disf%
PRINT #disf%, MID$(com$, 6, locof% - 6)
CLOSE disf%
start% = sbu%
END IF
ELSE
PRINT MID$(com$, 6, LEN(com$) - 5)
END IF
END SELECT
CASE "RUN": file$ = nexw$(com$): level& = 0
IF file$ = "" THEN GOTO 2
IF Exist%(file$ + ".PRG") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".prg"
IF Exist%(file$) = 0 THEN PRINT "File not found.": level& = 1: GOTO 2
opn% = 1
CLOSE
ERASE openfil$
DIM SHARED openfil$(1 TO VAL(fils$))
ers
OPEN file$ FOR INPUT AS #1
openfil$(1) = file$
FOR i% = 1 TO 9
parems$(1, i%) = nexw$(com$)
NEXT i%
CASE "CALL": file$ = nexw$(com$): level& = 0
IF file$ = "" THEN GOTO 2
IF Exist%(file$ + ".PRG") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".prg"
IF Exist%(file$) = 0 THEN PRINT "File not found.": level& = 1: GOTO 2
opn% = opn% + 1
OPEN file$ FOR INPUT AS opn%
openfil$(opn%) = file$
FOR i% = 1 TO 9
parems$(opn%, i%) = nexw$(com$)
NEXT i%
CASE "EXE": level& = 0
prg$ = nexw$(com$)
IF prg$ = "" THEN GOTO 2
file$ = nexw$(com$)
FOR i% = 1 TO 9
file$ = file$ + " " + nexw$(com$)
NEXT i%
IF Exist%(file$ + ".PRG") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".prg"
IF Exist%(file$) = 0 AND file$ <> "" THEN PRINT "File not found.": level& = 1: GOTO 2
CLOSE : opn% = 0
OPEN datloc$ FOR OUTPUT AS #1
PRINT #1, datloc$
PRINT #1, path$
PRINT #1, VAL(fils$)
PRINT #1, file$
CLOSE
OPEN path$ + "\temp.bat" FOR OUTPUT AS #1
PRINT #1, "@echo off"
PRINT #1, "call "; prg$
CLOSE
SYSTEM
CASE "CD": level& = 0
dir$ = nexw$(com$)
ON ERROR GOTO cd
CHDIR dir$
ON ERROR GOTO term
CASE "MD": level& = 0
dir$ = nexw$(com$)
ON ERROR GOTO md
MKDIR dir$
ON ERROR GOTO term
CASE "RD": level& = 0
dir$ = nexw$(com$)
ON ERROR GOTO rd
RMDIR dir$
ON ERROR GOTO term
CASE "ERASE": level& = 0
file$ = nexw$(com$)
ON ERROR GOTO er
KILL file$
ON ERROR GOTO term
CASE "COPY": from$ = nexw$(com$): level& = 0
IF Exist%(from$) = 0 THEN PRINT "File not found.": level& = 1: PRINT : GOTO 2
to$ = nexw$(com$)
IF Exist%(to$) = 1 THEN
level& = -1
PRINT "Source: "; from$; " ("; size$(from$); ")"
PRINT "Target: "; to$; " ("; size$(to$); ")"
over$ = UCASE$(choice$(to$ + " exists. Overwrite(Y/N)", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF over$ = "N" THEN level& = -2: GOTO 2
KILL to$
END IF
copy2 from$, to$
PRINT
CASE "MOVE": from$ = nexw$(com$): level& = 0
IF Exist%(from$) = 0 THEN PRINT "File not found.": level& = -1: PRINT : GOTO 2
to$ = nexw$(com$)
IF Exist%(to$) = 1 THEN
level& = -1
PRINT "Source: "; from$; " ("; size$(from$); ")"
PRINT "Target: "; to$; " ("; size$(to$); ")"
over$ = UCASE$(choice$(to$ + " exists. Overwrite(Y/N)", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF over$ = "N" THEN level& = -2: GOTO 2
KILL to$
END IF
copy2 from$, to$
PRINT
IF compare&(from$, to$) = 0 THEN
KILL from$
ELSE
PRINT
PRINT "Files not identical. Did not erase source."
level& = level& - 3
END IF
PRINT
CASE "RENAME": level& = 0
from$ = nexw$(com$)
IF Exist%(from$) = 0 THEN PRINT "File not found.": level& = 1: PRINT : GOTO 2
to$ = nexw$(com$)
PRINT "Renaming "; from$; " to "; to$
ON ERROR GOTO rn
NAME from$ AS to$
ON ERROR GOTO term
CASE "DIR": PRINT : level& = 0
IF UCASE$(LTRIM$(RTRIM$(com$))) = "DIR" THEN
FILES
ELSE
FILES nexw$(com$)
END IF
PRINT
CASE "END": IF opn% > 0 THEN CLOSE opn%: openfil$(opn%) = "": opn% = opn% - 1: level& = 0
CASE "CLOSE": CLOSE : opn% = 0: ERASE openfil$: DIM SHARED openfil$(1 TO VAL(fils$)): ers: level& = 0
CASE "IF": tru% = 0
frst$ = UCASE$(nexw$(com$))
SELECT CASE frst$
CASE "NOT": IF UCASE$(nexw$(com$)) <> "EXIST" THEN PRINT "Syntax error."
IF Exist%(nexw$(com$)) = 0 THEN tru% = 1
CASE "EXIST": IF Exist%(nexw$(com$)) = 1 THEN tru% = 1
CASE ELSE: md$ = nexw$(com$)
last$ = nexw$(com$)
SELECT CASE md$
CASE "=": IF frst$ = last$ THEN tru% = 1
CASE "<": IF VAL(frst$) < VAL(last$) THEN tru% = 1
CASE ">": IF VAL(frst$) > VAL(last$) THEN tru% = 1
CASE "<=": IF VAL(frst$) <= VAL(last$) THEN tru% = 1
CASE ">=": IF VAL(frst$) >= VAL(last$) THEN tru% = 1
CASE "<>": IF frst$ <> last$ THEN tru% = 1
CASE ELSE: PRINT "Syntax error.": PRINT
END SELECT
END SELECT
IF tru% = 1 THEN com$ = MID$(com$, start%, 1 + (LEN(com$) - start%)): GOTO 3
CASE "GOTO": level& = 0
IF opn% = 0 THEN PRINT "Illegal except in PRGs.": level& = 1: PRINT : GOTO 2
lnum% = VAL(nexw$(com$))
IF lnum% < 1 THEN lnum% = 1
CLOSE opn%
OPEN openfil$(opn%) FOR INPUT AS opn%
i% = 0
DO
IF EOF(1) THEN CLOSE opn%: openfil$(opn%) = "": opn% = opn% - 1: PRINT "Invalid line number.": level& = 0: EXIT DO
LINE INPUT #1, com$
i% = i% + 1
IF i% = ln% THEN GOTO 3
LOOP
CASE "COMPARE": PRINT : level& = compare&(nexw$(com$), nexw$(com$)): PRINT
CASE "EXE2": file$ = nexw$(com$)
IF Exist%(file$ + ".EXE") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".EXE"
IF Exist%(file$ + ".COM") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".COM"
IF Exist%(file$) = 0 THEN PRINT "File not found.": level& = 1: GOTO 2
a! = VAL(size$(file$))
exe2% = FREEFILE
OPEN file$ FOR BINARY AS exe2%
DIM dat AS STRING * 1
DIM b%(a! - 1)
i! = 0
DEF SEG = VARSEG(b%(0))
DO
dat = ""
GET exe2%, , dat
IF EOF(exe2%) THEN EXIT DO
POKE VARPTR(b%(0)) + i!, ASC(dat)
i! = i! + 1
LOOP
CLOSE exe2%
CALL absolute(VARPTR(b%(0)))
DEF SEG
level& = VARSEG(b%(0))
ERASE b%
CASE "LOAD": file$ = nexw$(com$)
IF nproc% = mproc% THEN PRINT "Sorry, you can only have"; mproc%; "loaded at one time."
IF Exist%(file$ + ".EXE") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".EXE"
IF Exist%(file$ + ".COM") = 1 AND Exist%(file$) = 0 THEN file$ = file$ + ".COM"
IF Exist%(file$) = 0 THEN PRINT "File not found.": level& = 1: GOTO 2
nproc% = nproc% + 1
gn$ = UCASE$(nexw$(com$))
IF gn$ = "" THEN PRINT "Procedure name required.": GOTO 2
a! = VAL(size$(file$))
exe2% = FREEFILE
OPEN file$ FOR BINARY AS exe2%
DIM dat AS STRING * 1
pl(nproc%).pn = gn$
pl(nproc%).leng = a!
b! = 0
IF nproc% > 1 THEN b! = 1 + pl(nproc% - 1).leng + pl(nproc% - 1).start
pl(nproc%).start = b!
i! = 0
DEF SEG = pseg%
DO
dat = ""
GET exe2%, , dat
IF EOF(exe2%) THEN EXIT DO
POKE poff%, ASC(dat)
i! = i! + 1
LOOP
CLOSE exe2%
DEF SEG
level& = b!
CASE "ABS": gn$ = nexw$(com$)
FOR i% = 1 TO mnum
de
CASE ELSE: level& = 0
transfer$ = path$ + "\prgrun2.bas"
CLOSE
ON ERROR GOTO fl
CHAIN com$
ON ERROR GOTO term
END SELECT
GOTO 2
7
term:
PRINT
PRINT "Error"; ERR; "at"; ERL;
SYSTEM
exis:
nexis% = 0
RESUME NEXT
errsad:
SELECT CASE SadMode%
CASE 12: SadMode% = 13: RESUME
CASE 13: SadMode% = 9: RESUME
CASE 9: SadMode% = 1: RESUME
CASE 1: SadMode% = 0: RESUME NEXT
END SELECT
errsad2:
IF SM% = 3 THEN SpH% = 0
RESUME NEXT
errsad3:
IF SM% = 4 THEN SpO% = 0
RESUME NEXT
errsad4:
GoodEga% = 0
RESUME NEXT
cd:
PRINT "Couldn't change to specified directory."
PRINT
level& = 1
RESUME 2
rd:
PRINT "Couldn't remove directory."
PRINT
level& = 1
RESUME 2
md:
PRINT "Couldn't make directory."
level& = 1
RESUME 9
er:
PRINT "Couldn't erase file."
PRINT
level& = 1
RESUME 2
copy2e:
PRINT "Copy not successful."
PRINT
CLOSE numf%, numt%
level& = 3
RESUME 2
cmp:
PRINT "Compare not successful."
PRINT
CLOSE cmp1%, cmp2%
level& = 3
RESUME 2
rn:
PRINT "Couldn't rename file."
PRINT
level& = 1
RESUME 2
fl:
PRINT "Bad command or file name."
PRINT
level& = 1
RESUME 2
cor1:
PRINT "<failed>"
IF ERR = 62 THEN PRINT "Data file probably corrupt."
RESUME 7
typ:
PRINT "Error displaying file."
PRINT
level& = 1
RESUME 2
9 IF Exist%(dir$ + "\nul") THEN PRINT "Directory already exists."
level& = 2
PRINT
GOTO 2
DATA "-","\","|","/","-","\","|","/"
REM $STATIC
SUB C (cm%)
IF smono% = 1 AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 4 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = cm%
END SUB
FUNCTION choic% (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
PRINT chcz$; "? ";
DO
cky$ = UCASE$(INKEY$)
IF cky$ = chca$ THEN cky% = 1: EXIT DO
IF cky$ = chcb$ THEN cky% = 2: EXIT DO
IF cky$ = chcc$ THEN cky% = 3: EXIT DO
IF cky$ = chcd$ THEN cky% = 4: EXIT DO
IF cky$ = chce$ THEN cky% = 5: EXIT DO
IF cky$ = chcf$ THEN cky% = 6: EXIT DO
IF cky$ = chcg$ THEN cky% = 7: EXIT DO
IF cky$ = chch$ THEN cky% = 8: EXIT DO
IF cky$ = chci$ THEN cky% = 9: EXIT DO
IF cky$ = chcj$ THEN cky% = 10: EXIT DO
IF cky$ <> "" THEN BEEP
LOOP
PRINT cky$
choic% = cky%
END FUNCTION
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
'c 3
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
IF key$ <> "" THEN BEEP
LOOP
PRINT cky$
'IF cp% > 0 THEN c cp%
'if c%=0 then c 1
choice$ = cky$
END FUNCTION
FUNCTION compare& (f1$, f2$)
IF Exist%(f1$) = 0 THEN PRINT "File not found.": level& = -1: EXIT FUNCTION
IF Exist%(f2$) = 0 THEN PRINT "File not found.": level& = -1: EXIT FUNCTION
ON ERROR GOTO cmp
PRINT "Comparing "; f1$; " ("; size$(f1$); ") with "; f2$; " ("; size$(f2$); ")."
id% = 1: sof$ = "yes"
IF size$(f1$) <> size$(f2$) THEN id% = 0: sof$ = "no"
i& = 0
comp& = lst&(VAL(LEFT$(size$(f1$), LEN(size$(f1$)) - 6)), VAL(LEFT$(size$(f2$), LEN(size$(f2$)) - 6)))
cmp1% = FREEFILE
OPEN f1$ FOR BINARY AS 1
cmp2% = FREEFILE
OPEN f2$ FOR BINARY AS 2
per% = -1
prog& = 0
DO
IF EOF(cmp1%) THEN EXIT DO
IF EOF(cmp2%) THEN EXIT DO
dat1 = ""
dat2 = ""
GET cmp1%, , dat1
GET cmp2%, , dat2
prog& = prog& + 1
IF dat1 <> dat2 THEN id% = 0: i& = i& + 1: sof$ = "no"
IF prog& MOD 20 = 0 THEN
oldper% = per%
per% = INT((prog& / comp&) * 100)
IF oldper% \ 5 < per% \ 5 THEN bar$ = prgbar$(per%)
PRINT " "; LTRIM$(STR$(per%)); "% "; bar$;
END IF
LOCATE CSRLIN, 1: PRINT "Ok so far: "; sof$; ". Checking byte"; prog&;
LOOP
oldper% = per%
per% = INT((prog& / comp&) * 100)
IF oldper% \ 5 < per% \ 5 THEN bar$ = prgbar$(per%)
PRINT " "; LTRIM$(STR$(per%)); "% "; bar$;
CLOSE cmp1%, cmp2%
i& = i& + dif&(VAL(size$(f1$)), VAL(size$(f2$)))
LOCATE CSRLIN, 1
IF id% = 1 THEN PRINT "Ok. "
IF id% = 0 THEN PRINT "Not ok."; i&; "bytes not matching."
compare& = i&
ON ERROR GOTO term
END FUNCTION
SUB copy2 (from$, to$)
ON ERROR GOTO copy2e
numf% = FREEFILE
numt% = FREEFILE + 1
nexcn% = 0
comp& = VAL(LEFT$(size$(from$), LEN(size$(from$)) - 6))
OPEN from$ FOR BINARY AS numf%
OPEN to$ FOR BINARY AS numt%
per% = -1
sof& = 0
DO
copydat = ""
GET numf%, , copydat
IF EOF(numf%) THEN EXIT DO
PUT numt%, , copydat
sof& = sof& + 1
IF sof& MOD 20 = 0 THEN
oldper% = per%
per% = INT((sof& / comp&) * 100)
IF oldper% \ 5 < per% \ 5 THEN bar$ = prgbar$(per%)
LOCATE CSRLIN, 1: PRINT nexc$; " "; LTRIM$(STR$(per%)); "% "; bar$;
END IF
LOCATE CSRLIN, 1: PRINT nexc$;
LOOP
oldper% = per%
per% = INT((sof& / comp&) * 100)
IF oldper% \ 5 < per% \ 5 THEN bar$ = prgbar$(per%)
LOCATE CSRLIN, 1: PRINT nexc$; " "; LTRIM$(STR$(per%)); "% "; bar$;
CLOSE numf%, numt%
copydat$ = ""
LOCATE CSRLIN, 1
PRINT "From "; from$; " ("; size$(from$); ") to "; to$; " (now "; size$(to$); ")"
IF size$(from$) <> size$(to$) THEN PRINT "There must have been a problem copying because the bytes don't match.": level& = 2
ON ERROR GOTO term
END SUB
FUNCTION dif& (e1&, e2&)
IF e1& > e2& THEN
dif& = e1& - e2&
ELSE
dif& = e2& - e1&
END IF
END FUNCTION
SUB ers
FOR ers1% = 1 TO VAL(fils$)
FOR ers2% = 1 TO 9
parems$(ers1%, ers2%) = ""
NEXT ers2%
NEXT ers1%
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
FUNCTION gt$ (prmpt$)
6
IF opn% = 0 THEN
PRINT prmpt$;
LINE INPUT ans$
ELSE
IF EOF(opn%) THEN CLOSE opn%: openfil$(opn%) = "": opn% = opn% - 1: GOTO 6
LINE INPUT #opn%, ans$
END IF
gt$ = modif$(ans$)
END FUNCTION
FUNCTION lst& (n1&, n2&)
temp& = n1&
IF n2& < n1& THEN temp& = n2&
lst& = temp&
END FUNCTION
FUNCTION modif$ (var$)
DO
var2$ = UCASE$(var$)
whr% = INSTR(var2$, "ERRORLEVEL")
IF whr% = 0 THEN EXIT DO
var$ = LEFT$(var$, whr% - 1) + LTRIM$(STR$(level&)) + RIGHT$(var$, LEN(var$) - (whr% + 9))
LOOP
FOR i% = 1 TO 9
DO
var2$ = UCASE$(var$)
whr% = INSTR(var2$, "%" + LTRIM$(STR$(i%)))
IF whr% = 0 THEN EXIT DO
pt$ = ""
IF opn% <> 0 THEN pt$ = parems$(opn%, i%)
var$ = LEFT$(var$, whr% - 1) + pt$ + RIGHT$(var$, LEN(var$) - (whr% + 1))
LOOP
NEXT i%
modif$ = var$
END FUNCTION
FUNCTION nexc$
nexct$ = nexcdat$(nexcn%)
nexcn% = nexcn% + 1
IF nexcn% > 7 THEN nexcn% = 0
nexc$ = nexct$
END FUNCTION
FUNCTION nexw$ (strng$)
IF UCASE$(strng$) <> UCASE$(strngbu$) THEN strngbu$ = strng$: start% = 1
found% = 0
FOR i% = start% TO LEN(strng$)
tmp$ = MID$(strng$, i%, 1)
IF tmp$ = " " THEN
IF found% = 1 THEN
a% = i% + 1
DO
tmp3$ = MID$(strng$, a%, 1)
IF tmp3$ <> " " THEN EXIT DO
a% = a% + 1
LOOP
start% = a%
nexw$ = tmp2$
EXIT FUNCTION
END IF
ELSE
tmp2$ = tmp2$ + tmp$
found% = 1
END IF
NEXT i%
start% = i%
nexw$ = tmp2$
END FUNCTION
FUNCTION prgbar$ (per%)
prgbar$ = STRING$(per% \ 5, "Û") + STRING$(20 - (per% \ 5), "°")
END FUNCTION
SUB sad
SadMode% = 12
ON ERROR GOTO errsad
SCREEN SadMode%
ON ERROR GOTO term
smono% = 0
SELECT CASE SadMode%
CASE 12: Monitor$ = "VGA"
CASE 13: Monitor$ = "MCGA"
CASE 9: Monitor$ = "EGA"
CASE 1: Monitor$ = "CGA"
CASE 0: Monitor$ = "Monochrome": smono% = 1
END SELECT
SpH% = 1
SpO% = 1
SM% = 4
ON ERROR GOTO errsad2
SCREEN SM%
ON ERROR GOTO term
SM% = 3
ON ERROR GOTO errsad3
SCREEN SM%
ON ERROR GOTO term
IF SpH% = 1 THEN Monitor$ = Monitor$ + " (Hercules)"
IF SpO% = 1 THEN Monitor$ = Monitor$ + " (Olivetti / AT&T)"
IF SadMode% = 9 THEN
GoodEga% = 1
ON ERROR GOTO errsad4
PALETTE 4, 0
ON ERROR GOTO term
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "> 64K " + Monitor$
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "<= 64K " + Monitor$
END IF
IF SadMode% <> 0 OR SM% <> 0 THEN SCREEN 0: WIDTH 80, 25
C 0
END SUB
FUNCTION size$ (fil$)
fr% = FREEFILE
OPEN fil$ FOR INPUT AS fr%
siz! = LOF(1)
CLOSE fr%
size$ = LTRIM$(STR$(siz!)) + " bytes"
END FUNCTION
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
IF Exist%("c:\prnshr\prnshr.dat") = 0 THEN
PRINT
PRINT "Welcome to Mike's expiremintal printer sharing program."
PRINT
PRINT "1 - This is the computer with the printer"
PRINT "2 - This is not the computer with the printer"
a$ = choice$("Your choice", "1", "2", "", "", "", "", "", "", "", "")
PRINT
SELECT CASE a$
CASE "1"
PRINT
LINE INPUT "(LPT1, LPT2, PRN, etc.) What port is the printer on? "; prn$
cab$ = choice$("Which COM port is the cable to the other computer connected to", "1", "2", "", "", "", "", "", "", "", "")
CASE "2"
PRINT
cab$ = choice$("Which COM port is the cable to the other computer connected to", "1", "2", "", "", "", "", "", "", "", "")
END SELECT
OPEN "c:\prnshr\prnshr.dat" FOR OUTPUT AS 1
PRINT #1, a$
IF a$ = "1" THEN PRINT #1, prn$
PRINT #1, cab$
CLOSE
END IF
OPEN "c:\prnshr\prnshr.dat" FOR INPUT AS 1
LINE INPUT #1, a$
IF a$ = "1" THEN LINE INPUT #1, prn$
LINE INPUT #1, cab$
CLOSE
DIM dat AS STRING * 1
SELECT CASE a$
CASE "1": PRINT "This program is meant to remain in the background. Please minimize it."
PRINT "Press any key to exit."
1 LOCATE 4, 1: PRINT "Waiting. "
IF INKEY$ <> "" THEN CLS : SYSTEM
ON ERROR GOTO notopen
OPEN "COM" + cab$ + ":300,E,8,1,TB2048,RB2048" FOR BINARY AS 1
ON ERROR GOTO term
LOCATE 4, 1: PRINT "Printing."
OPEN prn$ FOR BINARY AS 2
FOR i% = 1 TO 1000: NEXT i%
DO
IF EOF(1) THEN EXIT DO
GET 1, , dat
PUT 2, , dat
LOOP
dat = CHR$(12) ' hopefully eject paper.
PUT 2, , dat
CLOSE
GOTO 1
CASE "2"
IF Exist%("c:\prnshr\prnshr.tmp") = 1 THEN
OPEN "c:\prnshr\prnshr.tmp" FOR INPUT AS #1
LINE INPUT #1, file$
CLOSE
ELSE
LINE INPUT "File? "; file$
IF file$ = "" THEN SYSTEM
END IF
IF Exist%(file$) = 0 THEN PRINT "File '"; file$; "' not found.": SYSTEM
2 PRINT "Trying to open connection on COM"; cab$; ". ";
ON ERROR GOTO notopen2
OPEN "COM" + cab$ + ":300,E,8,1,TB2048,RB2048" FOR BINARY AS 2
ON ERROR GOTO term
PRINT "<Done>"
PRINT "Sending. ";
OPEN file$ FOR BINARY AS 1
DO
IF EOF(1) THEN EXIT DO
GET 1, , dat
PUT 2, , dat
LOOP
CLOSE
PRINT "<Done>"
END SELECT
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL;
SYSTEM
exis:
nexis% = 0
RESUME NEXT
notopen:
RESUME 1
notopen2:
PRINT "<Failed>"
ret$ = choice$("Retry", "Y", "N", "", "", "", "", "", "", "", "")
IF ret$ = "N" THEN SYSTEM
RESUME 2
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
I include Ramdrv, not just Ramdrv2, becuase it seems to contain more explanation.
DECLARE FUNCTION gt$ (prmpt$)
DECLARE SUB defrag ()
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
DIM SHARED kb%
DIM SHARED max%
ON ERROR GOTO term
PRINT
PRINT "Mike's expiremental ram drive program."
PRINT "Note: If this program is terminated, data in ram drive is lost."
PRINT "Maximum columbs is 255."
PRINT "Minimize this program. To acsess ram drive, append commands to instruction"
PRINT "file. See documentation. Or, press"
PRINT "There is no directory structure on the ramdrv."
PRINT "Please run in Windows because of Windows' abillity to multi-task."
PRINT "When active, 'ESC' to exit."
PRINT
IF Exist%("c:\ramdrv.dat") = 1 THEN loc$ = "a:\ramdrv.dat"
IF Exist%("a:\ramdrv.dat") = 1 THEN loc$ = "a:\ramdrv.dat"
IF loc$ = "" THEN
LINE INPUT "(default: 256) Size in lines? "; size$
LINE INPUT "(default: 8) Maximum number of files? "; max$
LINE INPUT "(default: 'c:\ramdrv.int') Instruction file? "; instfile$
ELSE
OPEN loc$ FOR INPUT AS #1
LINE INPUT #1, size$
LINE INPUT #1, max$
LINE INPUT #1, instfile$
CLOSE
END IF
IF size$ = "" THEN size$ = "256"
IF max$ = "" THEN max$ = "8"
IF instfile$ = "" THEN instfile$ = "c:\ramdrv.int"
size% = VAL(size$)
max% = VAL(max$)
PRINT "Size:"; size%; " Max:"; max%; " Inst file: "; instfile$
IF Exist%(instfile$) = 1 THEN PRINT "Inst file already exist.": E% = 1
IF size% < 1 THEN PRINT "Invalid size.": E% = 1
IF max% < 1 THEN PRINT "Invalid max num of files.": E% = 1
IF E% = 1 THEN SYSTEM
TYPE fatdata
filename AS STRING * 12
start AS INTEGER
endl AS INTEGER
END TYPE
max% = max% - 1
size% = size% - 1
DIM SHARED fat(0 TO max%) AS fatdata
DIM SHARED dat$(0 TO size%)
FOR i% = 0 TO max%
fat(i%).filename = ""
NEXT i%
DO
4
IF Exist%(instfile$) = 1 THEN
OPEN instfile$ FOR INPUT AS #1
DO
1
IF kb% = 1 THEN GOTO 4
IF EOF(1) THEN EXIT DO
kb% = 0
3
comm$ = gt$("Command? ")
SELECT CASE UCASE$(comm$)
CASE "COPY IN":
from$ = gt$("From? ")
IF Exist%(from$) = 0 THEN PRINT "File not found.": GOTO 1
to$ = gt$("To? ")
IF LEN(to$) > 12 THEN PRINT "Filename to long": GOTO 1
FOR i% = 0 TO max%
IF fat(i%).filename = to$ + STRING$(12 - LEN(to$), " ") THEN PRINT "File already exists.": GOTO 1
NEXT i%
opn% = -1
FOR i% = max% TO 0 STEP -1
IF fat(i%).filename = STRING$(12, " ") THEN opn% = i%
NEXT i%
IF opn% = -1 THEN PRINT "Cannot exceed maximum number of files.": GOTO 1
ns% = 0
IF opn% > 0 THEN ns% = fat(opn% - 1).endl + 1
fat(opn%).filename = to$
fat(opn%).start = ns%
OPEN from$ FOR INPUT AS #2
lin% = 0
DO
IF EOF(2) THEN EXIT DO
LINE INPUT #2, temp$
IF lin% + ns% > size% THEN PRINT "Out of room.": GOTO 1
dat$(lin% + ns%) = temp$
lin% = lin% + 1
LOOP
CLOSE #2
fat(opn%).endl = (lin% + ns%) - 1
CASE "COPY OUT":
from$ = gt$("From? ")
ex% = -1
FOR i% = 0 TO max%
IF fat(i%).filename = from$ + STRING$(12 - LEN(from$), " ") THEN ex% = i%
NEXT i%
IF ex% = -1 THEN PRINT "File not found.": GOTO 1
to$ = gt$("To? ")
IF Exist%(to$) = 1 THEN PRINT "File already exists.": GOTO 1
OPEN to$ FOR OUTPUT AS #2
FOR i% = fat(ex%).start TO fat(ex%).endl
PRINT #2, dat$(i%)
NEXT i%
CLOSE #2
CASE "DIR":
PRINT "File#", "Filename", "Size (in lines)"
tot% = 0
FOR i% = 0 TO max%
le% = 0
IF fat(i%).filename <> STRING$(12, " ") THEN le% = (fat(i%).endl - fat(i%).start) + 1
tot% = tot% + le%
PRINT i%, fat(i%).filename, le%
NEXT i%
PRINT "Total used space in lines:"; tot%; " Availible space in lines:"; (size% + 1) - tot%
CASE "ERASE"
del$ = gt$("Del? ")
FOR i% = 0 TO max%
IF fat(i%).filename = del$ + STRING$(12 - LEN(del$), " ") THEN ex% = i%
NEXT i%
FOR i% = fat(ex%).start% TO fat(ex%).endl
dat$(i%) = ""
NEXT i%
fat(ex%).filename = ""
fat(ex%).start = 0
fat(ex%).endl = 0
defrag
CASE "RENAME":
from$ = gt$("From? ")
ex% = -1
FOR i% = 0 TO max%
IF fat(i%).filename = from$ + STRING$(12 - LEN(from$), " ") THEN ex% = i%
NEXT i%
IF ex% = -1 THEN PRINT "File not found.": GOTO 1
to$ = gt$("To? ")
ex2% = -1
FOR i% = 0 TO max%
IF fat(i%).filename = to$ + STRING$(12 - LEN(from$), " ") THEN ex2% = i%
NEXT i%
IF ex2% > -1 THEN PRINT "File already exists.": GOTO 1
fat(ex%).filename = to$
END SELECT
LOOP
CLOSE
KILL instfile$
PRINT "Done processing inst file. Please minimize."
END IF
key$ = INKEY$
IF key$ = CHR$(27) THEN GOTO 2
IF UCASE$(key$) = "C" THEN kb% = 1: GOTO 3
LOOP
2 SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
SUB defrag
PRINT "Defrag SUB not complete. Defrag is necessary for erase. If you continue, data"
PRINT "loss will likely occur in ramdrive. I am sorry about the inconvienience and"
PRINT "shall try to write this SUB."
EXIT SUB
FOR i% = 0 TO max%
NEXT i%
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
FUNCTION gt$ (prmpt$)
SELECT CASE kb%
CASE 0: IF EOF(1) THEN PRINT "Incomplete Instruction."
LINE INPUT #1, in$
CASE 1: PRINT prmpt$; : LINE INPUT in$
END SELECT
gt$ = UCASE$(in$)
END FUNCTION
-----------------------------
DECLARE FUNCTION m$ (st$)
DECLARE SUB T (from$)
DECLARE SUB E (from$)
DECLARE SUB defrag ()
DECLARE SUB R (from$, to$)
DECLARE SUB O (from$, to$)
DECLARE SUB In (from$, to$)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
CLEAR , , 500
DIM SHARED nexis%
DIM SHARED one AS STRING * 1
DIM SHARED max%
DIM SHARED siz%
DIM SHARED so%
DIM SHARED dat$
rsv$ = SPACE$(300)
LINE INPUT "Max num of files? "; max$
IF max$ = "" THEN max$ = "64"
max% = VAL(max$)
LINE INPUT "('C:\RAMDRV2.DAT') Instruction file name? "; df$
IF df$ = "" THEN df$ = "C:\RAMDRV2.DAT"
TYPE tfile
nam AS STRING * 12
siz AS INTEGER
start AS INTEGER
END TYPE
DIM SHARED file(1 TO max%) AS tfile
FOR i% = 1 TO max%
file(i%).nam = ""
NEXT i%
'f% = FRE("")
'SELECT CASE f%
'CASE IS > 30000: REDIM dat(1) AS STRING * 25000: siz% = 25000
'CASE IS > 25000 AND f% < 30001: REDIM dat(1) AS STRING * 20000: siz% = 20000
'CASE IS > 20000 AND f% < 25001: REDIM dat(1) AS STRING * 15000: siz% = 15000
'CASE IS > 15000 AND f% < 20001: REDIM dat(1) AS STRING * 10000: siz% = 10000
'CASE IS > 10000 AND f% < 15001: REDIM dat(1) AS STRING * 5000: siz% = 5000
'CASE IS > 5000 AND f% < 10001: REDIM dat(1) AS STRING * 1000: siz% = 1000
'CASE IS > 1000 AND f% < 50001: REDIM dat(1) AS STRING * 500: siz% = 500
'CASE IS > 500 AND f% < 1001: REDIM dat(1) AS STRING * 100: siz% = 100
'END SELECT
'PRINT "Availible space:"; siz%
DO
IF Exist%(df$) = 1 THEN
x% = 1
OPEN df$ FOR INPUT AS 1
DO
1
IF EOF(1) THEN EXIT DO
LINE INPUT #1, inst$
SELECT CASE UCASE$(inst$)
CASE "I": INPUT #1, from$, to$: In from$, to$: n% = FRE("")
CASE "O": INPUT #1, from$, to$: O from$, to$: n% = FRE("")
CASE "R": INPUT #1, from$, to$: R from$, to$: n% = FRE("")
CASE "E": LINE INPUT #1, from$: E from$: n% = FRE("")
END SELECT
LOOP
CLOSE
KILL df$
x% = 0
END IF
2
inst$ = INKEY$
SELECT CASE UCASE$(inst$)
CASE "I": INPUT "From, to"; from$, to$: In from$, to$: n% = FRE("")
CASE "O": INPUT "From, to"; from$, to$: O from$, to$: n% = FRE("")
CASE "R": INPUT "From, to"; from$, to$: R from$, to$: n% = FRE("")
CASE "E": LINE INPUT "Name? "; from$: E from$: n% = FRE("")
CASE "D"
PRINT "#", "Name Start", "Length"
FOR i% = 1 TO so%
PRINT i%, file(i%).nam; " "; file(i%).start, file(i%).siz
NEXT i%
PRINT "Total:"; LEN(dat$); "bytes in"; so%; "files."
PRINT
PRINT "Largest creatible non-string array: "; FRE(-1)
PRINT "Free stack space: "; FRE(-2)
PRINT "Free sting space: "; FRE("")
PRINT
n% = FRE("")
CASE CHR$(27): EXIT DO
CASE "T": LINE INPUT "Name? "; from$: T from$: n% = FRE("")
END SELECT
LOOP
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
term:
IF ERR = 14 THEN
rsv$ = ""
CLOSE 2: defrag: n% = FRE(""): PRINT "Not enough space."
rsv$ = SPACE$(300)
IF x% = 1 THEN RESUME 1
RESUME 2
END IF
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB defrag
n% = 0
FOR i% = 1 TO max%
IF file(i%).nam <> m$("") THEN
z% = 0
IF n% > 0 THEN
IF file(i%).start > file(n%).start + file(n%).siz THEN
MID$(dat$, file(n%).start + file(n%).siz, file(i%).siz) = MID$(dat$, file(i%).start, file(i%).siz)
file(n% + 1).start = file(n%).start + file(n%).siz
file(n% + 1).siz = file(i%).siz
file(n% + 1).nam = file(i%).nam
file(i%).nam = ""
file(i%).start = 0
file(i%).siz = 0
z% = -1
END IF
END IF
n% = i% + z%
END IF
NEXT i%
IF so% > 0 THEN dat$ = LEFT$(dat$, file(so%).start% + file(so%).siz - 1)
IF so% = 0 THEN dat$ = ""
END SUB
SUB E (from$)
from$ = UCASE$(from$)
n% = 0
FOR i% = 1 TO so%
IF file(i%).nam = m$(from$) THEN n% = i%
NEXT i%
IF n% = 0 THEN PRINT "File not in memory.": EXIT SUB
file(n%).nam = ""
file(n%).start = 0
file(n%).siz = 0
so% = so% - 1
defrag
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB In (from$, to$)
to$ = UCASE$(to$)
IF Exist%(from$) = 0 THEN PRINT "File not found.": EXIT SUB
IF so% = max% THEN PRINT "No vacancies."
FOR i% = 1 TO so%
IF file(i%).nam = m$(to$) THEN PRINT "Name already used.": EXIT SUB
NEXT i%
n% = 1
IF so% > 0 THEN
n% = file(so%).start + file(so%).siz
END IF
OPEN from$ FOR BINARY AS 2
'IF n% + LOF(2) - 1 > siz% THEN PRINT "Not enough space.": CLOSE 3: EXIT SUB
'IF LOF(2) + 10000 > FRE("") THEN PRINT "Not enough space.": CLOSE 3: EXIT SUB
FOR i% = 1 TO LOF(2)
GET 2, , one
dat$ = dat$ + one
NEXT i%
file(so% + 1).nam = to$
file(so% + 1).start = n%
file(so% + 1).siz = LOF(2)
CLOSE 2
so% = so% + 1
END SUB
FUNCTION m$ (st$)
m$ = LEFT$(st$, 11) + SPACE$(12 - LEN(LEFT$(st$, 11)))
END FUNCTION
SUB O (from$, to$)
from$ = UCASE$(from$)
IF Exist%(to$) = 1 THEN PRINT "File already exists.": EXIT SUB
n% = 0
FOR i% = 1 TO so%
IF m$(from$) = file(i%).nam THEN n% = i%
NEXT i%
IF n% = 0 THEN PRINT "File not in memory.": EXIT SUB
OPEN to$ FOR BINARY AS 2
FOR i% = file(n%).start TO file(n%).start + file(n%).siz - 1
one = MID$(dat$, i%, 1)
PUT 2, , one
NEXT i%
CLOSE 2
END SUB
SUB R (from$, to$)
from$ = UCASE$(from$)
to$ = UCASE$(to$)
n% = 0
FOR i% = 1 TO so%
IF file(i%).nam = m$(from$) THEN n% = i%
NEXT i%
IF n% = 0 THEN PRINT "File not in memory.": EXIT SUB
file(n%).nam = to$
END SUB
SUB T (from$)
from$ = UCASE$(from$)
n% = 0
FOR i% = 1 TO so%
IF file(i%).nam = m$(from$) THEN n% = i%
NEXT i%
IF n% = 0 THEN PRINT "File not in memory.": EXIT SUB
PRINT MID$(dat$, file(n%).start, file(n%).siz)
END SUB
DECLARE FUNCTION vy! (dir%)
DECLARE SUB intbul (w%)
DECLARE FUNCTION vx! (dir%)
DECLARE SUB intply ()
DECLARE SUB intlev ()
DECLARE SUB game ()
DECLARE SUB sads ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE FUNCTION exist% (efile$)
DIM SHARED nexis%
sads
TYPE rt
st AS INTEGER
x AS SINGLE
y AS SINGLE
si AS INTEGER
sx AS SINGLE
sy AS SINGLE
px AS SINGLE
py AS SINGLE
END TYPE
TYPE pt
x AS SINGLE
y AS SINGLE
dir AS INTEGER
sh AS INTEGER
sx AS SINGLE
sy AS SINGLE
ms AS INTEGER
ac AS SINGLE
px AS SINGLE
py AS SINGLE
li AS INTEGER
sc AS INTEGER
sp AS INTEGER
END TYPE
TYPE alt
x AS SINGLE
y AS SINGLE
dir AS INTEGER
sx AS SINGLE
sy AS SINGLE
s AS SINGLE
px AS SINGLE
py AS SINGLE
des AS INTEGER
END TYPE
TYPE bt
x AS SINGLE
y AS SINGLE
sx AS SINGLE
sy AS SINGLE
px AS SINGLE
py AS SINGLE
tml AS INTEGER
END TYPE
DIM SHARED r(0 TO 53) AS rt
DIM SHARED p AS pt
DIM SHARED b(0 TO 16) AS bt
DIM SHARED al AS alt
DIM SHARED maxx%
DIM SHARED maxy%
DIM SHARED pi AS DOUBLE
DIM SHARED bc%
DIM SHARED c%
DIM SHARED shld%
'KEY 15, CHR$(0) + CHR$(29)
pi = 4 * ATN(1)
maxx% = 640
maxy% = 480 - 16 ' to accomodate for 1 line of text
p.ms = 5
p.ac = .2
al.s = .5
FOR i% = 0 TO 53
SELECT CASE i% MOD 7
CASE 0: r(i%).si = 18
CASE 1, 4: r(i%).si = 9
CASE 2, 3, 5, 6: r(i%).si = 4
END SELECT
NEXT i%
p.sp = 0
DO
COLOR 7, 0: CLS
PRINT "Welcome to Rocks for DOS."
PRINT "1 - Play"
PRINT "2 - High Score"
PRINT "3 - Info"
PRINT "4 - Exit"
SELECT CASE choice$("What will it be", "1", "2", "3", "4", "", "", "", "", "", "")
CASE "1"
game
CASE "4": EXIT DO
END SELECT
LOOP
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
sadserr:
PRINT
PRINT "Sorry, a VGA card is required for 640 x 480, 16 color graphics."
SYSTEM
' modified, c removed
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 15, 1
PRINT pr$; "? ";
LOCATE , , 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE , , 0
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB game
l% = 0
SCREEN 12
p.li = 5
p.sc = 0
'ON KEY(15) GOSUB spl
DO
CLS 0
l% = l% + 1
ro% = l% + 1
IF ro% > 8 THEN ro% = 8
intlev
intply
c% = 0
DO
'shld% = 0
'KEY(15) ON
k$ = INKEY$
SELECT CASE k$ ' 115,116
CASE CHR$(27): KEY(15) OFF: SCREEN 0: EXIT SUB
CASE CHR$(0) + CHR$(72)
fx! = vx!(p.dir)
fy! = vy!(p.dir)
IF fx! * p.ac + p.sx <= p.ms AND fy! * p.ac + p.sy <= p.ms THEN
p.sx = p.sx + fx!
p.sy = p.sy + fy!
ELSE
IF fx! * p.ac + p.sx > p.ms AND fy! * p.ac + p.sy > p.ms THEN
IF ABS(fx!) > ABS(fy!) THEN
p.sy = p.sy - fy! * p.ac
ELSE
p.sx = p.sx - fx! * p.ac
END IF
ELSE
IF fx! * p.ac + p.sx <= p.ms THEN
iy! = fy! * p.ms
IF p.sy > iy! THEN
p.sy = p.sy + 0 - ABS(fy! * p.ac)
ELSE
p.sy = p.sy + ABS(fy! * p.ac)
END IF
ELSE
ix! = fx! * p.ms
IF p.sx > ix! THEN
p.sx = p.sx + 0 - ABS(fx! * p.ac)
ELSE
p.sx = p.sx + ABS(fx! * p.ac)
END IF
END IF
END IF
END IF
CASE CHR$(0) + CHR$(75): p.dir = p.dir - 1: IF p.dir < 0 THEN p.dir = 359
CASE CHR$(0) + CHR$(77): p.dir = p.dir - 1: IF p.dir < 0 THEN p.dir = 359
CASE " ": IF bc% < 15 THEN intbul 0
CASE CHR$(0) + CHR$(80)
SELECT CASE p.sp
CASE 0: p.px = p.x: p.py = p.y: p.x = INT(RND * maxx%): p.y = INT(RND * maxy%): p.sx = 0: p.sy = 0
CASE 1: shld% = 1 - shld%
END SELECT
END SELECT
'KEY(15) STOP
SUB intbul (w%)
IF w% = 0 THEN
FOR i% = 0 TO 14
IF x% = -1 THEN n% = i%
NEXT i%
x = p.x
y = p.y
dir% = p.dir
ELSE
FOR i% = 15 TO 16
IF x% = -1 THEN n% = i%
NEXT i%
x = al.x
y = al.y
dir% = INT(RND * 360)
END IF
b(n%).x = x%
b(n%).y = y%
b(n%).sx = 5 * vx!(dir%)
b(n%).sy = 5 * vy!(dir%)
b(n%).px = -100
b(n%).py = -100
b(n%).tml = 30
END SUB
SUB intlev
FOR i% = 0 TO 53
SELECT CASE i% MOD 7
CASE 0
IF i% MOD 8 < ro% THEN
r(i%).st = 1
DO
r(i%).x = INT(RND) * maxx%
r(i%).y = INT(RND) * maxy%
IF r(i%).x < 50 OR maxx% - r(i%).x < 50 OR r(i%).y < 50 OR maxy% - r(i%).y < 50 THEN EXIT DO
LOOP
r(i%).sx = l% * INT(RND * 1.5 * 5) / 5 + .2
r(i%).sy = l% * INT(RND * 1.5 * 5) / 5 + .2
ELSE
r(i%).st = 0
END IF
r(i%).px = -100
r(i%).py = -100
CASE ELSE: r(i%).st = 0: r(i%).px = -100: r(i%).py = -100
END SELECT
NEXT i%
END SUB
' modified to detect VGA
SUB sads
ON ERROR GOTO sadserr
SCREEN 12
ON ERROR GOTO term
SCREEN 0
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
FUNCTION vx! (dir%)
a% = dir% MOD 180
m% = SGN(180 - dir%)
vx! = SIN(m% * (90 - ABS(90 - a%)) * pi / 180)
END FUNCTION
' work with (cos = b / c, sin = a / c)
FUNCTION vy! (dir%)
a% = dir% + 90
IF a% > 359 THEN a% = a% - 360
a% = a% MOD 180
m% = SGN(180 - dir%)
vy! = SIN(m% * (90 - ABS(90 - a%)) * pi / 180)
END FUNCTION
This message has been edited by MCalkins on Feb 23, 2011 2:48 AM
Warning: this program seems to try to use Smartdrv, which should not be done from Windows.
DECLARE FUNCTION Exist% (efile$)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
CONST numlines% = 64
2
ON ERROR GOTO term
DIM SHARED nexis%
DIM coms(1 TO numlines%) AS STRING * 128
FOR i% = 1 TO numlines%
coms(i%) = ""
NEXT i%
sf% = 1
tmpdir$ = ENVIRON$("TEMP")
IF tmpdir$ = "" THEN tmpdir$ = "c:"
SHELL "mem /m smartdrv > " + tmpdir$ + "\shell2.tmp"
OPEN tmpdir$ + "\shell2.tmp" FOR INPUT AS 1
LINE INPUT #1, sd$
CLOSE
KILL tmpdir$ + "\shell2.tmp"
sd% = 1
IF UCASE$(sd$) = "SMARTDRV IS NOT CURRENTLY IN MEMORY." THEN sd% = 0
IF Exist%(tmpdir$ + "shell2tm.bat") = 1 THEN KILL tmpdir$ + "shell2tm.bat"
IF Exist%(tmpdir$ + "\shell2.ini") = 1 THEN
OPEN tmpdir$ + "\shell2.ini" FOR INPUT AS 1
FOR i% = 1 TO numlines%
LINE INPUT #1, coms(i%)
NEXT i%
LINE INPUT #1, a$
sf% = VAL(a$)
CLOSE
KILL tmpdir$ + "\shell2.ini"
GOTO 4
END IF
PRINT
PRINT "Shell 2 is running. Note: This program requires QBasic and is using a"
PRINT "tremendes amount of conventional memory. ':?' for help."
IF sd% = 1 THEN PRINT "---Since Smartdrv is running, Write behind data will be committed buy the time": PRINT "S2 prompt reappears."
4 IF sd% = 1 THEN SHELL "smartdrv /f > " + tmpdir$ + "\shell2.tmp": KILL tmpdir$ + "\shell2.tmp"
DO
1
SHELL "cd > " + tmpdir$ + "\shell2.tmp"
OPEN tmpdir$ + "\shell2.tmp" FOR INPUT AS 1
LINE INPUT #1, curpath$
CLOSE
KILL tmpdir$ + "\shell2.tmp"
IF sd% = 1 THEN SHELL "smartdrv /c"
PRINT "[S2] "; curpath$
l% = CSRLIN - 1
FOR c% = 6 TO 80
LOCATE l%, c%
IF SCREEN(l%, c%) = 32 THEN EXIT FOR
NEXT c%
LINE INPUT ">"; a$
a$ = RTRIM$(LTRIM$(a$))
IF a$ = "" GOTO 1
3 IF LEFT$(a$, 1) = ":" THEN
SELECT CASE UCASE$(a$)
CASE ":E": EXIT DO
CASE ":M"
PRINT
PRINT "Largest creatible non-string array: "; FRE(-1)
PRINT "Free stack space: "; FRE(-2)
PRINT "Free string space: "; FRE("")
PRINT "Entries of line memory used: "; sf% - 1; "of"; numlines%
SHELL "mem /m qbasic"
GOTO 1
CASE ":H"
OPEN tmpdir$ + "\shell2.tmp" FOR OUTPUT AS 1
FOR i% = 1 TO sf% - 1
PRINT #1, LTRIM$(STR$(i%)); ": "; RTRIM$(coms(i%))
NEXT i%
CLOSE
SHELL "type " + tmpdir$ + "\shell2.tmp | more"
KILL tmpdir$ + "\shell2.tmp"
GOTO 1
CASE ":C"
SHELL
GOTO 2
CASE ":R"
CLEAR
GOTO 2
CASE ":?"
PRINT
PRINT "':E' to exit."
PRINT "':C' to begin a copy of the command interperater. Remeber that Shell2 is"
PRINT " in memory. Type the dos command 'EXIT' to return."
PRINT "':H' to see history."
PRINT "':Ln...' to select line n from history."
PRINT "':M' to see program memory status."
PRINT "':W:nn,nn' to set screen size in columbs and lines."
PRINT "':S:nn' to set screen mode. (see QBasic help for list.)"
PRINT "':R' to restart Shell 2."
PRINT "':F:n...' to execute command n with normal free conventional memory by"
PRINT " temporarily exiting Shell 2."
PRINT "':B:n...' to run BASIC program n. When you are done, exit that program to"
PRINT " return to Shell2."
PRINT "':Fi:n...' to find file n. You may give a path with the file name. The file will"
PRINT " be searched for in that directory and all its subdirectories."
PRINT "Shell 2 is a freeware BASIC program by Michael Calkins (Ph# 830-393-4866)."
PRINT "Since Shell 2 reads and writes to temporary files extensivly, I recommended that"
PRINT "you use Smartdrv disk caching or set the TEMP enviroment varible to a directory"
PRINT "on a ramdrive. Either of these would improve the perfomance of this program."
PRINT
GOTO 1
CASE ELSE
SELECT CASE LEFT$(UCASE$(a$), 3)
CASE ":L:"
a% = VAL(RIGHT$(a$, LEN(a$) - 3))
IF a% < 1 OR a% > numlines% THEN PRINT "Line number must be >= 1 and <="; STR$(numlines%); ".": GOTO 1
IF a% > sf% - 1 THEN PRINT "There have only been"; sf% - 1; "lines so far.": GOTO 1
a$ = RTRIM$(coms(a%))
5 c$ = choice$(a$ + " (Y/N/E)", "Y", "N", "E", "", "", "", "", "", "", "")
IF c$ = "N" THEN GOTO 1
IF c$ = "E" THEN
IF editor$ = "" THEN LINE INPUT "(ENTER for 'EDIT') Editor? "; editor$
IF editor$ = "" THEN editor$ = "EDIT"
OPEN tmpdir$ + "\shell2.tmp" FOR OUTPUT AS 1
PRINT #1, a$
CLOSE
SHELL editor$ + " " + tmpdir$ + "\shell2.tmp"
OPEN tmpdir$ + "\shell2.tmp" FOR INPUT AS 1
LINE INPUT #1, a$
CLOSE
KILL tmpdir$ + "\shell2.tmp"
GOTO 5
END IF
GOTO 3
CASE ":W:"
c% = VAL(MID$(a$, 4, 2))
l% = VAL(MID$(a$, 7, 2))
ON ERROR GOTO wid
WIDTH c%, l%
ON ERROR GOTO term
GOTO 1
CASE ":S:"
a% = VAL(RIGHT$(a$, LEN(a$) - 3))
ON ERROR GOTO scrn
SCREEN a%
ON ERROR GOTO term
GOTO 1
CASE ":F:"
b$ = RIGHT$(a$, LEN(a$) - 3)
IF sf% < numlines% + 1 THEN
coms(sf%) = a$
sf% = sf% + 1
ELSE
FOR i% = 1 TO numlines% - 1
coms(i%) = coms(i% + 1)
NEXT i%
coms(numlines%) = a$
END IF
OPEN tmpdir$ + "\shell2tm.bat" FOR OUTPUT AS 1
PRINT #1, "@echo off"
PRINT #1, b$
CLOSE
OPEN tmpdir$ + "\shell2.ini" FOR OUTPUT AS 1
FOR i% = 1 TO numlines%
PRINT #1, coms(i%)
NEXT i%
PRINT #1, sf%
CLOSE
SYSTEM
CASE ":B:"
b$ = RIGHT$(a$, LEN(a$) - 3)
IF sf% < numlines% + 1 THEN
coms(sf%) = a$
sf% = sf% + 1
ELSE
FOR i% = 1 TO numlines% - 1
coms(i%) = coms(i% + 1)
NEXT i%
coms(numlines%) = a$
END IF
OPEN tmpdir$ + "\shell2tm.bat" FOR OUTPUT AS 1
PRINT #1, "@echo off"
CLOSE
OPEN tmpdir$ + "\shell2.ini" FOR OUTPUT AS 1
FOR i% = 1 TO numlines%
PRINT #1, coms(i%)
NEXT i%
PRINT #1, sf%
CLOSE
ON ERROR GOTO notfound
RUN b$
ON ERROR GOTO term
CASE ELSE
IF LEFT$(UCASE$(a$), 4) = ":FI:" THEN
find$ = RIGHT$(a$, LEN(a$) - 4)
PRINT
SHELL "dir " + find$ + "/p /s /b"
PRINT
GOTO 1
ELSE
PRINT "Not a Shell 2 command."
GOTO 1
END IF
END SELECT
END SELECT
END IF
IF sf% < numlines% + 1 THEN
coms(sf%) = a$
sf% = sf% + 1
ELSE
FOR i% = 1 TO numlines% - 1
coms(i%) = coms(i% + 1)
NEXT i%
coms(numlines%) = a$
END IF
SHELL a$
LOOP
PRINT
PRINT "Thanks for choosing Shell 2, the memory hogging alternitive to DOSKey."
SYSTEM
term:
PRINT "Shell 2 had error"; ERR
PRINT "Shell 2 will now terminate itself."
SYSTEM
wid:
PRINT "40 x 25, 40 x 43, 40 x 50, 80 x 25, 80 x 43, or 80 x 50 text format only."
RESUME 1
scrn:
PRINT "Invalid screen mode or incorrect graphics card."
RESUME 1
exis:
nexis% = 0
RESUME NEXT
notfound:
PRINT "BASIC program not found."
CLEAR
GOTO 2
' This function is used to prompt the user to answer a question using 1 button.
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
' The following insures that none of the parapeters are ""
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
' The following removes case sensitivity.
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
LOCATE CSRLIN, POS(0), 1 ' makes cursor visible
DO
key$ = UCASE$(INKEY$) ' Case sensitivity is removed from input.
' If key is one of the specified keys then exit the loop.
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
' If key is pressed, but not one of the specified keys and sound is enabled then it will beep.
IF key$ <> "" AND snd$ = "Y" THEN BEEP
LOOP
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND ' a good thing to do
LOCATE CSRLIN, POS(0), 0 ' hides cursor
choice$ = sl$
END FUNCTION
' Tests to see if a file exists and can be opened.
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
Some time ago, I mentioned on these forums that I wanted to write a computer emulator or a virtual computer. This is partly inspired by emulators like Bochs, but also by my reading about Turing machines, after having seen a discussion between Mac and GreenMan. This is public domain.
'think about adding 32 bit (will eventually)
'investigate status flags
'implement and verify correct functioning of adc, sbc, div, idiv, mul, imul
'verify carry and overflow flags on all appropriate instructions
'simulates a hypothetical computer
'very simplistic: no interrupts, no ports, no segments. registers are inside
'the addressable memory space.
'while there is some resemblence to x86 assembly, a lot is different. this is
'not meant to be an x86 emulator, although adapting it into a primitive one is
'probably possible. also, i am not sure if using this as a tool to learn
'x86 assembly is a good idea either, because of the extent of the differences.
'16KB of addressable memory (includes registers, keyboard and screen buffers)
'disk simulated in external file (512 bytes to 1 MB)
'first 512 bytes from file are automatically loaded and executed
DEFINT A-Z
DECLARE FUNCTION addword% (n0 AS INTEGER, n1 AS INTEGER, c%, o%)
DECLARE FUNCTION subword% (n0 AS INTEGER, n1 AS INTEGER, c%, o%)
DECLARE SUB byteresult (n AS INTEGER, co AS INTEGER)
DECLARE SUB wordresult (n AS INTEGER, co AS INTEGER)
DECLARE FUNCTION signb% (n%)
DECLARE SUB ww (p%, d%)
DECLARE SUB wb (p%, d%)
DECLARE SUB wd (p%, d&)
DECLARE FUNCTION rw% (p%)
DECLARE FUNCTION rb% (p%)
DECLARE FUNCTION rd& (p%)
CONST memsize = &H4000
CONST maxdisk = &H100000
CONST als = &H200
CONST sbs = &H280
CONST kbs = &H20
CONST ip = 0 '16 bit ip (init to beginning of automatically loaded code)
CONST sp = 2 '16 bit sp (init to top of address space)
CONST bp = 4 '16 bit bp
CONST flags = 6 '16 bit flags
CONST ax = 8 '16 bit ax
CONST bx = &HA '16 bit bx
CONST cx = &HC '16 bit cx
CONST dx = &HE '16 bit dx
CONST si = &H10 '16 bit source index
CONST di = &H12 '16 bit destination index
CONST ddi = &H14 '32 bit disk index
CONST sm = &H18 '16 bit screen mode
CONST kb = &H1A 'keyboard buffer
CONST sb = kb + kbs 'screen buffer
CONST alp = sb + sbs
CONST carry = &H1
CONST overflow = &H2
CONST sign = &H4
CONST zero = &H8
CONST dir = &H10
DIM SHARED mem AS STRING * memsize
DIM b AS STRING * 1
CLS
PRINT "'.scb' will be appended to your input, and used as the disk image."
PRINT "'.scm' will be appended to your input, and used for the memory dump."
LINE INPUT "file? "; f$
OPEN f$ + ".scb" FOR INPUT AS 1: CLOSE 'verify exists
OPEN f$ + ".scb" FOR BINARY AS 1
SELECT CASE LOF(1)
CASE IS < als: PRINT "file too small": SYSTEM
CASE IS > maxdisk: PRINT "file too big": SYSTEM
END SELECT
PRINT "do you wish to load state from the memory dump? no means start fresh."
DO
k$ = LCASE$(INKEY$)
SELECT CASE k$
CASE "y"
PRINT k$
OPEN f$ + ".scm" FOR INPUT AS 2: CLOSE 2 'verify exists
OPEN f$ + ".scm" FOR BINARY AS 2
IF LOF(2) <> memsize THEN PRINT "mem dump size mismatch.": SYSTEM
GET 2, , mem
CLOSE 2
EXIT DO
CASE "n"
PRINT k$
FOR i = 0 TO als - 1
GET 1, , b
wb alp + i, ASC(b)
NEXT i
mem = STRING$(memsize, 0)
MID$(mem, 0, 2) = MKI$(alp)
MID$(mem, 2, 2) = MKI$(memsize - 2)
EXIT DO
END SELECT
LOOP
'update screen
IF updscr THEN
updscr = 0
SELECT CASE rw%(sm)
CASE 0
DEF SEG = &HB800
FOR i = 0 TO sbs - 1
POKE i + i, ASC(MID$(mem, sb + i + 1, 1))
POKE i + i + 1, &H7
NEXT i
CASE 1
DEF SEG = &HB800
FOR i = 0 TO sbs - 1
POKE i, ASC(MID$(mem, sb + i + 1, 1))
NEXT i
END SELECT
END IF
'handle keyboard input
k$ = INKEY$
IF LEN(k$) THEN
IF k$ = CHR$(&H1B) THEN EXIT DO
IF LEN(k$) = 1 THEN
FOR n = kbb TO (kbb + kbs) - 1
IF rb%(n) = 0 THEN
wb n, ASC(k$)
IF n < ((kbb + kbs) - 1) THEN wb n + 1, 0
ELSE
'BEEP
END IF
NEXT n
END IF
END IF
'execute instruction
ipv = rw%(ip)
SELECT CASE rb%(ipv)
CASE &H0 'hlt
STOP
EXIT DO
CASE &H11 'jmp [mem16]
ipv = rw%(rw%(ipv + 1))
CASE &H11 'jmp imm8
ipv = ipv + 2
ipv = ipv + signb%(rb%(ipv - 1))
CASE &H11 'jmp imm16
ipv = ipv + 3
ipv = ipv + rw%(ipv - 2)
CASE &H11 'mov [mem8],byte imm8
ipv = ipv + 4
wb rw%(ipv - 3), rb%(ipv - 1)
CASE &H11 'mov [mem16],word imm16
ipv = ipv + 5
ww rw%(ipv - 4), rw%(ipv - 2)
CASE &H11 'mov [mem8],byte [mem8]
ipv = ipv + 5
wb rw%(ipv - 4), rb%(rw%(ipv - 2))
CASE &H11 'mov [mem16],word [mem16]
ipv = ipv + 5
ww rw%(ipv - 4), rw%(rw%(ipv - 2))
CASE &H11 'xchg [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4))
wb rw%(ipv - 4), rb%(rw%(ipv - 2))
wb rw%(ipv - 2), n
CASE &H11 'xchg [mem16],word [mem16]
ipv = ipv + 5
n = rw%(rw%(ipv - 4))
ww rw%(ipv - 4), rw%(rw%(ipv - 2))
ww rw%(ipv - 2), n
CASE &H11 'readdisk
ipv = ipv + 1
n& = rd&(ddi)
IF n& > maxdisk THEN STOP: EXIT DO
GET 1, n&, b
wb rw%(di), ASC(b)
ww di, rw%(di) + (1 OR ((rw%(flags) AND dir) <> 0))
wd ddi, n& + 1
CASE &H11 'writedisk
ipv = ipv + 1
n& = rd&(ddi)
IF n& > maxdisk THEN STOP: EXIT DO
b = CHR$(rb%(rw%(si)))
PUT 1, n&, b
ww si, rw%(si) + (1 OR ((rw%(flags) AND dir) <> 0))
wd ddi, n& + 1
CASE &H11 'push [mem16]
ipv = ipv + 3
ww sp, rw%(sp) - 2
ww rw%(sp), rw%(rw%(ipv - 2))
CASE &H11 'pop [mem16]
ipv = ipv + 3
ww rw%(ipv - 2), rw%(rw%(sp))
ww sp, rw%(sp) + 2
CASE &H11 'push imm16
ipv = ipv + 3
ww sp, rw%(sp) - 2
ww rw%(sp), rw%(ipv - 2)
CASE &H11 'call imm16
ipv = ipv + 3
ww sp, rw%(sp) - 2
ww rw%(sp), ipv
ipv = ipv + rw%(ipv - 2)
CASE &H11 'call [mem16]
ww sp, rw%(sp) - 2
ww rw%(sp), ipv
ipv = rw%(rw%(ipv + 1))
CASE &H11 'ret
ipv = rw%(rw%(sp))
ww sp, rw%(sp) + 2
CASE &H11 'ret imm8
n = rb%(ipv + 1)
ipv = rw%(rw%(sp))
ww sp, rw%(sp) + 2 + n
CASE &H11 'nop
ipv = ipv + 1
CASE &H11 'and [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) AND rb%(ipv - 1)
wb rw%(ipv - 3), n
byteresult n, 0
CASE &H11 'and [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) AND rb%(rw%(ipv - 2))
wb rw%(ipv - 4), n
byteresult n, 0
CASE &H11 'and [mem16],word imm16
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) AND rw%(ipv - 2)
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'and [mem16],word [mem16]
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) AND rw%(rw%(ipv - 2))
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'or [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) OR rb%(ipv - 1)
wb rw%(ipv - 3), n
byteresult n, 0
CASE &H11 'or [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) OR rb%(rw%(ipv - 2))
wb rw%(ipv - 4), n
byteresult n, 0
CASE &H11 'or [mem16],word imm16
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) OR rw%(ipv - 2)
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'or [mem16],word [mem16]
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) OR rw%(rw%(ipv - 2))
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'xor [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) XOR rb%(ipv - 1)
wb rw%(ipv - 3), n
byteresult n, 0
CASE &H11 'xor [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) XOR rb%(rw%(ipv - 2))
wb rw%(ipv - 4), n
byteresult n, 0
CASE &H11 'xor [mem16],word imm16
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) XOR rw%(ipv - 2)
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'xor [mem16],word [mem16]
ipv = ipv + 5
n = rw%(rw%(ipv - 4)) XOR rw%(rw%(ipv - 2))
ww rw%(ipv - 4), n
wordresult n, 0
CASE &H11 'not byte [mem8]
ipv = ipv + 3
n = NOT rb%(rw%(ipv - 2))
wb rw%(ipv - 2), n
byteresult n, 0
CASE &H11 'not word [mem16]
ipv = ipv + 3
n = NOT rw%(rw%(ipv - 2))
ww rw%(ipv - 2), n
wordresult n, 0
CASE &H11 'neg byte [mem8]
CASE &H11 'neg word [mem16]
CASE &H11 'inc byte [mem8]
ipv = ipv + 3
n = rb%(rw%(ipv - 2)) + 1
c = n = &H100
IF c THEN n = 0
o = n = &H80
wb rw%(ipv - 2), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'inc word [mem16]
ipv = ipv + 3
n = addword%(rw%(rw%(ipv - 2)), 1, c, o)
ww rw%(ipv - 2), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'dec byte [mem8]
ipv = ipv + 3
n = rb%(rw%(ipv - 2)) - 1
c = n = &HFFFF
IF c THEN n = &HFF
o = n = &H7F
wb rw%(ipv - 2), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'dec word [mem16]
ipv = ipv + 3
n = subword%(rw%(rw%(ipv - 2)), 1, c, o)
ww rw%(ipv - 2), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'test [mem8],byte imm8
ipv = ipv + 4
byteresult rb%(rw%(ipv - 3)) AND rb%(ipv - 1), 0
CASE &H11 'test [mem8],byte [mem8]
ipv = ipv + 5
byteresult rb%(rw%(ipv - 4)) AND rb%(rw%(ipv - 2)), 0
CASE &H11 'test [mem16],word imm16
ipv = ipv + 5
wordresult rw%(rw%(ipv - 4)) AND rw%(ipv - 2), 0
CASE &H11 'test [mem16],word [mem16]
ipv = ipv + 5
wordresult rw%(rw%(ipv - 4)) AND rw%(rw%(ipv - 2)), 0
CASE &H11 'add [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) + rb%(ipv - 1)
c = n >= &H100
IF c THEN n = n AND &HFF
o = n >= &H80
wb rw%(ipv - 3), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'add [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) + rb%(rw%(ipv - 2))
c = n >= &H100
IF c THEN n = n AND &HFF
o = n >= &H80
wb rw%(ipv - 4), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'add [mem16],word imm16
ipv = ipv + 5
n = addword%(rw%(rw%(ipv - 4)), rw%(ipv - 2), c, o)
ww rw%(ipv - 4), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'add [mem16],word [mem16]
ipv = ipv + 5
n = addword%(rw%(rw%(ipv - 4)), rw%(rw%(ipv - 2)), c, o)
ww rw%(ipv - 4), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'sub [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) - rb%(ipv - 1)
c = n <= &HFFFF 'should be same as c=n0<n1
IF c THEN n = &HFF
o = n >= &H80
wb rw%(ipv - 2), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'sub [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) - rb%(rw%(ipv - 2))
c = n <= &HFFFF 'should be same as c=n0<n1
IF c THEN n = &HFF
o = n >= &H80
wb rw%(ipv - 4), n
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'sub [mem16],word imm16
ipv = ipv + 5
n = subword%(rw%(rw%(ipv - 4)), rw%(ipv - 2), c, o)
ww rw%(ipv - 4), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'sub [mem16],word [mem16]
ipv = ipv + 5
n = subword%(rw%(rw%(ipv - 4)), rw%(rw%(ipv - 2)), c, o)
ww rw%(ipv - 4), n
wordresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'cmp [mem8],byte imm8
ipv = ipv + 4
n = rb%(rw%(ipv - 3)) - rb%(ipv - 1)
c = n <= &HFFFF 'should be same as c=n0<n1
IF c THEN n = &HFF
o = n >= &H80
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'cmp [mem8],byte [mem8]
ipv = ipv + 5
n = rb%(rw%(ipv - 4)) - rb%(rw%(ipv - 2))
c = n <= &HFFFF 'should be same as c=n0<n1
IF c THEN n = &HFF
o = n >= &H80
byteresult n, (c AND carry) OR (o AND overflow)
CASE &H11 'cmp [mem16],word imm16
ipv = ipv + 5
wordresult subword%(rw%(rw%(ipv - 4)), rw%(ipv - 2), c, o), (c AND carry) OR (o AND overflow)
CASE &H11 'cmp [mem16],word [mem16]
ipv = ipv + 5
wordresult subword%(rw%(rw%(ipv - 4)), rw%(rw%(ipv - 2)), c, o), (c AND carry) OR (o AND overflow)
CASE &H11 'adc [mem8],byte imm8
CASE &H11 'adc [mem8],byte [mem8]
CASE &H11 'adc [mem16],word imm16
CASE &H11 'adc [mem16],word [mem16]
CASE &H11 'sbc [mem8],byte imm8
CASE &H11 'sbc [mem8],byte [mem8]
CASE &H11 'sbc [mem16],word imm16
CASE &H11 'sbc [mem16],word [mem16]
CASE &H11 'shl byte [mem8],imm8
CASE &H11 'shl word [mem16],imm16
CASE &H11 'shr byte [mem8],imm8
CASE &H11 'shr word [mem16],imm16
CASE &H11 'rcl byte [mem8],imm8
CASE &H11 'rcl word [mem16],imm16
CASE &H11 'rcr byte [mem8],imm8
CASE &H11 'rcr word [mem16],imm16
CASE &H11 'rol byte [mem8],imm8
CASE &H11 'rol word [mem16],imm16
CASE &H11 'ror byte [mem8],imm8
CASE &H11 'ror word [mem16],imm16
CASE &H11 'je|jz imm8
ipv = ipv + 2
IF rw%(flags) AND zero THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jne|jnz imm8
ipv = ipv + 2
IF NOT (rw%(flags) AND zero) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jb|jnae|jc imm8
ipv = ipv + 2
IF rw%(flags) AND carry THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jnb|jae|jnc imm8
ipv = ipv + 2
IF NOT (rw%(flags) AND zero) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'ja|jnbe imm8
ipv = ipv + 2
IF NOT (rw%(flags) AND (zero OR carry)) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jna|jbe imm8
ipv = ipv + 2
IF rw%(flags) AND (zero OR carry) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jl|jnge imm8
ipv = ipv + 2
IF (rw%(flags) AND sign) XOR (rw%(flags) AND overflow) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jnl|jge imm8
ipv = ipv + 2
IF NOT ((rw%(flags) AND sign) XOR (rw%(flags) AND overflow)) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jg|jnle imm8
ipv = ipv + 2
IF NOT ((rw%(flags) AND zero) OR (rw%(flags) AND sign) XOR (rw%(flags) AND overflow)) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jng|jle imm8
ipv = ipv + 2
IF (rw%(flags) AND zero) OR (rw%(flags) AND sign) XOR (rw%(flags) AND overflow) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jo imm8
ipv = ipv + 2
IF rw%(flags) AND overflow THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jno imm8
ipv = ipv + 2
IF NOT (rw%(flags) AND overflow) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'js imm8
ipv = ipv + 2
IF rw%(flags) AND sign THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jns imm8
ipv = ipv + 2
IF NOT (rw%(flags) AND sign) THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jcxz imm8
ipv = ipv + 2
IF rw%(cx) = 0 THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'jncxz imm8
ipv = ipv + 2
IF rw%(cx) <> 0 THEN ipv = ipv + signb(rb%(ipv - 1))
CASE &H11 'mov [[mem16]+imm8],byte imm8
CASE &H11 'mov [[mem16]+imm8],byte [mem8]
CASE &H11 'mov [[mem16]+imm8],word imm16
CASE &H11 'mov [[mem16]+imm8],word [mem16]
CASE &H11 'mov [mem8],byte [[mem16]+imm8]
CASE &H11 'mov [mem16],word [[mem16]+imm8]
CASE &H11 'mov [[mem16]+imm16],byte imm8
CASE &H11 'mov [[mem16]+imm16],byte [mem8]
CASE &H11 'mov [[mem16]+imm16],word imm16
CASE &H11 'mov [[mem16]+imm16],word [mem16]
CASE &H11 'mov [mem8],byte [[mem16]+imm16]
CASE &H11 'mov [mem16],word [[mem16]+imm16]
CASE &H11 'lodsb
'+ (1 OR ((rw%(flags) AND dir) <> 0))
CASE &H11 'lodsw
CASE &H11 'stosb
CASE &H11 'stosw
CASE &H11 'movsb
CASE &H11 'movsw
CASE &H11 'scasb
CASE &H11 'scasw
CASE &H11 'std
ipv = ipv + 1
ww flags, rw%(flags) OR dir
CASE &H11 'cld
ipv = ipv + 1
ww flags, rw%(flags) AND NOT dir
CASE &H11 'stc
ipv = ipv + 1
ww flags, rw%(flags) OR carry
CASE &H11 'clc
ipv = ipv + 1
ww flags, rw%(flags) AND NOT carry
CASE &H11 'cmc
ipv = ipv + 1
ww flags, rw%(flags) XOR carry
CASE &H11 'cbw [mem8],[mem8]
CASE &H11 'loop imm16
CASE ELSE 'reserved
STOP: EXIT DO
END SELECT
ww ip, ipv
LOOP
PRINT "dumping 0x"; HEX$(memsize); " bytes."
OPEN f$ + ".scm" FOR BINARY AS 2
PUT 2, , mem
SYSTEM
'not completely sure of carry and overflow logic
FUNCTION addword% (n0 AS INTEGER, n1 AS INTEGER, c, o)
n& = (CLNG(n0) + CLNG(n1))
n& = n& AND &HFFFF&
c = (n& < (CLNG(n0) AND &HFFFF&)) AND (n& < (CLNG(n1) AND &HFFFF&))
o = n& >= &H8000&
IF o THEN n& = n& - &H10000
addword% = n&
END FUNCTION
SUB byteresult (n AS INTEGER, co AS INTEGER)
z = n = 0
s = (n AND &H80) <> 0
f = rw%(flags)
'the way this is used, some instructions here affect overflow and carry that
'don't in x86
f = (f AND NOT (sign OR zero OR carry OR overflow)) OR (s AND sign) OR (z AND zero) OR co
ww flags, f
END SUB
FUNCTION rb% (p)
rb% = ASC(MID$(mem, p + 1, 1))
END FUNCTION
FUNCTION rd& (p)
rd& = CVD(MID$(mem, p + 1, 4))
END FUNCTION
FUNCTION rw% (p)
rw% = CVI(MID$(mem, p + 1, 2))
END FUNCTION
FUNCTION signb% (n)
IF n AND &H80 THEN signb% = &HFF00 OR n ELSE signb% = n
END FUNCTION
'not completely sure of carry and overflow logic
FUNCTION subword% (n0 AS INTEGER, n1 AS INTEGER, c, o)
c = (CLNG(n0) AND &HFFFF&) < (CLNG(n1) AND &HFFFF&)
n& = (CLNG(n0) - CLNG(n1))
n& = n& AND &HFFFF&
o = n& >= &H8000&
IF o THEN n& = n& - &H10000
subword% = n&
END FUNCTION
SUB wb (p, d)
MID$(mem, p + 1, 1) = CHR$(d)
END SUB
SUB wd (p, d&)
MID$(mem, p + 1, 4) = MKD$(d&)
END SUB
SUB wordresult (n AS INTEGER, co AS INTEGER)
z = n = 0
s = (n AND &H8000) <> 0
f = rw%(flags)
'the way this is used, some instructions here affect overflow and carry that
'don't in x86
f = (f AND NOT (sign OR zero OR carry OR overflow)) OR (s AND sign) OR (z AND zero) OR co
ww flags, f
END SUB
SUB ww (p, d)
MID$(mem, p + 1, 2) = MKI$(d)
END SUB
-------------------------------
DECLARE FUNCTION wcache% (addr AS LONG, size AS INTEGER)
DECLARE FUNCTION cacheaddr% (addr AS LONG, size AS INTEGER)
DECLARE SUB xmsinitcode ()
'memory:
'0 to 3ff interrupt vector table
'400 to 83ff display buffer
TYPE rgt
eip AS LONG
esp AS LONG
ebp AS LONG
flags AS LONG
eax AS LONG
ebx AS LONG
ecx AS LONG
edx AS LONG
esi AS LONG
edi AS LONG
END TYPE
DIM SHARED rg AS rgt
DIM SHARED cache(0 TO &H3FFF) AS INTEGER
TYPE cachelt
rank AS INTEGER
changed AS INTEGER
addr AS LONG
END TYPE
DIM SHARED cachelist(0 TO cacheblocks - 1) AS cachelt
DIM SHARED ivt(0 TO &HFF) AS LONG
DIM SHARED byte AS STRING * 1
TYPE xmst
ctrl AS LONG
errind AS INTEGER
size AS INTEGER
total AS INTEGER
handle AS INTEGER
length AS LONG
sourceh AS INTEGER
sourceo AS LONG
desth AS INTEGER
desto AS LONG
detect AS STRING * 44
query AS STRING * 32
alloc AS STRING * 29
errr AS STRING * 5
free AS STRING * 27
move AS STRING * 29
resize AS STRING * 30
END TYPE
DIM SHARED xms AS xmst
xmsinitcode
DEF SEG = VARSEG(xms)
CALL absolute(VARPTR(xms.detect))
IF xms.errind THEN PRINT "err: XMS 2.00 not detected.": SYSTEM
CALL absolute(VARPTR(xms.query))
IF xms.errind THEN PRINT "err: during query": SYSTEM
IF xms.size < (memsize / &H400) THEN PRINT "err: not enough": SYSTEM
xms.size = (memsize / &H400)
CALL absolute(VARPTR(xms.alloc))
IF xms.errind THEN PRINT "err: during alloc": SYSTEM
SCREEN 0
WIDTH 80, 25
COLOR 7, 0
CLS
'begin exection loop
DO
'handle keyboard input
k$ = INKEY$
IF LEN(k$) THEN
IF k$ = CHR$(&H1B) THEN EXIT DO
END IF
LOOP
DEF SEG = VARSEG(xms)
CALL absolute(VARPTR(xms.free))
IF xms.errind THEN PRINT "err: during free": STOP
SYSTEM
SUB wb (addr AS LONG, b AS INTEGER)
SELECT CASE addr
CASE 0 TO &H3FF: STOP
CASE &H400 TO &H83FF&
s = &HB800
o = addr - &H400
CASE ELSE
n = wcache(addr, 1)
s = VARSEG(cache(0))
o = (n * cacheblocksize) + (addr - cachelist(n).addr)
END SELECT
DEF SEG = s
POKE o, b
cachelist(n).changed = -1
END SUB
FUNCTION wcache (addr AS LONG, size AS INTEGER)
FOR i = 0 TO cacheblocks - 1
IF (addr >= cachelist(i).addr) AND ((addr + size) <= cachelist(i).addr + cacheblocksize) THEN EXIT FOR
NEXT i
IF i = cacheblocks THEN
FOR i = 0 TO cacheblocks - 1
IF cachelist(i).rank < 2 THEN n = i: best = cachelist(i).rank
IF best = 0 THEN EXIT FOR
NEXT i
IF (best = 0) AND (cachelist(i).changed <> 0) THEN
xms.length = cacheblocksize \ &H10
xms.sourceh = 0
xms.sourceo = CVL(MKI$(n * cacheblocksize) + MKI$(VARSEG(cache(0))))
xms.desth = xms.handle
xms.desto = cachelist(n).addr - main
DEF SEG = VARSEG(xms)
CALL absolute(VARPTR(xms.move))
IF xms.errind THEN
PRINT "err: during move"
CALL absolute(VARPTR(xms.free))
IF xms.errind THEN PRINT "err: during free"
STOP
END IF
END IF
xms.length = cacheblocksize \ &H10
xms.sourceh = xms.handle
xms.sourceo = cachelist(n).addr - main
xms.desth = 0
xms.desto = CVL(MKI$(n * cacheblocksize) + MKI$(VARSEG(cache(0))))
DEF SEG = VARSEG(xms)
CALL absolute(VARPTR(xms.move))
IF xms.errind THEN
PRINT "err: during move"
CALL absolute(VARPTR(xms.free))
IF xms.errind THEN PRINT "err: during free"
SYSTEM
END IF
FOR i = 0 TO cacheblocks - 1
IF cachelist(i).rank > 0 THEN cachelist(i).rank = cachelist(i).rank - 1
NEXT i
cachelist(n).addr = addr AND -4
cachelist(n).rank = cacheblocks
cachelist(n).changed = 0
i = n
END IF
wcache% = i
END FUNCTION
SUB wd (addr AS LONG, d AS LONG)
SELECT CASE addr
CASE 0 TO &H3FF
IF addr <> (addr AND -4) THEN STOP
ivt(addr \ 4) = d
CASE &H400 TO &H83FC&
s = &HB800
o = addr - &H400
CASE &H83FD TO &H83FF: STOP
CASE ELSE
n = wcache(addr, 4)
s = VARSEG(cache(0))
o = (n * cacheblocksize) + (addr - cachelist(n).addr)
END SELECT
DEF SEG = s
POKE o, d AND &HFF
POKE o + 1&, (d AND &HFF00&) \ &H100&
POKE o + 2&, (d AND &HFF0000) \ &H10000
POKE o + 3&, ((d AND &HFF000000) \ &H1000000) AND &HFF
cachelist(n).changed = -1
END SUB
SUB ww (addr AS LONG, w AS INTEGER)
SELECT CASE addr
CASE 0 TO &H3FF: STOP
CASE &H400 TO &H83FE&
s = &HB800
o = addr - &H400
CASE &H83FF: STOP
CASE ELSE
n = wcache(addr, 2)
s = VARSEG(cache(0))
o = (n * cacheblocksize) + (addr - cachelist(n).addr)
END SELECT
DEF SEG = s
POKE o, w AND &HFF
POKE o + 1&, (w AND &HFF00&) \ &H100&
cachelist(n).changed = -1
END SUB
SUB xmsinitcode
DIM t AS STRING, i, l AS LONG
t$ = "57e800005f83ef20c745040000b80043cd2f3c807553b01006cd2f891d8c4502"
t$ = t$ + "0730e4ff1d80fc02723f5fcb57e800005f83ef4cc745040000b40830dbff1df6"
t$ = t$ + "c38075258945068955085fcb57e800005f83ef6cc7450400008b5506b409ff1d"
t$ = t$ + "a801740589550a5fcbff4d045fcb57e800005f81ef8e00c7450400008b550ab4"
t$ = t$ + "0aff1da80174e25fcb5756e800005f81efaa00c7450400008d750cb40bff1d5e"
t$ = t$ + "a80174c55fcb57e800005f81efc600c7450400008b5d068b550ab40fff1da801"
t$ = t$ + "74a75fcb"
DEF SEG = VARSEG(xms)
FOR i = 0 TO &HC3
l = VARPTR(xms.detect)
POKE l + i, VAL("&h" + MID$(t, i + i + 1, 2))
NEXT i
END SUB
DECLARE SUB mail ()
DECLARE SUB sad ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE SUB c (cm%)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED Monitor$
DIM SHARED SadMode%
DIM SHARED smono%
DIM SHARED SpH%
DIM SHARED SpO%
DIM SHARED SM%
DIM SHARED GoodEga%
DIM SHARED log$
DIM SHARED port$
DIM SHARED turn%
ON ERROR GOTO term
sad
c 1
PRINT "Welcome to Mike's seriel text transfer program."
port$ = choice$("COM port(1/2)", "1", "2", "1", "1", "1", "1", "1", "1", "1", "1")
LINE INPUT "Log file? ('ENTER' for none) "; log$
PRINT "Press any key when ready."
SLEEP
WHILE INKEY$ <> "": WEND
attemps% = 0
1 PRINT "Open line on COM"; port$; ".";
attemps% = attemps% + 1
ON ERROR GOTO fail
OPEN "com" + port$ + ":300,N,8,1,lf,TB2048,RB2048" FOR RANDOM AS #1 LEN = 32767
ON ERROR GOTO term
PRINT " <done>"
PRINT "'ESC' to exit. Type whatever you want. Press 'ENTER' to send instantly."
PRINT "Type text '!!!-mail.' to transfer e-mail with other computer."
PRINT
IF log$ <> "" THEN
IF Exist%(log$) = 0 THEN OPEN log$ FOR OUTPUT AS #2: CLOSE #2
OPEN log$ FOR APPEND AS #2
PRINT #2, ""
PRINT #2, "Mike's Seriel text transfer program's log file."
PRINT #2, DATE$; " "; TIME$; " COM"; port$; " Attemps to open line:"; attemps%
PRINT #2, ""
END IF
DO
WHILE key$ = ""
key$ = INKEY$
LINE INPUT #1, in$
IF in$ <> "" THEN
in$ = "COM" + port$ + ": " + in$
PRINT in$
IF log$ <> "" THEN PRINT #2, "COM"; port$; ": "; in$
IF UCASE$(RIGHT$(in$, LEN(in$) - 6)) = "!!!-OTHER USER IS DONE." THEN GOTO 2
IF UCASE$(RIGHT$(in$, LEN(in$) - 6)) = "!!!-MAIL." THEN turn% = 0: mail
END IF
WEND
IF key$ = CHR$(27) THEN
out$ = "User is done."
PRINT #1, "!!!-Other "; out$
IF log$ <> "" THEN PRINT #2, "USER: "; out$
PRINT "USER: "; out$
GOTO 2
END IF
PRINT "USER: "; key$;
LINE INPUT out$
out$ = key$ + out$
PRINT #1, out$
IF log$ <> "" THEN PRINT #2, "USER: "; out$
IF UCASE$(RIGHT$(out$, LEN(out$) - 6)) = "!!!-OTHER USER IS DONE." THEN GOTO 2
IF UCASE$(RIGHT$(out$, LEN(out$) - 6)) = "!!!-MAIL." THEN turn% = 1: mail
LOOP
2 CLOSE
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
errsad:
SELECT CASE SadMode%
CASE 12: SadMode% = 13: RESUME
CASE 13: SadMode% = 9: RESUME
CASE 9: SadMode% = 1: RESUME
CASE 1: SadMode% = 0: RESUME NEXT
END SELECT
errsad2:
IF SM% = 3 THEN SpH% = 0
RESUME NEXT
errsad3:
IF SM% = 4 THEN SpO% = 0
RESUME NEXT
errsad4:
GoodEga% = 0
RESUME NEXT
fail:
PRINT " <failed>"
retry$ = UCASE$(choice$("Retry", "Y", "y", "N", "n", "Y", "Y", "Y", "Y", "Y", "Y"))
IF retry$ = "Y" THEN RESUME 1
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
SUB c (cm%)
IF smono% = 1 AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 4 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = cm%
END SUB
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
c 3
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
IF cp% > 0 THEN c cp%
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB mail
IF turn% = 0 THEN
perm$ = UCASE$(choice$("Other user wants to transfer mail. Do you give permission(Y/N)", "Y", "y", "N", "n", "Y", "Y", "Y", "Y", "Y", "Y"))
IF log$ <> "" THEN PRINT #2, "Permission: "; perm$
PRINT #1, "!!!-PERM"; perm$
IF perm$ = "N" THEN EXIT SUB
END IF
IF turn% = 1 THEN
PRINT "Waiting for permission to transfer mail. ";
DO
LINE INPUT #1, wait$
IF wait$ <> "" THEN EXIT DO
LOOP
PRINT "Permission ";
IF wait$ = "N" THEN PRINT "NOT granted.": EXIT SUB
PRINT "granted."
END IF
PRINT "Transfering mail.";
over% = 0
3
SELECT CASE turn%
CASE "0": OPEN "c:\seriel\" FOR INPUT AS #3 'left off here.
CASE "1":
END SELECT
END SUB
SUB sad
SadMode% = 12
ON ERROR GOTO errsad
SCREEN SadMode%
ON ERROR GOTO term
smono% = 0
SELECT CASE SadMode%
CASE 12: Monitor$ = "VGA"
CASE 13: Monitor$ = "MCGA"
CASE 9: Monitor$ = "EGA"
CASE 1: Monitor$ = "CGA"
CASE 0: Monitor$ = "Monochrome": smono% = 1
END SELECT
SpH% = 1
SpO% = 1
SM% = 4
ON ERROR GOTO errsad2
SCREEN SM%
ON ERROR GOTO term
SM% = 3
ON ERROR GOTO errsad3
SCREEN SM%
ON ERROR GOTO term
IF SpH% = 1 THEN Monitor$ = Monitor$ + " (Hercules)"
IF SpO% = 1 THEN Monitor$ = Monitor$ + " (Olivetti / AT&T)"
IF SadMode% = 9 THEN
GoodEga% = 1
ON ERROR GOTO errsad4
PALETTE 4, 0
ON ERROR GOTO term
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "> 64K " + Monitor$
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "<= 64K " + Monitor$
END IF
IF SadMode% <> 0 OR SM% <> 0 THEN SCREEN 0: WIDTH 80, 25
c 0
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
' look over and test
DECLARE FUNCTION wt& (tim$)
DECLARE SUB upd ()
DECLARE SUB defrag (a%)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE FUNCTION Exist% (efile$)
DIM SHARED nexis%
GOSUB help
3
IF Exist%("c:\taskscdl.dat") = 0 THEN
OPEN "c:\taskscdl.dat" FOR OUTPUT AS 1
CLOSE
END IF
TYPE tasktype
nam AS STRING * 16
action AS STRING * 128
tim AS STRING * 8
t AS LONG
d AS INTEGER
END TYPE
DIM SHARED tasks(1 TO 32) AS tasktype
DIM SHARED cur%
OPEN "c:\taskscdl.dat" FOR INPUT AS 1
FOR i% = 1 TO 33
IF EOF(1) THEN cur% = i%: EXIT FOR
LINE INPUT #1, tasks(i%).nam
LINE INPUT #1, tasks(i%).action
LINE INPUT #1, tasks(i%).tim
LINE INPUT #1, a$
tasks(i%).t = VAL(a$)
NEXT i%
CLOSE
2 PRINT "Task Scheduler is running."
PRINT "This program is meant to run in Windows while minimized in the background."
PRINT "To close this program, press escape. To get to the menu, press any other key."
DO
t$ = TIME$
LOCATE 5, 1: PRINT "Current time: "; t$
key$ = INKEY$
IF key$ <> "" THEN
IF key$ = CHR$(27) THEN CLS : SYSTEM
PRINT "--- Task Scheduler Menu ---"
PRINT "1 - Add a task"
PRINT "2 - Remove a task"
PRINT "3 - View tasks"
PRINT "4 - Help"
PRINT "5 - Back"
SELECT CASE choice$("What is your choice", "1", "2", "3", "4", "", "", "", "", "", "")
CASE "1"
IF cur% = 33 THEN PRINT "Sorry, all tasks used. Who needs to have more than 32 tasks anyway? If you want": PRINT "more, modify the program, you lazy bum.": SLEEP: WHILE INKEY$ <> "": WEND: GOTO 1
LINE INPUT "Name? "; tasks(cur%).nam
LINE INPUT "(hh:mm:ss) Time? "; tasks(cur%).tim
LINE INPUT "Action? "; tasks(cur%).action
tasks(cur%).t = wt&(tasks(cur%).tim)
cur% = cur% + 1
upd
GOTO 1
CASE "2"
LINE INPUT "Number? "; a$
a% = VAL(a$)
PRINT #1, "# Name Time Action"
PRINT LTRIM$(STR$(a%)); SPACE$(6 - POS(0)); tasks(a%).nam; " "; tasks(a%).tim; " "; RTRIM$(tasks(a%).action)
IF choice$("Remove this task", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN
tasks(a%).nam = ""
tasks(a%).tim = ""
tasks(a%).action = ""
tasks(a%).t = 0
defrag a%
upd
END IF
GOTO 1
CASE "3"
OPEN "c:\taskscdl.tmp" FOR OUTPUT AS 1
PRINT #1, "# Name Time Action"
FOR i% = 1 TO cur% - 1
PRINT LTRIM$(STR$(i%)); SPACE$(6 - POS(0)); tasks(i%).nam; " "; tasks(i%).tim; " "; RTRIM$(tasks(i%).action)
NEXT i%
CLOSE
SHELL "type c:\taskscdl.tmp | more"
KILL "c:\taskscdl.tmp"
SLEEP
WHILE INKEY$ <> "": WEND
GOTO 1
CASE "4"
IF Exist%("c:\taskscdl.txt") = 0 THEN
RESTORE
OPEN "c:\taskscdl.txt" FOR OUTPUT AS 1
FOR i% = 1 TO help%
READ a$
PRINT #1, a$
NEXT i%
CLOSE
END IF
SHELL "notepad c:\taskscdl.txt"
GOTO 1
CASE "5"
1 CLS
GOTO 2
END SELECT
END IF
a& = wt&(t$)
FOR i% = 1 TO cur% - 1
IF ABS(a& - tasks(i%).t) <= 5 THEN
IF tasks(i%).d = 0 THEN SHELL RTRIM$(tasks(i%).action): tasks(i%).d = 1
ELSE
IF tasks(i%).d = 1 THEN tasks(i%).d = 0
END IF
NEXT i%
LOOP
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
help:
'const help%=
RETURN
DATA "Mike's Task Scheduler ver 1 is a freeware BASIC program by Michael Calkins."
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB defrag (a%)
FOR i% = a% TO cur% - 1
IF i% < 32 THEN
tasks(i%).nam = tasks(i% + 1).nam
tasks(i%).tim = tasks(i% + 1).tim
tasks(i%).action = tasks(i% + 1).action
tasks(i%).t = tasks(i% + 1).t
ELSE
tasks(i%).nam = ""
tasks(i%).tim = ""
tasks(i%).action = ""
tasks(i%).t = 0
END IF
NEXT i%
END SUB
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB upd
OPEN "c:\taskscdl.dat" FOR OUTPUT AS #1
FOR i% = 1 TO 32
PRINT #1, tasks(i%).nam
PRINT #1, tasks(i%).action
PRINT #1, tasks(i%).tim
PRINT #1, tasks(i%).t
NEXT i%
CLOSE
END SUB
FUNCTION wt& (tim$)
hrs% = VAL(LEFT$(tim$, 2))
min% = hrs% * 60 + VAL(MID$(tim$, 4, 2))
wt& = min% * 60 + VAL(RIGHT$(tim$, 2))
END FUNCTION
' Please contact me to for info or to inform me of problems.
' Program is by Michael Calkins. Ph# (830) 393-4866
' For help, see the file "c:\terr\programs\readme.txt"
DECLARE SUB masscop (drv$)
DECLARE SUB massdel (drv$)
DECLARE SUB upd (dat$, num$)
DECLARE FUNCTION wtme& (dat$)
DECLARE SUB sad ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE SUB c (cm%)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED Monitor$
DIM SHARED SadMode%
DIM SHARED smono%
DIM SHARED SpH%
DIM SHARED SpO%
DIM SHARED SM%
DIM SHARED GoodEga%
DIM SHARED spcl%
ON ERROR GOTO term
sad
TYPE upddat
num AS STRING * 3
dat AS STRING * 10
ntme AS LONG
END TYPE
1 c 0: c 1: PRINT "Welcome to the territoy handling program."
c 2
PRINT "---Main Menu---"
PRINT "1 - Check in/out territory"
PRINT "2 - List the ten most urgent territories"
PRINT "3 - Create new territory"
PRINT "4 - Erase territory"
PRINT "5 - List territories that have been checked out for a long time"
PRINT "6 - Restore from backup"
PRINT "7 - Exit"
a$ = choice$("What is the number of your choice", "1", "2", "3", "4", "5", "6", "7", "1", "1", "1")
c 1
PRINT
SELECT CASE a$
CASE "1": c 3: LINE INPUT "Number of check in/out? "; b$
c 1
b$ = LTRIM$(RTRIM$(b$))
IF b$ = "" THEN GOTO 1
b$ = STRING$(3 - LEN(b$), "0") + b$
IF Exist%("C:\TERR\TERR." + b$) = 0 THEN PRINT "File not found: 'C:\TERR."; b$; "'": SLEEP: WHILE INKEY$ <> "": WEND: GOTO 1
OPEN "c:\terr\terr." + b$ FOR INPUT AS 1
i% = 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, state$
LINE INPUT #1, who$
LINE INPUT #1, cc$
LINE INPUT #1, d$
IF i% = 1 THEN td$ = d$
IF i% = 1 THEN tc$ = cc$
i% = i% + 1
LOOP
CLOSE
c 1
PRINT "Terr #"; b$; " note: "; td$; " created on: "; tc$
PRINT "Territory is "; state$
SELECT CASE state$
CASE "IN": inv$ = "out": PRINT "Last checked out to "; who$
CASE "OUT": inv$ = "in": PRINT "Is checked out to "; who$
END SELECT
PRINT "Date: "; cc$
PRINT "Note: "; d$
PRINT
e$ = UCASE$(choice$("Check territory " + inv$, "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF e$ = "Y" THEN
c 3
IF inv$ = "out" THEN LINE INPUT "Name of person? "; who$
LINE INPUT "('ENTER' for current date) Date check in/out? "; cc$
IF cc$ = "" THEN cc$ = DATE$
LINE INPUT "('ENTER' for none) Notes? "; d$
c 1
OPEN "c:\terr\terr." + b$ FOR APPEND AS 1
PRINT #1, UCASE$(inv$)
PRINT #1, who$
PRINT #1, cc$
PRINT #1, d$
CLOSE
END IF
CASE "2": c 3: LINE INPUT "('ENTER' for '001') Search all territories form: "; n1$
LINE INPUT "('ENTER' for '999') Search all territories to: "; n2$
c 1
IF n1$ = "" THEN n1$ = "1"
IF n2$ = "" THEN n2$ = "999"
n1% = VAL(n1$)
n2% = VAL(n2$)
DIM SHARED top(1 TO 10) AS upddat
FOR x% = n1% TO n2%
b$ = STRING$(3 - LEN(LTRIM$(STR$(x%))), "0") + LTRIM$(STR$(x%))
IF Exist%("C:\TERR\TERR." + b$) = 1 THEN
OPEN "c:\terr\terr." + b$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, state$
LINE INPUT #1, who$
LINE INPUT #1, cc$
LINE INPUT #1, d$
LOOP
CLOSE
IF state$ = "IN" THEN upd cc$, b$
END IF
NEXT x%
PRINT "As of "; DATE$; " the 10 most urgent territories between"; n1%; "and"; n2%; "are:"
FOR x% = 1 TO 10
PRINT "Terr#"; top(x%).num; " was last checked in "; top(x%).dat; " which was about"; top(x%).ntme; "days ago."
NEXT x%
PRINT "Press 'SPACE' to print, any other key to contiue."
DO
key$ = INKEY$
IF key$ <> "" THEN EXIT DO
LOOP
IF key$ = " " THEN
LPRINT "As of "; DATE$; " the 10 most urgent territories between"; n1%; "and"; n2%; "are:"
FOR x% = 1 TO 10
LPRINT "Terr#"; top(x%).num; " was last checked in "; top(x%).dat; " which was about"; top(x%).ntme; "days ago."
NEXT x%
END IF
ERASE top
WHILE INKEY$ <> "": WEND
CASE "3": c 3: LINE INPUT "Number of territory to create? "; b$
IF b$ = "" THEN GOTO 1
b$ = STRING$(3 - LEN(b$), "0") + b$
IF Exist%("C:\TERR\TERR." + b$) = 1 THEN c 1: PRINT "File already exists: 'C:\TERR."; b$; "'": SLEEP: WHILE INKEY$ <> "": WEND: GOTO 1
LINE INPUT "('ENTER' for current date) Date of creation? "; cc$
IF cc$ = "" THEN cc$ = DATE$
LINE INPUT "('ENTER' for none) Notes? "; d$
c 1
OPEN "c:\terr\terr." + b$ FOR OUTPUT AS 1
PRINT #1, "IN"
PRINT #1, "New territory."
PRINT #1, cc$
PRINT #1, d$
CLOSE
CASE "4": c 3: LINE INPUT "Number of territory to erase? ", b$
c 1:
IF b$ = "" THEN GOTO 1
b$ = STRING$(3 - LEN(b$), "0") + b$
IF Exist%("C:\TERR\TERR." + b$) = 0 THEN PRINT "File not found: 'C:\TERR\TERR."; b$; "'": SLEEP: WHILE INKEY$ <> "": WEND: GOTO 1
OPEN "c:\terr\terr." + b$ FOR INPUT AS 1
i% = 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, state$
LINE INPUT #1, who$
LINE INPUT #1, cc$
LINE INPUT #1, d$
IF i% = 1 THEN td$ = d$
IF i% = 1 THEN tc$ = cc$
i% = i% + 1
LOOP
CLOSE
PRINT "Terr #"; b$; " note: "; td$; " created on: "; tc$
PRINT "Territory is "; state$
SELECT CASE state$
CASE "IN": inv$ = "out": PRINT "Last checked out to "; who$
CASE "OUT": inv$ = "in": PRINT "Is checked out to "; who$
END SELECT
PRINT "Date: "; cc$
PRINT "Note: "; d$
PRINT
spcl% = 1
cc$ = UCASE$(choice$("Are you sure", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
spcl% = 0
c 1
IF cc$ = "Y" THEN KILL "c:\terr\terr." + b$
CASE "5": c 3: LINE INPUT "('ENTER' for '001') Search all territories form: "; n1$
LINE INPUT "('ENTER' for '999') Search all territories to: "; n2$
LINE INPUT "('ENTER' for 90) number of days? "; n3$
c 1
IF n1$ = "" THEN n1$ = "1"
IF n2$ = "" THEN n2$ = "999"
IF n3$ = "" THEN n3$ = "90"
z$ = UCASE$(choice$("Print", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
n1% = VAL(n1$)
n2% = VAL(n2$)
n3& = VAL(n3$)
z% = 0
IF z$ = "Y" THEN LPRINT "As of "; DATE$; ", the territories between"; n1%; "and"; n2%; "that have"
IF z$ = "Y" THEN LPRINT " been out for more than"; n3&; "days are:"
FOR x% = n1% TO n2%
b$ = STRING$(3 - LEN(LTRIM$(STR$(x%))), "0") + LTRIM$(STR$(x%))
IF Exist%("C:\TERR\TERR." + b$) = 1 THEN
OPEN "c:\terr\terr." + b$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, state$
LINE INPUT #1, who$
LINE INPUT #1, cc$
LINE INPUT #1, d$
LOOP
CLOSE
IF state$ = "OUT" THEN
IF wtme&(cc$) >= n3& THEN
PRINT "Terr#"; b$; " has been checked out to "; who$; " for about"; wtme&(cc$); "days."
IF z$ = "Y" THEN LPRINT "Terr#"; b$; " has been checked out to "; who$; " for about"; wtme&(cc$); "days."
z% = z% + 1
IF z% = 64 AND z$ = "Y" THEN
LPRINT ""
LPRINT ""
LPRINT "continued"
LPRINT ""
z% = 2
END IF
END IF
END IF
END IF
NEXT x%
PRINT "Press any key to continue."
SLEEP
WHILE INKEY$ <> "": WEND
CASE "6": c 0: b$ = UCASE$(choice$("Drive letter", "A", "a", "B", "b", "C", "c", "D", "d", "E", CHR$(27)))
IF Exist%(b$ + ":\terr-bak\backup.dat") = 0 THEN PRINT "File not found: '"; b$; ":\TERR-BAK\BACKUP.DAT'": SLEEP: WHILE INKEY$ <> "": WEND: GOTO 1
OPEN b$ + ":\terr-bak\backup.dat" FOR INPUT AS 1
LINE INPUT #1, cc$
PRINT cc$
LINE INPUT #1, d$
DO
d$ = RIGHT$(d$, 3)
d$ = STRING$(3 - LEN(d$), "0") + d$
c 0: c 1
PRINT cc$
f$ = UCASE$(choice$("('ESC' to cancel) Restore Terr#" + d$, "Y", "y", "N", "n", CHR$(27), "y", "y", "y", "y", "y"))
IF f$ = CHR$(27) THEN CLOSE : GOTO 1
IF f$ = "Y" THEN OPEN "c:\terr\terr." + d$ FOR OUTPUT AS 2
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, e$
IF LEFT$(e$, 15) = "---!!!---:Terr#" THEN EXIT DO
IF f$ = "Y" THEN PRINT #2, e$
LOOP
IF f$ = "Y" THEN CLOSE 2
d$ = e$
IF EOF(1) THEN EXIT DO
LOOP
c 0: c 1
PRINT cc$
PRINT "End of backup."
CLOSE
SLEEP
WHILE INKEY$ <> "": WEND
CASE "7": c 0: c 1
2 b$ = UCASE$(choice$("Backup territories", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF b$ = "Y" THEN
cc$ = UCASE$(choice$("Drive letter", "A", "a", "B", "b", "C", "c", "D", "d", "E", CHR$(27)))
IF cc$ = CHR$(27) THEN GOTO 2
IF Exist%(cc$ + ":\terr-bak\backup.dat") = 1 THEN
d$ = UCASE$(choice$("Backup already exist. Replace", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y"))
IF d$ = "N" THEN GOTO 2
END IF
IF Exist%(cc$ + ":\terr-bak\nul") = 0 THEN MKDIR cc$ + ":\terr-bak"
massdel cc$
masscop cc$
END IF
c 0
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
END SELECT
GOTO 1
term:
c 0: c 1
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
errsad:
SELECT CASE SadMode%
CASE 12: SadMode% = 13: RESUME
CASE 13: SadMode% = 9: RESUME
CASE 9: SadMode% = 1: RESUME
CASE 1: SadMode% = 0: RESUME NEXT
END SELECT
errsad2:
IF SM% = 3 THEN SpH% = 0
RESUME NEXT
errsad3:
IF SM% = 4 THEN SpO% = 0
RESUME NEXT
errsad4:
GoodEga% = 0
RESUME NEXT
SUB c (cm%)
IF smono% = 1 AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 4 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = cm%
END SUB
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
c 3
IF spcl% = 1 THEN COLOR 31, 1
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
IF cp% > 0 THEN c cp%
IF cp% = 0 THEN c 1
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
SUB masscop (drv$)
OPEN drv$ + ":\terr-bak\backup.dat" FOR OUTPUT AS 1
PRINT #1, "Backup of territories as of "; DATE$; ", "; TIME$; "."
FOR i% = 1 TO 999
b$ = STRING$(3 - LEN(LTRIM$(STR$(i%))), "0") + LTRIM$(STR$(i%))
IF Exist%("C:\terr\terr." + b$) = 1 THEN
OPEN "c:\terr\terr." + b$ FOR INPUT AS 2
PRINT #1, "---!!!---:Terr#"; b$
DO
IF EOF(2) THEN EXIT DO
LINE INPUT #2, copd$
PRINT #1, copd$
LOOP
CLOSE #2
END IF
NEXT i%
CLOSE
END SUB
SUB massdel (drv$)
IF Exist%(drv$ + ":\terr-bak\backup.dat" + b$) THEN KILL drv$ + ":\terr-bak\backup.dat"
END SUB
SUB sad
SadMode% = 12
ON ERROR GOTO errsad
SCREEN SadMode%
ON ERROR GOTO term
smono% = 0
SELECT CASE SadMode%
CASE 12: Monitor$ = "VGA"
CASE 13: Monitor$ = "MCGA"
CASE 9: Monitor$ = "EGA"
CASE 1: Monitor$ = "CGA"
CASE 0: Monitor$ = "Monochrome": smono% = 1
END SELECT
SpH% = 1
SpO% = 1
SM% = 4
ON ERROR GOTO errsad2
SCREEN SM%
ON ERROR GOTO term
SM% = 3
ON ERROR GOTO errsad3
SCREEN SM%
ON ERROR GOTO term
IF SpH% = 1 THEN Monitor$ = Monitor$ + " (Hercules)"
IF SpO% = 1 THEN Monitor$ = Monitor$ + " (Olivetti / AT&T)"
IF SadMode% = 9 THEN
GoodEga% = 1
ON ERROR GOTO errsad4
PALETTE 4, 0
ON ERROR GOTO term
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "> 64K " + Monitor$
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "<= 64K " + Monitor$
END IF
IF SadMode% <> 0 OR SM% <> 0 THEN SCREEN 0: WIDTH 80, 25
c 0
END SUB
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
SUB upd (dat$, num$)
tme& = wtme&(dat$)
FOR i% = 1 TO 10
IF tme& > top(i%).ntme THEN
FOR z% = 10 TO i% STEP -1
IF z% > 1 THEN top(z%).num = top(z% - 1).num
IF z% > 1 THEN top(z%).dat = top(z% - 1).dat
IF z% > 1 THEN top(z%).ntme = top(z% - 1).ntme
IF z% = i% THEN top(z%).num = num$
IF z% = i% THEN top(z%).dat = dat$
IF z% = i% THEN top(z%).ntme = tme&
NEXT z%
EXIT SUB
END IF
NEXT i%
END SUB
FUNCTION wtme& (dat$)
sf& = VAL(RIGHT$(dat$, 4)) * 365
IF sf& < 0 THEN sf& = 0
sf& = sf& + VAL(LEFT$(dat$, 2)) * 30
IF sf& < 0 THEN sf& = 0
sf& = sf& + VAL(MID$(dat$, 4, 2))
IF sf& < 0 THEN sf& = 0
sf2& = VAL(RIGHT$(DATE$, 4)) * 365
IF sf2& < 0 THEN sf2& = 0
sf2& = sf2& + VAL(LEFT$(DATE$, 2)) * 30
IF sf2& < 0 THEN sf2& = 0
sf2& = sf2& + VAL(MID$(DATE$, 4, 2))
IF sf2& < 0 THEN sf2& = 0
wtme& = ABS(sf2& - sf&)
END FUNCTION
Instructions for 'time2.bas', the elapsed time adder version 2 from PeanutWare.
Contents
1. Introduction to time2.
A. Welcome.
B. Improvements over time1b.
2. How to use time2.
A. The menu system
B. The function keys.
C. Entering time for a day.
D. Entering time for a week.
E. Getting a result.
3. The video alerts.
4. About time2.
1. Introduction to time2.------------------------------------------------------
-1A- Welcome.
The purpose of this program is to calculate the time an employee worked in
a single day and a single week. It is meant to be used with a normal employee
time sheet that gives start and end times for 2 regular shifts and perhaps 1
overtime shift. It gives the results in hours as decimal numbers. This should
mean a significant increase in the secretary's efficiency on payday.
System requirements:
MS-DOS QBASIC
keyboard with extended function keys (F11 & F12)
some free disk space for ini file
Recommendations:
color display
internal speaker
-1B- Improvements over time1b.
Time1b, my previous version, allowed daily entry only. It would give the
totals for a day; the user would have to add up the daily totals manually. Time2
has a new feature: a weekly total. After entry for each day is complete,
pressing F1 to F7 stores the daily totals in slots on the right side of the
screen. These are added up for a weekly total.
Also, time1b was designed for a time sheet with 1 overtime shift. I have
since discovered that some companies overtime is simply any regular time over
40 hours a week. Therefore, time2 has 2 modes. In mode 0, it functions like
time1b. In mode 1, it allows only regular time entry, and the weekly total shows
regular time capped at a certain number and overtime being anything in excess of
that.
For faster time entry, a dash ('-') can be substituted for a colon as the
time separator.
2. How to use time2.-----------------------------------------------------------
-2A- The menu system.
The program features an easy-to-use menu. The up and down arrow keys are
used to move the menu cursor. Also, 'ESC' is used to jump to the 'Exit'
position, and 'Backspace' is used to jump to the 'Clear' position. Press 'Enter'
on any position to select it.
The first several positions are for time entry (see 2C). 'Clear' is used to
reset all daily entry time slots to 0. 'Exit' is used to terminate the program.
-2B- The Function keys.
The function keys have purposes that are described below.
'F1' to 'F7' are used for entering time for a week (see 2D).
'F8' is used to set the overtime cap (see 2D). A prompt appears for you to
type the new cap. Enter the cap the same way you would enter any other time (see
2C). This number is only relevant in mode 1. The default cap is 40 hours. The
overtime cap is saved in 'time2.ini'.
'F9' is used to toggle on and off audio alerting. I recommend that you
it on.
'F10' toggles the mode. Mode 0 allows daily overtime entry, the weekly
overtime being a simple sum of the daily overtimes. Mode 1 doesn't allow
overtime entry, the weekly overtime being any total time in excess of the
overtime cap. The mode that you are in when exiting time2 is recorded in
'time2.ini'. The next time time2 is run, it will start in that mode.
'F12' clears the slots used for the weekly total.
-2C- Entering time for a day.
If you select any time slot from the menu, a green prompt will appear for
you to enter the time with. Copy the time from the time sheet using hours and
minutes. The program expects hour entry as a 24 hour figure (12 AM is 0, 12 PM
is 12, 1 PM is 13, etc.). Does it really matter? Yes. What happens when the 1st
shift starts at 8 AM (8) and ends at 1 PM (13)? Use a colon or a dash, ':' or
'-', to separate the hours from the minutes. If no neither is used, the entire
number will be assumed to be hours. If a colon is present, the first colon from
the left is considered the time separator. If there is no colon but there is a
dash, then the first dash from the left is the time separator. The number left
of the time separator will be hours, the number right of it will be minutes.
Although the time may be entered in many convenient ways, to prevent a
'misunderstanding' with the program, I recommend 'h:mm', 'hh:mm', 'h-mm', or
'hh-mm'. Time2 formats all time entries into 'hh:mm' as well as it can. To
indicate to the user the extent of change, three different sounds can be
generated. These alert the user to possible typing errors.
Here is a comparison of the user's entry and the formatted time:
entered format entered time result audio alert
------------------------------------------------------
hh:mm "13:30" --> "13:30" good sound
hh-mm "13-30" --> "13:30" ...
h:mm "8:45" --> "08:45" ...
... with space " 8 : 45 " --> "08:45" ...
... " 8 - 45 " --> "08:45" ...
bad time "24:60" --> "00:00" bad sound
... "-1:-100" --> "00:00" ...
with letters "05:3p" --> "05:03" ...
... "abc9:30" --> "00:30" ...
... "abc" --> "00:00" ...
The sounds:
good sound: 1/16 note E, 1/8 note F# .375 seconds
fair sound: 1/16 notes AE, 1/8 note F# .5 seconds
bad sound: 1/4 note E, 1/64 notes EDEDEDEDEDEDEDED 1 second
Note: Some of these sounds may also used elsewhere to indicate good or bad.
When you press enter at the prompt, the numbers on the screen are updated
to show the change. Please make a habit of double checking the numbers that you
typed to see if the program formatted them correctly. Also, the decimal hour
equivalent is displayed to the right of each entry slot.
-2D- Entering time for a week.
This new feature of Time2 should greatly increase the user's efficiency.
When you have entered the time for a day, you can copy that day's total to a
day slot in the upper right part of the screen. Do this by pressing the
appropriate function key from 'F1' to 'F7'. Each of these is associated with a
day slot. As an aid to the user's speed, the function key symbols to the left of
each day slot change color based on whether the slot is blank or not. This is
handy in rapidly choosing which button to press. Otherwise, it would be easy to
accidentally erase a total already copied by pressing the wrong key. Make a
habit of double checking which slot the daily total was copied into.
Copying to the day slots is not allowed if there is an obvious discrepancy.
-2E- Getting a result.
After each new daily shift time entry, the daily time total(s) on the right
side of the screen are immediately updated. The bright red regular total is the
elapsed time of the 2 regular shifts combined. In mode 0, the bright cyan total
is the elapsed time for the overtime shift. These total(s) are expressed in
decimal hours. If any of the contributing shifts have negative results, the
total in which that shift is included will read 'INVAL'.
When you have completed entering time for a day, any video alerts still
displayed would, in most cases, indicate a discrepancy in the time slots. Verify
the source of any alert. After accurately entering all the shifts used on a
particular day, you may copy the total to the time sheet and/or day slot (see
2D).
3. The video alerts.------------------------------------------------------------
Video alerts indicate obvious discrepancies in the entered times. The
alerts are shift specific, informing you which shifts are at fault or are in
conflict.
The 3 types of video alerts:
Neg Rslt:
This, along with the elapsed time total, will indicate that the elapsed
time of a shift has a negative result. This may appear frequently as you go down
the line entering times. Assuming that you start with "a clean slate," It
would normally appear when you type in the start time, and disappear when you
type in the end time. To avoid these false alarms, you might try entering the
times from bottom to top. However, if this alert persists after the specific
shift has been completed, you probably have a problem.
Both Wr Order and Overlap overlook empty shifts to reduce false alarms.
Wr Order:
This occurs whenever a start time for a shift is later in the day than the
start time of a later shift, indicating that the two shifts are in reverse
order. This would ordinarily not occur on a normal time sheet, but would not
necessarily lead to an inaccurate total result. This may result from
inadvertently entering a time in a 12 hour format. Always enter time in a 24
hour format. Doing so should be a habit.
Overlap:
This indicates that the time intervals of 2 shifts overlap. The alert
occurs when a shift has a start time earlier than the end time of a subsequent
shift AND the shift has an end time later than the start time of the same
subsequent shift. This would be highly unusual on a time sheet and would almost
certainly mean a problem.
If alerts persists after time entry has been completed for a certain day,
double check the entries. You may have made a typing error, or the time sheet
itself may have discrepancies.
4. About time2.----------------------------------------------------------------
As with most programs, time2 was both fun and sometimes frustrating to
write and debug. I am glad that I did this, though, and hope that time2 may be
of practical use. 'time2.bas' and 'time2.txt' are freeware; use and distribute
them as much as you want. I don't know how to obtain copyrights, so if you want
to modify or copy code from the program, you can. Please inform me of any
problems with my program or any suggestions for any subsequent versions.
Programmer:
Michael Calkins
4523 FM 541 W
Floresville, TX 78114
Phone number: 830-484-9060
I would like to thank Microsoft for their excellent BASIC language and for
QBASIC. May QBASIC always be recognized for its great value! Also thanks to
Mickey Vargas, Esther Mellick, and the Calkins Machine Corporation for giving me
a reason to write another program.
' time2
' By Michael Calkins
DECLARE FUNCTION exist% (efile$)
DECLARE SUB dat (m%)
DECLARE SUB snd (n%)
DECLARE SUB scr ()
DECLARE SUB mess (e%)
DECLARE FUNCTION abr$ (n%)
DECLARE FUNCTION form2$ (a%)
DECLARE SUB upd ()
DECLARE SUB form (m%, a$)
DECLARE SUB mark (hide%)
ON ERROR GOTO term
DIM SHARED nexis%
DIM SHARED m%, om%
DIM SHARED aud% 'audio
DIM SHARED mode% 'mode
DIM SHARED vld% 'validity indicator
DIM SHARED path$ 'path of ini file
path$ = "c:\time2"
m% = 0 'menu marker
om% = 0 'old menu marker
mode% = 1 ' 0 allows daily overtime entry, 1 doesn't.
aud% = 1 ' 0 is disabled, 1 is enabled
nl$ = CHR$(0) 'null character
TYPE tt
h AS INTEGER 'hours
m AS INTEGER 'minutes
sg AS INTEGER 'sometimes segments: min/60, somtimes other
END TYPE
DIM SHARED t(0 TO 8) AS tt
DIM SHARED w(0 TO 1, 0 TO 7) AS tt
t(8).h = 40
PLAY "mbt120"
dat 0
COLOR 7, 0: CLS 'white,black
COLOR 15, 6: PRINT "PeanutWare"; 'br white,brown
COLOR 7, 0 'white,black
PRINT " Time2"
SLEEP 1
CLS
PRINT "Time2, payroll time adder version 2."
PRINT
PRINT "1st shift:"
PRINT " Start:"; TAB(32); "h"
PRINT " End:"; TAB(32); "h"
PRINT "2nd shift:"
PRINT " Start:"; TAB(32); "h"
PRINT " End:"; TAB(32); "h"
scr
LOCATE 22, 1: PRINT "(F1-F7) Save day. (F8) Set reg cap. (F9) Audio: (F10) Mode:"
PRINT "(F12) Reset week."
upd
mark 0
DO
key$ = INKEY$
SELECT CASE key$
CASE nl$ + CHR$(71): om% = m%: m% = 0 'Home
CASE CHR$(27): om% = m%: m% = 7 'ESC
IF mode% = 1 THEN m% = 5
CASE CHR$(8): om% = m%: m% = 6 'Bkps
IF mode% = 1 THEN m% = 4
CASE nl$ + CHR$(72): om% = m%: m% = m% - 1 'up
IF m% < 0 THEN m% = 7 - 2 * mode%
CASE nl$ + CHR$(80): om% = m%: m% = m% + 1 'down
IF m% > 7 - 2 * mode% THEN m% = 0
CASE nl$ + CHR$(59), nl$ + CHR$(60), nl$ + CHR$(61), nl$ + CHR$(62), nl$ + CHR$(63), nl$ + CHR$(64), nl$ + CHR$(65)
' F1 to F7
mark 1
IF vld% = 1 THEN
al% = 2
n% = ASC(RIGHT$(key$, 1)) - 59
IF w(0, n%).h = 0 AND w(0, n%).m = 0 AND w(1, n%).h = 0 AND w(1, n%).m = 0 THEN al% = 1
w(0, n%).h = t(6).h
w(0, n%).m = t(6).m
w(0, n%).sg = t(6).sg
w(1, n%).h = t(7).h
w(1, n%).m = t(7).m
w(1, n%).sg = t(7).sg
ELSE
al% = 3
END IF
snd al%
upd
CASE nl$ + CHR$(66): LOCATE 1, 40 'F8
COLOR 10, 0 'green,black
LINE INPUT "(hh:mm) reg cap? "; a$
COLOR 7, 0 'white,black
form 8, a$
LOCATE 1, 40: PRINT SPACE$(40);
upd
CASE nl$ + CHR$(67): mark 1: aud% = 1 - aud%: upd 'F9
CASE nl$ + CHR$(68): mark 1: mode% = 1 - mode%: scr 'F11
IF mode% = 1 THEN
FOR i% = 0 TO 7
IF i% = 4 OR i% = 5 OR i% = 7 THEN
t(i%).h = 0
t(i%).m = 0
END IF
w(1, i%).h = 0
w(1, i%).m = 0
NEXT i%
END IF
IF m% > 5 THEN om% = m%: m% = m% - 2
upd
CASE nl$ + CHR$(134): mark 1 'F12
FOR n% = 0 TO 6
w(0, n%).h = 0
w(0, n%).m = 0
w(0, n%).sg = 0
w(1, n%).h = 0
w(1, n%).m = 0
w(1, n%).sg = 0
NEXT n%
upd
CASE CHR$(13) 'Enter
mark 1
SELECT CASE m%
CASE 0 TO 5 - 2 * mode%: LOCATE 4 + m% + (m% \ 2), 34 'menu 0 to 5: enter time
COLOR 10, 0 'green,black
LINE INPUT "(hh:mm) Time? "; a$
COLOR 7, 0 'white,black
form m%, a$
LOCATE 4 + m% + (m% \ 2), 34: PRINT SPACE$(46);
upd
CASE 6 - mode% * 2: FOR i% = 0 TO 5: t(i%).h = 0: t(i%).m = 0: NEXT i%: upd 'menu 6: clear time
CASE 7 - mode% * 2: LOCATE 22, 1: COLOR 7, 1 'menu 7: exit. white,blue
PRINT "Thank you for using Time2. Please report any problems with it to Michael";
COLOR 7, 0 'white,black
PRINT " "
COLOR 7, 1 'white,blue
PRINT "Calkins, Floresville, TX. Ph# 830-484-9060.";
COLOR 7, 0 'white,black
PRINT TAB(79); " "
SLEEP: WHILE INKEY$ <> "": WEND
dat 1
CLS
SYSTEM
END SELECT
CASE ELSE: GOTO 1
END SELECT
mark 0
1 LOOP
term:
LOCATE 22, 1: COLOR 7, 0 'white,black
PRINT "Error"; ERR; "at"; ERL; ". Please report this error to the programmer, Michael Calkins."
SYSTEM
exis:
nexis% = 0
RESUME NEXT
' 'abr$' returns a string based on the input 'n%'. 'abr$' is used for
' discrepency messages and displaying the alert status.
FUNCTION abr$ (n%)
SELECT CASE n%
CASE 1, 2: a$ = "Shft" + LTRIM$(STR$(n%))
CASE 3: a$ = "Overt"
CASE 4: a$ = "OFF"
CASE 5: a$ = "ON "
END SELECT
abr$ = a$
END FUNCTION
' 'dat' loads (m%=0) or saves (m%=1) settings in 'time2.ini', which is placed in
' the folder specified by 'path$'.
SUB dat (m%)
e% = exist%(path$ + "\time2.ini")
IF m% = 0 THEN
IF e% = 1 THEN
OPEN path$ + "\time2.ini" FOR INPUT AS 1
LINE INPUT #1, a$
IF a$ <> "TIME2 ini." THEN
CLOSE
PRINT "Invalid ini: '"; path$ + "\time2.ini'. Defaults will be used."
PRINT "Look at the file; if it is not a file used by you or some other program, delete"
PRINT "it so that Time2 can replace it with a valid ini file."
SLEEP: WHILE INKEY$ <> "": WEND
EXIT SUB
END IF
INPUT #1, mode%
INPUT #1, t(8).h, t(8).m
CLOSE
END IF
ELSE
IF e% = 1 THEN
OPEN path$ + "\time2.ini" FOR INPUT AS 1
LINE INPUT #1, a$
IF a$ <> "TIME2 ini." THEN
CLOSE
PRINT "Invalid ini: '"; path$ + "\time2.ini'. File won't be overwritten."
PRINT "Look at the file; if it is not a file used by you or some other program, delete"
PRINT "or rename it so that Time2 can replace it with a valid ini file. An alternative"
PRINT "is for you to backup 'time2.bas', then carefully change the 'path$' varible"
PRINT "within the program. That variable specifies the path of 'time2.ini'."
SLEEP: WHILE INKEY$ <> "": WEND
EXIT SUB
END IF
CLOSE
END IF
OPEN path$ + "\time2.ini" FOR OUTPUT AS 1
PRINT #1, "TIME2 ini."
PRINT #1, mode%
PRINT #1, t(8).h; ","; t(8).m
CLOSE
END IF
END SUB
' 'exist%' check attempts to see if a file exists. It returns 1 if the file or
' device can be opened for input, 0 if not.
' 'efile$' specifies the file or device to check for.
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
' 'form' formats the user's time input for storage in the 't' array.
' 'm%' specifies a subscript, 'a$' is the user's input.
SUB form (m%, a$)
a$ = RTRIM$(LTRIM$(a$))
a% = INSTR(a$, ":")
IF a% = 0 THEN a% = INSTR(a$, "-")
IF a% > 0 THEN
al% = 1
h# = VAL(LEFT$(a$, a% - 1))
m# = VAL(RIGHT$(a$, LEN(a$) - a%))
IF LEN(a$) - a% < 2 OR a% < 2 THEN al% = 2
ELSE
h# = VAL(a$)
m# = 0
al% = 2
END IF
IF INT(h#) < 0 OR INT(h# + .5) > 23 - (m% = 8) * 45 THEN h# = 0: al% = 3
IF INT(m#) < 0 OR INT(m# + .5) > 59 THEN m# = 0: al% = 3
t(m%).h = h#
t(m%).m = m#
IF aud% = 1 THEN
FOR i% = 1 TO LEN(a$)
SELECT CASE ASC(MID$(a$, i%, 1))
CASE 32, 45, 48 TO 58
CASE ELSE: al% = 3
END SELECT
NEXT i%
'entered format: 'al%' val
'h:mm' or 'hh:mm' 1
' ':', 'h:', ':m', 'h:m', 'hh:m', etc 2
'invalid time 3
snd al%
END IF
END SUB
' 'form2$' formats an integer for neat display, and returns the string result.
' 'form2$' ensures that the output will be at least 2 didgets. Although ensured
' by 'form', not 'form2$', the numbers won't have more than 2 didgets.
' 'a%' is the integer to format into text.
FUNCTION form2$ (a%)
a$ = LTRIM$(STR$(a%))
IF LEN(a$) < 2 THEN a$ = STRING$(2 - LEN(a$), "0") + a$
form2$ = a$
END FUNCTION
' 'mark' is responsible for the menu cursor. It erases the cursor from its old
' position (shared variable 'om%'), and draws it at its new position (shared
' variable 'm%').
' 'hide%' indicates whether to suppress highlighting of the cursor, 0 meaning
' highlight, non 0 meaning don't highlight.
SUB mark (hide%)
COLOR 7, 0 'white,black
LOCATE 4 + om% + (om% \ 2), 4: PRINT " "
IF hide% = 0 THEN COLOR 15, 4 'br white,red
LOCATE 4 + m% + (m% \ 2), 4: PRINT "--->"
COLOR 7, 0 'white,black
END SUB
' 'mess' displays discrepency messages.
' 'e%' contains a code specifying the type of error.
SUB mess (e%)
SELECT CASE e%
CASE 1 TO 3: m$ = "Neg rslt: " + abr$(e%)
CASE 4 TO 6: m$ = "Wr order: " + abr$((e% MOD 2) + 1) + " " + abr$(INT((e% + 1) / 2))
CASE 7 TO 9: m$ = "Overlap: " + abr$(((e% + 1) MOD 2) + 1) + " " + abr$(INT((e% - 2) / 2))
END SELECT
LOCATE ((e% - 1) \ 3) + 18, 1 + ((e% - 1) MOD 3) * 27
COLOR 31, 4 'blinking br white,red
PRINT "Û ";
COLOR 15, 4 'br white,red
PRINT m$;
COLOR 31, 4 'blinking br white,red
PRINT " Û";
COLOR 7, 0 'white,black
END SUB
' 'scr' is used when toggling mode. It changes the appearence of the menu, daily
' result, and weekly result.
SUB scr
COLOR 7, 0 'white,black
LOCATE 9, 1
SELECT CASE mode%
CASE 1
PRINT " "
PRINT " Clear"; TAB(32); " "
PRINT " Exit"; TAB(32); " "
PRINT
PRINT TAB(17); " "
PRINT TAB(17); " "
LOCATE 15, 40: PRINT "Day's results:"
PRINT TAB(40); "Time: hours."; TAB(80);
CASE 0
PRINT " Overtime:"
PRINT " Start:"; TAB(32); "h"
PRINT " End:"; TAB(32); "h"
PRINT
PRINT " Clear"
PRINT " Exit"
PRINT TAB(40); "Day's results:"
PRINT TAB(40); "Reg: hours. Over: hours."
END SELECT
END SUB
' If audio is enabled, 'snd' plays a specified alert.
' 'n%' specifies the alert.
SUB snd (n%)
IF aud% = 1 THEN
SELECT CASE n% 'audio alerts
CASE 1: PLAY "o3l16dl8f+"
CASE 2: PLAY "o3l16adl8f+"
CASE 3: PLAY "o3l4el64edededededededed"
END SELECT
END IF
END SUB
' 'upd' displays formated times, calculates and display the results, etc..
SUB upd
LOCATE 22, 38: COLOR 1, 0 'blue,black
PRINT form2$(t(8).h); ":"; form2$(t(8).m)
LOCATE 22, 57: COLOR 12 - aud% * 10, 0 'br red,black or green,black
PRINT abr$(aud% + 4)
LOCATE 22, 74: COLOR 1 + mode% * 4, 0 'blue,black or magenta,black
PRINT mode%
t(6).h = 0 'reseting these is necessary
t(6).m = 0
t(7).h = 0
t(7).m = 0
w(0, 7).h = 0
w(0, 7).m = 0
w(1, 7).h = 0
w(1, 7).m = 0
vld% = 1
COLOR 7, 0 'white,black
FOR i% = 18 TO 20: LOCATE i%, 1: PRINT SPACE$(80); : NEXT i%
PRINT
FOR i% = 0 TO 4 - 2 * mode% STEP 2
t(i%).sg = (t(i%).h * 60 + t(i%).m)
t(i% + 1).sg = (t(i% + 1).h * 60 + t(i% + 1).m)
a% = t(i% + 1).sg - t(i%).sg 'elapsed time in mins.
b% = a% \ 60 'elapsed hours for shift
c% = a% MOD 60 'minutes for shift
d% = 6 - (i% = 4) 'determines wheter to add results to reg. or overtime total
IF b% < 0 OR c% < 0 THEN 'alerts user of negative time.
t(d%).h = -1
mess i% / 2 + 1
vld% = 0
END IF
IF t(d%).h >= 0 THEN t(d%).h = t(d%).h + b%
t(d%).m = t(d%).m + c%
IF d% = 6 THEN 'if adding to the total for reg. shifts, ensures that
a% = t(d%).m 'total minutes don't exceed 59, carrying to the hours
t(d%).m = a% MOD 60 'place if neccessary.
t(d%).h = t(d%).h + a% \ 60
END IF
NEXT i%
FOR i% = 0 TO 2 + 4 STEP 2 ' checks for other discrepencies
IF t(i%).sg <> 0 OR t(i% + 1).sg <> 0 THEN
FOR x% = 0 TO 4 STEP 2
IF t(x%).sg <> 0 OR t(x% + 1).sg <> 0 THEN
IF i% > x% AND t(i%).sg < t(x% + 1).sg AND t(i% + 1).sg > t(x%).sg THEN 'overlap
IF i% = 2 THEN mess 7
IF i% = 4 THEN mess 9 - x% / 2
END IF
IF i% < x% AND t(i%).sg > t(x%).sg THEN 'incorect order
IF x% = 2 THEN mess 4
IF x% = 4 THEN mess 6 - i% / 2
END IF
END IF
NEXT x%
END IF
NEXT i%
FOR i% = 0 TO 7 - mode%
t(i%).sg = INT(t(i%).m / .6 + .5)
SELECT CASE i%
CASE 0 TO 5 - 2 * mode%
COLOR 13 + (i% > 3) * 4, 0 'br magenta,black or br blue,black
LOCATE 4 + i% + (i% \ 2), 19
PRINT form2$(t(i%).h); ":"; form2$(t(i%).m);
COLOR 7, 0 'white,black
sg$ = form2$(t(i%).sg)
IF RIGHT$(sg$, 1) = "0" THEN MID$(sg$, 2, 1) = " " 'cuts unnecessary ending '0'
PRINT " "; form2$(t(i%).h); "."; sg$
CASE 6, 7
LOCATE 16, (45 - 20 * (i% = 7)) + mode%: COLOR 12 + (i% = 7), 0'br red,black or br cyan,black
IF t(i%).h < 0 OR t(i%).m < 0 THEN
PRINT "INVAL"
ELSE
sg$ = form2$(t(i%).sg)
IF RIGHT$(sg$, 1) = "0" THEN MID$(sg$, 2, 1) = " "
PRINT form2$(t(i%).h); "."; sg$
END IF
END SELECT
NEXT i%
FOR c% = 0 TO 1 'adds up week
IF c% = 0 OR mode% = 0 THEN
FOR i% = 0 TO 6
w(c%, i%).sg = INT(w(c%, i%).m / .6 + .5)
w(c%, 7).h = w(c%, 7).h + w(c%, i%).h
w(c%, 7).m = w(c%, 7).m + w(c%, i%).m
NEXT i%
a% = w(c%, 7).m
w(c%, 7).m = a% MOD 60
w(c%, 7).h = w(c%, 7).h + a% \ 60
w(c%, 7).sg = INT(w(c%, 7).m / .6 + .5)
ELSE
t(8).sg = t(8).h * 60 + t(8).m
sg% = w(0, 7).h * 60 + w(0, 7).m
IF sg% > t(8).sg THEN
w(1, 7).sg = sg% - t(8).sg
w(1, 7).h = w(1, 7).sg \ 60
w(1, 7).m = w(1, 7).sg MOD 60
w(1, 7).sg = INT(w(1, 7).m / .6 + .5)
w(0, 7).h = t(8).h
w(0, 7).m = t(8).m
w(0, 7).sg = INT(w(0, 7).m / .6 + .5)
ELSE
w(1, 7).h = 0
w(1, 7).m = 0
w(1, 7).sg = 0
END IF
END IF
NEXT c%
COLOR 7, 0
LOCATE 3, 55: PRINT "Week:"
FOR i% = 0 TO 7
LOCATE 4 + i% - (i% = 7), 55
IF i% = 7 THEN
PRINT "Wk";
ELSE
IF w(0, i%).h = 0 AND w(0, i%).m = 0 AND w(1, i%).h = 0 AND w(1, i%).m = 0 THEN COLOR 1, 0'blue,black
PRINT "F"; LTRIM$(STR$(i% + 1));
COLOR 7, 0 'white,black
END IF
PRINT " R: ";
COLOR 13 + (i% = 7), 0 'br magenta,black or br red,black
sg$ = form2$(w(0, i%).sg)
IF RIGHT$(sg$, 1) = "0" THEN MID$(sg$, 2, 1) = " "
PRINT form2$(w(0, i%).h); "."; sg$; " h ";
COLOR 7, 0 ' white,black
IF mode% = 0 OR i% = 7 THEN
PRINT " O: ";
COLOR 9 - (i% = 7) * 2, 0 'br blue,black or br cyan,black
sg$ = form2$(w(1, i%).sg)
IF RIGHT$(sg$, 1) = "0" THEN MID$(sg$, 2, 1) = " "
PRINT form2$(w(1, i%).h); "."; sg$; " h";
COLOR 7, 0 ' white,black
ELSE
PRINT SPACE$(11);
END IF
NEXT i%
COLOR 7, 0 ' white,black
END SUB
DECLARE FUNCTION exist% (efile$)
DECLARE SUB copy (from$, to$)
DECLARE SUB upd ()
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DIM SHARED nexis%
ON ERROR GOTO term
CONST drv$ = ""
CONST dir$ = "c:\timecard"
CLS
PRINT
DO
upd
1
SELECT CASE INKEY$
CASE ""
CASE CHR$(27): CLS : SYSTEM
CASE ELSE
IF drv$ = "" THEN
LINE INPUT "Employee? "; emp$
IF exist%(dir$ + "\" + emp$ + "\timecard.dat") = 0 THEN
LINE INPUT "(ENTER for cancel) New employee name? "; full$
IF full$ = "" THEN CLOSE : CLS : LOCATE 3, 1: GOTO 1
LINE INPUT "(#.## no '$') Rate? "; rate$
MKDIR dir$ + "\" + emp$
OPEN dir$ + "\" + emp$ + "\timecard.dat" FOR OUTPUT AS 1
PRINT #1, emp$
PRINT #1, full$
PRINT #1, rate$
PRINT #1, "out"
PRINT #1, DATE$; " "; TIME$
CLOSE
END IF
OPEN dir$ + "\" + emp$ + "\timecard.dat" FOR INPUT AS 1
LINE INPUT #1, emp$
LINE INPUT #1, full$
LINE INPUT #1, rate$
LINE INPUT #1, stat$
LINE INPUT #1, when$
ELSE
IF exist%(dir$ + "\" + emp$ + "\timecard.dat") = 0 THEN
MKDIR dir$ + "\" + emp$
copy drv$ + "\timecard.log", dir$ + "\" + emp$ + "\timecard.log"
copy drv$ + "\timecard.pay", dir$ + "\" + emp$ + "\timecard.pay"
copy drv$ + "\timecard.dat", dir$ + "\" + emp$ + "\timecard.dat"
END IF
OPEN drv$ + "timecard.dat" FOR INPUT AS 1
LINE INPUT #1, emp$
LINE INPUT #1, full$
LINE INPUT #1, rate$
LINE INPUT #1, stat$
LINE INPUT #1, when$
END IF
rate! = VAL(rate$)
inv$ = "in"
IF stat$ = "in" THEN inv$ = "out"
emp$ = UCASE$(emp$)
PRINT "---Employee: "; full$; " ("; emp$; ")"
PRINT "---Current status: Checked "; stat$; " since "; when$
IF "N" = choice$("You wish to check " + emp$ + " " + inv$, "Y", "N", "", "", "", "", "", "", "", "") THEN CLOSE : CLS : LOCATE 3, 1: GOTO 1
upd
LINE INPUT "(mm:dd:yyyy or ENTER for current date) Date? "; d$
upd
LINE INPUT "(hh-mm-ss or ENTER for current time) Time? "; t$
CLOSE
IF d$ = "" THEN d$ = DATE$
IF t$ = "" THEN t$ = TIME$
IF drv$ = "" THEN
OPEN dir$ + "\" + emp$ + "\timecard.dat" FOR OUTPUT AS 1
PRINT #1, emp$
PRINT #1, full$
PRINT #1, rate$
PRINT #1, inv$
PRINT #1, d$; " "; t$
CLOSE
OPEN dir$ + "\" + emp$ + "\timecard.log" FOR APPEND AS 1
PRINT #1, inv$; ","; d$; " "; t$
CLOSE
IF inv$ = "out" THEN
OPEN dir$ + "\" + emp$ + "\timecard.pay" FOR APPEND AS 1
w$ = RIGHT$(when$, 8)
hrs! = (VAL(LEFT$(t$, 2)) + (VAL(MID$(t$, 4, 2)) + (VAL(RIGHT$(t$, 2)) / 60)) / 60) - (VAL(LEFT$(w$, 2)) + (VAL(MID$(w$, 4, 2)) + (VAL(RIGHT$(w$, 2)) / 60)) / 60)
IF d$ <> LEFT$(when$, 10) THEN hrs! = 24 + hrs!
PRINT #1, hrs!; ",", "$"; LTRIM$(STR$(rate! * hrs!))
CLOSE
END IF
ELSE
OPEN drv$ + "timecard.dat" FOR INPUT AS 1
PRINT #1, emp$
PRINT #1, full$
PRINT #1, rate$
PRINT #1, inv$
PRINT #1, d$; " "; t$
CLOSE
OPEN dir$ + "\" + emp$ + "\timecard.dat" FOR OUTPUT AS 1
PRINT #1, emp$
PRINT #1, full$
PRINT #1, rate$
PRINT #1, inv$
PRINT #1, d$; " "; t$
CLOSE
OPEN drv$ + "\timecard.log" FOR APPEND AS 1
PRINT #1, inv$; ","; d$; " "; t$
CLOSE
IF inv$ = "out" THEN
OPEN drv$ + "\timecard.pay" FOR APPEND AS 1
w$ = RIGHT$(when$, 8)
hrs! = (VAL(LEFT$(t$, 2)) + (VAL(MID$(t$, 4, 2)) + (VAL(RIGHT$(t$, 2)) / 60)) / 60) - (VAL(LEFT$(w$, 2)) + (VAL(MID$(w$, 4, 2)) + (VAL(RIGHT$(w$, 2)) / 60)) / 60)
IF d$ <> LEFT$(when$, 10) THEN hrs! = 24 + hrs!
PRINT #1, hrs!; ",", "$"; LTRIM$(STR$(rate! * hrs!))
CLOSE
END IF
copy drv$ + "\timecard.log", dir$ + "\" + emp$ + "\timecard.log"
copy drv$ + "\timecard.pay", dir$ + "\" + emp$ + "\timecard.pay"
END IF
CLS
CLEAR
PRINT
END SELECT
LOOP
CLS
SYSTEM
term:
PRINT "Error"; ERR; "at"; ERL
SYSTEM
exis:
nexis% = 0
RESUME NEXT
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
COLOR 7, 0
IF mon$ = "C" THEN COLOR 15, 1
PRINT pr$; "? ";
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
PRINT sl$
COLOR 7, 0
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
SUB copy (from$, to$)
IF exist%(to$) = 1 THEN KILL to$
OPEN from$ FOR BINARY AS 1
OPEN to$ FOR BINARY AS 2
DIM dat AS STRING * 1
DO
IF EOF(1) THEN EXIT DO
GET 1, , dat
PUT 2, , dat
LOOP
CLOSE
END SUB
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB upd
l% = CSRLIN
c% = POS(0)
LOCATE 1, 1
PRINT DATE$; " "; TIME$
LOCATE l%, c%
END SUB
pi# = 4 * ATN(1)
TYPE ct
x AS SINGLE
y AS SINGLE
END TYPE
DIM cr(0 TO 13) AS ct
mx% = 640
my% = 480
ra% = 30
ra2% = 50
RANDOMIZE TIMER
'ON PLAY(3) GOSUB addmus
'PLAY STOP
'PLAY "mb"
1 sng% = INT(RND * 3) + 3
evn% = 0
'SELECT CASE sng%
' CASE 3: PLAY "o2l2el4df+el2<bl4b>gl8ggl4f+l12agf+l4gl2e": mxe% = 5
' CASE 4: PLAY "o1l4a>l2dl4a.l8f+l4d<bba>l2dl4a.l8dl2mlbmnl4a": mxe% = 5
' CASE 5: PLAY "o2l4dde-d f.l8e-l2d l4ffcf l1d": mxe% = 2
'END SELECT
mode% = INT(RND * 3)
'PLAY ON
LINE (cr(0).x, cr(0).y)-(cr(1).x, cr(1).y), c%
LINE (cr(1).x, cr(1).y)-(cr(2).x, cr(2).y), c%
LINE (cr(2).x, cr(2).y)-(cr(0).x, cr(0).y), c%
LINE (cr(3).x, cr(3).y)-(cr(4).x, cr(4).y), c%
LINE (cr(4).x, cr(4).y)-(cr(5).x, cr(5).y), c%
LINE (cr(5).x, cr(5).y)-(cr(3).x, cr(3).y), c%
CIRCLE (x!, y!), 2, c2%, , , 1
IF mode% = 1 THEN
CIRCLE (x!, y!), bd%, c2%, , , 1
CIRCLE (x!, y!), ra2%, c2%, , , 1
LINE (x!, y!)-(x! + c!, y! + d!), c%
LINE (cr(6).x, cr(6).y)-(cr(7).x, cr(7).y), 0
LINE (cr(7).x, cr(7).y)-(cr(8).x, cr(8).y), 0
LINE (cr(8).x, cr(8).y)-(cr(6).x, cr(6).y), 0
LINE (cr(9).x, cr(9).y)-(cr(10).x, cr(10).y), 0
LINE (cr(10).x, cr(10).y)-(cr(11).x, cr(11).y), 0
LINE (cr(11).x, cr(11).y)-(cr(9).x, cr(9).y), 0
CIRCLE (cr(12).x, cr(12).y), 2, 0, , , 1
CIRCLE (cr(12).x, cr(12).y), bd%, 0, , , 1
CIRCLE (cr(12).x, cr(12).y), ra2%, 0, , , 1
LINE (cr(12).x, cr(12).y)-(cr(12).x + cr(13).x, cr(12).y + cr(13).y), 0
FOR i% = 6 TO 11
cr(i%).x = cr(i% - 6).x: cr(i%).y = cr(i% - 6).y
NEXT i%
cr(12).x = x!: cr(12).y = y!
cr(13).x = c!: cr(13).y = d!
LINE (cr(0).x, cr(0).y)-(cr(1).x, cr(1).y), c%
LINE (cr(1).x, cr(1).y)-(cr(2).x, cr(2).y), c%
LINE (cr(2).x, cr(2).y)-(cr(0).x, cr(0).y), c%
LINE (cr(3).x, cr(3).y)-(cr(4).x, cr(4).y), c%
LINE (cr(4).x, cr(4).y)-(cr(5).x, cr(5).y), c%
LINE (cr(5).x, cr(5).y)-(cr(3).x, cr(3).y), c%
CIRCLE (x!, y!), 2, c2%, , , 1
CIRCLE (x!, y!), bd%, c2%, , , 1
CIRCLE (x!, y!), ra2%, c2%, , , 1
LINE (x!, y!)-(x! + c!, y! + d!), c%
END IF
IF mode% = 2 THEN
LINE (cr(6).x, cr(6).y)-(cr(7).x, cr(7).y), 0
LINE (cr(7).x, cr(7).y)-(cr(8).x, cr(8).y), 0
LINE (cr(8).x, cr(8).y)-(cr(6).x, cr(6).y), 0
LINE (cr(9).x, cr(9).y)-(cr(10).x, cr(10).y), 0
LINE (cr(10).x, cr(10).y)-(cr(11).x, cr(11).y), 0
LINE (cr(11).x, cr(11).y)-(cr(9).x, cr(9).y), 0
CIRCLE (cr(12).x, cr(12).y), 2, 0, , , 1
FOR i% = 6 TO 11
cr(i%).x = cr(i% - 6).x: cr(i%).y = cr(i% - 6).y
NEXT i%
cr(12).x = x!: cr(12).y = y!
LINE (cr(0).x, cr(0).y)-(cr(1).x, cr(1).y), c%
LINE (cr(1).x, cr(1).y)-(cr(2).x, cr(2).y), c%
LINE (cr(2).x, cr(2).y)-(cr(0).x, cr(0).y), c%
LINE (cr(3).x, cr(3).y)-(cr(4).x, cr(4).y), c%
LINE (cr(4).x, cr(4).y)-(cr(5).x, cr(5).y), c%
LINE (cr(5).x, cr(5).y)-(cr(3).x, cr(3).y), c%
CIRCLE (x!, y!), 2, c2%, , , 1
END IF
ox! = x!: oy! = y!
x! = x! + cx!
y! = y! + cy!
IF of% MOD 10 = 0 THEN dir% = dir% + 1
IF x! >= mx% - bd% THEN
IF dir% > 0 AND dir% < 180 THEN
c% = c% + 1
dir% = 270 + (90 - dir%)
END IF
END IF
IF x! <= bd% THEN
IF dir% > 180 AND dir% < 360 THEN
c% = c% + 1
dir% = 90 + (270 - dir%)
END IF
END IF
IF y! >= my% - bd% THEN
IF dir% > 90 AND dir% < 270 THEN
c% = c% + 1
dir% = 180 - dir%
END IF
END IF
IF y! <= bd% THEN
IF dir% > 270 OR dir% < 90 THEN
c% = c% + 1
dir% = 180 + (0 - dir%)
END IF
END IF
IF c% >= 16 THEN c% = 1
c2% = c% + 1
IF c2% >= 16 THEN c2% = 1
of% = of% + 1
IF of% MOD 2 = 0 THEN of2% = of2% + 1
IF of% >= 360 THEN of% = of% - 360
IF of2% >= 360 THEN of2% = of2% - 360
DO
IF dir% >= 0 THEN EXIT DO
dir% = 360 + dir%
LOOP
IF dir% > 359 THEN dir% = dir% MOD 360
cx! = SIN(dir% * (pi# / 180))
cy! = 0 - COS(dir% * (pi# / 180))
LOOP
SCREEN 0
WIDTH 80
'RUN "sylvster"
END
addmus:
PLAY STOP
IF evn% > mxe% THEN PLAY "p4": RETURN 1
'LOCATE 1, 1: PRINT sng%; evn%
SELECT CASE sng%
CASE 3
SELECT CASE evn%
CASE 0: PLAY "l4el2bl4ag l2gl4f+l8ee l4>c.l8c<l4ag l2f+."
CASE 1: PLAY "l4<b >el8eel4df+ l2e.l4<b >l4gl8ggl4al8gf+ l4gl2e."
CASE 2: PLAY "bl4ag l2g.l8f+e l2f+l4ga l2b."
CASE 3: PLAY "l8ee l4>cc<f+f+ l8bbbbl4ee aad+d+"
CASE 4: PLAY "l8ef+gal4be >cc<f+f+bl8bbl4ee"
CASE 5: PLAY "agf+e ed+l2e."
CASE ELSE: SYSTEM
END SELECT
CASE 4
SELECT CASE evn%
CASE 0: PLAY "<a >l2dl4a.l8f+ l4d<bb>c+ l4mld mnl2dp4l8mlamnb"
CASE 1: PLAY ">l4c.<l8al4b.l8g l2e.l8mlgmna >l4c.l8<al4b.l8g l2e."
CASE 2: PLAY "l8mlgmna l4b-.l8gl4a.l8f l2d.l4d"
CASE 3: PLAY "dl8ddl4dl8<b>dl2e."
CASE 4: PLAY "o1l4a >l2dl4a.l8f+ l4d<bba >l2dl4a.l8d l2b."
CASE 5: PLAY "l4b l2al4a.l8f+ l4f+l8mlemnd<l4b>c+ mll1d mnl2d."
CASE ELSE: SYSTEM
END SELECT
CASE 5:
SELECT CASE evn%
CASE 0: PLAY "l4dde-d b-.l8al2g l4ggcg l1f"
CASE 1: PLAY "l4ffb-a a.l8gl2g l4gg>c<b- l1a"
CASE 2: PLAY "l4aa>dc c.<l8b-l2g. l4fb->c.<l8b- l1b-"
CASE ELSE: SYSTEM
END SELECT
CASE ELSE: SYSTEM
END SELECT
evn% = evn% + 1
PLAY ON
RETURN
DECLARE FUNCTION mv& (d$)
DECLARE FUNCTION dv$ (m&)
' $DYNAMIC
DECLARE SUB getpath ()
DECLARE FUNCTION ct! (d$)
DECLARE FUNCTION cs! (d$)
DECLARE FUNCTION dm% (m%, y!)
DECLARE SUB updc (f$, skp&)
DECLARE FUNCTION sel$ (m$)
DECLARE SUB nent ()
DECLARE SUB opne ()
DECLARE FUNCTION wt$ (n%)
DECLARE SUB loadent ()
DECLARE SUB saveent (l%, t$)
DECLARE FUNCTION trim$ (a$, a%)
DECLARE SUB cbox (hight%, wid%, title$)
DECLARE FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
DECLARE SUB action (code%)
DECLARE SUB box (sl%, sc%, el%, ec%, all%)
DECLARE SUB drwmenu ()
DECLARE SUB menusys ()
DECLARE SUB c (cm%)
DECLARE FUNCTION exist% (efile$)
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED nummenus%
DIM SHARED p1%
DIM SHARED p2%
DIM SHARED md%
DIM SHARED pp%
DIM SHARED tl%
DIM SHARED tc%
DIM SHARED prn$
DIM SHARED ent$
DIM SHARED Mon$
DIM SHARED tmp$
TYPE compt
file AS STRING * 64
nam AS STRING * 32
stat AS INTEGER
bs AS INTEGER
ist AS INTEGER
ibs AS INTEGER
last AS STRING * 7
END TYPE
DIM SHARED comp(0 TO 19) AS compt
TYPE chgt
typ AS STRING * 1
dat AS STRING * 12
v AS INTEGER
l AS LONG
END TYPE
DIM SHARED chg(0 TO 14) AS chgt
TYPE trt
dat AS STRING * 7
books AS INTEGER
bro AS INTEGER
hrs AS SINGLE
mags AS INTEGER
rv AS INTEGER
bs AS INTEGER
l AS LONG
END TYPE
DIM SHARED tr(0 TO 14) AS trt
DIM SHARED entnam AS STRING * 32
DIM SHARED path$
tmp$ = ENVIRON$("TEMP")
getpath
prn$ = "PRN"
IF exist%("TRM.dat") = 1 THEN
OPEN "TRM.dat" FOR INPUT AS 1
LINE INPUT #1, prn$
LINE INPUT #1, ent$
CLOSE
END IF
IF exist%(ent$) = 0 THEN
2 SELECT CASE choice$("<N>ew entity, <O>pen entity, or <E>xit", "N", "O", "E", "", "", "", "", "", "", "")
CASE "N": nent
CASE "O": opne
CASE "E": c 0: SYSTEM
END SELECT
IF ent$ = "" THEN GOTO 2
END IF
OPEN "TRM.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
loadent
nummenus% = 3
TYPE menudat
ni AS INTEGER
text AS STRING * 16
END TYPE
TYPE itemdat
text AS STRING * 14
code AS INTEGER
END TYPE
DIM SHARED menu(1 TO nummenus%) AS menudat
DIM SHARED items(1 TO nummenus%, 1 TO 20) AS itemdat
DIM SHARED shortcut$(-20 TO -1)
RESTORE Short
FOR i% = -1 TO -20 STEP -1
READ shortcut$(i%)
NEXT i%
RESTORE Menudata
FOR i% = 1 TO nummenus%
READ menu(i%).text
READ menu(i%).ni
NEXT i%
RESTORE m1
FOR i% = 1 TO menu(1).ni
READ items(1, i%).text
READ items(1, i%).code
NEXT i%
RESTORE m2
FOR i% = 1 TO menu(2).ni
READ items(2, i%).text
READ items(2, i%).code
NEXT i%
RESTORE M3
FOR i% = 1 TO menu(3).ni
READ items(3, i%).text
READ items(3, i%).code
NEXT i%
c 0
menusys
SYSTEM
term:
c 0
PRINT "Error"; ERR; "at"; ERL
PRINT "Please report the exact circumstances of this error to the author."
SYSTEM
exis:
nexis% = 0
RESUME NEXT
Menudata:
DATA "File",6,"Component",7,"Reports",4
m1:
DATA "Open",1,"New",2,"Edit",3,"Backup",4,"Options",5,"Exit",6
m2:
DATA "New Entry",7,"Edit Entry",8,"Stat Change",9,"BS Change",10,"Edit Change",11,"Edit Component",12,"New Component",13
M3:
DATA "Individual",14,"Book Study(Mon)",15,"Cong(Mon)",16,"Cong(Year)",17
Short:
DATA "","","","","","","","","","","","","","","","","","","",""
sadserr:
Mon$ = "M"
RESUME NEXT
REM $STATIC
SUB action (code%)
drwmenu
1
SELECT CASE code%
CASE 1: opne
OPEN "TRM.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
CASE 2: nent
CASE 3: o% = 0: p% = 0
5 c 3: CLS : c 4: PRINT "---Edit Entity---"
c 3
PRINT "<N>ame: "; entnam
8 FOR i% = 0 TO 19: comp(i%).file = "": NEXT i%
l% = -2
OPEN ent$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF l% >= o% AND l% <= o% + 19 THEN comp(l% - o%).file = a$
l% = l% + 1
LOOP
ln% = l% - 1
CLOSE
DO
FOR i% = 0 TO 19
IF LTRIM$(comp(i%).file) <> "" THEN
OPEN RTRIM$(comp(i%).file) FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, comp(i%).nam
INPUT #1, comp(i%).bs
INPUT #1, comp(i%).stat
INPUT #1, comp(i%).ibs
INPUT #1, comp(i%).ist
LINE INPUT #1, comp(i%).last
CLOSE
END IF
NEXT i%
FOR i% = 0 TO 19
LOCATE i% + 3
c 2
IF o% + i% = p% THEN c 1
IF LTRIM$(comp(i%).file) <> "" THEN
PRINT RTRIM$(comp(i%).file); STR$(comp(i%).bs); " "; trim$(RTRIM$(comp(i%).nam), 69 - POS(0)); " "; TAB(70); wt$(comp(i%).stat)
ELSE
PRINT SPACE$(80)
END IF
NEXT i%
c 3
WHILE INKEY$ <> "": WEND
PRINT "<ESC> exit <N>ame <> <> <ENTER> select "
4 k$ = INKEY$
SELECT CASE k$
CASE CHR$(27): EXIT DO
CASE "N", "n":
CLS : PRINT "---Edit Entity---"
PRINT "Latest: "; entnam
LINE INPUT "New name? "; entnam: saveent 1, entnam
GOTO 5
CASE CHR$(0) + CHR$(72): IF p% > 0 THEN p% = p% - 1
IF p% < o% THEN o% = o% - 1: GOTO 8
CASE CHR$(0) + CHR$(80): IF p% <= ln% THEN p% = p% + 1
IF p% > o% + 19 THEN o% = o% + 1: GOTO 8
CASE CHR$(0) + CHR$(73)
IF p% > 0 THEN
p% = p% - 20
o% = o% - 20
IF p% < 0 THEN p% = 0
IF o% < 0 THEN o% = 0
GOTO 8
ELSE
GOTO 4
END IF
CASE CHR$(0) + CHR$(81)
IF p% <= ln% THEN
p% = p% + 20
o% = o% + 20
IF p% > ln% + 1 THEN p% = ln% + 1
IF o% > ln% - 18 THEN o% = ln% - 18
IF o% < 0 THEN o% = 0
GOTO 8
ELSE
GOTO 4
END IF
CASE CHR$(13): c 3: CLS : c 4: PRINT "---Edit Entity---": c 3
PRINT "Name: "; entnam
PRINT "Latest component:"
IF LTRIM$(comp(p% - o%).file) <> "" THEN
PRINT "File: "; RTRIM$(comp(p% - o%).file)
PRINT "Name: "; trim$(RTRIM$(comp(p% - o%).nam), 74)
PRINT "Latest status: "; wt$(comp(p% - o%).stat)
PRINT "Latest BS:"; comp(p% - o%).ist
PRINT "Initial status: "; wt$(comp(p% - o%).ist)
PRINT "Initial BS:"; comp(p% - o%).ibs
PRINT "Last time entry: "; comp(i%).last
ELSE
PRINT "None"
END IF
PRINT
LINE INPUT "('' for no component.) New component file? "; comp(p% - o%).file
comp(p% - o%).file = (LTRIM$(comp(p% - o%).file))
saveent p% + 2, RTRIM$(comp(p% - o%).file)
GOTO 5
CASE ELSE: GOTO 4
END SELECT
LOOP
CASE 4
CASE 5: c 3: CLS : c 4: PRINT "---Options---"
c 3
PRINT "Current printer device: "; prn$
a$ = prn$
LINE INPUT "New device? "; prn$
prn$ = LTRIM$(RTRIM$(prn$))
IF prn$ = "" THEN prn$ = a$
OPEN "TRM.dat" FOR OUTPUT AS 1
PRINT #1, prn$
PRINT #1, ent$
CLOSE
c 0
CASE 6: c 0: SYSTEM
CASE 7: f$ = sel$("---New Time Entry---")
IF f$ = "" THEN GOTO 7
c 3: CLS : c 4: PRINT "---New Time Entry---": c 3
CASE 8
u& = -1
up& = -1
DO
f$ = sel$("Edit or Create a Time Entry.")
IF f$ = "" THEN EXIT DO
o& = 0
p& = 0
p1% = 0
13 c 3: CLS : c 4: PRINT "Edit or Create a Time Entry.": c 3
PRINT "File: "; f$
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, stat%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
PRINT "Name: "; a$; " "; "Last time entry: "; comp(i%).last
PRINT "Latest BS:"; bs%, "Latest stat: "; wt$(stat%); " Ini BS:"; ibs%, "Ini stat:"; ist%
PRINT "Date Books Brouchure Hours Mags RVs BStdys "
DO
FOR i% = 0 TO 14: tr(i%).dat = "": tr(i%).books = 0: tr(i%).bro = 0: tr(i%).hrs = 0: tr(i%).mags = 0: tr(i%).rv = 0: tr(i%).bs = 0: NEXT i%
l& = -7
ln& = -1
OPEN f$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF l& >= 0 THEN
IF a$ = "T" THEN
IF l& >= o& AND l& <= o& + 14 THEN
a% = l& - o&
INPUT #1, tr(a%).dat, tr(a%).books, tr(a%).bro, tr(a%).hrs, tr(a%).mags, tr(a%).rv, tr(a%).bs
chg(a%).l = l&
ELSE
LINE INPUT #1, a$
END IF
ln& = ln& + 1
ELSE
LINE INPUT #1, a$
END IF
END IF
l& = l& + 1
LOOP
CLOSE
14 FOR a% = 0 TO 14
c 2
LOCATE a% + 6, 1: PRINT SPACE$(80)
IF a% + o& <= ln& + 1 THEN
FOR b% = 0 TO 6
LOCATE a% + 6, b% * 9 + 1
c 2
IF o& + a% = p& AND b% = p1% THEN c 1
SELECT CASE b%
CASE 0: m$ = tr(a%).dat
CASE 1: m$ = STR$(tr(a%).books)
CASE 2: m$ = STR$(tr(a%).bro)
CASE 3: m$ = STR$(tr(a%).hrs)
CASE 4: m$ = STR$(tr(a%).mags)
CASE 5: m$ = STR$(tr(a%).rv)
CASE 6: m$ = STR$(tr(a%).bs)
END SELECT
IF tr(a%).dat = "" THEN m$ = ""
PRINT m$ + SPACE$(9 - LEN(m$))
NEXT b%
END IF
NEXT a%
c 3
WHILE INKEY$ <> "": WEND
LOCATE 23: PRINT "<ESC> exit <F> new file <> <> <PgUp> <PgDn> <ENTER> edit <DEL> delete"
15 k$ = INKEY$
SELECT CASE k$
CASE CHR$(27)
IF up& > -1 THEN
a% = up& - o&
OPEN f$ FOR APPEND AS 1
PRINT #1, "T"
PRINT #1, tr(a%).dat; ","; tr(a%).books; ","; tr(a%).bro; ","; tr(a%).hrs; ","; tr(a%).mags; ","; tr(a%).rv; ","; tr(a%).bs
CLOSE
updc f$, u&
u& = -1
up& = -1
END IF
GOTO 7 'ESC
CASE CHR$(0) + CHR$(75): p1% = p1% - 1 'left
IF p1% = -1 THEN p1% = 6
GOTO 14
CASE CHR$(0) + CHR$(77): p1% = p1% + 1 'right
IF p1% = 7 THEN p1% = 0
GOTO 14
CASE CHR$(0) + CHR$(72): IF p& > 0 THEN p& = p& - 1 'up
IF p& < o& THEN
o& = o& - 1
ELSE
IF up& > -1 THEN GOTO 16
GOTO 14
END IF
IF up& > -1 THEN GOTO 16
CASE CHR$(0) + CHR$(80): IF p& < ln& + 1 THEN p& = p& + 1 'down
IF p& > o& + 14 THEN
o& = o& + 1
ELSE
IF up& > -1 THEN GOTO 16
GOTO 14
END IF
CASE CHR$(0) + CHR$(73) ' pgup
IF p& > 0 THEN
p& = p& - 15
o& = o& - 15
IF p& < 0 THEN p& = 0
IF o& < 0 THEN o& = 0
IF up& > -1 THEN GOTO 16
ELSE
GOTO 15
END IF
CASE CHR$(0) + CHR$(81) ' pgdn
IF p& < ln& + 1 THEN
p& = p& + 15
o& = o& + 15
IF p& > ln& + 1 THEN p& = ln& + 1
IF o& > ln& - 13 THEN o& = ln& - 13
IF o& < 0 THEN o& = 0
IF up& > -1 THEN GOTO 16
ELSE
GOTO 15
END IF
CASE CHR$(13) 'enter
a% = p& - o&
b% = p1%
IF LTRIM$(tr(a%).dat) = "" THEN b% = 0
LOCATE a% + 6, b% * 9 + 1: PRINT SPACE$(9)
LOCATE a% + 6, b% * 9 + 1
c 1
LINE INPUT a$
SELECT CASE b%
CASE 0: tr(a%).dat = a$
CASE 1: tr(a%).books = VAL(a$)
CASE 2: tr(a%).bro = VAL(a$)
CASE 3: tr(a%).hrs = VAL(a$)
CASE 4: tr(a%).mags = VAL(a$)
CASE 5: tr(a%).rv = VAL(a$)
CASE 6: tr(a%).bs = VAL(a$)
END SELECT
u& = -1
IF p& < ln& + 1 THEN u& = tr(a%).l
up& = p&
GOTO 14
16 a% = up& - o&
OPEN f$ FOR APPEND AS 1
PRINT #1, "T"
PRINT #1, tr(a%).dat; ","; tr(a%).books; ","; tr(a%).bro; ","; tr(a%).hrs; ","; tr(a%).mags; ","; tr(a%).rv; ","; tr(a%).bs
CLOSE
updc f$, u&
u& = -1
up& = -1
GOTO 13
CASE CHR$(0) + CHR$(83) 'del
IF ln& = -1 OR p& - o& > ln& THEN GOTO 15
LOCATE 23: PRINT SPACE$(80)
LOCATE 23
IF choice$("Delete change", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN
LOCATE 23: PRINT "<ESC> exit <F> new file <> <> <PgUp> <PgDn> <ENTER> edit <DEL> delete"
GOTO 15
END IF
updc f$, tr(p& - o&).l
u& = -1
up& = -1
GOTO 13
CASE "F", "f"
IF up& > -1 THEN
a% = up& - o&
OPEN f$ FOR APPEND AS 1
PRINT #1, "T"
PRINT #1, tr(a%).dat; ","; tr(a%).books; ","; tr(a%).bro; ","; tr(a%).hrs; ","; tr(a%).mags; ","; tr(a%).rv; ","; tr(a%).bs
CLOSE
updc f$, u&
u& = -1
up& = -1
END IF
EXIT DO
CASE ELSE: GOTO 15
END SELECT
LOOP
LOOP
CASE 9: f$ = sel$("---Insert Status Change---")
IF f$ = "" THEN GOTO 7
c 3: CLS : c 4: PRINT "---Insert Status Change---": c 3
PRINT "Note: Status changes are ordered chronologically. Status changes do not alter"
PRINT "the initial status. The initial status is effective prior to the earliest"
PRINT "change."
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, b%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
b$ = wt$(b%)
PRINT "File: "; f$
PRINT "Name: "; a$
PRINT "Latest book study:"; bs%
PRINT "Latest status: "; wt$(b%)
PRINT "Initial BS:"; ibs%
PRINT "Initial status: "; wt$(ist%)
PRINT "Last time entry: "; comp(i%).last
PRINT
FOR i% = 0 TO 7: PRINT i%; wt$(i%): NEXT i%
cc% = VAL(choice$("Change status to", "0", "1", "2", "3", "4", "5", "6", "7", "", ""))
PRINT "Today: "; DATE$
LINE INPUT "(mm-dd-yyyy, '' for current) Status change effective: "; d$
d$ = LTRIM$(RTRIM$(d$))
IF d$ = "" THEN d$ = DATE$
OPEN f$ FOR APPEND AS 1
PRINT #1, "S"
PRINT #1, d$; ","; cc%
CLOSE
updc f$, -1
CASE 10: f$ = sel$("---Insert Book Study Change---")
IF f$ = "" THEN GOTO 7
c 3: CLS : c 4: PRINT "---Insert Book Study Change ---": c 3
PRINT "Note: BS changes are ordered chronologically. BS changes do not alter the"
PRINT "initial BS. The initial BS is effective prior to earliest change."
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, b%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
b$ = wt$(b%)
PRINT "File: "; f$
PRINT "Name: "; a$
PRINT "Latest book study:"; bs%
PRINT "Latest status: "; wt$(b%)
PRINT "Initial BS:"; ibs%
PRINT "Initial status: "; wt$(ist%)
PRINT "Last time entry: "; comp(i%).last
PRINT
INPUT "Change book study to"; bs%
PRINT "Today: "; DATE$
LINE INPUT "(mm-dd-yyyy, '' for current) BS change effective: "; d$
d$ = LTRIM$(RTRIM$(d$))
IF d$ = "" THEN d$ = DATE$
OPEN f$ FOR APPEND AS 1
PRINT #1, "B"
PRINT #1, d$; ","; STR$(bs%)
CLOSE
updc f$, -1
CASE 11
DO
f$ = sel$("Edit a Status or BS change.")
IF f$ = "" THEN EXIT DO
12 c 3: CLS : c 4: PRINT "Edit a Status or BS change.": c 3
PRINT "File: "; f$
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, stat%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
PRINT "Name: "; a$; " "; "Last time entry: "; comp(i%).last
PRINT "Latest BS:"; bs%, "Latest stat: "; wt$(stat%); " Ini BS:"; ibs%, "Ini stat:"; ist%
PRINT
o& = 0
p& = 0
DO
FOR i% = 0 TO 14: chg(i%).typ = "": NEXT i%
l& = -7
ln& = -1
OPEN f$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF l& >= 0 THEN
IF a$ = "S" OR a$ = "B" THEN
IF l& >= o& AND l& <= o& + 14 THEN
chg(l& - o&).typ = a$
INPUT #1, chg(l& - o&).dat, chg(l& - o&).v
chg(l& - o&).l = l&
ELSE
LINE INPUT #1, a$
END IF
ln& = ln& + 1
ELSE
LINE INPUT #1, a$
END IF
END IF
l& = l& + 1
LOOP
CLOSE
10 FOR i% = 0 TO 14
LOCATE i% + 6
c 2
IF o& + i% = p& THEN c 1
IF LTRIM$(chg(i%).typ) <> "" THEN
IF chg(i%).typ = "S" THEN
m1$ = "Status"
m2$ = wt$(chg(i%).v)
ELSE
m1$ = " BS"
m2$ = STR$(chg(i%).v)
END IF
PRINT m1$; " change: "; chg(i%).dat; " "; m2$; TAB(80); " "
ELSE
PRINT SPACE$(80)
END IF
NEXT i%
IF ln& = -1 THEN LOCATE 6, 1: PRINT "No changes!"
c 3
WHILE INKEY$ <> "": WEND
LOCATE 23: PRINT "<ESC> exit <F> new file <> <> <PgUp> <PgDn> <ENTER> edit <DEL> delete"
11 k$ = INKEY$
SELECT CASE k$
CASE CHR$(27): GOTO 7 'ESC
CASE CHR$(0) + CHR$(72): IF p& > 0 THEN p& = p& - 1 'up
IF p& < o& THEN
o& = o& - 1
ELSE
GOTO 10
END IF
CASE CHR$(0) + CHR$(80): IF p& < ln& THEN p& = p& + 1 'down
IF p& > o& + 14 THEN
o& = o& + 1
ELSE
GOTO 10
END IF
CASE CHR$(0) + CHR$(73) ' pgup
IF p& > 0 THEN
p& = p& - 15
o& = o& - 15
IF p& < 0 THEN p& = 0
IF o& < 0 THEN o& = 0
ELSE
GOTO 11
END IF
CASE CHR$(0) + CHR$(81) ' pgdn
IF p& < ln& THEN
p& = p& + 15
o& = o& + 15
IF p& > ln& THEN p& = ln&
IF o& > ln& - 14 THEN o& = ln& - 14
IF o& < 0 THEN o& = 0
ELSE
GOTO 11
END IF
CASE CHR$(13) 'enter
IF ln& = -1 THEN GOTO 11
c 3: CLS : c 4: PRINT "Edit a Status or BS change.": c 3
PRINT "File: "; f$
PRINT "Name: "; a$
PRINT "Latest BS:"; bs%, "Latest stat:"; stat%, "Ini BS:"; ibs%, "Ini stat:"; ist%
PRINT
PRINT
IF chg(p& - o&).typ = "S" THEN
m1$ = "Status"
m2$ = wt$(chg(p& - o&).v)
ELSE
m1$ = " BS"
m2$ = STR$(chg(p& - o&).v)
END IF
PRINT m1$; " change: "; chg(p& - o&).dat; " "; m2$; TAB(80); " "
PRINT
IF chg(p& - o&).typ = "S" THEN
FOR i% = 0 TO 7: PRINT i%; wt$(i%): NEXT i%
chg(p& - o&).v = VAL(choice$("Change status to", "0", "1", "2", "3", "4", "5", "6", "7", "", ""))
ELSE
INPUT "Change book study to"; chg(p& - o&).v
END IF
LINE INPUT "(mm-dd-yyyy, '' for old) Change effective: "; d$
d$ = LTRIM$(RTRIM$(d$))
IF d$ <> "" THEN chg(p& - o&).dat = d$
OPEN f$ FOR APPEND AS 1
PRINT #1, chg(p& - o&).typ
PRINT #1, chg(p& - o&).dat; ","; STR$(chg(p& - o&).v)
CLOSE
updc f$, chg(p& - o&).l
GOTO 12
CASE CHR$(0) + CHR$(83) 'del
IF ln& = -1 THEN GOTO 11
LOCATE 23: PRINT SPACE$(80)
LOCATE 23
IF choice$("Delete change", "Y", "N", "", "", "", "", "", "", "", "") = "N" THEN
LOCATE 23: PRINT "<ESC> exit <F> new file <> <> <PgUp> <PgDn> <ENTER> edit <DEL> delete"
GOTO 11
END IF
updc f$, chg(p& - o&).l
GOTO 12
CASE "F", "f": EXIT DO
CASE ELSE: GOTO 11
END SELECT
LOOP
LOOP
CASE 12: f$ = sel$("---Edit Componant---")
IF f$ = "" THEN GOTO 7
c 3: CLS : c 4: PRINT "---Edit Componant---": c 3
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, b%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
b$ = wt$(b%)
PRINT "File: "; f$
PRINT "Name: "; a$
PRINT "Latest BS:"; bs%
PRINT "Latest status: "; wt$(b%)
PRINT "Initial BS:"; ibs%
PRINT "Initial status: "; wt$(ist%)
PRINT "Last time entry: "; comp(i%).last
PRINT
IF choice$("(Y/N) Modify name", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN LINE INPUT "New name? "; a$
IF choice$("(Y/N) Modify INITIAL BS", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN INPUT "Book study"; ibs%
IF choice$("(Y/N) Modify INITIAL status", "Y", "N", "", "", "", "", "", "", "", "") = "Y" THEN
PRINT
FOR i% = 0 TO 7: PRINT i%; wt$(i%): NEXT i%
ist% = VAL(choice$("Component's initial status", "0", "1", "2", "3", "4", "5", "6", "7", "", ""))
END IF
SHELL "copy " + f$ + " " + tmp$ + "\trm.tmp > nul"
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
OPEN f$ FOR OUTPUT AS 2
i& = 0
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, b$
IF i& = 1 THEN b$ = a$
IF i& = 4 THEN b$ = STR$(ibs%)
IF i& = 5 THEN b$ = STR$(ist%)
PRINT #2, b$
i& = i& + 1
LOOP
CLOSE
KILL tmp$ + "\trm.tmp"
updc f$, -1
CASE 13: c 3: CLS : c 4: PRINT "---New Componant---": c 3
PRINT "This new component will be added to the current entity."
DO
LINE INPUT "('' to cancel.) Component file? "; a$
a$ = LTRIM$(RTRIM$(a$))
IF a$ = "" THEN EXIT DO
IF exist%(a$) = 1 THEN
PRINT "File already exists."
ELSE
LINE INPUT "Component name? "; b$
INPUT "Book study"; bs%
PRINT
FOR i% = 0 TO 7: PRINT i%; wt$(i%): NEXT i%
cc% = VAL(choice$("Component's initial status", "0", "1", "2", "3", "4", "5", "6", "7", "", ""))
OPEN a$ FOR OUTPUT AS 1
PRINT #1, "Valid TRM component file."
PRINT #1, b$
PRINT #1, bs%
PRINT #1, cc%
PRINT #1, bs%
PRINT #1, cc%
PRINT #1, ""
CLOSE
saveent -1, a$
EXIT DO
END IF
LOOP
CASE 14: f$ = sel$("---Individual Report---")
IF f$ = "" THEN GOTO 7
c 3: CLS : c 4: PRINT "---Individual Report---": c 3
OPEN f$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, a$
INPUT #1, bs%
INPUT #1, b%
INPUT #1, ibs%
INPUT #1, ist%
LINE INPUT #1, comp(i%).last
CLOSE
b$ = wt$(b%)
PRINT "File: "; f$
PRINT "Name: "; a$
PRINT "Latest BS:"; bs%
PRINT "Latest status: "; wt$(b%)
PRINT "Initial BS:"; ibs%
PRINT "Initial status: "; wt$(ist%)
PRINT "Last time entry: "; comp(i%).last
PRINT
PRINT "mm-yyyy"
LINE INPUT "From? "; d1$
LINE INPUT "To? "; d2$
dl& = mv&(d1!)
' enforce:
PRINT "(Time period must be included by chart time period.) Graph:"
LINE INPUT "From? "; d3$
LINE INPUT "To? "; d4$
LINE INPUT "Interval in months? "; iv%
d1! = cs!(d1!)
d2! = cs!(d2$)
OPEN f$ FOR INPUT AS 1
OPEN tmp$ + "\trm.tmp" FOR OUTPUT AS 2
OPEN tmp$ + "\trm-i.tmp" FOR OUTPUT AS 3
PRINT #2, "Individual report, "; d1$; " to "; d2$; ". Name: "; a$
PRINT #2, "File: "; f$
PRINT #2, "Latest BS:"; bs%, "Latest stat:"; stat%, "Ini BS:"; ibs%, "Ini stat:"; ist%
FOR i% = 0 TO 6
LINE INPUT #1, a$
IF i% = 4 THEN bs% = VAL(a$)
IF i% = 5 THEN cc% = VAL(a$)
NEXT i%
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF a$ = "T" THEN
INPUT #1, d$, tr(0).books, tr(0).bro, tr(0).hrs, tr(0).mags, tr(0).rv, tr(0).bs
i2! = ct!(d$)
ELSE
INPUT #1, d$, a%
i2! = cs!(d$)
IF a$ = "B" THEN bs% = a%
IF a$ = "S" THEN cc% = a%
END IF
IF i2! >= d1! AND i2! <= d1! THEN
' you will have to do this again afterward in case of blanks at end of time period.
IF mv&(d$) - dl& > 1 THEN
FOR i& = dl& TO mv&(d$)
IF i& >= mv&(d1$) AND i& <= mv&(d2$) THEN
PRINT #3, "*,"; d$; ","; tr(0).books; ","; tr(0).bro; ","; tr(0).hrs; ","; tr(0).mags; ","; tr(0).rv; ","; tr(0).bs
END IF
NEXT i&
END IF
IF a$ = "T" THEN
PRINT #3, " ,"; d$; ","; tr(0).books; ","; tr(0).bro; ","; tr(0).hrs; ","; tr(0).mags; ","; tr(0).rv; ","; tr(0).bs
ELSE
PRINT #3, d$; ","; a%
END IF
' ?? dl& =
ll& = lb&
i! = i3!
EXIT DO
END IF
l& = l& + 1
LOOP
CLOSE 1
LOOP
CLOSE
SUB box (sl%, sc%, el%, ec%, all%)
LOCATE sl%, sc%: PRINT "Ú"; STRING$((ec% - sc%) - 1, "Ä"); "¿"
IF all% = 1 THEN
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³"; SPACE$((ec% - sc%) - 1); "³"
NEXT i%
ELSE
FOR i% = sl% + 1 TO el% - 1
LOCATE i%, sc%: PRINT "³": LOCATE i%, ec%: PRINT "³"
NEXT i%
END IF
LOCATE el%, sc%: PRINT "À"; STRING$((ec% - sc%) - 1, "Ä"); "Ù"
END SUB
SUB c (cm%)
IF Mon$ = "M" THEN
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 0, 10 'menu high black, high white
CASE 2: COLOR 1, 0 'menu norm underl, black
CASE 3: COLOR 7, 0 'text norm white, black
CASE 4: COLOR 10, 0 'text high high white, black
CASE 5: COLOR 9, 0 'text red high underl, black
CASE 6: COLOR 1, 0 'text other underl, black
END SELECT
ELSE
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 11, 1 'menu high br cyan, blue
CASE 2: COLOR 11, 0 'menu norm br cyan, black
CASE 3: COLOR 7, 1 'text norm white, blue
CASE 4: COLOR 15, 1 'text high br white, blue
CASE 5: COLOR 12, 1 'text red br red, blue
CASE 6: COLOR 10, 1 'text other br greed, blue
END SELECT
END IF
cp% = cc%
cc% = cm%
END SUB
SUB cbox (hight%, wid%, title$)
IF hight% > 20 THEN hight% = 20
IF wid% > 77 THEN wid% = 77
zhight% = hight%
IF hight% \ 2 = hight% / 2 THEN zhight% = hight% - 1
sl% = INT(11.5 - INT(zhight% / 2 + .5))
IF hight% \ 2 = hight% / 2 THEN zhight% = hight% + 1
el% = INT(11.5 + INT(zhight% / 2 + .5))
zwid% = wid%
IF wid% / 2 <> wid% \ 2 THEN zwid% = wid% - 1
sc% = 39 - INT(zwid% / 2 + .5)
IF wid% / 2 <> wid% \ 2 THEN zwid% = wid% + 1
ec% = 41 + INT(zwid% / 2 - .5)
box sl%, sc%, el%, ec%, 1
LOCATE sl%, 40 - INT(LEN(title$) / 2 + .5): PRINT title$
tl% = sl% + 1
tc% = sc% + 1
END SUB
FUNCTION choice$ (pr$, c1$, c2$, c3$, c4$, c5$, c6$, c7$, c8$, c9$, c10$)
IF c2$ = "" THEN c2$ = c1$
IF c3$ = "" THEN c3$ = c1$
IF c4$ = "" THEN c4$ = c1$
IF c5$ = "" THEN c5$ = c1$
IF c6$ = "" THEN c6$ = c1$
IF c7$ = "" THEN c7$ = c1$
IF c8$ = "" THEN c8$ = c1$
IF c9$ = "" THEN c9$ = c1$
IF c10$ = "" THEN c10$ = c1$
c1$ = UCASE$(c1$)
c2$ = UCASE$(c2$)
c3$ = UCASE$(c3$)
c4$ = UCASE$(c4$)
c5$ = UCASE$(c5$)
c6$ = UCASE$(c6$)
c7$ = UCASE$(c7$)
c8$ = UCASE$(c8$)
c9$ = UCASE$(c9$)
c10$ = UCASE$(c10$)
c 4
PRINT pr$; "? ";
LOCATE , , 1
DO
key$ = UCASE$(INKEY$)
IF key$ = c1$ OR key$ = c2$ OR key$ = c3$ OR key$ = c4$ OR key$ = c5$ OR key$ = c6$ OR key$ = c7$ OR key$ = c8$ OR key$ = c9$ OR key$ = c10$ THEN sl$ = key$: EXIT DO
IF key$ <> "" THEN
IF snd$ = "Y" THEN BEEP
END IF
LOOP
LOCATE , , 0
PRINT sl$
c 3
WHILE INKEY$ <> "": WEND
choice$ = sl$
END FUNCTION
FUNCTION dm% (m%, y!)
IF y! MOD 4 = 0 AND (y! / 100 MOD 4 = 0 OR y! \ 100 <> y! / 100) THEN l% = 1
SELECT CASE m%
CASE 1: d% = 0
CASE 2: d% = 31
CASE 3: d% = 59 + l%
CASE 4: d% = 90 + l%
CASE 5: d% = 120 + l%
CASE 6: d% = 151 + l%
CASE 7: d% = 181 + l%
CASE 8: d% = 212 + l%
CASE 9: d% = 242 + l%
CASE 10: d% = 273 + l%
CASE 11: d% = 303 + l%
CASE 12: d% = 334 + l%
CASE 13: d% = 364 + l%
END SELECT
dm% = d%
END FUNCTION
SUB drwmenu
LOCATE 1, 1
FOR i% = 1 TO nummenus%
IF i% = p1% THEN c 1
PRINT menu(i%).text;
c 2
NEXT i%
IF p1% <> pp% THEN COLOR 0, 0: box 2, ((pp% - 1) * 16) + 1, menu(pp%).ni + 3, ((pp% - 1) * 16) + 16, 1: c 1: pp% = p1%
IF md% = 1 THEN
box 2, ((p1% - 1) * 16) + 1, menu(p1%).ni + 3, ((p1% - 1) * 16) + 16, 0
FOR i% = 1 TO menu(p1%).ni
LOCATE i% + 2, ((p1% - 1) * 16) + 2
IF i% = p2% THEN c 1
PRINT items(p1%, i%).text
c 2
NEXT i%
END IF
PRINT
END SUB
FUNCTION dv$ (m&)
d$ = LTRIM$(STR$(m& / 12))
dv$ = LTRIM$(STR$(m& MOD 12)) + "-" + d$
END FUNCTION
FUNCTION exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO 0'term
IF nexis% = 1 THEN CLOSE op%
exist% = nexis%
END FUNCTION
SUB getpath
SHELL "cd > " + tmp$ + "\TRM.tmp"
OPEN tmp$ + "\TRM.tmp" FOR INPUT AS 1
LINE INPUT #1, path$
CLOSE
KILL tmp$ + "\TRM.tmp"
IF RIGHT$(path$, 1) <> "\" THEN path$ = path$ + "\"
END SUB
SUB loadent
3 i% = 0
OPEN ent$ FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, entnam
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
a% = 0
IF exist%(a$) = 0 THEN
CLS : PRINT "File '"; a$; "' not found.": a% = 1
ELSE
OPEN a$ FOR INPUT AS 2
LINE INPUT #2, b$
IF b$ <> "Valid TRM component file." THEN CLOSE : CLS : PRINT "'"; a$; "' not a TRM component file.": a% = 1
CLOSE 2
END IF
IF a% = 1 THEN
CLOSE
LINE INPUT "('' for no component.) New component file? "; a$
SHELL "copy " + ent$ + " " + tmp$ + "\trm.tmp > nul"
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
OPEN ent$ FOR OUTPUT AS 2
i2% = -2
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, b$
IF i2% = i% THEN b$ = a$
IF b$ <> "" THEN PRINT #2, b$
i2% = i2% + 1
LOOP
CLOSE
KILL tmp$ + "\trm.tmp"
GOTO 3
END IF
i% = i% + 1
LOOP
CLOSE
END SUB
SUB menusys
p1% = 1
p2% = 0
md% = 0
pp% = 1
DO
drwmenu
key$ = INKEY$
SELECT CASE key$
CASE "":
CASE CHR$(0) + CHR$(80): md% = 1: p2% = p2% + 1
IF p2% > menu(p1%).ni THEN p2% = 1
CASE CHR$(0) + CHR$(72): md% = 1: p2% = p2% - 1
IF p2% < 1 THEN p2% = menu(p1%).ni
CASE CHR$(0) + CHR$(75): pp% = p1%: p1% = p1% - 1: p2% = md%
IF p1% < 1 THEN p1% = nummenus%
CASE CHR$(0) + CHR$(77): pp% = p1%: p1% = p1% + 1: p2% = md%
IF p1% > nummenus% THEN p1% = 1
CASE CHR$(27): pp% = p1%: md% = 0: p2% = 0: tp% = p1%: p1% = 0: drwmenu: p1% = tp%: pp% = tp%
CASE CHR$(13), " ":
IF md% = 0 THEN
md% = 1: p2% = 1
ELSE
t1% = p1%: t2% = p2%
md% = 0: p1% = 0: p2% = 0
action items(t1%, t2%).code
p1% = 1: pp% = 1
END IF
CASE ELSE
FOR i% = -20 TO -1
IF UCASE$(key$) = UCASE$(shortcut$(i%)) THEN action i%
NEXT i%
END SELECT
LOOP
' up 72 left 75 right 77 down 80 lf 10
END SUB
FUNCTION mv& (d$)
mv& = LEFT$(d$, 2) + RIGHT$(d$, 4) * 12
END FUNCTION
SUB nent
c 3: CLS : c 4: PRINT "---New Entity---"
c 3
be$ = ent$
DO
LINE INPUT "('' to cancel.) Entity file? "; ent$
ent$ = LTRIM$(RTRIM$(ent$))
IF ent$ = "" THEN ent$ = be$: CLS : EXIT SUB
IF exist%(ent$) = 1 THEN
PRINT "File already exists."
ELSE
LINE INPUT "Entity name? "; entnam
OPEN ent$ FOR OUTPUT AS 1
PRINT #1, "Valid TRM entity file."
PRINT #1, entnam
CLOSE
CLS
EXIT SUB
END IF
LOOP
END SUB
SUB opne
be$ = ent$
CLS
PRINT "---Open Entity---"
DO
PRINT
SHELL "dir /w | more"
SHELL "cd"
LINE INPUT "('' to cancel, dir name to change path.) Open entity? "; ent$
ent$ = LTRIM$(RTRIM$(ent$))
IF ent$ = "" THEN ent$ = be$: CLS : EXIT SUB
IF exist%(ent$ + "\nul") = 1 THEN
SHELL "cd " + ent$
ELSEIF exist%(ent$) = 1 THEN
OPEN ent$ FOR INPUT AS 1
a% = 0
IF EOF(1) THEN
a% = 1
ELSE
LINE INPUT #1, a$
IF a$ <> "Valid TRM entity file." THEN a% = 1
END IF
CLOSE
IF a% = 1 THEN
PRINT "Not a valid TRM entity file."
ELSE
loadent
CLS
EXIT SUB
END IF
ELSE
PRINT "File not found."
END IF
LOOP
END SUB
SUB sads
Mon$ = "C"
ON ERROR GOTO sadserr
SCREEN 1
ON ERROR GOTO term
IF Mon$ = "C" THEN SCREEN 0: WIDTH 80
END SUB
SUB saveent (l%, t$)
SHELL "copy " + ent$ + " " + tmp$ + "\trm.tmp > nul"
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
OPEN ent$ FOR OUTPUT AS 2
i% = 0
DO
IF EOF(1) THEN
IF i% < l% THEN
CLOSE
KILL tmp$ + "\trm.tmp"
SHELL "copy " + tmp$ + "\trm.tmp" + " " + ent$ + " > nul"
KILL tmp$ + "\trm.tmp"
c 0: PRINT "An error has occurred in the 'saveent' sub procedure of this program."
PRINT "Please report the exact circumstances of this error to the author."
PRINT i%; l%; "'"; t$; "'"
SYSTEM
END IF
IF l% = -1 OR l% = i% THEN
l% = i%
ELSE
EXIT DO
END IF
ELSE
LINE INPUT #1, a$
END IF
IF i% = l% THEN
a$ = t$
END IF
IF i% = 1 OR a$ <> "" THEN PRINT #2, a$
i% = i% + 1
LOOP
CLOSE
KILL tmp$ + "\trm.tmp"
loadent
END SUB
FUNCTION sel$ (m$)
c 3: CLS : c 4: PRINT m$: c 3
PRINT "Entity: "; entnam
o% = 0
p% = 0
DO
FOR i% = 0 TO 19: comp(i%).file = "": NEXT i%
l% = -2
OPEN ent$ FOR INPUT AS 1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF l% >= o% AND l% <= o% + 19 THEN comp(l% - o%).file = a$
l% = l% + 1
LOOP
ln% = l% - 1
CLOSE
9 FOR i% = 0 TO 19
IF LTRIM$(comp(i%).file) <> "" THEN
OPEN RTRIM$(comp(i%).file) FOR INPUT AS 1
LINE INPUT #1, a$
LINE INPUT #1, comp(i%).nam
INPUT #1, comp(i%).bs
INPUT #1, comp(i%).stat
LINE INPUT #1, comp(i%).last
CLOSE
END IF
NEXT i%
FOR i% = 0 TO 19
LOCATE i% + 3
c 2
IF o% + i% = p% THEN c 1
IF LTRIM$(comp(i%).file) <> "" THEN
PRINT LTRIM$(STR$(comp(i%).bs)); " "; trim$(RTRIM$(comp(i%).nam), 69 - POS(0)); " "; TAB(70); wt$(comp(i%).stat)
ELSE
PRINT SPACE$(80)
END IF
NEXT i%
IF ln% = -1 THEN LOCATE 3, 1: PRINT "No components!"
c 3
WHILE INKEY$ <> "": WEND
LOCATE 23, 1: PRINT "<ESC> exit <> <> <ENTER> select "
6 k$ = INKEY$
SELECT CASE k$
CASE CHR$(27): r$ = "": EXIT DO
CASE CHR$(0) + CHR$(72): IF p% > 0 THEN p% = p% - 1
IF p% < o% THEN
o% = o% - 1
ELSE
GOTO 9
END IF
CASE CHR$(0) + CHR$(80): IF p% < ln% THEN p% = p% + 1
IF p% > o% + 19 THEN
o% = o% + 1
ELSE
GOTO 9
END IF
CASE CHR$(0) + CHR$(73)
IF p% > 0 THEN
p% = p% - 20
o% = o% - 20
IF p% < 0 THEN p% = 0
IF o% < 0 THEN o% = 0
ELSE
GOTO 6
END IF
CASE CHR$(0) + CHR$(81)
IF p% < ln% THEN
p% = p% + 20
o% = o% + 20
IF p% > ln% THEN p% = ln%
IF o% > ln% - 19 THEN o% = ln% - 19
IF o% < 0 THEN o% = 0
ELSE
GOTO 6
END IF
CASE CHR$(13): r$ = RTRIM$(comp(p% - o%).file): EXIT DO
CASE ELSE: GOTO 6
END SELECT
LOOP
sel$ = r$
END FUNCTION
SUB timerl (tdly#)
tst# = TIMER
DO
IF TIMER - tst# >= tdly# THEN EXIT DO
LOOP
END SUB
FUNCTION trim$ (a$, a%)
IF LEN(a$) > a% THEN a$ = LEFT$(a$, a%)
trim$ = a$
END FUNCTION
SUB updc (f$, skp&)
SHELL "copy " + f$ + " " + tmp$ + "\trm.tmp > nul"
OPEN f$ FOR OUTPUT AS 2
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
FOR i% = 0 TO 6
LINE INPUT #1, a$
PRINT #2, a$
IF i% = 4 THEN bs% = VAL(a$)
IF i% = 5 THEN cc% = VAL(a$)
NEXT i%
CLOSE 1
i! = 0
ll& = -1
la$ = ""
DO
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
FOR i% = 0 TO 6: LINE INPUT #1, a$: NEXT i%
i3! = -1
l& = 0
lb& = -1
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, a$
IF a$ = "T" THEN
INPUT #1, d$, tr(0).books, tr(0).bro, tr(0).hrs, tr(0).mags, tr(0).rv, tr(0).bs
i2! = ct!(d$)
ELSE
INPUT #1, d$, a%
i2! = cs!(d$)
END IF
IF l& <> skp& AND (i3! = -1 OR i2! < i3!) AND (i2! > i! OR (i2! = i! AND l& > ll&)) THEN i3! = i2!: lb& = l&
l& = l& + 1
LOOP
CLOSE 1
IF i3! = -1 THEN EXIT DO
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
FOR i% = 0 TO 6: LINE INPUT #1, a$: NEXT i%
l& = 0
DO
LINE INPUT #1, a$
IF a$ = "T" THEN
INPUT #1, d$, tr(0).books, tr(0).bro, tr(0).hrs, tr(0).mags, tr(0).rv, tr(0).bs
ELSE
INPUT #1, d$, a%
END IF
IF lb& = l& THEN
PRINT #2, a$
IF a$ = "T" THEN
PRINT #2, d$; ","; tr(0).books; ","; tr(0).bro; ","; tr(0).hrs; ","; tr(0).mags; ","; tr(0).rv; ","; tr(0).bs
la$ = d$
ELSE
PRINT #2, d$; ","; a%
IF a$ = "B" THEN bs% = a%
IF a$ = "S" THEN cc% = a%
END IF
ll& = lb&
i! = i3!
EXIT DO
END IF
l& = l& + 1
LOOP
CLOSE 1
LOOP
CLOSE
KILL tmp$ + "\trm.tmp"
SHELL "copy " + f$ + " " + tmp$ + "\trm.tmp > nul"
OPEN tmp$ + "\trm.tmp" FOR INPUT AS 1
OPEN f$ FOR OUTPUT AS 2
i& = 0
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, b$
IF i& = 2 THEN b$ = STR$(bs%)
IF i& = 3 THEN b$ = STR$(cc%)
IF i& = 6 THEN b$ = la$
PRINT #2, b$
i& = i& + 1
LOOP
CLOSE
KILL tmp$ + "\trm.tmp"
END SUB
FUNCTION wt$ (n%)
SELECT CASE n%
CASE 0: n$ = "publisher "
CASE 1: n$ = "unbaptised "
CASE 2: n$ = "auxilary pi"
CASE 3: n$ = "regular pio"
CASE 4: n$ = "special pio"
CASE 5: n$ = "inactive "
CASE 6: n$ = "disfellows "
CASE 7: n$ = "dead "
END SELECT
wt$ = n$
END FUNCTION
DECLARE FUNCTION fmc% (file$)
DECLARE FUNCTION sr% (n%)
DECLARE FUNCTION fmx% (file$)
DECLARE SUB sad ()
DECLARE FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
DECLARE SUB c (cm%)
DECLARE FUNCTION Exist% (efile$)
COMMON transfer$
DIM SHARED cp%
DIM SHARED nexis%
DIM SHARED Monitor$
DIM SHARED SadMode%
DIM SHARED smono%
DIM SHARED SpH%
DIM SHARED SpO%
DIM SHARED SM%
DIM SHARED GoodEga%
ON ERROR GOTO term
sad
c 1
IF Exist%("c:\view.dat") = 1 THEN fil$ = "c:\view.dat": GOTO 1
IF Exist%("a:\view.dat") = 1 THEN fil$ = "a:\view.dat": GOTO 1
2
c 3
LINE INPUT "File: "; file$
c 1
IF Exist%(file$) = 0 THEN
PRINT "File not found."
c 3
IF UCASE$(choice$("Retype(Y/N)", "Y", "y", "N", "n", "y", "y", "y", "y", "y", "y")) = "Y" THEN GOTO 2
c 1
GOTO 3
END IF
GOTO 4
1
OPEN fil$ FOR INPUT AS #1
LINE INPUT #1, file$
CLOSE
KILL fil$
4
ON ERROR GOTO 0
DIM dat$(1 TO 20)
lin% = 1
col% = 1
c 0
COLOR 7, 1
CLS
' &h0d &h0a = lf
mx% = fmx%(file$)
mc% = fmc%(file$)
OPEN file$ FOR INPUT AS #1
LINE INPUT #1, dat$(1)
5
FOR i% = 2 TO 20
IF EOF(1) THEN EXIT FOR
LINE INPUT #1, dat$(i%)
NEXT
CLOSE
6
FOR i% = 1 TO 20
LOCATE i%, 1: PRINT STRING$(80, " ")
LOCATE i%, 1: PRINT MID$(dat$(i%), col%, col% + 80)
NEXT i%
LOCATE 21, 1
COLOR 0, 7
tex$ = "top line on screen is line:" + STR$(lin%) + " /" + STR$(mx%) + " Leftern most byte on columb" + STR$(col%) + " /" + STR$(mc%)
PRINT "'"; file$; "'"; STRING$(80 - (LEN(file$) + 2), " ")
LOCATE 22, 1: PRINT tex$; STRING$(80 - LEN(tex$), " ")
LOCATE 23, 1: PRINT "<ESC=exit> Use arrow keys, PgUp, PgDn, Home, End to move in the document. "
COLOR 7, 1
DO
key$ = INKEY$
SELECT CASE key$
CASE "":
CASE CHR$(27): GOTO 3
CASE CHR$(0) + CHR$(72):
IF lin% > 1 THEN lin% = lin% - 1
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE CHR$(0) + CHR$(75):
IF col% > 1 THEN col% = col% - 1
GOTO 6
CASE CHR$(0) + CHR$(77):
IF col% < mc% - 80 THEN col% = col% + 1
GOTO 6
CASE "<": col% = 1: GOTO 6
CASE ">": col% = mc% - 80: GOTO 6
CASE ",": col% = 1: GOTO 6
CASE ".": col% = mc% - 80: GOTO 6
CASE CHR$(0) + CHR$(80):
IF lin% < mx% - 19 THEN lin% = lin% + 1
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE CHR$(0) + CHR$(73):
IF lin% - 19 < 1 THEN lin% = 1
IF lin% - 19 >= 1 THEN lin% = lin% - 19
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE CHR$(0) + CHR$(81):
IF lin% + 19 > mx% - 19 THEN lin% = mx% - 19
IF lin% + 19 <= mx% - 19 THEN lin% = lin% + 19
IF lin% < 1 THEN lin% = 1
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE CHR$(0) + CHR$(79):
lin% = mx% - 19
IF lin% < 1 THEN lin% = 1
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE CHR$(0) + CHR$(71):
lin% = 1
CLOSE : OPEN file$ FOR INPUT AS #1
i% = 1
DO
LINE INPUT #1, dat$(1)
IF i% = lin% THEN EXIT DO
i% = i% + 1
LOOP
GOTO 5
CASE ELSE: BEEP
END SELECT
LOOP
3 CLOSE
c 0
c 1
PRINT "File Viewer ver. 2.0 by Michael Calkins."
COLOR 7, 0
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
term:
c 0
PRINT "Error"; ERR; "at"; ERL;
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
exis:
nexis% = 0
RESUME NEXT
errsad:
SELECT CASE SadMode%
CASE 12: SadMode% = 13: RESUME
CASE 13: SadMode% = 9: RESUME
CASE 9: SadMode% = 1: RESUME
CASE 1: SadMode% = 0: RESUME NEXT
END SELECT
errsad2:
SpO% = 0
RESUME NEXT
errsad3:
SpH% = 0
RESUME NEXT
errsad4:
GoodEga% = 0
RESUME NEXT
SUB c (cm%)
IF smono% = 1 AND cm% <> 0 AND cm% < 4 THEN COLOR 7, 0: EXIT SUB
IF smono% = 1 AND cm% = 4 THEN COLOR 2, 0: EXIT SUB
IF cm% < 0 OR cm% > 4 THEN EXIT SUB
SELECT CASE cm%
CASE 0: COLOR 7, 0: CLS
CASE 1: COLOR 2, 0
CASE 2: COLOR 15, 4
CASE 3: COLOR 15, 1
CASE 4: COLOR 14, 0
END SELECT
cp% = cc%
cc% = cm%
END SUB
FUNCTION choice$ (chcz$, chca$, chcb$, chcc$, chcd$, chce$, chcf$, chcg$, chch$, chci$, chcj$)
c 3
PRINT chcz$; "? ";
DO
cky$ = INKEY$
IF cky$ = chca$ OR cky$ = chcb$ OR cky$ = chcc$ OR cky$ = chcd$ OR cky$ = chce$ OR cky$ = chcf$ OR cky$ = chcg$ OR cky$ = chch$ OR cky$ = chci$ OR cky$ = chcj$ THEN EXIT DO
LOOP
PRINT cky$
IF cp% > 0 THEN c cp%
choice$ = cky$
END FUNCTION
FUNCTION Exist% (efile$)
nexis% = 1
op% = FREEFILE
ON ERROR GOTO exis
OPEN efile$ FOR INPUT AS op%
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE op%
Exist% = nexis%
END FUNCTION
FUNCTION fmc% (file$)
OPEN file$ FOR INPUT AS #1
max% = 0
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, j$
IF LEN(j$) > max% THEN max% = LEN(j$)
LOOP
CLOSE
fmc% = max%
END FUNCTION
FUNCTION fmx% (file$)
OPEN file$ FOR INPUT AS #1
mx% = 0
DO
IF EOF(1) THEN EXIT DO
LINE INPUT #1, j$
mx% = mx% + 1
LOOP
CLOSE
fmx% = mx%
END FUNCTION
SUB sad
SadMode% = 12
ON ERROR GOTO errsad
SCREEN SadMode%
ON ERROR GOTO term
smono% = 0
SELECT CASE SadMode%
CASE 12: Monitor$ = "VGA"
CASE 13: Monitor$ = "MCGA"
CASE 9: Monitor$ = "EGA"
CASE 1: Monitor$ = "CGA"
CASE 0: Monitor$ = "Monochrome": smono% = 1
END SELECT
SpH% = 1
SpO% = 1
ON ERROR GOTO errsad2
SCREEN 4
ON ERROR GOTO errsad3
SCREEN 3
ON ERROR GOTO term
IF SpH% = 1 THEN Monitor$ = Monitor$ + " (Hercules)"
IF SpO% = 1 THEN Monitor$ = Monitor$ + " (Olivetti / AT&T)"
IF SadMode% = 9 THEN
GoodEga% = 1
ON ERROR GOTO errsad4
PALETTE 4, 0
ON ERROR GOTO term
IF GoodEga% = 1 THEN PALETTE 4, 4: Monitor$ = "> 64K " + Monitor$
IF GoodEga% = 0 THEN Monitor$ = "<= 64K " + Monitor$
END IF
IF SadMode% <> 0 OR SM% <> 0 THEN SCREEN 0: WIDTH 80, 25
c 0
END SUB
This message has been edited by MCalkins on Feb 23, 2011 3:09 AM
DECLARE SUB pp (c%)
DECLARE SUB plot ()
DECLARE SUB bearing (c%)
DIM SHARED pi#
TYPE pt
x AS SINGLE
y AS SINGLE
z AS SINGLE
o0 AS SINGLE
o1 AS SINGLE
END TYPE
DIM SHARED p AS pt
DIM SHARED pavar!(0 TO 1)
TYPE cornert
atr AS INTEGER
a0 AS SINGLE
a1 AS SINGLE
x AS SINGLE
y AS SINGLE
z AS SINGLE
px AS SINGLE
py AS SINGLE
END TYPE
DIM SHARED nc%
nc% = 8
DIM SHARED corner(0 TO nc% - 1) AS cornert
TYPE edget
c0 AS INTEGER
c1 AS INTEGER
END TYPE
DIM SHARED ne%
ne% = 12
DIM SHARED edge(0 TO ne% - 1) AS edget
DIM SHARED bs%
pi# = ATN(1) * 4
DIM SHARED mx%
DIM SHARED my%
mx% = 640
my% = 480
pavar!(0) = 60
pavar!(1) = (my% / mx%) * pavar!(0)
p.x = 5
p.y = 75
p.z = 5
p.o0 = 0
p.o1 = 0
SCREEN 12
FOR x = -40 TO 40 STEP .25
p.x = x
'p.y = x + 50
p.z = x
FOR c% = 0 TO nc% - 1
bearing c%
pp c%
NEXT c%
LINE (0, 0)-(640, 480), 0, BF
plot
NEXT x
SUB bearing (c%)
'IF corner(c%).y = p.y THEN
' corner(c%).a0 = 90
'ELSE
corner(c%).a0 = ABS(ATN((corner(c%).x - p.x) / SQR((corner(c%).z - p.z) ^ 2 + (corner(c%).y - p.y) ^ 2)) / (pi# / 180))
'END IF
IF corner(c%).y > p.y THEN
IF corner(c%).x > p.x THEN
corner(c%).a0 = 180 - corner(c%).a0
ELSE
corner(c%).a0 = 180 + corner(c%).a0
END IF
ELSE
IF corner(c%).x < p.x THEN
corner(c%).a0 = 360 - corner(c%).a0
END IF
END IF
' IF corner(c%).x = p.x THEN
' corner(c%).a1 = 90
' ELSE
corner(c%).a1 = ABS(ATN((corner(c%).z - p.z) / SQR((corner(c%).x - p.x) ^ 2 + (corner(c%).y - p.y) ^ 2)) / (pi# / 180))
' END IF
IF corner(c%).z < p.z THEN corner(c%).a1 = 360 - corner(c%).a1
END SUB
SUB plot
FOR c% = 0 TO nc% - 1
IF corner(c%).px >= 0 AND corner(c%).px <= mx% AND corner(c%).py >= 0 AND corner(c%).py <= my% THEN PSET (corner(c%).px, corner(c%).py), 10
NEXT c%
FOR e% = 0 TO ne% - 1
IF corner(edge(e%).c0).px >= 0 AND corner(edge(e%).c0).px <= mx% AND corner(edge(e%).c0).py >= 0 AND corner(edge(e%).c0).py <= my% THEN
IF corner(edge(e%).c1).px >= 0 AND corner(edge(e%).c1).px <= mx% AND corner(edge(e%).c1).py >= 0 AND corner(edge(e%).c1).py <= my% THEN
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
ELSE
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
END IF
ELSE
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
END IF
NEXT e%
END SUB
corner(c%).py = ABS(ABS(360 - p.o1 < corner(c%).a1) * 360 + (360 - p.o1) - (360 - corner(c%).a1))
IF corner(c%).py > 180 THEN corner(c%).py = corner(c%).py - 360
corner(c%).py = my% / 2 - corner(c%).py * (my% / pavar!(1))
END SUB
--------------------------
DECLARE SUB upd ()
DECLARE SUB pp (c%)
DECLARE SUB plot ()
DECLARE SUB bearing (c%)
DIM SHARED pi#
TYPE pt
x AS SINGLE
y AS SINGLE
z AS SINGLE
o0 AS SINGLE
o1 AS SINGLE
END TYPE
DIM SHARED p AS pt
DIM SHARED pavar!(0 TO 1)
TYPE cornert
atr AS INTEGER
a0 AS SINGLE
a1 AS SINGLE
x AS SINGLE
y AS SINGLE
z AS SINGLE
px AS SINGLE
py AS SINGLE
END TYPE
DIM SHARED nc%
nc% = 8
DIM SHARED corner(0 TO nc% - 1) AS cornert
TYPE edget
c0 AS INTEGER
c1 AS INTEGER
END TYPE
DIM SHARED ne%
ne% = 12
DIM SHARED edge(0 TO ne% - 1) AS edget
DIM SHARED bs%
pi# = ATN(1) * 4
DIM SHARED mx%
DIM SHARED my%
mx% = 640
my% = 480
pavar!(0) = 60
pavar!(1) = (my% / mx%) * pavar!(0)
p.x = 5
p.y = 75
p.z = 5
p.o0 = 0
p.o1 = 0
SCREEN 12
DO
k$ = UCASE$(INKEY$)
SELECT CASE k$
CASE "A": p.x = p.x - 1
CASE "D": p.x = p.x + 1
CASE "W": p.y = p.y - 1
CASE "S": p.y = p.y + 1
CASE "R": p.z = p.z + 1
CASE "F": p.z = p.z - 1
CASE CHR$(0) + CHR$(72): p.o1 = p.o1 + 1
CASE CHR$(0) + CHR$(75): p.o0 = p.o0 - 1
CASE CHR$(0) + CHR$(77): p.o0 = p.o0 + 1
CASE CHR$(0) + CHR$(80): p.o1 = p.o1 - 1
CASE CHR$(27): EXIT DO
END SELECT
upd
LOOP
SUB bearing (c%)
'IF corner(c%).y = p.y THEN
' corner(c%).a0 = 90
'ELSE
corner(c%).a0 = ABS(ATN((corner(c%).x - p.x) / SQR((corner(c%).z - p.z) ^ 2 + (corner(c%).y - p.y) ^ 2)) / (pi# / 180))
'END IF
IF corner(c%).y > p.y THEN
IF corner(c%).x > p.x THEN
corner(c%).a0 = 180 - corner(c%).a0
ELSE
corner(c%).a0 = 180 + corner(c%).a0
END IF
ELSE
IF corner(c%).x < p.x THEN
corner(c%).a0 = 360 - corner(c%).a0
END IF
END IF
' IF corner(c%).x = p.x THEN
' corner(c%).a1 = 90
' ELSE
corner(c%).a1 = ABS(ATN((corner(c%).z - p.z) / SQR((corner(c%).x - p.x) ^ 2 + (corner(c%).y - p.y) ^ 2)) / (pi# / 180))
' END IF
IF corner(c%).z < p.z THEN corner(c%).a1 = 360 - corner(c%).a1
END SUB
SUB plot
FOR c% = 0 TO nc% - 1
IF corner(c%).px >= 0 AND corner(c%).px <= mx% AND corner(c%).py >= 0 AND corner(c%).py <= my% THEN PSET (corner(c%).px, corner(c%).py), 10
NEXT c%
FOR e% = 0 TO ne% - 1
IF corner(edge(e%).c0).px >= 0 AND corner(edge(e%).c0).px <= mx% AND corner(edge(e%).c0).py >= 0 AND corner(edge(e%).c0).py <= my% THEN
IF corner(edge(e%).c1).px >= 0 AND corner(edge(e%).c1).px <= mx% AND corner(edge(e%).c1).py >= 0 AND corner(edge(e%).c1).py <= my% THEN
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
ELSE
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
END IF
ELSE
LINE (corner(edge(e%).c0).px, corner(edge(e%).c0).py)-(corner(edge(e%).c1).px, corner(edge(e%).c1).py), e% + 1
END IF
NEXT e%
END SUB
Some of my old programs (Caclula2, Color, Intela, Intela2, Keyflags, Plot2, Qbasic)
February 23 2011, 3:29 AM
These are old programs. Some of them, like Color, Qbasic, and Intela, are probably some of my oldest surviving qbasic programs. Color borrowed the sparklepause procedure from the microsoft examples. Intela was one of my early interactive Qbasic programs. The music looks like it was borrowed form the microsoft examples (probably nibbles).
-------------- Calcula2
DECLARE FUNCTION p$ (in#)
DECLARE FUNCTION p2$ (in#)
COMMON transfer$
ON ERROR GOTO term:
pi = 3.141596254#
LOCATE 4, 1
PRINT " 7 8 9 +"
PRINT " 4 5 6 -"
PRINT " 1 2 3 *"
PRINT " 0 . = /"
PRINT " C CE M+ M-"
PRINT "CM RM SQR +/-"
PRINT "SIN COS TAN RCP"
PRINT "ABS INT ROU ^"
PRINT
PRINT "F1 = CE F2 = CM F3 = RM F4 = SQR F5 = +/- F6 = SIN F7 = COS F8 = TAN"
PRINT "F9 = RCP F10 = ABS F11 = INT F12 = ROU PgUp = M+ PgDn = M- ESC = Off"
PRINT "0-9,.,=,+,-,*,/,C,^ do what they represent."
DO
1
LOCATE 1, 1
IF m% = 1 THEN
PRINT "M"
ELSE
PRINT " "
END IF
LOCATE 1, 3
IF e% = 1 THEN
PRINT "E"
ELSE
PRINT " "
END IF
e% = 0
LOCATE 1, 6: PRINT last$; " "
LOCATE 2, 1: PRINT VAL(dis$); " "
a$ = UCASE$(INKEY$)
IF a$ = "1" OR a$ = "2" OR a$ = "3" OR a$ = "4" OR a$ = "5" OR a$ = "6" OR a$ = "7" OR a$ = "8" OR a$ = "9" OR a$ = "0" OR a$ = "." THEN
IF last$ <> "" AND c% = 0 THEN ent$ = "": c% = 1
IF last$ <> "+" AND last$ <> "-" AND last$ <> "ù" AND last$ <> "ö" THEN last$ = "": c% = 0
END IF
SELECT CASE a$
CASE CHR$(27): COLOR 7, 0: CLS
IF transfer$ <> "" THEN RUN transfer$
SYSTEM
CASE "0": ent$ = ent$ + "0": dis$ = ent$
CASE "1": ent$ = ent$ + "1": dis$ = ent$
CASE "2": ent$ = ent$ + "2": dis$ = ent$
CASE "3": ent$ = ent$ + "3": dis$ = ent$
CASE "4": ent$ = ent$ + "4": dis$ = ent$
CASE "5": ent$ = ent$ + "5": dis$ = ent$
CASE "6": ent$ = ent$ + "6": dis$ = ent$
CASE "7": ent$ = ent$ + "7": dis$ = ent$
CASE "8": ent$ = ent$ + "8": dis$ = ent$
CASE "9": ent$ = ent$ + "9": dis$ = ent$
CASE ".": ent$ = ent$ + ".": dis$ = ent$
CASE "+": GOSUB equ: back$ = total$: ent$ = "": last$ = "+": c% = 0
CASE "-": GOSUB equ: back$ = total$: ent$ = "": last$ = "-": c% = 0
CASE "*": GOSUB equ: back$ = total$: ent$ = "": last$ = "ù": c% = 0
CASE "/": GOSUB equ: back$ = total$: ent$ = "": last$ = "ö": c% = 0
CASE "^": GOSUB equ: back$ = total$: ent$ = "": last$ = "^": c% = 0
CASE "=": GOSUB equ
CASE "C": total$ = "": ent$ = "": dis$ = "": back$ = "": last$ = "": c% = 0
CASE CHR$(0) + CHR$(59): ent$ = "": dis$ = back$: last$ = "CE": c% = 0
CASE CHR$(0) + CHR$(60): mem$ = "": ent$ = "": m% = 0: last$ = "CM": c% = 0
CASE CHR$(0) + CHR$(61): dis$ = mem$: ent$ = "": back$ = "": last$ = "RM": c% = 0
CASE CHR$(0) + CHR$(62): GOSUB equ: ent$ = p$(SQR(VAL(total$))): last$ = "û": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(63): ent$ = p$(0 - VAL(ent$)): dis$ = ent$
CASE CHR$(0) + CHR$(64): GOSUB equ: ent$ = p2$(SIN(VAL(total$) * (pi / 180))): last$ = "SIN": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(65): GOSUB equ: ent$ = p2$(COS(VAL(total$) * (pi / 180))): last$ = "COS": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(66): GOSUB equ: ent$ = p2$(TAN(VAL(total$) * (pi / 180))): last$ = "TAN": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(67): GOSUB equ: ent$ = p$(1 / VAL(total$)): last$ = "RCP": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(68): GOSUB equ: ent$ = p$(ABS(VAL(total$))): last$ = "ABS": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(133): GOSUB equ: ent$ = p$(INT(VAL(total$))): last$ = "INT": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(134): GOSUB equ: ent$ = p$(INT(VAL(total$) + .5)): last$ = "ROU": c% = 0: dis$ = ent$
CASE CHR$(0) + CHR$(73): mem$ = p$(VAL(mem$) + VAL(ent$)): m% = 1: last$ = "M+": c% = 0
CASE CHR$(0) + CHR$(81): mem$ = p$(VAL(mem$) + VAL(ent$)): m% = 1: last$ = "M-": c% = 0
END SELECT
LOOP
equ:
SELECT CASE last$
CASE "+": last$ = "=": total$ = p$(VAL(back$) + VAL(ent$)): ent$ = total$: back$ = total$: dis$ = back$
CASE "-": last$ = "=": total$ = p$(VAL(back$) - VAL(ent$)): ent$ = total$: back$ = total$: dis$ = back$
CASE "ù": last$ = "=": total$ = p$(VAL(back$) * VAL(ent$)): ent$ = total$: back$ = total$: dis$ = back$
CASE "ö": last$ = "=": total$ = p$(VAL(back$) / VAL(ent$)): ent$ = total$: back$ = total$: dis$ = back$
CASE "^": last$ = "=": total$ = p$(VAL(back$) ^ VAL(ent$)): ent$ = total$: back$ = total$: dis$ = back$
CASE "=": last$ = "=": total$ = ent$: dis$ = total$
CASE ELSE: last$ = "=": total$ = ent$: dis$ = total$
END SELECT
c% = 0
RETURN
term:
IF ERR = 11 THEN last$ = "=": total$ = "": ent$ = "": back$ = total$: dis$ = back$: e% = 1: RESUME 1
CLS
PRINT "Error"; ERR; "at"; ERL
IF transfer$ <> "" THEN SLEEP: RUN transfer$
SYSTEM
FUNCTION p$ (in#)
p$ = LTRIM$(RTRIM$(STR$(in#)))
END FUNCTION
FUNCTION p2$ (in#)
in! = in#
p2$ = LTRIM$(RTRIM$(STR$(in!)))
END FUNCTION
--------------- Color
CLS
COLOR 7, 0
PRINT ""
BEEP
CLS
COLOR 0, 1
PRINT ""
BEEP
CLS
COLOR 0, 2
PRINT ""
BEEP
CLS
COLOR 0, 3
PRINT ""
BEEP
CLS
COLOR 0, 4
PRINT ""
BEEP
CLS
COLOR 0, 5
PRINT ""
BEEP
CLS
COLOR 0, 6
PRINT ""
BEEP
CLS
COLOR 0, 7
PRINT ""
BEEP
CLS
COLOR 0, 8
PRINT ""
BEEP
CLS
COLOR 0, 9
PRINT ""
BEEP
CLS
COLOR 0, 10
PRINT ""
BEEP
CLS
COLOR 0, 11
PRINT ""
BEEP
CLS
COLOR 0, 12
PRINT ""
BEEP
CLS
COLOR 0, 13
PRINT ""
BEEP
CLS
COLOR 0, 14
PRINT ""
BEEP
CLS
COLOR 0, 15
PRINT ""
BEEP
CLS
COLOR 7, 0
CLS
DEFINT A-Z
SUB SparklePause
'SparklePause:
' Creates flashing border for intro screen
WHILE INKEY$ = ""
FOR a = 1 TO 5
LOCATE 1, 1 'print horizontal sparkles
PRINT MID$(a$, a, 80);
LOCATE 22, 1
PRINT MID$(a$, 6 - a, 80);
FOR b = 2 TO 21 'Print Vertical sparkles
c = (a + b) MOD 5
IF c = 1 THEN
LOCATE b, 80
PRINT "*";
LOCATE 23 - b, 1
PRINT "*";
ELSE
LOCATE b, 80
PRINT " ";
LOCATE 23 - b, 1
PRINT " ";
END IF
NEXT b
NEXT a
WEND
END SUB
--------------- Intela
CLS
COLOR 7, 0
LOCATE 10, 20: INPUT "What is your name"; name$
CLS
1 LOCATE 10, 20: PRINT "Hello, "; name$; "!"
LOCATE 13, 20: PRINT "Type the letter of your choice, then press enter."
LOCATE 15, 10: PRINT "Your choices are:"
LOCATE 17, 20: PRINT " Play music ne time and quit "
LOCATE 18, 20: PRINT " Play music t o times and quit "
LOCATE 19, 20: PRINT " Play music t ree times and quit "
COLOR 15, 0
LOCATE 17, 32: PRINT "o"
LOCATE 18, 33: PRINT "w"
LOCATE 19, 33: PRINT "h"
COLOR 10, 0
LOCATE 17, 20: PRINT CHR$(17)
LOCATE 17, 49: PRINT CHR$(16)
LOCATE 18, 20: PRINT CHR$(17)
LOCATE 18, 50: PRINT CHR$(16)
LOCATE 19, 20: PRINT CHR$(17)
LOCATE 19, 52: PRINT CHR$(16)
COLOR 7, 0
LOCATE 11, 20: INPUT "What do you want to do"; What$
IF What$ = CHR$(111) THEN
GOTO 2
ELSE
IF What$ = CHR$(119) THEN
GOTO 3
ELSE
IF What$ = CHR$(104) THEN
GOTO 4
ELSE
IF What$ = CHR$(79) THEN
GOTO 2
ELSE
IF What$ = CHR$(87) THEN
GOTO 3
ELSE
IF What$ = CHR$(72) THEN
GOTO 4
ELSE
BEEP
CLS
GOTO 1
END IF
END IF
END IF
END IF
END IF
END IF
GOTO 6
2 PLAY "MBT160O1L8CDEDCDL4ECC"
GOTO 5
3 PLAY "MBT160O1L8CDEDCDL4ECC"
PLAY "MBT160O1L8CDEDCDL4ECC"
GOTO 5
4 PLAY "MBT160O1L8CDEDCDL4ECC"
PLAY "MBT160O1L8CDEDCDL4ECC"
PLAY "MBT160O1L8CDEDCDL4ECC"
5 CLS
LOCATE 15, 20: PRINT "Good-bye "; name$; "."
COLOR 31, 0
LOCATE 17, 20: PRINT "Press any key to continue."
COLOR 7, 0
DO
LOOP WHILE INKEY$ = ""
6 COLOR 7, 0
CLS
DEFINT A-Z
SUB A
BEEP
END SUB
SUB b
BEEP
BEEP
END SUB
SUB c
BEEP
BEEP
BEEP
END SUB
DEFSNG A-Z
SUB na
END SUB
DEFINT A-Z
SUB nb
END SUB
DEFSNG A-Z
SUB w (What$)
END SUB
SUB YName (name$)
END SUB
--------------- Intela2
CLS
COLOR 7, 0
LOCATE 10, 20: INPUT "What is your name"; name$
CLS
1 LOCATE 10, 20: PRINT "Hello, "; name$; "!"
LOCATE 13, 20: PRINT "Type the letter of your choice, then press enter."
LOCATE 15, 10: PRINT "Your choices are:"
LOCATE 17, 20: PRINT " Play music ne time and quit "
LOCATE 18, 20: PRINT " Play music t o times and quit "
LOCATE 19, 20: PRINT " Play music t ree times and quit "
COLOR 15, 0
LOCATE 17, 32: PRINT "o"
LOCATE 18, 33: PRINT "w"
LOCATE 19, 33: PRINT "h"
COLOR 10, 0
LOCATE 17, 20: PRINT CHR$(17)
LOCATE 17, 49: PRINT CHR$(16)
LOCATE 18, 20: PRINT CHR$(17)
LOCATE 18, 50: PRINT CHR$(16)
LOCATE 19, 20: PRINT CHR$(17)
LOCATE 19, 52: PRINT CHR$(16)
COLOR 7, 0
LOCATE 11, 20: INPUT "What do you want to do"; what$
what$ = UCASE$(what$)
IF what$ = "O" THEN t% = 1: GOTO 2
IF what$ = "W" THEN t% = 2: GOTO 2
IF what$ = "H" THEN t% = 3: GOTO 2
BEEP
GOTO 1
2 FOR i% = 1 TO t%
PLAY "MBT160O1L8CDEDCDL4ECC"
NEXT i%
CLS
LOCATE 15, 20: PRINT "Good-bye "; name$; "."
COLOR 31, 0
LOCATE 17, 20: PRINT "Press any key to continue."
SLEEP
COLOR 7, 0
CLS
SYSTEM
------------ Keyflags
DECLARE SUB h ()
DECLARE SUB s ()
DECLARE FUNCTION Exist% (fexis$)
DIM SHARED nexis%
DIM SHARED PKF
COLOR 7, 0
PRINT
PRINT "Thanks for using Mike's KeyFlag program."
DEF SEG = 0
PKF = PEEK(1047)
DEF SEG
IF Exist%("c:\keyflags.dat") = 0 THEN PRINT : SYSTEM
OPEN "c:\keyflags.dat" FOR INPUT AS 1
IF EOF(1) THEN PRINT "KeyFlags data file Corrupt."
LINE INPUT #1, par1$
IF EOF(1) THEN PRINT "KeyFlags data file Corrupt."
LINE INPUT #1, par2$
IF EOF(1) THEN PRINT "KeyFlags data file Corrupt."
LINE INPUT #1, par3$
IF EOF(1) THEN PRINT "KeyFlags data file Corrupt."
LINE INPUT #1, par4$
IF EOF(1) THEN PRINT "KeyFlags data file Corrupt."
LINE INPUT #1, par5$
CLOSE
KILL "c:\keyflags.dat"
par1$ = LEFT$(UCASE$(par1$), LEN(par1$) - 3)
par2$ = LEFT$(UCASE$(par2$), LEN(par2$) - 3)
par3$ = LEFT$(UCASE$(par3$), LEN(par3$) - 3)
par4$ = LEFT$(UCASE$(par4$), LEN(par4$) - 3)
par5$ = LEFT$(UCASE$(par5$), LEN(par5$) - 3)
ssd% = 0
hd% = 0
IF par1$ = "HELP" THEN h: hd% = hd% + 1
IF par2$ = "HELP" THEN h: hd% = hd% + 1
IF par3$ = "HELP" THEN h: hd% = hd% + 1
IF par4$ = "HELP" THEN h: hd% = hd% + 1
IF par5$ = "HELP" THEN h: hd% = hd% + 1
IF par1$ = "STATUS" THEN s: ssd% = ssd% + 1
IF par2$ = "STATUS" THEN s: ssd% = ssd% + 1
IF par3$ = "STATUS" THEN s: ssd% = ssd% + 1
IF par4$ = "STATUS" THEN s: ssd% = ssd% + 1
IF par5$ = "STATUS" THEN s: ssd% = ssd% + 1
nd% = 0
n% = 0
sd% = 0
ss% = 0
cd% = 0
c% = 0
KeyFlags = 0
IF par1$ = "NUMOFF" THEN n% = 0: nd% = nd% + 1
IF par2$ = "NUMOFF" THEN n% = 0: nd% = nd% + 1
IF par3$ = "NUMOFF" THEN n% = 0: nd% = nd% + 1
IF par4$ = "NUMOFF" THEN n% = 0: nd% = nd% + 1
IF par5$ = "NUMOFF" THEN n% = 0: nd% = nd% + 1
IF par1$ = "NUMON" THEN n% = 1: nd% = nd% + 1
IF par2$ = "NUMON" THEN n% = 1: nd% = nd% + 1
IF par3$ = "NUMON" THEN n% = 1: nd% = nd% + 1
IF par4$ = "NUMON" THEN n% = 1: nd% = nd% + 1
IF par5$ = "NUMON" THEN n% = 1: nd% = nd% + 1
IF par1$ = "CAPSOFF" THEN c% = 0: cd% = cd% + 1
IF par2$ = "CAPSOFF" THEN c% = 0: cd% = cd% + 1
IF par3$ = "CAPSOFF" THEN c% = 0: cd% = cd% + 1
IF par4$ = "CAPSOFF" THEN c% = 0: cd% = cd% + 1
IF par5$ = "CAPSOFF" THEN c% = 0: cd% = cd% + 1
IF par1$ = "CAPSON" THEN c% = 1: cd% = cd% + 1
IF par2$ = "CAPSON" THEN c% = 1: cd% = cd% + 1
IF par3$ = "CAPSON" THEN c% = 1: cd% = cd% + 1
IF par4$ = "CAPSON" THEN c% = 1: cd% = cd% + 1
IF par5$ = "CAPSON" THEN c% = 1: cd% = cd% + 1
IF par1$ = "SCROLLOFF" THEN ss% = 0: sd% = sd% + 1
IF par2$ = "SCROLLOFF" THEN ss% = 0: sd% = sd% + 1
IF par3$ = "SCROLLOFF" THEN ss% = 0: sd% = sd% + 1
IF par4$ = "SCROLLOFF" THEN ss% = 0: sd% = sd% + 1
IF par5$ = "SCROLLOFF" THEN ss% = 0: sd% = sd% + 1
IF par1$ = "SCROLLON" THEN ss% = 1: sd% = sd% + 1
IF par2$ = "SCROLLON" THEN ss% = 1: sd% = sd% + 1
IF par3$ = "SCROLLON" THEN ss% = 1: sd% = sd% + 1
IF par4$ = "SCROLLON" THEN ss% = 1: sd% = sd% + 1
IF par5$ = "SCROLLON" THEN ss% = 1: sd% = sd% + 1
IF hd% > 1 OR ssd% > 1 OR cd% > 1 OR sd% > 1 OR nd% > 1 THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF par1$ <> "NUMOFF" AND par1$ <> "NUMON" AND par1$ <> "CAPSOFF" AND par1$ <> "CAPSON" AND par1$ <> "SCROLLOFF" AND par1$ <> "SCROLLON" AND par1$ <> "HELP" AND par1$ <> "STATUS" AND par1$ <> "" THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF par2$ <> "NUMOFF" AND par2$ <> "NUMON" AND par1$ <> "CAPSOFF" AND par2$ <> "CAPSON" AND par2$ <> "SCROLLOFF" AND par2$ <> "SCROLLON" AND par2$ <> "HELP" AND par2$ <> "STATUS" AND par2$ <> "" THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF par3$ <> "NUMOFF" AND par3$ <> "NUMON" AND par1$ <> "CAPSOFF" AND par3$ <> "CAPSON" AND par3$ <> "SCROLLOFF" AND par3$ <> "SCROLLON" AND par3$ <> "HELP" AND par3$ <> "STATUS" AND par3$ <> "" THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF par4$ <> "NUMOFF" AND par4$ <> "NUMON" AND par1$ <> "CAPSOFF" AND par4$ <> "CAPSON" AND par4$ <> "SCROLLOFF" AND par4$ <> "SCROLLON" AND par4$ <> "HELP" AND par4$ <> "STATUS" AND par4$ <> "" THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF par5$ <> "NUMOFF" AND par5$ <> "NUMON" AND par1$ <> "CAPSOFF" AND par5$ <> "CAPSON" AND par5$ <> "SCROLLOFF" AND par5$ <> "SCROLLON" AND par5$ <> "HELP" AND par5$ <> "STATUS" AND par5$ <> "" THEN PRINT "Invalid parameters.": PRINT : SYSTEM
IF cd% = 1 THEN
IF c% = 1 THEN KeyFlags = KeyFlags + 64
ELSE
IF PKF = 64 OR PKF = 80 OR PKF = 96 OR PKF = 112 THEN KeyFlags = KeyFlags + 64
END IF
IF nd% = 1 THEN
IF n% = 1 THEN KeyFlags = KeyFlags + 32
ELSE
IF PKF = 32 OR PKF = 48 OR PKF = 96 OR PKF = 112 THEN KeyFlags = KeyFlags + 32
END IF
IF sd% = 1 THEN
IF ss% = 1 THEN KeyFlags = KeyFlags + 16
ELSE
IF PKF = 16 OR PKF = 48 OR PKF = 80 OR PKF = 112 THEN KeyFlags = KeyFlags + 16
END IF
DEF SEG = 0
POKE 1047, KeyFlags
DEF SEG
PRINT : SYSTEM
exis:
nexis% = 0
RESUME NEXT
term:
PRINT "Error"; ERR; "at"; ERL
PRINT : SYSTEM
FUNCTION Exist% (fexis$)
'-----MODIFIED-----
nexis% = 1
ON ERROR GOTO exis
OPEN fexis$ FOR INPUT AS #1
ON ERROR GOTO term
IF nexis% = 1 THEN CLOSE
Exist% = nexis%
END FUNCTION
SUB h
PRINT "Help for KeyFlags:"
PRINT
PRINT "KEYFLAGS [HELP] [STATUS] [NUM{ON|OFF}] [CAPS{ON|OFF}] [SCROLL{ON|OFF}]"
PRINT
PRINT "HELP - displays this help screen."
PRINT "STATUS - displays current KeyFlag status."
PRINT "NUM, CAPS, SCROLL - depending on wheter they or followed by ON or OFF, turn"
PRINT " on and off the KeyFlags."
PRINT
PRINT " * KEYFLAGS can include path and full file name."
PRINT " * HELP, STATUS, NUM, CAPS, and SCROLL can come in any order."
PRINT " * If any error with this program persists contact Michael Calkins at"
PRINT " 826 State Hwy 97E, Floresville, TX 78114, or call (830) 393-4866."
PRINT "Press any key."
SLEEP
WHILE INKEY$ <> "": WEND
PRINT
END SUB
SUB s
IF PKF = 64 OR PKF = 80 OR PKF = 96 OR PKF = 112 THEN sc% = 1
IF PKF = 32 OR PKF = 48 OR PKF = 96 OR PKF = 112 THEN sn% = 1
IF PKF = 16 OR PKF = 48 OR PKF = 80 OR PKF = 112 THEN ss% = 1
PRINT "Current status: ";
IF sn% = 1 THEN PRINT "NumOn ";
IF sn% = 0 THEN PRINT "NumOff ";
IF sc% = 1 THEN PRINT "CapsOn ";
IF sc% = 0 THEN PRINT "CapsOff ";
IF ss% = 1 THEN PRINT "ScrollOn";
IF ss% = 0 THEN PRINT "ScrollOff";
PRINT
END SUB
--------------- Plot2
RANDOMIZE TIMER
x% = INT(RND * 40) - 20
y% = INT(RND * 40) - 20
PRINT "X"; x%; "Y"; y%
PRINT "Y = A * abs_val(X)"
INPUT "A"; a#
SCREEN 1
LINE (1, 100)-(200, 100)
LINE (100, 1)-(100, 200)
LINE (x# - 1, y#)-(x# + 1, y#), 3
LINE (y# - 1, x#)-(y# + 1, x#), 3
FOR dx# = -19 TO 19 STEP .1
dy# = a# * ABS(x#)
PSET ((dx# + 20) * 5, (dy# + 20) * 5), 2
NEXT dx#
--------------- Qbasic
CLS
PRINT "By Michael Calkins"
BEEP
COLOR 9, 7
PRINT "Q B A S I C"
BEEP
CLS
PRINT ""
PRINT "Q B A S I C"
BEEP
BEEP
BEEP
CLS
BEEP
COLOR 7, 9
PRINT ""
PRINT "Internal Speaker"
BEEP
BEEP
BEEP
BEEP
CLS
BEEP
COLOR 4, 8
PRINT ""
PRINT "WOW!!"
BEEP
BEEP
BEEP
BEEP
CLS
BEEP
COLOR 7, 0
' Colors:
' 0=Black (Default Background)
' 1=Blue
' 2=Green
' 3=Light Light Blue
' 4=Red
' 5=Purple
' 6=Orange
' 7=Light Gray (Default Text)
' 8=Gray
' 9=Light Blue
' 10=Light Green
' 11=Light Light Light Blue
' 12=Pink/Light Red
' 13=Light Puple
' 14=Yellow
' 15=White
' 16=Black *
' 17=Blue *
' 18=Green *
' 19=Light Light Blue *
' 20=Red *
' 21=Purple *
' 22=Orange *
' 23=Light Gray (Default Text) *
' 24=Gray *
' 25=Light Blue *
' 26=Light Green *
' 27=Light Light Light Blue *
' 28=Pink/Light Red *
' 29=Light Puple *
' 30=Yellow *
' 31=White *
' (* Flashing)
This message has been edited by MCalkins on Feb 23, 2011 3:33 AM This message has been edited by MCalkins on Feb 23, 2011 3:32 AM
It has long been a goal of mine to write a compiler. I have tried several times, and am trying again now.
SBC originated a few years ago (early 2008). I believe I commented about it on the forums at the time. Its goal was to be highly compatible (although not completely) with QBASIC. It would have targeted real mode DOS. It stalled out when I couldn't decide/figure out how to handle error handling and automatic string management.
The included qbasic files were to test qbasic behavior.
That code is abandoned, and I don't see myself restarting that project anytime soon. QB64, from the way people are using it, seems to now fill the need for QBASIC compatibility.
As I said, I am again trying to write a compiler, although with very different design goals. I intend to not fail this time. I'll post more about it later. Here is the old stuff:
-------------- base.asm
;base
;this file provides the base of all programs. It contains the entry point,
;initializes the stack, and contains the exit point. It also contains the
;default runtime error handling code.
;this file should be included in all programs.
cpu 386
bits 16
segment code
..start:
mov ax,stack
mov ss,ax
mov sp,stacktop
mov ax,data
;mov ds,ax
mov fs,ax
;mov gs,ax
cld ;direction flag should be clear
; other init stuff here
call far basicentry
jmp far system
system:
xor al,al
jmp far killmenow
hexbyte: ;proc near
;converts byte into 2 char ascii hex result
;call with: DL=value, DS:BX=location to write result + 1
;returns: BX=old BX - 2, DL=0
push ax
push cx
mov cx,0x2
.loop:
mov al,dl
and al,0xf
cmp al,0xa
jb .skip
add al,0x27
.skip:
add al,0x30
mov [bx],al
dec bx
shr dl,4
loop .loop
pop cx
pop ax
retn
hexword: ;proc near
;converts word into 4 char ascii hex result
;call with: DX=value, DS:BX=location to write result + 3
;returns: BX=old BX - 4, DX=0
call hexbyte
xchg dl,dh
call hexbyte
retn
clsparem: proc far
;CLS with parameter
;call with: PUSH word value corresponing to BASIC CLS paremeter
;if success: returns nothing
;if failure: bails 'illegal function call'
;parameter is left on the stack
push bp
mov bp,sp
mov ax,[bp+0x6]
test ah,ah
jnz .error
cmp al,2
jz .textview
ja .error
cmp al,1
jz .gfxview
;clsall
pop bp
retf
.textview
call clstextview
pop bp
retf
.gfxview
;call far clsgfxview
pop bp
retf
.error
mov byte [fs:errorcode],0x5
jmp far bail
clstextview: ;proc near
retn
segment data
textlin: db 0x0 ;cursor position
textcol: db 0x0
textwidth: db 0x0 ;WIDTH
textheight: db 0x0
textviewtop: db 0x0 ;text viewport
textviewbottom: db 0x0
screenmode: db 0x0 ;SCREEN
activepage: db 0x0
visualpage: db 0x0
gfxviewhasbeenset: db 0x0 ;for CLS with no arguments
------------- string.asm
;string
;this file provides support for variable length strings, including storage,
;allocation, and deallocation. it also provides several basic string
;functions.
;this file should be included in any program that uses variable length
;strings or string manipulation.
;this file has the following environment limits:
minstringadd equ 0x4000
maxstringadd equ 0xfff0
maxstringspc equ 0xbff4 ;4 extra bytes for safety, may not be needed
segment code
createstring: ;proc far
;creates a variable len string descriptor
;call with: nothing
;if failure: bails 'out of string space'
;if success: DS:BX = pointer to descriptor
;new string will have length 0 and probably unusable address of 0x8000
push ax
push dx
mov dx,string
mov ds,dx
xor bx,bx
.loop:
mov ax,[bx+0x2]
test ax,ax
jz .found
add bx,0x4
cmp bx,minstringadd
jb .loop
mov byte [fs:errorcode],0xe
jmp far bail
.found:
mov [bx],ax ;ax is still 0
mov word [bx+0x2],minstringadd
pop dx
pop ax
retf
destroystring: ;proc far
;destroys a variable len string descriptor
;call with: BX=offset to descriptor
;returns nothing
push dx
push si
mov dx,string
mov ds,dx
mov word [bx+0x2],0x0
mov si,[fs:higheststring]
cmp bx,si
jne .out
xor si,si ;find new higheststring
xor dx,dx
.loop:
mov ax,[si+0x2]
cmp ax,dx
jbe .skip
mov dx,ax
mov bx,si
.skip:
add si,0x4
cmp si,minstringadd
jb .loop
mov [fs:higheststring],bx
.out:
pop si
pop dx
retf
compactstrings: ;proc near
;compacts all variable len strings
;call with: nothing
;returns: nothing
;if failure: might cause infinite loop? i'm tired... not sure.
pusha
mov dx,string
mov ds,dx
mov es,dx
mov bx,[fs:higheststring]
mov ax,[bx+0x2] ;should work even if bx+0x2 is null
mov di,minstringadd
mov dx,di
.loopd: ;loop through possible addresses
;even if dx=di, we want to procede just to update di
xor bx,bx
.loopb: ;loop through all descriptors
mov si,[bx+0x2]
cmp si,dx
jne .nextb
mov cx,[bx]
test cx,cx
jz .nextb
;found one to move
mov [fs:higheststring],bx ;might or might not be needed
.moveloop:
movsb
loop .moveloop
;di is up to date
mov dx,di
xor bx,bx
jmp short .loopb ;reset bx loop
.nextb:
add bx,0x4
cmp bx,minstringadd
jb .loopb
.nexta:
inc dx
cmp dx,ax ;what if ax=0xffff? will cause infinite loop?
jbe .loopd
popa
retn
enlargestring: ;proc far
;if a string is shorter than the new length, enlarges it
;call with: BX=offset to descriptor; AX=new length
;if failure: bails 'out of string space' or 'overflow'
;if success: DS:DI=pointer to string + old length
;string is guarenteed to be highest address
push cx
push dx
push si
cmp ax,0x7fff
jbe .skipoverflow
mov byte [fs:errorcode],0x6
jmp far bail
.skipoverflow:
mov dx,string
mov ds,dx
mov es,dx
call .double
cmp ax,maxstringadd
jnb .compact
cmp dx,minstringadd
jb .compact
.backagain:
mov [fs:higheststring],bx ;we will now be higheststring
mov si,[bx+0x2]
mov cx,[bx]
mov [bx],ax
mov [bx+0x2],di
test cx,cx
jz .skip
.loop:
movsb
loop .loop
.skip:
pop si
pop dx
pop cx
retf
.compact:
call compactstrings
call .double
cmp ax,maxstringadd
jnb .error
cmp dx,minstringadd
jnb .backagain
.error:
mov byte [fs:errorcode],0xe
jmp far bail
.double: ;local proc near
mov si,[fs:higheststring]
mov dx,[si+0x2]
add dx,[si]
mov di,dx ;start of new string
add dx,ax
retn
setstringlen: ;proc far
;sets new len of string. If larger, enlarges. If shorter, truncates.
;call with BX=offset to descriptor, AX=new len
push dx
mov dx,string
mov ds,dx
cmp [bx],ax
je .skip
jb .shrink
call far enlargestring
jmp short .skip
.shrink:
mov [bx],ax
.skip:
pop dx
retf
lenstr: ;proc far
;returns the len of a variable len string
;call with: BX=offset to descriptor
;returns: AX=length
push dx
mov dx,string
mov ds,dx
mov ax,[bx]
pop dx
retf
;parameter passing may need to be rethought
hex: ;proc far
;performs HEX$() on an LONG, ULONG, INTEGER, UINTEGER
;(INTEGER and UINTEGER) call with:
;PUSH word 0x0, PUSH word value, PUSH offset to descriptor. (6 bytes total)
;(LONG and ULONG) call with:
;PUSH dword value, PUSH offset to descriptor. (6 bytes total)
;returns: var len string (in the passed descriptor)
;parameters are left on the stack
enter 0x8,0 ;16/32 point
pusha
push edx ;16/32 point
mov bx,[bp+0x6]
mov edx,[bp+0x8] ;16/32 point
xor cx,cx
xor si,si
.loop:
inc cx
dec si
mov al,dl
and al,0xf
cmp al,0xa
jb .skip
add al,0x7
.skip:
add al,0x30
mov [bp+si],al
shr edx,4 ;16/32 point
test edx,edx ;16/32 point
jnz .loop
mov ax,cx
call far setstringlen
mov di,[bx+0x2]
.moveloop:
mov al,[bp+si]
mov [di],al
inc di
inc si
loop .moveloop
pop edx ;16/32 point
popa
leave
retf ;'call with' stuff still on stack
segment data
higheststring: dw 0x0000 ;offset to descriptor of string with highest address
segment string
times minstringadd db 0x0
resb maxstringspc
while the string environment limits seem at first glance to be about the same
as QBASIC's, be careful. This compiler will not necessarily handle things the
same way as QBASIC or QB. Especially, this compiler might rely on temporary
strings more heavily, so might have effectively lower limits than QBASIC.
fixed length arrays may not exceed 64K in size. the array's lowerbound will be
at offset 0 from its segment.
string arrays seem to be arrays of descriptors, and do not have to start at
offset 0
-----
rules:
direction flag will be clear
procs may destroy ds and es
fs will point to data
string descriptors with a string address of 0 are unused, and may have any
length. string descriptors with a non-zero string address are used, even if
length is 0. used string descriptors with a length of 0 may have any
non-zero string address. used string descriptors with any non-zero length must
have a valid string address.
do not pass an invalid or incorrect string descriptor to a procedure that
expects a valid string descriptor. doing so can cause catastropic string
corruption.
functions that need to return a variable len string will usually be given a
string descriptor, even if a temporary one. The CALLEE will be resposible
for ensuring that the var len string is big enough.
functions that need to return a fixed len string (or preknown) will be passed
a FAR pointer to the buffer. If the buffer is a var len string, it should be
large enough to prevent buffer overflow. The CALLER is responsible for this.
Future options:
If necessary, I may arrange for var len strings to be stored in more than one
segment. possibly, each module could have its own string segment. If this is
done, several changes will need to be made. For example, procedures that work
with string descriptors will need to know which segment the descriptor is in.
I may convert the string segment(s) to segments allocated at runtime. This
would allow for them to be deallocated to allow SHELL to have more
conventional memory. Their contents would be transfered to extended memory for
this. After the SHELL, space would be reallocated, and the contents transfered
back.
project history:
I have been thinking about the project for some time.
project began on Saturday 01-05-2008.
from 01-05-2008 to about 01-08-2008:
I have begun the base.asm, string.asm, and scr.asm files.
base.asm contains elementary initiallization and termination code. It also
contains a very primitive error handler that prints an error message.
string.asm contains several completely untested functions to create, destroy,
resize, and compact strings. Also, an untested HEX$() function.
I have tested base.asm with a custom written test.asm.
03-20-2008:
created backup to folder 032008
decided to keep things really simple. not going to worry about event trapping,
including error trapping. keep it simple, stupid.
--------------- qbasic.txt
ABS Function
for integers: should be very easy to implement
for fp: don't know yet
see SGN
APPEND Keyword
part of file i/o
ABSOLUTE Keyword
should be easy to implement because of platform choice.
this is the main reason for targeting 16 bit mode
will take more research
AS Keyword
ACCESS Keyword
file i/o. will use DOS functions, possibly network function or IOCTL
ASC Function
super easy
AND Operator
for integers, easy
for fp, requires conversion
for get/put, part of gfx
Boolean
ATN Function
trig. no clue how to implement. might leave
ANY Keyword
no clue. probably leave for someone else
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ B º
ÈÍÍͼ
BASE Keyword
option base: part of array support
BLOAD Statement
will take research. requires file i/o
Basic Character Set
Boolean Operators
easy
BEEP Statement
not sure yet
BSAVE Statement
see bload
BINARY Keyword
part of file i/o. shouldn't be hard
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ C º
ÈÍÍͼ
CALL Statement
part of procedure support
COLOR Statement
depends on screen mode. should be easy
CALL ABSOLUTE Statement
see absolute
COM Statement
will take work. might leave for someone else
CASE Keyword
select case. easy
COMMON Statement
part of multi-module support. not sure yet
CDBL Function
fp support
CONST Statement
should be easy
CHAIN Statement
in a compiled program?? not sure
COS Function
trig. not easy
CHDIR
file system, will use DOS functions
CSNG Function
fp support
CHR$ Function
easy. already coded
CSRLIN Function
screen text support. should be easy
CINT Function
numeric conversion
CVD Function
fp support
CIRCLE Statement
gfx
CVDMBF Function
compatibility fp
CLEAR Statement
no clue. may leave for others
CVI Function
super easy
CLNG Function
numeric conversion
CVL Function
super easy
CLOSE Statement
file i/o
CVS Function
fp
CLS Statement
text screen and gfx. partially stubbed
CVSMBF Function
compat fp
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ D º
ÈÍÍͼ
DATA Statement
will take research, but shouldn't be a problem
DEFLNG Statement
easy
Data Type Keywords
not sure yet how strongly typing will be enforced. Probably imitate C style
DEFSNG Statement
easy
DATE$ Function
not sure
DEFSTR Statement
easy
DATE$ Statement
not sure
DIM Statement
easy
DECLARE Statement
procedure support
DO...LOOP Statement
easy
DEF FN Statement
archaic. it can wait
DOUBLE Keyword
fp
DEF SEG Statement
easy because of platform choice
DRAW Statement
gfx. menno will want it, but I don't use it
DEFDBL Statement
easy
$DYNAMIC Metacommand
array support. not sure yet
DEFINT Statement
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ E º
ÈÍÍͼ
ELSE Keyword
mostly easy. will take some research
ERDEV Function
will take research
ELSEIF Keyword
will take research
ERDEV$ Function
will take research
END Statement
easy
ERL Function
error handling. will partially implement
ENVIRON Statement
DOS environment. shouldn't be much problem
ERR Function
error handling. will partially implement
ENVIRON$ Function
DOS environment.
ERROR Statement
easy
EOF Function
file i/o. will take research
EXIT Statement
easy
EQV Operator
Boolean. easy
EXP Function
math. might leave for others
ERASE Statement
see clear. might leave for others.
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ F º
ÈÍÍͼ
FIELD Statement
archaic. it can wait
FOR...NEXT Statement
quirks will take some research
FILEATTR Function
file i/o or file system. will use DOS
FRE Function
strings: easy
array: don't know yet
other: not sure
FILES Statement
who uses it? will leave for others to implement, but might provide better
alternative. (native language file system search using DOS)
FREEFILE Function
file i/o
FIX Function
numeric conversion
FUNCTION Statement
procedure. easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ G º
ÈÍÍͼ
GET (File I/O) Statement
file i/o
GOSUB Statement
easy
GET (Graphics) Statement
gfx. easy in screen 13
GOTO Statement
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ H º
ÈÍÍͼ
HEX$ Function
already coded
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ I º
ÈÍÍͼ
IF...THEN...ELSE Statement
will take research
INSTR Function
easy
IMP Operator
easy
INT Function
numeric conversion
INKEY$ Function
easy
INTEGER Keyword
easy
INP Function
easy
IOCTL Statement
will take research
INPUT Statement
not sure
IOCTL$ Function
will take research
INPUT$ Function
will take research
IS Keyword
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ K º
ÈÍÍͼ
KEY (Assignment) Statement
not sure
KILL Statement
DOS file system
KEY (Event Trapping) Statement
not sure
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ L º
ÈÍÍͼ
LBOUND Function
array support
LOCK...UNLOCK Statements
DOS network file system?
LCASE$ Function
easy
LOF Function
file i/o
LEFT$ Function
easy
LOG Function
math. can leave for others
LEN Function
already coded
LONG Keyword
easy
LET Statement
easy
LOOP Keyword
easy
LINE (Graphics) Statement
gfx
LPOS Function
will take research
LINE INPUT Statement
research. shouldn't be a huge problem
LPRINT Statement
printer i/o
LIST Keyword
not sure
LPRINT USING Statement
will leave for others, probably
LOC Function
file i/o
LSET Statement
archaic
LOCATE Statement
text screen, easy
LTRIM$ Function
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ M º
ÈÍÍͼ
MID$ Function
easy
MKI$ Function
super easy
MID$ Statement
easy, but will take research
MKL$ Function
super easy
MKD$ Function
fp
MKS$ Function
fp
MKDIR Statement
dos file system
MKSMBF$ Function
archaic fp
MKDMBF$ Function
archaic fp
MOD Operator
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ N º
ÈÍÍͼ
NAME Statement
dos fs
NOT Operator
easy
NEXT Keyword
see for
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ O º
ÈÍÍͼ
OCT$ Function
easy
ON TIMER Statement
not sure
OFF Keyword
ON...GOSUB Statement
not sure
ON COM Statement
not sure
ON...GOTO Statement
not sure
ON ERROR Statement
will partially implement
OPEN Statement
file i/o. will use DOS
ON Keyword
OPEN COM Statement
will take research. might leave for others
PCOPY Statement
text screen and gfx
easy in screen 0.
POS Function
easy
PEEK Function
easy
PRESET Statement
gfx
PEN Function
not sure
PRINT Statement
screen text. easy
PEN Statement
not sure
PRINT USING Statement
might leave for others
PLAY Function
will take research
PSET Statement
gfx
PLAY (Music) Statement
will take research, but will be worth it
PUT (File I/O) Statement
file i/o
PLAY (Event Trapping) Statements
not sure
PUT (Graphics) Statement
gfx
PMAP Function
gfx
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ R º
ÈÍÍͼ
RANDOM Keyword
file i/o
RETURN Statement
easy
RANDOMIZE Statement
no clue
RIGHT$ Function
easy
READ Statement
not sure
RMDIR Statement
fs
REDIM Statement
array
RND Function
not sure
REM Statement
easy
RSET Statement
archaic
RESET Statement
file i/o
RTRIM$ Function
easy
RESTORE Statement
not sure
RUN Statement
no clue
RESUME Statement
error
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ S º
ÈÍÍͼ
SCREEN Function
text screen. easy
SQR Function
math
SCREEN Statement
gfx
STATIC Statement
procedure, easy
SEEK Function
file i/o
$STATIC Metacommand
array
SEEK Statement
file
STEP Keyword
gfx
SELECT CASE Statement
easy
STICK Function
not sure
SGN Function
math
STOP Statement
will terminate program
SHARED Statement
easy
STR$ Function
easy
SHELL Statement
will use DOS exec
STRIG Function
not sure
SIN Function
math, trig
STRIG Statements
mot sure
SINGLE Keyword
fp
STRING Keyword
easy
SLEEP Statement
not sure
STRING$ Function
easy
SOUND Statement
not sure
SUB Statement
procedure, easy
SPACE$ Function
easy
SWAP Statement
should be easy
SPC Function
not sure
SYSTEM Statement
easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ T º
ÈÍÍͼ
TAB Function
not sure
TIMER Statements
not sure
TAN Function
math, trig
TO Keyword
THEN Keyword
TROFF Statement
huh? not in a compiled program
TIME$ Function
not sure
TRON Statement
no
TIME$ Statement
not sure
TYPE Statement
easy
TIMER Function
not sure
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ U º
ÈÍÍͼ
UBOUND Function
array
UNTIL Keyword
easy
UCASE$ Function
easy
USING Keyword
might leave for someone else
UNLOCK Statement
DOS network fs?
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ V º
ÈÍÍͼ
VAL Function
will take research
VARSEG Function
easy
VARPTR Function
easy
VIEW Statement
gfx, not sure
VARPTR$ Function
archaic compatibility. might not implement
VIEW PRINT Statement
text screen, easy
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ W º
ÈÍÍͼ
WAIT Statement
not sure
WIDTH Statements
in screen 0: easy
WEND Keyword
easy
WINDOW Statement
gfx
WHILE...WEND Statement
easy
WRITE Statement
not sure
ÉÍÍÍ»
ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹ X º
ÈÍÍͼ
XOR Operator
easy
------------ clstext.bas
DEFINT A-Z
CLS
PRINT "QBASIC behavior:"
PRINT "CLS with no paremeter clears 25th line even if not in text viewport"
PRINT "CLS 2 does not unless its in text viewport"
PRINT "since QB64 demo #4 doesn't support SLEEP, INPUT is used."
INPUT t$
CLS
FOR i = 1 TO 25
LOCATE i, 1: PRINT i;
NEXT
VIEW PRINT 10 TO 11
CLS 2
LOCATE 11, 10: PRINT "text viewport";
LOCATE 10, 10: INPUT t$
CLS
LOCATE 10, 1: INPUT t$
------------ div0.bas
DEFINT A-Z
DECLARE FUNCTION f% (t AS STRING)
DIM SHARED count
CLS
'order of execution of functions
PRINT f("a") + f("b") - (f("c") + f("d")) + f("e") ^ f("f") + f("g"), f("h")
FUNCTION f (t AS STRING)
PRINT t; count
count = count + 1
f = 0
END FUNCTION
-------------- err.bas
DEFINT A-Z
DECLARE FUNCTION inc% (b%)
ON ERROR GOTO 1
CLS
b = 0
a = 0
'execution of functions in an error generating statement
'order of execution (not the same as order of operations)
a = a + 1: PRINT inc(b) + a / 0: a = a - 100
'a = a + 1: PRINT a / 0 + inc(b): a = a - 100
1
PRINT a, b
RESUME
FUNCTION inc (b)
b = b + 1
inc = 0
END FUNCTION
-----------
DEFINT A-Z
DECLARE FUNCTION f% (t AS STRING)
DIM SHARED count
CLS
'order of execution of functions
PRINT f("a") + f("b") - (f("c") + f("d")) + f("e") ^ f("f") + f("g"), f("h")
FUNCTION f (t AS STRING)
PRINT t; count
count = count + 1
f = 0
END FUNCTION
-------------- ord2.bas
DEFINT A-Z
DECLARE FUNCTION f% (t AS STRING)
DECLARE FUNCTION sf% (n AS INTEGER)
DIM SHARED count
CLS
'order of execution of functions
PRINT f("a") + f("b") + f("c") + sf(f("d") + f("e")) + f("f") + f("g")
FUNCTION f (t AS STRING)
PRINT t; count
count = count + 1
f = 0
END FUNCTION
FUNCTION sf (n AS INTEGER)
PRINT "hello"
sf = 0
END FUNCTION