10 ' HOLOGRAM.BAS  Created 15 June 1987 - Revised 29 April 2001
   ' http://www.ebicom.net/~rsf1/hologram.bas
   ' This is a Low-Tec  Scientific Simulations Shareware program by
   ' Robert S. Fritzius 305 Hillside Drive  Starkville, MS 39759
   ' Visit Shade Tree Physics at http://www.ebicom.net/~rsf1
   ' ON ERROR GOTO 10000  'SIMCGA notice
   ' Sydex's SIMCGA is licensed for Low-Tec programs
   DEFINT I,J
   I=0 'General counter
   J=0 'General counter
   IYR=20 'Y Reference on screen
   IX=0   'Screen X coordinate
   IY=0   'Screen Y coordinate
20 C=0
   HM=10  'Horizontal Multiple for screen display
   VM=4   'Vertical   Multiple for screen display
   RAD%=0 ' Radius of impact areas
   RC=1   ' Refraction Coefficient
   NMAX=7
   D%=0
40 X=0
   Y=0
   Z=0
50 P=0
   R=0
    PF =0  ' Point  to  Film   distance
    PF2=0  ' Point  to  Film   distance Squared

    SF =0  ' Source to  Film   distance
    SF2=0  ' Source to  Film   distance Squared

    SP =0  ' Source to  Point  distnace
    SP2=0  ' Source to  Point  distance Squared

    SPF=0  ' Source-Point-Film distance

    ASF=0  ' Amplitude Source to Film
    ASP=0  ' Amplitude Source to Point
    APF=0  ' Amplitude Point  to Film
    ASPF=0 ' Amplitude Source-Point-Film
    FAMP=0
    FAMP1=0
    FAMP2=0
    SRC=0 'Scaled Reflection Coefficient

90  OX=10  'location of point source
    OY=20
    OZ=100

    XC=30 ' Centroid of refracting bodies
    YC=20 '   "
    ZC=20 '   "

    PD=0  ' Phase delay of refracting points

    IP=32000 'Integration Period
110 LSI=2.1 ' Log Source Intensity
120 WL=1:' WaveLength of point source
130 P2=2*3.1417   '2 PI
    XM%=60
    YM%=40
150 NP%=1
    ESC$=CHR$(27)
    FMT1$="Source Intensity = ######  Zs = ####   W/L = ###   NB = ###"
    Z$="" 'Inkeys value
270 DIM X(50),Y(50),Z(50)
300 CLS:PRINT
    PRINT "                             H O L O G R A M"
    PRINT
    PRINT "                            Robert S. Fritzius"
    PRINT "                            305 Hillside Drive
    PRINT "                           Starkville, MS 39759
    PRINT "                              601-324-1284"
    PRINT
    PRINT
    PRINT
370 PRINT "                           1) Create Holograms"
    print "                           2) Info on program"
385 PRINT "                           3) Exit"
390 PRINT
400 INPUT "                              Which Choice";T
410 IF T<1 AND T>3 THEN 400
440 ON T GOTO 800,6000,9000
450 :
800 cls:PRINT
810 locate  4,1
    print using "(a)   Log (Source Intensity)      =  ##.## ";LSI
    print using "(b)   Source-Screen Distance      = #####  ";OZ
    print using "(c)   Source Wavelength           = ###.## ";WL
    print using "(d)   Integration period          = ###### ";IP
    print       "      Refracting body data"
    print using "(e)   Refraction Coefficient      =  #.###";RC
    print using "(f)   Refractor centroid  X       = ####";XC
    print using "(g)   Refractor centroid  Y       = ####";YC
    print using "(h)   Refractor centroid  Z       = ####";ZC
    print using "(i)   No. of refractors (1 - 7)   =  ###";NP%
    print using "(j)   Phase delay of refractors   =  ### degrees";PD
    print       "(k)   Return to first menu"
	   print"(esc) Exit program
850 LOCATE 17,1
    Print "   Which item to change <ENTER> to run";
