Draw a Pythagoras Tree with Microsoft PowerPoint (VBA)

Abstract

This article describes how to draw a Pythagoras Tree in Microsoft PowerPoint using Visual Basic for Applications (VBA).

Motivation

A Pythagoras Tree is a simple yet beautiful fractal named after the ancient Greek mathematician Pythagoras. The consulity company logo contains parts of this fractal and therefore VBA and PowerPoint was given a try to paint this fractal. The PowerPoint VBA API offers a function to draw a line wich is practically all it takes to draw the tree.

Objective

Draw a Pythagoras Tree with PowerPoint VBA for a given depth.

Setup

In VBA some Types, Constants and helping procedures, e.g. paintAngleFromPoint, paintTriangle, paintSquare were built. With paintAngleFromPoint, one can draw almost anything. Of course one could have used existing shapes of PowerPoint, i.e. squares and triangles to paint the tree, but the function to draw the line (actually a vector) is considered the more versatile option.

Results

11 Iterations

15 Iterations

Source Code

Option Explicit

 

Type Point

    X As Double

    Y As Double

End Type

 

Type Triangle

    ptA As Point

    ptB As Point

    ptC As Point

    AC As Double

    AD As Double

    BC As Double

    BD As Double

    CD As Double

    Alpha As Double

    Beta As Double

End Type

 

Type Square

    ptA As Point

    ptB As Point

End Type

 

Type PythagoreanTree

    tBase As Triangle

    sLeft As Square

    sRight As Square

End Type

 

Public Const Pi As Double = 3.14159265358979

Public Const Pi180 As Double = 0.0174532925199433

 

Function GM() As Double

    GM = (Sqr(5) - 1) / 2

End Function

 

Function ARCSIN(ByVal dblSinus As Double) As Double

    ARCSIN = Atn(dblSinus / Sqr(-dblSinus * dblSinus + 1)) / Pi180

End Function

 

Function ARCCOS(ByVal dblCosinus As Double) As Double

    ARCCOS = (Atn(-dblCosinus / Sqr(-dblCosinus * dblCosinus + 1)) + 2 * Atn(1)) / Pi180

End Function

 

Function paintAngleFromPoint(ptStart As Point, ByVal angle As Double,

                             Radius As Double, Optional Color As Long) As Point

 

    Dim SinL As Double

    Dim CosL As Double

 

    angle = angle * Pi180

 

    SinL = Sin(angle) * Radius

    CosL = Cos(angle) * Radius

 

    ActiveWindow.Selection.SlideRange.Shapes.AddLine(ptStart.X, ptStart.Y, ptStart.X + SinL, ptStart.Y - CosL).Select

    ActiveWindow.Selection.ShapeRange.Line.ForeColor.RGB = Color

 

    paintAngleFromPoint.X = ptStart.X + SinL

    paintAngleFromPoint.Y = ptStart.Y - CosL

 

End Function

 

