Anonymous user
Color wheel: Difference between revisions
→{{header|Wren}}
(Color wheel in FreeBASIC) |
|||
Line 1,412:
https://www.dropbox.com/s/g3l5rbywo34bnp6/IMG_4600.PNG?dl=0
This file is no longer there!!! 10 Sep 2021
=={{header|VBScript}}==
Building a BMP file and opening it with the default viewer. It takes 5 seconds in my 5 years old notebook. Run with Cscript if you don want to be clicking at annoying message boxes.
<lang vb>
option explicit
Class ImgClass
Private ImgL,ImgH,ImgDepth,bkclr
private xmini,xmaxi,ymini,ymaxi
dim ImgArray() 'rgb in 24 bit mode, indexes to palette in 8 bits
private filename
private Palette
public property get xmin():xmin=xmini:end property
public property get ymin():ymin=ymini:end property
public property get xmax():xmax=xmaxi:end property
public property get ymax():ymax=ymaxi:end property
public sub set0 (x0,y0) 'sets the new origin (default tlc)
if x0<0 or x0>=imgl or y0<0 or y0>imgh then err.raise 9
xmini=-x0
ymini=-y0
xmaxi=xmini+imgl-1
ymaxi=ymini+imgh-1
end sub
'constructor
Public Default Function Init(name,w,h,dep,bkg,pal)
dim i,j
ImgL=w
ImgH=h
set0 0,0 'tlc
redim imgArray(ImgL-1,ImgH-1)
bkclr=bkg
if bkg<>0 then
for i=0 to ImgL-1
for j=0 to ImgH-1
imgarray(i,j)=bkg
next
next
end if
filename=name
ImgDepth =dep
'load user palette if provided
if imgdepth=8 then
if isarray(pal) then
if ubound(pal)=255 then
palette=pal
else
mypalette
end if
else
mypalette
end if
end if
set init=me
end function
'class termination writes it to a BMP file and displays it
'if an error happens VBS terminates the class before exiting so the BMP is displayed the same
Private Sub Class_Terminate
if err<>0 then wscript.echo "Error " & err.number
wscript.echo "copying image to bmp file"
savebmp
wscript.echo "opening " & filename & "with uour default viewer"
CreateObject("Shell.Application").ShellExecute filename
End Sub
'writes a 32bit integr value as binary to a string
Sub WriteLong(ByRef Fic,ByVal k)
Dim x
For x=1 To 4
Fic.Write chr(k and &hFF)
k=k\256
Next
End Sub
Public Sub SaveBMP
'Save the picture to a bmp file
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Dim Fic
Dim i,r,g,b
Dim k,x,y,padding
dim bpp:bpp=imgdepth\8
Set Fic = WScript.CreateObject("scripting.Filesystemobject").OpenTextFile(filename, ForWriting, True)
if fic is nothing then wscript.echo "error creating file" & filename :wscript.quit
dim bms:bms=ImgH* 4*(((ImgL*bpp)+3)\4) 'bitmap size including padding
dim pals:if (imgdepth=8) then pals=(ubound(Palette)+1)*4 else pals=0
'FileHeader
Fic.Write "BM" 'Type
WriteLong Fic, 14+40+ pals + bms 'Size of entire file in bytes
fic.write string(4,0)
WriteLong Fic,54+pals '2 words: offset of BITMAPFILEHEADER (access to the beginning of the bitmap) 54=14+40 (fileheader+infoheader)
'InfoHeader
WriteLong Fic,40 'Size of Info Header(40 bytes)
WriteLong Fic,ImgL
WriteLong Fic,ImgH
Fic.Write chr(1) & chr(0) 'Planes : 1
Fic.Write chr(ImgDepth) & chr(0) 'Bitcount : 1,4,8,16,24,32 = bitsperpixel
fic.write string(8,0)&chr(&Hec)&chr(4)& string(2,0)&chr(&Hec)&chr(4)& string(2,0)& string(8,0)
'palette
If (imgdepth=8) Then
For i=0 to ubound(palette)
writelong fic ,Palette(i)
Next
End If
'write bitmap
dim xx:xx=(ImgL*bpp) mod 4
if xx<>0 then padding=Space(4-xx) else padding=""
Select Case ImgDepth
Case 24
'wscript.echo imgdepth
For y=ImgH-1 to 0 step-1 'Origin of bitmap: bottom left
For x=0 To ImgL-1
'writelong fic, Pixel(x,y)
k=ImgArray(x,y)
Fic.Write chr(k and &hff)
k=k\256
Fic.Write chr(k and &hff)
k=k\256
Fic.Write chr(k and &hff)
Next
Fic.Write padding
Next
Case 8
For y=ImgH-1 to 0 step-1
For x=0 To ImgL-1
Fic.Write chr(ImgArray(x,y) and &hff)
Next
Fic.Write padding
Next
Case Else
WScript.Echo "ColorDepth unknown : " & ImgDepth & " bits"
End Select
Fic.Close
Set Fic=Nothing
End Sub
end class
function hsv2rgb( Hue, Sat, Value) 'hue 0-360 0-ro 120-ver 240-az ,sat 0-100,value 0-100
dim Angle, Radius,Ur,Vr,Wr,Rdim
dim r,g,b, rgb
Angle = (Hue-150) *0.01745329251994329576923690768489
Ur = Value * 2.55
Radius = Ur * tan(Sat *0.01183199)
Vr = Radius * cos(Angle) *0.70710678 'sqrt(1/2)
Wr = Radius * sin(Angle) *0.40824829 'sqrt(1/6)
r = (Ur - Vr - Wr)
g = (Ur + Vr - Wr)
b = (Ur + Wr + Wr)
'clamp values
if r >255 then
Rdim = (Ur - 255) / (Vr + Wr)
r = 255
g = Ur + (Vr - Wr) * Rdim
b = Ur + 2 * Wr * Rdim
elseif r < 0 then
Rdim = Ur / (Vr + Wr)
r = 0
g = Ur + (Vr - Wr) * Rdim
b = Ur + 2 * Wr * Rdim
end if
if g >255 then
Rdim = (255 - Ur) / (Vr - Wr)
r = Ur - (Vr + Wr) * Rdim
g = 255
b = Ur + 2 * Wr * Rdim
elseif g<0 then
Rdim = -Ur / (Vr - Wr)
r = Ur - (Vr + Wr) * Rdim
g = 0
b = Ur + 2 * Wr * Rdim
end if
if b>255 then
Rdim = (255 - Ur) / (Wr + Wr)
r = Ur - (Vr + Wr) * Rdim
g = Ur + (Vr - Wr) * Rdim
b = 255
elseif b<0 then
Rdim = -Ur / (Wr + Wr)
r = Ur - (Vr + Wr) * Rdim
g = Ur + (Vr - Wr) * Rdim
b = 0
end if
hsv2rgb= (b and &hff)+256*((g and &hff)+256*(r and &hff))
end function
function ang(col,row)
'if col =0 then if row>0 then ang=0 else ang=180:exit function
if col =0 then
if row<0 then ang=90 else ang=270 end if
else
if col>0 then
ang=atn(-row/col)*57.2957795130
else
ang=(atn(row/-col)*57.2957795130)+180
end if
end if
ang=(ang+360) mod 360
end function
Dim X,row,col,fn,tt,hr,sat,row2
const h=160
const w=160
const rad=159
const r2=25500
tt=timer
fn=CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)& "\test.bmp"
Set X = (New ImgClass)(fn,w*2,h*2,24,0,0)
x.set0 w,h
'wscript.echo x.xmax, x.xmin
for row=x.xmin+1 to x.xmax
row2=row*row
hr=int(sqr(r2-row2))
for col=-hr to hr
sat=100-sqr(row2+col*col)/rad *50
' wscript.echo c,r
x.imgArray(col+160,row+160)=hsv2rgb(ang(row,col)+90,100,sat)
next
'script.echo row
next
Set X = Nothing
wscript.echo "Time " & (timer-tt) & " ms"
</lang>
=={{header|Wren}}==
| |||