rem Pixel Migrate .... Rev 2.3
      rem A J Tooth // February 2007
      
      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 and load picture
      proc_setup
      
      repeat
        rem Master ASM routine
        call Master%
        
        rem Display the result
        proc_BMP_DispB(xscreen%,yscreen%,picmir%)
        sys "MessageBeep",0
        
        rem Change the parameters
        proc_change(a$,b&)
        
      until b&<>0 or a$="s" or a$="S"
      
      if a$="s" then
        proc_save(Name$,"F",picmir%,lgth%,Newpic$)
        colour 2 : print tab(1,1);"File saved as: ";Newpic$
        proc_event(a$,b&)
      endif
      
      quit
      rem End of Program =========================================================
      rem ========================================================================
      
      rem Setup and load picture
      def proc_setup
      
      rem Change the Windows Title
      title$ = " PIXEL MIGRATION by Tony Tooth"
      sys "SetWindowText", @hwnd%, title$
      sys "GetSystemMetrics", 0 to xscreen%
      sys "GetSystemMetrics", 1 to yscreen%
      vdu 23,22,xscreen%;yscreen%;8,16,16,1 : rem Set fullscreen mode
      colour 3 : colour 132,0,0,50 : colour 4,0,0,50 : colour 132 : cls : off : mouse on
      
      MxR%=4 : rem Max radius
      
      rem Choose effect
      lam=0.1 : cc&=0 : proc_effect(cc&,lam)
      
      rem Pick any picture, convert to 1024x768
      proc_pichoose24(Name$,FulName$,Pre$,wdth%,hght%,lgth%)
      
      rem Go to full screen
      proc_fullscreen(xscreen%,yscreen%)
      xmax%=xscreen%-1 : ymax%=yscreen%-1
      
      rem Display a Picture
      proc_gendisp(1,FulName$,0,0,wdth%,hght%,pic%,lgth%)
      *FONT Verdana,11,B
      colour 3 : print tab(5,5);"Calculating .... Please wait."
      
      rem Setup II
      proc_setup2
      endproc
      rem ========================================================================
      
      rem Setup 2
      def proc_setup2
      local pass&
      
      rem Set up mirror bitmap
      proc_BMP_Set(wdth%,hght%,picmir%,Wlim%,lgth%)
      
      dim Calc% 1000, Update% 500, Master% 200, itmp% 3, ftmp% 3
      dim rgb%(2), Force(2)
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_Calc(pass&)
        proc_Update(pass&)
        proc_Master(pass&)
      next pass&
      endproc
      rem =======================================================================
      
      rem Change the parameters
      def proc_change(return a$,return b&)
      local in&
      
      colour 3 : print tab(1,1);lam;"  "
      
      proc_event(a$,b&) : rem Wait for a mouse-click or a key-press.
      
      in&=asc(a$)
      case in& of
        when 61,140: lam+=0.01
        when 45,141: lam-=0.01 : if lam<0.01 then lam=0.01
      endcase
      colour 1 : print tab(1,1);lam;"  "
      endproc
      rem =======================================================================
      
      rem Effect choice routine
      def proc_effect(return CC&, return Lam)
      local a&,d&,x%,y%,b&,rd&,gd&,bd&,a$
      
      if Z%=0 then
        dim chs$(2)
        chs$(0)="D o u b l e : \2Colour diffuses in both directions"
        chs$(1)="B r i g h t  : \2Colour diffuses from dark to light"
        chs$(2)="D a r k      : \2Colour diffuses from light to dark"
      endif
      
      rem Instructions
      font$="Verdana" : proc_instruct
      
      for a&=0 to 2
        for d&=25 to 1 step-1
          rd&=int(255*(1-d&/25)) : gd&=rd& : bd&=50+int(205*(1-d&/25))
          colour 7,rd&,gd&,bd& : gcol 7
          circle fill 150,fn_adapt(1,1200-100*a&),d&
        next d&
        Msg$="\3"+chs$(a&)
        proc_msg(font$,11,"B",225,fn_adapt(1,1220-100*a&),Msg$)
      next a&
      
      colour 6,150,150,250
      Msg$="\6P I X E L  M I G R A T I O N "
      proc_msg("Blackadder ITC",30,"B",500,fn_adapt(1,400),Msg$)
      
      mouse on
      repeat
        mouse x%,y%,b&
        sys "Sleep",10
        Aa%=x%>125 and x%<175
        case true of
          when Aa% and (y%>fn_adapt(1,975) and y%<fn_adapt(1,1025))  : mouse on 137
          when Aa% and (y%>fn_adapt(1,1075) and y%<fn_adapt(1,1125)) : mouse on 137
          when Aa% and (y%>fn_adapt(1,1175) and y%<fn_adapt(1,1225)) : mouse on 137
          otherwise
            mouse on 0
        endcase
        
        if x%>125 and x%<175 and b&=4 then
          case true of
            when (y%>fn_adapt(1,975) and y%<fn_adapt(1,1025))  : CC&=3 : Lam=0.1
            when (y%>fn_adapt(1,1075) and y%<fn_adapt(1,1125)) : CC&=2 : Lam=0.07
            when (y%>fn_adapt(1,1175) and y%<fn_adapt(1,1225)) : CC&=1 : Lam=0.07
            otherwise
              CC&=0
          endcase
          if CC&<>0 then sys "MessageBeep",0
        endif
      until CC&>0
      
      rem Chosen button turns GREEN
      for d&=25 to 1 step-1
        rd&=0 : gd&=int(255*(1-d&/25)) : bd&=50-int(50*(1-d&/25))
        colour 7,rd&,gd&,bd& : gcol 7
        circle fill 150,fn_adapt(1,1200-100*(CC&-1)),d&
      next d&
      a$=inkey$(50)
      mouse off
      endproc
      rem =======================================================================
      
      rem Instructions
      def proc_instruct
      
      rem Display a message backdrop
      proc_back(50,fn_adapt(1,1300),700,fn_adapt(1,125),150,0,0)
      
      Msg$="\3Click on a button for choice of effect"
      proc_msg(font$,11,"B",100,fn_adapt(1,1375),Msg$)
      
      rem Display a message backdrop
      proc_back(50,fn_adapt(1,600),1200,fn_adapt(1,250),0,50,100)
      
      Msg$="\1* \2After the first altered image appears rotate the mouse-wheel or"
      Msg$=Msg$+"\n   press the \3+\2/\3- \2keys to change intensity of effect."
      proc_msg(font$,11,"B",100,fn_adapt(1,800),Msg$)
      
      Msg$="\1* \2Press -\3S\2- to \3SAVE \2the image."
      proc_msg(font$,11,"B",100,fn_adapt(1,720),Msg$)
      
      Msg$="\1* \2Click either mouse button or press -\3Esc\2- to \1QUIT\2."
      proc_msg(font$,11,"B",100,fn_adapt(1,670),Msg$)
      
      endproc
      rem =======================================================================
      
      rem Master ASM Routine
      def proc_Master(opt&)
      P%=Master%
      [opt opt&
      
      mov edx,0
      mov [^y%],edx
      
      .yloop
      mov edx,0
      mov [^x%],edx
      
      .xloop
      call Calc%            ;Force calculation
      
      call Update%          ;Mirror BMP update routine
      
      inc dword [^x%]
      mov edx,[^x%]
      cmp edx,[^wdth%]
      jl near xloop
      
      inc dword [^y%]
      mov edx,[^y%]
      cmp edx,[^hght%]
      jl near yloop
      
      ret
      ]
      endproc
      rem ======================================================================
      
      rem Force calculation Routine
      def proc_Calc(opt&)
      P%=Calc%
      [opt opt&
      
      mov eax,[^y%]
      imul eax,[^Wlim%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,54
      mov [^ref00%],eax
      
      finit
      fldz
      fst qword [^Force(0)]
      fst qword [^Force(1)]
      fstp qword [^Force(2)]
      
      mov edx,[^MxR%]
      neg edx
      mov [^p%],edx
      
      .ploop
      mov edx,[^MxR%]
      neg edx
      mov [^q%],edx
      
      .qloop
      mov eax,[^p%]
      cmp eax,0
      jne ok
      mov eax,[^q%]
      cmp eax,0
      jne ok
      jmp miss
      
      .ok
      mov eax,[^y%]
      add eax,[^p%]
      mov [^py%],eax
      mov eax,[^x%]
      add eax,[^q%]
      mov [^qx%],eax
      
      mov ebx,[^py%]
      cmp ebx,0
      jl near miss
      cmp ebx,[^ymax%]
      jg near miss
      mov ebx,[^qx%]
      cmp ebx,0
      jl near miss
      cmp ebx,[^xmax%]
      jg near miss
      
      mov eax,[^py%]
      imul eax,[^Wlim%]
      add eax,[^qx%]
      add eax,[^qx%]
      add eax,[^qx%]
      add eax,54
      mov [^ref%],eax
      
      fild dword [^p%]
      fmul st0,st0
      fild dword [^q%]
      fmul st0,st0
      faddp st1,st0
      fsqrt
      fstp qword [^dis]
      
      mov dl,0
      mov [^a&],dl
      
      .aloop
      mov ecx,0
      mov cl,[^a&]
      mov eax,[^ref%]
      add eax,ecx
      mov ebx,[^ref00%]
      add ebx,ecx
      mov ecx,0
      mov edx,0
      mov cl,pic%[eax]
      mov dl,pic%[ebx]
      sub ecx,edx
      
      mov [itmp%],ecx
      fild dword [itmp%]
      mov al,[^cc&]
      cmp al,1
      je cont
      fabs
      cmp al,2
      je cont
      fchs
      .cont
      fld qword [^dis]
      fdivp st1,st0
      mov eax,0
      mov al,[^a&]
      shl eax,3
      fld qword ^Force(0)[eax]
      faddp st1,st0
      fstp qword ^Force(0)[eax]
      
      inc byte [^a&]
      mov dl,[^a&]
      cmp dl,2
      jbe near aloop
      
      .miss
      inc dword [^q%]
      mov edx,[^q%]
      cmp edx,[^MxR%]
      jle near qloop
      
      inc dword [^p%]
      mov edx,[^p%]
      cmp edx,[^MxR%]
      jle near ploop
      
      ret
      ]
      endproc
      rem ======================================================================
      
      rem BMP Update Routine
      def proc_Update(opt&)
      P%=Update%
      [opt opt&
      
      mov dl,0
      mov [^aa&],dl
      
      .aaloop
      finit
      mov ebx,[^ref00%]
      mov eax,0
      mov [itmp%],eax
      mov al,[^aa&]
      add ebx,eax
      mov al,pic%[ebx]
      mov [itmp%],eax
      fild dword [itmp%]
      fld qword [^lam]
      mov al,[^aa&]
      shl eax,3
      fld qword (^Force(0))[eax]
      fmulp st1,st0
      faddp st1,st0
      fistp dword [itmp%]
      mov ecx,[itmp%]
      cmp ecx,0
      jge good1
      mov ecx,0
      .good1
      cmp ecx,255
      jle good2
      mov ecx,255
      .good2
      mov picmir%[ebx],cl
      
      inc byte [^aa&]
      mov dl,[^aa&]
      cmp dl,2
      jbe aaloop
      
      ret
      ]
      endproc
      rem ======================================================================
      
      rem That which is coded in ASM above
      def proc_dump
      
      ref00%=y%*3072 + 3*x% + 54 : rem DONE
      Force()=0.0 : rem DONE
      
      for p%=-MxR% to MxR%
        for q%=-MxR% to MxR%
          
          rem DONE
          if (p%<>0 or q%<>0) then
            py%=y%+p% : qx%=x%+q% : rem DONE
            
            rem Ensure only pixels within the picture frame are permitted
            rem DONE
            if (py%>=0 and py%<=767) and (qx%>=0 and qx%<=1023) then
              
              ref%=py%*3072 + 3*qx% + 54   : rem DONE
              dis=1.0*(sqr(p%*p% + q%*q%)) : rem DONE
              
              for a&=0 to 2 : rem DONE
                diff%=?(pic%+ref%+a&) - ?(pic%+ref00%+a&) : rem DONE
                Force(a&)+=diff%/dis                      : rem DONE
              next a&
            endif
          endif
        next q%
      next p%
      
      rem DONE
      for a&=0 to 2
        col%=?(pic%+ref00%+a&) + lam*Force(a&) : rem DONE
        if col%<0 then col%=0                  : rem DONE
        if col%>255 then col%=255              : rem DONE
        cl&=col%                               : rem DONE
        ?(picmir%+ref00%+a&)=cl&               : rem DONE
      next a&
      endproc
      rem ======================================================================