## Theodorus Spiral

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Roland Chastain
Posts: 1008
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Theodorus Spiral

Hello everybody!

Here is a simple Theodorus spiral.

Code: Select all

``````' vectors.bi

type TVector
x as double
y as double
end type

declare function Rotate(byval AVector as TVector, byval ATheta as double) as TVector
declare function Perpendicular(byval AVector as TVector, byval AClockWise as boolean = FALSE) as TVector
declare function Normalize(byval AVector as TVector) as TVector
declare function Add(byval AVector1 as TVector, byval AVector2 as TVector) as TVector
declare function Scale(byval AVector as TVector, byval AFactor as double) as TVector
declare function Mirror(byval AVector as TVector) as TVector

function Rotate(byval AVector as TVector, byval ATheta as double) as TVector
/'
x' = x cos θ − y sin θ
y' = x sin θ + y cos θ
'/
dim result as TVector
with AVector
result.x = .x * Cos(ATheta) - .y * Sin(ATheta)
result.y = .x * Sin(ATheta) + .y * Cos(ATheta)
end with
return result
end function

function Perpendicular(byval AVector as TVector, byval AClockWise as boolean) as TVector
/'
x' = x cos θ − y sin θ
y' = x sin θ + y cos θ
'/
dim result as TVector
dim as integer LSign = IIf(AClockWise, -1, 1)
with AVector
result.x = -.y * LSign
result.y =  .x * LSign
end with
return result
end function

function Normalize(byval AVector as TVector) as TVector
dim result as TVector
dim LLength as double
with AVector
LLength = Sqr(.x * .x + .y * .y)
result.x = .x / LLength
result.y = .y / LLength
end with
return result
end function

function Add(byval AVector1 as TVector, byval AVector2 as TVector) as TVector
dim result as TVector
result.x = AVector1.x + AVector2.x
result.y = AVector1.y + AVector2.y
return result
end function

function Scale(byval AVector as TVector, byval AFactor as double) as TVector
dim result as TVector
with AVector
result.x = .x * AFactor
result.y = .y * AFactor
end with
return result
end function

function Mirror(byval AVector as TVector) as TVector
dim result as TVector
with AVector
result.x =  .x
result.y = -.y
end with
return result
end function
``````

Code: Select all

``````' theodorus.bas

#include "vectors.bi"

const SW = 640
const SH = SW
const CNumTriangles = 16
const CScale = 72

dim shared LCenter as TVector = (SW / 2, SH / 2)
dim shared LColor as uinteger = rgb(0, 255, 0)

sub DrawLine(byval APoint1 as TVector, byval APoint2 as TVector)

line(APoint1.x, APoint1.y)-(APoint2.x, APoint2.y), LColor
end sub

screenres SW, SH, 32
windowtitle "Theodorus Spiral"

dim A as TVector = (0.0, 0.0)
dim B as TVector = (1.0, 0.0)
dim C as TVector

for i as integer = 1 to CNumTriangles

DrawLine(A, B)
DrawLine(B, C)

B = C
next

' Close the last triangle
DrawLine(C, A)

sleep
``````
neil
Posts: 594
Joined: Mar 17, 2022 23:26

### Re: Theodorus Spiral

Maybe you could try to make something like this?
Colored extended spiral of Theodorus with 110 triangles.
https://en.wikipedia.org/wiki/Spiral_of ... tended.svg
Roland Chastain
Posts: 1008
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Re: Theodorus Spiral

Here is a Cairo version.

Code: Select all

``````' color.bi

type TColor
r as double
g as double
b as double
a as double
declare constructor(as uinteger)
declare constructor(as double, as double, as double, as double = 1.0)
end type

constructor TColor(rgba_ as uinteger)
r = (rgba_ and &hFF000000) / &hFF000000
g = (rgba_ and &h00FF0000) / &h00FF0000
b = (rgba_ and &h0000FF00) / &h0000FF00
a = (rgba_ and &h000000FF) / &h000000FF
end constructor

