'
' SPROGH:A SPIROGRAPH SIMULATOR BY PHIL PAUSTIAN
'
'       VERSION 3.2
'       COPYRIGHT 1989
'
' PROGRAM INDEX                STARTS ON LINE
'    INTRODUCTORY SCREEN...................40
'    DRAW INITIAL MENU....................120
'    SET MENU.............................142
'    COMMAND CHOOSING.....................177
'    SET DISK GEARS.......................185
'    SET RING GEARS.......................210
'    SET PEN POSITION.....................235
'    MOVE.................................250
'    SIZE.................................300
'    TURN.................................340
'    OVAL.................................350
'    HUE (LINE COLOR).....................360
'    WIPE (PAINT FILL)....................370
'    FORM (GEARS OR DEGREES)..............430
'    LOAD/SAVE............................440
'    INITIALIZE (RESET VARIABLES).........515
'    VERSION..............................525
'    EXAMPLES.............................550
'    AGAIN (MACRO COMMANDS)...............582
'    BLANK MENU...........................610
'    CLEAR SCREEN.........................615
'    GO  (DRAW DESIGN)....................620
'    QUIT.................................705
'    ERROR TRAPPPING (FILE INPUT).........750
'    LOGO.................................787
'    NUMBER INPUT SUBROUTINE..............820
'    WORD INPUT SUBROUTINE................885
'    MACRO INPUT (AGAIN COMMAND)..........932
'    WIPE: COLOR CHANGES SUBROUTINE.......940
'    TILE PATTERNS........................992
'    END.................................1106

'    Intro Screen
' INITIALIZE VARIABLES AND DRAW SAMPLE IMAGE
$STACK &H4000
SCREEN 2:KEY OFF:CLS
WINDOW SCREEN (-150,-100)-(150,110)
PI=ATN(1)/45:DSKANGL=-12*PI:RNGANGL=9.5*PI
GDTOGL%=1:PENINPUT=.55:CIR=360*PI:REP%=1
SIZOPT%=0:SIZOPT$="auto "
OVALNESS=1.7:ROTAT=0:MOVHORIZ=0
MOVVERT=0:SIZ=1.25:HUE%=1:ZERO=.01:WD=4:HG=8.4
DIM WNDW%(3500), BLANKLINE%(1000), MENUWNDW%(3500), TILER%(5)
DIM REFRESHA%(15000), CROSSHAIRS%(100), TILE$(150)
GET (-150,102)-(150,110),BLANKLINE%
SEE$=COMMAND$:IF SEE$<>"" THEN GOTO SCRENE

INTROSCREEN:
GET (-150,-100)-(150,100),REFRESHA%
CLS:STOG=ABS(STOG-1)
LINE (-148,-98)-(146,99),,B
LINE (-146,-100)-(148,97),,B
IF STOG=1 THEN S1=5.3:S2=-55:S3=12:S4=-34 ELSE S1=4:S2=-40:S3=8:S4=-24
GOSUB LOGO

LOCATE 23,3:PRINT "by Phil Paustian"
LOCATE 23,55:PRINT "Press any key to begin";
GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%

'   DRAW TWO SAMPLE DESIGNS
DSKANGL=-DSKANGL:PENINPUT=ABS(PENINPUT-1.4):KY$="G":GOTO SET

SCRENE:
'   INPUT SCREEN TYPE
DEF SEG=&H40:SCRNTYPE=PEEK(&H10) AND 48
IF SCRNTYPE=48 THEN
   SCREEN 2: FILESIZ=40000:DEF SEG=&HB000:EXT$=".HRC":LINELENGTH%=76
ELSE
   IF SEE$<>"" THEN
     SCRN$=MID$(SEE$,LEN(SEE$)-3,2)
     IF SCRN$=".C" OR SCRN$=".M" THEN SCRN$=RIGHT$(SCRN$,1):GOTO 1
   END IF
   LOCATE 23,55:PRINT "(C)olor or (M)onochrome?";
   WHILE NOT INSTAT:WEND:KK$=INKEY$
   SCRN$=UCASE$(KK$):IF SCRN$<>"C" AND SCRN$<>"M" THEN GOTO SCRENE
1  IF SCRN$="C" THEN
       SCREEN 1,0:FILESIZ=16384
       DEF SEG=&HB800:EXT$=".COL":WD=7:LINELENGTH%=36
   ELSE
       SCREEN 2:FILESIZ=16384
       DEF SEG=&HB800:EXT$=".MON":LINELENGTH%=76
   END IF
END IF
WINDOW SCREEN (-150,-100)-(150,110):CLS
GET (-150,102)-(150,110),BLANKLINE%
GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
IF SCRN$="C" THEN
 GET (-150,-100)-(150,100),REFRESHA%
END IF
' DRAW CROSSHAIRS FOR USE IN MOVING THE CENTER OF THE DESIGN
LINE (-148,-93)-(-138,-93):LINE (-143,-98)-(-143,-88)
CIRCLE (-143,-93),5
GET (-150,-100)-(-137,-87),CROSSHAIRS%:PUT (-150,-100),CROSSHAIRS%
IF SEE$<>"" THEN
 FIL$=SEE$
 GOSUB FILEXIST
 IF FILECONTINUE=1 THEN
  BLOAD SEE$,0
  GET (-150,-100)-(150,100),REFRESHA%
  GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
  WHILE NOT INSTAT:WEND:KK$=INKEY$
  PUT (-150,-100),WNDW%
 END IF
  PUT (-150,102),BLANKLINE%,PSET
END IF
'    REINITIALIZE VARIABLES
LOCATED$="":SIZ=1:PENPOS=1:RATIO=1:SAMPLE%=0:SAMPL%=0:REP%=0
IF SEE$="" THEN FIL$="SPIRO1"+EXT$
OVALNESS=1:DSKANGL=0:RNGANGL=0:MENU%=1:PENINPUT=1

LOCATE 25,1:PRINT "Hit Command Letter:";

'    PRINTING THE MENU
LINE (-150,-100)-(14*WD-150,24*HG-104),,B
LINE (-148,-98)-(14*WD-148,24*HG-102),,B
LOCATE 2,2:PRINT "Disk"
LOCATE 4,2:PRINT "Ring"
LOCATE 6,2:PRINT "Pen position"
LOCATE 8,2:PRINT "Move center"
LOCATE 10,2:PRINT "Size:"
LOCATE 12,2:PRINT "Turn:"
LOCATE 13,2:PRINT "Oval:"
LOCATE 14,2:PRINT "Hue:"
LOCATE 15,2:PRINT "Form:"
LOCATE 16,2:PRINT "Again"
LOCATE 17,2:PRINT "Wipe"
LOCATE 18,2:PRINT "Load/save"
LOCATE 19,2:PRINT "Examples"
LOCATE 20,2:PRINT "Blank menu"
LOCATE 21,2:PRINT "Clear screen"
LOCATE 22,2:PRINT "Go"
LOCATE 23,2:PRINT "Quit";
GET (-150,-100)-(14*WD-146,24*HG-100),MENUWNDW%

