
DECLARE SUB FILELIST (P1$)
DECLARE SUB lstprog ()
DECLARE SUB LDPROGRAM (P1$)
DECLARE SUB SVPROGRAM (P1$)
DECLARE SUB PROGRUN ()
DECLARE SUB LEAVEOS9 (WORD$)
DECLARE SUB gnpart (CMD$, otxt$, Q%)
DECLARE SUB MODELPROC (TEXT$)

DECLARE SUB er ()
DECLARE SUB spmenu ()
DECLARE SUB doscr ()
DECLARE SUB START ()
DECLARE SUB hlp ()
DECLARE SUB McHSOD ()
DECLARE SUB chsod (aaa%, bbb%, ccc%)
DECLARE SUB loadsg ()
DECLARE SUB Menu ()
DECLARE SUB playsg (cplc%)
DECLARE SUB sec ()
DECLARE SUB linfo ()
DECLARE SUB clm ()
DECLARE SUB playt (n%, octave%)
DECLARE SUB drsc ()
DECLARE SUB iniscrn ()
DECLARE SUB retscr ()
DEFINT A-Z
DECLARE SUB waitp ()
DECLARE SUB SetReg (Reg%, Value%)
DECLARE SUB mouse (CX, dx, BX)
DECLARE SUB MousePointer (SW)
DECLARE SUB mPP (HH, VV, H1, V1, note$, nt$, n, o, tim, B)


COMMON SHARED ROOT$
COMMON SHARED PROGLENGTH, FMVAR, EXTLOOP, EXTPROMPT
CONST BaseAddr = &H220 'Change if your sound card uses another base address

CONST RegAddr = BaseAddr + 8, DataAddr = BaseAddr + 9
COMMON note$, nt$
DEFINT A-Z
       
        REM %%%%% SPECIAL THANKS TO  Jeff Barnette  %%%%%
        REM %%%%% FOR THIS MOUSE ROUTINE %%%%%
DIM SHARED cur$, rec$

DIM SHARED Bgnd, Fgnd, Border, curc, aaa, bbb, ccc, ddd, eee
DIM SHARED slim
DIM SHARED plc
DIM SHARED songdb(100, 3)
DIM SHARED A(9): REM %%% FOR MOUSEROUTINE %%%
DEF SEG = VARSEG(A(0))
    
RESTORE
FOR i = 0 TO 17
READ r
POKE VARPTR(A(0)) + i, r
NEXT i
DATA &HB8,&H00,&H00,&H55,&H8B,&HEC,&HCD,&H33,&H92
DATA &H8B,&H5E,&H06,&H89,&H07,&H5D,&HCA,&H02,&H00
CALL MousePointer(0)      'Reset mouse and
       
CALL MousePointer(3)      'Get coordinates



REM MODEL2.BAS

ROOT$ = "C:\QBASIC\"
DIM SHARED PROGRAMARRY$(200)
  cur$ = CHR$(219)


 

H1 = 1: V1 = 1

CALL retscr

CALL iniscrn




SCREEN 12

TEXT$ = "HELP"
EXTLOOP = 0




 aaa = &HF1
 bbb = &HE4
 ccc = &HE4
 ddd = &H9D
 eee = &H9D

 CALL chsod(aaa, bbb, ccc)





      Bgnd = 0
      Fgnd = 7
      Border = 1
      curc = 15
    
     slim = 100' set sec delay at 300
      plc = 0
      plclim = 100
     rec$ = "Stop"
     octave = 4
     duration! = .01

DO

SCREEN 12

PRINT "-------------------------"
PRINT "- COCO FM SOUNDCARD     -"
PRINT "-  2004 EXTENDED BASIC  -"
PRINT "-   RADIO SHACK         -"
PRINT "-------------------------"


IF FMVAR = 0 THEN
 EXTPROMPT = 0
 DO
 LINE INPUT "]"; TEXT$
 
  PRINT "___"

 CALL MODELPROC(TEXT$)

LOOP UNTIL EXTPROMPT = 1


END IF

IF FMVAR = 1 THEN
EXTFM = 0

 CALL START
 CLS
LOCATE 1, 1
      
