punkshell/src/assets/logo/make-ico.tcl

# make-ico.tcl - build multi-resolution Windows .ico files and web rasters from
# the SVG masters in this directory, with no Windows-only component (G-135).
#
# Replaces make-ico.ps1: rasterization is rsvg-convert (librsvg, true alpha,
# cross-platform); PNG decode is pure Tcl (core zlib inflate + row unfilter);
# DIB and ICONDIR assembly is pure [binary format]. ImageMagick is not used for
# assembly - its ICO writer picks its own entry formats.
#
# Entry formats (unchanged from make-ico.ps1):
#   <=128 px entries : uncompressed 32-bit BGRA DIB (BITMAPINFOHEADER + XOR + AND mask)
#   256 px entry     : PNG-compressed (Vista+ convention)
#   -allpng makes every entry PNG-compressed (web favicons: ~10x smaller, but
#   unreadable by GDI+ and tklib's ico package - never use it for a PE resource).
#
# Every artifact produced gets its <artifact>.assetorigin.toml sidecar
# (re)written - artifact and source sha256 plus the invocation options - so
# regeneration cannot leave a stale record. Format: see AGENTS.md here.
#
# usage (any tclsh 8.6+, rsvg-convert on PATH):
#   tclsh make-ico.tcl all ?-check?
#       Regenerate every recorded artifact from the MANIFEST below into place
#       (files are rewritten only when bytes change). -check builds everything
#       but writes nothing: reports match/DIFFER per artifact and sidecar,
#       exit 1 on any difference - the drift probe.
#   tclsh make-ico.tcl ico -svg <in.svg> -ico <out.ico> ?-sizes {16 24 32 48 64 128 256}? ?-allpng? ?-role <role>? ?-work <dir>?
#   tclsh make-ico.tcl raster -svg <in.svg> -png <out.png> -size <n> ?-role <role>?

set MANIFEST {
    {ico    punk-mark.svg                    punk-mark.ico                   {16 24 32 48 64 128 256} 0 pe-resource}
    {ico    alternative/punk-mark-solid.svg  alternative/punk-mark-solid.ico {16 24 32 48 64 128 256} 0 pe-resource}
    {ico    project-default/icon.svg         project-default/icon.ico        {16 24 32 48 64 128 256} 0 pe-resource}
    {ico    web/icon.svg                     web/favicon.ico                 {16 32 48}               1 web}
    {raster web/icon-opaque.svg              web/apple-touch-icon.png        180 {} web}
    {raster web/icon-opaque.svg              web/icon-192.png                192 {} web}
    {raster web/icon-opaque.svg              web/icon-512.png                512 {} web}
}

# ---------------------------------------------------------------- file helpers

proc readbin {path} {
    set f [open $path rb]
    set data [read $f]
    close $f
    return $data
}
proc writebin {path data} {
    set f [open $path wb]
    puts -nonewline $f $data
    close $f
}

# Relative path from directory basedir to path, forward slashes.
proc relpath {basedir path} {
    set base [file split [file normalize $basedir]]
    set p [file split [file normalize $path]]
    set caseless [expr {$::tcl_platform(platform) eq "windows"}]
    set i 0
    while {$i < [llength $base] && $i < [llength $p]} {
        set a [lindex $base $i]
        set b [lindex $p $i]
        if {$caseless} {
            set a [string tolower $a]
            set b [string tolower $b]
        }
        if {$a ne $b} break
        incr i
    }
    set rel [concat [lrepeat [expr {[llength $base] - $i}] ..] [lrange $p $i end]]
    if {![llength $rel]} {return .}
    return [join $rel /]
}

# ---------------------------------------------------------------- sha256 (pure Tcl)
# Self-contained so the script runs under any stock tclsh; the checker
# (scriptlib/developer/assetorigin_check.tcl) embeds the same algorithm.