STARTING:
IF MENU%=1 THEN
  PUT (-150,-100),MENUWNDW%,PSET
  IF GDTOGL%=1 THEN
    LOCATE 2,7:PRINT "gears"
    LOCATE 3,3:PRINT FIX((DSKGR+.001*SGN(DSKGR))*100)/100
    LOCATE 4,7:PRINT "gears"
    LOCATE 5,3:PRINT FIX((RNGGEAR+.001*SGN(RNGGEAR))*100)/100
  ELSE
    RATIO=1
    LOCATE 2,7:PRINT "degrees"
    LOCATE 3,3:PRINT FIX((DSKDEG+.001*SGN(DSKDEG))*100)/100
    LOCATE 4,7:PRINT "degrees"
    LOCATE 5,3:PRINT FIX((RNGDEG+.001*SGN(RNGDEG))*100)/100
  END IF
    LOCATE 7,3:PRINT FIX((PENINPUT+.001*SGN(PENINPUT))*100)/100
    LOCATE 9,4:PRINT LOCATED$
    IF GDTOGL%=1 THEN
      IF DSKANGL*RNGANGL<>0 THEN RATIO=DSKANGL/RNGANGL
      IF RATIO<>-1 THEN PENPOS=PENINPUT/(RATIO+1)*RATIO ELSE PENPOS=-PENINPUT
    ELSE
      RATIO=1:PENPOS=PENINPUT
    END IF
   LOCATE 10,7:PRINT SIZOPT$
   LOCATE 11,3:PRINT FIX((SIZ+.001*SGN(SIZ))*100)/100
   LOCATE 12,7:PRINT FIX((ROTAT+.001*SGN(ROTAT))*100)/100
   LOCATE 13,7:PRINT FIX((OVALNESS+.001*SGN(OVALNESS))*100)/100
   LOCATE 14,6:PRINT INT(HUE%)
   IF GDTOGL%=0 THEN
    LOCATE 15,7:PRINT "degrees"
   ELSE
    LOCATE 15,7:PRINT "gears"
   END IF
END IF

'   SEND THE PROGRAM TO THE APPROPRIATE ROUTINE
WHILE NOT INSTAT:WEND
KY$=UCASE$(INKEY$)
SET:
KOUT$=INKEY$
IF KOUT$=CHR$(27) THEN REP%=0:GOTO STARTING
SELECT CASE KY$

CASE ="D"
'      DISK SUBROUTINE
' THIS MUST BE SET TO ANY NUMBER EXCEPT 0 BEFORE YOU CAN DRAW A DESIGN.
' SEE THE 'EXAMPLES' COMMAND FOR SOME POSSIBLE SETTINGS.  SEE THE 'FORM'
' COMMAND FOR THE DIFFERENCES BETWEEN INPUTTING  BY 'DISK GEARS' AND
' INPUTTING BY 'DISK DEGREES.'
 IF GDTOGL%=1 THEN
    PROMP$="Disk gears ["+STR$(FIX((DSKGR+.001*SGN(DSKGR))*100)/100)+"]: "
    DEFAU$=STR$(DSKGR):GOSUB INNUM
    IF ABORT%=1 THEN GOTO STARTING
    IF PLUS%=1 THEN ASKNUM=ASKNUM+DSKGR
    IF ASKNUM<>0 THEN DSKGR=ASKNUM:DSKDEG=360/DSKGR:DSKANGL=-DSKDEG*PI
 ELSE
    PROMP$="Disk degrees ["+STR$(FIX((DSKDEG+.001*SGN(DSKDEG))*100)/100)+"]: "
    DEFAU$=STR$(DSKDEG)
    GOSUB INNUM
    IF ABORT%=1 THEN GOTO STARTING
    IF PLUS%=1 THEN ASKNUM=ASKNUM+DSKDEG
    IF ASKNUM<>0 AND ABS(ASKNUM)<32768 THEN
     IF ASKNUM=>360 THEN ASKNUM=(ASKNUM/360-INT(ASKNUM/360))*360
     IF ASKNUM<>0 THEN DSKDEG=ASKNUM
     DSKGR=360/DSKDEG:DSKANGL=DSKDEG*PI
    END IF
 END IF

CASE ="R"
'      RING SUBROUTINE
' THIS MUST BE SET AT ANY NUMBER OTHER THAN 0 BEFORE YOU CAN DRAW A DESIGN
' SEE THE 'FORM' COMMAND FOR THE DIFFERENCES BETWEEN INPUT BY GEARS AND
' INPUT BY DEGREES
 IF GDTOGL%=1 THEN
   PROMP$="Ring gears ["+STR$(FIX((RNGGEAR+.001*SGN(RNGGEAR))*100)/100)+"]: "
   DEFAU$=STR$(RNGGEAR)
   GOSUB INNUM
   IF ABORT%=1 THEN GOTO STARTING
   IF PLUS%=1 THEN ASKNUM=ASKNUM+RNGGEAR
   IF ASKNUM<>0 THEN RNGGEAR=ASKNUM:RNGDEG=360/RNGGEAR:RNGANGL=RNGDEG*PI
 ELSE
   PROMP$="Ring degrees ["+STR$(FIX((RNGDEG+.001*SGN(RNGDEG))*100)/100)+"]: "
   DEFAU$=STR$(RNGDEG)
   GOSUB INNUM
   IF ABORT%=1 THEN GOTO STARTING
   IF PLUS%=1 THEN ASKNUM=ASKNUM+RNGDEG
   IF ASKNUM<>0 AND ABS(ASKNUM)<32768 THEN
    IF ASKNUM=>360 THEN ASKNUM=(ASKNUM/360-INT(ASKNUM/360))*360
    IF ASKNUM<>0 THEN RNGDEG=ASKNUM
    RNGGEAR=360/RNGDEG:RNGANGL=RNGDEG*PI
   END IF
 END IF

CASE ="P"
'      PEN POSITION SUBROUTINE
' WHEN PENINPUT IS 0 THE PEN SITS AT THE CENTER OF THE DISK.  WHEN PEN IS
' SET AT 1 THE PEN SITS AT THE EDGE OF THE DISK.  YOU CAN SET THE PEN
' ANYWHERE BETWEEN THOSE TWO POINTS, OR EVEN SET IT OUTSIDE THE DISK WITH
' NUMBERS GREATER THAN 1
 PROMP$="Pen position ["+STR$(FIX((PENINPUT+.001*SGN(PENINPUT))*100)/100)+"]: "
 DEFAU$=STR$(PENINPUT)
 GOSUB INNUM
 IF ABORT%=1 THEN GOTO STARTING
 IF PLUS%=1 THEN ASKNUM=ASKNUM+PENINPUT
 PENINPUT=ASKNUM



CASE ="M"
'      MOVE SUBROUTINE
 PUT (-150,-100),WNDW%,PSET
 IF REP%=0 THEN PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%
 PROMP$=LOCATED$+":Move (U,D,L,R)? "
 DEFAU$=""
 CHOIC$="UDLR"
 GOSUB INWORD
 IF ABORT%=1 THEN
   IF REP%=0 THEN PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%
   GOTO STARTING
 END IF
 PROMP$=""
 SELECT CASE ASKWRD$
        CASE ="U"
        PROMP$="up"
        CASE ="D"
        PROMP$="down"
        CASE ="L"
        PROMP$="left"
        CASE ="R"
        PROMP$="right"
 END SELECT
 IF PROMP$="" THEN
  IF REP%=0 THEN PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%
  GOTO STARTING
 END IF
 PROMP$=LOCATED$+":How far? ("+PROMP$+") "
 DEFAU$=""
 GOSUB INNUM
 IF REP%=0 THEN PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%
 IF ABORT%=1 THEN GOTO STARTING
 SELECT CASE ASKWRD$
        CASE ="U"
         IF ABS(MOVVERT-ASKNUM)<91 THEN MOVVERT=MOVVERT-ASKNUM
        CASE ="D"
	 IF ABS(MOVVERT+ASKNUM)<91 THEN MOVVERT=MOVVERT+ASKNUM
        CASE ="L"
         IF ABS(MOVHORIZ-ASKNUM)<141 THEN MOVHORIZ=MOVHORIZ-ASKNUM
        CASE ="R"
         IF ABS(MOVHORIZ+ASKNUM)<141 THEN MOVHORIZ=MOVHORIZ+ASKNUM
 END SELECT
 IF REP%=0 THEN PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%
 LOCATED$=""
 IF MOVVERT<0 THEN LOCATED$="U"+STR$(ABS(MOVVERT))+" "
 IF MOVVERT>0 THEN LOCATED$="D"+STR$(MOVVERT)+" "
 IF MOVHORIZ<0 THEN LOCATED$=LOCATED$+"L"+STR$(ABS(MOVHORIZ))+" "
 IF MOVHORIZ>0 THEN LOCATED$=LOCATED$+"R"+STR$(MOVHORIZ)+" "
 IF REP%=0 THEN DELAY 1:PUT (MOVHORIZ-7,MOVVERT-7),CROSSHAIRS%

