'===========================================================================
' Subject: SPACE SHIP THINGY (STAR TREK)      Date: 04-18-99 (21:56)       
'  Author: Ross Harper                        Code: QB, QBasic, PDS        
'  Origin: t.r.harper@btinternet.com        Packet: DEMOS.ABC
'===========================================================================
'' Hya!!
'' This was a little program I put together after watching Star Trek: First
'' Contact.  In Zefram Cochrane's ship, there was a little computer simulation
'' running showing his ship and all sorts of warp fields around it.  This
'' program was just a bit of fun at having a go. 
''
'' I might integrate it into a game someday...
''
'' Press 'H' whilst running to see the instructions
''
'' A challenge:  When you exceed Spatial Distortion Factor 7, the stars seem
'' to arrange themselves into horizontal lines whilst passing.  If anyone out
'' there in BASIC-land can sort this out, I'd love to hear from you!!
''
'' Lot's of love,
'' Wish you were here,
'' Ross!
''
'' Peachy512@yahoo.com
'' ICQ: 15844814
'' The Zax Bypass: http://members.xoom.com/Peachy512/Asylum/home.htm
''
DECLARE SUB box (q1!, a1!, q2!, a2!, col!)
DECLARE SUB xwing (col!)
DECLARE SUB definestars ()
DECLARE SUB drawstars (col!)
DECLARE SUB movestars ()
DECLARE SUB help ()
DECLARE SUB reinit ()
DECLARE SUB probe (col!)
DECLARE SUB vessel (col!)
DECLARE SUB cross (x!, y!, l!, col!)
DECLARE SUB ship (col!)
DECLARE SUB mainloop ()
DECLARE SUB pause (time!)
DECLARE SUB checkroutine ()
DECLARE SUB lfield (col!)
COMMON SHARED scx, scy, pfield, pfr, sp, fr, simr, defaultr, ves, warpcx1, warpcx2, warpcy, starx(), stary(), strs, wx1, wx2, wy, col
SCREEN 9
scx = 320: scy = 125: defaultr = 100: sp = 0: ves = 3: strs = 50
'warpcx1 = scx - 37: warpcx2 = scx + 37
warpcx1 = 320: warpcx2 = 320
warpcy = scy + 40
DIM starx(strs), stary(strs)
vessel (15)
definestars
drawstars (15)
mainloop

SUB allships
IF pfield = 1 AND col <> 0 THEN
        COLOR 2: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        COLOR 10: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (4)
END IF
IF pfield = 1 AND col = 0 THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (0)
END IF
END SUB

SUB box (q1, a1, q2, a2, col)
COLOR col
LINE (q1, a1)-(q2, a1)
LINE (q2, a1)-(q2, a2)
LINE (q2, a2)-(q1, a2)
LINE (q1, a2)-(q1, a1)
END SUB

SUB checkroutine
IF sp < 0 THEN sp = 0
IF sp > 9 THEN sp = 9
IF simr >= pfr THEN simr = 0
END SUB

SUB cross (x, y, l, col)
COLOR col
LINE (x - l, y - l)-(x + l, y + l)
LINE (x + l, y - l)-(x - l, y + l)
END SUB

SUB definestars
FOR n = 1 TO strs
        starx(n) = INT(RND * 640) + 1
        stary(n) = INT(RND * 350) + 1
NEXT n
END SUB

SUB drawstars (col)
FOR n = 1 TO strs
        ''IF col <> 0 THEN col = INT(RND * 7) + 8
        COLOR col
       
        PSET (starx(n), stary(n))
NEXT n
END SUB

SUB help
SCREEN 11
CLS
PRINT "Keys:"
PRINT
PRINT "Q        Move vessel up"
PRINT "A        Move vessel down"
PRINT "O        Move vessel left"
PRINT "P        Move vessel right"
PRINT "(This has no effect other than user preferences!)"
PRINT
PRINT "W        Generates / Disengages Physical Warp Field"
PRINT "(Logical warp field is generated also.)"
PRINT
PRINT "UP       Increase Logical Spatial Disturbance "
PRINT "DOWN     Decrease Logical Spatial Disturbance "
PRINT
PRINT "<        Move Logical Warp Field Generation Centre Outwards"
PRINT ">        Move Logical Warp Field Generation Centre Inwards"
PRINT "@        Move Logical Warp Field Generation Centre Up"
PRINT "/        Move Logical Warp Field Generation Centre Down"
PRINT
PRINT "C        Re-initialises screen"
PRINT "H        This help screen"
PRINT
PRINT "F1       Change vessel shape (type in number)"
PRINT
LOCATE 29, 1: PRINT "Press a key to continue": SLEEP: reinit
END SUB

SUB lfield (col)
COLOR 0
CIRCLE (scx, warpcy), defaultr + 101
CIRCLE (scx, warpcy), defaultr - 9
'CIRCLE (scx, warpcy), pfr + 1
COLOR col
fr = (sp * 10) + pfr + 1
LOCATE 2, 1: PRINT fr
CIRCLE (scx, warpcy), fr
END SUB

