'                         ***************************
'                         *                         *
'                         *  PLANETARIUMSIMULATION  *
'                         *        Vers. 1.0i       *
'                         ***************************
' ==============================================================================
'                          H A U P T P R O G R A M M
' ==============================================================================
$S>
$S&
CLS
@titlescreen
@init
@fade
CLOSES 7
@start
WHILE end&=0
  IF end&=0 THEN
    ON cont& GOSUB starchart,planetarium
  ENDIF
WEND
@closeprogram
EDIT
' ==============================================================================
'                          P R O G R A M M - M O D U L E
' ==============================================================================
PROCEDURE titlescreen
  DIM plane%(8),plane$(8)
  pfad$=DIR$(0)
  @load_acbm(pfad$+"planetarium.pic",99)          ! load graphics to screen
  DISPLAY ON
RETURN
'  -----------------------------------
PROCEDURE setcol1
  SETCOLOR 0,0,0,0       ! black
  SETCOLOR 1,15,15,15    ! white
  SETCOLOR 2,15,15,4     ! light yellow
  SETCOLOR 3,15,3,3      ! light red
  SETCOLOR 4,8,8,15      ! light blue
  SETCOLOR 5,14,5,0      ! intensif red
  SETCOLOR 6,15,12,10    ! ochre
  SETCOLOR 7,1,1,3       ! dark blue
RETURN
'  -----------------------------------
PROCEDURE setcol2
  SETCOLOR 0,12,12,12      ! gray
  SETCOLOR 1,0,0,0         ! black
  SETCOLOR 4,15,15,15      ! white
  SETCOLOR 7,1,1,3         ! dark blue
RETURN
'  -----------------------------------
PROCEDURE fade
  FOR color&=0 TO 10
    fade&=(15/10)*color&
    FOR pal&=1 TO cols&
      SETCOLOR pal&,15-fade&,15-fade&,15
    NEXT pal&
  NEXT color&
  FOR color&=0 TO 10
    fade&=(15/10)*color&
    FOR pal&=1 TO cols&
      SETCOLOR pal&,0,0,15-fade&
    NEXT pal&
  NEXT color&
RETURN
'  ===================================
PROCEDURE init
  end&=0
  presetloc&=1  ! pre-set location
  @presetloc
  s_time!=TRUE  ! set system-time
  sim!=FALSE    ! forces creation of whole screen
  tele!=FALSE   ! Teleskope switched off
  avail&=0      ! counter for available telescope objects
  mode&=1       ! Defaultmode starchart
  resolution&=2 ! Defaul Hires
  hori&=640
  verti&=256
  i1&=239       ! i1&=number of stars
  i2&=240
  i3&=50        ! i3&=number of constellations
  f=1
  datum$=SPACE$(10)
  format$=SPACE$(18)
  format1$=SPACE$(26)
  year$=RIGHT$(DATE$,4)
  IF MID$(DATE$,3,1)="." THEN
    day$=LEFT$(DATE$,2)
    month$=MID$(DATE$,4,2)
  ELSE
    day$=LEFT$(DATE$)
    month$=MID$(DATE$,3,2)
  ENDIF
  interval$="2"
  delay$="6"
  p1=PI/180
  p2=180/PI
  c=360
  DIM z$(i3&,1),z&(i3&,1)
  DIM fpos&(i2&,1),p(11),re(i2&),de(i2&),fstern$(i2&)
  DIM const&(i2&),lk(i2&)
  DIM plan$(5),tb(5),ep(5),ph(5),mp(5),e(5),kn(5),i(5),ae(5)
  DIM plpos&(5,1)
  DIM men$(40)
  DIM avail$(20)
  ' ----------------------------------------------------------------
  ' read data
  '
  RESTORE constellations
  FOR i&=0 TO i3&
    READ z$(i&,0),z$(i&,1),z&(i&,0),z&(i&,1)
  NEXT i&
  RESTORE fstars
  FOR s&=1 TO i1&
    READ re(s&)
    READ de(s&)
    READ fstern$(s&)
    READ const&(s&)
    READ lk(s&)
  NEXT s&
  RESTORE planets
  FOR p&=0 TO 5
    READ plan$(p&),tb(p&),ep(p&),ph(p&),mp(p&),e(p&),kn(p&),i(p&),ae(p&)
  NEXT p&
  RESTORE availobjects
  REPEAT
    INC avail&
    READ avail$(avail&)
  UNTIL avail$(avail&)="ENDE"
  DEC avail&
  ' ----------------------------------------------------------------
  '  ** funktions **
  DEFFN mo(x)=x-INT(x/c)*c     ! special modulo
RETURN
'  ===================================
PROCEDURE presetloc
  ON presetloc& GOSUB wuennenberg,berlin,moskow,new_york,arctic,antarctic,quito
RETURN
'  ===================================
PROCEDURE systemtime
  LSET datum$=DATE$
  localtime$=TIME$
RETURN
'  -----------------------------------
PROCEDURE start
  CLOSES 1
  OPENS 1,0,0,640,256,3,32768
  OPENW #1,0,0,640,256,0,1024,1
  TITLEW #1,"                               Planetarium"
  ~ActivateWindow(WINDOW(1))
  cont&=0
  @setcol1
  @about
  @initmenu1
  WHILE cont&=0
    ON MENU GOSUB checkmenu
    SLEEP
  WEND
RETURN
'  -----------------------------------
PROCEDURE about
  CLS
  LOCATE 1,3
  PCOLOR 4,0
  PRINT "This program, originally written for C64 by H.Hinkelmann, shows a view of the"
  PRINT
  PRINT "whole sky (a celestial chart) for any date and time and any place on earth."
  PRINT
  PRINT "Default time is system time, read by the program from time$ and date$,"
  PRINT
  PRINT "default place is W"+CHR$(220)+"NNENBERG (where I live)."
  PRINT
  PRINT "Date, time and place may be altered by selecting the appropriate functions"
  PRINT
  PRINT "from the pulldown menu. Pointing at stars and clicking the left mousebutton"
  PRINT
  PRINT "will cause flashing of all stars belonging to the constellation. The name of"
  PRINT
  PRINT "the star you pointed at and the name of its constellation (german and latin)"
  PRINT
  PRINT "will be shown. Choosing 'Look for name' from the menu will let you enter the"
  PRINT
  PRINT "name of a star or constellation and show their positions as explained before."
  PRINT
  PRINT "The other functions are self-explicable (I hope)."
  PRINT
  PRINT "ENJOY !!"
RETURN
'  -----------------------------------
PROCEDURE initmenu1
  RESTORE men1
  i%=-1
  REPEAT
    INC i%
    READ men$(i%)
  UNTIL men$(i%)="ENDE"
  men$(i%)=""
  men$(i%+1)=""
  MENU men$()
  FOR i%=4 TO 7
    MENU (i%),16+192
  NEXT i%
  MENU (27+resolution&),16+64+256            ! set hook
  MENU (22+mode&),16+64+256
  MENU (12+presetloc&),16+64+256
  @keys
RETURN
'  -----------------------------------
PROCEDURE keys
  MENU KEY 1,&H63
  MENU KEY 2,&H65
  MENU KEY 10,&H6C
  MENU KEY 11,&H64
  MENU KEY 23,&H73
  MENU KEY 24,&H70
  MENU KEY 25,&H74
  MENU KEY 28,&H31
  MENU KEY 29,&H32
  MENU KEY 32,&H6E
  MENU KEY 35,&H68