CASE ="S"
'      SIZE SUBROUTINE
' "AUTO" CALCULATES SIZE AUTOMATICALLY ACCORDING TO THE SCALE SET BY 'SIZ'
' "FIXED" FIXES THE RING AT ITS CURRENT POSITION ON THE SCREEN SO THAT ALL
'   SUBSEQUENT DRAWINGS WILL BE SCALED TO FIT AROUND IT
' "NESTED" DETERMINES THE SIZE OF THE HOLE IN THE MIDDLE OF THE SCREEN AND
'   ADJUSTS 'SIZ' TO FIT SUBSEQUENT DRAWINGS INSIDE
'   NESTED RESETS TO THE "AUTO" SETTING
  PROMP$="Auto, Fixed or Nested ["+SIZOPT$+"]:"
  CHOIC$="AFN"
  DEFAU$=""
  GOSUB INWORD
  IF ABORT%=1 THEN GOTO STARTING
  SELECT CASE ASKWRD$
   CASE ="A"
    SIZOPT%=0:SIZOPT$="auto "
    PROMP$="Size ["+STR$(FIX((SIZ+.001*SGN(SIZ))*100)/100)+"]:"
    DEFAU$=STR$(SIZ)
    GOSUB INNUM
    IF ABORT%=1 THEN GOTO STARTING
    IF ASKNUM<>0 THEN SIZ=ASKNUM+SIZ*PLUS%
   CASE ="F"
    IF SIZOPT%=0 THEN
      SIZOPT%=1:SIZOPT$="fixed"
      SIGN=SGN(DSKANGL)*SGN(RNGANGL)
      IF PENINPUT=0 THEN PENINPUT=.001
      LINEUP=(ABS(RATIO)-ABS(PENPOS/PENINPUT)*SIGN)/(ABS(RATIO)+ABS(PENPOS))
    END IF
   CASE ="N"
    IF SIZOPT%=1 THEN
      SIGN=SGN(DSKANGL)*SGN(RNGANGL)
      IF PENINPUT=0 THEN PENINPUT=.001
      NEWLINEUP=(ABS(RATIO)-ABS(PENPOS/PENINPUT)*SIGN)/(ABS(RATIO)+ABS(PENPOS))
      FIXLINEUP=LINEUP/NEWLINEUP
    END IF
    NEST=(ABS(RATIO)-ABS(PENPOS))/(ABS(RATIO)+ABS(PENPOS))
    IF SIZOPT%=1 THEN NEST=FIXLINEUP*NEST
    SIZOPT%=0:SIZOPT$="auto ":SIZ=SIZ*NEST
  END SELECT

CASE ="T"
'      TURN SUBROUTINE
' SETS ROTAT AS THE STARTING ROTATION OF THE RING, INPUT BY THE NUMBER OF
' DEGREES TO TURN, WHEN SET AT 999, DRAWING CONTINUES FROM WHERE STOPPED IT
 PROMP$="Turn ["+STR$(FIX((ROTAT+.001*SGN(ROTAT))*100)/100)+"]: "
 DEFAU$=STR$(ROTAT):GOSUB INNUM
 IF ABORT%=1 THEN GOTO STARTING
 IF PLUS%=1 THEN ASKNUM=ASKNUM+ROTAT
 ROTAT=ASKNUM

CASE ="O"
'      OVAL SUBROUTINE
' AN OVALNESS GREATER THAN 1 MAKES THE IMAGE THE NORMAL WIDTH, BUT DIVIDES
' HEIGHT BY OVALNESS GIVING YOU A WIDE, SHORT OVAL.  AN OVALNESS LESS THAN
' ONE MULTIPLIES THE WIDTH BY OVALNESS, GIVING YOU A TALL, NARROW OVAL
 PROMP$="Oval ["+STR$(FIX((OVALNESS+.001*SGN(OVALNESS))*100)/100)+"]: "
 DEFAU$=STR$(OVALNESS):GOSUB INNUM
 IF ABORT%=1 THEN GOTO STARTING
 OVALNESS=ASKNUM+OVALNESS*PLUS%

CASE ="H"
'      HUE SUBROUTINE
' IN MONOCHROME ODD NUMBERS DRAW IN WHITE, EVEN NUMBERS IN BLACK
' IN COLOR IT IS UNTESTED, SINCE I USE A HERCULES MONITOR
 PROMP$="Hue ["+STR$(INT(HUE%+.001))+"]: "
 DEFAU$=STR$(HUE%):GOSUB INNUM
 IF ABORT%=1 THEN GOTO STARTING
 HUE%=ASKNUM+HUE%*PLUS%:WHILE HUE%>255:HUE%=HUE%-256:WEND
 IF EXT$=".COL" THEN COL=HUE% MOD 7:COLOR ,INT(COL/3.6)

CASE ="W"
 '     WIPE
 'PAINT SUBROUTINE: PAINTS AT CROSSHAIRS
 'ENTER NUMBER OF COLOR OR PATTERN (0-99),
 'OR, AFTER ENTERING A NEGATIVE NUMBER, ENTER A SERIES
 'OF NUMBERS TO INDICATE USER-DEFINED PATTERN
 TILECOLOR%=0:PUT (-150,-100),WNDW%,PSET
 PROMP$="Wipe color? (0-99) ":DEFAU$=STR$(WIPED%):
 GOSUB INNUM
 IF ABORT%=1 THEN GOTO STARTING
 WIPE%=ASKNUM+WIPE%*PLUS%:PROMP$="Pattern? ":WIPED%=WIPE%
 IF WIPE%>9 THEN
   IF TILE$(10)="" THEN
    PUT (-150,102),BLANKLINE%,PSET
    LOCATE 25,1:PRINT "Loading Patterns...";
    FOR X=10 TO 150:READ Y
     WHILE Y<>999
      IF Y=-1 THEN GOTO JUMPOUT
      TILE$(X)=TILE$(X)+CHR$(Y)
      READ Y
     WEND
    NEXT X
   END IF
   JUMPOUT:
   IF WIPE%>100 THEN TILECOLOR%=INT(WIPE%/100):WIPE%=WIPE% MOD 100
   IF WIPE%<>9 THEN WIPE$=TILE$(WIPE%)
 END IF
 IF WIPE%<0 THEN
   WIPE$="":WIPENUM%=0
   WHILE WIPENUM%<256
   DEFAU$=STR$(WIPENUM%):GOSUB INNUM
   IF ABORT%=1 AND NONUM%=0 THEN GOTO STARTING
   IF NONUM%=1 THEN ASKNUM=999
   WIPENUM%=ASKNUM+WIPENUM%*PLUS%
   IF WIPENUM%<0 THEN
     WIPE$=OLDWIPE$:OLDPROMP$="Pattern? "
     FOR X=1 TO LEN(WIPE$)
     OLDPART$=STR$(ASC(MID$(WIPE$,X,1)))
     OLDPROMP$=OLDPROMP$+MID$(OLDPART$,2,LEN(OLDPART$)-1)+CHR$(249)
     NEXT X:PROMP$=OLDPROMP$
   ELSE
    IF WIPENUM%<256 THEN WIPE$=WIPE$+CHR$(WIPENUM%)
    PROMP$=PROMP$+RIGHT$(STR$(WIPENUM%),LEN(STR$(WIPENUM%))-1)+CHR$(249)
   END IF
   WEND
 END IF
 IF TILECOLOR%<>0 THEN GOSUB COLORTILE
 IF WIPE%<9 AND WIPE%=>0 THEN
  IF EXT$=".COL" THEN COLOR ,INT(WIPE%/4.1)
  ON ERROR GOTO STACKSPACE
  PAINT (MOVHORIZ,MOVVERT),WIPE%,HUE%
 ELSE
  PAINT (MOVHORIZ,MOVVERT),WIPE$,HUE%
  OLDWIPE$=WIPE$
  ON ERROR GOTO 0
 END IF
 GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
 PUT (-150,102),BLANKLINE%,PSET
 LOCATE 25,1:PRINT ">";

