rem Shift Colour ....... Rev 2.0
      rem A J Tooth // Sept 2008
      
      rem ===================================================================
      on error if (err=17) then quit
      himem=lomem + 100000000
      *FLOAT 64
      install @lib$+"MyUtils.bbc"
      install @lib$+"BMP_Utils.bbc"
      rem ===================================================================
      
      rem Basic set up
      proc_setup
      
      rem PHASE ONE
      rem ===================================================================
      
      rem Choose a picture
      proc_pichoose(Name$,FulName$,Pre$,wdth%,hght%,lgth%,pic%)
      
      rem Set scaling for displaying pictures centrally
      proc_scale(xscreen%,yscreen%,wdth%,hght%,xb%,yb%,xc%,yc%)
      
      rem Display BMP as is
      proc_BMP_Disp(xc%,yc%,pic%,xb%,yb%)
      
      rem Set up a copy bitmap according to parameters provided
      proc_BMP_Set(wdth%,hght%,picmir%,Wlim%,ntused%)
      
      rem ASM Setup
      proc_ASM_Setup
      
      proc_event(a$,b&)
      rem PHASE TWO
      rem ===================================================================
      
      rem Create histogram
      call histo%
      
      rem Find maximum, lowest and highest of histogram
      thr&=255
      proc_max(max%,lo&,hi&,thr&)
      
      rem Display histogram
      proc_disp_histo(max%,lo&,hi&,thr&)
      
      rem Alter image
      call Yconvert%
      
      rem Display stretched BMP
      proc_BMP_Disp(xc%,yc%,picmir%,xb%,yb%)
      
      proc_event(a$,b&)
      
      if a$="s" then
        proc_save(Name$,"St",picmir%,lgth%,Newpic$)
        colour 3 : print tab(1,1);"Picture saved as: ";Newpic$
        a$=inkey$(100)
      endif
      
      if b&=4 then run else quit
      quit
      rem End of Program ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      rem =========================================================================================================
      
      rem Basic set up
      def proc_setup
      local a&,b&
      
      rem Go to full screen
      proc_fullscreen(xscreen%,yscreen%)
      
      rem Standard grey-scale weightings
      wr=0.30 : wg=0.59 : wb=0.11
      
      dim conv(2,2), inv(2,2)
      
      restore
      rem Load RGB to YUV factors
      for a&=0 to 2
        for b&=0 to 2
          read conv(b&,a&)
        next b&
      next a&
      
      conv()*=1.0
      
      rem Load YUV to RGB factors
      for a&=0 to 2
        for b&=0 to 2
          read inv(b&,a&)
        next b&
      next a&
      
      inv()*=1.0
      
      endproc
      rem =========================================================================================================
      
      rem YUV RGB Conversion data
      data 0.299,-0.14713,0.615,0.587,-0.28886,-0.51499,0.114,0.436,-0.10001
      data 1.000,1.000,1.000,0.000,-0.39465,2.03211,1.13983,-0.58060,0.000
      rem =======================================================================
      
      rem Find maximum, lowest and highest of histogram
      def proc_max(return max%, return lo&, return hi&,thr&)
      local a&,lind&,hind&
      
      max%=0 : lo&=255 : hi&=0
      lind&=0 : hind&=0
      for a&=0 to 255
        if Hist%(a&)>max% then max%=Hist%(a&)
        if Hist%(a&)>1000 and lind&=0 then lo&=a& : lind&=1
        if (255-a&)<thr& and Hist%(255-a&)>1000 and hind&=0 then hi&=255-a& : hind&=1
      next a&
      
      endproc
      rem =========================================================================================================
      
      rem Display histogram
      def proc_disp_histo(max%,lo&,return hi&,return thr&)
      local a&
      
      *REFRESH OFF
      repeat
        cls
        gcol 3
        for a&=0 to 255
          move 500+4*a&,500
          draw 500+4*a&,500+1000*Hist%(a&)/max%
        next a&
        
        gcol 1 : move 500+4*thr&,500 : draw 500+4*thr&,1500
        
        colour 3 : print tab(10,10);"Lowest: ";lo&
        print tab(10,12);"Highest: ";hi&
        print tab(10,14);"Threshold: ";thr&
        *REFRESH
        
        proc_event(a$,b&)
        case asc(a$) of
          when 140 : if thr&>1 then thr&-=1 : hi&=thr&-1
          when 141 : if thr&<255 then thr&+=1 : hi&=thr&-1
        endcase
        
      until b&=4
      
      dis%=hi&-lo&
      
      cls
      *REFRESH ON
      endproc
      rem =========================================================================================================
      
      rem ASM Setup
      def proc_ASM_Setup
      local pass&
      
      dim histo% 1000, Yconvert% 1000, itmp% 3, ftmp% 7
      dim Hist%(255)
      
      i255%=255
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_histo(pass&)
        proc_Yconvert(pass&)
      next pass&
      
      endproc
      rem =========================================================================================================
      
      rem Histogram
      def proc_histo(opt&)
      P%=histo%
      
      [opt opt&
      
      mov edx,0
      mov [^y%],edx
      
      .yyyloop
      mov edx,0
      mov [^x%],edx
      
      .xxxloop
      mov eax,[^y%]
      imul eax,[^Wlim%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,54
      mov [^ref%],eax
      
      finit
      fild dword [^i255%]         ;Normalise RGB Values
      mov bl,pic%[eax+2]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdiv st0,st1
      fstp qword [^R]
      mov bl,pic%[eax+1]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdiv st0,st1
      fstp qword [^G]
      mov bl,pic%[eax]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdivrp st1,st0
      fstp qword [^B]             ;Normalise RGB Values
      
      fld qword [^R]              ;Y calculation
      fld qword [^conv(0,0)]
      fmulp st1,st0
      fld qword [^G]
      fld qword [^conv(0,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^B]
      fld qword [^conv(0,2)]
      fmulp st1,st0
      faddp st1,st0
      fild dword [^i255%]
      fmulp st1,st0
      fistp dword [^yv%]
      
      mov ebx,0
      mov bl,[^yv%]
      
      shl ebx,2
      inc dword ^Hist%(0)[ebx]
      
      inc dword [^x%]
      mov edx,[^x%]
      cmp edx,[^wdth%]
      jl near xxxloop
      
      inc dword [^y%]
      mov edx,[^y%]
      cmp edx,[^hght%]
      jl near yyyloop
      
      ret
      ]
      endproc
      rem =========================================================================================================
      
      rem YUV/RGB Assembly Routine
      def proc_Yconvert(opt&)
      P%=Yconvert%
      [opt opt&
      
      mov edx,0
      mov [^y%],edx
      
      .yloop
      mov edx,0
      mov [^x%],edx
      
      .xloop
      mov eax,[^y%]
      imul eax,[^Wlim%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,[^x%]
      add eax,54
      mov [^ref%],eax
      
      mov ebx,0
      finit
      fild dword [^i255%]         ;Normalise RGB Values
      mov bl,pic%[eax+2]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdiv st0,st1
      fstp qword [^R]
      mov bl,pic%[eax+1]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdiv st0,st1
      fstp qword [^G]
      mov bl,pic%[eax]
      mov [itmp%],ebx
      fild dword [itmp%]
      fdivrp st1,st0
      fstp qword [^B]             ;Normalise RGB Values
      
      fld qword [^R]              ;Y calculation
      fld qword [^conv(0,0)]
      fmulp st1,st0
      fld qword [^G]
      fld qword [^conv(0,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^B]
      fld qword [^conv(0,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^Y]             ;Y calculation
      
      fld qword [^R]              ;U calculation
      fld qword [^conv(1,0)]
      fmulp st1,st0
      fld qword [^G]
      fld qword [^conv(1,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^B]
      fld qword [^conv(1,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^U]             ;U calculation
      
      fld qword [^R]              ;V calculation
      fld qword [^conv(2,0)]
      fmulp st1,st0
      fld qword [^G]
      fld qword [^conv(2,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^B]
      fld qword [^conv(2,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^V]             ;V calculation
      
      fld qword [^Y]              ;Alter Y
      fild dword [^i255%]
      fmulp st1,st0
      mov bl,[^lo&]
      mov [itmp%],ebx
      fild dword [itmp%]
      fsubp st1,st0
      fild dword [^dis%]
      fdivp st1,st0
      fst qword [^Y]
      
      fld qword [^inv(0,0)]       ;Recover R
      fmulp st1,st0
      fld qword [^U]
      fld qword [^inv(0,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^V]
      fld qword [^inv(0,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^R]             ;Recover R
      
      fld qword [^Y]              ;Recover G
      fld qword [^inv(1,0)]
      fmulp st1,st0
      fld qword [^U]
      fld qword [^inv(1,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^V]
      fld qword [^inv(1,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^G]             ;Recover G
      
      fld qword [^Y]              ;Recover B
      fld qword [^inv(2,0)]
      fmulp st1,st0
      fld qword [^U]
      fld qword [^inv(2,1)]
      fmulp st1,st0
      faddp st1,st0
      fld qword [^V]
      fld qword [^inv(2,2)]
      fmulp st1,st0
      faddp st1,st0
      fstp qword [^B]             ;Recover B
      
      mov eax,[^ref%]             ;Update BMP with revised RGB Values
      fild dword [^i255%]
      fld qword [^R]
      fmul st0,st1
      fistp dword [itmp%]
      mov ecx,[itmp%]
      cmp ecx,255
      jle RokH
      mov ecx,255
      .RokH
      cmp ecx,0
      jge RokL
      mov ecx,0
      .RokL
      mov picmir%[eax+2],cl
      
      fld qword [^G]
      fmul st0,st1
      fistp dword [itmp%]
      mov ecx,[itmp%]
      cmp ecx,255
      jle GokH
      mov ecx,255
      .GokH
      cmp ecx,0
      jge GokL
      mov ecx,0
      .GokL
      mov picmir%[eax+1],cl
      
      fld qword [^B]
      fmulp st1,st0
      fistp dword [itmp%]
      mov ecx,[itmp%]
      cmp ecx,255
      jle BokH
      mov ecx,255
      .BokH
      cmp ecx,0
      jge BokL
      mov ecx,0
      .BokL
      mov picmir%[eax],cl         ;Update BMP with revised RGB Values
      
      inc dword [^x%]
      mov edx,[^x%]
      cmp edx,[^wdth%]
      jb near xloop
      
      inc dword [^y%]
      mov edx,[^y%]
      cmp edx,[^hght%]
      jb near yloop
      
      ret
      ]
      endproc
      rem =======================================================================