FreeBasic

Великолепный исходник программы для построения квадратичных и круговых диаграмм. Все построение вынесено в функции. Конечно же это может пригодиться в своих программах,  имеющих статистическую составляющую.

Платформы: Windows, Linux
Автор: Lothar Schirm

'Autor: Lothar Schirm
'made: 08.09.2007

Declare Sub OutText(x As Single, y As Single, Text As String, _
Ausrichtung As String)
Declare Sub Balkendiagramm(x() As String, y() As Single, n As Integer, _
ymin As Single, ymax As Single, ny As Integer, _
hor As String, vert As String, Text As String, _
Farbe As Integer)
Declare Sub Kreisdiagramm(x() As String, y() As Single, n As Integer, _
Text As String)


'------------------------ Kleines Beispielprogramm ----------------------------

Dim As String x(7)
Dim As Single y(7)
Dim As Integer i

Screen 0
Cls
Print "Testprogramm fuer Kreis- und Balkendiagramme"
Print
Print "Folgende Tabelle wird graphisch ausgewertet:"
Print
Print "Umsaetze 2000 - 2007"
Print "Jahr", "Mio EUR"
For i = 0 To 7
    x(i) = Str(2000 + i)
    y(i) = 30 + 50 * Rnd(i)
    Print x(i), y(i)
Next i
Print
Print "Weiter: Beliebige Taste"
Getkey

Screen 12
Color 0, 15
Cls

Balkendiagramm(x(), y(), 7, 0, 100, 10, "Jahr", "Mio EUR", _
"Umsaetze 2000 - 2007", 4)
Locate 29, 30
Print "Weiter: Beliebige Taste"
Getkey

Cls 0
Kreisdiagramm(x(), y(), 7, "Umsaetze 2000 - 2007")
Locate 29, 30
Print "Beenden: Beliebige Taste"
Getkey

'-------------------------------- Beispielprogramm Ende -----------------------


Sub OutText(x As Single, y As Single, Text As String, Ausrichtung As String)
    ' Gibt einen Text an pixelgenauen Koordinaten aus
    ' - x, y = (Sicht)koordinaten
    ' - Text = auszugebender Text
    ' - Ausrichtung = Position des Textes bezueglich (x, y):
    '   "l": linksbuendig (d.h. Text rechts von (x, y)
    '   "r": rechtsbuendig (d.h. Text links von (x, y)
    '   "z": zentriert.

    Dim As Integer xp, yp

    'Umwandlung in Pixelkoordinaten:
    xp = Pmap(x, 0)
    yp = Pmap(y, 1) - 8

    'Text plazieren:
    Select Case Lcase(Ausrichtung)
        Case "l": Draw String (xp, yp), Text
        Case "r": Draw String (xp - 8 * Len(Text), yp), Text
        Case "z": Draw String (xp - 8 * Len(Text) / 2, yp), Text
    End Select

End Sub


