REM dff7bbc.bas - jackord@kw.igs.net - 19 Apr 09 - BBC Basic 5.50b
      REM X-ray diffraction patterne for cubic crystals generated by superimposing
      REM   Huygens' wavelets from an n x n x n array of single atoms (SC),
      REM   or a basis of 2 (BCC) or 4 (FCC) atoms, where n=8, 12, 16, or 20.
      REM The wavelength can be chosen to enhance diffraction from (111), (201), or (211) planes.
      REM The pattern from the basis is displayed first,
      REM   then frames 1 to n show development of the pattern as a row is formed,
      REM   frames n+1 to 2*n as rows are added to form a layer,
      REM   frames 2*n+1 to 3*n as layers are added to form a cube.
      
      *FLOAT 64
      
      REM Install libraries
      INSTALL @lib$+"WINLIB5"
      
      REM Controls
      b1% = FN_button("SC", 10, 5, 60, 20, FN_setproc(PROCq1), 0)
      b2% = FN_button("BCC", 10, 30, 60, 20, FN_setproc(PROCq2), 0)
      b3% = FN_button("FCC", 10, 55, 60, 20, FN_setproc(PROCq3), 0)
      c1% = FN_combobox("", 0, 80, 80, 60, 0, 3)
      c2% = FN_combobox("", 0, 105, 80, 60, 0, 3)
      c3% = FN_combobox("", 0, 130, 80, 60, 0, 3)
      
      REM Initialize window
      WindowWidth=320                                   : REM Pixel Scale 0-320
      WindowHeight=240                                  : REM Pixel Scale 0-240
      VDU 23,22,WindowWidth;WindowHeight;8,12,16,128
      SYS "SetWindowText", @hwnd%, "Cubic Crystals"
      SYS "SendMessage", c1%, &143, 0, "la=2a/3"
      SYS "SendMessage", c1%, &143, 0, "la=2a/5"
      SYS "SendMessage", c1%, &143, 0, "la=2a/6"
      SYS "SendMessage", c2%, &143, 0, "n=8"
      SYS "SendMessage", c2%, &143, 0, "n=12"
      SYS "SendMessage", c2%, &143, 0, "n=16"
      SYS "SendMessage", c2%, &143, 0, "n=20"
      SYS "SendMessage", c3%, &143, 0, "expX1"
      SYS "SendMessage", c3%, &143, 0, "expX10"
      SYS "SendMessage", c3%, &143, 0, "expX100"
      SYS "SendMessage", c1%, &14E, 0, 0
      SYS "SendMessage", c2%, &14E, 3, 0
      SYS "SendMessage", c3%, &14E, 0, 0
      DIM la(2)
      a=3.615E-7
      la(0)=2*a/3: la(1)=2*a/5: la(2)=2*a/6
      *FONT Arial,10
      OFF: ON CLOSE QUIT
      
      REPEAT
        WAIT 1
      UNTIL FALSE
      
      DEF PROCq1: kk=1
      DEF PROCq2: kk=2
      DEF PROCq3: kk=4
      
      CLS : VDU 5
      ORIGIN 400, 240
      SYS "SendMessage", c1%, &147, 0, 0 TO ch1%
      SYS "SendMessage", c2%, &147, 0, 0 TO ch2%
      SYS "SendMessage", c3%, &147, 0, 0 TO ch3%
      n=8+4*ch2%: ne=10^ch3%
      z=30: zz=z*z
      * REFRESH OFF
      FOR nf=0 TO 3*n
        FOR ny=-120 TO 120                              : REM Screen loops
          FOR nx=-120 TO 120
            r0=SQR(zz+nx*nx+ny*ny): sr=0: si=0
            b=2*PI*a/r0/la(ch1%)
            sr=1: si=0: ni=1: sn=1                      : REM SC
            IF kk=2 THEN
              t=b/2*(nx+ny+z-r0)                        : REM BCC
              rr=COS(t): ri=SIN(t)
              qr=sr+rr*sr-ri*si: si=si+rr*si+ri*sr
              sr=qr
            ENDIF
            IF kk=4 THEN
              t=b/2*(nx+ny)                             : REM FCC
              rr=COS(t): ri=SIN(t)
              qr=sr+rr*sr-ri*si: qi=si+rr*si+ri*sr
              t=b/2*(nx+z-r0)
              rr=COS(t): ri=SIN(t)
              qr=qr+rr*sr-ri*si: qi=qi+rr*si+ri*sr
              t=b/2*(ny+z-r0)
              rr=COS(t): ri=SIN(t)
              qr=qr+rr*sr-ri*si: qi=qi+rr*si+ri*sr
              sr=qr: si=qi
            ENDIF
            IF nf>0 THEN
              IF nf<=n THEN im=nf ELSE im=n
              FOR i=1 TO im                             : REM Array X loop
                t=b*ni*nx
                rr=COS(t): ri=SIN(t)
                qr=sr+rr*sr-ri*si:si=si+rr*si+ri*sr
                sr=qr: ni=2*ni: sn=2*sn
              NEXT i
            ENDIF
            IF nf>n THEN
              IF nf<2*n THEN im=nf-n ELSE im=n
              ni=1
              FOR i=1 TO im                             : REM Array Y loop
                t=ni*b*ny
                rr=COS(t): ri=SIN(t)
                qr=sr+rr*sr-ri*si:si=si+rr*si+ri*sr
                sr=qr: ni=2*ni: sn=2*sn
              NEXT i
            ENDIF
            IF nf>2*n THEN
              ni=1                                      : REM Array Z loop
              FOR i=1 TO nf-2*n
                t=ni*b*(z-r0)
                rr=COS(t): ri=SIN(t)
                qr=sr+rr*sr-ri*si:si=si+rr*si+ri*sr
                sr=qr: ni=2*ni: sn=2*sn
              NEXT i
            ENDIF
            sc=ne*1000/sn/kk
            c=INT((sr*sr+si*si)*sc): IF c>255 THEN c=255
            GCOL 1
            COLOUR 1, 0, c, 0
            PLOT -2*nx, -2*ny
          NEXT nx
        NEXT ny
        GCOL 15: RECTANGLE FILL -400, -240, 160, 160
        GCOL 0: MOVE -380, -204: PRINT "Frame "; nf;: MOVE -360, -144
        IF nf=0 THEN PRINT "Basis": del=200
        IF nf=n THEN PRINT "Line": del=200
        IF nf=2*n THEN PRINT "Square": del=200
        IF nf=3*n THEN PRINT "Cube": del=200
        * REFRESH
      NEXT nf
      * REFRESH ON
      ENDPROC