CASE ="F"
'      FORM SUBROUTINE
' TOGGLE BETWEEN INPUT BY NUMBER OF GEARS AND INPUT BY NUMBER OF DEGREES
' WHEN FORM IS 'DEGREES' THERE ARE A COUPLE DIFFERENCES IN THE WAY THE IMAGE
' IS DRAWN.  1. THE SIZE OF THE DISK AND RING ARE NOT SET IN PROPORTION
' TO THE NUMBER OF GEARS. 2. THE DISK SIMPLY TURNS X NUMBER OF DEGREES, IT
' DOES NOT ROLL INSIDE THE RING.
 GDTOGL%=ABS(GDTOGL%-1):PUT (-150,102),BLANKLINE%,PSET
 LOCATE 25,1:IF GDTOGL%=1 THEN PRINT "Form:gears"; ELSE PRINT "Form:degrees";

CASE ="L"
'      LOAD/SAVE SUBROUTINE
 IF REP%=1 THEN GOTO REPEAT
 PROMP$="(D)isk or (M)emory?"
 CHOIC$="DM":DEFAU$=""
 GOSUB INWORD
 SCREENSAVE$=ASKWRD$
 SELECT CASE SCREENSAVE$
        CASE ="D"
          PROMP$="(L)oad or (S)ave?"
          CHOIC$="SL"
          DEFAU$=""
          GOSUB INWORD
          IF ABORT%=1 THEN GOTO STARTING
          IF ASKWRD$<>"" THEN
            SL$=ASKWRD$
            PROMP$="File name ["+FIL$+"]: "
            CHOIC$=""
            DEFAU$=FIL$
            GOSUB INWORD
            IF ABORT%=1 THEN GOTO STARTING
            IF ASKWRD$<>"" THEN FIL$=ASKWRD$
            GOSUB FILEXIST
            IF FILECONTINUE=1 THEN
             SELECT CASE SL$
                    CASE ="S"
                      IF MENU%=1 THEN PUT (-150,-100),WNDW%,PSET
                      ON ERROR GOTO CANTSAVE
                      BSAVE FIL$,0,FILESIZ
                      ON ERROR GOTO 0
                    CASE ="L"
                      BLOAD FIL$,0
                      GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
                      WHILE NOT INSTAT:WEND
                      KK$=INKEY$
             END SELECT
            END IF
          END IF
        CASE ="M"
'               VIDEO-REFRESH
           PROMP$="Save or Restore:"
           CHOIC$="SR"
           DEFAU$=""
           GOSUB INWORD
           IF ABORT%=1 THEN GOTO STARTING
           FRESH$=ASKWRD$
           SELECT CASE FRESH$
                  CASE ="S"
                    PUT (-150,-100),WNDW%,PSET
                    GET (-150,-100)-(150,100),REFRESHA%
                  CASE ="R"
                    PROMP$="Restore, Negative, Sum, Icon? "
                    CHOIC$="RNSI"
                    DEFAU$=""
                    GOSUB INWORD
                    IF ABORT%=1 THEN GOTO STARTING
                    PUT (-150,-100),WNDW%,PSET
                    SELECT CASE  ASKWRD$
                           CASE ="R"
                             PUT (-150,-100),REFRESHA%,PSET
                             GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
                           CASE ="N"
                             PUT (-150,-100),REFRESHA%,PRESET
                             GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
                           CASE ="S"
                             PUT (-150,-100),REFRESHA%,OR
                             GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
                           CASE ="I"
                             PUT (-150,-100),REFRESHA%,XOR
                             GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
                    END SELECT
           END SELECT
           IF REP%=2 THEN GOTO REPEAT
 END SELECT

 CASE ="I"
'       INITIALIZE SUBROUTINE, RESETS MOST VARIABLES TO THEIR STARTING VALUES
' DOES NOT EFFECT DISK, RING, FORM, OR AGAIN COMMANDS
 MOVVERT=0:MOVHORIZ=0:ROTAT=0:SIZ=1
 PENPOS=1:RATIO=1:PENINPUT=1:MENU%=1
 OVALNESS=1:HUE%=1:SIZOPT%=0:SIZOPT$="auto"
 LOCATED$="":FIL$="SPIRO1"+EXT$
 PUT (-150,102),BLANKLINE%,PSET
 LOCATE 25,1:PRINT "Initialized!";

  CASE ="V"
 '       VERSION: A BASICALLY USELESS SUBROUTINE
  PUT (-150,-100),WNDW%,PSET:PUT (-150,-100),WNDW%
  LOCATE 3,1:PRINT "SPROGH!"
  LOCATE 5,1:PRINT "version 3.1"
  LOCATE 9,1:PRINT "by"
  LOCATE 10,1:PRINT "Phil Paustian"
  LOCATE 11,1:PRINT "Box 644"
  LOCATE 12,1:PRINT "Terry, MT"
  LOCATE 13,4:PRINT "59349"
  LOCATE 15,2:PRINT "REGISTER"
  LOCATE 16,7:PRINT "NOW!"
  LOCATE 19,1:PRINT "Send $4.37 if"
  LOCATE 20,1:PRINT "you enjoyed"
  LOCATE 21,1:PRINT "this program."
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT "Press any key to continue";
  WHILE NOT INSTAT:WEND:V$=INKEY$
  PUT (-150,-100),WNDW%,PSET

CASE ="Z"
'      ZERO: DOES NOTHING BUT WAITS ONE SECOND AND BEEPS
' THE ONLY CONCEIVABLE USE IS TO PUT A DELAY INTO "AGAIN" COMMANDS
  DELAY 1:SOUND 100,4

CASE ="E"
' EXAMPLES SUBROUTINE
 IF GDTOGL%=1 THEN
   SELECT CASE SAMPLE%
   CASE =0
     CLS:GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
INMACRO$="ID16R72P.4GP.5H3GP.6H5GSNT+20H7GP.8H1GP1H3GSNP1.5H5GP2.1H7GP2.7H1G"
     MACRO$=INMACRO$:MACRO%=1:REP%=2
   CASE =1
     REP%=2:MACRO%=11:PENINPUT=1.1:SIZOPT%=0:SIZOPT$="auto ":siz=1
     CLS:GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
     INMACRO$="D40R60SFP+-.1G":MACRO$=INMACRO$
   CASE =2
     PENINPUT=.4:ROTAT=-3:REP%=2
     CLS:GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
     INMACRO$="D20R60SA1T+3P+.05G":REP%=2:MACRO%=30:MACRO$=INMACRO$
   END SELECT
   SAMPLE%=SAMPLE%+1:IF SAMPLE%>2 THEN SAMPLE%=0
  ELSE
   ROTAT=0:REP%=2:MACRO%=1
   SELECT CASE SAMPL%
   CASE =0
    INMACRO$="ID124R2P.9CGZD2R60P1H3CGZE":MACRO$=INMACRO$
   CASE =1
    INMACRO$="D58R266P1H7CGZD141R141H1CGW93MR135W93ML135ZE":MACRO$=INMACRO$
   CASE =2
    INMACRO$="LMRNH0D44R278SA1.5O1.5LMRSGZD4R93LMRNLMRSGZE":MACRO$=INMACRO$
   END SELECT
   SAMPL%=SAMPL%+1:IF SAMPL%>2 THEN SAMPL%=0
  END IF
  GOTO REPEAT

