Code: Select all
#Include once "fltk-c.bi"
'Declare Function Box_Event cdecl (me as any ptr, event as FL_EVENT) as Integer
Declare Sub Create_Window_Main ()
Declare Sub draw_lines Cdecl (widget As FL_Widget Ptr)
Declare Sub draw_circles Cdecl (widget As FL_Widget Ptr)
Declare Sub myfbgfxtofltkimg Cdecl (byval UserData as any ptr)
Declare Function calcd(cd1 as Double,cd2 as Double,cd3 as Double,cd4 as Double,cd5 as Double,cd6 as Double) as double
Declare Function myboxHandleCB cdecl (self as any ptr,event as Fl_Event) as integer
Declare Sub mymain()
Declare Sub drawlines
Declare Sub drawcircles
Declare Sub zoomin()
Declare Sub zoomout()
Declare Sub zoominpan()
Declare Sub zoomoutpan()
Declare Sub escapeme()
'Windows and widgets:
Dim Shared As Fl_Window Ptr win
Dim Shared As Fl_BoxEX Ptr box
Dim Shared As Fl_Button Ptr btn_draw_line
Dim Shared As Fl_Button Ptr btn_draw_circle
Dim Shared As Fl_Image Ptr img
'Dim Shared As Fl_EventNumber Ptr en
Dim Shared mywidth As Integer
Dim Shared myheight As Integer
Dim Shared As Integer myfltkimage_mouse_x, myfltkimage_mouse_y
Dim Shared As BOOLEAN mbp,mousebuttondown, mousebuttonup,myfltkimage_mouse_scroll_up,myfltkimage_mouse_scroll_down
Dim Shared As Integer mswp
Dim Shared As BOOLEAN drawingline=FALSE, drawingcircle=FALSE
Dim Shared As Integer linec,circlec
Dim Shared As Double lines(100,4), circles(100,3)
Dim Shared As String drawing_entity
drawing_entity="line"
Dim Shared As Integer mouse_clicks
Dim Shared As Integer wx1,wy1,wx2,wy2,wzoom,wzoomt,maxzoomin,maxzoomout
mywidth=580
myheight=580
'ScreenRes mywidth,myheight,,,fb.GFX_NULL
wx1=0
wy1=0
wx2=mywidth-1
wy2=myheight-1
wzoomt=10
maxzoomin=10
maxzoomout=10000
Dim Shared As Integer w,h,pitch_src
Dim Shared As Integer bytes_img=3 ' RGB
ScreenRes mywidth,myheight,,,-1
ScreenInfo w,h,,,pitch_src
Dim Shared As Integer pitch_img
pitch_img=w*bytes_img
Dim Shared As UByte Ptr rgb_img
rgb_img=allocate(h*pitch_img)
window (wx1,wy1)-(wx2,wy2)
Create_Window_Main ()
Fl_WidgetSetCallback0 btn_draw_line, @draw_lines
Fl_WidgetSetCallback0 btn_draw_circle, @draw_circles
Fl_BoxExSetHandleCB box,@myboxHandleCB
Fl_AddIdle @mymain, box
Fl_WindowShow(win)
Fl_Run
DeAllocate rgb_img
End
Sub draw_lines Cdecl (widget As FL_Widget Ptr)
drawing_entity="line"
End Sub
Sub draw_circles Cdecl (widget As FL_Widget Ptr)
drawing_entity="circle"
End Sub
Sub Create_Window_Main ()
win = Fl_WindowNew (800, 600, "my_fbgfx_to_fltk_image_test-5")
box = Fl_BoxExNew(120, 0, 580, 580)
btn_draw_line = Fl_ButtonNew (10, 10, 100, 20, "Draw lines")
btn_draw_circle = Fl_ButtonNew (10, 40, 100, 20, "Draw circles")
End Sub
function myboxHandleCB cdecl (self as any ptr,event as Fl_Event) as integer
Select Case event
Case 1 'mouse button pressed
'Print "push"
Select Case Fl_EventButton
Case 1
mousebuttondown=TRUE
Case 2
'middle button
Case 3
escapeme
End Select
Case 11 'mouse moved
'Print "move"
'Print Fl_EventX();" ";Fl_EventY()
myfltkimage_mouse_x=Fl_EventX()-Fl_WidgetGetX(box)
myfltkimage_mouse_y=Fl_EventY()'-Fl_WidgetGetY(box)
'change the mousey to increase from bottom up
myfltkimage_mouse_y=579-myfltkimage_mouse_y
myfltkimage_mouse_x=wx1+(wx2-wx1)*(myfltkimage_mouse_x/(580))
myfltkimage_mouse_y=wy1+(wy2-wy1)*(myfltkimage_mouse_y/(580))
Case 19 'mouse scrollwheel
'Print "mousewheel"
Select Case Fl_EventDY()
Case Is > 0
'zoom out
myfltkimage_mouse_scroll_up=TRUE
Case Is < 0
'zoom in
myfltkimage_mouse_scroll_down=TRUE
End Select
End Select
Return 1
End Function
Function calcd(cd1 as Double,cd2 As Double,cd3 as Double,cd4 as Double,cd5 as Double,cd6 as Double) as double
calcd = sqr((cd1-cd4)^2 + (cd2-cd5)^2 + (cd3-cd6)^2)
end function
Sub mymain()
Sleep 50
ScreenLock
Cls
If mousebuttondown=TRUE Then
mousebuttondown=FALSE
mouse_clicks+=1
EndIf
Select Case mouse_clicks
Case 1
Select Case drawing_entity
Case "line"
If drawingline=FALSE Then
drawingline=TRUE
linec=linec+1
lines(linec,1)=myfltkimage_mouse_x
lines(linec,2)=myfltkimage_mouse_y
EndIf
Case "circle"
If drawingcircle=FALSE Then
drawingcircle=TRUE
circlec=circlec+1
circles(circlec,1)=myfltkimage_mouse_x
circles(circlec,2)=myfltkimage_mouse_y
EndIf
End Select
Case 2
Select Case drawing_entity
Case "line"
If drawingline=TRUE Then
drawingline=FALSE
mouse_clicks=0
lines(linec,3)=myfltkimage_mouse_x
lines(linec,4)=myfltkimage_mouse_y
EndIf
Case "circle"
If drawingcircle=TRUE Then
drawingcircle=FALSE
mouse_clicks=0
Dim r As Double
r=calcd( circles(circlec,1) , circles(circlec,2) ,0, CDbl(myfltkimage_mouse_x), CDbl(myfltkimage_mouse_y),0)
circles(circlec,3)=r
EndIf
End Select
End Select
If drawingline=TRUE Then Line(lines(linec,1),lines(linec,2))-(myfltkimage_mouse_x,myfltkimage_mouse_y)
If drawingcircle=TRUE Then
Dim r As Double
r=calcd( circles(circlec,1) , circles(circlec,2) ,0, CDbl(myfltkimage_mouse_x), CDbl(myfltkimage_mouse_y),0)
Circle( circles(circlec,1),circles(circlec,2) ),r
EndIf
If myfltkimage_mouse_scroll_up=TRUE Then
myfltkimage_mouse_scroll_up=FALSE
'"Scroll up - zoom out"
zoomoutpan
window (wx1,wy1)-(wx2,wy2)
EndIf
If myfltkimage_mouse_scroll_down=TRUE Then
myfltkimage_mouse_scroll_down=FALSE
'"Scroll down - zoom in"
zoominpan
window (wx1,wy1)-(wx2,wy2)
EndIf
drawlines
drawcircles
myfbgfxtofltkimg(box)
ScreenUnLock
End Sub
Sub escapeme()
mouse_clicks=0
If drawingline=TRUE Then
drawingline=FALSE
linec=linec-1
EndIf
If drawingcircle=TRUE Then
drawingcircle=FALSE
circlec-=1
EndIf
End Sub
Sub zoomin()
If wx2-wx1<maxzoomin Then Exit Sub
wzoom=(wx2-wx1)/wzoomt
wx1=wx1+wzoom
wy1=wy1+wzoom
wx2=wx2-wzoom
wy2=wy2-wzoom
End Sub
Sub zoomout()
wzoom=(wx2-wx1)/wzoomt
wx1=wx1-wzoom
wy1=wy1-wzoom
wx2=wx2+wzoom
wy2=wy2+wzoom
End Sub
Sub zoominpan()
If wx2-wx1<maxzoomin Then Exit Sub
Dim As Double panxf,panyf,panx,pany
panxf=(myfltkimage_mouse_x-wx1)/(wx2-wx1)
panyf=(myfltkimage_mouse_y-wy1)/(wy2-wy1)
wx1=wx1+wzoom
wy1=wy1+wzoom
wx2=wx2-wzoom
wy2=wy2-wzoom
panx=wx1+int((wx2-wx1)*panxf)
pany=wy1+Int((wy2-wy1)*panyf)
wx1=wx1+(myfltkimage_mouse_x-panx)
wx2=wx2+(myfltkimage_mouse_x-panx)
wy1=wy1+(myfltkimage_mouse_y-pany)
wy2=wy2+(myfltkimage_mouse_y-pany)
wzoom=(wx2-wx1)/wzoomt
If wzoom<1 Then wzoom=1
End Sub
Sub zoomoutpan()
Dim As Double panxf,panyf,panx,pany
panxf=(myfltkimage_mouse_x-wx1)/(wx2-wx1)
panyf=(myfltkimage_mouse_y-wy1)/(wy2-wy1)
wx1=wx1-wzoom
wy1=wy1-wzoom
wx2=wx2+wzoom
wy2=wy2+wzoom
panx=wx1+((wx2-wx1)*panxf)
pany=wy1+((wy2-wy1)*panyf)
wx1=wx1+(myfltkimage_mouse_x-panx)
wx2=wx2+(myfltkimage_mouse_x-panx)
wy1=wy1+(myfltkimage_mouse_y-pany)
wy2=wy2+(myfltkimage_mouse_y-pany)
wzoom=(wx2-wx1)/wzoomt
End Sub
Sub drawlines
Dim As Integer i
For i = 1 To linec
If i=linec Then
If drawingline=TRUE Then Exit For
EndIf
Line(lines(i,1),lines(i,2))-(lines(i,3),lines(i,4))
Next
End Sub
Sub drawcircles
Dim As Integer i
For i = 1 To circlec
If i=circlec Then
If drawingcircle=TRUE Then Exit For
EndIf
circle(circles(i,1),circles(i,2)),circles(i,3)
Next
End Sub
Sub button_draw_line()
escapeme
drawing_entity="line"
End Sub
Sub button_draw_circle()
escapeme
drawing_entity="circle"
End Sub
Sub myfbgfxtofltkimg Cdecl (byval UserData as any ptr)
Dim As Integer i,x,y
Dim as ubyte ptr rs=screenptr() ' row source
Dim as ubyte ptr ri=rgb_img ' row image
Dim as ulong r,g,b
For y = 0 to h-1
i=0
For x = 0 to w-1
Palette get rs[x],r,g,b
ri[i+0]=r: ri[i+1]=g : ri[i+2]=b : i+=3
Next
rs+=pitch_src
ri+=pitch_img
Next
Fl_ImageDelete img
img = Fl_RGB_ImageNew(rgb_img,w,h,bytes_img,pitch_img)
Fl_WidgetSetImage box,img
Fl_WidgetRedraw box
End Sub