DO
DO
KE$ = INKEY$
  KE$ = UCASE$(KE$)
      
 LOCATE 2, 2
   PRINT LN$; " "; rec$; " "; octave; "oct N <"; n; " "; slim; "T"; aaa; " "; bbb; " "; ccc; "--"; NN
   
   
    LOCATE 3, 2: PRINT ddd, eee
   IF KE$ <> "" THEN
  
      lch = ASC(LEFT$(KE$, 1)): rch = ASC(RIGHT$(KE$, 1))
      PRINT lch, rch;
    

   END IF
   CALL mPP(HH, VV, H1, V1, note$, nt$, n, o, tim, B)


   
    IF rec$ = "PLAY" AND B = 0 THEN
     
      CALL playsg(cplc)

       CALL waitp
    END IF



   IF note$ <> (nt$) THEN
   songdb(plc, 2) = tim
    tim = 0
   END IF
   IF note$ <> (nt$) OR dx = 1 THEN
    
     CALL waitp
   
     octave = o
    CALL playt(n, octave)
    
     IF rec$ = "Record" THEN
      
      songdb(plc, 0) = n
      songdb(plc, 1) = o
     
      plc = plc + 1
      IF plc > (plclim) THEN plc = plclim: rec$ = "Stop": CALL er
     END IF
       
   nt$ = note$
   LN$ = nt$
  
   END IF

    IF rec$ = "Record" THEN
     tim = tim + 1: IF tim > 4000 THEN tim = 4000
    END IF


   IF note$ = "" THEN tm = 0
   
 IF V1 <> (VV) OR H1 <> (HH) THEN
  CALL drsc
       H1 = HH
       V1 = VV
 END IF

LOOP UNTIL KE$ <> ""
 CALL waitp
  IF KE$ = "Q" THEN FMVAR = 0: EXTFM = 1
  IF KE$ = "x" OR KE$ = "X" THEN FMVAR = 0
  IF KE$ = "," THEN octave = octave - 1
     IF octave < 1 THEN octave = 1
  IF KE$ = "." THEN octave = octave + 1
     IF octave > 7 THEN octave = 7
 
  IF KE$ = "1" THEN NN = NN + 1
     
  IF KE$ = "2" THEN NN = NN - 1
     

  IF KE$ = "R" THEN rec$ = "Record"
  IF KE$ = "P" THEN rec$ = "PLAY"
  IF KE$ = "S" THEN rec$ = "Stop"

   IF KE$ = "N" THEN rec$ = "New": CALL clm
   IF KE$ = "M" THEN CALL Menu
   
     IF KE$ = "V" THEN

       CALL spmenu


      END IF
  
   
    
      IF lch = 0 AND rch = 63 THEN
          CALL McHSOD

      END IF


      IF lch = 0 AND rch = 73 THEN slim = slim - 5: IF slim <= 5 THEN slim = 5
   
      IF lch = 0 AND rch = 81 THEN slim = slim + 5: IF slim >= 2000 THEN slim = 2000
   
      IF lch = 0 AND rch = 59 THEN aaa = aaa + 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 84 THEN aaa = aaa - 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 60 THEN bbb = bbb + 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 85 THEN bbb = bbb - 1: CALL chsod(aaa, bbb, ccc)
     
      IF lch = 0 AND rch = 61 THEN ccc = ccc + 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 86 THEN ccc = ccc - 1: CALL chsod(aaa, bbb, ccc)

      IF lch = 0 AND rch = 134 THEN ddd = ddd + 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 136 THEN ddd = ddd - 1: CALL chsod(aaa, bbb, ccc)

      IF lch = 0 AND rch = 133 THEN eee = eee + 1: CALL chsod(aaa, bbb, ccc)
      IF lch = 0 AND rch = 135 THEN eee = eee - 1: CALL chsod(aaa, bbb, ccc)



   IF KE$ = "L" THEN CALL linfo

 CALL playt(n + NN, octave)
 
Ed = 0' set end variable to 0

   p$ = INKEY$
    'IF p$ = "q" THEN Ed = 1


   lch = 0
   rch = 0


LOOP UNTIL EXTFM = 1

END IF


LOOP UNTIL EXTLOOP = 1
PRINT "---"; ""

PRINT "RETURNING TO DOS"

END




END

SUB chsod (aaa, bbb, ccc)

 aa2 = &HF1 + aaa
 bb2 = &HE4 + bbb
 cc2 = &HE4 + ccc
 dd2 = &H9D + ddd
 ee2 = &H9D + eee



FOR i = 0 TO 224
  SetReg i, 0 'Clear all registers
NEXT i

