Dim As Double d, r dim as Double ySin, yCos dim as Double sinRot = sin(angle) Dim as Double cosRot = cos(angle)
dim as ulong ptr imgSurPtr Dim As Integer i, j, w, h, w2, h2, pix, defaultColour = RGB( 255, 0, 255) ImageInfo imgSur, w, h, , ,imgSurPtr d = lenght(0,0, w,h ): w2 = w /2 : h2 = h /2
imgOut = ImageCreate ( d, d, RGB( 255,0,255)) dim as ulong ptr imgOutPtr Dim As Integer wo, ho ImageInfo imgOut, wo, ho, , ,imgOutPtr
r = d /2
For j = 0 To d - 1 ySin = (j - r ) * sinRot yCos = (j - r ) * cosRot For i = 0 To d - 1
Var xsrc = int((i - r ) * cosRot - ySin + w2 + 0.5 ) Var ysrc = int((i - r ) * sinRot + yCos + h2 + 0.5 )
if (xsrc >= 0) and (xsrc < w) and (ysrc >= 0) and (ysrc < h) Then pix = imgSurPtr[ysrc * w + xsrc] Else pix = defaultColour EndIf If pix <> RGB(255,0,255) Then PSet imgOut, (i, j),pix Next Next
'Line imgOut,(0,0) - (d-1,d-1), &Hcccccc, B
End Scope
Return imgOut End Function
Sub RotatImage ( _ ByRef imgSur As Any Ptr, _ angle As Double = 0 _ )
Dim As Double d, r dim as Double ySin, yCos dim as Double sinRot = sin(angle) Dim as Double cosRot = cos(angle)
dim as ulong ptr imgSurPtr Dim As Integer i, j, w, h, w2, h2, pix, defaultColour = RGB( 255, 0, 255) ImageInfo imgSur, w, h, , ,imgSurPtr d = lenght(0,0, w,h ): w2 = w /2 : h2 = h /2
imgOut = ImageCreate ( d, d, RGB( 255,0,255)) dim as ulong ptr imgOutPtr Dim As Integer wo, ho ImageInfo imgOut, wo, ho, , ,imgOutPtr
r = d /2
For j = 0 To d - 1 ySin = (j - r ) * sinRot yCos = (j - r ) * cosRot For i = 0 To d - 1
Var xsrc = int((i - r ) * cosRot - ySin + w2 + 0.5 ) Var ysrc = int((i - r ) * sinRot + yCos + h2 + 0.5 )
if (xsrc >= 0) and (xsrc < w) and (ysrc >= 0) and (ysrc < h) Then pix = imgSurPtr[ysrc * w + xsrc] Else pix = defaultColour EndIf If pix <> RGB(255,0,255) Then PSet imgOut, (i, j),pix Next Next
imgSur = imgOut
End Scope End Sub
function Scale_Image ( _ imgSur As Any Ptr, _ scale_x As Double = 1.0, _ scale_y As Double = 1.0 _ ) As Any Ptr
If imgSur = 0 And scale_x > 0 And scale_y > 0 Then Exit Function
Dim As Any Ptr imgOut
Scope #undef onscreen #define onscreen(xx,yy,xres,yres) xx >= 0 and xx < xres and yy >= 0 and yy < yres
Dim As Integer i,j, scx, scy Dim imgSurPtr As ULong Ptr, w As Integer, h As Integer ImageInfo imgSur, w, h, , , imgSurPtr
imgOut = ImageCreate ( Int(w * scale_x), Int(h * scale_y)) Dim imgOutPtr As ULong Ptr, wo As Integer, ho As Integer ImageInfo imgOut, wo, ho, , , imgOutPtr
For j = 0 To h For i = 0 To w scx = Int( i * scale_x ) scy = Int( j * scale_y ) If onscreen( scx, scy, wo, ho) Then Line imgOut,( scx, scy) - ( scx + scale_x * 2, scy + scale_y * 2), imgSurPtr[ j * w + i], BF EndIf Next Next
'Line imgOut,( 0, 0) - ( wo-1, ho-1), &Hcccccc, B
End Scope Return imgOut End Function
Sub ScaleImage ( _ imgSur As Any Ptr, _ x As Double, _ y As Double, _ scale_x As Double = 1.0, _ scale_y As Double = 1.0 _ )
If imgSur = 0 And scale_x > 0 And scale_y > 0 Then Exit sub
Dim As Any Ptr imgOut
Scope #undef onscreen #define onscreen(xx,yy,xres,yres) xx >= 0 and xx < xres and yy >= 0 and yy < yres
Dim As Integer i,j, scx, scy, WS, hs Dim imgSurPtr As ULong Ptr, w As Integer, h As Integer ImageInfo imgSur, w, h, , , imgSurPtr
WS = Int(w * scale_x) hs = Int(h * scale_y) imgOut = ImageCreate ( ws, hs) Dim imgOutPtr As ULong Ptr, wo As Integer, ho As Integer ImageInfo imgOut, wo, ho, , , imgOutPtr
For j = 0 To h For i = 0 To w scx = Int( i * scale_x ) scy = Int( j * scale_y ) If onscreen( scx, scy, wo, ho) Then Line imgOut,( scx, scy) - ( scx + scale_x * 2, scy + scale_y * 2), imgSurPtr[ j * w + i], BF EndIf Next Next
Put ( x - WS / 2, y - hs / 2), imgOut, Trans
End Scope End Sub
Sub ScalImage ( _ ByRef imgSur As Any Ptr, _ scale_x As Double = 1.0, _ scale_y As Double = 1.0 _ )
If imgSur = 0 And scale_x > 0 And scale_y > 0 Then Exit sub
Dim As Any Ptr imgOut
Scope #undef onscreen #define onscreen(xx,yy,xres,yres) xx >= 0 and xx < xres and yy >= 0 and yy < yres
Dim As Integer i,j, scx, scy, WS, hs Dim imgSurPtr As ULong Ptr, w As Integer, h As Integer ImageInfo imgSur, w, h, , , imgSurPtr
WS = Int(w * scale_x) hs = Int(h * scale_y) imgOut = ImageCreate ( ws, hs) Dim imgOutPtr As ULong Ptr, wo As Integer, ho As Integer ImageInfo imgOut, wo, ho, , , imgOutPtr
For j = 0 To h For i = 0 To w scx = Int( i * scale_x ) scy = Int( j * scale_y ) If onscreen( scx, scy, wo, ho) Then Line imgOut,( scx, scy) - ( scx + scale_x * 2, scy + scale_y * 2), imgSurPtr[ j * w + i], BF EndIf Next Next
imgSur = imgOut
End Scope End Sub
Sub RotaZoomImage OverLoad( _ imgSur As Any Ptr, _ x As Double, _ y As Double, _ angle As Double = 0, _ scale_x As Double = 1.0, _ scale_y As Double = 1.0 _ )
If imgSur = 0 Then Exit Sub
Dim As Any Ptr imgOut = Scale_Image( imgSur, scale_x, scale_y) imgOut = Rotate_Image( imgOut, angle)
Dim As Integer w, h, WS, hs ImageInfo imgOut, w, h
x -= w / 2 y -= h / 2
Put ( x - WS , y - hs ), imgOut,Trans End Sub
Sub RotaZoomImage OverLoad( _ imgTarget As Any Ptr, _ imgSur As Any Ptr, _ x As Double, _ y As Double, _ angle As Double = 0, _ scale_x As Double = 1.0, _ scale_y As Double = 1.0 _ )
If imgSur = 0 Or imgTarget = 0 Then Exit Sub
Dim As Any Ptr imgOut = Scale_Image( imgSur, scale_x, scale_y) imgOut = Rotate_Image( imgOut, angle)
Dim As Integer w, h, WS, hs ImageInfo imgOut, w, h
x -= w / 2 y -= h / 2
Put imgTarget, ( x - WS , y - hs ), imgOut,Trans End Sub
#Ifdef __FB_MAIN__ ' #include "fbgfx.bi" Using FB '' Êîíñòàíòû ñêàíêîäîâ õðàíÿòñÿ â ïðîñòðàíñòâå èìåí FB â lang FB
Dim Shared As Integer scrx, scry ScreenControl GET_DESKTOP_SIZE, scrx, scry screenres scrx, scry, 32, 2 Color 0, RGB( 120,136,178) ScreenSet 1, 0
Dim As Any Ptr rimg Dim As Any Ptr _ img = imagecreate( 120, 60, RGB( 105,0,255)) Circle img,(10, 20),20, &HccFF33,,,,F Circle img,(60, 40),40, RGB( 255,0,255),,,,F Circle img,(60, 30),15, &H006600,,,,F Circle img,(90, 50),15, &H000066,,,,F
Dim As Any Ptr scr = imagecreate( 200, 200, &H333333)
Dim As Integer mx, my, mz, mb, mc, res Dim As Integer x = scrx / 2, y = scry / 2 Dim As Double angle = 0, scale = 1, asp = 0.02
Do
res = GetMouse ( mx, my, mz, mb, mc )
If multikey(&h4D) then asp += .02 'right KEY If multikey(&h4B) then asp -= .02 'left KEY If multikey(&h50) Then scale -= .1 'down KEY If multikey(&H48) then scale += .1 'up KEY 'If multikey(SC_PAGEUP) then scale += .1 'up KEY 'If multikey(SC_PAGEDOWN) then scale -= .1 'up KEY angle += asp
ScreenUnlock() Sleep 25 Flip Loop Until multikey(&H01) Or InKey = Chr(255)+"k" Or InKey = Chr(27) 'loop until ESC key pressed While Inkey <> "": Wend End #EndIf