CASE ="A"
'    AGAIN SUBROUTINE
' ALLOWS INPUT OF MACRO$ FOR AUTOMATIC REPETITION OF COMMANDS
' AN 'A' ANYWHERE WITHIN MACRO$ WILL RESET MACRO$ AND PUT YOU
' IN AN ENDLESS LOOP (HITTING ESCAPE, OR ANY KEY WILL END LOOP)
 IF REP%=2 THEN MACRO$=INMACRO$:GOTO REPEAT
 PROMP$="AGAIN:":CHOIC$="":DEFAU$=INMACRO$
 GOSUB INWORD
 IF ABORT%=1 THEN GOTO STARTING
 IF ASKWRD$<>"" THEN INMACRO$=ASKWRD$
 MACRO$=INMACRO$
 IF MACRO$<>"" THEN
   IF RIGHT$(MACRO$,1)="A" THEN LOOPA=1 ELSE LOOPA=0
   IF LOOPA=0 THEN
     PROMP$="HOW MANY TIMES? "
     DEFAU$=""
     GOSUB INNUM
     IF ABORT%=1 THEN GOTO STARTING
     IF ASKNUM<>0 THEN MACRO%=ASKNUM:REP%=2:GOTO REPEAT
   ELSE
     PROMP$="Start drawing (Y or N)?"
     CHOIC$="YN":DEFAU$=""
     GOSUB INWORD
     IF ABORT%=1 THEN GOTO STARTING
     IF ASKWRD$="Y" THEN MACRO%=1:REP%=2:GOTO REPEAT
   END IF
 END IF

CASE ="B"
'    BLANK SCREEN SUBROUTINE
' TOGGLE THAT DETERMINES IF MENU IS TO BE PRINTED ON LEFT SIDE OF SCREEN
 MENU%=ABS(MENU%-1):IF MENU%=0 THEN PUT (-150,-100),WNDW%,PSET

CASE ="C"
'    CLEAR SCREEN SUBROUTINE
 CLS:GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
 LOCATE 25,1:PRINT ">";

CASE ="G"
'    GO SUBROUTINE, THIS SECTION DOES ALL THE DRAWING
 IF REP%=2 AND VAL(MACRO$)<>0 THEN
    PROMP$="GO ":GOSUB INNUM:RECOUNT%=ASKNUM
 END IF
 IF DSKANGL*RNGANGL=0 THEN
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT "YOU MUST SET RING AND DISK FIRST";
  GOTO STARTING
 END IF
WHILE ABS(DSKANGL)>CIR:DSKANGL=DSKANGL-CIR*SGN(DSKANGL):WEND
WHILE ABS(RNGANGL)>CIR:RNGANGL=RNGANGL-CIR*SGN(RNGANGL):WEND
 PUT (-150,-100),WNDW%,PSET
 IF GDTOGL%=1 THEN
   RATIO=DSKANGL/RNGANGL
   IF RATIO<>-1 THEN PENPOS=PENINPUT/(RATIO+1)*RATIO ELSE PENPOS=-PENINPUT
 ELSE
   RATIO=1:PENPOS=PENINPUT
 END IF
SIZCONST=100/(ABS(RATIO)+ABS(PENPOS))
IF SIZOPT%=1 THEN
  SIGN=SGN(DSKANGL)*SGN(RNGANGL)
  IF PENINPUT=0 THEN PENINPUT=.001
  NEWLINEUP=(ABS(RATIO)-ABS(PENPOS/PENINPUT)*SIGN)/(ABS(RATIO)+ABS(PENPOS))
  FIXLINEUP=LINEUP/NEWLINEUP
  SIZCONST=SIZCONST*FIXLINEUP
END IF
IF OVALNESS>1 THEN
   OVALWIDE=1/OVALNESS:OVALHIGH=1
ELSE
   OVALWIDE=1:OVALHIGH=OVALNESS
END IF
ROTE=ROTAT
IF ROTE<>999 THEN
  WHILE ROTE>360:ROTE=ROTE-360:WEND
  WHILE ROTE<0:ROTE=ROTE+360:WEND
  DSKPLOT=0:RNGPLOT=ROTE*PI
END IF
IF EXT$=".COL" THEN COL=HUE% MOD 7:COLOR ,INT(COL/3.6)
DSKMEM=DSKPLOT:RNGMEM=RNGPLOT
PUT (-150,102),BLANKLINE%,PSET
HORIZSCALE=SIZ*OVALHIGH*SIZCONST
VERTSCALE=SIZ*OVALWIDE*SIZCONST
PLOTHOR=SIN(DSKPLOT+RNGPLOT*GDTOGL%)*PENPOS+SIN(RNGPLOT)*RATIO
PLOTVERT=COS(DSKPLOT+RNGPLOT*GDTOGL%)*PENPOS+COS(RNGPLOT)*RATIO
PSET(MOVHORIZ+PLOTHOR*HORIZSCALE,MOVVERT+PLOTVERT*VERTSCALE),HUE%
COUNT%=0
'     HERE IS THE ACTUAL PLOTTING OF THE DESIGN
 WHILE NOT INSTAT
   COUNT%=COUNT%+1
   DSKPLOT=DSKPLOT+DSKANGL
   RNGPLOT=RNGPLOT+RNGANGL
   WHILE ABS(DSKPLOT)>CIR:DSKPLOT=DSKPLOT-CIR*SGN(DSKPLOT):WEND
   WHILE ABS(RNGPLOT)>CIR:RNGPLOT=RNGPLOT-CIR*SGN(RNGPLOT):WEND
   PLOTHOR=SIN(DSKPLOT+RNGPLOT*GDTOGL%)*PENPOS+SIN(RNGPLOT)*RATIO
   PLOTVERT=COS(DSKPLOT+RNGPLOT*GDTOGL%)*PENPOS+COS(RNGPLOT)*RATIO
   LINE -(MOVHORIZ+PLOTHOR*HORIZSCALE,MOVVERT+PLOTVERT*VERTSCALE),HUE%
   IF RECOUNT%=0 AND COUNT%>10 THEN
    DM=ABS(DSKPLOT)-ABS(DSKMEM):RM=ABS(RNGPLOT)-ABS(RNGMEM)
    IF ABS(DM)<ZERO OR ABS(DM)>CIR-ZERO THEN
      IF ABS(RM)<ZERO OR ABS(RM)>CIR-ZERO THEN GOTO DONE
    END IF
   END IF
   IF RECOUNT%=1 THEN
     RECOUNT%=0
     GOTO DONE
   END IF
   IF RECOUNT%<>0 THEN RECOUNT%=RECOUNT%-1
 WEND
 IF REP%=1 THEN GOTO SCRENE
 REP%=0
 KK$=UCASE$(INKEY$):RECOUNT%=0
 DONE:
 GET (-150,-100)-(14*WD-146,24*HG-100),WNDW%
 PUT (-150,102),BLANKLINE%,PSET
 LOCATE 25,1:PRINT ">";
 SELECT CASE REP%
        CASE =0
          GOTO STARTING
        CASE =1
          GOTO INTROSCREEN
        CASE =2
          GOTO REPEAT
 END SELECT