Sub Balkendiagramm(x() As String, y() As Single, n As Integer, ymin As Single, _
    ymax As Single, ny As Integer, hor As String, _
    vert As String, Text As String, Farbe As Integer)
    '- x(0) bis x(n) = Benennung der Balken
    '- y(0) bis y(n) = Wert der Balken
    '- n + 1         = Anzahl der Balken
    '- ymin, ymax    = Abmessung vertikale Achse (ymin muss <= 0 sein!)
    '- ny            = Anzahl der Achsenabschnitte auf der vertikalen Achse
    '- hor           = Beschriftung horizontale Achse
    '- vert          = Beschriftung vertikale Achse (max 13 Zeichen)
    '- Text          = Bildunterschrift
    '- Farbe         = Farbe

    Dim As Single Balkenpos(n), xmin, xmax, ay, y0, Breite
    Dim As Integer xlo, ylo, xru, yru, i

    View
    Window Screen

    'Pixelkoordinaten des Darstellungsfeldes: xlo = xlinksoben usw.
    xlo = 8 * 15  'Textspalte 15
    ylo = 16 * 2  'Textzeile 2
    xru = 8 * 75  'Textspalte 75
    yru = 16 * 22 'Textzeile 22

    'Beschriftung vertikale Achse:
    OutText(xlo, ylo, Str(ymax) + Space(1), "r")
    OutText(xlo, yru, Str(ymin) + Space(1), "r")
    OutText(xlo, (ylo + yru) / 2, vert + Space(1), "r")

    'Beschriftung horizontale Achse:
    For i = 0 To n
        OutText(xlo + (xru - xlo) * (i + 0.5) / (n + 1), yru + 16, Str(x(i)), "z")
    Next i
    OutText((xlo + xru) / 2, yru + 32, hor, "z")

    'Bildunterschrift:
    OutText((xlo + xru) / 2, yru + 48, Text, "z")

    'Fenster fuer Graphik in Sichtkoordinaten definieren:
    View (xlo, ylo)-(xru, yru)
    xmin = 0: xmax = 100
    Window (xmin, ymin)-(xmax, ymax)

    'Rahmen zeichnen:
    Line (xmin, ymin)-(0.995 * xmax, 0.995 * ymax), , B

    'Teilung vertikale Achse:
    ay = 0.995 * (ymax - ymin) / ny
    For i = 0 To ny
        y0 = ymin + i * ay
        Line (xmin, y0)-(xmax, y0)
    Next i

    'Balken zeichnen:
    Breite = 0.8 * (xmax - xmin) / (n + 1)
    For i = 0 To n
        Balkenpos(i) = xmin + (i + 0.1) * (xmax - xmin) / (n + 1)
        Line(Balkenpos(i), 0) - (Balkenpos(i) + Breite, y(i)), Farbe, BF
    Next i

End Sub


Sub Kreisdiagramm(x() As String, y() As Single, n As Integer, Text As String)
    '- x(0) bis x(n) = Bezeichnung der Kreissegmente
    '- y(0) bis y(n) = Wert der Kreissegmente
    '- n + 1         = Anzahl der Kreissegmente
    '- Text          = Bildunterschrift

    Dim As Single Alpha(n), r, sum, xp, yp, beta
    Dim As Integer i, x0, y0
    Const pi = 3.141593

    View
    Window Screen

    'Diagramm berechnen und segmentweise zeichnen (alpha(0) bis alpha(n) sind
    'die zu y(0) bis y(n) zugehoerigen Winkel im Kreis:
    x0 = 320
    y0 = 200
    r = 160
    sum = 0
    For i = 0 To n
        sum = sum + y(i)
    Next i
    Alpha(0) = 2 * pi * y(0) / sum
    For i = 1 To n
        Alpha(i) = 2 * pi * y(i) / sum + Alpha(i - 1)
    Next i

    Circle (x0, y0), r,, 0, -Alpha(0)
    For i = 1 To n
        Circle (x0, y0), r,, Alpha(i - 1), -Alpha(i)
    Next i

    'Diagramm-Segmente faerben und beschriften:
    For i = 0 To n
        If i = 0 Then beta = Alpha(0) / 2 Else beta = (Alpha(i) + Alpha(i - 1)) / 2
        xp = x0 + 0.5 * r * Cos(beta)
        yp = y0 - 0.5 * r * Sin(beta)
        Paint (xp, yp), i Mod 15, Loword(Color)
        xp = x0 + 1.1 * r * Cos(beta)
        yp = y0 - 1.1 * r * Sin(beta)
        If Alpha(i) > pi/2 And Alpha(i) < 3*pi/2 Then
            OutText(xp, yp, x(i) + ": " + Str(y(i)), "r")
        Else
            OutText(xp, yp, x(i) + ": " + Str(y(i)), "l")
        End If
    Next i

    'Bildunterschrift:
    Locate 25, (80 - Len(Text)) / 2
    Print Text

End Sub