SetReg &H20, &H1 'Plays carrier note at specified octave ch. 1
SetReg &H23, &H1 'Plays modulator note at specified octave ch. 1
SetReg &H40, aa2 'Set carrier total level to softest ch. 1
SetReg &H43, &H0 'Set modulator level to loudest ch. 1
SetReg &H60, bb2 'Set carrier attack and decay ch. 1
SetReg &H63, cc2 'Set modulator attack and decay ch. 1
SetReg &H80, dd2 'Set carrier sustain and release ch. 1
SetReg &H83, ee2 'Set modulator sustain and release ch. 1

SetReg &H21, &H1 'Plays carrier note at specified octave ch. 2
SetReg &H24, &H1 'Plays modulator note at specified octave ch. 2
SetReg &H41, &H1F 'Set carrier total level to softest ch. 2
SetReg &H44, &H0 'Set modulator level to loudest ch. 2
SetReg &H61, &HE4 'Set carrier attack and decay ch. 2
SetReg &H64, &HE4 'Set modulator attack and decay ch. 2
SetReg &H81, &H9D 'Set carrier sustain and release ch. 2
SetReg &H84, &H9D 'Set modulator sustain and release ch. 2

SetReg &H22, &H1 'Plays carrier note at specified octave ch. 3
SetReg &H25, &H1 'Plays modulator note at specified octave ch. 3
SetReg &H42, &H1F 'Set carrier total level to softest ch. 3
SetReg &H45, &H0 'Set modulator level to loudest ch. 3
SetReg &H62, &HE4 'Set carrier attack and decay ch. 3
SetReg &H65, &HE4 'Set modulator attack and decay ch. 3
SetReg &H82, &H9D 'Set carrier sustain and release ch. 3
SetReg &H85, &H9D 'Set modulator sustain and release ch. 3


END SUB

SUB clm
CLS
COLOR 0, 1, 0
PRINT "Clearing music buffer..."

INPUT "are you sure you want to empty the Buffer?"; yn$

IF yn$ = "Y" OR yn$ = "y" THEN
DO

 songdb(ct, 0) = 0

 songdb(ct, 1) = 0

 songdb(ct, 2) = 0

 songdb(ct, 3) = 0
 ct = ct + 1

LOOP UNTIL ct >= (plc)



PRINT " Buffer Cleared .."
SLEEP
CLS
END IF
  plc = 0

CALL doscr

END SUB

SUB doscr
CALL retscr
CALL iniscrn
CALL drsc


END SUB

SUB drsc


V = 0

COLOR 2, 4

LOCATE 5, 1
 
nnt$ = ""
nnd$ = ""


DO
SELECT CASE (V)
CASE IS = 0
nnt$ = "C"
nnd$ = "D"
CASE IS = 1
nnt$ = "E"
nnd$ = "F"
CASE IS = 2
nnt$ = "G"
nnd$ = "A"

CASE IS = 3
nnt$ = "B"
nnd$ = "C"

CASE IS = 4
nnt$ = "D"
nnd$ = "E"

CASE IS = 5
nnt$ = "F"
nnd$ = "G"

CASE IS = 6
nnt$ = "A"
nnd$ = "B"

CASE IS = 7
nnt$ = "C"
nnd$ = "D"



END SELECT

PRINT nnt$; STRING$(78, " ")
PRINT nnd$

V = V + 1

LOOP UNTIL V >= 8

   CALL retscr

END SUB

SUB er
COLOR 4, 0, 0
CLS


PRINT "!!   ERROR  !! "
PRINT " You have exceeded Buffer Space"
PRINT "## Recording haulted ##"
PRINT "Press <X> to resume ."

   DO
    KE$ = INKEY$
   LOOP UNTIL KE$ = "X"


  CALL doscr

END SUB

SUB FILELIST (P1$)

REM
REM
REM SHOWFILE
 NAME$ = P1$


 PRINT "#########"
 PRINT "# LIST  #"
 PRINT "#########"
  PRINT NAME$
IF NAME$ <> "" THEN
OPEN NAME$ FOR INPUT AS #1
 DO
 INPUT #1, A$
 PRINT A$


 V = V + 1
 IF V > 22 THEN V = 0: SLEEP

 LOOP UNTIL EOF(1)


CLOSE #1

 SLEEP
END IF


END SUB

SUB gnpart (CMD$, otxt$, Q)

