[Keith Vetter] 2015-12-01 -- http://www.wikiwand.com/en/Penrose_tiling%|%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 Tiling screenshot]
----

======
##+##########################################################################
#
# 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)
return
======

-----
https://gitlab.com/momath/ptile%|%ptile :  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.

<<categories>>Mathematics