RETURN
'  -----------------------------------
PROCEDURE checkmenu
  SELECT MENU(0)
  CASE 1
    cont&=mode&
  CASE 2                     ! closeprogram
    cont&=1
    end&=1
  CASE 10,11
    ON (MENU(0)-9) GOSUB setloc,settime
    cont&=mode&
  CASE 13 TO 19              ! pre-set locations
    presetloc&=MENU(0)-12
    FOR i&=13 TO 20
      MENU (i&),16+64
    NEXT i&
    MENU (12+presetloc&),16+64+256
    @presetloc
    @show_loc
    cont&=mode&
  CASE 20
    @setstime
    cont&=mode&
  CASE 23,24                 ! chart or planetarium
    EVERY STOP
    sim!=FALSE
    mode&=MENU(0)-22
    cont&=mode&
    MENU 23,16+64
    MENU 24,16+64
    MENU MENU(0),16+64+256
    IF mode&=2
      cont&=mode&
      FOR i&=10 TO 20
        MENU i&,16+16        ! not to be chosen in planetarium-mode
      NEXT i&
    ENDIF
  CASE 25                    ! toggle telescope-mode on/off
    IF tele!=TRUE THEN
      tele!=FALSE
      MENU 25,16+64
    ELSE
      tele!=TRUE
      MENU 25,16+64+256
    ENDIF
  CASE 28,29                 ! MedRes or HiRes
    sim!=FALSE
    resolution&=MENU(0)-27
    FOR i&=28 TO 29
      MENU i&,16+64
    NEXT i&
    MENU MENU(0),16+64+256
  CASE 32                    ! look for star/constellation
    IF mode&=2               ! interrupt planetarium-mode
      EVERY STOP
      @get_name
      EVERY  CONT
    ELSE
      @get_name
    ENDIF
  CASE 35                    ! hardcopy
    @print
  ENDSELECT
RETURN
'  -----------------------------------
PROCEDURE setloc
  SETWPEN 7,6
  OPENW #2,110,verti&/2-60,420,120,0,0,1
  TITLEW #2," Please enter coordinates :"
  ~ActivateWindow(WINDOW(2))
  CLS
  LOCATE 1,1
  PRINT "    Accepted are:"
  PRINT "    Latitude    90 (north) to  -90 (south)"
  PRINT "    Longitude  180 (west)  to -180 (east)"
  PRINT " ---------------------------------------------"
  latitude$=STR$(latitude)
  longitude$=STR$(longitude)
  latitude=500
  longitude=500
  loc$=""
  WHILE ABS(latitude)>90
    LOCATE 1,6
    PRINT "    Latitude         ";
    FORM INPUT 5 AS latitude$
    latitude=VAL(latitude$)
  WEND
  WHILE ABS(longitude)>180
    LOCATE 1,8
    PRINT "    Longitude        ";
    FORM INPUT 6 AS longitude$
    longitude=VAL(longitude$)
  WEND
  LOCATE 1,10
  INPUT "    Name of location ",loc$
  CLOSEW #2
  COLOR 0,6
  SETWPEN 0,1
  FOR i&=13 TO 20
    MENU (i&),16+64
  NEXT i&
  presetloc&=0
RETURN
'  -----------------------------------
PROCEDURE settime
  @systemtime
  wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,4,2))/100-1
  IF wtime<0 THEN
    wtime=wtime+24
  ENDIF
  OPENW #2,110,verti&/2-60,420,120,0,0,1
  TITLEW #2," Set time of observation :"
  ~ActivateWindow(WINDOW(2))
  CLS
  LOCATE 1,1
  PRINT "           Present dates:"
  PRINT " ---------------------------------------------"
  PRINT "          Date :   ";DATE$
  PRINT "    Systemtime :   ";localtime$
  PRINT "Universal time :   ";wtime
  PRINT " ---------------------------------------------"
  year&=0
  month&=0
  day&=0
  WHILE year&<=0 OR year&>3000
    LOCATE 3,7
    PRINT "Year   ";
    FORM INPUT 4 AS year$
    year&=VAL(year$)
  WEND
  WHILE month&<=0 OR month&>12
    LOCATE 16,7
    PRINT "Month  ";
    FORM INPUT 2 AS month$
    month&=VAL(month$)
  WEND
  IF (month&<8 AND month& MOD 2<>0) OR (month&>7 AND month& MOD 2=0) THEN
    WHILE day&<=0 OR day&>31
      LOCATE 30,7
      PRINT "Day   ";
      FORM INPUT 2 AS day$
      day&=VAL(day$)
    WEND
  ENDIF
  IF (month&<8 AND month& MOD 2=0) OR (month&>7 AND month& MOD 2<>0) THEN
    WHILE day&<=0 OR day&>30
      LOCATE 30,7
      PRINT "Day   ";
      FORM INPUT 2 AS day$
      day&=VAL(day$)
    WEND
  ENDIF
  IF month&=2 AND year& MOD 4<>0 THEN
    WHILE day&<=0 OR day&>28
      LOCATE 30,7
      PRINT "Day   ";
      FORM INPUT 2 AS day$
      day&=VAL(day$)
    WEND
  ENDIF
  IF month&=2 AND year& MOD 4=0 AND year& MOD 400<>0 THEN
    WHILE day&<=0 OR day&>29
      LOCATE 30,7
      PRINT "Day   ";
      FORM INPUT 2 AS day$
      day&=VAL(day$)
    WEND
  ENDIF
  IF month&=2 AND year& MOD 4=0 AND year& MOD 400=0 THEN
    WHILE day&<=0 OR day&>28
      LOCATE 30,7
      PRINT "Day   ";
      FORM INPUT 2 AS day$
      day&=VAL(day$)
    WEND
  ENDIF
  PRINT "---------------------------------------------"
  wtime$=STR$(wtime)
  wtime=-1
  WHILE wtime<0 OR wtime>23.59 OR FRAC(wtime)>=0.6
    PRINT " Plase enter universal time (hh.mm):";
    LOCATE 20,CRSLIN+1
    FORM INPUT 5 AS wtime$
    wtime=VAL(wtime$)
  WEND
  datum$=RIGHT$("0"+STR$(day&),2)+"."+RIGHT$("0"+STR$(month&),2)+"."+STR$(year&)
  s_time!=FALSE
  CLOSEW #2
RETURN
'  -----------------------------------
PROCEDURE wuennenberg
  loc$="W"+CHR$(252)+"nnenberg"
  latitude=52
  longitude=-8.5
RETURN
'  -----------------------------------
PROCEDURE berlin
  loc$="Berlin"
  latitude=51.6
  longitude=-14
RETURN
'  -----------------------------------
PROCEDURE moskow
  loc$="Moskow"
  latitude=55.5
  longitude=-37.5
RETURN
'  -----------------------------------
PROCEDURE new_york
  loc$="New York"
  latitude=40.6
  longitude=-74
RETURN
'  -----------------------------------
PROCEDURE arctic
  loc$="Arctic Pole"
  latitude=90
  longitude=0
RETURN
'  -----------------------------------
PROCEDURE antarctic
  loc$="Antarctic Pole"
  latitude=-90
  longitude=0
RETURN
'  -----------------------------------
PROCEDURE quito
  loc$="Quito (equator)"
  latitude=0.5
  longitude=78
RETURN
'  -----------------------------------
PROCEDURE show_loc
  w_width&=28*8+8*LEN(loc$)+4
  OPENW #3,hori&/2-w_width&/2,verti&/2-15,w_width&,30,0,0,1
  TITLEW #3,"         Location "
  CLS
  PRINT
  PRINT " .. setting parameters for "+loc$;
  DELAY 1
  CLOSEW #3