ll = LEN(CMD$)
IF Q <= (ll) THEN
IF Q = 0 THEN Q = 1

otxt$ = ""
CH$ = ""

DO

  CH$ = MID$(CMD$, Q, 1)

IF CH$ <> "," AND CH$ <> ":" AND CH$ <> "(" AND CH$ <> ")" AND CH$ <> CHR$(32) AND CH$ <> CHR$(34) THEN
otxt$ = otxt$ + CH$
END IF

IF Q <= (ll) THEN
  Q = Q + 1

END IF


LOOP UNTIL CH$ = CHR$(13) OR CH$ = ":" OR CH$ = "," OR CH$ = CHR$(34) OR CH$ = CHR$(32) OR Q >= (ll)

END IF

END SUB

SUB hlp
CLS

SCREEN 0

OPEN "qbmusic.txt" FOR INPUT AS #1

DO
INPUT #1, A$
PRINT A$
SLEEP



LOOP UNTIL EOF(1)
 CLOSE #1




END SUB

SUB iniscrn


CH = 0

DO

PRINT STRING$(79, 219)
CH = CH + 1

LOOP UNTIL CH >= 23


END SUB

SUB LDPROGRAM (P1$)
REM
REM LOADS PROGRAM INTO INTEGER BASIC
REM
CLS
Z$ = P1$




IF RIGHT$(Z$, 4) <> ".COB" THEN Z$ = Z$ + ".COB"


PRINT " getting :"; Z$

OPEN Z$ FOR INPUT AS #8
x = 1
DO
 PRINT A$

 IF EOF(8) = FALSE THEN LINE INPUT #8, A$

 PROGRAMARRY$(x) = A$


 x = x + 1
LOOP UNTIL EOF(8)


CLOSE #8
   PROGLENGTH = x



END SUB

SUB linfo
  
   COLOR 7, 0, 0
   CLS
  
  
   ct = 0
   DO

    PRINT songdb(ct, 0), songdb(ct, 1), songdb(ct, 2)

   ct = ct + 1
   LOOP UNTIL ct >= (plc)
 
   PRINT
   PRINT " ### DONE ###"
   SLEEP
CALL doscr

END SUB

SUB loadsg

FILES


INPUT "Name of Qbmusic file to load "; na$

OPEN na$ FOR INPUT AS #1
ct = 0
DO

LINE INPUT #1, A$

   ll = LEN(A$)


 FOR ct = 1 TO (ll)
 CH$ = MID$(A$, ct, 1)
   PRINT CH$;
      
    
  IF CH$ = ":" THEN
     
   SELECT CASE cut
     CASE IS = 0
     songdb(cct, 0) = VAL(NN$)
    
     CASE IS = 1
     songdb(cct, 1) = VAL(NN$)
    
     CASE IS = 2
     songdb(cct, 2) = VAL(NN$)


      END SELECT
     IF CH$ = ":" THEN cut = cut + 1
      IF cut = 3 THEN cut = 0: cct = cct + 1: PRINT
NN$ = "": CH$ = ""
  END IF

 NN$ = NN$ + CH$
 NEXT ct


LOOP UNTIL EOF(1)

   
CLOSE #1
   plc = cct
     PRINT "Size <"; plc; ">"
SLEEP
END SUB

SUB lstprog

 PRINT PROGLENGTH

FOR x = 1 TO (PROGLENGTH)

  TXT$ = PROGRAMARRY$(x)
  IF TXT$ <> "" THEN
   PRINT x, TXT$
  END IF
 A$ = INKEY$

 IF A$ = CHR$(32) THEN SLEEP



NEXT x
SLEEP

END SUB

SUB McHSOD

        CLS
        COLOR 3, 0

        INPUT "Tone "; AA1
         INPUT " Decay t "; BB1
          INPUT "Decay d"; CC1
           INPUT "cd1 "; dd1
            INPUT "CD2 "; ee1
          
           IF AA1 <> 0 THEN aaa = AA1
           IF BB1 <> 0 THEN bbb = BB1
           IF CC1 <> 0 THEN ccc = CC1
          
           IF dd1 <> 0 THEN ddd = dd1
           IF ee1 <> 0 THEN eee = ee1
      

          
         CALL chsod(aaa, bbb, ccc)
    
CALL doscr
END SUB

