rem Crystal Ball ........... Rev 6.2
      rem A J Tooth // July 2005
      rem Modified 20th August to cater for multiple screen sizes
      
      rem =======================================================
      on error if (err=17) then quit
      *FLOAT 64
      himem=lomem + 100000000
      install @lib$+"MyUtils.bbc"
      install @lib$+"BMP_Utils.bbc"
      rem =======================================================
      
      rem Setup
      proc_setup
      
      rem Select picture
      proc_picselect
      
      rem Second pass setup
      proc_setup2
      
      |kk%=1.5 : rem Initially 1.5 radii from the picture
      
      repeat
        rem Check for zoom
        proc_zoom
        
        rem Check whether the mouse has moved
        proc_msmve(bt&)
        
        rem Expand / contract circular area around the mouse position
        call rotate%
        
        rem Display BMP
        proc_BMP_DispB(xscreen%,yscreen%,pfmir%)
        
        rem Display material of the crystal ball
        msg$="\9"+Index$(?ind%)
        proc_msg("Georgia Italic",12,"B",10,fn_adapt(1,1500),msg$)
        
        *REFRESH
      until bt&=1
      *REFRESH ON
      
      proc_back(100,fn_adapt(1,1250),1000,fn_adapt(1,200),150,150,150)
      msg$="\14Left-click to choose another picture."
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,1400),msg$)
      
      msg$="\14Right-click to \9QUIT"
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,1350),msg$)
      
      proc_mclick(b&)
      if b&=4 then run else quit
      
      quit
      rem End of Program ==========================================
      rem =========================================================
      
      rem Check for zoom
      def proc_zoom : local w&
      
      w&=asc(inkey$(0))
      case w& of
          rem Zoom IN
        when 140: |kk%+=0.1 : if |kk%>10.0 then |kk%=10.0
          rem Zoom OUT
        when 141: |kk%-=0.1 : if |kk%<1.1 then |kk%=1.1
        otherwise
          rem Do nothing
      endcase
      endproc
      rem =========================================================
      
      rem Check whether the mouse has moved
      def proc_msmve(return but&) : local mx%,my%
      
      but&=0
      mouse mx%,my%,but&
      !Xmid%=int(mx%/2) : !Ymid%=int(my%/2)
      if !Xmid%<100 then !Xmid%=100
      if !Xmid%>(!Xlim%-100) then !Xmid%=!Xlim%-100
      if !Ymid%<100 then !Ymid%=100
      if !Ymid%>(!Ylim%-100) then !Ymid%=!Ylim%-100
      
      if but&=4 then
        ?ind%+=1 : if ?ind%=5 then ?ind%=0
        |kk%=Index(?ind%)
      endif
      endproc
      rem =========================================================
      
      rem Setup
      def proc_setup
      
      rem Revert to normal windowed mode
      proc_revert(xscreen%,yscreen%,0,0)
      mouse on
      
      rem Change the Windows Title
      title$ = "Crystal Ball"
      sys "SetWindowText", @hwnd%, title$
      
      rem Display a backdrop picture
      proc_BackPic("BPic.jpg",xscreen%,yscreen%)
      
      rem Displays my icon
      proc_AJTicon(10,fn_adapt(1,650))
      
      colour 8,160,90,20
      
      msg$="\8CRYSTAL BALL"
      proc_msg("Blackadder ITC",24,"B",350,fn_adapt(1,500),msg$)
      
      proc_back(100,fn_adapt(1,1250),1000,fn_adapt(1,200),150,150,150)
      
      msg$="\14Choose to view either a \10jpeg\14, \10gif \14or \10bitmap \14image."
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,1400),msg$)
      
      msg$="\11CLICK THE MOUSE TO CONTINUE."
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,1350),msg$)
      
      proc_back(100,fn_adapt(1,600),1000,fn_adapt(1,250),150,150,150)
      msg$="\10Roll the mouse-wheel to zoom in or out."
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,700),msg$)
      
      msg$="\10Click \11LEFT \10mouse button to toggle Refractive Index."
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,750),msg$)
      
      msg$="\10Click \11RIGHT \10mouse button to exit"
      proc_msg("Georgia Italic",12,"B",200,fn_adapt(1,800),msg$)
      
      proc_mclick(b&) : rem Wait for a mouse click
      
      endproc
      rem =======================================================================
      
      rem Second pass setup
      def proc_setup2
      
      dim rgb% 3, Xlim% 3, Ylim% 3, Xmid% 3, Ymid% 3
      
      rem Set up a blank bitmap
      proc_BMP_Set(xscreen%,yscreen%,pfmir%,Wlim%,lgth%)
      
      !Xlim%=xscreen%-1 : !Ylim%=yscreen%-1 : !Xmid%=xscreen%/2 : !Ymid%=yscreen%/2
      
      dim rotate% 5000, Index(4), Index$(4)
      
      rem Refractive indices for Water, Glass, Diamond
      Index(0)=1.33 : Index(1)=1.50 : Index(2)=2.41
      Index(3)=1.77 : Index(4)=1.77
      Index$(0)="Water" : Index$(1)="Glass" : Index$(2)="Diamond"
      Index$(3)="Ruby" : Index$(4)="Sapphire"
      
      dim dist% 7, csalp% 7, snalp% 7, theta% 7, rdist% 7
      dim csthe% 7, snthe% 7, xn% 3, yn% 3, x% 3, y% 3, f100% 7
      dim f1000% 7, md% 7, rd% 7, ftmp% 7, ftmp2% 7, r% 3, th% 3
      dim Flg% 0, fX% 7, RInd% 7, thinc% 7, alpha% 7, itmp% 3
      dim tnalpha% 7, Cee% 7, ybar% 7, xbar% 7, tnalpbet% 7
      dim kk% 7, ind% 0, trav% 7, fac% 7
      
      ?ind%=0 : rem Initially Water
      |f1000%=1200.0 : |rd%=150.0
      |f100%=250.0   : |RInd%=1.33
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_rotate(pass&)
      next pass&
      
      endproc
      rem =======================================================================
      
      rem Select picture
      def proc_picselect
      
      rem Choose a picture
      proc_pichoose(Name$,FulName$,Pre$,wdth%,hght%,ntused%,pic%)
      
      rem Go to full screen
      proc_fullscreen(xscreen%,yscreen%)
      
      *REFRESH OFF
      rem Display the picture initially in a full window
      proc_BMP_DispB(xscreen%,yscreen%,pic%)
      
      rem Set up a blank bitmap
      proc_BMP_Set(xscreen%,yscreen%,pf%,Wlim%,lgth%)
      
      command$=" SCREENSAVE "+"temp.bmp"+" 0,0,"+str$(2*xscreen%)+","+str$(2*yscreen%)
      oscli command$
      command$=" LOAD "+"temp.bmp "+str$~pf%
      oscli command$
      
      *REFRESH
      endproc
      rem =======================================================================
      
      rem Rotate and Display Routine
      def proc_rotate(opt%)
      P%=rotate%
      [opt opt%
      
      mov esi,pf%
      mov edi,pfmir%
      mov eax,[^lgth%]
      sub eax,54
      shr eax,2
      mov ecx,eax
      cld
      rep movsd
      
      finit
      
      mov edx,0
      mov [r%],edx                ;Initialise r-loop counter
      
      .rloop
      fld qword [rd%]
      fld qword [f100%]
      fdivp st1,st0
      fild dword [r%]
      fmulp st1,st0
      fst qword [dist%]           ;Radius, rho
      
      fld st0                     ;X f0r (-X,-rho)
      fmulp st1,st0
      fld qword [rd%]
      fld st0
      fmulp st1,st0
      faddp st1,st0
      fsqrt
      fchs
      fstp qword [fX%]            ;X f0r (-X,-rho)
      
      fld qword [dist%]           ;Angle 0f incidence
      fld st0
      fld st0
      fmulp st1,st0
      fld qword [rd%]
      fld st0
      fmulp st1,st0
      fsubrp st1,st0
      fsqrt
      fpatan
      fst qword [thinc%]          ;Angle 0f incidence
      
      fsin                        ;Angle 0f refraction
      fld st0
      fld st0
      fmulp st1,st0
      fld qword [RInd%]
      fld st0
      fmulp st1,st0
      fsubrp st1,st0
      fpatan                      ;Angle 0f refraction
      
      fld qword [thinc%]
      fsubrp st1,st0
      fst qword [alpha%]          ;The angle Alpha
      
      fsincos
      fdivp st1,st0
      fst qword [tnalpha%]
      
      fld st0
      fmulp st1,st0
      fld qword [fX%]
      fld st0
      fmulp st1,st0
      fld qword [rd%]
      fld st0
      fmulp st1,st0
      fsubp st1,st0
      fmulp st1,st0               ;(X*X-rd*rd)*tnalpha*tnalpha
      
      fld qword [dist%]
      fld qword [fX%]
      fld qword [tnalpha%]
      fmulp st1,st0
      fmulp st1,st0
      fld st0
      faddp st1,st0               ;2*rho*X*tnalpha
      
      fld qword [dist%]
      fld st0
      fmulp st1,st0               ;rho*rho
      
      faddp st1,st0
      faddp st1,st0
      fstp qword [Cee%]           ;Combined answer = Cee
      
      fld qword [fX%]
      fld qword [tnalpha%]
      fmulp st1,st0
      fld qword [dist%]
      faddp st1,st0
      fst qword [ftmp%]           ;Temporarily store (X*tnalpha + rho)
      fld st0
      fmulp st1,st0
      fld qword [tnalpha%]
      fld st0
      fmulp st1,st0
      fld1
      fst qword [ftmp2%]          ;Keep (1+tnalpha*tnalpha) in ftmp2
      faddp st1,st0
      fld qword [Cee%]
      fmulp st1,st0
      fsubp st1,st0
      fsqrt
      fld qword [ftmp%]
      fsubp st1,st0
      fld qword [ftmp2%]
      fdivp st1,st0
      fst qword [ybar%]
      
      fld st0
      fmulp st1,st0
      fld qword [rd%]
      fld st0
      fmulp st1,st0
      fsubrp st1,st0
      fsqrt
      fstp qword [xbar%]
      
      fld qword [ybar%]
      fld qword [xbar%]
      fpatan
      fld qword [alpha%]
      fsubrp st1,st0
      
      fsin
      fld qword [RInd%]
      fmulp st1,st0
      fld st0
      fld st0
      fmulp st1,st0
      fld1
      fsubrp st1,st0
      fsqrt
      fpatan
      
      fld qword [alpha%]
      faddp st1,st0
      fsincos
      fdivp st1,st0               ;Tan(alpha+beta)
      
      fld qword [kk%]
      fld qword [rd%]
      fmulp st1,st0
      fld qword [xbar%]
      fsubp st1,st0
      fmulp st1,st0
      fld qword [ybar%]
      faddp st1,st0
      fchs
      fstp qword [rdist%]
      
      fld qword [ybar%]          ;%-age traversal distance through crystal
      fld qword [dist%]
      faddp st1,st0
      fld st0
      fmulp st1,st0
      fld qword [xbar%]
      fld qword [fX%]
      fsubp st1,st0
      fld st0
      fmulp st1,st0
      faddp st1,st0
      fsqrt
      fld qword [rd%]
      fld st0
      faddp st1,st0
      fdivp st1,st0
      fstp qword [trav%]          ;%-age traversal distance through crystal
      
      fld qword [trav%]
      fld1
      fld1
      faddp st1,st0
      fdivp st1,st0
      fld1
      fsubrp st1,st0
      fstp qword [fac%]
      
      mov edx,0
      mov [th%],edx               ;Initialise th-loop counter
      
      .thloop
      fldpi
      fld st0
      faddp st1,st0
      fld qword [f1000%]
      fdivp st1,st0
      fild dword [th%]
      fmulp st1,st0
      fst qword [theta%]          ;Angle
      
      fld st0
      fcos
      fld qword [dist%]
      fmulp st1,st0
      fild dword [Xmid%]
      faddp st1,st0
      fistp dword [xn%]
      
      fsin
      fld qword [dist%]
      fmulp st1,st0
      fild dword [Ymid%]
      faddp st1,st0
      fistp dword [yn%]
      
      fld qword [theta%]
      fld st0
      fcos
      fld qword [rdist%]
      fmulp st1,st0
      fild dword [Xmid%]
      faddp st1,st0
      fistp dword [x%]
      
      fsin
      fld qword [rdist%]
      fmulp st1,st0
      fild dword [Ymid%]
      faddp st1,st0
      fistp dword [y%]
      
      mov ebx,[x%]                ;Check that point is within bmp limits
      cmp ebx,0
      jl black
      cmp ebx,[Xlim%]
      jg black
      mov eax,[y%]
      cmp eax,0
      jl black
      cmp eax,[Ylim%]
      jg black                    ;Check that point is within screen limits
      
      mov eax,[Xlim%]             ;Source bmp-reference
      add eax,[Xlim%]
      add eax,[Xlim%]
      add eax,3
      imul eax,[y%]
      add eax,[x%]
      add eax,[x%]
      add eax,[x%]
      add eax,54                  ;Source bmp-reference
      
      mov ecx,pf%[eax]
      mov [rgb%],ecx
      jmp cont
      .black
      mov ecx,&3F3F3F
      mov [rgb%],ecx
      
      .cont
      mov ebx,[xn%]               ;Check that point is within bmp limits
      cmp ebx,0
      jl near miss
      cmp ebx,[Xlim%]
      jg near miss
      mov eax,[yn%]
      cmp eax,0
      jl near miss
      cmp eax,[Ylim%]
      jg near miss                ;Check that point is within screen limits
      
      mov eax,[Xlim%]               ;Destination bmp-reference
      add eax,[Xlim%]
      add eax,[Xlim%]
      add eax,3
      imul eax,[yn%]
      add eax,[xn%]
      add eax,[xn%]
      add eax,[xn%]
      add eax,54                  ;Destination bmp-reference
      
      mov dl,[ind%]
      cmp dl,3
      je ruby
      cmp dl,4
      je near sapphire
      mov cl,[rgb%]               ;Transfer rgb v@lue
      mov pfmir%[eax],cl
      mov cl,[rgb%+1]
      mov pfmir%[eax+1],cl
      mov cl,[rgb%+2]
      mov pfmir%[eax+2],cl        ;Transfer rgb v@lue
      jmp miss
      
      .ruby
      mov ecx,0
      mov cl,[rgb%]
      mov [itmp%],ecx
      fild dword [itmp%]
      fld qword [fac%]
      fmulp st1,st0
      fistp dword [itmp%]
      mov cl,[itmp%]
      mov pfmir%[eax],cl
      mov cl,[rgb%+1]
      mov [itmp%],ecx
      fild dword [itmp%]
      fld qword [fac%]
      fmulp st1,st0
      fistp dword [itmp%]
      mov cl,[itmp%]
      mov pfmir%[eax+1],cl
      mov cl,[rgb%+2]
      mov pfmir%[eax+2],cl        ;Transfer rgb v@lue
      jmp miss
      
      .sapphire
      mov ecx,0
      mov cl,[rgb%]               ;Transfer rgb v@lue
      mov pfmir%[eax],cl
      mov cl,[rgb%+1]
      mov [itmp%],ecx
      fild dword [itmp%]
      fld qword [fac%]
      fmulp st1,st0
      fistp dword [itmp%]
      mov cl,[itmp%]
      mov pfmir%[eax+1],cl
      mov cl,[rgb%+2]
      mov [itmp%],ecx
      fild dword [itmp%]
      fld qword [fac%]
      fmulp st1,st0
      fistp dword [itmp%]
      mov cl,[itmp%]
      mov pfmir%[eax+2],cl        ;Transfer rgb v@lue
      
      .miss
      mov edx,[th%]               ;th loop control
      add edx,1
      mov [th%],edx
      cmp edx,1200
      jle near thloop
      
      mov edx,[r%]                ;r loop control
      add edx,1
      mov [r%],edx
      cmp edx,249
      jle near rloop
      
      ret
      ]
      endproc
      rem ======================================================================