CASE ="Q"
'    QUIT SUBROUTINE
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT "ARE YOU SURE? ";
  WHILE NOT INSTAT:WEND
  KK$=UCASE$(INKEY$)
  IF KK$="Y" THEN
    CLS
    LOCATE 1,1:PRINT "Have a nice day!"
    RANDOMIZE TIMER:HUE%=1
    WHILE NOT INSTAT
    IF SCRN$="C" THEN
      HUE%=INT(RND(2)*6+1)
      IF HUE%>3 THEN COLOR ,1:HUE%=HUE%-3 ELSE COLOR ,0
    END IF
    S1=INT(RND(2)*14+2)
    S2=INT(RND(2)*(300-20*S1))-150
    S3=INT(RND(2)*29+2)
    S4=INT(RND(2)*(200-5*S3))-100
    GET (2*S1+S2,2*S3+S4)-(19*S1+S2,3*S3+S4),REFRESHA%
    PUT (2*S1+S2,2*S3+S4),REFRESHA%
    GET (S1+S2,3*S3+S4)-(19*S1+S2,4*S3+S4),REFRESHA%
    PUT (S1+S2,3*S3+S4),REFRESHA%
    GET (3*S1+S2,S3+S4)-(5*S1+S2,2*S3+S4),REFRESHA%
    PUT (3*S1+S2,S3+S4),REFRESHA%
    GET (16*S1+S2,S3+S4)-(17*S1+S2,2*S3+S4),REFRESHA%
    PUT (16*S1+S2,S3+S4),REFRESHA%
    GET (5*S1+S2,4*S3+S4)-(6*S1+S2,5*S3+S4),REFRESHA%
    PUT (5*S1+S2,4*S3+S4),REFRESHA%
    GET (15*S1+S2,4*S3+S4)-(16*S1+S2,5*S3+S4),REFRESHA%
    PUT (15*S1+S2,4*S3+S4),REFRESHA%
    GOSUB LOGO
    DELAY .3
    WEND
    LOCATE 25,30:PRINT "The end?";
    DELAY .5
    SCREEN 0,0,0,0:END
  END IF
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT ">";

END SELECT
  IF REP%=0 THEN GOTO STARTING ELSE GOTO REPEAT


FILEXIST:
  FILERR=0:FILECONTINUE=0
  ON ERROR GOTO FILERROR
  OPEN FIL$ FOR INPUT AS #1
  CLOSE 1
CONTINUEAFTERERROR:
  ON ERROR GOTO 0
  IF SL$="S" THEN
    IF FILERR=0 THEN
      PROMP$=CHR$(34)+FIL$+CHR$(34)+" exists. Overwrite?"
      CHOIC$="YN"
      DEFAU$=""
      GOSUB INWORD
      IF ASKWRD$="Y" THEN FILECONTINUE=1
    ELSE
      FILECONTINUE=1
    END IF
  ELSE
    IF FILERR=1 THEN
      PUT (-150,102),BLANKLINE%,PSET
      LOCATE 25,1:PRINT CHR$(34);FIL$;CHR$(34);" doesn't exist";
    ELSE
      FILECONTINUE=1
    END IF
  END IF
  RETURN
FILERROR:
  FILERR=1:RESUME CONTINUEAFTERERROR
CANTSAVE:
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT "Cannot save";
  RESUME NEXT
STACKSPACE:
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT "Out of stack space";
  RESUME NEXT

LOGO:
LINE (4*S1+S2,1*S3+S4)-(5*S1+S2,1*S3+S4),HUE%
LINE (16*S1+S2,1*S3+S4)-(17*S1+S2,1*S3+S4),HUE%
LINE (4*S1+S2,2*S3+S4)-(16*S1+S2,2*S3+S4),HUE%
LINE (17*S1+S2,2*S3+S4)-(19*S1+S2,2*S3+S4),HUE%
LINE (2*S1+S2,3*S3+S4)-(4*S1+S2,3*S3+S4),HUE%
LINE (6*S1+S2,3*S3+S4)-(7*S1+S2,3*S3+S4),HUE%
LINE (9*S1+S2,3*S3+S4)-(10*S1+S2,3*S3+S4),HUE%
LINE (11*S1+S2,3*S3+S4)-(12*S1+S2,3*S3+S4),HUE%
LINE (14*S1+S2,3*S3+S4)-(15*S1+S2,3*S3+S4),HUE%
LINE (17*S1+S2,3*S3+S4)-(18*S1+S2,3*S3+S4),HUE%
LINE (1*S1+S2,4*S3+S4)-(5*S1+S2,4*S3+S4),HUE%
LINE (6*S1+S2,4*S3+S4)-(9*S1+S2,4*S3+S4),HUE%
LINE (10*S1+S2,4*S3+S4)-(15*S1+S2,4*S3+S4),HUE%
LINE (16*S1+S2,4*S3+S4)-(17*S1+S2,4*S3+S4),HUE%
LINE (18*S1+S2,4*S3+S4)-(19*S1+S2,4*S3+S4),HUE%
LINE (1*S1+S2,4*S3+S4)-(4*S1+S2,1*S3+S4),HUE%
LINE (5*S1+S2,5*S3+S4)-(6*S1+S2,5*S3+S4),HUE%
LINE (15*S1+S2,5*S3+S4)-(16*S1+S2,5*S3+S4),HUE%
LINE (5*S1+S2,1*S3+S4)-(5*S1+S2,5*S3+S4),HUE%
LINE (6*S1+S2,4*S3+S4)-(6*S1+S2,5*S3+S4),HUE%
LINE (8*S1+S2,2*S3+S4)-(8*S1+S2,4*S3+S4),HUE%
LINE (9*S1+S2,3*S3+S4)-(9*S1+S2,4*S3+S4),HUE%
LINE (10*S1+S2,2*S3+S4)-(10*S1+S2,4*S3+S4),HUE%
LINE (13*S1+S2,2*S3+S4)-(13*S1+S2,4*S3+S4),HUE%
LINE (15*S1+S2,4*S3+S4)-(15*S1+S2,5*S3+S4),HUE%
LINE (16*S1+S2,1*S3+S4)-(16*S1+S2,5*S3+S4),HUE%
LINE (17*S1+S2,1*S3+S4)-(17*S1+S2,2*S3+S4),HUE%
LINE (17*S1+S2,3*S3+S4)-(17*S1+S2,4*S3+S4),HUE%
LINE (18*S1+S2,3*S3+S4)-(18*S1+S2,4*S3+S4),HUE%
LINE (19*S1+S2,2*S3+S4)-(19*S1+S2,4*S3+S4),HUE%
RETURN

