#include "fbgfx.bi"
#include "crt.bi"
#include "vbcompat.bi"

#ifdef __FB_WIN32__
#define Windows
#include "windows.bi"
#endif

'#define DebugTimings

#ifdef Windows
SetPriorityClass(GetCurrentProcess,IDLE_PRIORITY_CLASS)
#endif

const as integer pal_count = 256
dim shared as integer iHalt

#ifdef DebugTimings
  dim shared as double CompareDD,CheckDD,MutateDD,ClosestDD,Find_Best_pDD,RenderDD
  dim shared as integer CompareLL,CheckLL,MutateLL,ClosestLL,Find_Best_pLL,RenderLL
#endif
#macro BeginTime()
  #ifdef DebugTImings
    dim as double ddTemp = timer
    __FUNCTION_NQ__#ll  += 1
  #endif
#endmacro
#macro EndTime()
  #ifdef DebugTimings    
    __FUNCTION_NQ__#dd  += (timer-ddTemp)
  #endif
#endmacro

type tpal
  as uinteger pal(0 to pal_count - 1)
end type
type PictureStruct
	union
    as uinteger pal(0 to pal_count - 1)
    as tpal tPal
  end union
  as ubyte MutateA(0 to pal_count-1)
  as ubyte MutateB(0 to pal_count-1)
  as integer BestDiff(63,63)
  as short Best_p(63,63)
  as fb.image ptr pBuffIN,pBuffOut,pBuffTemp  
  as integer old_score,new_score
  as integer cnt,full_cnt
  as integer iBetter,iDone,LastBetter
  as any ptr pMutex,pThread
  as double dTime,LoadTime
  as string sText,sFile
end type

printf(!"Size=%i\n",sizeof(PictureStruct))
#define irnd() cint(rand() xor (rand() shl 15))  
function compare(tPic as PictureStruct) as integer  
	BeginTime()
  dim as integer diff  
	var p1 = cast(integer ptr,tPic.pBuffIN+1)
	var p2 = cast(integer ptr,tPic.pBuffOUT+1)    
	for yx as integer = 0 to (256*256)-1		
    var c1 = *p1, c2 = *p2    
    dim as integer r1 = abs(((c1 shr 16) and 255)-((c2 shr 16) and 255))
    dim as integer g1 = abs(((c1 shr  8) and 255)-((c2 shr  8) and 255))
    dim as integer b1 = abs(((c1 shr  0) and 255)-((c2 shr  0) and 255))
    diff += (r1+g1+b1): p1 += 1: p2 += 1
  next yx
  EndTime()
	return diff  
end function
sub check(tPic as PictureStruct)  
	BeginTime()
  var p1 = cast(integer ptr,tPic.pBuffIN+1)
	var p2 = cast(integer ptr,tPic.pBuffOUT+1)
  for yx as integer = 0 to (256*256)-1
    if (*p1 and &hFFFFFF)=0 then
      if (*p2 and &hFFFFFF) then        
        printf !"massive trans error %s %s\n", hex(*p1, 6), hex(*p2, 6) 
        exit sub
      end if
    elseif (*p2 and &hFFFFFF)=0 then
      printf !"massive trans error %s %s\n", hex(*p1, 6), hex(*p2, 6) 
      exit sub
    end if
    p1 += 1: p2 += 1
  next yx
  EndTime()
end sub
sub mutate(tPic as PictureStruct) 
  BeginTime()
  ' change pal
  var zz = rand() mod 3,iA = cint(iRnd())
  select case zz
  case 0
    dim as integer x = (iRnd() mod pal_count) ' 0 to pal_count-1
    dim as integer b = (iA and &hF)+((iA and &h70) shr 4) ' 0 to 23
    dim as integer v = ((iA and &h100) shr 8) ' 0 to 1
    tPic.pal(x) and= not (1 shl b)
    tPic.pal(x) or= v shl b
    tPic.MutateA(x) += 1
    ' don't allow the trans color
    if (tPic.pal(x) and &HFFFFFF) = 0 then
      tPic.pal(x) = &H080808
    end if
  case 1
    dim as integer x = (iRnd() mod pal_count) ' 0 to pal_count-1
    tPic.pal(x) = cptr(uinteger ptr,tPic.pBuffIN+1)[iRnd() and &hFFFF]
    tPic.MutateA(x) += 1
    ' don't allow the trans color
    if (tPic.pal(x) and &HFFFFFF) = 0 then
      tPic.pal(x) = &H080808
    end if
  case 2
    dim as integer cnt = (Rand() mod 5) + 2 ' between 2 and 6 changes?
    for i as integer = 0 to cnt - 1
      dim as integer x = (iRnd() mod pal_count) ' 0 to pal_count-1
      tPic.pal(x) = cptr(uinteger ptr,tPic.pBuffIN+1)[iRnd() and &hFFFF]
      tPic.MutateA(x) += 1
      ' don't allow the trans color
      if (tPic.pal(x) and &HFFFFFF) = 0 then
        tPic.pal(x) = &H080808
      end if
    next i
  end select 
  EndTime()