855 WI$=inkey$:if WI$="" then 855
    IF WI$="K" OR WI$="k" THEN 300
    IF WI$= esc$ THEN CLS:END
    locate 17,1:print string$(40," ");
    WI%=ASC(WI$)
    IF WI%=13 THEN 890 ' <ENTER> Key was depressed
    IF WI%<64 OR WI%>122 THEN 850 ' Outside usable range
    IF WI%>96 AND WI%<123 THEN WI%=WI%-32  'make upper case
    WI%=WI%-64
    LCWI$=CHR$(WI%+96)
    LOCATE 17,1:PRINT "   New Value for ("LCWI$") ";
    INPUT NV$
    IF NV$="" THEN GOTO 810
    NV=VAL(NV$)
    LOCATE 17,1:PRINT STRING$(50," ");
    ON WI% GOTO 861,862,863,864,865,866,867,868,869,870
861 LSI=NV:GOTO 810
862 OZ =NV:GOTO 810
863 WL =NV:GOTO 810
864 IP =NV:GOTO 810
865 RC =NV:GOTO 810
866 XC =NV:GOTO 810
867 YC =NV:GOTO 810
868 ZC =NV:GOTO 810
869 IF NV>0 and NV<=NMAX THEN NP%=NV:GOTO 810
870 PD =NV:GOTO 810
    GOTO 850
890 CLS:SCREEN 2
    P2WL=P2/WL ' 2 PI/WL
    Amp=(oz^2)/(1e4)*10^LSI
    SRC=10*SQR(NP%+1)

    'Assign positions of refracting points
      FOR I=1 TO NP%
	X(I)=XC
	Y(I)=YC+ 2*(I-NP%/2) - 1
	Z(I)=ZC
      NEXT I

    PDR=PD*P2/360

    DRAW  "BM"+STR$(     0) +","+STR$(IYR+    0)  'x,y origin
    DRAW  " M"+STR$(10*XM%) +","+STR$(IYR+    0)
    DRAW  " M"+STR$(10*XM%) +","+STR$(IYR+4*YM%)
    DRAW  " M"+STR$(     0) +","+STR$(IYR+4*YM%)
    DRAW  " M"+STR$(     0) +","+STR$(IYR+    0)

    LOCATE 2,1:PRINT "X,Y plane projections of source and refracting bodies";
    X=OX
    Y=OY
    IX=HM*X
    IY=IYR+ VM*Y
    FOR RAD%=1 to 10
     CIRCLE(IX,IY),RAD%
    NEXT RAD%
    FOR I=1 TO NP%
     X=X(I):Y=Y(I)
     IX=HM*X
     IY=IYR + VM*Y
     FOR RAD%=1 TO 5
      CIRCLE(IX,IY),RAD%
     NEXT RAD%
    NEXT I
    LOCATE 24,15:PRINT "Press any key to begin hologram formation.";
900 z$=inkey$:if z$="" then 900
    locate  2,1:print string$(78," ");
    locate 24,1:print string$(78," ");
950 GOSUB 5500:' Print Parameters
990 :
1000 '
1040 Z=0:' photographic plane
1045 FOR I=1 TO IP
      X=RND(1)*XM%
      Y=RND(1)*YM%
      'Source to Film
1090   SF2=(X-OX)^2+(Y-OY)^2+(Z-OZ)^2
       SF=SQR(SF2) 'distance - source to film element x,y
1100   ASF=Amp/SF  'was Amp/SF2

      'Source to Point
       FAMP1=0
       FAMP2=0
1120   FOR P=1 TO NP%

1130   'Source to Point
1140    SP2=(X(P)-OX)^2+(Y(P)-OY)^2+(Z(P)-OZ)^2
	SP=SQR(SP2) 'source to point distance
1150    ASP=Amp/SP 'Amplitude of source at point

       'Point to Film
1170    PF2=(X(P)-X)^2+(Y(P)-Y)^2+(Z(P)-Z)^2
	PF=SQR(PF2)
1180    SPF = SP + PF
1190    ASPF=ASP/PF  'check this  ( was ASPF=ASP/SPF )
1200    FAMP1=FAMP1 + SRC*ASPF*COS(P2WL*SPF+PDR)
	FAMP2=FAMP2 + SRC*ASPF*SIN(P2WL*SPF+PDR)