namespace eval sha256 {
    variable K {
        0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5
        0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174
        0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da
        0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967
        0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85
        0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 0xd192e819 0xd6990624 0xf40e3585 0x106aa070
        0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3
        0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2
    }
    proc hex {data} {
        variable K
        set bitlen [expr {wide([string length $data]) * 8}]
        append data \x80
        set pad [expr {(56 - [string length $data] % 64 + 64) % 64}]
        append data [string repeat \x00 $pad] [binary format W $bitlen]
        set h0 0x6a09e667; set h1 0xbb67ae85; set h2 0x3c6ef372; set h3 0xa54ff53a
        set h4 0x510e527f; set h5 0x9b05688c; set h6 0x1f83d9ab; set h7 0x5be0cd19
        set n [string length $data]
        for {set off 0} {$off < $n} {incr off 64} {
            binary scan [string range $data $off [expr {$off + 63}]] Iu16 w
            for {set t 16} {$t < 64} {incr t} {
                set x [lindex $w [expr {$t - 15}]]
                set s0 [expr {((($x >> 7) | ($x << 25)) ^ (($x >> 18) | ($x << 14)) ^ ($x >> 3)) & 0xffffffff}]
                set x [lindex $w [expr {$t - 2}]]
                set s1 [expr {((($x >> 17) | ($x << 15)) ^ (($x >> 19) | ($x << 13)) ^ ($x >> 10)) & 0xffffffff}]
                lappend w [expr {([lindex $w [expr {$t - 16}]] + $s0 + [lindex $w [expr {$t - 7}]] + $s1) & 0xffffffff}]
            }
            set a $h0; set b $h1; set c $h2; set d $h3
            set e $h4; set f $h5; set g $h6; set h $h7
            for {set t 0} {$t < 64} {incr t} {
                set S1 [expr {((($e >> 6) | ($e << 26)) ^ (($e >> 11) | ($e << 21)) ^ (($e >> 25) | ($e << 7))) & 0xffffffff}]
                set ch [expr {(($e & $f) ^ (~$e & $g)) & 0xffffffff}]
                set T1 [expr {($h + $S1 + $ch + [lindex $K $t] + [lindex $w $t]) & 0xffffffff}]
                set S0 [expr {((($a >> 2) | ($a << 30)) ^ (($a >> 13) | ($a << 19)) ^ (($a >> 22) | ($a << 10))) & 0xffffffff}]
                set maj [expr {($a & $b) ^ ($a & $c) ^ ($b & $c)}]
                set T2 [expr {($S0 + $maj) & 0xffffffff}]
                set h $g; set g $f; set f $e; set e [expr {($d + $T1) & 0xffffffff}]
                set d $c; set c $b; set b $a; set a [expr {($T1 + $T2) & 0xffffffff}]
            }
            set h0 [expr {($h0 + $a) & 0xffffffff}]; set h1 [expr {($h1 + $b) & 0xffffffff}]
            set h2 [expr {($h2 + $c) & 0xffffffff}]; set h3 [expr {($h3 + $d) & 0xffffffff}]
            set h4 [expr {($h4 + $e) & 0xffffffff}]; set h5 [expr {($h5 + $f) & 0xffffffff}]
            set h6 [expr {($h6 + $g) & 0xffffffff}]; set h7 [expr {($h7 + $h) & 0xffffffff}]
        }
        return [format %08x%08x%08x%08x%08x%08x%08x%08x $h0 $h1 $h2 $h3 $h4 $h5 $h6 $h7]
    }
    proc file_hex {path} {
        return [hex [readbin $path]]
    }
}

# ---------------------------------------------------------------- PNG decode

# Return {w h ihdr-only} without decoding pixel data.
proc png_info {data} {
    if {[string range $data 0 7] ne "\x89PNG\r\n\x1a\n"} {error "not a PNG"}
    binary scan [string range $data 8 15] Iua4 len type
    if {$type ne "IHDR"} {error "PNG missing IHDR"}
    binary scan [string range $data 16 28] IuIucucucucucu w h depth ctype comp filt inter
    return [list w $w h $h depth $depth colortype $ctype interlace $inter]
}

