Penrose Tiling
Keith Vetter 2015-12-01 -- Penrose Tiling is a non-periodic tiling generated by an aperiodic set of prototiles. Penrose tilings are named after mathematician and physicist Roger Penrose, who investigated these sets in the 1970s.
Shown here is a Penrose tiling of type P3 constructed using deflation. The P3 uses a pair of rhombuses with equal sides but different angles plus a set of rules of how they may be assembled.
Deflation is a construction technique where existing rhombuses are divided into two or three smaller rhombuses. In this instance we start with a circle divided into 10 half-rhombus triangles. The next generation divides each triangle into smaller triangles. By careful orientation and drawing the border of only two sides of each triangle we construct a Penrose tiling.
##+##########################################################################
#
# Penrose.tcl -- Draws a Penrose P3 tiling using deflation of the Robinson triangles
# by Keith Vetter 2015-11-25
# Based on http://preshing.com/20110831/penrose-tiling-explained/
package require Tk
package require img::window
package require tooltip
# Try loading trampoline for pdf output
lappend auto_path ~/misc/tcl_packages
catch {package require trampoline}
set S(sz) 700
set S(generation) [expr {2 + int(rand() * 4)}]
set S(max,generation) 10
set S(save,file) penrose.svg
set S(colors,0) #2212FF
set S(colors,1) #7575FF
array set CLR {
steps 100
delay 20
big,delay 2500
go 0
}
##+##########################################################################
#
# Generation0 -- produce the initial Penrose tiling
#
proc Generation0 {} {
global S TRI
set pi [expr {acos(-1)}]
set TRI(0) {}
set type "0"
set A {0 0}
set radius [expr {$S(sz) / 2}]
for {set i 0} {$i < 10} {incr i} {
set theta [expr {$i * 2 * $pi / 10}]
set B [list [expr {$radius * cos($theta)}] [expr {$radius * sin($theta)}]]
set theta [expr {($i + 1) * 2 * $pi / 10}]
set C [list [expr {$radius * cos($theta)}] [expr {$radius * sin($theta)}]]
set D [VAdd $B $C]
if {$i & 1} {
lappend TRI(0) [list $type $A $B $C]
} else {
lappend TRI(0) [list $type $A $C $B]
}
}
}
##+##########################################################################
#
# SubDivideThisGeneration -- creates the next generation of Penrose tiling
#
proc SubDivideThisGeneration {current_generation} {
global TRI
set next_generation [expr {$current_generation + 1}]
if {[info exists TRI($next_generation)]} return
set phi [expr { 1 / ((1 + sqrt(5)) / 2)}]
set new_triangles {}
foreach triangle $TRI($current_generation) {
lassign $triangle type A B C
if {$type == 0} {
set P [VAdd $A [VAdd $B $A -1] $phi]
lappend new_triangles [list 1 $P $C $A] [list 0 $C $P $B]
} else {
set Q [VAdd $B [VAdd $A $B -1] $phi]
set R [VAdd $B [VAdd $C $B -1] $phi]
lappend new_triangles [list 1 $R $C $A] [list 1 $Q $R $B] [list 0 $R $Q $A]
}
}
set TRI($next_generation) $new_triangles
return
}
##+########################################################################## #
# DrawThisGeneration -- draws all the Robinson triangles for this generation
#
proc DrawThisGeneration {generation} {
set ::S(generation) $generation
.generations config -text "Generation $generation"
.c delete all
set width 5
if {$generation > 3} {set width 3}
if {$generation > 5} {set width 2}
if {$generation > 7} {set width 1}
foreach triangle $::TRI($generation) {
lassign $triangle type A B C
.c create polygon {*}$B {*}$A {*}$C -fill $::S(colors,$type) \
-tag [list poly "poly_$type"] -width 1 -outline $::S(colors,$type)
.c create line {*}$B {*}$A {*}$C -fill black -width $width -tag border
}
SizeToWindow
}
##+##########################################################################
#
# NewGeneration -- changes to a new generation of the tiling.
#
proc NewGeneration {generation} {
global TRI
if {$generation eq "+"} {
set generation [expr {$::S(generation) + 1}]
} elseif {$generation eq "-"} {
set generation [expr {$::S(generation) - 1}]
}
set generation [expr {max(0, min($generation, $::S(max,generation)))}]
if {! [info exists TRI($generation)]} {
for {set i 0} {$i < $generation} {incr i} {
SubDivideThisGeneration $i
}
}
DrawThisGeneration $generation
}
################################################################
#
# GUI stuff below
#
#
proc DoDisplay {} {
destroy {*}[winfo child .]
wm title . "Penrose Tiling"
frame .ctrl -bd 2 -relief solid
canvas .c -width $::S(sz) -height $::S(sz) -bd 0 -highlightthickness 0 -bg cyan
bind .c <Configure> {
set h [expr {%h / 2.0}] ; set w [expr {%w / 2.0}] ;
%W config -scrollregion [list -$w -$h $w $h] ;
SizeToWindow
}
grid .c -row 0 -column 0 -sticky news
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
# Generations dialog
::ttk::frame .f_generations -borderwidth 2 -relief ridge
::ttk::label .generations -text "Generation $::S(generation)" -foreground blue
button .prev -image ::bit::left -command {NewGeneration -}
tooltip::tooltip .prev "Previous generation"
button .next -image ::bit::right -command {NewGeneration +}
tooltip::tooltip .next "Next generation"
button .zoomin -image ::bit::up -command {Zoom 1.1}
tooltip::tooltip .zoomin "Zoom in"
bind .zoomin <3> {Zoom 2}
button .zoomout -image ::bit::down -command {Zoom .9}
tooltip::tooltip .zoomout "Zoom out"
bind .zoomout <3> {Zoom .5}
grid x .generations - - -in .f_generations
grid x x .zoomin x -in .f_generations
grid x .prev x .next -in .f_generations
grid x x .zoomout -in .f_generations
grid columnconfigure .f_generations {0 99} -weight 1
place .f_generations -in .c -relx 1 -x -10 -y 10 -anchor ne
button .hideorshow -image ::bit::right -command HideOrShowCtrlPanel \
-bd 2 -relief ridge -highlightthickness 0 -padx 1m
tooltip::tooltip .hideorshow "Show or hide\nconfiguration panel"
place .hideorshow -in .c -relx 1 -rely 1 -x -2 -y -2 -anchor se
# Control panel
label .ctrl.title -text "Penrose Tiling\nConfiguration"
.ctrl.title config -font "[font actual [.ctrl.title cget -font]] -weight bold"
# Colors dialog
set CP .ctrl.colors
::ttk::labelframe $CP -text Colors -padding {0 0 0 .1i}
::ttk::label $CP.t_rhomb -text "t rhomb "
label $CP.t_rhomb_value -textvariable ::S(colors,0) \
-relief sunken -bg white -width 10
button $CP.t_pick -image ::bit::star -command {PickColor 0}
tooltip::tooltip $CP.t_pick "Pick color for t rhombus"
::ttk::label $CP.tt_rhomb -text "T rhomb "
label $CP.tt_rhomb_value -textvariable ::S(colors,1) \
-relief sunken -bg white
button $CP.tt_pick -image ::bit::star -command {PickColor 1}
tooltip::tooltip $CP.tt_pick "Pick color for T rhombus"
grid $CP.t_rhomb $CP.t_rhomb_value $CP.t_pick -sticky ew
grid $CP.tt_rhomb $CP.tt_rhomb_value $CP.tt_pick -sticky ew
grid configure $CP.t_pick -padx .05i
grid configure $CP.tt_pick -padx .05i
foreach w {random white reset} \
tip {"Random colors" "Black and white coloring" "Reset coloring"} {
::ttk::button $CP.$w -text [string totitle $w] \
-command [list ChangeColoring $w]
tooltip::tooltip $CP.$w $tip
grid $CP.$w - - -pady {1m 0}
}
grid $CP.random -pady {5m 0}
::ttk::checkbutton $CP.animate -text "Animate" \
-variable ::CLR(go) -command RotateColors
grid $CP.animate - - -pady {5m 0}
# Save dialog
set SF .ctrl.f_save
::ttk::labelframe $SF -text Save -padding {0 0 0 .1i}
::ttk::button $SF.fillscreen -text "Fill window" -command FullPage
tooltip::tooltip $SF.fillscreen "Expand tiling to\nfill the window"
::ttk::button $SF.8_5x11 -text "8\xbd x 11" -command 8_5x11
tooltip::tooltip $SF.8_5x11 "Resize window to\n8\xbd x 11 ratio"
::ttk::button $SF.border -text "Border" -command Border
tooltip::tooltip $SF.border "Draw border around tiling"
::ttk::button $SF.save -text "Save" -command DoSave
tooltip::tooltip $SF.save "Save tiling"
pack $SF.fillscreen $SF.8_5x11 $SF.border \
-side top -expand 1 -pady {1m 0}
pack $SF.save -side left -expand 1 -pady {4m 0}
::ttk::button .ctrl.about -text About -command About
tooltip::tooltip .ctrl.about "About Penrose Tiling"
grid .ctrl.title -pady {.1i .2i}
grid .ctrl.colors -padx .05i
grid .ctrl.f_save -padx .05i -sticky ew -pady {.1i 0}
grid rowconfigure .ctrl 100 -weight 1
grid .ctrl.about -row 101 -pady .1i
}
proc HideOrShowCtrlPanel {} {
if {[winfo ismapped .ctrl]} {
grid forget .ctrl
.hideorshow config -image ::bit::right
} else {
grid .ctrl -row 0 -column 1 -sticky ns
.hideorshow config -image ::bit::left
}
}
proc ChangeColoring {{how random}} {
if {$how eq "reset"} {
set ::S(colors,0) #2212FF
set ::S(colors,1) #7575FF
.c config -bg cyan
} elseif {$how eq "white"} {
set ::S(colors,0) white
set ::S(colors,1) white
.c config -bg white
} else {
set ::S(colors,0) [format "\#%02x%02x%02x" \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}]]
set ::S(colors,1) [format "\#%02x%02x%02x" \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}]]
}
.c itemconfig poly_0 -fill $::S(colors,0) -outline $::S(colors,0)
.c itemconfig poly_1 -fill $::S(colors,1) -outline $::S(colors,1)
}
proc PickColor {who} {
set new_clr [tk_chooseColor -initialcolor $::S(colors,$who)]
if {$new_clr ne ""} {
set ::S(colors,$who) $new_clr
.c itemconfig poly_0 -fill $::S(colors,0) -outline $::S(colors,0)
.c itemconfig poly_1 -fill $::S(colors,1) -outline $::S(colors,1)
}
}
##+##########################################################################
#
# VAdd -- adds two vectors w/ scaling of 2nd vector
#
proc VAdd {v1 v2 {scaling 1}} {
foreach {x1 y1} $v1 {x2 y2} $v2 break
return [list [expr {$x1 + $scaling*$x2}] [expr {$y1 + $scaling*$y2}]]
}
##+##########################################################################
#
# SizeToWindow -- scales tiling to fit snugly in the canvas window.
#
proc SizeToWindow {} {
.c delete boundary
lassign [.c bbox all] x0 y0 x1 y1
if {$x0 eq ""} return
set actual_width [expr {$x1 - $x0}]
set actual_height [expr {$y1 - $y0}]
set canvas_width [winfo width .c]
set canvas_height [winfo height .c]
if {$canvas_width < 10} return
set scale_width [expr {$canvas_width / double($actual_width)}]
set scale_height [expr {$canvas_height / double($actual_height)}]
set scale_factor [expr {min($scale_width, $scale_height)}]
.c scale all 0 0 $scale_factor $scale_factor
}
proc Zoom {factor} {
.c delete boundary
.c scale all 0 0 $factor $factor
}
image create bitmap ::bit::left -data {
#define left_width 11
#define left_height 11
static char left_bits = {
0x00, 0x00, 0x20, 0x00, 0x30, 0x00, 0x38, 0x00, 0xfc, 0x01, 0xfe,
0x01, 0xfc, 0x01, 0x38, 0x00, 0x30, 0x00, 0x20, 0x00, 0x00, 0x00
}
}
image create bitmap ::bit::right -data {
#define right_width 11
#define right_height 11
static char right_bits = {
0x00, 0x00, 0x20, 0x00, 0x60, 0x00, 0xe0, 0x00, 0xfc, 0x01, 0xfc,
0x03, 0xfc, 0x01, 0xe0, 0x00, 0x60, 0x00, 0x20, 0x00, 0x00, 0x00
}
}
image create bitmap ::bit::up -data {
#define up_width 11
#define up_height 11
static char up_bits = {
0x00, 0x00, 0x20, 0x00, 0x70, 0x00, 0xf8, 0x00, 0xfc, 0x01, 0xfe,
0x03, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0x00, 0x00, 0x00, 0x00
}
}
image create bitmap ::bit::down -data {
#define down_width 11
#define down_height 11
static char down_bits = {
0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x70, 0x00, 0x70, 0x00, 0xfe,
0x03, 0xfc, 0x01, 0xf8, 0x00, 0x70, 0x00, 0x20, 0x00, 0x00, 0x00
}
}
image create bitmap ::bit::star -data {
#define plus_width 11
#define plus_height 11
static char plus_bits = {
0x00, 0x00, 0x22, 0x02, 0x24, 0x01, 0xa8, 0x00, 0x70, 0x00, 0xfe,
0x03, 0x70, 0x00, 0xa8, 0x00, 0x24, 0x01, 0x22, 0x02, 0x00, 0x00
}
}
proc About {} {
set txt "Penrose Tiling\nby Keith Vetter\nNovember, 2015"
set detail "A Penrose tiling is a non-periodic tiling generated by "
append detail "an aperiodic set of prototiles. Penrose tilings are "
append detail "named after mathematician and physicist Roger Penrose, "
append detail "who investigated these sets in the 1970s."
append detail "\n\n"
append detail "Shown here is a Penrose tiling of type P3 constructed using "
append detail "deflation. The P3 uses a pair of rhombuses with equal sides "
append detail "but different angles plus a set of rules of how they may be "
append detail "assembled. "
append detail "\n\n"
append detail "Deflation is a construction technique where existing "
append detail "rhombuses are divided into two or three smaller rhombuses. "
append detail "In this instance we start with a circle divided into 10 "
append detail "half-rhombus triangles. The next generation divides each "
append detail "triangle into smaller triangles. By careful orientation and "
append detail "drawing the border of only two sides of each triangle we "
append detail "construct a Penrose tiling."
tk_messageBox -icon info -message $txt -detail $detail \
-title "About Penrose Tiling" -parent .
}
proc 8_5x11 {} {
.c config -width 8.5i -height 11i
return
# Resize canvas to be in 8.5 x 11 ratio
# TODO: allow 11 x 8.5
set w [winfo width .c]
set h [winfo height .c]
set new_height [expr {round($w * 11 / 8.5)}]
set new_width [expr {round($h * 8.5 / 11)}]
if {$new_height < $h} {
.c config -height $new_height
} elseif {$new_width < $w} {
.c config -width $new_width
} else {
return
}
update
wm geom . [winfo reqwidth .]x[winfo reqheight .]
}
proc FullPage {} {
.c delete boundary
# Expands canvas content to fill the current canvas window
# Assumes 0,0 is center of window and content is circular
set c_width [expr {[winfo width .c] / 2.}]
set c_height [expr {[winfo height .c] / 2.}]
set c_diag [expr {hypot($c_width, $c_height)}]
set c_diag [expr {$c_diag + 10}]
lassign [.c bbox all] x0 y0 x1 y1
set r_width [expr {($x1 - $x0) / 2.}]
set r_height [expr {($y1 - $y0) / 2.}]
set scale_x [expr {$c_diag / $r_width}]
set scale_y [expr {$c_diag / $r_height}]
.c scale all 0 0 $scale_y $scale_y
}
proc Border {} {
.c delete boundary
set x [expr {[winfo width .c] / 2 + 1}]
set y [expr {[winfo height .c] / 2 + 1}]
.c create rect -$x -$y $x $y -tag boundary -width 10 -outline black -fill {}
}
proc DoSave {} {
set filetypes [list {Svg .svg} {Image .png}]
if {"trampoline" in [package names]} {
lappend filetypes [list Pdf .pdf]
}
set fname [tk_getSaveFile -filetypes $filetypes \
-title "Save Penrose Tiling" \
-initialfile [file rootname $::S(save,file)] \
-typevariable ::S(save,type)]
if {$fname eq ""} return
set ::S(save,file) [string map [list [pwd]/ ""] $fname]
set ext [string tolower [file extension $::S(save,file)]]
if {$ext eq ".svg"} {
SaveSvg
} elseif {$ext eq ".pdf"} {
SavePdf
} else {
SavePng
}
tk_messageBox -icon info -message "Saved tiling as $::S(save,file)" -parent .
}
proc SavePng {} {
# Canvas must be topmost with no placed slaves
foreach slave [place slaves .c] {
set PLACE($slave) [place info $slave]
place forget $slave
}
raise .
update
# Hack, sometimes the tk_getSaveFile dialogs weren't being deleted in time
after 50 ; update
if {"::img::pen" in [image names]} { image delete ::img::pen }
image create photo ::img::pen -data .c
foreach slave [array names PLACE] {
place $slave {*}$PLACE($slave)
}
::img::pen write $::S(save,file) -format png
image delete ::img::pen
}
proc SavePdf {} {
set x_shift [expr {[winfo width .c] / 2}]
set y_shift [expr {[winfo height .c] / 2}]
.c move all $x_shift $y_shift
::pdf::generate .c $::S(save,file)
.c move all -$x_shift -$y_shift
}
proc SaveSvg {} {
set fout [open $::S(save,file) w]
puts $fout [GenerateSvg]
close $fout
}
proc GenerateSvg {} {
set xml "<?xml version='1.0'?>\n"
append xml "<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 1.1//EN' "
append xml "'Graphics/SVG/1.1/DTD/svg11.dtd'>\n"
set width [winfo width .c]
set height [winfo height .c]
append xml "<svg width='$width' height='$height' version='1.1' "
append xml "xmlns='http://www.w3.org/2000/svg' "
append xml "xmlns:xlink='http://www.w3.org/1999/xlink'>\n"
foreach id [.c find all] {
set line ""
if {[.c type $id] eq "polygon"} {
set stroke [.c itemcget $id -outline]
set fill [.c itemcget $id -fill]
set line " <polygon points='[GetTranslatedCoords $id]' "
append line "style='stroke-width: 1; stroke-linejoin: round; "
append line "stroke: $stroke; fill: $fill'"
append line "/>"
} elseif {[.c type $id] eq "line"} {
set stroke [.c itemcget $id -fill]
set width [.c itemcget $id -width]
set line " <polyline points='[GetTranslatedCoords $id]' "
append line "style='stroke-linejoin: round; fill: none; "
append line "stroke-width: $width; stroke: $stroke'"
append line "/>"
} elseif {[.c type $id] eq "rectangle"} {
lassign [GetTranslatedCoords $id] x0 y0 x1 y1
set w [expr {$x1 - $x0}]
set h [expr {$y1 - $y0}]
set stroke [.c itemcget $id -outline]
set width [.c itemcget $id -width]
set line " <rect x='$x0' y='$y0' width='$w' height='$h' "
append line "style='fill: none; stroke: $stroke; stroke-width: $width'/>"
} else {
puts stderr "svg conversion error: unknown type: [.c type id]"
}
append xml $line "\n"
}
append xml "</svg>\n"
return $xml
}
##+##########################################################################
#
# GetTranslatedCoords -- shift coordinates so 0,0 is in the top left corner
#
proc GetTranslatedCoords {id} {
set x_shift [expr {[winfo width .c] / 2}]
set y_shift [expr {[winfo height .c] / 2}]
set xy {}
foreach {x y} [.c coords $id] {
lappend xy [expr {round($x + $x_shift)}] [expr {round($y + $y_shift)}]
}
return $xy
}
##+##########################################################################
#
# RotateColors -- animation to slowly fade the colors
#
proc RotateColors {} {
global CLR
foreach aid [after info] { after cancel $aid }
if {! $CLR(go)} return
foreach id {poly_0 poly_1} {
set clr [format "\#%02x%02x%02x" \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}] \
[expr {int (255 * rand())}]]
RotateColorForId $id $clr
}
after $CLR(big,delay) RotateColors
}
proc RotateColorForId {id next_color} {
global CLR
set who ""
regexp {\d+} $id who
set current [.c itemcget $id -fill]
foreach var {red0 green0 blue0} value [winfo rgb . $current] {
set $var [expr {$value/256}]
}
foreach var {red1 green1 blue1} value [winfo rgb . $next_color] {
set $var [expr {$value/256}]
}
set dred [expr {$red1 - $red0}]
set dgreen [expr {$green1 - $green0}]
set dblue [expr {$blue1 - $blue0}]
# Generate after events for each step in the color fade
for {set i 0} {$i < $CLR(steps)} {incr i} {
set red [expr {int($red0 + $dred/double($CLR(steps)) * $i)}]
set green [expr {int($green0 + $dgreen/double($CLR(steps)) * $i)}]
set blue [expr {int($blue0 + $dblue/double($CLR(steps)) * $i)}]
set clr [format "\#%02x%02x%02x" $red $green $blue]
after [expr {($i+1) * $CLR(delay)}] \
".c itemconfig $id -fill $clr -outline $clr ; set ::S(colors,$who) $clr"
}
}
################################################################
Generation0
DoDisplay
NewGeneration $S(generation)
returnptile : MoMath's fixes/extensions to Stuart Levy's ptile project from the mid 1990s. Ptile lets the user interactively build a tiling, as a collection of patches, each comprising one or more polygonal tiles. The user can copy, paste and duplicate patches.