RETURN
'  -----------------------------------
PROCEDURE setstime
  s_time!=TRUE
  OPENW #3,hori&/2-120,verti&/2-15,240,30,0,0,1
  TITLEW #3,"            Time "
  CLS
  PRINT
  PRINT "   ...... setting systemtime"
  DELAY 1
  CLOSEW #3
RETURN
'  ===================================
PROCEDURE starchart
  cont&=0
  WHILE cont&=0
    @buildscreen
    @set_stars
    sim!=TRUE
    @initmenu2
    DEFMOUSE 3
    SETCOLOR 17,&HF00
    @functs
  WEND
RETURN
'  -----------------------------------
PROCEDURE buildscreen
  @adapt
  IF ABS(latitude)=90
    MUL latitude,0.99999999
  ENDIF
  sb=SIN(RAD(latitude))
  cb=COS(RAD(latitude))
  IF s_time!=TRUE THEN
    @systemtime
    IF MID$(localtime$,2,1)=":" THEN
      wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,3,2))/100-1
    ELSE
      wtime=VAL(LEFT$(localtime$,2))+VAL(MID$(localtime$,4,2))/100-1
    ENDIF
    IF wtime<0 THEN
      wtime=wtime+24
    ENDIF
  ENDIF
  IF mode&=1 THEN
    @timefunction
  ENDIF
  IF loc$<>"" AND LEFT$(loc$,3)<>"for" THEN
    loc$="for "+loc$
  ENDIF
  IF sim!=FALSE THEN
    CLOSES 1
    OPENS 1,0,0,hori&,verti&,3,modus%
    OPENW #0,0,0,hori&,verti&,8+16+1024,512,1
    CLS
  ENDIF
  TITLEW #0,"Celestial chart "+loc$
  ~ActivateWindow(WINDOW(0))
  @setcol1
  @setcol2
  COLOR 7,0
  PELLIPSE hori&/2,verti&/2+yoff&/2,radius&*extend&,radius&
  COLOR 1
  ELLIPSE hori&/2,verti&/2+yoff&/2,radius&*extend&,radius&
  IF latitude<0 THEN
    hu=verti&
  ELSE
    hu=0
  ENDIF
  COLOR 6
  ELLIPSE hori&/2,hu+latitude/9*10*yfak+yoff&,(radius&-yoff&)/50*extend&,(radius&-yoff&)/50
  PRINT AT(xfak&,2);datum$
  PRINT AT(xfak&,xfak&+2);"OZ "+oz$
  PRINT AT(xfak&,xfak&+3);"WZ "+wz$
  IF longitude<0 THEN
    o$=SPACE$(xfak&-1)+"E"
  ELSE
    o$=SPACE$(xfak&-1)+"W"
  ENDIF
  l$=RIGHT$(SPACE$(4)+STR$(CINT(ABS(longitude))),3)
  LOCATE 31*xfak&-3,2
  PRINT "Longitude :";l$;o$
  IF latitude<0 THEN
    o$=SPACE$(xfak&-1)+"S"
    COLOR 1
  ELSE
    o$=SPACE$(xfak&-1)+"N"
    COLOR 1
  ENDIF
  TEXT hori&/2-radius&*extend&-10,verti&/2-4,"E"
  TEXT hori&/2+radius&*extend&+2,verti&/2-4,"W"
  l$=RIGHT$(SPACE$(4)+STR$(CINT(ABS(latitude))),3)
  LOCATE 31*xfak&-3,3
  PRINT "Latitude  :";l$;o$
  COLOR 1
RETURN
'  -----------------------------------
PROCEDURE adapt
  SELECT resolution&
  CASE 1
    modus%=32768
    hori&=640
    verti&=256
    extend&=2
  CASE 2
    modus%=32772
    hori&=640
    verti&=512
    extend&=1
  ENDSELECT
  xfak&=hori&/320
  yfak=verti&/200
  yoff&=6
  radius&=(verti&-2*yoff&)/2
  ' -------------------
RETURN
'  -----------------------------------
PROCEDURE set_stars
  t%=TIMER
  n1$=""
  @earthsunmoon
  @planets
  @stars
  t%=TIMER-t%
  '  PRINT AT(65,28*yfak);t%/200;
RETURN
'  -----------------------------------
PROCEDURE earthsunmoon
  be=FN mo(tg*0.985609121+99.18)
  ex=FN mo(be+SINQ(be-102.2)*1.845)
  ea=1+SINQ(ex-192.2)*0.0167
  ' Sun:
  ls=FN mo(ex+180)
  ' Moon:
  lm=tg*13.1763976+51.23
  pm=tg*0.111399014+208.9
  km=372.1-tg*0.052953643
  lm=FN mo(lm)
  pm=FN mo(pm)
  km=FN mo(km)
  am=lm-pm
  km=km-SINQ(acs)*0.16
  ms=(lm-ls)*2-am
  am=am+SINQ(ms)*1.2738888889-SINQ(acs)*(0.18638888889+0.36)
  lm=lm+SINQ(ms)*1.2738888889-SINQ(acs)*0.18638888889+SINQ(am)*6.28833333
  m1=lm-ls
  lm=lm+SINQ(m1*2)*0.65833333333
  m2=lm-km
  lm=lm-SINQ(m2*2)*0.12
  bm=SINQ(m2)*5.14539
  m3=(lm-ls)*2-m2
  bm=bm+SINQ(m3)*0.15
  al=ls
  ab=0
  @rekdek
  n$="Sun"
  color&=2
  @plot
  IF x&>0 AND y&>0 THEN
    COLOR 2
    PELLIPSE x&,y&,radius&/40*extend&,radius&/40
    COLOR 4
    ELLIPSE x&,y&,radius&/40*extend&,radius&/40
  ENDIF
  al=lm
  ab=bm
  @rekdek
  n$="Moon"
  color&=4
  @plot
  IF x&>0 AND y&>0 THEN
    COLOR 4
    PELLIPSE x&,y&,radius&/40*extend&,radius&/40
  ENDIF
RETURN
'  -----------------------------------
PROCEDURE stars
  FOR s&=1 TO i1&
    n$=fstern$(s&)
    de=de(s&)
    re=re(s&)
    lk=lk(s&)
    color&=4
    @plot
    fpos&(s&,0)=x&        ! screepositions of
    fpos&(s&,1)=y&        ! stars
  NEXT s&
RETURN
'  -----------------------------------
PROCEDURE planets
  FOR pl=0 TO 5
    n$=plan$(pl)
    ml=FN mo(tb(pl)*tg+ep(pl))
    wl=ml+SINQ(ml-ph(pl))*mp(pl)
    sp=ae(pl)+SINQ(wl-ph(pl)-90)*e(pl)*ae(pl)
    ws=FN mo(c+ex-wl)
    si=SINQ(ws)
    fl=ea/sp-COSQ(ws)
    we=DEG(ATN(si/fl))
    al=FN mo(ex+we-180*(fl>=0))
    wt=SIN((wl-kn(pl))*PI)*i(pl)
    ab=DEG(ATN(TAN(RAD(wt))*ABS(SINQ(we)/si)))
    @rekdek
    color&=5
    lk=-1
    @plot
    plpos&(pl,0)=x&       ! screenpositions of
    plpos&(pl,1)=y&       ! planets
  NEXT pl
RETURN
'  -----------------------------------
PROCEDURE rekdek
  sn=SINQ(ab)
  cs=COSQ(ab)
  sl=SINQ(al)
  cl=COSQ(al)
  de=DEG(ASIN(ec*sn+es*cs*sl))
  re=DEG(2*ATN((ec*cs*sl-es*sn)/(COSQ(de)+cs*cl)))
  re=FN mo(re)