# Decode an 8-bit RGBA non-interlaced PNG (what rsvg-convert emits) into rows of
# RGBA byte values: a list of $h rows, each a flat list of $w*4 ints, top-down.
proc png_decode_rgba_rows {data} {
    set info [png_info $data]
    if {[dict get $info depth] != 8 || [dict get $info colortype] != 6 || [dict get $info interlace] != 0} {
        error "unsupported PNG variant (need 8-bit RGBA non-interlaced): $info"
    }
    set w [dict get $info w]
    set h [dict get $info h]
    set idat ""
    set pos 8
    set n [string length $data]
    while {$pos < $n} {
        binary scan [string range $data $pos [expr {$pos + 7}]] Iua4 len type
        if {$type eq "IDAT"} {
            append idat [string range $data [expr {$pos + 8}] [expr {$pos + 8 + $len - 1}]]
        } elseif {$type eq "IEND"} {
            break
        }
        incr pos [expr {12 + $len}]
    }
    set raw [zlib decompress $idat]
    set rowbytes [expr {$w * 4}]
    if {[string length $raw] != ($rowbytes + 1) * $h} {
        error "PNG pixel payload length mismatch"
    }
    set rows {}
    set prev [lrepeat $rowbytes 0]
    set pos 0
    for {set y 0} {$y < $h} {incr y} {
        binary scan [string range $raw $pos $pos] cu f
        binary scan [string range $raw [expr {$pos + 1}] [expr {$pos + $rowbytes}]] cu* cur
        incr pos [expr {$rowbytes + 1}]
        switch -- $f {
            0 {
                set recon $cur
            }
            1 {
                set recon [lrange $cur 0 3]
                for {set i 4} {$i < $rowbytes} {incr i} {
                    lappend recon [expr {([lindex $cur $i] + [lindex $recon [expr {$i - 4}]]) & 0xff}]
                }
            }
            2 {
                set recon {}
                for {set i 0} {$i < $rowbytes} {incr i} {
                    lappend recon [expr {([lindex $cur $i] + [lindex $prev $i]) & 0xff}]
                }
            }
            3 {
                set recon {}
                for {set i 0} {$i < 4} {incr i} {
                    lappend recon [expr {([lindex $cur $i] + [lindex $prev $i] / 2) & 0xff}]
                }
                for {set i 4} {$i < $rowbytes} {incr i} {
                    lappend recon [expr {([lindex $cur $i] + ([lindex $recon [expr {$i - 4}]] + [lindex $prev $i]) / 2) & 0xff}]
                }
            }
            4 {
                set recon {}
                for {set i 0} {$i < $rowbytes} {incr i} {
                    set x [lindex $cur $i]
                    if {$i >= 4} {
                        set a [lindex $recon [expr {$i - 4}]]
                        set c [lindex $prev [expr {$i - 4}]]
                    } else {
                        set a 0
                        set c 0
                    }
                    set b [lindex $prev $i]
                    set p [expr {$a + $b - $c}]
                    set pa [expr {abs($p - $a)}]
                    set pb [expr {abs($p - $b)}]
                    set pc [expr {abs($p - $c)}]
                    if {$pa <= $pb && $pa <= $pc} {
                        set pred $a
                    } elseif {$pb <= $pc} {
                        set pred $b
                    } else {
                        set pred $c
                    }
                    lappend recon [expr {($x + $pred) & 0xff}]
                }
            }
            default {
                error "PNG row $y: unknown filter type $f"
            }
        }
        set prev $recon
        lappend rows $recon
    }
    return $rows
}

# ---------------------------------------------------------------- ICO assembly

# DIB icon entry: BITMAPINFOHEADER (doubled height), bottom-up BGRA XOR data,
# then the 1bpp AND mask (bit set where fully transparent, rows padded to 4 bytes).
proc dib_entry {s rows} {
    set hdr [binary format iiissiiiiii 40 $s [expr {$s * 2}] 1 32 0 [expr {$s * $s * 4}] 0 0 0 0]
    set xor {}
    set mask {}
    set maskrowbytes [expr {(($s + 31) / 32) * 4}]
    for {set y [expr {$s - 1}]} {$y >= 0} {incr y -1} {
        set row [lindex $rows $y]
        set maskrow [lrepeat $maskrowbytes 0]
        set x 0
        foreach {r g b a} $row {
            lappend xor $b $g $r $a
            if {$a == 0} {
                set bi [expr {$x / 8}]
                lset maskrow $bi [expr {[lindex $maskrow $bi] | (0x80 >> ($x % 8))}]
            }
            incr x
        }
        lappend mask {*}$maskrow
    }
    return $hdr[binary format c* $xor][binary format c* $mask]
}

# Build the .ico image (as a binary string) from a list of {size payload} pairs.
proc ico_assemble {entries} {
    set dir [binary format sss 0 1 [llength $entries]]
    set offset [expr {6 + 16 * [llength $entries]}]
    set body ""
    foreach entry $entries {
        lassign $entry s payload
        set dim [expr {$s >= 256 ? 0 : $s}]
        set len [string length $payload]
        append dir [binary format ccccssii $dim $dim 0 0 1 32 $len $offset]
        append body $payload
        incr offset $len
    }
    return $dir$body
}

