rem Ripple ........ Rev 3.0
      rem A J Tooth // December 2006
      
      rem Preamble==================================
      on error if (err=17) then quit
      *FLOAT 64
      himem=lomem + 100000000
      install @lib$+"MyUtils.bbc"
      install @lib$+"BMP_Utils.bbc"
      rem Preamble==================================
      
      rem Setup
      proc_setup
      
      rem Choose a picture
      proc_pichoose24(Name$,FulName$,Pre$,wdth%,hght%,lgth%)
      
      rem Go to full screen
      proc_fullscreen(xscreen%,yscreen%)
      
      rem Display the picture initially
      proc_gendisp(1,FulName$,0,0,xscreen%,yscreen%,pic%,lgth%)
      
      rem Set up mirror bitmap
      proc_BMP_Set(xscreen%,yscreen%,picmir%,Wlim%,lgth%)
      
      rem Ripple setup
      proc_setripple
      
      rem ASM Setup
      proc_setupASM
      
      *REFRESH OFF
      repeat
        sys "GetCurrentProcess" to hprocess%
        sys "SetPriorityClass", hprocess%, &100
        rem Create refracted image
        call refract%
        sys "GetCurrentProcess" to hprocess%
        sys "SetPriorityClass", hprocess%, &20
        
        rem Display the distorted image
        proc_BMP_Disp(xscreen%,yscreen%,picmir%,0,0)
        *REFRESH
        
        proc_event(a$,b&) : rem Wait for a mouse-click or a key-press.
        
        rem Change parameters
        proc_parchange(a$)
        
      until (b&=1 or b&=4)
      
      *REFRESH ON
      if b&=4 then run else quit
      quit
      rem End of Program ==========================================
      rem =========================================================
      
      rem Setup
      def proc_setup
      
      rem Revert to normal windowed screen
      proc_revert(xscreen%,yscreen%)
      
      mouse on
      mode 22 : off : colour 132,0,0,50 : colour 4,0,0,50 : colour 128 : cls : colour 3
      rem Change the Windows Title
      title$ = " Ripples"
      sys "SetWindowText", @hwnd%, title$
      
      rem Display a background picture
      proc_BackPic("Squig.jpg",xscreen%,yscreen%)
      
      rem Displays my icon
      proc_AJTicon(10,650)
      
      *FONT Blackadder ITC,30,B
      vdu 5
      colour 8,160,190,20
      gcol 8 : move 1200,1050 : print;"RIPPLES"
      
      *FONT Georgia Italic,12,B
      proc_back(100,1250,1100,200,150,150,150)
      move 175,1400 : gcol 6: print;"Choose to view either a jpeg, gif or bitmap image."
      gcol 3 : move 175,1350 : print;"PRESS ANY KEY OR CLICK THE MOUSE TO ";
      gcol 2 : print;"CONTINUE"
      
      proc_back(100,400,1000,350,150,150,150)
      move 175,700 : gcol 2: print;"Click the left mouse button to ";
      gcol 3 : print;"re-run"
      move 175,650 : gcol 2 : print;"Click the right mouse button to ";
      gcol 1 : print;"QUIT"
      move 175,600 : gcol 2 : print;"Roll the ";
      gcol 3 : print;"mouse wheel ";
      gcol 2 : print;"to increase water depth";
      move 175,550 : gcol 2 : print;"Press the ";
      gcol 3: print;"+/- ";
      gcol 2 : print;"keys to increase wave height";
      move 175,500 : gcol 2 : print;"Press the ";
      gcol 3 : print;"arrow ";
      gcol 2 : print;"keys to change horiz/vert frequency";
      vdu 4
      
      proc_event(a$,b&) : rem Wait for a mouse-click or a key-press.
      
      endproc
      rem =======================================================================
      
      rem Ripple setup
      def proc_setripple
      
      rem Refractive indices
      n1=1.00
      n2=1.333
      n12=n1/n2
      
      rem Ripple freq
      n=3.0
      m=7.0
      
      a=9.0  : rem Ripple amplitude
      d=20.0 : rem Water depth
      
      apn=a*pi*n
      apm=a*pi*m
      
      endproc
      rem =======================================================================
      
      rem Change parameters
      def proc_parchange(A$)
      local in&
      
      in&=asc(A$)
      if in&=140 then d-=1.0
      if in&=141 then d+=1.0
      if d<a then d=a
      
      if in&=45 then a-=1.0
      if in&=61 then a+=1.0
      if a>d then a=d
      if a<1.0 then a=1.0
      
      if in&=138 then n-=1.0
      if in&=139 then n+=1.0
      if n<1.0 then n=1.0
      
      if in&=136 then m-=1.0
      if in&=137 then m+=1.0
      if m<1.0 then m=1.0
      endproc
      rem =======================================================================
      
      rem ASM Setup
      def proc_setupASM
      
      dim refract% 2000, itmp% 3, ftmp% 7
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_refract(pass&)
      next pass&
      endproc
      rem =======================================================================
      
      rem BMP Update Routine
      def proc_refract(opt&)
      P%=refract%
      [opt opt&
      
      mov edx,0
      mov [^yy%],edx
      .yloop
      mov edx,0
      mov [^xx%],edx
      .xloop
      
      finit
      fild dword [^xx%]                ;Calculate x & y
      fadd st0,st0
      fild dword [^xscreen%]
      fld1
      fsubp st1,st0
      fdivp st1,st0
      fstp qword [^x]
      fild dword [^yy%]
      fadd st0,st0
      fild dword [^yscreen%]
      fld1
      fsubp st1,st0
      fdivp st1,st0
      fstp qword [^y]                  ;Calculate x & y
      
      fldpi
      fld qword [^n]
      fld qword [^x]
      fmulp st1,st0
      fmul st0,st1
      fsincos
      fstp qword [^cnx]
      fstp qword [^snx]
      fld qword [^m]
      fld qword [^y]
      fmulp st1,st0
      fmulp st1,st0
      fsincos
      fstp qword [^cmy]
      fstp qword [^smy]
      
      fld qword [^apn]                ;Normal vector t0 surface
      fld qword [^cnx]
      fld qword [^smy]
      fmulp st1,st0
      fmulp st1,st0
      fchs
      fstp qword [^nx]
      fld qword [^apm]
      fld qword [^snx]
      fld qword [^cmy]
      fmulp st1,st0
      fmulp st1,st0
      fchs
      fstp qword [^ny]
      fld1
      fstp qword [^nz]                ;Normal vector t0 surface
      
      fld qword [^nx]                 ;Normalise vector
      fmul st0,st0
      fld qword [^ny]
      fmul st0,st0
      fld qword [^nz]
      fmul st0,st0
      faddp st1,st0
      faddp st1,st0
      fsqrt
      fld qword [^nx]
      fdiv st0,st1
      fstp qword [^nx]
      fld qword [^ny]
      fdiv st0,st1
      fstp qword [^ny]
      fld qword [^nz]
      fdiv st0,st1
      fstp qword [^nz]               ;Normalise vector
      
      fld1
      fdivrp st1,st0
      fst qword [^ridn]
      fld st0                        ;Calculate arccos using arctan
      fmul st0,st0
      fld1
      fsubrp st1,st0
      fsqrt
      fxch st1
      fpatan
      fst qword [^Theta1]            ;Calculate Theta1
      fsin
      fld qword [^n12]
      fmulp st1,st0
      fld st0
      fmul st0,st0
      fld1
      fsubrp st1,st0
      fsqrt
      fpatan
      fstp qword [^Theta2]          ;Calculate Theta2
      
      fld qword [^Theta2]
      fcos
      fld qword [^ridn]
      fsubp st1,st0
      fst qword [^lam]
      
      fld qword [^nx]              ;Calculate refracted vector
      fmul st0,st1
      fstp qword [^rox]
      fld qword [^ny]
      fmul st0,st1
      fstp qword [^roy]
      fld qword [^nz]
      fmulp st1,st0
      fld1
      faddp st1,st0
      fstp qword [^roz]            ;Calculate refracted vector
      
      fld qword [^rox]             ;Normalise vector
      fmul st0,st0
      fld qword [^roy]
      fmul st0,st0
      fld qword [^roz]
      fmul st0,st0
      faddp st1,st0
      faddp st1,st0
      fsqrt
      fld qword [^rox]
      fdiv st0,st1
      fstp qword [^rox]
      fld qword [^roy]
      fdiv st0,st1
      fstp qword [^roy]
      fld qword [^roz]
      fdivrp st1,st0
      fstp qword [^roz]            ;Normalise vector
      
      fld qword [^a]
      fld qword [^snx]
      fld qword [^smy]
      fmulp st1,st0
      fmulp st1,st0
      fld qword [^d]
      fchs
      faddp st1,st0
      fchs
      fld qword [^roz]
      fdivp st1,st0
      fstp qword [^alp]
      
      fld qword [^alp]            ;Bitmap ref
      fld qword [^rox]
      fmulp st1,st0
      fild dword [^xx%]
      faddp st1,st0
      fistp dword [^xr%]
      fld qword [^alp]
      fld qword [^roy]
      fmulp st1,st0
      fild dword [^yy%]
      faddp st1,st0
      fistp dword [^yr%]          ;Bitmap ref
      
      mov eax,[^xr%]              ;Is the point within the source bitmap?
      cmp eax,0
      jl near miss
      cmp eax,[^xscreen%]
      jge near miss
      mov eax,[^yr%]
      cmp eax,0
      jl near miss
      cmp eax,[^yscreen%]
      jge near miss               ;Is the point within the source bitmap?
      
      mov eax,[^yy%]              ;Destination reference
      imul eax,[^Wlim%]
      add eax,[^xx%]
      add eax,[^xx%]
      add eax,[^xx%]
      add eax,54
      mov ebx,eax                 ;Destination reference
      
      mov eax,[^yr%]              ;Source reference
      imul eax,[^Wlim%]
      add eax,[^xr%]
      add eax,[^xr%]
      add eax,[^xr%]
      add eax,54                  ;Source reference
      
      mov cl,pic%[eax]            ;Store in new bitmap
      mov picmir%[ebx],cl
      mov cl,pic%[eax+1]
      mov picmir%[ebx+1],cl
      mov cl,pic%[eax+2]
      mov picmir%[ebx+2],cl       ;Store in new bitmap
      
      .miss
      inc dword [^xx%]
      mov edx,[^xx%]
      cmp edx, [^xscreen%]
      jb near xloop
      
      inc dword [^yy%]
      mov edx,[^yy%]
      cmp edx, [^yscreen%]
      jb near yloop
      
      ret
      ]
      endproc
      rem ======================================================================
      
      def proc_dump1
      
      for yy%=0 to yscreen%-1
        for xx%=0 to xscreen%-1
          
          x=(xx%*2/xscreen%-1) : y=(yy%*2/yscreen%-1) : rem DONE
          
          pnx=pi*n*x : pmy=pi*m*y       : rem DONE
          
          cnx=cos(pnx) : snx=sin(pnx)   : rem DONE
          cmy=cos(pmy) : smy=sin(pmy)   : rem DONE
          
          rem Surface normal
          nx=-apn*cnx*smy   : rem DONE
          ny=-apm*snx*cmy   : rem DONE
          nz=1.0            : rem DONE
          
          rem Normaliser HERE = DONE
          
          rem ALL DONE
          rem Calculate refraction angle
          ridn=1/nmod : rem Incident vector dotted with normal vector
          Theta1=acs(ridn)
          Theta2=asn(n12*sin(Theta1)) : rem n12=n1/n2
          
          rem Calculate refraction vector
          lam=cos(Theta2) - ridn : rem DONE
          
          rox=lam*nx      : rem DONE
          roy=lam*ny      : rem DONE
          roz=1.0+lam*nz  : rem DONE
          
          rem Normaliser
          rmod=sqr(rox*rox+roy*roy+roz*roz) : rem DONE
          rox/=rmod : rem DONE
          roy/=rmod : rem DONE
          roz/=rmod : rem DONE
          
          
          rem Height of water surface
          h=-d+a*snx*smy : rem DONE
          
          rem Find where refraction vector hits the bottom (z=0)
          alp=-h/roz  : rem DONE
          
          rem Calculate bitmap position
          xr%=int(1.0*xx%+alp*rox)  : rem DONE
          yr%=int(1.0*yy%+alp*roy)  : rem DONE
          
          rem All DONE
          if (xr%>=0 and xr%<xscreen%) and (yr%>=0 and yr%<yscreen%) then
            ref%=yy%*Wlim% + 3*xx% + 54  : rem DONE
            rft%=yr%*Wlim% + 3*xr% + 54  : rem DONE
            
            ?(picmir%+ref%)=?(pic%+rft%)     : rem DONE
            ?(picmir%+ref%+1)=?(pic%+rft%+1) : rem DONE
            ?(picmir%+ref%+2)=?(pic%+rft%+2) : rem DONE
          endif
        next xx%
      next yy%
      
      endproc
      rem ======================================================================