constructor TColor(r_ as double, g_ as double, b_ as double, a_ as double)
r = r_
g = g_
b = b_
a = a_
end constructor

/'
dim c1 as TColor = TColor(&hFF00FF80)

with c1
print(.r)
print(.g)
print(.b)
print(.a)
end with

dim c2 as TColor = TColor(1.0, 1.0, 1.0, 0.5)

with c2
print(.r)
print(.g)
print(.b)
print(.a)
end with
'/
``````

Code: Select all

``````' command.bi

' https://www.freebasic.net/forum/viewtopic.php?p=206588#p206588

'  Tested with the passed parameters:
'  "+3 --option1 -4 --option2=-5 foo.bas --option3=file.ext"

type TCommandLineOption
public:
key as string ' option name
value as string
end type

type TCommandLine
public:
declare constructor ()
declare function HasOption(byref aOptionName as const string) as integer
declare function GetOptionValue(byref aOptionName as const string) as string
declare function GetAloneValueNth(byval n as integer) as string
private:
dim aOptions(any) as TCommandLineOption
End Type

function SameString(byref aLeft as const string, byref aRight as const string, byref aCaseSensitive as const boolean) as boolean
if aCaseSensitive then
return aLeft = aRight
else
return lcase(aLeft) = lcase(aRight)
end if
end function

dim shared caseSensitive as boolean = false

constructor TCommandLine ()
erase(aOptions)
dim i as integer = 0
do while command(i + 1) <> ""
redim preserve aOptions(i)
if left(command(i + 1), 2) = "--" then
dim n as integer = instr(3, command(i + 1), "=")
if n = 0 then
aOptions(i).key = mid(command(i + 1), 3)
else
aOptions(i).key = mid(command(i + 1), 3, n - 3)
aOptions(i).value = mid(command(i + 1), n + 1)
end if
else
aOptions(i).value = command(i + 1)
end if
i += 1
loop
end constructor

function TCommandLine.HasOption(byref aOptionName as const string) as integer
for i as integer = LBound(aOptions) to UBound(aOptions)
if (aOptions(i).key <> "") andalso SameString(aOptions(i).key, aOptionName, caseSensitive) then
return -1
end if
next i
return 0
end function

function TCommandLine.GetOptionValue(byref aOptionName as const string) as string
for i as integer = LBound(aOptions) to UBound(aOptions)
if (aOptions(i).key <> "") andalso SameString(aOptions(i).key, aOptionName, caseSensitive) then
return aOptions(i).value
end if
next i
return ""
end function

function TCommandLine.GetAloneValueNth(byval n as integer) as string
dim k as integer = 0
for i as integer = LBound(aOptions) to UBound(aOptions)
if aOptions(i).key = "" then
k += 1
if k = n then
return aOptions(i).value
end if
end if
next i
return ""
end function

/'
dim myOptions as TCommandLine

print(myOptions.HasOption("option1"))
print("[" & myOptions.GetOptionValue("option2") & "]")

dim n as integer = 1
var s = myOptions.GetAloneValueNth(n)
do while s <> ""
print("[" & s & "]")
n += 1
s = myOptions.GetAloneValueNth(n)
loop
'/
``````

Code: Select all

``````' theodorus.bas

' Theodorus spiral

#include "cairo/cairo.bi"
#include "color.bi"
#include "command.bi"
#include "vectors.bi"

#define EXPAND_TCOLOR(c) c.r, c.g, c.b, c.a

dim as integer scrWidth = 640
dim as integer scrHeight = scrWidth
dim as integer numTriangles = 16
dim shared as double scale_ = 64

sub DrawTriangle(byval APoint1 as TVector, byval APoint2 as TVector, byval APoint3 as TVector, byval cr as cairo_t ptr, pen as TColor, fill as TColor)

dim as TVector LPoint4, LPoint5, LPoint6

APoint1 = Scale(APoint1, scale_)
APoint2 = Scale(APoint2, scale_)
APoint3 = Scale(APoint3, scale_)