end sub
#if 0
sub mutate(tPic as PictureStruct)
  
	' change pal
	dim as integer x = (iRnd() mod pal_count)
  
  var iA = cint(iRnd())
	if (iA and &h8000) then
		dim as integer b = (iA and &hF)+((iA and &h70) shr 4) ' 0 to 23
		dim as integer v = ((iA and &h100) shr 8) shl b     ' 0 to  1
		tPic.pal(x) = (tPic.pal(x) and (not (1 shl b))) or v		
  else
		tPic.pal(x) = cptr(uinteger ptr,tPic.pBuffIN+1)[iRnd() and &hFFFF]
  end if
  
	' don't allow the trans color
	if (tPic.pal(x) and &HFFFFFF) = 0 then tPic.pal(x) = &H080808
    
  
end sub
#endif
function closest(byval c as uinteger, byval cl as uinteger ptr, has_trans as integer) as uinteger
  BeginTime()
	dim as integer best_diff = 256*3
	dim as uinteger result = any
  
	if has_trans and ((c and &HFFFFF) = 0) then 
    EndTime()
    return 0
  end if
  
	for i as integer = 0 to 3 - (has_trans and 1)
		dim as uinteger c1 = c
		dim as uinteger c2 = cl[i]
    dim as integer diff = _
    abs(((c1 shr 16) and 255)-((c2 shr 16) and 255)) + _
    abs(((c1 shr  8) and 255)-((c2 shr  8) and 255)) + _
    abs(((c1 shr  0) and 255)-((c2 shr  0) and 255)) 		
		if diff < best_diff then
			result = cl[i]: best_diff = diff
    end if
  next i
  
  EndTime()
	return result
  
end function
function find_best_p(tPic as PictureStruct,block_x as integer, block_y as integer, byref has_trans as integer) as integer
  
  BeginTime()
	dim as any ptr p1 = tPic.pBuffIN+1
  var iPitch = tPic.pBuffIN->Pitch
  
	p1 += block_y * 4 * iPitch
  
	has_trans = 0
  
	scope
		dim as any ptr p1a = p1 + (block_x * 4 * 4)
		for y as integer = 0 to 3
			for x as integer = 0 to 3
				dim as uinteger c1 = cast(uinteger ptr, p1a)[x]
				if (c1 and &HFFFFFF) = 0 then has_trans = 1        
      next x
			p1a += iPitch
    next y
  end scope
  
	dim as integer best_diff = tPic.BestDiff(block_x,block_y) '256*64*64
	dim as integer best_p = tPic.Best_P(block_x,block_y)
  if *cast(uinteger ptr,@tPic.MutateA(best_p)) <> *cast(uinteger ptr,@tPic.MutateB(best_p)) then
    best_diff = 256*64*64: best_p = 0
    for p as integer = 0 to pal_count-3 step 2		
      dim as integer diff    
      dim as any ptr p1a = p1 + (block_x * 4 * 4)
      dim as uinteger backup
      if has_trans then
        backup = tPic.pal(p+3)
        tPic.pal(p+3) = 0
      end if
      for y as integer = 0 to 3
        for x as integer = 0 to 3
          dim as uinteger c1 = cast(uinteger ptr, p1a)[x]
          dim as uinteger c2 = closest(c1, @tPic.pal(p), has_trans)
          diff += abs(((c1 shr 16) and 255)-((c2 shr 16) and 255)) + _
          abs(((c1 shr  8) and 255)-((c2 shr  8) and 255)) + _
          abs(((c1 shr  0) and 255)-((c2 shr  0) and 255)) 		
        next x
        p1a += iPitch
      next y
      if has_trans then tPic.pal(p+3) = backup    
      if diff < best_diff then
        best_diff = diff: best_p = p
      end if    
    next p
  else    
    for p as integer = 0 to pal_count-3 step 2
      if *cast(uinteger ptr,@tPic.MutateA(p)) <> *cast(uinteger ptr,@tPic.MutateB(p)) then      
        dim as integer diff    
        dim as any ptr p1a = p1 + (block_x * 4 * 4)
        dim as uinteger backup
        if has_trans then
          backup = tPic.pal(p+3)
          tPic.pal(p+3) = 0
        end if
        for y as integer = 0 to 3
          for x as integer = 0 to 3
            dim as uinteger c1 = cast(uinteger ptr, p1a)[x]
            dim as uinteger c2 = closest(c1, @tPic.pal(p), has_trans)
            diff += abs(((c1 shr 16) and 255)-((c2 shr 16) and 255)) + _
            abs(((c1 shr  8) and 255)-((c2 shr  8) and 255)) + _
            abs(((c1 shr  0) and 255)-((c2 shr  0) and 255)) 		
          next x
          p1a += iPitch
        next y
        if has_trans then tPic.pal(p+3) = backup    
        if diff < best_diff then
          best_diff = diff: best_p = p
        end if
      end if
    next p
  end if
  tPic.BestDiff(block_x,block_y) = best_diff
  tPic.Best_p(block_x,block_y) = best_p
  
  EndTime()
	return best_p
  
