Fibonacci word/fractal
You are encouraged to solve this task according to the task description, using any language you may know.
The Fibonacci word may be represented as a fratal as described here:
- For F_wordm start with F_wordCharn=1
- Draw a segment forward
- If current F_wordChar is 0
- Turn left if n is even
- Turn right if n is odd
- next n and iterate until end of F_word
For this task create and display a fractal similar to Fig 1.
AutoHotkey
Prints F_Word30 currently. Segment length and F_Wordn can be adjusted.
Some portions of code from Gdip examples.
<lang AutoHotkey>SetBatchLines, -1
- #MaxMem 200 ; Increased memory required for F_Word > 37
p := 0.3 ; Segment length (pixels) F_Word := 30
SysGet, Mon, MonitorWorkArea W := FibWord(F_Word), d := 1, x1 := 0, y1 := MonBottom , Width := A_ScreenWidth, Height := A_ScreenHeight
If (!pToken := Gdip_Startup()) { MsgBox, 48, gdiplus error!, Gdiplus failed to start. Please ensure you have gdiplus on your system ExitApp } OnExit, Exit
Gui, 1: -Caption +E0x80000 +LastFound +AlwaysOnTop +ToolWindow +OwnDialogs Gui, 1: Show, NA
hwnd1 := WinExist(), hbm := CreateDIBSection(Width, Height), hdc := CreateCompatibleDC() , obm := SelectObject(hdc, hbm), G := Gdip_GraphicsFromHDC(hdc), Gdip_SetSmoothingMode(G, 4) , pPen := Gdip_CreatePen(0xffff0000, 1)
Loop, Parse, W { if (d = 0) x2 := x1 + p, y2 := y1 else if (d = 1 || d = -3) x2 := x1, y2 := y1 - p else if (d = 2 || d = -2) x2 := x1 - p, y2 := y1 else if (d = 3 || d = -1) x2 := x1, y2 := y1 + p Gdip_DrawLine(G, pPen, x1, y1, x2, y2) if (!Mod(A_Index, 1500)) UpdateLayeredWindow(hwnd1, hdc, 0, 0, Width, Height) if (A_LoopField = 0) { if (!Mod(A_Index, 2)) d += 1 else d -= 1 } x1 := x2, y1 := y2, d := Mod(d, 4) }
Gdip_DeletePen(pPen), UpdateLayeredWindow(hwnd1, hdc, 0, 0, Width, Height) , SelectObject(hdc, obm), DeleteObject(hbm), DeleteDC(hdc), Gdip_DeleteGraphics(G) return
FibWord(n, FW1=1, FW2=0) { Loop, % n - 2 FW3 := FW2 FW1, FW1 := FW2, FW2 := FW3 return FW3 }
Esc:: Exit: Gdip_DeletePen(pPen), SelectObject(hdc, obm), DeleteObject(hbm) , DeleteDC(hdc), Gdip_DeleteGraphics(G), Gdip_Shutdown(pToken) ExitApp</lang>
C++
<lang cpp>
- include <windows.h>
- include <string>
using namespace std;
class myBitmap { public:
myBitmap() : pen( NULL ) {}
~myBitmap()
{
DeleteObject( pen );
DeleteDC( hdc );
DeleteObject( bmp );
}
bool create( int w, int h )
{
BITMAPINFO bi;
ZeroMemory( &bi, sizeof( bi ) );
bi.bmiHeader.biSize = sizeof( bi.bmiHeader );
bi.bmiHeader.biBitCount = sizeof( DWORD ) * 8;
bi.bmiHeader.biCompression = BI_RGB; bi.bmiHeader.biPlanes = 1; bi.bmiHeader.biWidth = w; bi.bmiHeader.biHeight = -h; HDC dc = GetDC( GetConsoleWindow() ); bmp = CreateDIBSection( dc, &bi, DIB_RGB_COLORS, &pBits, NULL, 0 ); if( !bmp ) return false; hdc = CreateCompatibleDC( dc ); SelectObject( hdc, bmp ); ReleaseDC( GetConsoleWindow(), dc ); width = w; height = h; clear(); return true;
}
void clear()
{
ZeroMemory( pBits, width * height * sizeof( DWORD ) );
}
void setPenColor( DWORD clr )
{
if( pen ) DeleteObject( pen ); pen = CreatePen( PS_SOLID, 1, clr ); SelectObject( hdc, pen );
}
void saveBitmap( string path )
{
BITMAPFILEHEADER fileheader; BITMAPINFO infoheader; BITMAP bitmap; DWORD* dwpBits; DWORD wb; HANDLE file;
GetObject( bmp, sizeof( bitmap ), &bitmap ); dwpBits = new DWORD[bitmap.bmWidth * bitmap.bmHeight]; ZeroMemory( dwpBits, bitmap.bmWidth * bitmap.bmHeight * sizeof( DWORD ) ); ZeroMemory( &infoheader, sizeof( BITMAPINFO ) ); ZeroMemory( &fileheader, sizeof( BITMAPFILEHEADER ) );
infoheader.bmiHeader.biBitCount = sizeof( DWORD ) * 8; infoheader.bmiHeader.biCompression = BI_RGB; infoheader.bmiHeader.biPlanes = 1; infoheader.bmiHeader.biSize = sizeof( infoheader.bmiHeader ); infoheader.bmiHeader.biHeight = bitmap.bmHeight; infoheader.bmiHeader.biWidth = bitmap.bmWidth; infoheader.bmiHeader.biSizeImage = bitmap.bmWidth * bitmap.bmHeight * sizeof( DWORD );
fileheader.bfType = 0x4D42; fileheader.bfOffBits = sizeof( infoheader.bmiHeader ) + sizeof( BITMAPFILEHEADER ); fileheader.bfSize = fileheader.bfOffBits + infoheader.bmiHeader.biSizeImage;
GetDIBits( hdc, bmp, 0, height, ( LPVOID )dwpBits, &infoheader, DIB_RGB_COLORS );
file = CreateFile( path.c_str(), GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL ); WriteFile( file, &fileheader, sizeof( BITMAPFILEHEADER ), &wb, NULL ); WriteFile( file, &infoheader.bmiHeader, sizeof( infoheader.bmiHeader ), &wb, NULL ); WriteFile( file, dwpBits, bitmap.bmWidth * bitmap.bmHeight * 4, &wb, NULL ); CloseHandle( file );
delete [] dwpBits;
}
HDC getDC() { return hdc; }
int getWidth() { return width; }
int getHeight() { return height; }
private:
HBITMAP bmp; HDC hdc; HPEN pen; void *pBits; int width, height;
}; class fiboFractal { public:
fiboFractal( int l )
{
bmp.create( 600, 440 ); bmp.setPenColor( 0x00ff00 ); createWord( l ); createFractal(); bmp.saveBitmap( "path_to_save_bitmap" );
}
private:
void createWord( int l )
{
string a = "1", b = "0", c; l -= 2; while( l-- ) { c = b + a; a = b; b = c; } fWord = c;
}
void createFractal()
{
int n = 1, px = 10, dir, py = 420, len = 1, x = 0, y = -len, goingTo = 0;
HDC dc = bmp.getDC(); MoveToEx( dc, px, py, NULL ); for( string::iterator si = fWord.begin(); si != fWord.end(); si++ ) { px += x; py += y; LineTo( dc, px, py ); if( !( *si - 48 ) ) { // odd if( n & 1 ) dir = 1; // right else dir = 0; // left switch( goingTo ) { case 0: // up y = 0; if( dir ){ x = len; goingTo = 1; } else { x = -len; goingTo = 3; } break; case 1: // right x = 0; if( dir ) { y = len; goingTo = 2; } else { y = -len; goingTo = 0; } break; case 2: // down y = 0; if( dir ) { x = -len; goingTo = 3; } else { x = len; goingTo = 1; } break; case 3: // left x = 0; if( dir ) { y = -len; goingTo = 0; } else { y = len; goingTo = 2; } }
}
n++;
} }
string fWord; myBitmap bmp;
}; int main( int argc, char* argv[] ) {
fiboFractal ff( 23 ); return system( "pause" );
} </lang>
D
This uses the turtle module from the Dragon Curve Task, and the module from the Grayscale Image task.
<lang d>import std.range, grayscale_image, turtle;
void drawFibonacci(Color)(Image!Color img, ref Turtle t,
in string word, in real step) {
foreach (immutable i, immutable c; word) {
t.forward(img, step);
if (c == '0') {
if ((i + 1) % 2 == 0)
t.left(90);
else
t.right(90);
}
}
}
void main() {
auto img = new Image!Gray(1050, 1050);
auto t = Turtle(30, 1010, -90);
const w = recurrence!q{a[n-1] ~ a[n-2]}("1", "0").drop(24).front;
img.drawFibonacci(t, w, 1);
img.savePGM("fibonacci_word_fractal.pgm");
}</lang> It prints the level 25 word as the Python entry.
Icon and Unicon
This probably only works in Unicon. It also defaults to showing the factal for F_word25 as larger Fibonacci words quickly exceed the size of window I can display, even with a line segment length of a single pixel.
<lang unicon>global width, height
procedure main(A)
n := integer(A[1]) | 25 # F_word to use sl := integer(A[2]) | 1 # Segment length width := integer(A[3]) | 1050 # Width of plot area height := integer(A[4]) | 1050 # Height of plot area w := fword(n) drawFractal(n,w,sl)
end
procedure fword(n)
static fcache
initial fcache := table()
/fcache[n] := case n of {
1: "1"
2: "0"
default: fword(n-1)||fword(n-2)
}
return fcache[n]
end
record loc(x,y)
procedure drawFractal(n,w,sl)
static lTurn, rTurn
initial {
every (lTurn|rTurn) := table()
lTurn["north"] := "west"; lTurn["west"] := "south"
lTurn["south"] := "east"; lTurn["east"] := "north"
rTurn["north"] := "east"; rTurn["east"] := "south"
rTurn["south"] := "west"; rTurn["west"] := "north"
}
wparms := ["FibFractal "||n,"g","bg=white","canvas=normal",
"fg=black","size="||width||","||height,"dx=10","dy=10"]
&window := open!wparms | stop("Unable to open window")
p := loc(10,10)
d := "north"
every i := 1 to *w do {
p := draw(p,d,sl)
if w[i] == "0" then d := if i%2 = 0 then lTurn[d] else rTurn[d]
}
until Event() == &lpress
WriteImage("FibFract"||n||".png")
close(&window)
end
procedure draw(p,d,sl)
if d == "north" then p1 := loc(p.x,p.y+sl) else if d == "south" then p1 := loc(p.x,p.y-sl) else if d == "east" then p1 := loc(p.x+sl,p.y) else p1 := loc(p.x-sl,p.y) DrawLine(p.x,p.y, p1.x,p1.y) return p1
end</lang>
Logo
fibonacci.word.fractal can draw any number of line segments. A Fibonacci number shows the self-similar nature of the fractal. The Fibonacci word values which control the turns are generated here by some bit-twiddling iteration.
<lang Logo>; Return the low 1-bits of :n
- For example if n = binary 10110111 = 183
- then return binary 111 = 7
to low.ones :n
output ashift (bitxor :n (:n+1)) -1
end
- fibbinary should be a fibbinary value
- return the next larger fibbinary value
to fibbinary.next :fibbinary
localmake "filled bitor :fibbinary (ashift :fibbinary -1) localmake "mask low.ones :filled output (bitor :fibbinary :mask) + 1
end
to fibonacci.word.fractal :steps
localmake "step.length 5 ; length of each step
localmake "fibbinary 0
repeat :steps [
forward :step.length
if (bitand 1 :fibbinary) = 0 [
ifelse (bitand repcount 1) = 1 [right 90] [left 90]
]
make "fibbinary fibbinary.next :fibbinary
]
end
setheading 0 ; initial line North fibonacci.word.fractal 377</lang>
Perl
Creates file fword.png containing the Fibonacci Fractal. <lang perl>use strict; use warnings; use GD;
my @fword = ( undef, 1, 0 );
sub fword { my $n = shift; return $fword[$n] if $n<3; return $fword[$n] //= fword($n-1).fword($n-2); }
my $size = 3000; my $im = new GD::Image($size,$size); my $white = $im->colorAllocate(255,255,255); my $black = $im->colorAllocate(0,0,0); $im->transparent($white); $im->interlaced('true');
my @pos = (0,0); my @dir = (0,5); my @steps = split //, fword 23; my $i = 1; for( @steps ) { my @next = ( $pos[0]+$dir[0], $pos[1]+$dir[1] ); $im->line( @pos, @next, $black ); @dir = ( $dir[1], -$dir[0] ) if 0==$_ && 1==$i%2; # odd @dir = ( -$dir[1], $dir[0] ) if 0==$_ && 0==$i%2; # even $i++; @pos = @next; }
open my $out, ">", "fword.png" or die "Cannot open output file.\n"; binmode $out; print $out $im->png; close $out; </lang>
Python
Note that for Python 3, functools.lru_cache could be used instead of the memoize decorator below. <lang python>from functools import wraps from turtle import *
def memoize(obj):
cache = obj.cache = {}
@wraps(obj)
def memoizer(*args, **kwargs):
key = str(args) + str(kwargs)
if key not in cache:
cache[key] = obj(*args, **kwargs)
return cache[key]
return memoizer
@memoize def fibonacci_word(n):
assert n > 0
if n == 1:
return "1"
if n == 2:
return "0"
return fibonacci_word(n - 1) + fibonacci_word(n - 2)
def draw_fractal(word, step):
for i, c in enumerate(word, 1):
forward(step)
if c == "0":
if i % 2 == 0:
left(90)
else:
right(90)
def main():
n = 25 # Fibonacci Word to use. step = 1 # Segment length. width = 1050 # Width of plot area. height = 1050 # Height of plot area. w = fibonacci_word(n)
setup(width=width, height=height) speed(0) setheading(90) left(90) penup() forward(500) right(90) backward(500) pendown() tracer(10000) hideturtle()
draw_fractal(w, step)
# Save Poscript image. getscreen().getcanvas().postscript(file="fibonacci_word_fractal.eps") exitonclick()
if __name__ == '__main__':
main()</lang>
The output image is probably the same.
REXX
Programming note: the starting point (.) and the ending point (∙) are also shown to help visually identify the end points.
About half of the REXX program is dedicated to plotting the appropriate character.
<lang rexx>/*REXX program generates a Fibonacci word, then plots the fractal curve.*/
parse arg ord . /*obtain optional arg from the CL*/
if ord== then ord=23 /*Not specified? Then use default*/
s=fibWord(ord) /*obtain the ORD fib word. */
x=0; y=0; maxX=0; maxY=0; dx=0; dy=1; @.=' '; xp=0; yp=0; @.0.0=.
do n=1 for length(s); x=x+dx; y=y+dy /*advance the plot for next point*/ maxX=max(maxX,x); maxY=max(maxY,y) /*set the maximums for displaying*/ c='│'; if dx\==0 then c='─'; if n==1 then c='┌' /*1st plot.*/ @.x.y=c /*assign a plotting character. */ if @(xp-1,yp)\==' ' & @(xp,yp-1)\==' ' then call @ xp,yp,'┐' /*fixup*/ if @(xp-1,yp)\==' ' & @(xp,yp+1)\==' ' then call @ xp,yp,'┘' /* " */ if @(xp+1,yp)\==' ' & @(xp,yp+1)\==' ' then call @ xp,yp,'└' /* " */ if @(xp+1,yp)\==' ' & @(xp,yp-1)\==' ' then call @ xp,yp,'┌' /* " */ xp=x; yp=y; z=substr(s,n,1) /*save old x,y; assign plot char*/ if z==1 then iterate /*if Z is a "one", then skip it.*/ ox=dx; oy=dy; dx=0; dy=0 /*save DX,DY as the old versions.*/ d=-n//2; if d==0 then d=1 /*determine sign for chirality. */ if oy\==0 then dx=-sign(oy)*d /*Going north|south? Go east|west*/ if ox\==0 then dy= sign(ox)*d /* " east|west? " south|north*/ end /*n*/
call @ x,y,'∙' /*signify the last point plotted.*/
do r=maxY to 0 by -1; _= /*show a row at a time, top 1st.*/
do c=0 to maxX; _=_||@.c.r; end /*c*/
if _\= then say strip(_,'T') /*if not blank, then show a line.*/
end /*r*/ /* [↑] only show non-blank rows.*/
exit /*stick a fork in it, we're done.*/ /*─────────────────────────────────@ subroutine─────────────────────────*/ @: parse arg xx,yy,p; if arg(3)== then return @.xx.yy; @.xx.yy=p; return /*─────────────────────────────────FIBWORD subroutine───────────────────*/ fibWord: procedure; arg x; !.=0; !.1=1 /*obtain the order of fib word. */
do k=3 to x; k1=k-1; k2=k-2 /*generate the Kth Fibonacci word*/
!.k=!.k1 || !.k2 /*construct the next FIB word. */
end /*k*/ /* [↑] generate Fibonacci words.*/
return !.x /*return the Xth fib word. */</lang> output when using the input of 14
∙
│ ┌─┐ ┌─┐ ┌─┐ ┌─┐ ┌─┐
└─┘ │ │ └─┘ │ │ └─┘ │
┌┘ └┐ ┌┘ └┐ ┌┘
│ │ │ ┌─┐ │ │
└┐ ┌┘ └─┘ └─┘ └┐
┌─┐ │ │ ┌─┐ ┌─┐ │
│ └─┘ └─┘ │ │ └─┘
└┐ ┌─┐ ┌─┐ ┌┘ └┐
│ │ └─┘ │ │ │
┌┘ └┐ ┌┘ └┐ ┌┘
│ ┌─┐ │ │ ┌─┐ │ │ ┌─┐
└─┘ └─┘ └─┘ └─┘ └─┘ │
┌─┐ ┌─┐ ┌┘
│ └─┘ │ │
└┐ ┌┘ └┐
│ │ ┌─┐ │
┌┘ └─┘ └─┘
│ ┌─┐
└─┘ │
┌┘
│
└┐
┌─┐ │
│ └─┘
└┐ ┌─┐ ┌─┐
│ │ └─┘ │
┌┘ └┐ ┌┘
│ ┌─┐ │ │
└─┘ └─┘ └┐
┌─┐ ┌─┐ ┌─┐ ┌─┐ ┌─┐ │
│ └─┘ │ │ └─┘ │ │ └─┘
└┐ ┌┘ └┐ ┌┘ └┐
│ │ ┌─┐ │ │ │
┌┘ └─┘ └─┘ └┐ ┌┘
│ ┌─┐ ┌─┐ │ │ ┌─┐
└─┘ │ │ └─┘ └─┘ │
┌┘ └┐ ┌─┐ ┌─┐ ┌┘
│ │ │ └─┘ │ │
└┐ ┌┘ └┐ ┌┘ └┐
┌─┐ │ │ ┌─┐ │ │ ┌─┐ │
. └─┘ └─┘ └─┘ └─┘ └─┘
The output of this REXX program for this Rosetta Code task requirements can be seen here ───► Fibonacci word/fractal/FIBFRACT.REX.
Racket
Prime candidate for Turtle Graphics. I've used a values-turtle, which means you don't get the joy of seeing the turltle bimble around the screen. But it allows the size of the image to be set (useful if you want to push the n much higher than 23 or so!
We use word-order 23, which gives a classic n shape (inverted horseshoe).
Save the (first) implementation of Fibonacci word to Fibonacci-word.rkt; since we do not generate the words here.
<lang racket>#lang racket (require "Fibonacci-word.rkt") (require graphics/value-turtles)
(define word-order 23) ; is a 3k+2 fractal, shaped like an n (define height 420) (define width 600)
(define the-word
(parameterize ((f-word-max-length #f)) (F-Word word-order)))
(for/fold ((T (turtles width height
0 height ; in BL corner
(/ pi -2)))) ; point north
((i (in-naturals))
(j (in-string (f-word-str the-word))))
(match* (i j)
((_ #\1) (draw 1 T))
(((? even?) #\0) (turn -90 (draw 1 T)))
((_ #\0) (turn 90 (draw 1 T)))))</lang>
Tcl
<lang tcl>package require Tk
- OK, this stripped down version doesn't work for n<2…
proc fibword {n} {
set fw {1 0}
while {[llength $fw] < $n} {
lappend fw [lindex $fw end][lindex $fw end-1]
} return [lindex $fw end]
} proc drawFW {canv fw {w {[$canv cget -width]}} {h {[$canv cget -height]}}} {
set w [subst $w] set h [subst $h]
# Generate the coordinate list using line segments of unit length
set d 3; # Match the orientation in the sample paper
set eo [set x [set y 0]]
set coords [list $x $y]
foreach c [split $fw ""] {
switch $d { 0 {lappend coords [incr x] $y} 1 {lappend coords $x [incr y]} 2 {lappend coords [incr x -1] $y} 3 {lappend coords $x [incr y -1]} } if {$c == 0} { set d [expr {($d + ($eo ? -1 : 1)) % 4}] } set eo [expr {!$eo}]
}
# Draw, and rescale to fit in canvas
set id [$canv create line $coords]
lassign [$canv bbox $id] x1 y1 x2 y2
set sf [expr {min(($w-20.) / ($y2-$y1), ($h-20.) / ($x2-$x1))}]
$canv move $id [expr {-$x1}] [expr {-$y1}]
$canv scale $id 0 0 $sf $sf
$canv move $id 10 10
# Return the item ID to allow user reconfiguration
return $id
}
pack [canvas .c -width 500 -height 500] drawFW .c [fibword 23]</lang>