Programmation QBasic Document Sample
++++++++++++++++++++++++++++++++++++++
' Programme: Calcul de l'aire d'un cercle.
' Auteur: Tiger-222.
' Date de création: Lundi 13 Novembre 2006.
depart:
CLS
COLOR 2
GOTO debut
interface:
CLS
LOCATE 1, 1: COLOR 8, 0: PRINT " ±±±±±±±± ±±±±±±±±"
LOCATE 2, 1: COLOR 8, 0: PRINT " °°°°°°°°°°°°°°°°°°°°°°"
LOCATE 3, 1: COLOR 8, 0: PRINT " °°° °°°"
LOCATE 4, 1: COLOR 8, 0: PRINT " °°°°°°°°°°°°°°°°°°°°°°"
LOCATE 5, 1: COLOR 8, 0: PRINT " °°°° °°°"
LOCATE 6, 1: COLOR 8, 0: PRINT " °°°° °°°"
LOCATE 7, 1: COLOR 8, 0: PRINT " °°°°°°°°°°°°°°°°°°°°°°"
LOCATE 8, 1: COLOR 8, 0: PRINT " °°°°°°° °°°°°°°"
LOCATE 9, 1: COLOR 8, 0: PRINT " °°°°°°°°°°°°°°°°°°°°°°"
RETURN
debut:
GOSUB interface:
LOCATE 1, 11: COLOR 2, 0: PRINT "Cercle"
LOCATE 3, 6: COLOR 2, 0: PRINT "Calcul de l'aire"
LOCATE 5, 5: COLOR 2, 0: PRINT "Rayon: "
LOCATE 6, 5: COLOR 2, 0: PRINT "Aire :"
LOCATE 8, 10: COLOR 26, 0: PRINT "cm / cm²"
GOTO rayon
rayon:
' mise en place des valeurs
LOCATE 5, 12: COLOR 2, 0: INPUT "", R
IF R 500 THEN
LOCATE 6, 11: COLOR 4, 0: PRINT "impossible"
SLEEP
GOTO debut
ELSE
A = R ^ 2 * 3.14
LOCATE 6, 11: COLOR 2, 0: PRINT A
SLEEP
GOTO debut
END IF
============================================
more by http://www.freewebs.com/davidweb/download.htm
qbasic my style
--------------------------------------------------------------------------- ' ' QBASWIN II DEMONSTRATION PROGRAM ' written by John Strong ' July 1992 ' ' THIS IS PUBLIC DOMAIN SOFTWARE. YOU MAY FREELY DISTRIBUTE THIS PROGRAM ' ONLY IN ITS ORIGINAL FORM. MODIFIED VERSIONS ARE NOT TO BE DISTRIBUTED. ' ' For more information on QuickBASIC programming libraries or if you have ' any questions about QBASWIN II, you may contact the author, John Strong, ' at Strongsoft, 3155 SW 178th Avenue, Aloha, OR 97006. (203)436-2836 ' ' To create your own program using QBASWIN II, refer to file QBASWIN2.TMP '--------------------------------------------------------------------------- DECLARE SUB Background () DECLARE SUB BlatantAd () DECLARE SUB Delay (n%) DECLARE SUB GoodBye () DECLARE SUB HowToUse () DECLARE SUB InitWindow (mem%) DECLARE SUB Intro () DECLARE SUB PopDown () DECLARE SUB PopUp (ulr%, ulc%, lrr%, lrc%, attr%, frame%, shadow%, saveit%) DECLARE SUB Stacker () DECLARE SUB WhatsNew () DECLARE SUB ZoomDown (snd%, zooms%) DECLARE SUB ZoomUp (ulr%, ulc%, lrr%, lrc%, attr%, frame%, shadow%, saveit%, snd%, zooms%) REDIM SHARED work%(0), winmem%(0) 'InitWindow will redim these winmem% = 32766 'window memory buffer size at maximum InitWindow winmem% 'this must be done first! '-------------------------------------------------------------------------- Background 'create background pattern Intro 'do snazzy intro WhatsNew 'text on the new features of QBASWIN II Stacker 'demo on stacking windows HowToUse 'tutorial on using QBASWIN II BlatantAd 'I gotta plug my own software! GoodBye 'I'm outta here END whatsnewtext: DATA "QBASWIN II is the latest incarnation of a windowing utility I wrote a little" DATA "over a year ago called QBASWIN.BAS. QBASWIN proved to be a very popular" DATA "little program that gave Microsoft QBASIC, a non-compiling version of" DATA "QuickBASIC, pop-up window capability. QBASWIN.BAS contained a small" DATA "machine-language program that allowed even the novice QBASIC programmer to" DATA "supercharge the ho-hum menus typical of non-compiled BASIC." DATA "" DATA "So what's different with QBASWIN II? Glad you asked! The ability to create" DATA "create super-fast pop-up windows is surely a great addition to QBASIC, but" DATA "what about when you want to erase a window? Users wanted to pop up a window" DATA "and then pop it down again without disturbing the screen underneath, which" DATA "QBASWIN couldn't do. But QBASWIN II does!" DATA "" DATA "In fact, QBASWIN II will allow you to pop and unpop windows, stack and" DATA "unstack windows, even create zooming windows! As with the previous version," DATA "QBASWIN II features transparent shadowing and frame." DATA " " DATA "I hereby put QBASWIN II in the public domain -- it can be freely distributed" DATA "as long as it remains in its original form and is not modified in any way." DATA " " DATA " Hit any key to see the window stacking demo!" UsingText: DATA "Using QBASWIN II is even easier than using QBASWIN I! DATA " " DATA "Accompanying this demo program is a file called QBASWIN2.TMP, which is a" DATA "template on which to build your QBASIC programs using QBASWIN II. Merely" DATA "copy the template file to a .BAS file, i.e., COPY QBASWIN2.TMP MYPROG.BAS," DATA "load up the newly created .BAS file into QBASIC and start programming!" DATA "The window routines are already set up and are ready to go." DATA "" DATA "There are four window routines that you can use - PopUp, PopDown, ZoomUp," DATA "and ZoomDown. PopUp will create a window and optionally preserve the" DATA "underlying screen, and PopDown will restore the most recently saved window." DATA "Similarly, ZoomUp will create an exploding window effect, and ZoomDown will" DATA "restore the most recently saved zoomed windows." DATA "" DATA "The syntax for PopUp is:" DATA " CALL PopUp(ulr%,ulc%,lrr%,lrc%,attr%,frame%,shadow%,saveit%)" DATA "where:" DATA " ulr% - upper left row attr% - color scheme" DATA " ulc% - upper left column frame% - frame switch, 1 or 0" DATA " lrr% - lower right row shadow% - shadow switch, 1 or 0" DATA " lrc% - lower right column saveit% - window save switch, 1 or 0" DATA " (Hit any key)" DATA "The arguments ulr%, ulc%, lrr%, and lrc% are fairly self-explanatory." DATA "However, the next four might need a little clarification." DATA " " DATA "attr%: This is a color attribute, a number than contains both foreground" DATA " and background color information. The attribute is the background" DATA " color times 16 plus the foreground color. So, for white (7) on" DATA " blue (1), the attribute would be (1 * 16) + 7 = 23." DATA "" DATA "frame%: Setting this to 1 will result in a frame around the window, while" DATA " setting it to 0 will prevent a frame from being displayed." DATA " " DATA "shadow%: Setting this to 1 will result in a transparent shadow underneath" DATA " the window, while setting it to 0 will result in no shadow." DATA " " DATA "saveit%: The underlying screen will be saved if this is set to 1, allowing" DATA " it to be restored later. No screen save will occur if this is" DATA " set to 0." DATA "" DATA "The syntax for PopDown is:" DATA " CALL PopDown DATA "(pretty simple, huh?)" DATA " (Hit any key)" DATA "Using ZoomUp and ZoomDown is much the same, except that there are two" DATA "extra arguments in ZoomUp and two arguments in ZoomDown." DATA " " DATA "The syntax for ZoomUp is:" DATA " CALL ZoomUp(ulr%,ulc%,lrr%,lrc%,attr%,frame%,shadow%,saveit%,snd%,zooms%)" DATA "where:" DATA " snd% - sound switch zooms% - number of saves" DATA " " DATA "snd%: Setting this to 1 will enable sound effects." DATA " " DATA "zooms%: This argument is used between the ZoomUp and ZoomDown routines" DATA " and is not an input; it just needs to be in the argument list." DATA " It tells the ZoomDown routine how many screen restores need to be" DATA " done to zoom down a zoomed window. DATA "" DATA "The syntax for ZoomDown is:" DATA " CALL ZoomDown(snd%,zooms%) DATA "where snd% is used as in ZoomUp and zooms% is as described above. Once" DATA "again, zooms% is not an input, it just needs to be there. Trust me!" DATA " " DATA " (Hit any key)" DATA " " BlatantText: DATA "OK, here's the part where I get to plug my shareware library! If you've" DATA "liked how QBASWIN II can supercharge a user interface in QBASIC, then you" DATA "ought to take a look at DATA " " DATA " ******* EZ-Windows Volume I, from Strongsoft ******* DATA " " DATA "a user interface toolkit for QuickBASIC 4.5 and PDS 7.x. This library " DATA "allows the QB programmer to create slick front ends to their programs and" DATA "forever do away with those choose-by-number menus. Pulldown menus, pop-up" DATA "windows with *many* frame and shadow options, scrolling and tagging menus," DATA "input routines, dialogue boxes, and much more are included. And all" DATA "routines support a mouse!" DATA " " DATA "Look for the file EZW1V30A.ZIP on your local BBS, or contact the author" DATA "(John Strong) to receive the shareware library. I can be reached at: DATA " " DATA " Strongsoft" DATA " 3155 SW 178th Avenue" DATA " Aloha, OR 97006" DATA " (203) 436-2836 (current number) DATA " " DATA " (Hit any key to end demo)" '-------------------- Machine Language Program Data ------------------------ prog: DATA 55,8B,EC,83,EC,10,53,51,6,57,56,B9,8,0,BF,0,0,8B,5B,6,8B,7,48,89 DATA 43,F0,47,47,E2,F3,FF,46,F6,FF,46,F4,FF,46,F2,FF,46,F0,BB,0,B0,A1,10,0 DATA 25,30,0,3D,30,0,74,3,BB,0,B8,8E,C3,8B,5E,FE,B8,A0,0,F7,E3,8B,5E,FC DATA D1,E3,3,C3,8B,F8,57,8B,46,F8,8B,5E,FC,2B,C3,40,8B,D8,53,8B,46,FA,8B,56 DATA FE,2B,C2,40,8B,C8,51,8B,46,F6,3D,0,0,7F,5B,F7,D0,40,89,46,F6,1E,6,57 DATA 51,53,8B,F7,6,8B,46,F0,8E,C0,1F,26,8B,3E,0,0,83,C7,A,57,41,43,51,51 DATA 8B,CB,F3,A5,59,2B,F3,2B,F3,81,C6,A0,0,E2,F0,59,26,89,3E,0,0,8B,46,FE DATA 26,89,5,8B,46,FC,26,89,45,2,8B,46,FA,26,89,45,4,8B,46,F8,26,89,45,6 DATA 58,26,89,45,8,5B,59,5F,7,1F,BA,0,0,8A,66,F6,B0,20,83,7E,F4,0,74,5 DATA B0,C4,BA,1,0,51,8B,CB,83,7E,F4,0,74,8,50,B0,B3,AB,83,E9,1,58,F3,AB DATA 83,7E,F4,0,74,8,50,83,EF,2,B0,B3,AB,58,83,FA,0,75,E,83,7E,F2,0,74 DATA 8,50,B0,8,47,AA,4F,4F,58,2B,FB,2B,FB,81,C7,A0,0,59,B0,20,83,7E,F4,0 DATA 74,7,83,F9,2,75,2,B0,C4,BA,0,0,E2,AF,83,7E,F2,0,74,B,8B,CB,B0,8 DATA 83,C7,2,47,AA,E2,FC,83,7E,F4,0,74,27,59,5B,5F,B0,DA,AB,3,FB,3,FB,83 DATA EF,4,B0,BF,AB,50,B8,A0,0,49,F7,E1,3,F8,58,83,EF,2,B0,D9,AB,2B,FB,2B DATA FB,B0,C0,AB,5E,5F,7,59,5B,8B,E5,5D,CA,10,0 DATA 55,8B,EC,53,51,52,6,57,56,1E,BB,0,B0,A1,10,0,25,30,0,3D,30,0,74,5 DATA BB,0,B8,8E,C3,8B,76,6,8E,1C,8B,36,0,0,83,FE,0,74,44,8B,1C,B8,A0,0 DATA F7,E3,8B,5C,2,D1,E3,3,C3,8B,F8,8B,44,6,8B,5C,2,2B,C3,40,8B,D8,8B,44 DATA 4,8B,14,2B,C2,40,8B,C8,8B,74,8,83,EE,A,89,36,0,0,83,C6,A,41,43,51 DATA 8B,CB,F3,A5,59,2B,FB,2B,FB,81,C7,A0,0,E2,F0,1F,5E,5F,7,5A,59,5B,8B,E5 DATA 5D,CA,2,0 DEFINT A-Z SUB Background COLOR 3, 1 'cyan on blue CLS LOCATE 2, 1 fill$ = " ** Strongsoft ** " FOR j = 1 TO 11 FOR k = 1 TO 3 PRINT fill$; NEXT PRINT " "; FOR k = 1 TO 2 PRINT fill$; NEXT NEXT Delay 100 END SUB SUB BlatantAd attr = 6 * 16 + 14 ZoomUp 1, 1, 25, 80, attr, 1, 0, 1, 1, zooms1 COLOR 14, 6 LOCATE 1, 28 PRINT "[ Blatant Advertisement ]" RESTORE BlatantText FOR i = 1 TO 22 READ a$ IF a$ = "" THEN Delay 1000 LOCATE i + 2, 3: PRINT a$; NEXT Delay 10000 ZoomDown 1, zooms1 END SUB SUB Delay (n) n! = n / 100 IF n! < 0 THEN n! = -n! x! = TIMER WHILE TIMER < x! + n! IF n > 0 THEN IF INKEY$ <> "" THEN EXIT SUB END IF WEND END SUB SUB GoodBye Delay 100 attr = 1 * 16 + 7 ZoomUp 2, 2, 24, 79, attr, 0, 0, 0, 0, zooms0 COLOR 7, 0 Delay 100 CLS END SUB SUB HowToUse attr = 5 * 16 + 14 ZoomUp 1, 1, 25, 80, attr, 1, 0, 1, 1, zooms1 COLOR 14, 5 LOCATE 1, 31 PRINT "[ Using QBASWIN II ]" RESTORE UsingText FOR j = 1 TO 3 GOSUB clearscreen FOR i = 1 TO 22 READ a$ IF a$ = "" THEN Delay 1000 LOCATE i + 2, 3: PRINT a$; NEXT Delay 10000 NEXT ZoomDown 1, zooms1 EXIT SUB clearscreen: attr = 5 * 16 + 14 ZoomUp 2, 2, 24, 79, attr, 0, 0, 0, 0, zooms0 RETURN END SUB SUB InitWindow (mem) 'work() holds the program REDIM work(250) DEF SEG = VARSEG(work(0)) RESTORE prog FOR i = 1 TO 499 READ D$ POKE i - 1, VAL("&H" + D$) NEXT DEF SEG REDIM winmem(mem) END SUB SUB Intro attr = 2 * 16 + 14 ZoomUp 2, 2, 24, 79, attr, 1, 0, 1, 1, zooms1 Delay 25 attr = 1 * 16 + 15 ZoomUp 5, 5, 15, 40, attr, 1, 1, 1, 1, zooms2 COLOR 15, 1 LOCATE 7, 12: PRINT "Strongsoft Presents..." LOCATE 10, 15: PRINT "QBASWIN II !!!" LOCATE 12, 17: PRINT "July, 1992" Delay 200 attr = 4 * 16 + 14 PopUp 11, 30, 17, 55, attr, 1, 1, 1 COLOR 14, 4 LOCATE 13, 36: PRINT "For DOS 5.0's" LOCATE 15, 37: PRINT "QBASIC 1.0" Delay 200 attr = 6 * 16 PopUp 16, 45, 20, 75, attr, 1, 1, 1 COLOR 0, 6 LOCATE 18, 47: PRINT "Works with QuickBASIC, too!" LOCATE 23, 14 COLOR 14, 2 PRINT "(Hit a key at any time to accelerate through the demo)" Delay 350 FOR i = 1 TO 2 PopDown Delay 50 NEXT ZoomDown 1, zooms2 Delay 50 ZoomDown 1, zooms1 END SUB SUB PopDown DEF SEG = VARSEG(work(0)) winseg = VARSEG(winmem(0)) CALL absolute(winseg, 375) DEF SEG END SUB SUB PopUp (ulr, ulc, lrr, lrc, attr, frame, shadow, saveit) IF ulr < lrr AND ulc < lrc THEN DEF SEG = VARSEG(work(0)) winseg = VARSEG(winmem(0)) IF saveit THEN newattr = -attr ELSE newattr = attr CALL absolute(ulr, ulc, lrr, lrc, newattr, frame, shadow, winseg, 0) DEF SEG END IF END SUB SUB Stacker frame = 1 shadow = 1 saveit = 1 DEF SEG = 0 POKE 1050, PEEK(1052) DEF SEG DO FOR i = 1 TO 50 DEF SEG = 0 IF PEEK(1050) <> PEEK(1052) THEN ecode = 1: EXIT DO DEF SEG bg = RND * 7 fg = RND * 16 attr = bg * 16 + fg ulr = 15 * RND + 1 lrr = ulr + 8 ulc = 45 * RND + 1 lrc = ulc + 33 PopUp ulr, ulc, lrr, lrc, attr, frame, shadow, saveit Delay -1 NEXT COLOR fg, bg LOCATE ulr + 4, ulc + 5 PRINT "Hit any key to continue" Delay 100 FOR i = 1 TO 50 DEF SEG = 0 IF PEEK(1050) <> PEEK(1052) THEN ecode = 2 DEF SEG PopDown Delay -1 NEXT IF ecode THEN EXIT DO LOOP IF ecode = 1 THEN FOR j = 1 TO i PopDown Delay -1 NEXT END IF DEF SEG = 0 POKE 1050, PEEK(1052) DEF SEG END SUB SUB WhatsNew attr = 3 * 16 + 1 ZoomUp 1, 1, 25, 80, attr, 1, 0, 1, 1, zooms COLOR 3, 1 LOCATE 1, 35: PRINT " What's New " COLOR 1, 3 RESTORE whatsnewtext FOR i = 1 TO 21 READ a$ IF a$ = "" THEN Delay 1000 LOCATE i + 2, 3: PRINT a$ NEXT Delay 10000 ZoomDown 1, zooms END SUB SUB ZoomDown (snd, zooms) FOR i = 49 TO zooms + 1 STEP -1 IF snd THEN SOUND i * 110 + 440, .05 ELSE SOUND 0, .08 NEXT FOR i = 1 TO zooms PopDown IF snd THEN SOUND (zooms - i) * 110 + 440, .08 ELSE SOUND 0, .08 NEXT zooms = 0 END SUB SUB ZoomUp (ulr, ulc, lrr, lrc, attr, frame, shadow, saveit, snd, zooms) IF ulr < lrr AND ulc < lrc THEN DEF SEG = VARSEG(work(0)) winseg = VARSEG(winmem(0)) crow = (ulr + lrr) / 2 ccol = (ulc + lrc) / 2 IF lrr - ulr > lrc - ulc THEN dc = 1 dr = INT((lrr - ulr) / (lrc - ulc)) ELSE dr = 1 dc = INT((lrc - ulc) / (lrr - ulr)) END IF ulr0 = crow - 1 lrr0 = crow + 1 ulc0 = ccol - 1 lrc0 = ccol + 1 c = 0 z = 1 IF saveit = 1 THEN newattr = -attr ELSE newattr = attr DO z = z + 2 CALL absolute(ulr0, ulc0, lrr0, lrc0, newattr, frame, 0, winseg, 0) ulr0 = ulr0 - dr ulc0 = ulc0 - dc CALL absolute(ulr0, ulc0, lrr0, lrc0, newattr, frame, 0, winseg, 0) lrr0 = lrr0 + dr lrc0 = lrc0 + dc IF snd THEN SOUND z * 110 + 440, .08 ELSE SOUND 0, .08 LOOP UNTIL lrr0 >= lrr OR lrc0 >= lrc z2 = z CALL absolute(ulr, ulc, lrr, lrc, newattr, frame, shadow, winseg, 0) DO UNTIL z2 > 49 z2 = z2 + 2 IF snd THEN SOUND z2 * 110 + 440, .08 ELSE SOUND 0, .08 LOOP DEF SEG END IF zooms = -(saveit = 1) * z END SUB
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
message$ = "I" i = 1 CLS PRINT "I've been wanting to say this for along time but I've never had the guts to." PRINT "So here it is, my true feelings..." DO: LOOP UNTIL INKEY$ <> "" DO i = i + 1 CLS PRINT message$ LOCATE 23, 1 PRINT "Press any key" DO: LOOP UNTIL INKEY$ <> "" SELECT CASE i CASE 2 message$ = "I l" CASE 3 message$ = "I lo" CASE 4 message$ = "I lov" CASE 5 message$ = "I love" CASE 6 message$ = "I love y" CASE 7 message$ = "I love yo" CASE 8 message$ = "I love yoghurt" END SELECT LOOP UNTIL i = 9
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'set the screen mode to screen 12 SCREEN 12 'declare arrays DIM light1(1225) DIM light2(1225) DIM blank(1225) DIM vertbar(53 * 8) DIM horizbar(53 * 8) DIM board(5, 5, 1, 1) 'board (boardlocationX, boardloactionY, pixellocationX, pixellocationY) type$ = "square" 'clear the screen CLS 'draw different sprites used GET (1, 1)-(35, 35), blank 'blank space (light off) LINE (1, 1)-(35, 35), 14, BF GET (1, 1)-(35, 35), light1 CLS CIRCLE (35 / 2, 35 / 2), INT(35 / 2), 14 PAINT STEP(x, y), 14, 14 GET (1, 1)-(35, 35), light2 CLS LINE (1, 1)-(8, 53), 15, BF LINE (3, 1)-(6, 53), 9, BF LINE (5, 1)-(4, 53), 1, BF GET (1, 1)-(8, 53), vertbar CLS LINE (1, 1)-(53, 8), 15, BF LINE (1, 3)-(53, 6), 9, BF LINE (1, 5)-(53, 4), 1, BF GET (1, 1)-(53, 8), horizbar presetup: FOR b = 1 TO 5 FOR a = 1 TO 5 x = a * 45 + 144 y = b * 45 + 64 'board((x - 189) / 45, (y - 109) / 45, 1, 0) = x 'board((x - 189) / 45, (y - 109) / 45, 0, 1) = y board(a, b, 1, 0) = x board(a, b, 0, 1) = y NEXT a NEXT b CLS GOSUB drawscrn begin: onlights = 0 offlights = 0 'read data from array to place lights FOR y = 1 TO 5 FOR x = 1 TO 5 IF board(x, y, 0, 0) = 1 THEN IF type$ = "square" THEN PUT (board(x, y, 1, 0), board(x, y, 0, 1)), light1, PSET ELSE PUT (board(x, y, 1, 0), board(x, y, 0, 1)), light2, PSET END IF onlights = onlights + 1 ELSE 'IF board(x, y, 1, 0) > 0 AND board(x, y, 0, 1) > 0 THEN PUT (board(x, y, 1, 0), board(x, y, 0, 1)), blank, PSET 'END IF offlights = offlights + 1 END IF NEXT x NEXT y 'update stats box LOCATE 11, 60 PRINT onlights LOCATE 15, 60 PRINT offlights 'test if all lights are on IF onlights = 25 THEN GOTO win 'ask for co-ordinates ask: LOCATE 28, 3 PRINT "> " DO c1$ = INKEY$ LOCATE 28, 5 IF c1$ <> CHR$(13) THEN PRINT c1$ LOOP UNTIL c1$ <> "" AND c1$ <> CHR$(13) DO c2$ = INKEY$ LOCATE 28, 6 IF c2$ <> CHR$(13) THEN PRINT c2$ LOOP UNTIL c2$ <> "" c$ = c1$ + c2$ IF c2$ = CHR$(13) THEN 'check for commands OTHER than co-ordinates SELECT CASE UCASE$(UCASE$(c1$)) CASE "R" ERASE board LOCATE 28, 5 PRINT " " GOTO presetup CASE "L" IF type$ = "square" THEN type$ = "circle" ELSE type$ = "square" LOCATE 28, 5 PRINT " " GOTO begin CASE "E", "Q" CLS PRINT "THANKYOU FOR PLAYING!" END CASE ELSE LOCATE 28, 5 PRINT " " GOTO begin END SELECT END IF DO confirm$ = INKEY$ LOOP UNTIL confirm$ = CHR$(13) LOCATE 28, 5 PRINT " " 'check that co-ordinates are valid. If they are then apply then x & y locations SELECT CASE UCASE$(LEFT$(c$, 1)) CASE "A" b = 1 CASE "B" b = 2 CASE "C" b = 3 CASE "D" b = 4 CASE "E" b = 5 CASE ELSE GOTO begin END SELECT SELECT CASE UCASE$(RIGHT$(c$, 1)) CASE "1" a = 1 CASE "2" a = 2 CASE "3" a = 3 CASE "4" a = 4 CASE "5" a = 5 CASE ELSE GOTO begin END SELECT 'select the style of lights to be shown SELECT CASE a CASE 2, 3, 4 IF b > 1 AND b < 5 THEN style = 1 'middle 5 lights IF b = 1 THEN style = 2 'top 4 lights IF b = 5 THEN style = 3 'bottom 4 lights CASE 1 IF b > 1 AND b < 5 THEN style = 4 'left 4 lights IF b = 1 THEN style = 5 'top left 3 lights IF b = 5 THEN style = 6 'bottom left 3 lights CASE 5 IF b > 1 AND b < 5 THEN style = 7 'right 4 lights IF b = 1 THEN style = 8 'top right 3 lights IF b = 5 THEN style = 9 'bottom right 3 lights END SELECT 'apply to array depending on the style IF board(a, b, 0, 0) = 1 THEN board(a, b, 0, 0) = 0 ELSE board(a, b, 0, 0) = 1 SELECT CASE style CASE 1 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 CASE 2 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 CASE 3 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 CASE 4 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 CASE 5 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 CASE 6 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a + 1, b, 0, 0) = 1 THEN board(a + 1, b, 0, 0) = 0 ELSE board(a + 1, b, 0, 0) = 1 CASE 7 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 CASE 8 IF board(a, b + 1, 0, 0) = 1 THEN board(a, b + 1, 0, 0) = 0 ELSE board(a, b + 1, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 CASE 9 IF board(a, b - 1, 0, 0) = 1 THEN board(a, b - 1, 0, 0) = 0 ELSE board(a, b - 1, 0, 0) = 1 IF board(a - 1, b, 0, 0) = 1 THEN board(a - 1, b, 0, 0) = 0 ELSE board(a - 1, b, 0, 0) = 1 END SELECT GOTO begin drawscrn: 'CLS 'draw the board FOR y = 100 TO 340 STEP 45 FOR x = 180 TO 400 STEP 45 PUT (x, y), horizbar, OR NEXT x NEXT y FOR x = 180 TO 440 STEP 45 FOR y = 100 TO 300 STEP 45 PUT (x, y), vertbar, OR NEXT y NEXT x 'write co-ordinates on the exterior of the board LOCATE 8, 20 PRINT "A" LOCATE 11, 20 PRINT "B" LOCATE 14, 20 PRINT "C" LOCATE 17, 20 PRINT "D" LOCATE 20, 20 PRINT "E" LOCATE 23, 26 PRINT "1" LOCATE 23, 32 PRINT "2" LOCATE 23, 38 PRINT "3" LOCATE 23, 44 PRINT "4" LOCATE 23, 50 PRINT "5" 'draw new frame to display game stats PUT (450, 100), horizbar, OR PUT (503, 100), horizbar, OR PUT (450, 100), vertbar, OR PUT (450, 153), vertbar, OR PUT (450, 206), vertbar, OR PUT (450, 251), horizbar, OR PUT (503, 251), horizbar, OR PUT (549, 100), vertbar, OR PUT (549, 153), vertbar, OR PUT (549, 206), vertbar, OR 'write into the new frame LOCATE 8, 61 PRINT "STATS:" LOCATE 10, 59 PRINT "LIGHTS ON" LOCATE 11, 59 PRINT ">" LOCATE 14, 59 PRINT "LIGHTS OFF" LOCATE 15, 59 PRINT ">" 'DISPLAY PROMPT LOCATE 27, 3 PRINT "PLEASE ENTER CO-ORDINATES:" RETURN win: CLS PRINT "WELL DONE!" END
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|