RETURN
'  -----------------------------------
PROCEDURE plot
  ' ------ Stundenwinkel ------
  sw=FN mo(ar-re-longitude)
  ' ------ transform coordinates ------
  h=ASIN(sb*SINQ(de)+cb*COSQ(de)*COSQ(sw))
  IF h<0 THEN
    x&=0
    y&=0
  ELSE
    a=(SINQ(de)-sb*SIN(h))/(cb*COS(h))
    IF ABS(a)>=1 THEN
      a=a*0.9998
    ENDIF
    a=ACOS(a)
    IF sw<180 THEN
      a=-a
    ENDIF
    ' ------ Gradmaß ------
    r=99-h*198/PI
    w=-a-PI/2
    x&=(COS(w)*r*xfak&*1.25+hori&/2-0.5)
    y&=(SIN(w)*r*yfak+verti&/2-0.5)*0.99+yoff&
    ' ---------------------
    '    @display
    COLOR color&
    IF lk=0 THEN
      PLOT x&,y&
    ELSE
      PELLIPSE x&,y&,1*extend&,1
    ENDIF
  ENDIF
RETURN
'  -----------------------------------
PROCEDURE print
  SETCOLOR 0,15,15,15       ! black
  SETCOLOR 7,15,15,15       ! white
  SETCOLOR 1,0,0,0
  SETCOLOR 4,0,0,0
  HARDCOPY
  @setcol2
RETURN
'  ===================================
PROCEDURE timefunction
  day&=VAL(LEFT$(datum$,2))
  month&=VAL(MID$(datum$,4,2))
  year&=VAL(MID$(datum$,7))
  @time
RETURN
'  -----------------------------------
PROCEDURE time
  datum$=RIGHT$("0"+STR$(day&),2)+"."+RIGHT$("0"+STR$(month&),2)+"."+STR$(year&)
  wz$=STR$(wtime,5,2)
  wz$=" "+wz$
  zt=INT(wtime)+(FRAC(wtime)/0.6)
  lo=INT(longitude/15)*15
  oz=FN mo(zt*15-lo)/15
  oz$=" "+STR$(INT(oz))+RIGHT$(wz$,3)
  IF LEN(oz$)<6
    oz$=" "+oz$
  ENDIF
  ii=month&<3
  k=day&+INT((153*month&-11*ii-162)/5)+INT((1461*year&+ii)/4)+(year&>=0)*366
  IF k>577736 THEN
    k=k-INT((INT((year&+ii)/100)*3-5)/4)
  ENDIF
  ta=k-693596
  tg=k-711858+zt/24
  ii=ta/36525
  e=23.452294-ii*0.013125-ii*ii*1.639E-06+ii*ii*ii*5.028E-07
  es=SINQ(e)
  ec=COSQ(e)
  ' aries:
  ar=zt*360.985647/24+FRAC(ta/1461)*1440.02509
  ar=ar+INT(ta/1461)*0.307572+99.2018973
  ar=FN mo(ar)
RETURN
'  ===================================
'  -----------------------------------
PROCEDURE initmenu2
  MENU men$()
  FOR i%=4 TO 7
    MENU (i%),16+192
  NEXT i%
  MENU 24,16+64                    ! make menuitems available
  MENU 25,16+64
  MENU 32,16+64
  MENU 35,16+64
  MENU 27+resolution&,16+64+256    ! set hook
  MENU 22+mode&,16+64+256
  IF tele!=TRUE
    MENU 25,16+64+256
  ENDIF
  IF presetloc&<>0
    MENU (12+presetloc&),16+64+256
  ENDIF
  @keys
RETURN
'  -----------------------------------
PROCEDURE functs
  done!=FALSE
  WHILE cont&=0
    ON MENU GOSUB checkmenu
    ON MENU BUTTON GOSUB checkpos
    SLEEP
  WEND
RETURN
'  -----------------------------------
PROCEDURE get_name
  SETWPEN 7,6
  OPENW #2,110,verti&/2-60,420,50,0,0,1
  TITLEW #2,"Look for star or constellation"
  ~ActivateWindow(WINDOW(2))
  PRINT " Please enter name or part of";
  INPUT " name :";star$
  CLOSEW #2
  SETWPEN 0,1
  ~ActivateWindow(WINDOW(0))
  @searchname
  IF found!=FALSE THEN
    @mistake(star$+" unknown !")
  ELSE
    @found
  ENDIF
RETURN
'  -----------------------------------
PROCEDURE searchname
  found!=FALSE
  FOR p&=0 TO 5
    IF INSTR(plan$(p&),star$)<>0 THEN
      fall&=0
      show&=p&
      found!=TRUE
    ENDIF
    EXIT IF found!=TRUE
  NEXT p&
  IF found!=FALSE THEN
    FOR s&=1 TO i1&
      IF INSTR(fstern$(s&),star$)<>0
        show&=s&
        fall&=1
        found!=TRUE
      ENDIF
      EXIT IF found!=TRUE
    NEXT s&
  ENDIF
  IF found!=FALSE THEN
    FOR sb&=0 TO i3&
      IF INSTR(z$(sb&,0),star$)<>0 OR INSTR(z$(sb&,1),star$)<>0
        show&=sb&
        fall&=2
        found!=TRUE
      ENDIF
      EXIT IF found!=TRUE
    NEXT sb&
  ENDIF
RETURN
'  -----------------------------------
PROCEDURE found
  x&=0
  y&=0
  SELECT fall&
  CASE 0
    x&=plpos&(show&,0)
    y&=plpos&(show&,1)
    IF x&=0 AND y&=0
      @mistake(plan$(show&)+" not visible !")
    ELSE
      n$=plan$(show&)
      n1$=""
      @display
      COLOR 3
      ELLIPSE x&,y&,2*extend&,2
      @blink1(0)
      COLOR 1
      ELLIPSE x&,y&,2*extend&,2
    ENDIF
  CASE 1
    x&=fpos&(show&,0)
    y&=fpos&(show&,1)
    IF x&=0 AND y&=0
      @mistake(fstern$(show&)+" not visible !")
    ELSE
      n$=fstern$(show&)
      n1$=z$(const&(show&),0)+"  "+z$(const&(show&),1)
      @display
      COLOR 3
      ELLIPSE x&,y&,2*extend&,2
      @constellation
      @blink1(0)
      COLOR 1
      ELLIPSE x&,y&,2*extend&,2
      COLOR 4
      @constellation
    ENDIF
  CASE 2
    from&=z&(show&,1)
    to&=z&(show&,1)+z&(show&,0)
    FOR i&=from& TO to&
      IF fpos&(i&,0)<>0 AND fpos&(i&,1)<>0 THEN
        x&=fpos&(i&,0)
        y&=fpos&(i&,1)
        show&=i&
      ENDIF
      EXIT IF fpos&(i&,0)<>0 AND fpos&(i&,1)<>0
    NEXT i&
    IF x&=0 AND y&=0
      @mistake(z$(show&,1)+" not visible !")
    ELSE
      n$=fstern$(show&)
      n1$=z$(const&(show&),0)+"  "+z$(const&(show&),1)
      @display
      COLOR 3
      ELLIPSE x&,y&,2*extend&,2
      @constellation
      @blink1(0)
      COLOR 1
      ELLIPSE x&,y&,2*extend&,2
      COLOR 4
      @constellation
    ENDIF
  ENDSELECT