1210   NEXT P
       FAMP1=FAMP1 + ASF*COS(P2WL*SF)
       FAMP2=FAMP2 + ASF*SIN(P2WL*SF)
       FAMP=FAMP1^2 + FAMP2^2

1235   D%=INT(FAMP)
       IX=HM*X
       IY=IYR + VM*Y
1280   FOR RAD%=1 TO D%
	CIRCLE(IX,IY),RAD%
       NEXT RAD%
1300   Z$=INKEY$:IF Z$="" THEN 1320
       GOSUB 4000 ' Draw dark outlines around source and bodies
       IF Z$=ESC$ THEN I=IP:GOTO 1320
1310   Z$=INKEY$:IF Z$="" THEN 1310
       IF Z$=ESC$ THEN I=IP
1320 NEXT I
     GOSUB 4000 ' Draw dark outlines around source and bodies
     LOCATE 24,1:PRINT STRING$(79," ");
1335 LOCATE 24,24:PRINT "Press any key for new run.";
1337 Z$=INKEY$:IF Z$="" THEN 1337
1340 GOTO 800

2000 'Display digitized equivalent
2990 RETURN

4000 'Draw dark outlines around source and refracting bodies
    X=OX
    Y=OY
    IX=HM*X
    IY=IYR+ VM*Y
    FOR J=0 to 80  'RAD =10
     JX=IX+12*1.0*COS(P2*J/80)
     JY=IY+12*0.4*SIN(P2*J/80)
     PSET(JX,JY),0
    NEXT J
    FOR K=1 TO NP%
     X=X(K):Y=Y(K)
     IX=HM*X
     IY=IYR + VM*Y
     FOR J=0 TO 80 'RAD = 5
      JX=IX+7*1.0*COS(P2*J/80)
      JY=IY+7*0.4*SIN(P2*J/80)
      PSET(JX,JY),0
     NEXT J
    NEXT K
    RETURN
5500 'Display parameters
5510 LOCATE 2,5:PRINT USING FMT1$;Amp;OZ;WL;NP%;
     LOCATE 24,1:PRINT STRING$(79," ");
     LOCATE 24,22:PRINT "Space = pause  ESC = end loop";
5990 RETURN
6000 CLS:PRINT
     PRINT TAB(25)"Information on Hologram"
     PRINT
PRINT "Hologram simulates a monochromatic source located 100 arbitrary units above
PRINT "a photographic film with a linear array of refracting points situated
PRINT "between the source and film.   The default number of refracting points is "
PRINT "one.  You may select 1 thru 7 points and their x,y,z centroid.
8900 locate 24,24:Print "Press any key to return.";
8990 z$=inkey$:if z$="" then 8990
8995 GOTO 300
9000 CLS:SCREEN 0:END
10000 CLS:PRINT
10002 if err<>5 then PRINT "Error code ="err:goto 10090
10005 PRINT "     This machine does not know how to do high-resolution graphics."
      PRINT
      PRINT "                             Options"
      PRINT
      PRINT "(1) Use a computer that has a CGA, VGA, or EGA card.
      PRINT
      PRINT "(2) If your computer has a Monochrome Graphics Adapter (MGA) card, run"
      PRINT "    SIMCGA first, then run your Low-Tec graphics program(s).  When you"
      PRINT "    finish, run RMVCGA to remove SIMCGA."
      PRINT
      PRINT "SIMCGA, Copyright (C) 1988-1992 by Sydex, Inc., is a program which enables"
      PRINT "a Monochrome Graphics Adapter (MGA) to simulate a Color Graphics Adapter"
      PRINT "(CGA).  SIMCGA will not work with a Monochrome text Display Adapter (MDA)."
      PRINT "SIMCGA is licensed for use with Low-Tec programs as a non-supported item."
10090 LOCATE 23,20
      PRINT " Press any key to exit program.";
10095 Z$=INKEY$:IF Z$="" THEN 10095
      END