SUB Menu
COLOR 1, 0, 0
 CLS
 DO
 PRINT "Load a File <L>"
 PRINT " Save this File <S>"
 PRINT "  Name this File  <N>"
 PRINT "   Tweek the SEC feature <E>"
 PRINT "    Change Screen Colors <C>  "
 PRINT "e<X>it"

INPUT KE$

    KE$ = UCASE$(KE$)
    
    
     SELECT CASE KE$
     CASE IS = "C"
      INPUT "Fore Color "; Fgnd
      INPUT "BackGround "; Bgnd
      INPUT "Border "; Border
      CALL retscr
     
     CASE IS = "E"
       INPUT "SEC"; slim
       PRINT "Sec delay is now < "; slim
       PRINT
    CASE IS = "L"
    'CALL clm
     CALL loadsg
   
    CASE IS = "S"
      INPUT "Name of file to be Saved under "; na$

      OPEN na$ FOR OUTPUT AS #1

      DO
       n = songdb(ct, 0)
       o = songdb(ct, 1)
       tim = songdb(ct, 2)

       PRINT #1, STR$(n); ":"; STR$(o); ":"; STR$(tim); ":"

         ct = ct + 1
      LOOP UNTIL ct >= (plc)
       CLOSE #1

    END SELECT

LOOP UNTIL KE$ = "X"

CALL doscr

END SUB

SUB MODELPROC (TEXT$)

 IF TEXT$ <> "" THEN

 TEXT$ = UCASE$(TEXT$)

 IF RIGHT$(TEXT$, 1) <> " " THEN TEXT$ = TEXT$ + " "

 WORD$ = ""
 L = LEN(TEXT$)
 x = 1
 CALL gnpart(TEXT$, otxt$, Q): WORD$ = otxt$
 REST$ = RIGHT$(TEXT$, L - Q + 1)
 CALL gnpart(TEXT$, otxt$, Q): P1$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P2$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P3$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P4$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P5$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P6$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P7$ = otxt$
 CALL gnpart(TEXT$, otxt$, Q): P8$ = otxt$


   V1 = VAL(P1$)
   V2 = VAL(P2$)
   V3 = VAL(P3$)
   V4 = VAL(P4$)
   V5 = VAL(P5$)
   V6 = VAL(P6$)
   V7 = VAL(P7$)
   V8 = VAL(P8$)

 
  LNV = VAL(WORD$)
  IF LNV > 0 OR WORD$ = "0" THEN
  PROGRAMARRY$(LNV) = REST$

  IF LNV > (PROGLENGTH) THEN PROGLENGTH = LNV

  END IF


'PRINT WORD$, V1
 'SLEEP

 SELECT CASE (WORD$)

 CASE IS = "WAV"
  SHELL "DIR/W *.WAV"


 CASE IS = "FM", "MUSIC"
  FMVAR = 1
 
  EXTPROMPT = 1

 CASE IS = "NEW"
 FOR LX = 0 TO (200)

 PROGRAMARRY$(LX) = ""

 NEXT LX

  PROGLENGTH = 0

 CASE IS = "PRINT", "?"
  PRINT P1$

 CASE IS = "LIST"
 CALL lstprog
 CASE IS = "QBMENU"
  RUN ROOT$ + "QBMENU.BAS"

 CASE IS = "HELP"
  PRINT "### HELP ####"
  PRINT ""
  PRINT ""

 CASE IS = "TI994A"
  RUN ROOT$ + "TI994A.BAS"


 CASE IS = "LPT1WRITE"
  OPEN "FLPT1.DAT" FOR OUTPUT AS #8
  LP1 = 1

 CASE IS = "LPT1READ"
  OPEN "FLPT1.DAT" FOR INPUT AS #8

 CASE IS = "LPT1PURG"
  CLS
  PRINT "# EXITING ROUTINE GOES HERE"
  PRINT "#  "
  PRINT "#   "
     
      'CALL SAVESET
     
        SLEEP 1
  RUN ROOT$ + "LPT1PURG.BAS"



 CASE IS = "COCO2"
  CLS
  PRINT "############"
  PRINT "# COCO 2 ###"
  PRINT "############"
   SLEEP 1
   RUN ROOT$ + "QBMENU.BAS"

 CASE IS = "AUDIO"

   EQ = 1



 CASE IS = "CLS", "TEXT", "AUDIO"
      TEXTSHOW = 1


 CASE IS = "NOTEXT"
 TEXTSHOW = 0


 CASE IS = "HELP"

          

  PROMPT$ = PROMPT$ + "----------- HELP ----------- " + CR$
  PROMPT$ = PROMPT$ + "Beep tone print" + CR$
  PROMPT$ = PROMPT$ + "goto com1 com2 " + CR$
  PROMPT$ = PROMPT$ + "              CirCle Pset " + CR$
  PROMPT$ = PROMPT$ + "              line   Box " + CR$



 CASE IS = "CIRC"


 CASE IS = "DUAL"
  OPEN "COM1:19200,N,8,1" FOR RANDOM AS #1
  DUAL = 1

 CASE IS = "TONOFF", "QUIT", "HALT"

 TON1 = 0
 TON2 = 0
 TON3 = 0
 TON4 = 0

 CASE IS = "TONE"
  TON1 = V1
 CASE IS = "TONE1"
  TON2 = V1
 CASE IS = "TONE2"
  TON3 = V1
 CASE IS = "TONE3"
  TON4 = V1
 CASE IS = "TONE4"
  TON5 = V1
 CASE IS = "TONE5"
  TON6 = V1

 CASE IS = "ADDWORD"
  'CALL BUILDHBASE
 CASE IS = "HEB"

  htext$ = P1$
 CASE IS = "L", "LINE"