end function
sub render(tPic as PictureStruct)
  BeginTime()	
  dim as any ptr p1 = tPic.pBuffIN+1,p2 = tPic.pBuffOUT+1
  dim as integer iPitch = tPic.pBuffIN->pitch
  
	for y1 as integer = 0 to 63
		for x1 as integer = 0 to 63
			dim as integer has_trans
			dim as integer best_p = find_best_p(tPic,x1, y1, has_trans)
      
			' Now we found closest, render it truly
			dim as any ptr p1a = p1 + (x1 * 4 * 4)
			dim as any ptr p2a = p2 + (x1 * 4 * 4)
			dim as uinteger backup
			if has_trans then
				backup = tPic.pal(best_p+3)
				tPic.pal(best_p+3) = 0
      end if      
      for y as integer = 0 to 3
        for x as integer = 0 to 3
          dim as uinteger c1 = cast(uinteger ptr, p1a)[x]
          'dim as uinteger c2 = closest(c1, @tPic.pal(best_p), has_trans)
          cast(uinteger ptr, p2a)[x] = closest(c1, @tPic.pal(best_p), has_trans)
          'end if
        next x
        p1a += iPitch: p2a += iPitch
      next y
			if has_trans then
				tPic.pal(best_p+3) = backup
      end if
    next x1
		p1 += iPitch * 4 : p2 += iPitch * 4
  next y1
  EndTime()
end sub
function LoadPicture(tPic as PictureStruct,sBitmap as string) as integer
  if fileexists(sBitmap)=0 then return 0  
  with tPic
    var iFile = instrrev(sBitmap,"\")
    if iFile=0 then iFile = instrrev(sBitmap,"/")
    .sFile = mid$(sBitmap,iFile+1)
    if .pBuffIN   = 0 then .pBuffIN   = imagecreate(256,256)
    if .pBuffIN   = 0 then return 0
    if .pBuffOUT  = 0 then .pBuffOUT  = imagecreate(256,256)
    if .pBuffOUT  = 0 then return 0
    if .pBuffTemp = 0 then .pBuffTemp = imagecreate(256,256)
    if .pBuffTemp = 0 then return 0
    if .pMutex    = 0 then .pMutex    = MutexCreate()
    if .pMutex    = 0 then return 0
    .old_score=256*256*(256*3):.new_score=0:.iDone=0
    .cnt=0:.full_cnt=0:.LoadTime = timer:.LastBetter=0
    bload sBitmap,tPic.pBuffIN
    var pPix = cast(ubyte ptr,.pBuffIN+1)
    for CNT as integer = 0 to (256*256*4)-1
      var i1 = cint(pPix[CNT])+cint(pPix[CNT] and 7)    
      if i1 > 255 then i1 = 255    
      pPix[CNT] = i1 and &b111110001111100011111000    
    next CNT
    for x as integer = 0 to pal_count-1
      .pal(x) = (iRnd() and &b111110001111100011111000)
      if (.pal(x) and &b111110001111100011111000) = 0 then .pal(x) = &H080808
      .MutateB(x) = 255: .MutateA(x) = 0
    next x
    for Y as integer = 0 to 63
      for X as integer = 0 to 63
        .BestDiff(X,Y)= 256*64*64
        .Best_p(X,Y)=0
      next X
    next Y      
  end with
  return 1
end function

screenres 1024, 512, 32

'#ifdef Windows
'chdir "h:\jogos\rally"
'var sFold = "h:\jogos\rally\TexDump2\"
'#else
var sFold = exepath()+"/TexDump2/"
'#endif
var sFile = dir$(sFold+"*.bmp")

dim as PictureStruct tPics(1)
'bload "TexDump2/50E2954D506BA6A3-GreatBritain_Japan_USA.bmp", buffer1
printf(!"%s\n",sFile)
'sFile = dir$()
if LoadPicture(tPics(0),sFold+sFile) = 0 then 
  print "Failed to load '"+sFold+sFile+"'": sleep: end
end if
'sFile = dir$()
sFile = dir$()
if LoadPicture(tPics(1),sFold+sFile) = 0 then
  print "Failed to load '"+sFold+sFile+"'": sleep: end
end if

sub ExtraThread(pPic as PictureStruct ptr)
  with *pPic
    do
      if iHalt then exit do      
      var dTMR = timer      
      #ifdef Windows
      SwitchToThread()      
      #endif
      var old_pal = .tPal
      mutate(*pPic)
      memcpy(.pBuffTemp, .pBuffOut, sizeof(fb.image) + (.pBuffOut->pitch * .pBuffOut->height))      
      render(*pPic)      
      mutexlock(.pMutex)
      .new_score = compare(*pPic): .full_cnt += 1    
      if .new_score <= .old_score then
        for CNT as integer = 0 to 63
          cast(uinteger ptr,@.MutateB(0))[CNT] = cast(uinteger ptr,@.MutateA(0))[CNT]
        next CNT
      end if
      if .new_score >= .old_score then
        .tPal = old_pal: .new_score = .old_score      
        memcpy(.pBuffOut, .pBuffTemp , sizeof(fb.image) + (.pBuffOut->pitch * .pBuffOut->height))
      else
        .cnt += 1: .old_score = .new_score: .iBetter = 1        
        .LastBetter = timer-.LoadTime
      end if      
      if (.full_cnt and 15)=0 then check(*pPic)       
      if .full_cnt > (.cnt*20) then 
        .iDone = 1: 
        mutexunlock(.pMutex): exit do      
      end if
      .dTime = (timer-dTMR)
      mutexunlock(.pMutex)
    loop
  end with  
end sub

put(  0, 0), tPics(0).pBuffIN, pset
put(512, 0), tPics(1).pBuffIN, pset

tPics(0).pThread = ThreadCreate(cast(any ptr,@ExtraThread),cast(any ptr,@tPics(0)))
tPics(1).pThread = ThreadCreate(cast(any ptr,@ExtraThread),cast(any ptr,@tPics(1)))

#ifdef Windows
SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_ABOVE_NORMAL)
#endif

