forum.boolean.name - Диаграммы

Понадобилось тут оперативно выводить диаграммы для отладочки.
Код:
;created by impersonalis (icq: 11-999-51-51)



Const i2DSegment_FillingPointDir%=4



Function iDiagram2DSegmentMaskCreate%(R#,a1#,a2#,AlphaColorR%,AlphaColorG%,AlphaColorB%,BettaColorR%,BettaColorG%,BettaColorB%)

        ;создаёт двуцветное изображение (если наложить его на квадрат, получим вписанный сегмент):

        ;Alpha                цвет НЕ маски

        ;Betta                цвет маски

        ;----

        ;R#                        радиус сегмента

        ;a1#,a2#                углы раствора сегмента (a2>a1)

        Local AntiA#=a2+(360-Abs(a2-a1))*0.5

        Local TFP.TFillingPoint

        Local tTFP.TFillingPoint

        Local CurBuff%=GraphicsBuffer()

        Local Mask%=CreateImage(R*2,R*2)

        Local ColorKey%

        Local DX%[i2DSegment_FillingPointDir]

        Local DY%[i2DSegment_FillingPointDir]

        Local NewColorKey%=(0 Shl 24) Or (AlphaColorR Shl 16) Or (AlphaColorG Shl 8) Or AlphaColorB

        DX[0]=-1:DX[1]=1:DX[2]=0:DX[3]=0

        DY[0]=0:DY[1]=0:DY[2]=-1:DY[3]=1

        SetBuffer ImageBuffer(Mask)

        Color AlphaColorR,AlphaColorG,AlphaColorB

        Rect 0,0,2*R,2*R

        Color BettaColorR,BettaColorG,BettaColorB

        Oval 0,0,2*R,2*R

        Color AlphaColorR,AlphaColorG,AlphaColorB

        Line R,R,R+R*Cos(a1),R-R*Sin(a1)

        Line R,R,R+R*Cos(a2),R-R*Sin(a2)        

        Delete Each TFillingPoint

        TFP=New TFillingPoint

        TFP\x=R+0.5*R*Cos(AntiA)

        TFP\y=R-0.5*R*Sin(AntiA)

        LockBuffer (ImageBuffer(Mask))

        ColorKey=ReadPixel(TFP\x,TFP\y)

        While (Last TFillingPoint)<>Null

                tTFP=Last TFillingPoint

                If ReadPixel(tTFP\x,tTFP\y)=ColorKey

                        WritePixel(tTFP\x,tTFP\y,NewColorKey)

                        For I=0 To i2DSegment_FillingPointDir-1

                                TFP=New TFillingPoint

                                TFP\x=tTFP\x+DX[i]

                                TFP\y=tTFP\y+DY[i]

                        Next

                EndIf

                Delete tTFP

        Wend

        UnlockBuffer (ImageBuffer(Mask))

        SetBuffer CurBuff

        MidHandle Mask

        MaskImage Mask,BettaColorR,BettaColorG,BettaColorB

        Return Mask

End Function



Type  TFillingPoint

        Field x%

        Field y%

End Type



Function iDiagram2DSegmentCreate%(R#,a1#,a2#,image%,MASKr%,MASKg%,MASKb%)

        ;создаёт имагу-сектор из текстуры*

        ;R#                                                                радиус

        ;a1#,a2#                                                        углы

        ;image%                                                        текстура*

        ;MASKr%,MASKg%,MASKb%                цвет маски

        Local AX%,AY%,D%

        AX=ImageWidth(image)*0.5-R

        AY=ImageHeight(image)*0.5-R

        D=2*R

        

        Local IMG%=CreateImage(D,D)

        MaskImage IMG,MASKr,MASKg,MASKb

        Local CurBuff%=GraphicsBuffer()

        Local AnotherColorR%=(MASKr Xor $FFFFFFFF) And $000000FF

        Local AnotherColorG%=(MASKg Xor $FFFFFFFF) And $000000FF

        Local AnotherColorB%=(MASKb Xor $FFFFFFFF) And $000000FF

        Local Mask%=iDiagram2DSegmentMaskCreate%(R,a1,a2,MASKr,MASKg,MASKb,AnotherColorR,AnotherColorG,AnotherColorB)

        

        SetBuffer ImageBuffer(IMG)

        CopyRect AX,AY,D,D,0,0,ImageBuffer(image)

        DrawImage Mask,R,R

        SetBuffer CurBuff

        

        FreeImage Mask

        Return IMG

End Function



Dim iDiagram2D_ANG#(0)

Dim iDiagram2D_IMG%(0)

Dim iDiagram2D_LEG$(0)

Global iDiagram2D_Count%



Function iDiagram2DCreate%(R#,strt_a#,MASKr%,MASKg%,MASKb%,Sr%,Sg%,Sb%)

        ;R#                                                                радиус диаграммы

        ;strt_a#                                                        угол, от которого строится диаграмма (угол поворота)

        ;MASKr%,MASKg%,MASKb%                цвет маски

        ;Sr%,Sg%,Sb%                                        цвет контрастных линий, разделяющих сегменты и обрамляющих диаграмму

        Local CurBuff%=GraphicsBuffer()

        Local a#=strt_a

        Local segm%

        Local ResultIMG%=CreateImage(2*R,2*R)

        SetBuffer ImageBuffer(ResultIMG)

        Color MASKr,MASKg,MASKb

        Rect 0,0,2*R,2*R

        SetBuffer CurBuff

        For i=0 To iDiagram2D_Count-1

                segm%=iDiagram2DSegmentCreate%(R,a,a+iDiagram2D_ANG(i),iDiagram2D_IMG(i),MASKr,MASKg,MASKb)

                MaskImage segm,MASKr,MASKg,MASKb

                SetBuffer ImageBuffer(ResultIMG)

                DrawImage segm,0,0



                Color Sr,Sg,Sb

                Line R,R,R+R*Cos(a),R-R*Sin(a)

                Line R,R,R+R*Cos(a+iDiagram2D_ANG(i)),R-R*Sin(a+iDiagram2D_ANG(i))



                SetBuffer CurBuff

                FreeImage segm

                a=a+iDiagram2D_ANG(i)

        Next

        SetBuffer ImageBuffer(ResultIMG)

        Color Sr,Sg,Sb

        Oval 0,0,2*R,2*R,False 

        SetBuffer CurBuff

        MaskImage ResultIMG,MASKr,MASKg,MASKb

        Return ResultIMG

End Function





Function iHistogram2DCreate%(xs%,ys%,BCr%,BCg%,BCb%,Sep%,Sr%,Sg%,Sb%)

        ;xs%,ys%                                размеры области, занимаемой гистограммой

        ;BCr%,BCg%,BCb%                цвет фона

        ;Sep%                                        обрамлять столбцы

        ;Sr%,Sg%,Sb%                        цвет обрамления

        Local max#=iDiagram2D_ANG(0)

        For i=1 To iDiagram2D_Count-1

                If max<iDiagram2D_ANG(i)

                        max=iDiagram2D_ANG(i)

                EndIf

        Next

        ;=

        Local YK#=ys/max

        Local dX#=xs/iDiagram2D_Count

        Local CurBuff%=GraphicsBuffer()

        Local ResultIMG%=CreateImage(xs,ys)

        SetBuffer ImageBuffer(ResultIMG)

        Color BCr,BCg,BCb

        Rect 0,0,xs,ys

        For i=0 To iDiagram2D_Count-1

                Local x#=i*dX

                Local y#=ys-YK*iDiagram2D_ANG(i)

                CopyRect(0,0,dX,YK*iDiagram2D_ANG(i),x,y,ImageBuffer(iDiagram2D_IMG(i)))

                If Sep

                        Color Sr,Sg,Sb

                        Rect x,y,dX,YK*iDiagram2D_ANG(i),False

                EndIf

        Next

        SetBuffer CurBuff

        MaskImage ResultIMG,BCr,BCg,BCb

        Return ResultIMG

End Function



Function iGramLegendCreate%(BCr%,BCg%,BCb%,TCr%,TCg%,TCb%,Sep%,Sr%,Sg%,Sb%)

        ;BCr%,BCg%,BCb%                цвет фона

        ;TCr%,TCg%,TCb%                цвет текста

        ;Sep%                                        обрамлять

        ;Sr%,Sg%,Sb%                        цвет обрмления

        Local SHIFT1%=StringWidth(" ")

        Local D%=FontHeight()

        Local YS%=D*iDiagram2D_Count

        Local XS%=StringWidth(iDiagram2D_LEG(0)+Str(iDiagram2D_ANG(0)))

        For i=1 To iDiagram2D_Count-1

                If XS<StringWidth(iDiagram2D_LEG(i)+Str(iDiagram2D_ANG(i)))

                        XS=StringWidth(iDiagram2D_LEG(i)+Str(iDiagram2D_ANG(i)))

                EndIf

        Next

        XS=XS+D+SHIFT1*2

        Local CurBuff%=GraphicsBuffer()

        Local ResultIMG%=CreateImage(XS,YS)

        SetBuffer ImageBuffer(ResultIMG)

        Color BCr,BCg,BCb

        Rect 0,0,XS,YS

        For i=0 To iDiagram2D_Count-1

                Local x#=0

                Local y#=i*D

                CopyRect(0,0,D,D,x,y,ImageBuffer(iDiagram2D_IMG(i)))

                Color TCr,TCg,TCb

                Text x+D,y," "+Str(iDiagram2D_ANG(i))+" "+iDiagram2D_LEG(i)

                If Sep

                        Color Sr,Sg,Sb

                        Rect x,y,D,D,False

                EndIf

        Next

        SetBuffer CurBuff

        Return ResultIMG

End Function



Function iGramMonoTexCreate%(xs%,ys%,ind%)

        ;xs%,ys%                размеры текстуры

        ;ind%                        номер текстуры 1..14

        Local CurBuff%=GraphicsBuffer()

        Local ResultIMG%=CreateImage(xs,ys)

        SetBuffer ImageBuffer(ResultIMG)

        Local A%,B%

        If ind>7

                ind=ind-7

                A=150

                B=255

        Else

                A=255

                B=0

        EndIf

        Color A,A,A

        Rect 0,0,xs,ys

        Color B,B,B

        Select ind

                Case 1

                        ;=

                Case 2

                        For i=0 To xs Step 5;p

                                Line i,0,i,ys

                        Next

                Case 3

                        For i=0 To ys Step 5;p

                                Line 0,i,xs,i

                        Next

                Case 4

                        For i=0 To xs*2 Step 10;p*2

                                Line 0+i,ys,-ys+i,0

                        Next

                Case 5

                        For i=0 To xs*2 Step 10;p*2

                                Line xs-i,ys,xs+ys-i,0

                        Next

                Case 6

                        For i=0 To xs*2 Step 20;p*2*2

                                Line xs-i,ys,xs+ys-i,0

                                Line 0+i,ys,-ys+i,0

                        Next

                Case 7

                        For i=0 To xs Step 10;p*2

                                Line i,0,i,ys

                                Line 0,i,xs,i

                        Next

                Default

                ;=

        End Select

        SetBuffer CurBuff

        Return ResultIMG

End Function

;===demo code=======================

Graphics 800,600,32,2

SetBuffer BackBuffer()

SetFont LoadFont("Arial",20)





iDiagram2D_Count=14

Dim iDiagram2D_ANG(iDiagram2D_Count-1)

Dim iDiagram2D_IMG(iDiagram2D_Count-1)

Dim iDiagram2D_LEG(iDiagram2D_Count-1)



Local total%=0

Local pp#=360/Float(iDiagram2D_Count)

For i=0 To iDiagram2D_Count-1

        iDiagram2D_IMG(i)=iGramMonoTexCreate(200,200,i+1)

        iDiagram2D_ANG(i)=Rand(pp*0.5,pp)

        iDiagram2D_LEG(i)=Chr(Rand(65,90))+Chr(Rand(97,122))+Chr(Rand(97,122))

        total=total+iDiagram2D_ANG(i)

Next

iDiagram2D_ANG(iDiagram2D_Count-1)=360-(total-iDiagram2D_ANG(iDiagram2D_Count-1))



Local LEGEND%=iGramLegendCreate%(255,255,255,0,0,0,True,0,0,0)

Local HIST%=iHistogram2DCreate%(200,200,255,0,255,1,255,0,0)

Local DIAGR=iDiagram2DCreate(100,Rand(0,369),255,0,255,0,0,0)









ClsColor 200,200,0

Cls



DrawBlock LEGEND,10,10

DrawImage HIST,10+ImageWidth(LEGEND)+10,10

DrawImage DIAGR,10+ImageWidth(LEGEND)+10,10+ImageHeight(HIST)+10



Flip

WaitKey()

End
iGramMonoTexCreate - создаёт семл простой текстуры, для использования в диаграммах. В коллекции 14 семплов, удобных для вывода на печать ч\б принтером - привет офисная отчётность!
iGramLegendCreate - создаёт картинку-легенду к диаграмме
iHistogram2DCreate - создаёт столбчатую диаграмму
iDiagram2DCreate - создаёт круговую диаграмму
iDiagram2DSegmentCreate - создаёт текстурированный сегмент круговой диаграммы
iDiagram2DSegmentMaskCreate - создаёт маску сегмента. И да - для заливки рекурсия не нужна.

Разумеется, можно использовать в качестве текстур свои image == )
При использовании - указать имя автора в about == )