INNUM:
'    INPUT NUMBERS ON SCREEN LINE 25.
' ONLY ALLOWS NUMERIC CHARACTERS TO BE ENTERED,
' ALLOWS USE OF BACKSPACE, RIGHT AND LEFT ARROWS, AND ESCAPE,
' THE '5' KEY TYPES OUT THE ENTIRE DEFAULT
' AN INITIAL '+' MEANS THE INPUT WILL BE ADDED TO THE DEFAULT,
' TO SUBRACT FROM DEFAULT, START WITH '+-'
   ASKNUM$=DEFAU$:ABORT%=0:PLUS%=0:KPOS%=0:NONUM%=0
   IF VAL(DEFAU$)>0 THEN ASKNUM$=RIGHT$(DEFAU$,LEN(DEFAU$)-1)
   PUT (-150,102),BLANKLINE%,PSET
   IF LEN(PROMP$)<LINELENGTH% THEN
     LIN%=25:LOCATE LIN%,1:PRINT PROMP$;
   ELSE
     FOR X=1 TO LEN(PROMP$)/LINELENGTH%+1
     LOCATE 26-X,1:PRINT MID$(PROMP$,(X-1)*LINELENGTH%+1,LINELENGTH%);
     NEXT X
   END IF
 ANOTHERNUMBER:
   IF REP%=2 THEN
     IF LEN(MACRO$)<>0 THEN KK$=LEFT$(MACRO$,1) ELSE KK$=CHR$(13)
     IF ASC(KK$)>42 AND ASC(KK$)<58 THEN
       MACRO$=RIGHT$(MACRO$,LEN(MACRO$)-1)
     ELSE
       KK$=CHR$(13)
     END IF
   ELSE
     WHILE NOT INSTAT:WEND:KK$=UCASE$(INKEY$)
   END IF
   IF KK$=CHR$(27) THEN
      PUT (-150,102),BLANKLINE%,PSET
      ABORT%=1:LOCATE 25,1:PRINT ">";:RETURN
   END IF
   IF RIGHT$(KK$,1)=CHR$(75) AND LEN(KK$)=2 THEN KK$=CHR$(8)
   IF LEN(KK$)=2 AND RIGHT$(KK$,1)=CHR$(76) THEN
       PRINT RIGHT$(ASKNUM$,LEN(ASKNUM$)-KPOS%);
       KPOS%=LEN(ASKNUM$)
   END IF
   IF LEN(KK$)=2 AND RIGHT$(KK$,1)=CHR$(77) THEN
       IF LEN(ASKNUM$)>KPOS% THEN KK$=MID$(ASKNUM$,KPOS%+1,1)
   END IF
   IF KK$=CHR$(8) AND KPOS%>0 THEN
       KPOS%=KPOS%-1:LOCATE CSRLIN,POS-1:PRINT " ";:LOCATE 25,POS-1
   END IF
   IF ASC(KK$)>42 AND ASC(KK$)<58 AND ASC(KK$)<>47 THEN
     IF LEN(ASKNUM$)>KPOS% THEN
        RGHT$=RIGHT$(ASKNUM$,LEN(ASKNUM$)-KPOS%-1)
     ELSE
        RGHT$=""
     END IF
     ASKNUM$=LEFT$(ASKNUM$,KPOS%)+KK$+RGHT$
     KPOS%=KPOS%+1:PRINT KK$;
   END IF
   IF KK$<>CHR$(13) THEN GOTO ANOTHERNUMBER
   IF KPOS%=0 THEN ABORT%=1:NONUM%=1
   ASKNUM$=LEFT$(ASKNUM$,KPOS%)
   IF LEFT$(ASKNUM$,1)=CHR$(43) THEN
      ASKNUM$=RIGHT$(ASKNUM$,LEN(ASKNUM$)-1):PLUS%=1
   END IF
   ASKNUM=VAL(ASKNUM$)
   WHILE ASKNUM>32768:ASKNUM=ASKNUM/10:WEND
   IF KPOS%=0 AND WIPE%=1 THEN ASKNUM=999
   PUT (-150,102),BLANKLINE%,PSET
   LOCATE 25,1:PRINT ">";
   RETURN

INWORD:
'    INPUT WORDS OR LETTERS ON SCREEN LINE 25.
' ALLOWS ONLY LEGAL CHOICES TO BE INPUT,
' ALLOWS BACKSPACE, ESCAPE, AND RIGHT AND LEFT ARROWS,
' THE '5' KEY TYPES OUT THE ENTIRE DEFAULT STRING.
  ASKWRD$=DEFAU$:ABORT%=0:KPOS%=0
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT PROMP$;
 ANOTHERLETTER:
  IF REP%=2 AND MACRO$<>"" THEN
    KK$=LEFT$(MACRO$,1)
    MACRO$=RIGHT$(MACRO$,LEN(MACRO$)-1)
  ELSE
    WHILE NOT INSTAT:WEND
    KK$=UCASE$(INKEY$)
  END IF
  IF KK$=CHR$(27) THEN
    PUT (-150,102),BLANKLINE%,PSET
    ABORT%=1:LOCATE 25,1:PRINT ">";:RETURN
  END IF
  IF LEN(KK$)=2 AND RIGHT$(KK$,1)=CHR$(75) THEN KK$=CHR$(8)
  IF LEN(KK$)=2 AND RIGHT$(KK$,1)=CHR$(76) THEN
    PRINT RIGHT$(ASKWRD$,LEN(ASKWRD$)-KPOS%);:KPOS%=LEN(ASKWRD$)
  END IF
  IF LEN(KK$)=2 AND RIGHT$(KK$,1)=CHR$(77) THEN
    IF LEN(ASKWRD$)>KPOS% THEN KK$=MID$(ASKWRD$,KPOS%+1,1)
  END IF
  IF KK$=CHR$(8) AND KPOS%>0 THEN
    KPOS%=KPOS%-1
    LOCATE 25,POS-1:PRINT " ";:LOCATE 25,POS-1
  END IF
  IF INSTR(CHOIC$,KK$)<>0 OR CHOIC$="" THEN
   IF ASC(KK$)>32 THEN
     IF LEN(ASKWRD$)>KPOS% THEN
       RGHT$=RIGHT$(ASKWRD$,LEN(ASKWRD$)-KPOS%-1)
     ELSE
       RGHT$=""
     END IF
     ASKWRD$=LEFT$(ASKWRD$,KPOS%)+KK$+RGHT$
     KPOS%=KPOS%+1:PRINT KK$;
   END IF
  END IF
  IF CHOIC$="" AND KK$<>CHR$(13) THEN GOTO ANOTHERLETTER
  ASKWRD$=LEFT$(ASKWRD$,KPOS%)
  PUT (-150,102),BLANKLINE%,PSET
  LOCATE 25,1:PRINT ">";:RETURN

REPEAT:
'    READS COMMANDS FROM MACRO$ WHEN RUNNING MACROS (THE 'A' COMMAND)
 IF MACRO$="" THEN MACRO%=MACRO%-1:MACRO$=INMACRO$
 IF MACRO%=0 THEN REP%=0:GOTO STARTING
 KY$=LEFT$(MACRO$,1)
 MACRO$=RIGHT$(MACRO$,LEN(MACRO$)-1)
 GOTO SET

COLORTILE:
'  CHANGES COLORS IN TILE PATTERNS FOR WIPE COMMAND
IF EXT$=".COL" THEN
 IF TILECOLOR% MOD 12 >5 THEN
  COL=HUE% MOD 7:COLOR ,1-INT(COL/3.6)
 END IF