do until multikey(fb.sc_escape)
	dim as string sText
  dim as integer AllDone
  for CNT as integer = 0 to 1    
    with tPics(CNT)
      if .iDone > 0 then
        ThreadWait(.pThread):.pThread=0
        printf(!"[%s] done\n",sFold+.sFile)
        bsave sFold+.sFile+".bmp",.pBuffOut
        .iDone = -1: sFile = dir$()
        if len(sFile) then 
          LoadPicture(tPics(CNT),sFold+sFile)
          .pThread = ThreadCreate(cast(any ptr,@ExtraThread),cast(any ptr,@tPics(CNT)))
        end if
      end if
      if .iDone = -1 then AllDone += 1 
      mutexlock(.pMutex)
      var iX = CNT*512
      if .iBetter then        
        .iBetter=0
        screenlock
        put(iX,0),.pBuffIN,pset
        put(iX+256,0),.pBuffOUT,pset
        put(iX,256),.pBuffOUT,preset
        put(iX,256),.pBuffIN,and        
        dim as integer iColor
        for iPY as integer = 256 to 511 step 16
          for iPX as integer = iX+256 to iX+511 step 16
            line(iPX,iPY)-(iPX+15,iPY+15),.pal(iColor),bf
            iColor += 1
          next iPX
        next iPY
        screenunlock        
      end if
      if CNT then sText += "  ~~~  "
      sText += .sFile & " - " & .cnt & "/" & .full_cnt & " = " & _
      .new_score & " (" & cint(.dTIME*1000) & "ms|" & .LastBetter & "s)"
      mutexunlock(.pMutex)
    end with    
  next CNT		  
	WindowTitle(sText)
  sleep 200,1
  if AllDone > 1 then exit do
loop
iHalt = 1
for CNT as integer = 0 to 1 
  if tPics(CNT).pThread then
    ThreadWait(tPics(CNT).pThread)
  end if
next CNT

#ifdef DebugTimings
  #define ShowStatus(FuncName) printf(#FuncName !" %i %4.3f (%4.3f)\n",FuncName##LL,FuncName##DD,(FuncName##DD)/(FuncName##LL))
  ShowStatus(Compare)
  ShowStatus(Check)
  ShowStatus(Mutate)
  ShowStatus(Closest)
  ShowStatus(Find_Best_p)
  ShowStatus(Render)
#endif

printf(!"done!\n")
sleep