IF DUAL = 1 THEN

PRINT #1, "L" + STR$(V1) + STR$(V2) + STR$(V3) + STR$(V4) + STR$(V5) + CHR$(13)
DO

 IF LOC(1) <> 0 THEN INPUT #1, A$


LOOP UNTIL LOC(1) = 0 AND A$ = "GO"



END IF

 CASE IS = "CIRCLE", "CIRC", "C"
    CIRCLE (V1, V2), V3, V4

IF DUAL = 1 THEN

PRINT #1, "C" + STR$(V1) + STR$(V2) + STR$(V3) + STR$(V4) + CHR$(13)
DO

 IF LOC(1) <> 0 THEN INPUT #1, A$


LOOP UNTIL LOC(1) = 0 AND A$ = "GO"



END IF

 CASE IS = "CAD"
 CLOSE #1
 OPEN ROOT$ + "CADOBJ.DAT" FOR OUTPUT AS #1
 PRINT "BUILDING CAD DATA"

 PRINT #1, swth / 2
 PRINT #1, shht / 2
 PRINT #1, CHR$(34) + P1$ + CHR$(34)
 CLOSE #1
 CHAIN ROOT$ + "QBCAD.BAS"


 CASE IS = "BASIC"

 CASE IS = "GOTO"
  LNGOTO = VAL(P1$)



 CASE IS = "CLS"
 CLS

 CASE IS = "RUN"

  CALL PROGRUN

 CASE IS = "SAVE"
  CALL SVPROGRAM(P1$)


 CASE IS = "LOAD"
  CALL LDPROGRAM(P1$)


 CASE IS = "SAY"
 'speaker (P1$)
   CLS
 CASE IS = "AUXOUT"
  IF auxsp > 0 THEN PRINT #12, P1$


 CASE IS = "EXIT", "REBOOT"

  'CALL SAVESET
    

  CLS

  PRINT " REBOOT WILL TAKE YOU TO CoCoROM"
  INPUT " EXIT TO DOS OR MS WINDOWS "; choice$

   choice$ = UCASE$(choice$)

   SELECT CASE (choice$)
    CASE IS = "DOS"
    SYSTEM

    CASE IS = "REBOOT"
    CLS
    PRINT "GOING INTO COCO ROM"
    PRINT "PLEASE WAIT..."

    RUN "C:\QBASIC\COCOROM.BAS"

   END SELECT


 CASE IS = "QBASIC"
  CLS

  PRINT " EXITING TO QBASIC ... "
  END
 CASE IS = "SCREEN"
  SCREEN VAL(P1$)

 CASE IS = "LPRINT"
     IF LP1 = 1 THEN PRINT #8, SUFFIX$

 IF prnbr = 0 THEN LPRINT P1$

 SELECT CASE (prnsd$)
 CASE IS = "S"
 prnouttext$ = P1$
 CASE IS = "P"
 LPRINT P1$


 CASE IS = "CLS"
 CLS

 CASE IS = "COPYOS"
 RUN "c:\qbasic\cocorom.bas"



 CASE IS = "SCREENSAVER"
  RUN "c:\qbasic\SCREENS.BAS"


 CASE IS = "VGA"
 'CALL VGA

 CASE IS = "REMOTE"
  'CALL REMOTE

 CASE IS = "LIST"

  CALL lstprog
  IF P1$ <> "" THEN CALL FILELIST(P1$)
 CASE IS = "RS232", "MODEM"
   'CALL RS232



 END SELECT


 CASE IS = "CLOCK"
 CLS
 PRINT " getting clock ...."
 PRINT "       please wait"
 'CALL diskgr
 RUN "C:\QBASIC\clock1.bas"



 CASE IS = "BEEP"
 BEEP
 CASE IS = "FILES"
   CHDIR "C:\QBASIC"

   SHELL "DIR *.COB"
   SLEEP

 CASE IS = "DIR"
 CLS
 FILES
 SLEEP
 CLS
 CASE IS = "DISKCOPY"
 RUN "C:\QBASIC\DISKCOPY.BAS"

 CASE IS = "PLAY"
  PLAY P1$

 CASE IS = "DRAW"
  DRAW P1$
 CASE IS = "SHELL"
  SHELL P1$
  PRINT " ### DONE  ### "

  SLEEP
  CLS
  PRINT "PLEASE WAIT..."

  CASE IS = "WINDOWS", "GUI", "OS9"
  RUN "C:\QBASIC\QBWIN01.BAS"


 CASE IS = "DDRAW"

  OPEN ROOT$ + P1$ + ".DRW" FOR INPUT AS #1
   INPUT #1, A$
 
   
   DRAW "BM0,0BR" + STR$(V2) + "BD" + STR$(V3) + "C" + STR$(V4) + A$

  CLOSE #1
 CASE IS = "FILES"
  SHELL "DIR/W *.DRW"


 END SELECT




 TEXT$ = ""
 ' 10, 1: PRINT STRING$(20, " ")

