Program: Train.bas
Implementation Select: Implementation
Operation Select: Program: TRAIN.BAS
DEFDBL A-Z
' TRAIN.BAS
' Revision 1.0 16 Dec 1995
' Revision 2.0 15 Okt 2001
' Added S = Stop functionality (v = 0)
' Revision 2.1 16 Nov 2001
' Added Terrell rotation Revision 3 24 Sep 2002
' Added v observed Revision 3.1 8 Mrt 2004
' Revision 4 23 Apr 2015
' Added Length Contraction functionality - Corrected ts2 te2 calc
DECLARE SUB GETSCREEN ()
DECLARE SUB SETSTANDARD ()
DECLARE SUB ANGLE (x#, y#, angl#)
DECLARE SUB INITIALISE ()
DECLARE SUB GETXY (posi, r, x#, y#, ts#)
CONST pi = 3.141592653589#
CONST pi2 = 2 * pi
CONST left = 75, right = 77, ESC = 27, up = 72, down = 80
DIM SHARED lc, r, posmax, c, x0
DIM SHARED scren%, typetr
DIM SHARED xmax, ymax, xchrmax, ychrmax, fract
DIM SHARED waittim, delta, test%
null$ = CHR$(0) ' See page 191
s0:
CLS : COLOR 7
INPUT "demo type ? (1 = Round 2 = Long 3 = Terrell 0 = end) "; typetr
INITIALISE
SELECT CASE typetr
CASE IS = 1
title$ = "Train on round track Demonstration"
posobsrx = 41
posobsry = ychrmax / 2 + 1
CASE IS = 2
title$ = "Train on long track Demonstration"
posobsrx = 22
posobsry = ychrmax / 2 + 1
CASE IS = 3
title$ = "Terrell rotation ?"
posobsrx = 41
posobsry = ychrmax / 2 + 5
CASE ELSE
END
END SELECT
s1:
INITIALISE: INIT = 1
SCREEN scren%: CLS
COLOR 7
LOCATE 1, 25: PRINT title$
LOCATE ychrmax - 1, 1: PRINT "Use RIGHT arrow key to increase the speed of the train";
COLOR 15
LOCATE posobsry, posobsrx: PRINT "O"
LOCATE 3, 60: PRINT "O = Observer";
COLOR 7
LOCATE ychrmax, 1: PRINT "Use LEFT arrow key to decrease the speed of the train";
LOCATE ychrmax - 2, 1: PRINT "Use F to Freeze ";
LOCATE ychrmax - 2, 22: PRINT "L for Length Contr";
LOCATE ychrmax - 2, 46: PRINT "S to Stop";
LOCATE ychrmax - 2, 62: PRINT "Esc to Terminate";
send = 0 ' end condition
Rdis = r * fract ' radius displayed
r2 = r * 1.4
ltrain = 100: ltrain1 = ltrain ' length train
gamma = 1: lc = 0 ' gamma and length contraction
eyer = r * fract / 2 ' radius eye displayed
eyer2 = r * fract / 2 + 5 ' radius eye displayed
x0 = xmax / 2 - r: y0 = ymax / 2 ' center left circle
x1 = x0 + 2 * r ' center right circle
x0dis = xmax / 2 - Rdis: x1dis = x0dis + 2 * Rdis 'display coordinates
stopx = 0: ' stop = 0
vmax = 100:
dvfact = pi / 1000: dv% = 1
dts = dvfact * r / 2 ' delta ts for stopx=1 = .36/2
v% = 0 ' initial speed of the train
ts = r / c: ' delay time object 1
ts2 = r2 / c: ' delay time object 2
pos1 = 0
pos2 = 0
SELECT CASE typetr
CASE IS = 1
x0 = xmax / 2: x0dis = x0
posmax = 2 * pi * r
CASE IS = 2
posmax = 2 * r + pi * r + 2 * r + pi * r
CASE IS = 3
x0 = xmax / 2: x0dis = x0
posmax = 2 * pi * r
y0 = y0 + 50
END SELECT
str: PSET (x0dis, y0), 15 ' center
poso = pos1
pos1 = pos1 + v% * r * dvfact:
poso2 = pos2
pos2 = pos2 + v% * r * dvfact:
SELECT CASE typetr
CASE IS = 1, 2
IF pos1 > posmax THEN pos1 = pos1 - posmax
IF pos1 < 0 THEN pos1 = pos1 + posmax
CASE IS = 3
IF pos1 > 300 AND v% > 0 THEN pos1 = -270: pos2 = -270
IF pos1 < -270 AND v% < 0 THEN pos1 = 300: pos2 = 300
END SELECT
IF INIT = 0 THEN
xdispso = xdisps: yso = ys
xdispeo = xdispe: yeo = ye
angso = angs: angeo = ange
pos1so = pos1s
END IF
xdispso2 = xdisps2: yso2 = ys2
xdispeo2 = xdispe2: yeo2 = ye2
angso2 = angs2: angeo2 = ange2
'GETXY pos1, xs, ys, ts
IF stopx = 0 THEN
FOR i = 0 TO 5
pos1s = pos1 - ts * v%
GETXY pos1s, r, xs, ys, ts
NEXT i
ELSE
ts = ts - dts
IF ts < 0 THEN ts = 0
pos1s = pos1 - ts * volds
GETXY pos1s, r, xs, ys, tss
END IF
xdisps = xs
IF INIT = 1 THEN pos1so = pos1s
IF stopx = 0 THEN
vs = (pos1s - pos1so) / (r * dvfact)
ELSE
vs = (pos1s - pos1so) / dts / 2
END IF
COLOR 12
IF vold = v% THEN
LOCATE 3, 1:
IF vs * v% >= 0 THEN PRINT "v obs"; : PRINT USING "###.##"; vs; : PRINT SPACE$(3)
END IF
COLOR 7
ANGLE xs, ys, angs
IF stopx = 0 THEN
GETXY pos1 - ltrain1, r, xe, ye, te
FOR i = 0 TO 5
pos1e = pos1 - ltrain1 - te * v%
GETXY pos1e, r, xe, ye, te
NEXT i
ELSE
te = te - dts
IF te < 0 THEN te = 0
pos1e = pos1 - ltrain1 - te * volds
GETXY pos1e, r, xe, ye, tee
END IF
xdispe = xe
'IF xdispe > 2 * R THEN xdispe = 2 * R + (xdispe - 2 * R)
'IF xdispe < 0 THEN xdispe = xdispe
ANGLE xe, ye, ange
IF INIT = 1 THEN
xdispso = xdisps: yso = ys
xdispeo = xdispe: yeo = ye
angso = angs: angeo = ange
INIT = 0
END IF
IF stopx = 0 THEN
vold = v%
FOR i = 0 TO 5
pos2s = pos2 - ts2 * v%
GETXY pos2s, r2, xs2, ys2, ts2
NEXT i
ELSE
ts2 = ts2 - dts
IF ts2 < 0 THEN ts2 = 0
pos2s = pos2 - ts2 * volds
GETXY pos2s, r2, xs2, ys2, tss2
END IF
xdisps2 = xs2
ANGLE xs2, ys2, angs2
IF stopx = 0 THEN
GETXY pos2 - ltrain1, r2, xe2, ye2, te2
FOR i = 0 TO 5
pos2e = pos2 - ltrain1 - te2 * v%
GETXY pos2e, r2, xe2, ye2, te2
NEXT i
ELSE
te2 = te2 - dts
IF te2 < 0 THEN te2 = 0
pos2e = pos2 - ltrain1 - te2 * volds
GETXY pos2e, r2, xe2, ye2, tee2
END IF
xdispe2 = xe2
ANGLE xe2, ye2, ange2
LOCATE 2, 1: PRINT "Speed "; v%
LOCATE 2, 16: PRINT "Length train ";
PRINT USING "####.##"; pos1s - pos1e
LOCATE 2, 42: PRINT "Length Contr ";
IF lc = 0 THEN PRINT "OFF" ELSE PRINT "ON "
LOCATE 2, 66: PRINT "Speed c "; c
' LOCATE 3, 1: PRINT "xs "; xs; "ys "; ys; SPACE$(5)
' LOCATE 4, 1: PRINT angs * 180 / pi ' ange * 180 / pi
' LOCATE 5, 1: PRINT "pos1 "; pos1; "pos1s "; pos1s; SPACE$(5)
reo = re: rso = rs: rso1 = rs1: reo1 = re1
poseo = pose: posso = poss
IF typetr = 3 THEN
reo2 = re2: rso2 = rs2: rso2 = rs2: reo2 = re2
poseo2 = pose2: posso2 = poss2
END IF
SELECT CASE typetr
CASE IS = 1
' circle
rs = pos1 / r: re = rs - ltrain1 / r
rs = pi / 2 - rs: re = pi / 2 - re: ' 4 o'clock and 3 o'clock
IF rs < 0 THEN rs = rs + pi2
IF re < 0 THEN re = re + pi2
rs1 = rs: re1 = re ' 3 o'clock and 4 o'clock
IF rs < re THEN
re1 = 0
rs1 = re1
ELSE
rs = 0
re1 = pi2
IF rs1 > pi2 - .01 THEN rs1 = 0: re1 = 0
END IF
CIRCLE (x0dis + xdispso * fract, y0 - yso), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdispeo * fract, y0 - yeo), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis, y0), Rdis, 0, rso, reo
IF rso1 <> reo1 THEN CIRCLE (x0dis, y0), Rdis, 0, rso1, reo1
CIRCLE (x0dis, y0), Rdis, 15, rs, re
IF rs1 <> re1 THEN CIRCLE (x0dis, y0), Rdis, 15, rs1, re1
CIRCLE (x0dis + xdisps * fract, y0 - ys), 1.5, 12 ' new red dot
CIRCLE (x0dis + xdispe * fract, y0 - ye), 1.5, 4 ' new red dot
' Observer yellow horizon
CIRCLE (x0dis, y0), eyer, 0, angso, angeo
CIRCLE (x0dis, y0), eyer, 14, angs, ange
CASE IS = 2
' Horizontal part top
IF pos1 > 0 AND pos1 < (2 * r + ltrain1) THEN
poss = pos1: pose = pos1 - ltrain1
IF pose < 0 THEN pose = 0
IF poss > 2 * r THEN poss = 2 * r
END IF
' Right circle
IF pos1 > 2 * r AND pos1 < (2 * r + pi * r + ltrain1) THEN
rs = (pos1 - 2 * r) / r: re = rs - ltrain1 / r
rs = pi / 2 - rs: re = pi / 2 - re: '12 o'clock and 3 o'clock
rs1 = rs + pi2: re1 = re + pi2 ' 3 o'clock and 6 o'clock
IF rs < 0 THEN rs = 0
IF re > pi / 2 THEN re = pi / 2
IF rs1 > pi2 THEN rs1 = pi2
IF re1 > pi2 THEN re1 = pi2
IF rs1 < 1.5 * pi THEN rs1 = 1.5 * pi
END IF
' Horizontal part bottom
IF pos1 > (2 * r + pi * r) AND pos1 < (4 * r + pi * r + ltrain1) THEN
poss = pos1 - 2 * r - pi * r: pose = poss - ltrain1
IF pose < 0 THEN pose = 0
IF poss > 2 * r THEN poss = 2 * r
END IF
' Left cicle
IF (pos1 >= 0 AND pos1 < ltrain1) OR (pos1 > (4 * r + pi * r) AND pos1 < (4 * r + 2 * pi * r)) THEN
IF pos1 > ltrain1 THEN
rs = (pos1 - 4 * r - 2 * pi * r) / r
ELSE
rs = pos1 / r
END IF
rs = pi / 2 - rs ' 1.5*pi < rs < 0.5*pi from 3 o'clock
re = rs + ltrain1 / r
IF rs < pi / 2 THEN rs = pi / 2
IF re > 1.5 * pi THEN re = 1.5 * pi
END IF
CIRCLE (x0dis + xdispso * fract, y0 - yso), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdispeo * fract, y0 - yeo), 1.5, 0 ' clear red dot with black dot
' Horizontal part top
IF poso > 0 AND poso < (2 * r + ltrain1) THEN
LINE (x0dis + poseo * fract, y0 - r)-(x0dis + posso * fract, y0 - r), 0
END IF
IF pos1 > 0 AND pos1 < (2 * r + ltrain1) THEN
LINE (x0dis + pose * fract, y0 - r)-(x0dis + poss * fract, y0 - r), 15
END IF
' right circle
IF poso > 2 * r AND poso < (2 * r + pi * r + ltrain1) THEN
IF reo > 0 THEN CIRCLE (x1dis, y0), Rdis, 0, rso, reo
IF rso1 <> pi2 THEN CIRCLE (x1dis, y0), Rdis, 0, rso1, reo1
END IF
IF pos1 > 2 * r AND pos1 < (2 * r + pi * r + ltrain1) THEN
IF re > 0 THEN CIRCLE (x1dis, y0), Rdis, 15, rs, re
IF rs1 <> pi2 THEN CIRCLE (x1dis, y0), Rdis, 15, rs1, re1
END IF
' Horizontal part bottom
IF poso > (2 * r + pi * r) AND poso < (4 * r + pi * r + ltrain1) THEN
LINE (x0dis + 2 * Rdis - posso * fract, y0 + r)-(x0dis + 2 * Rdis - poseo * fract, y0 + r), 0
END IF
IF pos1 > (2 * r + pi * r) AND pos1 < (4 * r + pi * r + ltrain1) THEN
LINE (x0dis + 2 * Rdis - poss * fract, y0 + r)-(x0dis + 2 * Rdis - pose * fract, y0 + r), 15
END IF
'left circle
IF (poso > 0 AND poso < ltrain1) OR (poso > (4 * r + pi * r) AND poso < (4 * r + 2 * pi * r)) THEN
CIRCLE (x0dis, y0), Rdis, 0, rso, reo
END IF
IF (pos1 >= 0 AND pos1 < ltrain1) OR (pos1 > (4 * r + pi * r) AND pos1 < (4 * r + 2 * pi * r)) THEN
CIRCLE (x0dis, y0), Rdis, 15, rs, re
END IF
CIRCLE (x0dis + xdisps * fract, y0 - ys), 1.5, 12 ' new red start dot
CIRCLE (x0dis + xdispe * fract, y0 - ye), 1.5, 4 ' new red end dot
' Observer
CIRCLE (x0dis, y0), eyer, 0, angso, angeo
' detect negative length of train !! by v > c
IF pos1s < pos1e THEN asave = angs: angs = ange: ange = asave
CIRCLE (x0dis, y0), eyer, 14, angs, ange
CASE IS = 3
IF angs > ange THEN ange = angs + .001
IF angs2 > ange2 THEN ange2 = angs2 + .001
poss = pos1: pose = pos1 - ltrain1
LINE (x0dis + poseo * fract, y0 - r)-(x0dis + posso * fract, y0 - r), 0
LINE (x0dis + pose * fract, y0 - r)-(x0dis + poss * fract, y0 - r), 15
CIRCLE (x0dis + xdispso * fract, y0 - yso), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdispeo * fract, y0 - yeo), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdisps * fract, y0 - ys), 1.5, 12 ' new red dot
CIRCLE (x0dis + xdispe * fract, y0 - ye), 1.5, 4 ' new red dot
' Observer yellow horizon
CIRCLE (x0dis, y0), eyer, 0, angso, angeo
CIRCLE (x0dis, y0), eyer, 14, angs, ange
poss2 = pos2: pose2 = pos2 - ltrain1
LINE (x0dis + poseo2 * fract, y0 - r2)-(x0dis + posso2 * fract, y0 - r2), 0
LINE (x0dis + pose2 * fract, y0 - r2)-(x0dis + poss2 * fract, y0 - r2), 15
CIRCLE (x0dis + xdispso2 * fract, y0 - yso2), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdispeo2 * fract, y0 - yeo2), 1.5, 0 ' clear red dot with black dot
CIRCLE (x0dis + xdisps2 * fract, y0 - ys2), 1.5, 12 ' new red dot
CIRCLE (x0dis + xdispe2 * fract, y0 - ye2), 1.5, 4 ' new red dot
' Observer yellow horizon
CIRCLE (x0dis, y0), eyer2, 0, angso2, angeo2
CIRCLE (x0dis, y0), eyer2, 14, angs2, ange2
END SELECT
freeze = 0
time1 = TIMER + waittim
s16:
a$ = INKEY$
IF a$ = CHR$(ESC) THEN send = 1
IF UCASE$(a$) = "S" THEN volds = v%: v% = 0: vold = 0: stopx = 1
IF UCASE$(a$) = "F" THEN
freeze = freeze + 1
COLOR 15
LOCATE ychrmax - 2, 1: PRINT "Use F to Un-Freeze";
END IF
IF UCASE$(a$) = "L" THEN
IF lc = 1 THEN lc = 0 ELSE lc = 1
END IF
IF freeze = 1 AND send <> 1 THEN GOTO s16
IF freeze <> 0 THEN
COLOR 7
LOCATE ychrmax - 2, 1: PRINT "Use F to Freeze ";
END IF
'IF time1 <> 0 THEN
IF a$ = null$ + CHR$(right) THEN vold = v%: v% = v% + dv%: stopx = 0
IF v% = c THEN v% = v% - dv%
IF a$ = null$ + CHR$(left) THEN vold = v%: v% = v% - dv%: stopx = 0: 'time1 = TIMER
IF lc > 0 THEN gamma = 1 / SQR(1 - v% * v% / (c * c)) ELSE gamma = 1
ltrain1 = ltrain / gamma ' Lorentz Contracion
'ELSE
IF TIMER < time1 THEN GOTO s16 ' clear lock
'END IF
IF x1 < 0 THEN END
IF send = 1 THEN GOTO s10
GOTO str
s10:
COLOR 14
LOCATE ychrmax, 1: PRINT SPACE$(60);
LOCATE ychrmax, 20: PRINT "NEXT TEST ?";
DO: a$ = INKEY$: LOOP UNTIL a$ <> ""
GOTO s0
SUB ANGLE (x, y, angl)
' ANGLE
x1 = x: y1 = y
IF x1 >= 0 AND y1 > 0 THEN dang = 0: sign = 1
IF x1 < 0 AND y1 > 0 THEN dang = pi: x1 = -x1: sign = -1
IF x1 < 0 AND y1 < 0 THEN dang = pi: x1 = -x1: y1 = -y1: sign = 1
IF x1 >= 0 AND y1 < 0 THEN dang = 2 * pi: y1 = -y1: sign = -1
IF x1 < .01 THEN x1 = .01
angl = ATN(y1 / x1) * sign + dang
END SUB
SUB GETSCREEN
' GETSCREEN
SELECT CASE scren%
CASE 7
xmax = 320: ymax = 200
r = 60: fract = 1.2
xchrmax = 40: ychrmax = 25
CASE 8
xmax = 640: ymax = 200
r = 60: fract = 2.4
xchrmax = 80: ychrmax = 25
CASE 9
xmax = 640: ymax = 350
r = 115: fract = 1.368
xchrmax = 80: ychrmax = 25
CASE 12
xmax = 640: ymax = 480
r = 150: fract = 1
xchrmax = 80: ychrmax = 30
CASE ELSE
nscren% = scren%: PRINT "SCREEN ERROR, not 7, 8, 9 or 12"
END SELECT
EXIT SUB
END SUB
SUB GETXY (pos1, r, x, y, t)
' GETXY
' This subroutine calculates the x,y coordinates of pos1
' the distance from the observer
' and the time t from the observer
' The observer stands at 0,0
posi = pos1
SELECT CASE typetr
CASE IS = 1
IF posi < 0 THEN posi = posi + posmax
IF posi < pi * r THEN ' right circle
y = r * COS(posi / r)
x = r * SIN(posi / r)
ELSE ' left circle
posi = posi - pi * r
y = -r * COS(posi / r)
x = -r * SIN(posi / r)
END IF
CASE IS = 2
IF posi < 0 THEN posi = posi + posmax
IF posi < 2 * r THEN ' top track
y = r: x = posi
GOTO e1
END IF
posi = posi - 2 * r
IF posi < pi * r THEN ' right circle
y = r * COS(posi / r)
x = 2 * r + r * SIN(posi / r)
GOTO e1
END IF
posi = posi - pi * r
IF posi < 2 * r THEN ' bottom track
y = -r: x = 2 * r - posi
ELSE ' left circle
posi = posi - 2 * r
y = -r * COS(posi / r)
x = -r * SIN(posi / r)
END IF
CASE IS = 3
y = r: x = posi
END SELECT
e1:
dist = SQR(x * x + y * y)
t = dist / c
END SUB
SUB INITIALISE
' INITIALISE
delta = .1 'display factor for vx and vy
waittim = .1 'wait time in seconds
scren% = 9 'screen mode 9
c = 30 'speed of light
x0 = 1000
GETSCREEN
END SUB
Back to my home page Contents of This Document