# Module to on-demand render Puppy SVG Icons into photo images using tksvg.
#
# chw June 2020

package require Tk
if { $::tk_version < 9 } {
    package require tksvg
}

namespace eval ::PuppyIcons {

    variable svg		;# SVG data
    array set svg {}		;# indexed by icon name

    variable viewbox		;# common viewBox {x y w h} for icons
    set viewbox {0 0 100 100}	;# all Puppy icons have this viewbox

    variable icache	;# image cache indexed by icon name, size,
    array set icache {}	;# e.g. "status/user-trash-full,24"

    # Module initializer: cache the SVG data from a gzip'ed bundle.
    # SVG for each icon is recompressed to conserve process memory.

    apply [list file {
	variable svg
	set f [open $file rb]
	set data [zlib gunzip [read $f]]
	close $f
	foreach {name value} $data {
	    set svg($name) [zlib gzip $value]
	}
    } [namespace current]] [file join \
	[file dirname [info script]] puppy-svg-bundle.gz]

    # Return list of icon names which can be rendered.

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

    # Return SVG for named icon.

    proc svg {name} {
	variable svg
	if {![info exists svg($name)]} {
	    return -code error "icon $name does not exist"
	}
	return [zlib gunzip $svg($name)]
    }

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

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

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

    proc image_nc {name {size 16}} {
	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]
    }

    # Flush image cache deleting all images.

    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.
    # Images which have point sizes are resized to new scale.

    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} name size] == 2 && $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]
		    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]
		}
	    }
	}
    }

    # Make procs visible in PuppyIcons ensemble.

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

}

package provide PuppyIcons 0.1