RETURN
'  -----------------------------------
PROCEDURE checkpos
  IF done!=FALSE AND MENU(5)>hori&/2-radius&*extend& AND MENU(5)<hori&/2+radius&*extend& THEN
    mausx&=MENU(5)
    mausy&=MENU(6)
    @searchstar
    IF fall&=0 THEN
      x&=plpos&(show&,0)
      y&=plpos&(show&,1)
      n$=plan$(show&)
      n1$=""
      @display
      COLOR 3
      ELLIPSE x&,y&,2*extend&,2
      @blink1(1)
      COLOR 1
      ELLIPSE x&,y&,2*extend&,2
    ELSE
      x&=fpos&(show&,0)
      y&=fpos&(show&,1)
      n$=fstern$(show&)
      n1$=z$(const&(show&),0)+"  "+z$(const&(show&),1)
      @display
      COLOR 3
      GRAPHMODE 2
      ELLIPSE x&,y&,2*extend&,2
      @constellation
      @blink1(1)
      COLOR 1
      GRAPHMODE 2
      ELLIPSE x&,y&,2*extend&,2
      COLOR 4
      @constellation
    ENDIF
  ELSE
    done!=FALSE
  ENDIF
RETURN
'  -----------------------------------
PROCEDURE searchstar
  fall&=0
  min%=2000000
  FOR p&=0 TO 5
    f1%=plpos&(p&,0)-mausx&
    f2%=plpos&(p&,1)-mausy&
    xx%=f1%*f1%+f2%*f2%
    IF xx%<min% THEN
      min%=xx%
      show&=p&
    ENDIF
  NEXT p&
  FOR s&=1 TO i1&
    f1%=fpos&(s&,0)-mausx&
    f2%=fpos&(s&,1)-mausy&
    xx%=f1%*f1%+f2%*f2%
    IF xx%<min% THEN
      min%=xx%
      show&=s&
      fall&=1
    ENDIF
  NEXT s&
RETURN
'  ----------------------------------
PROCEDURE display
  LSET format$=n$
  PRINT AT(xfak&,yfak*24-1);format$;
  LSET format1$=n1$
  PRINT AT(xfak&,yfak*24);format1$;
RETURN
'  -----------------------------------
PROCEDURE constellation
  GRAPHMODE 1
  from&=z&(const&(show&),1)
  to&=z&(const&(show&),1)+z&(const&(show&),0)
  FOR i&=from& TO to&
    PLOT fpos&(i&,0),fpos&(i&,1)
  NEXT i&
RETURN
'  -----------------------------------
PROCEDURE blink1(bed|)
  alle%=0
  aha!=FALSE
  DO
    FOR i=15 TO 0 STEP -0.1
      SETCOLOR 3,i,i,0
    NEXT i
    FOR i=0 TO 15 STEP 0.1
      SETCOLOR 3,i,i,0
    NEXT i
  LOOP WHILE MOUSEK=(bed|)
  EVERY STOP
  IF tele!=TRUE THEN                                  ! look for picture
    i&=0
    REPEAT
      INC i&
      IF INSTR(n1$,avail$(i&)) OR avail$(i&)=n$
        aha!=TRUE
        DISPLAY OFF
        @load_acbm(pfad$+avail$(i&)+".pic",99)        ! load graphic to screen
        DISPLAY ON
        REPEAT
        UNTIL MOUSEK
        CLOSES 7
        FRONTS 1
      ENDIF
    UNTIL aha!=TRUE OR i&>=avail&
  ENDIF
  IF mode&=2
    EVERY  CONT
  ENDIF
  done!=TRUE
RETURN
'  -----------------------------------
PROCEDURE mistake(mist$)
  w_x&=hori&/2-4*LEN(mist$)-2
  w_y&=verti&/2-25
  SETWPEN 0,3
  OPENW #2,w_x&,w_y&,8*LEN(mist$)+8,50,0,0,1
  TITLEW #2,"   ERROR !!"
  SOUND 1660,20,255
  PRINT mist$
  DELAY 2
  CLOSEW #2
  SETWPEN 0,1
RETURN
'  ===================================
PROCEDURE planetarium
  loc$=loc$+"          *** Planetarium ***"
  s_time!=FALSE
  @setplanparam
  $I+
  EVERY delay&*200+t% GOSUB animate
  @animate
  DO
    $U+
    SLEEP
    EXIT IF cont&=1
  LOOP
  EVERY STOP
  $U-
  $I-
  end&=0
  MENU 23,16+64+256
  MENU 24,16+64
  '  sim!=FALSE
  mode&=1
  loc$=MID$(loc$,5,LEN(loc$)-29)
RETURN
'  -----------------------------------
PROCEDURE setplanparam
  SETWPEN 7,6
  OPENW #2,190,verti&/2-20,242,40,0,0,1
  TITLEW #2,"Parameters for simulation"
  ~ActivateWindow(WINDOW(2))
  PRINT " Interval (hours)  ";
  FORM INPUT 4 AS interval$
  interval&=VAL(interval$)
  PRINT " Delay   (seconds) ";
  FORM INPUT 3 AS delay$
  delay&=VAL(delay$)
  CLOSEW #2
  SETWPEN 0,1
  ~ActivateWindow(WINDOW(0))
RETURN
'  -----------------------------------
PROCEDURE animate
  sim!=TRUE
  ADD wtime,interval&
  IF wtime>24 THEN
    WHILE wtime>24
      wtime=wtime-24
      INC day&
    WEND
    IF (month&<8 AND month& MOD 2<>0) OR (month&>7 AND month& MOD 2=0) THEN
      IF day&>31 THEN
        INC month&
        day&=day&-31
      ENDIF
    ENDIF
    IF (month&<8 AND month& MOD 2=0) OR (month&>7 AND month& MOD 2<>0) THEN
      IF day&>30
        INC month&
        day&=day&-30
      ENDIF
    ENDIF
    IF month&=2 AND year& MOD 4<>0 THEN
      IF day&>28
        INC month&
        day&=day&-28
      ENDIF
    ENDIF
    IF month&=2 AND year& MOD 4=0 AND year& MOD 400<>0 THEN
      IF day&>29
        INC month&
        day&=day&-29
      ENDIF
    ENDIF
    IF month&=2 AND year& MOD 4=0 AND year& MOD 400=0 THEN
      IF day&>28
        INC month&
        day&=day&-28
      ENDIF
    ENDIF
    IF month&>12 THEN
      INC year&
      month&=1
    ENDIF
  ENDIF
  @time
  @buildscreen
  @set_stars
RETURN
'  ===================================
PROCEDURE closeprogram
  COLOR 1,0
  CLOSES 1