END IF
END SUB

SUB mouse (CX, dx, BX)
        
        
       

           POKE VARPTR(A(4)), &H92           'Swap code,Get CX setup
          CALL absolute(CX, VARPTR(A(0)))     'Run Code
              CX = CX                     'Adjust 25x80
           POKE VARPTR(A(4)), &H91           'Swap code,Get DX setup
          CALL absolute(dx, VARPTR(A(0)))     'Run Code
              dx = dx                     'Adjust 25x80
           POKE VARPTR(A(4)), &H93           'Swap code,Get BX setup
          CALL absolute(BX, VARPTR(A(0)))     'Run Code
END SUB

SUB MousePointer (SW)
        
           POKE VARPTR(A(0)) + 1, SW         'Swap code,Set AX = (SW)
          CALL absolute(C, VARPTR(A(0)))     'Run Code

                                          'Note:
                                             'SW = 0-reset
                                             'SW = 1-on
                                             'SW = 2-off
                                             'SW = 3-coordinates


END SUB

SUB mPP (HH, VV, H1, V1, note$, nt$, n, o, tim, B)
       
      CALL mouse(CX, BX, dx)
           cur$ = CHR$(177)
    'LOCATE 20, 1: PRINT dx

       IF dx = 1 OR dx = 2 THEN
       
         IF dx = 1 THEN cur$ = CHR$(221)
         IF dx = 2 THEN cur$ = CHR$(222)

        IF dx = 2 THEN EX = 1 ELSE EX = 0

        SELECT CASE (VV)
        
         CASE IS = (5)
          n = 95: o = 3 + EX
        
        
         CASE IS = (6)
          n = 135: o = 3 + EX

         CASE IS = (7)
         
           n = 175: o = 3 + EX
         CASE IS = (8)
         
           n = 205: o = 3 + EX
         CASE IS = (9)
         
           n = 255: o = 3 + EX
         CASE IS = (10)
          
           n = 35: o = 4 + EX
         CASE IS = (11)
          
           n = 75: o = 4 + EX
         CASE IS = (12)
          
           n = 95: o = 4 + EX
         CASE IS = (13)
          
           n = 125: o = 4 + EX
         CASE IS = (14)
          
           n = 175: o = 4 + EX
         CASE IS = (15)
          note$ = "F"
           n = 195: o = 4 + EX
         CASE IS = (16)
          
           n = 255: o = 4 + EX
         CASE IS = (17)
           n = 35: o = 5 + EX
         CASE IS = (18)
          n = 75: o = 5 + EX
        
         CASE IS = (19)
          n = 95: o = 5 + EX
        
      

       END SELECT
       
           note$ = CHR$(SCREEN(VV, 1))
       
  END IF


       HH = CX
       VV = BX
    
    
       VV = CX / 8
       HH = BX / 8


       IF HH < 1 THEN HH = 1
       IF VV < 1 THEN VV = 1
    
       IF HH > 79 THEN HH = 79
       IF VV > 23 THEN VV = 23
       
        rc = INT(RND(1) * (14)) + 1
         COLOR curc, rc
       LOCATE VV, HH
        PRINT cur$;


       IF V1 <> (VV) OR H1 <> (HH) THEN

       LOCATE V1, H1
     


       COLOR Bgnd, Bgnd, 0
       PRINT " ";
       END IF
           CALL retscr

  IF dx = 0 THEN note$ = " ": nt$ = " ": B = 0 ELSE B = 1: cur$ = CHR$(178)



      


