# Module to on-demand render MaterialIcons-Regular.svg
# into photo images using tksvg.
#
# chw January 2019
# image_ncg contributed by dzach May/July 2019

package require Tk
package require tdom
package require tksvg

namespace eval ::MaterialIcons {

    variable glyph	;# SVG glyph cache
    array set glyph {}	;# indexed by glyph name

    variable viewbox	;# common viewBox {x y w h} for glyphs

    variable icache	;# image cache indexed by glyph name, size,
    array set icache {}	;# opacity, color, e.g. "zoom_out,24,1.0,black"

    variable template	;# SVG template for a glyph

    # Module initializer: parse and cache the SVG file.

    proc _init {file} {
	variable glyph
	variable viewbox
	variable template
	set f [open $file]
	set doc [dom parse -channel $f]
	close $f
	set root [$doc documentElement]
	foreach node [$root getElementsByTagName glyph] {
	    if {[$node hasAttribute glyph-name] && [$node hasAttribute d]} {
		set d [$node getAttribute d]
		if {$d eq "M0 0z"} {
		    # skip empty icon
		    continue
		}
		set glyph([$node getAttribute glyph-name]) $d
	    }
	}
	foreach node [$root getElementsByTagName font-face] {
	    if {[$node hasAttribute bbox]} {
		set bbox [$node getAttribute bbox]
		# keep only first bbox
		break
	    }
	}
	$doc delete
	if {![info exists bbox]} {
	    return -code error "no bbox attribute found"
	}
	set template0 {
	    <?xml version="1.0" encoding="UTF-8" standalone="no"?>
	    <svg id="%%s" width="%g" height="%g" viewBox="%s" version="1.1">
	      <g>
		<path fill="%%s" fill-opacity="%%g"
		 stroke="%%s" stroke-width="%%g"
		 transform="rotate(%%g,256,256) scale(1,-1) translate(0,%g)"
		 d="%%s"/>
	      </g>
	    </svg>
	}
	lassign $bbox x1 y1 x2 y2
	set w [expr {$x2 - $x1}]
	set h [expr {$y2 - $y1}]
	set viewbox [list $x1 $y1 $w $h]
	set template [format $template0 $w $h $viewbox [expr {0 - $y2 - $y1}]]
    }

    # Invoke and release initializer.

    _init [file join [file dirname [info script]] MaterialIcons-Regular.svg]
    rename _init {}

    # Return list of icon (glyph) names which can be rendered.

    proc names {{pattern *}} {
	variable glyph
	tailcall lsort [array names glyph $pattern]
    }

    # Return SVG for named icon with optional fill color and opacity.

    proc svg {name {color black} {opacity 1.0}
	{stroke none} {strokewidth 1.0} {angle 0}} {
	variable glyph
	variable template
	if {![info exists glyph($name)]} {
	    return -code error "glyph $name does not exist"
	}
	tailcall format $template $name $color $opacity \
	    $stroke $strokewidth $angle $glyph($name)
    }

    # Return photo image for named icon with optional size, fill color,
    # and opacity. If size is negative, it specifies pixels, else points
    # taking the current tk scaling into account.

    proc image {name {size 16} {color black} {opacity 1.0}} {
	variable icache
	set fullname ${name},${size},${opacity},${color}
	if {[info exists icache($fullname)]} {
	    if {![catch {::image inuse $icache($fullname)}]} {
		return $icache($fullname)
	    }
	    unset icache($fullname)
	}
	set icache($fullname) [image_nc $name $size $color $opacity]
	return $icache($fullname)
    }

    # Like the "image" method above but without caching.

    proc image_nc {name {size 16} {color black} {opacity 1.0}} {
	variable viewbox
	if {![string is integer $size]} {
	    return -code error "expect integer size"
	}
	if {$size == 0} {
	    return -code error "invalid size"
	}
	lassign $viewbox x y w h
	if {$size < 0} {
	    set size [expr {-1.0 * $size}]
	} else {
	    set dpi [expr {72.0 * [tk scaling]}]
	    set size [expr {$dpi * $size / 72.0}]
	}
	set scale [expr {1.0 * $size / $w}]
	tailcall ::image create photo -format [list svg -scale $scale] \
	    -data [svg $name $color $opacity]
    }

    # Flush image cache.

    proc flush {} {
	variable icache
	foreach fullname [array names icache] {
	    catch {::image delete $icache($fullname)}
	    unset icache($fullname)
	}
    }

    # Rebuild image cache; useful when tk scaling has changed.

    proc rebuild {} {
	variable icache
	variable viewbox
	set dpi [expr {72.0 * [tk scaling]}]
	lassign $viewbox x y w h
	foreach fullname [array names icache] {
	    if {[scan $fullname {%[^,],%d,%g,%s} name size opacity color] == 4
		    && $size > 0} {
		set size [expr {$dpi * $size / 72.0}]
		set scale [expr {1.0 * $size / $w}]
		if {[catch {::image inuse $icache($fullname)}]} {
		    set this [::image create photo \
				-format [list svg -scale $scale] \
				-data [svg $name $color $opacity]]
		    set icache($fullname) $this
		} else {
		    $icache($fullname) configure -width 1 -height 1
		    $icache($fullname) configure -width 0 -height 0
		    $icache($fullname) configure \
			-format [list svg -scale $scale]
		}
	    }
	}
    }

    # Convert a display size including optional unit to pixels.
    # Valid unit suffixes are d (density points), p (points),
    # and m (millimeters), and without unit suffix, pixels.

    proc val2px {val} {
	set dval ""
	if {[scan $val "%g" dval] == 1} {
	    if {[string match "*d" $val]} {
		set val [expr {[tk scaling] * 72.0 / 160.0 * $dval}]
	    } elseif {[string match "*p" $val]} {
		set val [expr {[tk scaling] * $dval}]
	    } elseif {[string match "*m" $val]} {
		set val [expr {[tk scaling] * 72.0 / 25.4 * $dval}]
	    }
	}
	if {![string is double $val]} {
	    return -code error "expect number for size"
	} elseif {$val < 0} {
	    set val [expr {-1.0 * $val}]
	}
	return $val
    }

    # Like the "image_nc" method but accepting many options:
    #   name		glyph name to be rendered
    #   imgname		name of photo image
    #   -size S		size with optional unit suffix
    #   -fill C		fill color
    #   -opacity O	fill opacity
    #   -stroke C	stroke color
    #   -strokewidth S	stroke width with optional unit suffix
    #   -angle A	angle in degrees

    proc image_ncg {name imgname args} {
	variable viewbox
	array set opts {
	    -size 24d -fill black -opacity 1.0 -stroke none
	    -strokewidth 1.0 -angle 0
	}
	array set opts $args
	lassign $viewbox x y w h
	set size [val2px $opts(-size)]
	if {$size == 0} {
	    return -code error "invalid size"
	}
	set scale [expr {1.0 * $size / $w}]
	# if stroke width has units or is negative, don't scale it
	if {![string is double -strict $opts(-strokewidth)] ||
	    $opts(-strokewidth) < 0} {
	    # reverse the scale
	    set opts(-strokewidth) \
		[expr {abs([val2px $opts(-strokewidth)] / $scale)}]
	}
	tailcall ::image create photo $imgname \
	    -format [list svg -scale $scale] \
	    -data [svg $name $opts(-fill) $opts(-opacity) $opts(-stroke) \
		$opts(-strokewidth) $opts(-angle)]
    }

    # Make some procs visible in MaterialIcons ensemble.

    namespace ensemble create -subcommands {
	names svg image image_nc flush rebuild image_ncg
    }

}

package provide MaterialIcons 0.2