Code: Select all
#include "fbgfx.bi"
Using FB
Windowtitle "Simple Paint Program"
screenres 640,480,32
dim shared as integer cmd
cmd = 0 'draw mode default
dim shared as integer btnID 'id of button pressed
dim shared as integer penSize
penSize = 3 'pen size default
dim shared as integer mirror
mirror = 0 'default to no mirror
'fill in pallete with colors
dim as ubyte r,g,b
dim shared as uinteger colors(48)
for i as integer = 0 to 47
read r,g,b
colors(i) = rgb(r,g,b)
next i
dim shared as any ptr canvas1,canvas2 'displayed image
canvas1 = imageCreate(640,480,rgb(255,255,254)) 'save image while screen is being worked on
canvas2 = imageCreate(640,480,rgb(255,255,254)) 'saves saved image for UNDO
dim shared as integer mx,my,ox,oy,sx,sy,dx,dy,mb 'mouse variables
SetMouse(0,0,1,1)
dim shared as integer sColor 'id of selected color in palette
sColor = 0 'black pen default palette#0
dim shared as integer mode1, mode2 'fill rectangle, fill circle
sub update()
screenlock()
'=============
'draw buttons
'=============
for x as integer = 0 to 15
if cmd=x or (mirror = 1 and x = 7) then
line (x*40,0)-(x*40+39,20),rgb(100,100,255),bf
else
line (x*40,0)-(x*40+39,20),rgb(10,10,255),bf
end if
next x
draw string (4,8),"DRAW RECT CIRC LINE FILL RUB CLS HMIR UNDO SAVE LOAD PEN .... .... .... QUIT",rgb(255,255,254)
for i as integer = 0 to 15
line (i*40,0)-(i*40+39,20),rgb(200,200,200),b
next i
'==================
' draw palette
'==================
for x as integer = 0 to 39
line (x*16,464)-(x*16+15,479),colors(x),bf
if x = sColor or (mirror = 1 and x = 7) then
line (x*16,464)-(x*16+15,479) ,rgb(255,255,254),b
line (x*16+1,464+1)-(x*16+15-1,479-1) ,rgb(0,0,0),b
else
line (x*16,464)-(x*16+15,479) ,rgb(0,0,0),b
end if
next x
screenunlock()
sleep 2
end sub
sub thickLine(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,size As Integer,c As UInteger)
dim as integer x,y
if x1 = x2 and y1 = y2 then
circle (x1, y1), size, c, , , , f
elseif abs(x2 - x1) >= abs(y2 - y1) then
dim K as Single = (y2 - y1) / (x2 - x1)
for I as Integer = x1 To x2 step sgn(x2 - x1)
x = I
y = K * (I - x1) + y1
circle (x,y), size, c, , , , f
if mirror = 1 then
circle (640-x,y),size,c,,,,f 'for horizontal mirror
end if
next I
else
dim L as Single = (x2 - x1) / (y2 - y1)
for J as Integer = y1 To y2 step sgn(y2 - y1)
x = L * (J - y1) + x1
y = J
circle (x,y), size,c,,,,f
if mirror = 1 then
circle (640-x,y),size,c,,,,f 'for horizontal mirror
end if
next J
end if
end sub
sub floodfill (x As Integer, y As Integer, oldcolour As Integer, newcolour As Integer)
Dim As Integer Ptr p = New Integer[16*1024 * 1024]
Dim As Integer n = 0
Dim As Integer x0, y0
if oldcolour = newcolour then exit sub
p[n] = x
p[n+1] = y
n = n + 2
While n > 0
y0 = p[n-1]
x0 = p[n-2]
n = n - 2
If Point(x0, y0) = oldcolour Then
Pset (x0, y0), newcolour
p[n] = x0
p[n+1] = y0-1
p[n+2] = x0
p[n+3] = y0+1
p[n+4] = x0-1
p[n+5] = y0
p[n+6] = x0+1
p[n+7] = y0
n = n + 8
End If
Wend
Delete p
End Sub
sub Fill()
floodfill (mx,my,point(mx,my),colors(sColor))
update()
'wait for select button release
while mb=1
getmouse mx,my,,mb
wend
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
sub drawRectangle()
dim as integer r
dim as string s
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then 'mouse has moved so draw erase old draw new
screenlock()
put (0,0),canvas1,trans 'restore screen
'fill rectangle mode?
if mode1 = 1 then
for i as integer = oy to my
line (ox,i)-(mx,i),colors(sColor)
next i
end if
thickLine(ox,oy,mx,oy,penSize,colors(sColor))
thickLine(mx,oy,mx,my,penSize,colors(sColor))
thickLine(mx,my,ox,my,penSize,colors(sColor))
thickLine(ox,my,ox,oy,penSize,colors(sColor))
screenunlock()
update()
sleep 1
end if
wend
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
sub drawLine()
dim as integer sx,sy
sx = mx
sy = my
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then 'mouse has moved so draw erase old draw new
put (0,0),canvas1,trans 'restore screen
thickLine(sx,sy,mx,my,penSize,colors(sColor)) 'draw line
ox = mx
oy = my
update()
end if
wend
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
sub drawPen()
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then 'mouse has moved so draw erase old draw new
thickLine(ox,oy,mx,my,penSize,colors(sColor)) 'drawline onto screenBuffer
ox = mx
oy = my
update()
end if
sleep 1
wend
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
Sub ellipse(x0 As Integer, Y0 As Integer, X1 As Integer, y1 As Integer, c as uinteger)
'bresenham circle
'void bresenham_ellipse( x0 As Integer,y0 As Integer, x1 As integer, y1 As integer )
If x0>x1 Then Swap x0,x1
If y0>y1 Then Swap y0,y1
Dim As Integer x,y,a2,b2, S, T,xb,yb,b
b=(y1-y0)/2
b2=b*b
a2=(x1-x0)^2/4
xb=(x0+x1)/2
yb=(y0+y1)/2
x = 0
y = b
S = a2*(1-2*b) + 2*b2
T = b2 - 2*a2*(2*b-1)
if mode2 = 1 then 'fill ellipse
line ((xb-x),(yb+y))-((xb-x),(yb-y)),c
line ((xb+x),(yb+y))-((xb+x),(yb-y)),c
end if
circle ((xb+x),(yb+y)),3,c,,,,f
circle ((xb+x),(yb-y)),3,c,,,,f
circle ((xb-x),(yb+y)),3,c,,,,f
circle ((xb-x),(yb-y)),3,c,,,,f
Do
If S<0 Then
S += 2*b2*(2*x+3)
T += 4*b2*(x+1)
x+=1
Elseif T<0 Then
S += 2*b2*(2*x+3) - 4*a2*(y-1)
T += 4*b2*(x+1) - 2*a2*(2*y-3)
x+=1
y-=1
Else
S -= 4*a2*(y-1)
T -= 2*a2*(2*y-3)
y-=1
End If
if mode2 = 1 then 'fill ellipse
line ((xb-x),(yb+y))-((xb-x),(yb-y)),c
line ((xb+x),(yb+y))-((xb+x),(yb-y)),c
end if
circle ((xb+x),(yb+y)),3,c,,,,f
circle ((xb+x),(yb-y)),3,c,,,,f
circle ((xb-x),(yb+y)),3,c,,,,f
circle ((xb-x),(yb-y)),3,c,,,,f
Loop While y>0
End Sub
sub drawCircle()
dim as double r
dim as integer x,y,cx,cy
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then 'mouse has moved so draw erase old draw new
screenlock()
put (0,0),canvas1,trans 'restore screen
ellipse(ox,oy,mx,my,colors(sColor)) 'draw onto screen
if mirror = 1 then
ellipse(640-ox,oy,640-mx,my,colors(sColor))
end if
screenunlock()
update()
end if
wend
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
sub Rubber()
dim as double r
dim as integer x,y,cx,cy
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then 'mouse has moved so draw erase old draw new
line(ox,oy)-(ox+20,oy+20),rgb(255,255,254),bf 'erase box outline
line(mx,my)-(mx+20,my+20),rgb(255,255,254),bf
line(mx,my)-(mx+20,my+20),rgb(0,0,0),b 'draw box outline
ox = mx
oy = my
update()
end if
wend
line(ox,oy)-(ox+20,oy+20),rgb(255,255,254),bf 'erase box outline
put canvas2,(0,0),canvas1,pset 'canvas2 = canvas1
get (0,0)-(639,479),canvas1 'canvas1 = screen
end sub
sub save()
dim fileName As String
locate 20,10
get (0,0)-(639,479),canvas1 'save into canvas1
line (60,140)-(560,172),rgb(255,255,254),bf
line (60,140)-(560,172),rgb(1,1,1),b
Line Input "Enter picture name:", fileName
locate 26,10
print " ... SAVING"
bsave filename + ".bmp",canvas1
put (0,0),canvas1,pset 'copy to screen
update()
end sub
sub load()
dim fileName as string
locate 20,10
line (60,140)-(560,172),rgb(255,255,254),bf
line (60,140)-(560,172),rgb(1,1,1),b
line input "Enter picture name:",fileName
bload filename + ".bmp",canvas1
put (0,0),canvas1,pset 'copy to screen
update()
end sub
color rgb(0,0,0),rgb(255,255,254) 'black ink, white paper
cls 'executes the color change
update()
dim as string key
do
getmouse mx,my,,mb
ox = mx
oy = my
if mb = 1 then
'is it over drawing area?
if my>20 and my<480-20 then
if cmd = 0 then
drawPen()
end if
if cmd = 1 then
drawRectangle()
end if
if cmd = 2 then
drawCircle()
end if
if cmd = 3 then
drawLine()
end if
if cmd = 4 then
Fill()
end if
if cmd = 5 then
Rubber()
end if
end if
'is it over buttons
if my<20 then
btnID = mx\40
if btnID=1 then 'set rectangle mode
get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
locate 18,2
print "Release mouse button over fill or not fill icon to select mode"
update()
'drop down rectangle examples
for j as integer = 0 to 1
line (44,j*32+23)-(44+31,j*32+31+23),rgb(255,255,254),bf
line (44,j*32+23)-(44+31,j*32+31+23),rgb(1,1,1),b
line (52,31)-(52+16,31+16),rgb(1,1,1),b
line (52,63)-(52+16,63+16),rgb(1,1,1),bf
next j
while mb=1
getmouse mx,my,,mb
wend
'was it released over shape fill mode?
if mx>44 and mx<75 and my>25 and my<87 then
mode1 = (int(my-23)\32)
end if
put (0,0),canvas1,pset 'restore screen
update()
end if
if btnID=2 then 'set rectangle mode
get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
locate 18,2
print "Release mouse button over fill or not fill icon to select mode"
update()
'drop down ellipse examples
for j as integer = 0 to 1
line (84,j*32+25)-(84+31,j*32+31+25),rgb(255,255,254),bf
line (84,j*32+25)-(84+31,j*32+31+25),rgb(1,1,1),b
circle (99,40),10,rgb(1,1,1)
circle (99,73),10,rgb(1,1,1),,,,f
next j
while mb=1
getmouse mx,my,,mb
wend
'was it released over shape fill mode?
if mx>84 and mx<115 and my>25 and my<87 then
mode2 = (int(my-23)\32)
end if
put (0,0),canvas1,pset 'restore screen
update()
end if
if btnID<6 then
cmd = btnID
end if
if btnID=6 then
color rgb(1,1,1),rgb(255,255,254) 'black ink, white paper
line canvas1,(0,0)-(639,479),rgb(255,255,254),bf 'clear canvas1
cls
end if
if btnID=7 then
mirror = mirror+1
if mirror=2 then mirror = 0
end if
if btnID=8 then
put canvas1,(0,0),canvas2,pset 'get previous
put (0,0),canvas1,pset 'copy to screen
update()
end if
if btnID = 9 then
save()
update()
'btnID = mode 'reset button ID
end if
if btnID = 10 then
load()
update()
'btnID = mode 'reset button ID
end if
if btnID = 11 then 'pen size
get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
locate 8,2
print "Release mouse button over desired pen size"
update()
'drop down pen examples
for j as integer = 0 to 3
line (449,j*23+23)-(449+22,j*23+22+23),rgb(255,255,254),bf
line (449,j*23+23)-(449+22,j*23+22+23),rgb(1,1,1),b
circle (449+11,j*23+11+23),j*2+1,rgb(1,1,1),,,,f
next j
while mb=1
getmouse mx,my,,mb
wend
'was it released over pen size?
if mx>454 and mx<476 and my>23 and my<114 then
penSize = (int(my-23)\23)*2+1
end if
put (0,0),canvas1,pset 'restore screen
update()
end if
'wait for button release
while mb = 1
getmouse mx,my,,mb
wend
update()
end if
'is it over pallete?
if my>464 then
sColor = mx\16
while mb = 1
getmouse mx,my,,mb
wend
end if
update()
end if
loop until btnID = 15
imageDestroy(canvas1)
imageDestroy(canvas2)
'Custom colors
ColorData:
' === microsoft PAINT standard colors ===
data 0 ,0 , 0 'BLACK
data 127,127,127 'dark gray
data 195,195,195 'light gray
data 255,255,254 'WHITE
data 136, 0, 21 'red brown
data 185,122, 87 'brown
data 237, 28, 36 'red
data 255,174,201 'pink
data 255,127, 39 'orange
data 255,201, 14 'deep yellow gold
data 255,242, 0 'yellow
data 239,228,176 'light yellow
data 34,177, 76 'green
data 181,230, 29 'lime
data 0,162,232 'turquoise medium blue
data 153,217,234 'light blue
data 63, 72,204 'indigo dark blue
data 112,146,190 'blue gray
data 163, 73,164 'purple
data 200,191,231 'lavenda
'=====================================
data 255,128,128
data 255, 0, 0
data 128, 64, 64
data 128, 0, 0
data 255,255,128 'yellow
data 255,255, 0
data 255,128, 64 'orange
data 255,128, 0
data 128, 64, 0 'brown
data 128,128, 0
data 128,255,128 'green
data 128,255, 0
data 0,255, 0
data 0,128, 0
data 0, 64, 0
data 128,128, 64
data 0,255,128
data 0,255, 64
data 0,128,128
data 0,128, 64
data 0, 64, 64
data 128,128,128 'gray
data 128,255,255 'blue
data 0,255,255
data 0, 64,128
data 0, 0,255
data 0, 0,128
data 64,128,128
data 0,128,255
data 0,128,192
data 128,128,255
data 0, 0,160
data 0, 0, 64
data 192,192,192 'gray
data 255,128,192 'red
data 128,128,192
data 128, 0, 64
data 128, 0,128 'purple
data 64, 0, 64
data 64, 0,128 'black
data 255,128,255
data 255, 0,255
data 255, 0,128
data 128, 0,255
data 64, 0,128
data 255,255,254 'white