DECLARE SUB INTERRUPTQB (intnum AS INTEGER, InReg AS ANY, OutReg AS ANY)
DECLARE FUNCTION NUMOFNEIGHBORS% (a%(), I%, J%)
DECLARE SUB ASSIGNLOGARRAY (a%(), B%())
DECLARE SUB DISPLAYARRAY (B%(), GEN%, DONEXTGEN%)
DECLARE SUB DETBIRTHORDEATH (AIJ%, N%, B%(), I%, J%)
DEFINT A-Z
DECLARE SUB GETINITCONFIG (a())
TYPE RegType
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
BP AS INTEGER
SI AS INTEGER
DI AS INTEGER
FLAGS AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
DIM SHARED REGS AS RegType
CONST ROWS = 50
CONST COLS = 80
CONST CELLS = ROWS * COLS
CONST GENS = 100
DIM a(ROWS, COLS), B(ROWS, COLS)
WIDTH 80, 50
'Instructions
'============
'
'1) Run the program below to see a display. Cancel out
'
'2) Fix the numbers given and number of lines as required to make your program do something. To do that,
' In sub GETINITCONFIG after CLS, find a block of instructions like this
' LOCATE 15, 33: PRINT "A"
' LOCATE 12, 18: PRINT "B"
' LOCATE 7, 47: PRINT "C"
' LOCATE 1, 46: PRINT "D"
' LOCATE 17, 43: PRINT "E"
' LOCATE 1, 25: PRINT "F"
' LOCATE 18, 48: PRINT "G"
' LOCATE 8, 58: PRINT "H"
' LOCATE 18, 4: PRINT "I"
' LOCATE 19, 22: PRINT "J"
'
'3) Tell the user how to EXC (just hit "x" in top-right of DOS Window?)'
'
'4) Now you can make it run. Give instructions to user by including something like this at the top
'
PRINT "***********"
PRINT "Instructions"
PRINT "============"
PRINT "1) Start program. Click to replace letters with asterisks"
PRINT "2) On the last letter, use right-click"
PRINT "3) Wait about x minutes. You should see this:"
PRINT SPACE$(10); "* * *"
PRINT SPACE$(10); " * "
PRINT SPACE$(10); " *"
' qbguy: fix this so that it shows what the user should see
PRINT "4) When satisfied with the demo, go to SUB GETINITCONFIG and remove block of code that looks like this:"
PRINT " LOCATE 15, 33: PRINT chr$(34);Achr$(34)"
PRINT " LOCATE 12, 18: PRINT chr$(34);Bchr$(34)"
PRINT " LOCATE 7, 47: PRINT chr$(34)C;chr$(34)"
PRINT " etc."
LINE INPUT "Press Enter to get started"; e$: CLS
CALL GETINITCONFIG(a())
CALL ASSIGNLOGARRAY(a(), B())
CALL DISPLAYARRAY(a(), GEN, DONEXTGEN)
GEN = GEN + 1
DO WHILE GEN <= GENS AND DONEXTGEN
FOR J = 2 TO COLS - 1
FOR I = 2 TO ROWS - 1
N = NUMOFNEIGHBORS(a(), I, J)
CALL DETBIRTHORDEATH(a(I, J), N, B(), I, J)
NEXT
NEXT
CALL DISPLAYARRAY(B(), GEN, DONEXTGEN)
CALL ASSIGNLOGARRAY(B(), a())
GEN = GEN + 1
LOOP
' Given two arrays, assign all cells of a to b
SUB ASSIGNLOGARRAY (a(), B())
FOR J = 1 TO COLS
FOR I = 1 TO ROWS
B(I, J) = a(I, J)
NEXT
NEXT
END SUB
SUB DETBIRTHORDEATH (AIJ, N, B(), I, J)
IF NOT AIJ AND N = 3 THEN
B(I, J) = -1
ELSEIF AIJ AND (N < 2 OR N > 3) THEN
B(I, J) = 0
END IF
END SUB
' Display all cells in array
SUB DISPLAYARRAY (B(), GEN, DONEXTGEN)
DIM T AS SINGLE
CLS
FOR I = 1 TO ROWS
FOR J = 1 TO COLS
IF B(I, J) THEN PRINT "*"; ELSE PRINT " ";
NEXT
NEXT
T = TIMER
DO WHILE T > TIMER - .2
KEY$ = INKEY$
REGS.AX = 3
CALL INTERRUPTQB(&H33, REGS, REGS)
IF REGS.BX <> 0 OR KEY$ <> "" THEN EXIT DO
LOOP
IF KEY$ = CHR$(27) THEN END
DONEXTGEN = -1
END SUB
' Get initial configuration
SUB GETINITCONFIG (a())
DIM T AS SINGLE
REGS.AX = 0
CLS
LOCATE 15, 33: PRINT "A"
LOCATE 12, 18: PRINT "B"
LOCATE 7, 47: PRINT "C"
LOCATE 1, 46: PRINT "D"
LOCATE 17, 43: PRINT "E"
LOCATE 1, 25: PRINT "F"
LOCATE 18, 48: PRINT "G"
LOCATE 8, 58: PRINT "H"
LOCATE 18, 4: PRINT "I"
LOCATE 19, 22: PRINT "J"
CALL INTERRUPTQB(&H33, REGS, REGS) 'Initialize mouse driver
REGS.AX = 1
CALL INTERRUPTQB(&H33, REGS, REGS) 'Show cursor
DO
REGS.AX = 3
CALL INTERRUPTQB(&H33, REGS, REGS)
IF REGS.BX = 1 THEN
ROW = REGS.DX \ 8 + 1
COL = REGS.CX \ 8 + 1
a(ROW, COL) = NOT a(ROW, COL)
REGS.AX = 2
CALL INTERRUPTQB(&H33, REGS, REGS)
LOCATE ROW, COL
IF a(ROW, COL) THEN PRINT "*"; ELSE PRINT " ";
REGS.AX = 1
CALL INTERRUPTQB(&H33, REGS, REGS)
T = TIMER: WHILE T > TIMER - .5: WEND
END IF
LOOP UNTIL REGS.BX = 2
END SUB
SUB INTERRUPTQB (intnum AS INTEGER, InReg AS RegType, OutReg AS RegType)
'standard INTERRUPTQB call compatibility with QBasic
'some static variables
STATIC a() AS LONG, bReady AS INTEGER
'If assembler array not created, create it
IF NOT bReady THEN
'don't change anything
I = 50: DIM a(1 TO I) AS LONG
a(1) = &H53EC8B55: a(2) = &H1E575651: a(3) = &H5E8B9C06: a(4) = &HA078B0E
a(5) = &HC70774E4: a(6) = &HE9FFFF07: a(7) = &HEC8300A1: a(8) = &HB3F88A0A
a(9) = &HE85E89CD: a(10) = &HCBEA46C7: a(11) = &H74253C90: a(12) = &H75263C04
a(13) = &HEA46C714: a(14) = &H46C701E8: a(15) = &HC7CB00EC: a(16) = &H2C2EE46
a(17) = &HF046C7: a(18) = &H85E8B90: a(19) = &H5E8B37FF: a(20) = &HE37FF06
a(21) = &H50008FB8: a(22) = &HE85E8D16: a(23) = &H8BDA8C53: a(24) = &H378B0A5E
a(25) = &H8E0C5E8B: a(26) = &H10448B1F: a(27) = &H75FFFF3D: a(28) = &H50C28B02
a(29) = &H3D12448B: a(30) = &H275FFFF: a(31) = &HC08EC28B: a(32) = &H5C8B048B
a(33) = &H44C8B02: a(34) = &H8B06548B: a(35) = &H748B0C7C: a(36) = &H9CCB1F0A
a(37) = &H83EC8B55: a(38) = &H1E5620C5: a(39) = &H89E476C5: a(40) = &H25C8904
a(41) = &H89044C89: a(42) = &H7C890654: a(43) = &H12448C0C: a(44) = &H8F10448F
a(45) = &H448F0A44: a(46) = &HE448F08: a(47) = &H9D0EC483: a(48) = &H5E5F1F07
a(49) = &HCA5D5B59: a(50) = &H9165000A
'Checksum, can be ommited
S1 = 0: S2 = 0: p = VARPTR(a(1)): DEF SEG = VARSEG(a(1))
FOR I = 0 TO 199
S1 = (S1 + PEEK(p + I)) MOD 255: S2 = (S2 + S1) MOD 255
NEXT I
IF S1 OR S2 THEN ERROR 2: intnum = -1: EXIT SUB ' Checksum Error
'End of the checksum
bReady = -1
END IF
'This is where we call our assembler INTERRUPTQB calling function
DEF SEG = VARSEG(a(1))
CALL ABSOLUTE(intnum, VARSEG(InReg), VARPTR(InReg), VARSEG(OutReg), VARPTR(OutReg), 0)
END SUB
FUNCTION NUMOFNEIGHBORS (a(), I, J)
N = 0
FOR C = J - 1 TO J + 1
FOR R = I - 1 TO I + 1
IF a(R, C) THEN N = N + 1
NEXT
NEXT
IF a(I, J) THEN N = N - 1
NUMOFNEIGHBORS = N
END FUNCTION