cairo_move_to(cr, APoint1.x, APoint1.y)
cairo_line_to(cr, APoint2.x, APoint2.y)
cairo_line_to(cr, APoint3.x, APoint3.y)
cairo_close_path(cr)

cairo_set_source_rgba(cr, EXPAND_TCOLOR(fill))
cairo_fill_preserve(cr)
cairo_set_source_rgba(cr, EXPAND_TCOLOR(pen))
cairo_stroke(cr)

LPoint4 = Scale(Normalize(Perpendicular(APoint2)), 8)
LPoint5 = Perpendicular(LPoint4)
LPoint6 = Perpendicular(LPoint5)

cairo_move_to(cr, LPoint4.x, LPoint4.y)
cairo_rel_line_to(cr, LPoint5.x, LPoint5.y)
cairo_rel_line_to(cr, LPoint6.x, LPoint6.y)
cairo_set_source_rgba(cr, EXPAND_TCOLOR(pen))
cairo_stroke(cr)
end sub

screenres scrWidth, scrHeight, 32
windowtitle "Theodorus Spiral"

dim cl as TCommandLine

dim as TColor bkColor = TColor(0.0, 0.0, 0.0, 0.0)
dim as TColor penColor = TColor(0.0, 0.3, 0.0, 1.0)
dim as TColor fillColor = TColor(0.0, 0.5, 0.0, 1.0)

if cl.HasOption("bkcolor") then
bkColor = TColor(valint("&h" & cl.GetOptionValue("bkcolor")))
end if
if cl.HasOption("pencolor") then
penColor = TColor(valint("&h" & cl.GetOptionValue("pencolor")))
end if
if cl.HasOption("fillcolor") then
fillColor = TColor(valint("&h" & cl.GetOptionValue("fillcolor")))
end if
if cl.HasOption("triangles") then
numTriangles = valint(cl.GetOptionValue("triangles"))
end if

dim as any ptr image = imagecreate(scrWidth, scrHeight, rgba(0, 0, 0, 0))
dim as any ptr pixels
imageinfo(image, scrWidth, scrHeight,,, pixels)
dim as cairo_surface_t ptr sf = cairo_image_surface_create_for_data(pixels, CAIRO_FORMAT_ARGB32, scrWidth, scrHeight, scrWidth * 4)
dim as cairo_t ptr cr = cairo_create(sf)

cairo_set_source_rgba(cr, EXPAND_TCOLOR(bkColor))
cairo_paint(cr)
cairo_translate(cr, scrWidth / 2, scrHeight / 2)
cairo_scale(cr, 1, -1)
cairo_set_line_cap(cr, CAIRO_LINE_CAP_ROUND)
cairo_set_line_width(cr, 0.8)

dim LPoint1 as TVector = (0.0, 0.0)
dim LPoint2 as TVector = (1.0, 0.0)
dim LPoint3 as TVector

for i as integer = 1 to numTriangles

DrawTriangle(LPoint1, LPoint2, LPoint3, cr, penColor, fillColor)

LPoint2 = LPoint3
next

cairo_destroy(cr)
cairo_surface_write_to_png(sf, "image.png")
cairo_surface_destroy(sf)

screenlock()
put (0, 0), image, pset
screenunlock()

imagedestroy image

sleep
``````

You can find vectors.bi in the first post.

Usage example (under Linux):

./theodorus --bkcolor=EBF7E3FF --pencolor=1B3409FF --fillcolor=9BD770FF --triangles=16

neil wrote: Apr 19, 2024 3:26 Maybe you could try to make something like this?
Thanks for the idea. I imagine we should store all points in memory and draw the triangles in the reverse order.

P.-S. Made little improvements in the program, and created a git repository.
dafhi
Posts: 1673
Joined: Jun 04, 2005 9:51

### Re: Theodorus Spiral

thanks for providing the image. that's beautiful.
Roland Chastain
Posts: 1008
Joined: Nov 24, 2011 19:49
Location: France
Contact:

### Re: Theodorus Spiral

dafhi wrote: Apr 21, 2024 3:38 thanks for providing the image. that's beautiful.
Thank you for the compliment.