maybe you know graphicguestbook? At this page you can draw small pictures using a 12 color pallet. So I decided to paint something really special for a friend and made a programm that can convert RGB to LAB and find the closed looking color mixed up 12*12 colors in 8 blendings and placed some tile pictures to one big picture.
Now I increased the colors to 16 an implemented the c64 color pallet, so you can convert every picture to 16 colors with dithering (~400 colors) and I think it's maybe good to share.
Example:
Here you can download the color.b24 file for the actual pallet. This file holds an 24 bit indexed array to store every color-index calculated from the pallet, that matches best. So everytime you add, remove or change a color... this calculations have to be refreshed and this takes a while. But this way you can convert in realtime (I watched TV this way).
http://www.file-upload.net/download-870 ... r.zip.html
Programm:
Code: Select all
#INCLUDE "vbcompat.bi"
#Define MAX_COLOR 16
Declare Function readShader( shader() As Byte ) As Integer
Declare Function mix_color(c1 As ULong, c2 As ULong, ratio As ubyte) As ULong
Declare Sub rgbToLab(ByRef c As UInteger, lab() As Single )
Declare Function de_1994(lab1() As Single, lab2() As Single) As Single
Declare Function loadBMP( Dateiname As String ) As ULong Ptr
Type mixed_colorT
vRGB As ULong
c1 As ULong
c2 As ULong
ratio As UByte
vLAB(2) As Single
End Type
Dim Shared intPalette(0 To 15) As UInteger
intPalette(0) = &hFF000000
intPalette(1) = &hFFffffff
intPalette(2) = &hFF883932
intPalette(3) = &hFF67b6bd
intPalette(4) = &hFF8b3f96
intPalette(5) = &hFF55a049
intPalette(6) = &hFF40318d
intPalette(7) = &hFFbfce72
intPalette(8) = &hFF8b5429
intPalette(9) = &hFF574200
intPalette(10) = &hFFb86962
intPalette(11) = &hFF505050
intPalette(12) = &hFF787878
intPalette(13) = &hFF94e089
intPalette(14) = &hFF7869c4
intPalette(15) = &hFF9f9f9f
Dim Shared As Single cc1, cc2, dc, dl, da, db, dh, ssecond, third
Dim Shared As ULong Ptr bild
Dim Shared As ULong Ptr sc
Dim Shared As UInteger sW, sH
Dim As Byte shader(8, 2, 2)
Dim As mixed_colorT mixed_color(MAX_COLOR * MAX_COLOR * 8)
Dim As UInteger color_count, pixel
Dim As UShort Ptr trueColor = Callocate(2^24 * SizeOf(UShort) )
Dim As Double sec
Open Cons For output As #1
Print #1, "generating shaders..."
readShader( shader() )
Print #1, "mix the colors..."
For c1 As UInteger = 0 To MAX_COLOR - 1
For c2 As UInteger = 0 To MAX_COLOR - 1
For ratio As UByte = 0 To 7
Dim As UInteger found
Dim As UInteger col = mix_color(intPalette(c1), intPalette(c2), ratio)
For test As UInteger = 0 To color_count
If mixed_color(test).vRGB = col Then
found = 1
EndIf
Next
If found = 0 Then
mixed_color(color_count).vRGB = col
mixed_color(color_count).c1 = intPalette(c1)
mixed_color(color_count).c2 = intPalette(c2)
mixed_color(color_count).ratio = ratio
rgbToLab(col, mixed_color(color_count).vLAB() )
color_count += 1
End If
found = 0
Next
Next
Next
Print #1, color_count - 1
If Not FileExists("color.b24") Then
Print #1, "Calculating new..."
For f As uinteger = 0 To 2^24
Dim As Single diff, oldDiff = &h0FFFFFFF
Dim As UInteger ff
Dim As Single lab1(2)
rgbToLab(f, lab1() )
For t As UInteger = 0 To color_count - 1
diff = de_1994(lab1(), mixed_color(t).vLAB() )
If diff < oldDiff Then
ff = t
oldDiff = diff
End If
Next
Dim As UShort saveFF = ff
trueColor[f] = saveFF
If Timer()-sec >= 3 Then
Print #1, CInt (100 / 2^24 * f) & "%"
sec = Timer()
EndIf
Next
Print #1, "Saving..."
Dim map As Integer = FreeFile
Open "color.b24" For Binary Access write As #map
Put #map, 1, trueColor[0], 2^24
Close #map
Else
Print #1, "Load from file..."
Dim map As Integer = freefile
Open "color.b24" For Binary Access Read As #map
Get #map, 1, trueColor[0], 2^24
Close #map
End If
Print #1, "Done."
bild = loadBMP( Command(1) )
Dim As Integer r, g, b
For y As UInteger = 0 To sH - 1 Step 3
ScreenLock
For x As UInteger = 0 To sW - 1 Step 3
Dim As ULong col = *(bild + 8 + x + y * sW)
Dim As UShort cIdx = trueColor[&h00FFFFFF And col]
Dim As Integer xxx, yyy
For yy As UInteger = y To y + 2
For xx As UInteger = x To x + 2
If xx < sW And yy < sH Then
Select Case shader(mixed_color(cIdx).ratio, xxx, yyy)
Case 0:
*(sc + xx + yy * sW) = mixed_color(cIdx).c2
Case 1:
*(sc + xx + yy * sW) = mixed_color(cIdx).c1
End Select
EndIf
xxx += 1
Next
yyy += 1
xxx = 0
Next
yyy = 0
xxx = 0
Next
ScreenUnLock
Next
Sleep
Function loadBMP ( Dateiname As String ) As ULong Ptr
Dim As Integer ff = FreeFile
Open Dateiname For Binary As #ff
If (Lof(ff) < 32) Then
Close #ff
Return 0
End If
Get #ff, 19, sW
Get #ff, 23, sH
Close #ff
sH = ABS(sH)
If ((sW < 0) OR (sW > 2000) OR (sH > 2000)) Then Return 0
ScreenRes sW, sH, 32
sc = ScreenPtr
Dim bild As ULong Ptr
bild = ImageCreate(sW, sH, 0, 32)
BLoad dateiname, bild
Return bild
End Function
Function mix_color(c1 As ULong, c2 As ULong, ratio As ubyte) As ULong
Dim As UByte r1, g1, b1, r2, g2, b2
Dim inv_ratio As UByte = 8 - ratio
Dim As UByte rM, gM, bM
r1 = lobyte(hiword(c1))
g1 = hibyte(loword(c1))
b1 = lobyte(loword(c1))
r2 = lobyte(hiword(c2))
g2 = hibyte(loword(c2))
b2 = lobyte(loword(c2))
rM = CInt( (r1 * ratio + r2 * inv_ratio) / 8)
gM = CInt( (g1 * ratio + g2 * inv_ratio) / 8)
bM = CInt( (b1 * ratio + b2 * inv_ratio) / 8)
Return RGBA(rM, gM, bM, 255)
End Function
Function readShader( shader() As Byte ) As Integer
Dim As String pixel
Dim As Integer block, x, y
For i As UInteger = 0 To (3 * 3) * 8 - 1
Read pixel
Select Case pixel
Case ".":
shader(block, x, y) = 0
Case "#":
shader(block, x, y) = 1
End Select
x += 1
If x = 3 Then
x = 0
y += 1
If y = 3 Then
y = 0
block += 1
EndIf
EndIf
Next
Return 1
End Function
Sub rgbToLab(ByRef c As UInteger, lab() As Single )
Dim As Single r, g, b
r = LoByte(hiword(c)) /255
g = HiByte(loword(c)) /255
b = LoByte(loword(c)) /255
If r > 0.04045 Then
r = (r+0.055)/1.055
r = r ^ 2.4
Else
r = r/12.92
End If
If g > 0.04045 Then
g = (g+0.055)/1.055
g = g ^ 2.4
Else
g = g/12.92
End If
If b > 0.04045 Then
b = (b+0.055)/1.055
b = b ^ 2.4
Else
b = b/12.92
End If
r *= 100
g *= 100
b *= 100
Dim As Double x, y, z, x1, y1, z1
x = r * 0.4124 + g * 0.3576 + b * 0.1805
y = r * 0.2126 + g * 0.7152 + b * 0.0722
z = r * 0.0193 + g * 0.1192 + b * 0.9505
x1 = x/95.047
y1 = y/100
z1 = z/108.883
If x1 > 0.008856 Then
x1 = x1 ^ (1/3)
Else
x1 = 7.787* x1 + 16/116
End If
If y1 > 0.008856 Then
y1 = y1 ^ (1/3)
Else
y1 = (7.787 * y1) + (16/116)
End If
If z1 > 0.008856 Then
z1 = z1 ^ (1/3)
Else
z1 = 7.787*z1 + 16/116
End If
lab(0) = 116* y1 -16
lab(1) = 500*(x1-y1)
lab(2) = 200*(y1-z1)
End Sub
Function de_1994(lab1() As Single, lab2() As Single) As Single
cc1 = Sqr(lab1(1)*lab1(1)+lab1(2)*lab1(2))
cc2 = Sqr(lab2(1)*lab2(1)+lab2(2)*lab2(2))
dc = cc1 - cc2
dl = lab1(0) - lab2(0)
da = lab1(1) - lab2(1)
db = lab1(2) - lab2(2)
dh = (da * da) + (db * db) - (dc * dc)
If (dh < 0) Then
dh = 0
Else
dh = sqr(dh)
End If
ssecond = dc / (1 + 0.045 * cc1)
third = dh / (1 + 0.015 * cc1)
Return (sqr(dl * dl + ssecond * ssecond + third * third))
End Function
Data ".", ".", "."
Data ".", ".", "."
Data ".", ".", "."
Data ".", ".", "."
Data ".", "#", "."
Data ".", ".", "."
Data ".", ".", "."
Data ".", "#", "."
Data ".", ".", "#"
Data "#", ".", "#"
Data ".", ".", "."
Data "#", ".", "#"
Data ".", "#", "."
Data "#", "#", "#"
Data ".", "#", "."
Data ".", "#", "#"
Data "#", ".", "#"
Data "#", "#", "#"
Data "#", "#", "#"
Data "#", ".", "#"
Data "#", "#", "#"
Data "#", "#", "#"
Data "#", "#", "#"
Data "#", "#", "#"