\ Simulation of Young 2-slit experiment with
\   individual photons
\
\ ---------------------------------------------------
\     (c) Copyright 1998  Julian V. Noble.          \
\       Permission is granted by the author to      \
\       use this software for any application pro-  \
\       vided this copyright notice is preserved.   \
\ ---------------------------------------------------


\ This is an ANS Forth program requiring the
\   FLOAT, FLOAT EXT, FILE and TOOLS EXT wordsets.
\
\ Environmental dependencies:
\       Assumes independent floating point stack
\       Assumes non-Standard graphics words from Win32Forth

MARKER -2slit

include prng.f
include ansfalsi.f


    0.1 seed 2!

    10e FCONSTANT x1
     5e FCONSTANT y1

   300e FCONSTANT y_lim
   500e FCONSTANT x_lim

    x1 F2*  FSIN  F2/  x1 F+  FCONSTANT  c

    FVARIABLE zeta


\ non-Standard Win32Forth graphics words

    WinDC theDC

: set_plot  ( -- )
    CONDC PutHandle: theDC          \ initialize DC to the console
    0 0 800 600 BLACK  FillArea: theDC
    WHITE           BrushColor: theDC   ;

: offset    ( x y n -- x+n y+n)
     TUCK  +  >R  +  R>  ;

: scale   ( f: x y -- )  ( -- x' y')
    y1  F/  1e  F-  F2/   y_lim  F*   FNEGATE   F>S
    x1  F/  1e  F+  F2/   x_lim  F*             F>S  SWAP  ;

: fplot    ( f: x y --)     \ plot a point
    scale  50 offset  2     FillCircle: theDC ;

\ Simulation

: new_zeta   prng  F2*  1e  F-   c  F*  zeta  F!  ;

: new_y      prng  F2*  1e  F-   y1 F*  ;

: f1    ( f: x -- f1 = x+sin[2x]/2 - zeta )
        FDUP   F2*  FSIN  F2/  F+   zeta  F@  F-  ;

: new_x     ( f: -- x)      \ invert cos^2 distribution
            new_zeta
            use( f1 x1 fnegate x1 1.0e-4 )falsi   ;

: 2slits    ( Npoints --)
        0.1 seed 2!                 \ initialize prng
        500 500 gotoxy              \ move cursor away
        set_plot                    \ make background
        0 DO
            new_x  new_y  fplot     \ plot a point
        LOOP
        BEGIN  KEY?  UNTIL          \ loop until key pressed
        KEY DROP    CLS  ;          \ clean up