SUB mainloop
DO
COLOR 15
LOCATE 1, 1: PRINT "Spatial Distortian Factor "; sp
LOCATE 21, 1: PRINT "Physical: ": COLOR 2: LINE (170, 285)-(200, 285): COLOR 15
LOCATE 22, 1: PRINT "Logical:": COLOR 4: LINE (170, 300)-(200, 300): COLOR 15
LOCATE 23, 1: PRINT "Generation Centre:": CALL cross(185, 315, 5, 10): COLOR 15
a$ = LCASE$(INKEY$)
IF a$ = "h" THEN help: a$ = ""
IF a$ = "q" THEN vessel (0): scy = scy - 5: vessel (15)
IF a$ = "a" THEN vessel (0): scy = scy + 5: vessel (15)
IF a$ = "o" THEN vessel (0): scx = scx - 5: vessel (15)
IF a$ = "p" THEN vessel (0): scx = scx + 5: vessel (15)
IF a$ = "c" THEN reinit
IF a$ = CHR$(0) + ";" THEN
        LOCATE 1, 1: PRINT STRING$(80, " ")
        LOCATE 1, 1: INPUT "Vessel Number"; ves
        reinit
END IF

IF a$ = "," THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
                 CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CALL cross(warpcx1, warpcy, 5, 0)
                 CALL cross(warpcx2, warpcy, 5, 0)
                 warpcx1 = warpcx1 - 1: warpcx2 = warpcx2 + 1
                 CALL cross(warpcx1, warpcy, 5, 2)
                 CALL cross(warpcx2, warpcy, 5, 2)
END IF
IF a$ = "." THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
                 CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CALL cross(warpcx1, warpcy, 5, 0)
                 CALL cross(warpcx2, warpcy, 5, 0)
                 warpcx1 = warpcx1 + 1: warpcx2 = warpcx2 - 1
        CALL cross(warpcx1, warpcy, 5, 2)
        CALL cross(warpcx2, warpcy, 5, 2)
END IF
IF a$ = "'" THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
                 CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CALL cross(warpcx1, warpcy, 5, 0)
                 CALL cross(warpcx2, warpcy, 5, 0)
                 CIRCLE (scx, warpcy), fr
                 warpcy = warpcy - 1
                 CALL cross(warpcx1, warpcy, 5, 2)
                 CALL cross(warpcx2, warpcy, 5, 2)
END IF
IF a$ = "/" THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
                 CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
                 CALL cross(warpcx1, warpcy, 5, 0)
                 CALL cross(warpcx2, warpcy, 5, 0)
                 CIRCLE (scx, warpcy), fr
                 warpcy = warpcy + 1
                 CALL cross(warpcx1, warpcy, 5, 2)
                 CALL cross(warpcx2, warpcy, 5, 2)
END IF


IF a$ = "w" AND pfield = 0 THEN
        LOCATE 1, 1: PRINT "Physical Warp Field Generating"
        pause (1)
        LOCATE 1, 1: PRINT STRING$(80, " ")
        pfr = defaultr
        COLOR 2
        CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        lfield (4)
        COLOR 15: pfield = 1: a$ = "": simr = 0
END IF
IF a$ = "w" AND pfield = 1 THEN
        LOCATE 1, 1: PRINT "Physical Warp Field Disengaging"
        pause (1)
        LOCATE 1, 1: PRINT STRING$(80, " ")
        COLOR 0
        CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (0)
        COLOR 15: pfield = 0: vessel (15): a$ = "": pfr = defaultr
END IF
IF pfield = 1 THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        simr = simr + 5
        COLOR 2: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        vessel (15)
        movestars
        IF a$ = CHR$(0) + "h" THEN
                lfield (0)
                sp = sp + 1
                lfield (4)
        END IF
        IF a$ = CHR$(0) + "p" THEN
                lfield (0)
                sp = sp - 1
                lfield (4)
        END IF
END IF
checkroutine
LOOP
END SUB

SUB movestars
plus = sp ^ 2
drawstars (0)
FOR n = 1 TO strs
        stary(n) = stary(n) + plus
        IF stary(n) > 350 THEN stary(n) = -5: starx(n) = INT(RND * 640) + 1
NEXT n
drawstars (15)
END SUB

SUB pause (time)
starttime = INT(TIMER) + time
DO
LOOP UNTIL INT(TIMER) > starttime
END SUB

SUB probe (col)
IF col <> 0 THEN
        CALL cross(warpcx1, warpcy, 5, 10)
        CALL cross(warpcx2, warpcy, 5, 10)
END IF
IF col = 0 THEN
        CALL cross(warpcx1, warpcy, 5, 0)
        CALL cross(warpcx2, warpcy, 5, 0)