END SUB

SUB playsg (cplc)


cplc = cplc + 1
IF cplc > (plc) THEN cplc = 0

n = songdb(cplc, 0): o = songdb(cplc, 1): TD = songdb(cplc, 2)

octave = o
CALL playt(n, octave)

ddy = 0
RANDOMIZE TIMER
ddy = 0
DO

CALL sec

 ddy = ddy + 1

LOOP UNTIL ddy >= (TD)



END SUB

SUB playt (n, octave)

       FOR j = 0 TO 2
      SetReg &HA0 + j, n 'Set note number
      SetReg &HB0 + j, &H21 + 4 * octave 'Set octave and switch on channel
       NEXT j

END SUB

SUB PROGRUN
REM
REM
REM RUN THE PROGRAM

XX = 1
BREAK = 0

DO
IF LNGOTO > 0 THEN XX = LNGOTO: LNGOTO = 0
 A$ = INKEY$
IF A$ = CHR$(0) + CHR$(134) THEN BREAK = 1: PRINT : PRINT "BREAK AT LINE "; XX

 CMD$ = PROGRAMARRY$(XX)



 'PRINT "### {"; CMD$; "}"
 CALL MODELPROC(CMD$)



 XX = XX + 1
LOOP UNTIL BREAK = 1 OR XX >= 1000 OR XX > (PROGLENGTH)




SLEEP

END SUB

SUB retscr
COLOR Bgnd, Fgnd, Border


END SUB

SUB sec

FOR y = 0 TO (slim)

KE$ = INKEY$
 KE$ = UCASE$(KE$)

 IF KE$ = "S" THEN
  y = slim
  rec$ = "Stop"
 END IF

NEXT y

END SUB

SUB SetReg (Reg, Value)
OUT RegAddr, Reg
OUT DataAddr, Value
END SUB

SUB spmenu
COLOR 1, 0, 1
CLS

INPUT "Playback Speed "; slim

CALL doscr
END SUB

SUB START
SCREEN 0
CLS

st:



LOCATE 3, 6: PRINT STRING$(19, "#")
LOCATE 4, 7: PRINT "# Qbasic 1.1      #"
LOCATE 5, 8: PRINT "#  sound Card FM  #"
LOCATE 6, 9: PRINT "#  L.A.B.         #"
LOCATE 7, 10: PRINT STRING$(19, "#")


LOCATE 10, 12: PRINT "press <C> to start."
LOCATE 11, 13: PRINT " <I> for instructions"
   DO
    KE$ = INKEY$

     IF KE$ = "I" THEN CALL hlp: GOTO st

   LOOP UNTIL KE$ = "C"

END SUB

SUB SVPROGRAM (P1$)


PRINT "PROGRAM LENGTH"
PRINT PROGLENGTH

Z$ = P1$

IF RIGHT$(Z$, 4) <> ".COB" THEN Z$ = Z$ + ".COB"

OPEN "c:\qbasic\" + Z$ FOR OUTPUT AS #9
x = 1
DO

 PRINT #9, PROGRAMARRY$(x)
  x = x + 1
LOOP UNTIL x > (PROGLENGTH)

CLOSE #9

PRINT "DONE"
PRINT " SAVING "; Z$

SLEEP
END SUB

SUB waitp

  FOR j = 0 TO 2
    SetReg &HB0 + j, 0 'Switch channel off
  NEXT j

END SUB

