Simple Paint Program
Простейшая программная реализация редактора графики. Мне очень понравилось, как автор построил код этой программы. Все сделано средствами встроенной библиотеки FbGFX.
Платформы: Windows, Linux
Автор: BasicCoder2
#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