RETURN
'   ----------------------------------- End --------------------------------
'   Order of datas:
'   rektascension, deklination, name, pointer to constellation , brightness
'   ========================================================================
fstars:
DATA 37.8,89.3,Polaris,0,0
DATA 0269.8,86.0,UMi2,0,0
DATA 0252.5,82.2,UMi3,0,0
DATA 0246.3,75.5,UMi4,0,0
DATA 0238.5,78.0,UMi6,0,0
DATA 0230.2,71.8,Pherkad,0,0
DATA 0222.7,74.2,Kochab,0,0
DATA 0206.9,49.3,Benetnasch,1,0
DATA 0201.0,54.9,Mizar,1,0
DATA 0193.5,56.0,Alioth,1,0
DATA 0183.9,57.0,Megrez,1,0
DATA 0178.5,53.7,Phekda,1,0
DATA 0165.9,61.8,Dubhe,1,0
DATA 0165.5,56.4,Merah,1,0
DATA 0028.6,63.7,Achird,2,0
DATA 0021.5,060.2,Ksora,2,0
DATA 0014.2,060.7,Cas3,2,0
DATA 0010.1,056.5,Schedir,2,0
DATA 0002.3,059.2,Caph,2,0
DATA 0003.3,015.2,Algenib,3,0
DATA 0326.0,009.9,Enif,3,0
DATA 0346.2,015.2,Markab,3,0
DATA 0340.8,030.2,Homam,3,0
DATA 0342.5,024.6,Matar,3,0
DATA 0345.9,028.1,Scheat,3,0
DATA 0311.6,034.0,Gienah,4,0
DATA 0310.4,045.3,Deneb,4,1.26
DATA 0305.6,040.3,Schedir,4,0
DATA 0296.2,045.1,Cyg4,4,0
DATA 0292.7,028.0,Albireo,4,0
DATA 0302.8,-00.8,Aql1,5,0
DATA 0297.7,008.9,Altair,5,0.77
DATA 0296.6,010.6,Tarazed,5,0
DATA 0292.0,003.5,Deneb Okab,5,0
DATA 0298.8,006.3,Alshain,5,0
DATA 0286.6,-04.9,Aql5,5,0
DATA 0286.4,013.9,Aql6,5,0
DATA 0284.7,032.7,Sulafat,6,0
DATA 0283.0,037.0,Lyr2,6,0
DATA 0282.5,033.4,Scheliak,6,0
DATA 0280.2,038.8,Lyr4,6,0
DATA 0279.2,038.8,Wega,6,0.04
DATA 0265.6,-39.0,Sco1,7,0
DATA 0264.3,-43.0,Sco2,7,0
DATA 0263.4,-37.1,Shaula,7,0
DATA 0262.7,-37.3,Sco4,7,0
DATA 0252.5,-34.3,Sco5,7,0
DATA 0249.0,-28.2,Sco6,7,0
DATA 0247.3,-26.4,Antares,7,1.08
DATA 0241.4,-19.8,Acrab,7,0
DATA 0240.1,-22.6,Dschubba,7,0
DATA 0239.7,-26.1,Sco10,7,0
DATA 0228.9,033.3,Boo1,8,0
DATA 0225.0,041.0,Meres,8,0
DATA 0221.2,027.1,Izar,8,0
DATA 0218.0,038.3,Haris,8,0
DATA 0218.0,030.5,Boo5,8,0
DATA 0213.9,019.2,Arcturus,8,.6
DATA 0208.7,018.4,Boo6,8,0
DATA 0201.3,-11.2,Spica,9,.96
DATA 0198.0,-07.5,Vir2,9,0
DATA 0195.5,011.0,Vindemiatrix,9,0
DATA 0193.9,003.4,Minelauva,9,0
DATA 0190.0,-01.0,Porrima,9,0
DATA 0185.0,000.0,Vir6,9,0
DATA 0177.0,002.0,Zavijah,9,0
DATA 0191.9,-59.7,Cru1,10,0
DATA 0187.8,-57.1,Cru2,10,1.24
DATA 0186.7,-63.1,Cru3,10,0
DATA 0183.8,-58.8,Cru4,10,0
DATA 0177.3,014.5,Denebola,11,0
DATA 0168.6,015.4,Coxa,11,0
DATA 0168.5,020.5,Zosma,11,0
DATA 0155.0,019.9,Algieba,11,0
DATA 0152.1,012.0,Regulus,11,1.36
DATA 0151.8,016.8,Leo7,11,0
DATA 0146.5,023.8,Ras Ela.Australis,11,0
DATA 0116.3,028.0,Pollux,12,1.15
DATA 0113.7,031.9,Kastor,12,0
DATA 0101.3,012.9,Gem3,12,0
DATA 0101.0,025.1,Gem4,12,0
DATA 0099.4,016.4,Gem5,12,0
DATA 0095.7,022.5,Gem6,12,0
DATA 0111.0,-29.3,Aludra,13,0
DATA 0107.1,-26.4,Wezen,13,0
DATA 0104.7,-29.0,Adara,13,0
DATA 0101.3,-16.7,Sirius,13,-1.47
DATA 0098.2,-18.0,Mirzam,13,0
DATA 0090.0,037.2,Aur1,14,0
DATA 0089.0,045.0,Menkalinan,14,0
DATA 0079.2,046.0,Capella,14,0.09
DATA 0075.5,043.8,Aur4,14,0
DATA 0074.3,033.2,Hassaleh,14,0
DATA 0088.8,007.4,Beteigeuze,15,.8
DATA 0086.9,-09.1,Ori2,15,0
DATA 0085.2,-02.0,Ori3,15,0
DATA 0084.1,-01.2,Alnilam,15,0
DATA 0083.0,-00.3,Mintaka,15,0
DATA 0081.3,006.4,Bellatrix,15,0
DATA 0078.6,-08.2,Rigel,15,.08
DATA 0059.5,040.0,Per1,16,0
DATA 0058.5,031.9,Per2,16,0
DATA 0055.7,047.8,Per3,16,0
DATA 0051.1,049.9,Mirfak,16,0
DATA 0047.0,041.0,Algol,16,0
DATA 0046.2,053.5,Miram,16,0
DATA 0031.0,042.0,Alamak,17,0
DATA 0017.4,035.6,Mirach,17,0
DATA 0009.1,030.8,And3,17,0
DATA 0002.1,029.1,Sirrah,17,0
DATA 0345.8,077.6,Cep1,18,0
DATA 0342.5,066.0,Cep2,18,0
DATA 0322.2,070.6,Alfrik,18,0
DATA 0319.6,062.6,Alderamin,18,0
DATA 0269.2,051.5,Etamin,19,0
DATA 0262.6,052.3,Alwaid,19,0
DATA 0231.2,059.0,Dra3,19,0
DATA 0246.0,061.6,Dra4,19,0
DATA 0172.5,069.7,Gianfar,19,0
DATA 0257.2,065.7,Nodus01,19,0
DATA 0268.5,056.9,Grumium,19,0
DATA 0288.1,067.7,Nodus02,19,0
DATA 0031.8,023.5,Hamal,20,0
DATA 0028.7,020.8,Scheratain,20,0
DATA 0028.5,019.3,Mesarthim,20,0
DATA 0084.4,021.2,Tau1,21,0
DATA 0081.6,028.6,Elnath,21,0
DATA 0069.0,016.5,Aldebaran,21,.86
DATA 0058.8,012.5,Tau4,21,0
DATA 0056.9,024.1,Plejaden,21,1
DATA 0114.8,005.2,Prokyon,22,.34
DATA 0111.8,008.3,Cmi2,22,0
DATA 0331.4,-00.3,Sadalmelek,23,0
DATA 0322.9,-05.6,Sadalsud,23,0
DATA 0343.7,-15.8,Skat,23,0
DATA 0311.8,-09.7,Albali,23,0
DATA 0337.0,-00.3,Aqu6,23,0
DATA 0331.3,-14.0,Aqu7,23,0
DATA 0343.0,-07.8,Aqu8,23,0
DATA 0347.0,-20.4,Aqu9,23,0
DATA 0194.1,038.3,Chara,24,0
DATA 0188.5,041.4,Cvn2,24,0
DATA 0304.5,-12.5,Algedi,25,0
DATA 0305.3,-14.8,Dabih,25,0
DATA 0325.0,-16.7,Nashira,25,0
DATA 0326.8,-16.1,Deneb Algiedi,25,0
DATA 0321.7,-22.4,Cap5,25,0
DATA 0316.5,-17.3,Cap6,25,0
DATA 0219.9,-60.8,Toliman,26,.33
DATA 0211.0,-60.4,Cen2,26,.59
DATA 0190.4,-49.0,Cen3,26,0
DATA 0182.2,-50.7,Cen4,26,0
DATA 0205.0,-53.5,Cen5,26,0
DATA 0200.1,-36.7,Cen6,26,0
DATA 0208.9,-44.3,Cen7,26,0
DATA 0211.7,-36.4,Cen8,26,0
DATA 0045.6,004.1,Menkar,27,0
DATA 0010.9,-18.0,Deneb Kaitos,27,0
DATA 0034.8,-03.0,Mira,27,0
DATA 0026.0,-15.9,Tau Ceti,27,0
DATA 0084.9,-34.1,Phakt,28,0
DATA 0087.7,-35.8,Col2,28,0
DATA 0233.7,026.7,Gemma,29,0
DATA 0232.0,029.4,Crb2,29,0
DATA 0188.6,-23.4,Crv2,30,0
DATA 0183.9,-17.5,Crv3,30,0
DATA 0187.5,-16.5,Crv4,30,0
DATA 0182.5,-22.6,Crv5,30,0
DATA 0024.4,-57.3,Achernar,31,.47
DATA 0077.0,-05.1,Cursa,31,0
DATA 0059.5,-13.5,Zaurak,31,0
DATA 0055.8,-09.8,Rana,31,0
DATA 0069.2,-30.5,Theemin,31,0
DATA 0258.7,014.4,Ras Algethi,32,0
DATA 0247.6,021.5,Rutilicus,32,0
DATA 0258.8,024.8,Sarin,32,0
DATA 0250.3,031.6,Her4,32,0
DATA 0258.8,036.8,Her5,32,0
DATA 0266.6,027.7,Her6,32,0
DATA 0141.9,-08.7,Alfard,33,0
DATA 0131.7,006.4,Hya2,33,0
DATA 00133.9,006.0,Hya3,33,0
DATA 0162.4,-16.2,Hya4,33,0
DATA 0199.7,-23.2,Hya5,33,0
DATA 0202.4,-23.3,Hya6,33,0
DATA 0211.6,-26.7,Hya7,33,0
DATA 0083.2,-17.8,Arneb,34,0
DATA 0082.1,-20.8,Nihal,34,0
DATA 0078.2,-16.2,Lep3,34,0
DATA 0222.7,-16.1,Zuben Algenubi,35,0
DATA 0229.3,-09.4,Zuben Elschemali,35,0
DATA 0226.0,-25.3,Lib3,35,0
DATA 0220.5,-47.4,Lup1,36,0
DATA 0224.6,-43.1,Lup2,36,0
DATA 0233.8,-41.2,Lup3,36,0
DATA 0263.7,012.6,Ras Alhague,37,0
DATA 0265.9,004.6,Kelb al Rai,37,0
DATA 0243.6,-03.7,Oph3,37,0
DATA 0249.3,-10.6,Oph4,37,0
DATA 0257.6,-15.7,Sabik,37,0
DATA 0269.8,-09.8,Oph5,37,0
DATA 0030.2,002.5,Kaitain,38,0
DATA 0349.0,003.1,Psc2,38,0
DATA 0344.4,-29.6,Fomalhaut,39,1.16
DATA 0271.5,-30.1,Nash,40,0
DATA 0275.3,-29.8,Kaus Medius,40,0
DATA 0276.0,-34.4,Kaus Australis,40,1
DATA 0285.7,-29.9,Ascella,40,0
DATA 0277.0,-25.4,Kaus Borealis,40,0
DATA 0274.4,-36.8,Sgr6,40,0
DATA 0283.8,-26.3,Nunki,40,0
DATA 0287.4,-21.0,Sgr8,40,0
DATA 0286.7,-27.7,Sgr9,40,0
DATA 0281.4,-27.0,Sgr10,40,0
DATA 0236.1,006.4,Unuk,41,0
DATA 0275.3,-02.9,Ser2,41,0
DATA 0237.5,-03.3,Ser3,41,0
DATA 0028.3,029.5,Metallah,42,0
DATA 0032.4,035.0,Tri2,42,0
DATA 0034.3,033.8,Tri3,42,0
DATA 0189.3,-69.1,Mus1,43,0
DATA 0191.6,-68.1,Mus2,43,0
DATA 0006.6,-42.3,Phe1,44,0
DATA 0016.5,-46.4,Phe2,44,0
DATA 0022.1,-46.3,Phe3,44,0
DATA 0252.2,-69.0,Tra1,45,0
DATA 0238.8,-63.4,Tra2,45,0
DATA 0229.7,-68.7,Tra3,45,0
DATA 0334.6,-60.3,Tuc1,46,0
DATA 0263.0,-49.9,Ara1,47,0
DATA 0261.3,-55.5,Ara2,47,0
DATA 0096.0,-52.7,Canopus,48,-.73
DATA 0138.3,-69.7,Car2,48,0
DATA 0125.6,-59.5,Car3,48,0
DATA 0161.3,-59.7,Car4,48,-1
DATA 0332.1,-47.0,Alnair,49,0
DATA 0340.7,-46.9,Gru2,49,0
DATA 0122.4,-47.4,Vel1,50,0
DATA 0131.2,-54.7,Vel2,50,0
constellations:
DATA Ursa minor,Kleiner Wagem,6,1
DATA Ursa major,Großer Wagen,6,8
DATA Cassiopeia,Kassiopeia,4,15
DATA Pegasus,Pegasus,5,20
DATA Cygnus,Schwan,4,26
DATA Aquilla,Adler,6,31
DATA Lyra,Leier,4,38
DATA Scorpius,Skorpion,9,43
DATA Bootes,Bootes,6,53
DATA Virgo,Jungfrau,6,60
DATA Crux,Kreuz des Südens,3,67
DATA Leo,Löwe,6,71
DATA Gemini,Zwillinge,5,78
DATA Canis major,Großer Hund,4,84
DATA Auriga,Fuhrmann,4,89
DATA Orion,Orion,6,94
DATA Perseus,Perseus,5,101
DATA Andromeda,Andromeda,3,107
DATA Cepheus,Kepheus,3,111
DATA Draco,Drache,7,115
DATA Aries,Widder,2,123
DATA Taurus,Stier,4,126
DATA Canis minor,Kleiner Hund,1,131
DATA Aquarius,Wassermann,7,133
DATA Canes venatici,Jagdhunde,1,141
DATA Capricornus,Steinbock,5,143
DATA Centaurus,Zentaur,7,149
DATA Cetus,Walfisch,3,157
DATA Columba,Taube,1,161
DATA Corona borealis,Krone,1,163
DATA Corvus,Rabe,3,165
DATA Eridanus,Eridanus,4,169
DATA Hercules,Herkules,5,174
DATA Hydra,Wasserschlange,6,180
DATA Lepus,Hase,2,187
DATA Libra,Waage,2,190
DATA Lupus,Wolf,2,193
DATA Ophiochus,Schlangenträger,5,196
DATA Pisces,Fische,1,202
DATA Piscis australis,Süd. Fisch,0,204
DATA Sagittarius,Schütze,9,205
DATA Serpens,Schlange,2,215
DATA Triangulum,Dreieck,2,218
DATA Musca,Fliege,1,221
DATA Phoenix,Phönix,2,223
DATA Triang.aust.,Südl.Dreieck,2,226
DATA Tucana,Tukan,0,229
DATA Ara,Ara,1,230
DATA Carina,Kiel,3,232
DATA Grus,Kranich,1,236
DATA Vela,Segel,1,238
planets:
DATA Merkur,4.0923,31.19,76.987
DATA 23.00,.2056,47.826,7.004,.3871
DATA Venus,1.6021,80.85,131.149
DATA .76,.0068,76.410,3.394,.7233
DATA Mars,.5240,144.14,335.507
DATA 11.00,.0934,49.326,1.850,1.5237
DATA Jupiter,.0831,316.19,13.839
DATA 5.30,.0485,100.146,1.305,5.2028
DATA Saturn,.0335,158.36,92.460
DATA 5.50,.0557,113.511,2.486,9.5810
DATA Uranus,.0117,98.38,170.173
DATA 5.70,.0472,73.847,.773,19.1823
'
men1:
DATA  Program,continue     ,end  ,about....,! author: Rolf Kühr,!         Am Südhang 21,!         D4798 Wünnenberg,!         Version 1.0i,
DATA  Change parameters,  Location......    ,  Date/Time.....    ,  Pre-set locations    ,!  Wünnenberg,!  Berlin,!  Moskow,!  New York,!  Arctic Pole,!  Antarctic Pole,!  Quito (equator),  System-time....  ,
DATA  Mode,  Star chart       ,-  Planetarium     ,-  Telescope,
DATA  Resolution,  640*240     ,  640*480     ,
DATA  Look for,- name     ,
DATA  Print,- hardcopy     ,
DATA ENDE
'
availobjects:
DATA Uranus,Jupiter,Saturn,Merkur,Mars,Jagdhunde,Orion
DATA ENDE
'
'       LOAD ACBM :Program to load Amiga-Continues-BitMap
'
'       <C> 1989 by GFA Systemtechnik GmbH.
'
' ****************************************************************
'
' 28.8.89
'
'
PROCEDURE load_acbm(bild$,f|)
  IF bild$<>"" AND RIGHT$(bild$,1)<>":" AND EXIST(bild$)
    OPEN "i",#1,bild$
    '
    mybuf%=AllocMem(360,65537)
    IF mybuf%=0
      ALERT 0,"Not enough memory",0,"OK",v&
      END
    ENDIF
    inbuf%=mybuf%
    cbuf%=ADD(mybuf%,120)
    ctab%=ADD(mybuf%,240)
    BGET #1,inbuf%,12
    IF MKL$({ADD(inbuf%,8)})<>"ILBM" AND MKL$({ADD(inbuf%,8)})<>"ACBM"
      ALERT 0,"No ILBM file !",0,"OK",v&
      CLOSE #1
    ELSE
      CLR bmhd!,cmap!,body!
      '
      WHILE NOT EOF(#1) OR (bmhd! AND cmap! AND body!)
        BGET #1,inbuf%,8
        len%={ADD(inbuf%,4)}
        SELECT MKL$({inbuf%})
        CASE "BMHD"
          @read_bmhd
          bmhd!=TRUE
        CASE "CMAP"
          @read_cmap
          cmap!=TRUE
        CASE "CAMG"
          @read_camg
          camg!=TRUE
        CASE "ABIT"
          @read_abit
          abit!=TRUE
        DEFAULT
          RELSEEK #1,len%-ODD(len%)   ! skip unknown chunk
        ENDSELECT
      WEND
      CLOSE #1
      '
    ENDIF
    mybuf%=FreeMem(mybuf%,360)
  ELSE
    exit!=TRUE
  ENDIF
RETURN
PROCEDURE read_bmhd
  BGET #1,inbuf%,len%
  w&=CARD{inbuf%}
  h&=CARD{ADD(inbuf%,2)}
  d|=BYTE{ADD(inbuf%,8)}
  c|=BYTE{ADD(inbuf%,10)}
  sw&=CARD{ADD(inbuf%,16)}
  sh&=CARD{ADD(inbuf%,18)}
  rb&=SHR(w&,3)
  srb&=SHR(sw&,3)
  cols&=BSET(0,d|)
  IF camg!
    v%=camg%
  ELSE
    CLR v%
    IF sw&>320
      v%=OR(v%,&H8000)
    ENDIF
    IF sh&>256
      v%=OR(v%,4)
    ENDIF
  ENDIF
  IF WINDOW(f|)=0               ! Fenster geöffnet?
    OPENS 7,0,0,sw&,sh&,d|,v%
    DISPLAY OFF
  ENDIF
  mem%=v%
RETURN
PROCEDURE read_cmap
  LOCAL v&
  cmap!=TRUE
  BGET #1,cbuf%,len%
  FOR v&=0 TO PRED(cols&)
    v%=ADD(cbuf%,MUL(3,v&))
    r|=BYTE{v%}
    g|=BYTE{SUCC(v%)}
    b|=BYTE{ADD(v%,2)}
    '
    CARD{ADD(ctab%,ADD(v&,v&))}=ADD(ADD(g|,SHL(r|,4)),SHR(b|,4))
    SETCOLOR v&,CARD{ADD(ctab%,v&*2)}
  NEXT v&
RETURN
PROCEDURE read_camg
  camg!=TRUE
  BGET #1,inbuf%,len%
  camg%=LONG{inbuf%}
RETURN
PROCEDURE read_abit
  LOCAL mem|,wad%
  '
  mem|=0
  bpl%=MUL(h&,SHR(w&,3))
  wad%=WINDOW(f|)
  IF wad%                        ! In Fenster kopieren
    bm%=LONG{LONG{wad%+50}+4}
    dl|=MIN(d|,BYTE{bm%+5})      ! Bitplanes
    wl&=MIN(sw&,CARD{wad%+8})
    hl&=MIN(sh&,CARD{wad%+10})
    '
    a|=BYTE{wad%+54}             ! Borders ?
    IF wl&+a|>CARD{wad%+8}
      SUB wl&,a|
    ENDIF
    xof%=a|
    '
    a|=BYTE{wad%+55}
    IF hl&+a|>CARD{wad%+10}
      SUB hl&,a|+3
    ENDIF
    yof%=a|
    '
    a|=BYTE{wad%+56}
    IF wl&+a|+BYTE{wad%+54}>CARD{wad%+8}
      SUB wl&,a|
    ENDIF
    '
    a|=BYTE{wad%+57}
    IF hl&+a|+BYTE{wad%+55}>CARD{wad%+10}
      SUB hl&,a|
    ENDIF
    '
    ADD xof%,CARD{wad%+4}
    ADD yof%,CARD{wad%+6}
    INLINE bm2%,40
    CARD{bm2%}=srb&
    CARD{bm2%+2}=sh&
    BYTE{bm2%+4}=0
    BYTE{bm2%+5}=dl|
    BYTE{bm2%+6}=0
    '
    FOR mem|=1 TO d|                    ! Einlesen
      IF mem|<=dl|
        bpad%=AllocMem(bpl%,3)
        LONG{bm2%+4+mem|*4}=bpad%
        BGET #1,bpad%,bpl%
      ELSE
        RELSEEK #1,bpl%
      ENDIF
    NEXT mem|
    '
    ~BltBitMap(bm2%,0,0,bm%,xof%,yof%,wl&,hl&,&HC0,&H3F,0)
    '
    FOR mem|=1 TO dl|
      ~FreeMem(LONG{bm2%+4+mem|*4},bpl%)
    NEXT mem|
  ELSE
    REPEAT
      bpad%=LONG{ADD(SCREEN(7),ADD(192,SHL(mem|,2)))}
      BGET #1,bpad%,bpl%
      INC mem|
    UNTIL mem|=d|
  ENDIF
RETURN