Function paintTriangle(ptStart As Point, ByVal angle As Double, Radius As Double) As Triangle

 

    ' computation of lengths (pythagorean theorem)

    'k = Sqr((np.Y - p.Y) ^ 2 + (l * gm) ^ 2)

 

    'Const LNGCOLOR As Long = 16711680

    Dim LNGCOLOR As Long

    Dim colorPalette As Variant

    colorPalette = Array(RGB(69, 106, 168), RGB(153, 178, 221), RGB(104, 137, 194), RGB(45, 85, 153), RGB(24, 62, 126))

    LNGCOLOR = colorPalette(RAND_INT(0, 4))

 

    Dim ptNew As Point

    Dim AC As Double ' segment C to B

 

    ' new point is given starting point

    ptNew = ptStart

 

    ' computation of opposite leg radius

    AC = Sin(ARCCOS(GM) * Pi180) * Radius ' 78.6151377757423

 

    Dim XOffset As Double

    Dim YOffset As Double

 

    Dim Beta As Double

    Dim Alpha As Double, rotAlpha

 

    ' compute X starting point for initial rotation

    Beta = Cos(angle * Pi180)

    XOffset = Radius * (1 - Beta) / 2

    'ptNew.X = ptStart.X + XOffset

 

    ' compute Y starting point for initial rotation

    Alpha = Sin(angle * Pi180)

    YOffset = Radius * Alpha / 2

    'ptNew.Y = ptStart.Y - YOffset

 

    ' hypothenuse

    Call paintAngleFromPoint(ptNew, 90 + angle, Radius, LNGCOLOR)

 

    paintTriangle.ptA = ptNew

 

    ' adjacent leg

    ptNew = paintAngleFromPoint(ptNew, ARCCOS(GM) + angle, AC, LNGCOLOR)

 

    paintTriangle.ptC = ptNew

 

    ' opposite leg

    ptNew = paintAngleFromPoint(ptNew, 90 + ARCCOS(GM) + angle, GM() * Radius, LNGCOLOR)

 

    paintTriangle.ptB = ptNew

 

    ' set return value (struct)

    With paintTriangle

        .AC = AC

        .BC = Cos(ARCCOS(GM) * Pi180) * Radius

        .CD = Cos(ARCSIN(GM) * Pi180) * GM() * Radius

        .AD = GM() * Radius

        .BD = (1 - GM()) * Radius

        .Alpha = ARCSIN(GM)

        .Beta = ARCCOS(GM)

    End With

 

End Function

 

Function paintSquare(ptStart As Point, ByVal angle As Double, Radius As Double) As Square

 

    Dim ptNew As Point

    Dim CB As Double ' segment C to B

    Dim LNGCOLOR As Long

    Dim colorPalette As Variant

    colorPalette = Array(RGB(69, 106, 168), RGB(153, 178, 221), RGB(104, 137, 194), RGB(45, 85, 153), RGB(24, 62, 126))

    LNGCOLOR = colorPalette(RAND_INT(0, 4))

 

    ' new point is given starting point

    ptNew = ptStart

 

    ' 1st leg

    ptNew = paintAngleFromPoint(ptStart, angle, Radius, LNGCOLOR)

    paintSquare.ptA = ptNew

 

    ' 2nd leg

    ptNew = paintAngleFromPoint(ptNew, 90 + angle, Radius, LNGCOLOR)

    paintSquare.ptB = ptNew

 

    ' 3rd leg

    ptNew = paintAngleFromPoint(ptNew, 180 + angle, Radius, LNGCOLOR)

 

End Function

 

Sub main()

 

    Dim p As Point

    p.X = 330

    p.Y = 400

 

    Dim newSlide As Slide

    Set newSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, _

        ActivePresentation.SlideMaster.CustomLayouts(7))

    newSlide.Select

 

    Call paintPythagoreanTree(p, 0, 100, 1, 15)

 

End Sub

 

Function paintPythagoreanTree(ByRef p As Point, ByVal iAngle As Double,

    ByVal l As Double, ByVal i As Integer, ByVal depth As Integer)

 

    Dim t As Triangle

    Dim sl As Square

    Dim sr As Square

    Dim pt As Point

 

    ' paint base triangle

    t = paintTriangle(p, iAngle, l)

 

    ' paint left square

    sl = paintSquare(t.ptA, (360 - t.Alpha) * i + iAngle + (i - 1) * t.Alpha, t.AC)

 

    If i <= depth Then

        pt = sl.ptA

        Call paintPythagoreanTree(pt, (360 - t.Alpha) * i + iAngle + (i - 1) * t.Alpha, t.AC, i + 1, depth)

 

    End If

 

    ' right sqare

    sr = paintSquare(t.ptC, iAngle - t.Alpha + 90, t.BC)

 

    If i <= depth Then

        pt = sr.ptA

        Call paintPythagoreanTree(pt, iAngle + t.Beta, t.BC, i + 1, depth)

    End If

 

End Function

 

Function RAND_INT(ByVal l As Long, ByVal u As Long, Optional recalc_trigger) As Long

 

    Randomize

    RAND_INT = Int((u - l + 1) * Rnd + l)

 

End Function

Sketchess



Dieter Neumann