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