proc rasterize {svg size png} {
    if {[catch {exec -ignorestderr rsvg-convert -w $size -h $size -o $png $svg} err]} {
        if {[string match "*couldn't execute*" $err]} {
            error "rsvg-convert not found on PATH - install librsvg (any platform) to rasterize"
        }
        error "rsvg-convert failed at ${size}px for $svg: $err"
    }
    set data [readbin $png]
    set info [png_info $data]
    if {[dict get $info w] != $size || [dict get $info h] != $size} {
        error "rasterizer returned [dict get $info w]x[dict get $info h] for ${size}px"
    }
    return $data
}

# Build the full .ico binary for svg at the given sizes.
proc ico_build {svg sizes allpng workdir} {
    set entries {}
    foreach s $sizes {
        set png [file join $workdir "$s.png"]
        set data [rasterize $svg $s $png]
        if {$allpng || $s == 256} {
            lappend entries [list $s $data]
        } else {
            lappend entries [list $s [dib_entry $s [png_decode_rgba_rows $data]]]
        }
    }
    return [ico_assemble $entries]
}

# ---------------------------------------------------------------- sidecars

proc toml_escape {s} {
    return [string map {\\ \\\\ \" \\\"} $s]
}

# Sidecar content for artifact (bytes given) derived from source via options.
proc sidecar_content {artifactpath artifactbytes sourcepath role options} {
    set srcrel [relpath [file dirname $artifactpath] $sourcepath]
    set lines {}
    lappend lines "# assetorigin provenance sidecar (schema 1) for the asset named by this file"
    lappend lines "# with the .assetorigin.toml suffix stripped. Optional and advisory."
    lappend lines "schema = 1"
    lappend lines "role = \"[toml_escape $role]\""
    lappend lines "hash = \"sha256:[sha256::hex $artifactbytes]\""
    lappend lines "source = \"[toml_escape $srcrel]\""
    lappend lines "source_hash = \"sha256:[sha256::file_hex $sourcepath]\""
    lappend lines "generator = \"make-ico.tcl\""
    lappend lines "options = \"[toml_escape $options]\""
    return "[join $lines \n]\n"
}

# Write content to path only when bytes differ; return unchanged|updated|created.
proc write_if_changed {path content} {
    if {[file exists $path]} {
        if {[readbin $path] eq $content} {
            return unchanged
        }
        writebin $path $content
        return updated
    }
    writebin $path $content
    return created
}

# Compare content against path without writing; return match|DIFFER|MISSING.
proc check_against {path content} {
    if {![file exists $path]} {return MISSING}
    if {[readbin $path] eq $content} {return match}
    return DIFFER
}

# ---------------------------------------------------------------- subcommands

proc opts_parse {argl spec} {
    # spec: dict option -> default; boolean options have default 0 and take no value
    set out $spec
    for {set i 0} {$i < [llength $argl]} {incr i} {
        set o [lindex $argl $i]
        if {![dict exists $spec $o]} {error "unknown option $o (expected: [dict keys $spec])"}
        if {[dict get $spec $o] eq "0"} {
            dict set out $o 1
        } else {
            incr i
            if {$i >= [llength $argl]} {error "option $o needs a value"}
            dict set out $o [lindex $argl $i]
        }
    }
    return $out
}

proc workdir_make {requested} {
    if {$requested ne ""} {
        file mkdir $requested
        return [list $requested 0]
    }
    set base ""
    foreach v {TEMP TMP TMPDIR} {
        if {[info exists ::env($v)] && $::env($v) ne ""} {
            set base $::env($v)
            break
        }
    }
    if {$base eq ""} {set base /tmp}
    set dir [file join $base "make-ico-[pid]"]
    file mkdir $dir
    return [list $dir 1]
}

proc cmd_ico {argl} {
    set o [opts_parse $argl {-svg {} -ico {} -work {} -sizes {16 24 32 48 64 128 256} -allpng 0 -role {}}]
    if {[dict get $o -svg] eq "" || [dict get $o -ico] eq ""} {error "ico: -svg and -ico are required"}
    set role [dict get $o -role]
    if {$role eq ""} {set role [expr {[dict get $o -allpng] ? "web" : "pe-resource"}]}
    lassign [workdir_make [dict get $o -work]] work cleanup
    try {
        set bytes [ico_build [dict get $o -svg] [dict get $o -sizes] [dict get $o -allpng] $work]
        set state [write_if_changed [dict get $o -ico] $bytes]
        set options "ico -sizes {[dict get $o -sizes]}"
        if {[dict get $o -allpng]} {append options " -allpng"}
        set sc [sidecar_content [dict get $o -ico] $bytes [dict get $o -svg] $role $options]
        set scstate [write_if_changed "[dict get $o -ico].assetorigin.toml" $sc]
        puts "wrote [dict get $o -ico] ([string length $bytes] bytes, [llength [dict get $o -sizes]] entries: [join [dict get $o -sizes] ,]) \[$state\]; sidecar \[$scstate\]"
    } finally {
        if {$cleanup} {file delete -force $work}
    }
}

proc cmd_raster {argl} {
    set o [opts_parse $argl {-svg {} -png {} -size {} -role web}]
    if {[dict get $o -svg] eq "" || [dict get $o -png] eq "" || [dict get $o -size] eq ""} {
        error "raster: -svg, -png and -size are required"
    }
    set size [dict get $o -size]
    set bytes [rasterize [dict get $o -svg] $size [dict get $o -png]]
    set sc [sidecar_content [dict get $o -png] $bytes [dict get $o -svg] [dict get $o -role] "raster -size $size"]
    set scstate [write_if_changed "[dict get $o -png].assetorigin.toml" $sc]
    puts "wrote [dict get $o -png] ([string length $bytes] bytes, ${size}px) sidecar \[$scstate\]"
}

proc cmd_all {argl} {
    global MANIFEST
    set o [opts_parse $argl {-check 0 -work {}}]
    set check [dict get $o -check]
    set here [file dirname [file normalize [info script]]]
    lassign [workdir_make [dict get $o -work]] work cleanup
    set drift 0
    try {
        foreach row $MANIFEST {
            lassign $row kind src artifact sizes allpng role
            set svg [file join $here $src]
            set out [file join $here $artifact]
            if {$kind eq "ico"} {
                set subwork [file join $work [string map {/ _} $artifact]]
                file mkdir $subwork
                set bytes [ico_build $svg $sizes $allpng $subwork]
                set options "ico -sizes {$sizes}"
                if {$allpng} {append options " -allpng"}
            } else {
                set bytes [rasterize $svg $sizes [file join $work [file tail $artifact]]]
                set options "raster -size $sizes"
            }
            set sc [sidecar_content $out $bytes $svg $role $options]
            if {$check} {
                set astate [check_against $out $bytes]
                set sstate [check_against "$out.assetorigin.toml" $sc]
                if {$astate ne "match"} {set drift 1}
                if {$sstate ne "match"} {set drift 1}
                puts [format "%-33s %-7s ([string length $bytes] bytes)  sidecar: %s" $artifact $astate $sstate]
            } else {
                set astate [write_if_changed $out $bytes]
                set sstate [write_if_changed "$out.assetorigin.toml" $sc]
                puts [format "%-33s %-9s ([string length $bytes] bytes)  sidecar: %s" $artifact $astate $sstate]
            }
        }
    } finally {
        if {$cleanup} {file delete -force $work}
    }
    if {$check && $drift} {
        puts "DRIFT: one or more artifacts or sidecars do not match a fresh regeneration"
        exit 1
    }
}

# ---------------------------------------------------------------- dispatch

set cmd [lindex $argv 0]
set rest [lrange $argv 1 end]
switch -- $cmd {
    ico    {cmd_ico $rest}
    raster {cmd_raster $rest}
    all    {cmd_all $rest}
    default {
        puts stderr "usage: tclsh make-ico.tcl all ?-check?"
        puts stderr "       tclsh make-ico.tcl ico -svg <in.svg> -ico <out.ico> ?-sizes {16 24 32 48 64 128 256}? ?-allpng? ?-role <role>? ?-work <dir>?"
        puts stderr "       tclsh make-ico.tcl raster -svg <in.svg> -png <out.png> -size <n> ?-role <role>?"
        exit 2
    }
}