END IF
WIPE1$=WIPE$
FOR TILEPART=1 TO LEN(WIPE$)
 TILER%(0)=ASC(MID$(WIPE$,TILEPART,1))
 SELECT CASE TILECOLOR% MOD 5
  CASE =1
    TILER%(0)=TILER%(0)*2
    WHILE TILER%(0)>255:TILER%(0)=TILER%(0)-255:WEND
  CASE =2
    TILER%(0)=255-TILER%(0)
  CASE =3
    T1%=TILER%(0):T3%=0
    FOR T2%=1 TO 8
     T3%=T3%*2
     IF T1% MOD 2=1 THEN T3%=T3%+1
     T1%=INT(T1%/2)
    NEXT T2%
    TILER%(0)=T3%
  CASE =4
    TILER%(0)=ASC(MID$(WIPE$,LEN(WIPE$)-TILEPART+1,1))
  END SELECT
 TILER%(1)=TILER%(0) MOD 4
 TILER%(2)=(TILER%(0)-TILER%(1))/4 MOD 4
 TILER%(3)=(TILER%(0)-TILER%(1)-TILER%(2)*4)/16 MOD 4
 TILER%(4)=(TILER%(0)-TILER%(1)-TILER%(2)*4-TILER%(3)*16)/64
 FOR TLC=1 TO 4
  SELECT CASE INT(TILECOLOR%/12) MOD 6
         CASE =1
          IF TILER%(TLC)>1 THEN TILER%(TLC)=5-TILER%(TLC)
         CASE =2
          IF TILER%(TLC)=1 OR TILER%(TLC)=2 THEN TILER%(TLC)=3-TILER%(TLC)
         CASE =3
          IF TILER%(TLC)<2 THEN TILER%(TLC)=1-TILER%(TLC)
         CASE =4
          IF TILER%(TLC)=0 OR TILER%(TLC)=3 THEN TILER%(TLC)=3-TILER%(TLC)
         CASE =5
          IF TILER%(TLC)=0 OR TILER%(TLC)=2 THEN TILER%(TLC)=2-TILER%(TLC)
  END SELECT
 NEXT TLC
 TILER%(0)=TILER%(1)+TILER%(2)*4+TILER%(3)*16+TILER%(4)*64
 WHILE TILER%(0)>255:TILER%(0)=TILER%(0)-255:WEND
 MID$(WIPE1$,TILEPART,1)=CHR$(TILER%(0))
NEXT TILEPART
WIPE$=WIPE1$
RETURN

' PATTERNS 10-19
DATA 1,999
DATA 15,999
DATA 127,999 '
DATA 17,999
DATA 21,999  '
DATA 17,17,1,17,1,17,17,16,17,16,999
DATA 1,1,1,1,17,17,16,16,16,16,17,17,999
DATA 144,144,18,18,66,66,72,72,9,9,33,33,36,36,132,132,999
DATA 75,999
DATA 93,93,65,65,999

' PATTERNS 20-29
DATA 1,16,17,0,999
DATA 255,255,0,999
DATA 255,0,0,0,0,0,999
DATA 31,0,0,0,0,999
DATA 63,0,0,0,243,0,0,0,999
DATA 31,0,227,0,124,0,143,0,241,0,62,0,199,0,248,0,999
DATA 85,170,0,85,85,0,0,0,999
DATA 0,0,170,85,0,85,170,0,170,85,0,0,255,0,0,255,999
DATA 85,170,0,0,255,0,0,85,85,0,0,255,0,0,999
DATA 85,170,85,255,255,255,170,85,170,0,0,0,999

' PATTERNS 30-39
DATA 255,3,3,3,999
DATA 255,3,3,3,3,255,48,48,48,48,999
DATA 15,15,15,240,240,240,999
DATA 31,31,31,0,0,241,241,241,0,0,999
DATA 252,252,252,252,3,3,999
DATA 126,66,90,90,66,126,129,999
DATA 5,10,5,10,175,95,175,95,999
DATA 28,34,65,73,65,34,28,0,999
DATA 1,130,68,40,16,40,68,130,999
DATA 3,6,12,24,255,24,12,6,3,255,999

' PATTERNS 40-49
DATA 1,2,4,136,64,32,16,136,999
DATA 7,142,221,232,112,184,221,139,999
DATA 68,68,64,95,64,68,68,4,245,4,999
DATA 96,111,111,96,6,246,246,6,999
DATA 60,102,102,195,0,0,195,102,102,60,0,0,999
DATA 3,3,3,6,6,28,56,96,96,192,192,192,96,96,56,28,6,6,999
DATA 136,5,34,80,136,80,34,5,999
DATA 62,34,175,168,184,136,143,0,0,999
DATA 34,32,112,32,34,2,7,2,999
DATA 62,34,227,128,128,128,227,34,62,8,8,8,999

' PATTERNS 50-59
DATA 156,54,99,54,156,201,999
DATA 1,3,7,15,31,63,127,255,999
DATA 60,153,153,195,0,0,195,153,153,60,0,0,999
DATA 31,16,16,16,241,1,1,1,999
DATA 221,68,119,17,999
DATA 255,128,159,144,144,144,999
DATA 255,255,1,253,253,5,245,245,21,213,213
DATA  84,84,87,80,80,95,64,64,127,0,0,999
DATA 128,128,142,136,136,139,8,8,232,136,136,184,999
DATA 254,128,190,130,186,162,170,170,42,171,40,235,8,239,0,999
DATA 0,127,1,125,5,117,21,85,0,247,4,245,5,117,69,85,999

' PATTERNS 60-69
DATA 250,128,190,130,186,162,170,42,171,40,235,8,175,160,190,2,250
DATA  130,186,138,170,168,171,40,175,32,235,10,999
DATA 99,99,54,22,12,24,52,54,999
DATA 0,192,227,47,28,48,236,199,3,999
DATA 217,112,39,108,201,28,55,48,24,999
DATA 124,64,95,65,69,5,245,4,999
DATA 21,215,81,119,4,215,64,221,999
DATA 243,243,51,51,63,63,0,0,999
DATA 247,20,20,119,65,65,127,0,999
DATA 54,73,65,34,20,8,0,999
DATA 56,68,130,146,140,64,48,14,129,64,38,41,40,68,131,999

' PATTERNS 70-79
DATA 8,8,20,34,193,34,20,8,999
DATA 20,34,73,85,148,34,34,65,73,65,34,34,148,85,73,34,999
DATA 6,9,9,6,0,96,144,144,96,0,999
DATA 119,5,119,80,999
DATA 8,28,42,65,227,65,42,28,8,8,8,999
DATA 8,42,34,34,54,20,213,20,54,34,34,42,8,999
DATA 0,62,8,162,85,170,85,162,8,62,999
DATA 255,85,170,85,170,85,255,8,8,8,8,999
DATA 32,38,25,1,16,145,98,2,999
DATA 146,41,68,999

' PATTERNS 80-89
DATA 17,131,199,239,255,254,124,56,17,130,69,170,85,170,84,40,999
DATA 17,34,68,136,17,34,68,34,17,136,68,34,999
DATA 15,30,60,120,240,225,195,135,15,135,195,225,240,120,60,30,999
DATA 7,37,7,0,112,82,112,0,999
DATA 87,37,87,0,117,82,117,0,999
DATA 147,57,124,254,56,56,57,57,57,1,69,999
DATA 132,12,20,39,65,39,20,12,132,192,224,243,251,243,224,192,999
DATA 16,56,124,254,56,124,999
DATA 15,19,37,121,73,73,74,76,120,0,999
DATA 128,20,54,99,8,99,54,20,999

' PATTERNS 90-99
DATA 32,32,32,0,0,7,0,0,999
DATA 102,0,153,0,102,0,85,0,170,0,85,0,999
DATA 136,0,34,0,102,0,153,0,999
DATA 255,1,1,1,1,13,13,1,999
DATA 8,20,42,85,170,85,42,20,8,28,62,127,255,127,62,28,999
DATA 85,42,20,8,20,42,999
DATA 21,10,228,241,241,228,10,999
DATA 125,17,215,16,215,17,125,1,999
DATA 109,9,107,72,91,66,218,18,214,144,182,132,181,36,173,33,999
DATA 78,72,72,78,74,74,78,66,66,78,74,74,999

DATA 7,9,19,33,121,65,127,0,0,124,68,84,68,92,80,112,0,0
DATA  124,68,92,80,112,0,0,124,68,84,68,124,0,0
DATA  124,68,84,68,116,20,28,0,0,112,80,92,68,84,84,124,0,0,0,999
DATA -1
END