END IF
COLOR col
''probe hull
CIRCLE (scx, scy + 40), 35
CIRCLE (scx, scy + 40), 10
'' left nacelle
'LINE (scx - 35, scy + 55)-(scx - 35, scy + 25)
'LINE (scx - 40, scy + 55)-(scx - 40, scy + 25)
'LINE (scx - 36, scy + 56)-(scx - 39, scy + 56)
'LINE (scx - 36, scy + 24)-(scx - 39, scy + 24)
'' right nacelle
'LINE (scx + 35, scy + 55)-(scx + 35, scy + 25)
'LINE (scx + 40, scy + 55)-(scx + 40, scy + 25)
'LINE (scx + 36, scy + 56)-(scx + 39, scy + 56)
'LINE (scx + 36, scy + 24)-(scx + 39, scy + 24)
IF pfield = 1 AND col <> 0 THEN
        COLOR 2: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        COLOR 10: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (4)
END IF
IF pfield = 1 AND col = 0 THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (0)
END IF

END SUB

SUB reinit
SCREEN 9
CLS
vessel (15)
CALL cross(warpcx1, warpcy, 5, 2)
CALL cross(warpcx2, warpcy, 5, 2)
definestars
drawstars (15)
END SUB

SUB ship (col)
''warp centres
IF col <> 0 THEN
        CALL cross(warpcx1, warpcy, 5, 10)
        CALL cross(warpcx2, warpcy, 5, 10)
END IF
IF col = 0 THEN
        CALL cross(warpcx1, warpcy, 5, 0)
        CALL cross(warpcx2, warpcy, 5, 0)
END IF
COLOR col
''saucer section
CIRCLE (scx, scy), 30
CIRCLE (scx, scy), 5
'' middle
LINE (scx, scy + 22)-(scx, scy + 55)
'' bottom
LINE (scx - 5, scy + 55)-(scx + 5, scy + 55)
'' bottom to circle left
LINE (scx - 5, scy + 55)-(scx - 10, scy + 22)
'' bottom to circle right
LINE (scx + 5, scy + 55)-(scx + 10, scy + 22)
'' left nacelle pylon
LINE (scx - 6, scy + 50)-(scx - 35, scy + 47)
LINE (scx - 6, scy + 45)-(scx - 35, scy + 43)
'' right nacelle pylon
LINE (scx + 6, scy + 50)-(scx + 35, scy + 47)
LINE (scx + 6, scy + 45)-(scx + 35, scy + 43)
'' left nacelle
LINE (scx - 35, scy + 55)-(scx - 35, scy + 25)
LINE (scx - 40, scy + 55)-(scx - 40, scy + 25)
LINE (scx - 36, scy + 56)-(scx - 39, scy + 56)
LINE (scx - 36, scy + 24)-(scx - 39, scy + 24)
'' right nacelle
LINE (scx + 35, scy + 55)-(scx + 35, scy + 25)
LINE (scx + 40, scy + 55)-(scx + 40, scy + 25)
LINE (scx + 36, scy + 56)-(scx + 39, scy + 56)
LINE (scx + 36, scy + 24)-(scx + 39, scy + 24)
IF pfield = 1 AND col <> 0 THEN
        COLOR 2: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        COLOR 10: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (4)
END IF
IF pfield = 1 AND col = 0 THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (0)
END IF

END SUB

SUB vessel (col)
IF ves = 1 THEN ship (col)
IF ves = 2 THEN probe (col)
IF ves = 3 THEN xwing (col)
END SUB

SUB xwing (col)
IF col <> 0 THEN
        CALL cross(warpcx1, warpcy, 5, 10)
        CALL cross(warpcx2, warpcy, 5, 10)
END IF
IF col = 0 THEN
        CALL cross(warpcx1, warpcy, 5, 0)
        CALL cross(warpcx2, warpcy, 5, 0)
END IF
''fuselage
CALL box(scx - 5, scy + 50, scx + 5, scy + 30, col)
''nose
LINE (scx - 5, scy + 30)-(scx - 2, scy)
LINE (scx + 5, scy + 30)-(scx + 2, scy)
CIRCLE (scx, scy), 10, , , , 10 / 5
''left wing
LINE (scx - 5, scy + 50)-(scx - 50, scy + 45)
LINE (scx - 5, scy + 37)-(scx - 50, scy + 40)
''left gun
CALL box(scx - 50, scy + 45, scx - 51, scy + 20, col)

''right wing
LINE (scx + 5, scy + 50)-(scx + 50, scy + 45)
LINE (scx + 5, scy + 37)-(scx + 50, scy + 40)
''right gun
CALL box(scx + 50, scy + 45, scx + 51, scy + 20, col)


''fusial thrust engines
CALL box(scx - 5, scy + 45, scx - 8, scy + 55, col)
CALL box(scx + 5, scy + 45, scx + 8, scy + 55, col)
IF pfield = 1 AND col <> 0 THEN
        COLOR 2: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        COLOR 10: CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (4)
END IF
IF pfield = 1 AND col = 0 THEN
        COLOR 0: CIRCLE (warpcx1, warpcy), pfr: CIRCLE (warpcx2, warpcy), pfr
        CIRCLE (warpcx1, warpcy), simr: CIRCLE (warpcx2, warpcy), simr
        lfield (0)
END IF

END SUB