# svgrender.tcl --
#
#       This file is a part of the Whiteboard plugin for Tkabber
#       XMPP client. It renders a subset of SVG on a Tk canvas.

package require Tk 8.5
catch {package require Img}

namespace eval svg {
    variable Debug 0
}

proc svg::loadFile {c filename} {
    set f [open $filename]
    set file [read $f]
    close $f

    ::xmpp::xml::parseData $file [namespace code [list parseSVGFile $c]]
}

proc svg::parseSVGFile {c xmldata} {
    Debug 2 $xmldata
    ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels

    if {$tag != "svg"} {
        return -code error "Not a SVG file"
    }

    parseSVGItem $c {} {} $xmldata
}

proc svg::parseSVGItem {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    switch -- $tag {
        svg {
            ParseSVG $c $transform $curAttrs $item
        }
        rect {
            ParseRect $c $transform $curAttrs $item
        }
        line {
            ParseLine $c $transform $curAttrs $item
        }
        polyline {
            ParsePolyline $c $transform $curAttrs $item
        }
        polygon {
            ParsePolygon $c $transform $curAttrs $item
        }
        circle {
            ParseCircle $c $transform $curAttrs $item
        }
        ellipse {
            ParseEllipse $c $transform $curAttrs $item
        }
        text {
            ParseText $c $transform $curAttrs $item
        }
        image {
            ParseImage $c $transform $curAttrs $item
        }
        g {
            ParseG $c $transform $curAttrs $attrs $subels
        }
        default {
            Debug 1 Unknown SVG tag '$tag'
            return ""
        }
    }
}

proc svg::ParseSVG {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    foreach subel $subels {
        parseSVGItem $c $transform $curAttrs $subel
    }
    return ""
}

proc svg::ParseG {c transform curAttrs attrs items} {
    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    array set Attrs $curAttrs
    array set Attrs $attrs
    set curAttrs [array get Attrs]

    foreach item $items {
        parseSVGItem $c $transform $curAttrs $item
    }
    return ""
}

proc svg::ParsePolygon {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    set p [TransformPoints $transform [::xmpp::xml::getAttr $attrs points]]

    array set Attrs $curAttrs
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem line

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            fill -
            stroke -
            stroke-width -
            stroke-linejoin {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    if {[info exists Attrs(fill)]} {
        set opts [PolygonOpts]
        set drawitem polygon
    } else {
        set opts [LineOpts]
        set drawitem line
        lappend p [lindex $p 0] [lindex $p 1]
    }

    Debug 2 $drawitem $p $opts
    eval [list $c create $drawitem] $p $opts
}

proc svg::ParseCircle {c transform curAttrs item} {
    variable Unitcircle

    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    array set Attrs $curAttrs
    array set Attrs {cx 0 cy 0 r 0}
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem circle

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            cx -
            cy -
            r -
            fill -
            stroke -
            stroke-width {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    set opts [CircleOpts]

    set points {}
    for {set i 0} {$i < 30} {incr i} {
        set a [expr {3.1415926 * $i / 15}]
        lappend points [expr {$Attrs(cx) + $Attrs(r)*cos($a)}] \
                       [expr {$Attrs(cy) + $Attrs(r)*sin($a)}]
    }

    set points [TransformPoints $transform $points]

    Debug 2 polygon $points $opts
    eval [list $c create polygon $points] $opts
}

proc svg::ParseEllipse {c transform curAttrs item} {
    variable Unitcircle

    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    array set Attrs $curAttrs
    array set Attrs {cx 0 cy 0 rx 0 ry 0}
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem circle

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            cx -
            cy -
            rx -
            ry -
            fill -
            stroke -
            stroke-width {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    set opts [CircleOpts]

    set points {}
    for {set i 0} {$i < 30} {incr i} {
        set a [expr {3.1415926 * $i / 15}]
        lappend points [expr {$Attrs(cx) + $Attrs(rx)*cos($a)}] \
                       [expr {$Attrs(cy) + $Attrs(ry)*sin($a)}]
    }

    set points [TransformPoints $transform $points]

    Debug 2 polygon $points $opts
    eval [list $c create polygon $points] $opts
}

proc svg::ParseLine {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    set x1 [::xmpp::xml::getAttr $attrs x1]
    set y1 [::xmpp::xml::getAttr $attrs y1]
    set x2 [::xmpp::xml::getAttr $attrs x2]
    set y2 [::xmpp::xml::getAttr $attrs y2]

    foreach {x1 y1} [TransformCoord $transform $x1 $y1] break
    foreach {x2 y2} [TransformCoord $transform $x2 $y2] break

    array set Attrs $curAttrs
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem line

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            stroke -
            stroke-width -
            stroke-linecap -
            stroke-linejoin {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    set opts [LineOpts]

    Debug 2 line $x1 $y1 $x2 $y2 $opts
    eval [list $c create line $x1 $y1 $x2 $y2] $opts
}

proc svg::ParseRect {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    set x      [::xmpp::xml::getAttr $attrs x]
    set y      [::xmpp::xml::getAttr $attrs y]
    set width  [::xmpp::xml::getAttr $attrs width]
    set height [::xmpp::xml::getAttr $attrs height]
    set rx     [::xmpp::xml::getAttr $attrs rx]
    set ry     [::xmpp::xml::getAttr $attrs ry]
    if {$rx != ""} {
        Debug 1 Round corners are ignored
    }
    set x2 [expr {$x + $width}]
    set y2 [expr {$y + $height}]

    foreach {xx yy} [TransformCoord $transform $x $y] break
    foreach {xx1 yy1} [TransformCoord $transform $x2 $y] break
    foreach {xx2 yy2} [TransformCoord $transform $x2 $y2] break
    foreach {xx3 yy3} [TransformCoord $transform $x $y2] break

    array set Attrs $curAttrs
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem line

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            stroke -
            stroke-width -
            stroke-linejoin {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    set opts [PolygonOpts]

    Debug 2 polygon $xx $yy $xx1 $yy1 $xx2 $yy2 $xx3 $yy3] $opts
    eval [list $c create polygon $xx $yy $xx1 $yy1 $xx2 $yy2 $xx3 $yy3] $opts
}

proc svg::ParsePolyline {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    set p [TransformPoints $transform [::xmpp::xml::getAttr $attrs points]]

    array set Attrs $curAttrs
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]
    set drawitem line

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        switch -- $attr {
            "" {}
            fill -
            stroke -
            stroke-width -
            stroke-linecap -
            stroke-linejoin {
                set Attrs($attr) $val
            }
            default {
                Debug 1 Unknown style attr '$attr'
            }
        }
    }

    set opts [LineOpts]

    Debug 2 line $p $opts
    eval [list $c create line] $p $opts
}

proc svg::ParseImage {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    set x  [::xmpp::xml::getAttr $attrs x]
    set y  [::xmpp::xml::getAttr $attrs y]

    if {$x == ""} {set x 0}
    if {$y == ""} {set y 0}

    foreach {x y} [TransformCoord $transform $x $y] break

    array set Attrs $curAttrs
    array set Attrs $attrs

    # Works only with BOB data included in the same XMPP stanza
    set cid [::xmpp::xml::getAttr $attrs http://www.w3.org/1999/xlink:href]

    if {[string first cid: $cid] != 0} {
        return
    }

    lassign [::xmpp::bob::get [string range $cid 4 end]] type data

    if {![info exists data] || $data == ""} {
        return ""
    }

    if {[catch {image create photo -data $data} image]} {
        return ""
    }

    bind $c <Destroy> +[list image delete $image]

    set opts [ImageOpts]

    Debug 2 image $x $y -image $image $opts
    eval [list $c create image $x $y -image $image] $opts
}

proc svg::ParseText {c transform curAttrs item} {
    ::xmpp::xml::split $item tag xmlns attrs cdata subels

    eval lappend transform \
         [ParseTransform [::xmpp::xml::getAttr $attrs transform]]

    set x  [::xmpp::xml::getAttr $attrs x]
    set y  [::xmpp::xml::getAttr $attrs y]

    if {$x == ""} {set x 0}
    if {$y == ""} {set y 0}

    foreach {x y} [TransformCoord $transform $x $y] break

    array set Attrs $curAttrs
    array set Attrs $attrs
    set styles [split [::xmpp::xml::getAttr $attrs style] \;]

    foreach s $styles {
        foreach {attr val} [split $s :] break
        set attr [string trim $attr]
        set val [string trim $val]
        set Attrs($attr) $val
    }

    set allopts [TextOpts]

    set opts [lindex $allopts 0]
    set fontopts [lindex $allopts 1]
    if {$fontopts != ""} {
        variable app_font
        set fontname [list font $fontopts]
        if {![info exists app_font($fontname)]} {
            # create a font to match the settings
            set app_font($fontname) \
                [eval [list font create $fontname] $fontopts]
        }
        lappend opts -font $app_font($fontname)
    }

    Debug 2 text $x $y -text $cdata $opts
    eval [list $c create text $x $y -text $cdata] $opts
}

proc svg::LineOpts {} {
    upvar Attrs Attrs
    upvar c c
    set opts {-joinstyle miter -capstyle butt}
    foreach {attr val} [array get Attrs] {
        switch -- $attr {
            "" {}
            stroke {lappend opts -fill [color $c $val]}
            stroke-width {lappend opts -width $val}
            stroke-linecap {
                switch -- $val {
                    round {lappend opts -capstyle round}
                    square {lappend opts -capstyle projecting}
                }
            }
            stroke-linejoin {
                switch -- $val {
                    round {lappend opts -joinstyle round}
                    bevel {lappend opts -joinstyle bevel}
                }
            }
            id {lappend opts -tags [list [list id $val]]}
        }
    }
    return $opts
}

proc svg::PolygonOpts {} {
    upvar Attrs Attrs
    upvar c c
    set opts {-joinstyle miter -fill "" -outline ""}
    foreach {attr val} [array get Attrs] {
        switch -- $attr {
            "" {}
            fill {
                if {$val != "" && $val != "none"} {
                    lappend opts -fill [color $c $val]
                }
            }
            stroke {
                if {$val != "" && $val != "none"} {
                    lappend opts -outline [color $c $val]
                }
            }
            stroke-width {lappend opts -width $val}
            stroke-linejoin {
                switch -- $val {
                    round {lappend opts -joinstyle round}
                    bevel {lappend opts -joinstyle bevel}
                }
            }
            id {lappend opts -tags [list [list id $val]]}
        }
    }
    return $opts
}

proc svg::CircleOpts {} {
    upvar Attrs Attrs
    upvar c c
    set opts {-smooth bezier -joinstyle round -fill "" -outline ""}
    foreach {attr val} [array get Attrs] {
        switch -- $attr {
            "" {}
            fill {
                if {$val != "" && $val != "none"} {
                    lappend opts -fill [color $c $val]
                }
            }
            stroke {
                if {$val != "" && $val != "none"} {
                    lappend opts -outline [color $c $val]
                }
            }
            stroke-width {lappend opts -width $val}
            id {lappend opts -tags [list [list id $val]]}
        }
    }
    return $opts
}

proc svg::ImageOpts {} {
    upvar Attrs Attrs
    upvar c c
    set opts {-anchor nw}
    foreach {attr val} [array get Attrs] {
        switch -- $attr {
            id {lappend opts -tags [list [list id $val]]}
        }
    }
    return $opts
}

proc svg::TextOpts {} {
    upvar Attrs Attrs
    upvar c c
    set opts {-anchor w}
    set fontopts {}
    foreach {attr val} [array get Attrs] {
        switch -- $attr {
            "" {}
            fill {lappend opts -fill [color $c $val]}
            font-family      {lappend fontopts -family $val}
            font-size        {lappend fontopts -size $val}
            font-size-adjust { # How to do this in Tk? }
            font-stretch     { # How to do this in Tk? }
            font-style       {  if {[string equal $val italic]
                                     || [string equal $val oblique]} {
                                    lappend fontopts -slant italic
                                }
                             }
            font-variant     { # How to do this in Tk? }
            font-weight      {  if {[string match bold* $val]} {
                                    lappend fontopts -weight bold
                                }
                             }
            text-decoration  {  foreach subval $val {
                                    switch -- $subval {
                                        underline {
                                            lappend fontopts -underline on
                                        }
                                        line-through {
                                            lappend fontopts -overstrike on
                                        }
                                    }
                                }
                             }
            dx   { # How to do this in Tk? }
            dy   { # How to do this in Tk? }
            id {lappend opts -tags [list [list id $val]]}
        }
    }
    return [list $opts $fontopts]
}


proc svg::TransformPoints {transform raw_points} {
    # SVG spec says coordinate points can be separated by comma or
    # white space or comma-with-white-space
    # string map...    convert , to space
    # regsub...        condense multiple whitespaces to single space
    regsub -all {\s\s*} [string map {, { }} [string trim $raw_points]] \
                { } points_str

    set p {}
    foreach {x y} [split $points_str] {
        eval lappend p [TransformCoord $transform $x $y]
    }
    return $p
}

proc svg::ParseTransform {s} {
    Debug 2 $s

    set t {}
    while {[regexp {(\w+)\s*\(([^\)]*)\)(.*)} $s temp transform param s]} {
        lappend t [list $transform [split $param ", "]]
    }

    Debug 1 $s $t
    return $t
}

proc svg::TransformCoord {transform x y} {
    Debug 2 $transform $x $y

    set matrix [list 1 0 0 1 0 0]

    foreach t $transform {
        foreach {op param} $t break
        switch -- $op/[llength $param] {
            matrix/6 {
                set matrix [Tcompose $matrix $param]
            }
            translate/1 {
                foreach tx $param break
                set matrix [Tcompose $matrix [list 1 0 0 1 $tx 0]]
            }
            translate/2 {
                foreach {tx ty} $param break
                set matrix [Tcompose $matrix [list 1 0 0 1 $tx $ty]]
            }
            scale/1 {
                foreach sx $param break
                set matrix [Tcompose $matrix [list $sx 0 0 $sx 0 0]]
            }
            scale/2 {
                foreach {sx sy} $param break
                set matrix [Tcompose $matrix [list $sx 0 0 $sy 0 0]]
            }
            rotate/1 {
                foreach a $param break
                set a [expr {3.1415926 * $a / 180}]
                set matrix [Tcompose $matrix \
                                [list [expr {cos($a)}]  [expr {sin($a)}] \
                                      [expr {-sin($a)}] [expr {cos($a)}] 0 0]]
            }
            rotate/3 {
                foreach {a cx cy} $param break
                set a [expr {3.1415926 * $a / 180}]
                set matrix [Tcompose $matrix [list 1 0 0 1 $cx $cy]]
                set matrix [Tcompose $matrix \
                                [list [expr {cos($a)}]  [expr {sin($a)}] \
                                      [expr {-sin($a)}] [expr {cos($a)}] 0 0]]
                set matrix [Tcompose $matrix \
                                [list 1 0 0 1 [expr {-$cx}] [expr {-$cy}]]]
            }
            skewX/1 {
                foreach a $param break
                set a [expr {3.1415926 * $a / 180}]
                set matrix [Tcompose $matrix [list 1 0 [expr {tan($a)}] 1 0 0]]
            }
            skewY/1 {
                foreach a $param break
                set a [expr {3.1415926 * $a / 180}]
                set matrix [Tcompose $matrix [list 1 [expr {tan($a)}] 0 1 0 0]]
            }
        }
    }

    return [Tapply $matrix $x $y]
}

proc svg::Tcompose {matrix1 matrix2} {
    Debug 2 [list $matrix1] [list $matrix2]

    foreach {a1 b1 c1 d1 e1 f1} $matrix1 break
    foreach {a2 b2 c2 d2 e2 f2} $matrix2 break

    set a [expr {$a1*$a2 + $c1*$b2}]
    set b [expr {$b1*$a2 + $d1*$b2}]
    set c [expr {$a1*$c2 + $c1*$d2}]
    set d [expr {$b1*$c2 + $d1*$d2}]
    set e [expr {$a1*$e2 + $c1*$f2 + $e1}]
    set f [expr {$b1*$e2 + $d1*$f2 + $f1}]

    return [list $a $b $c $d $e $f]
}

proc svg::Tapply {matrix x y} {
    Debug 2 [list $matrix] $x $y

    foreach {a b c d e f} $matrix break
    set x1 [expr {$a*$x + $c*$y + $e}]
    set y1 [expr {$b*$x + $d*$y + $f}]

    Debug 1 $x1 $y1
    return [list $x1 $y1]
}

proc svg::color {c color} {
    Debug 2 $color

    if {[catch {$c create line 0 0 0 0 -fill $color -width 0} id]} {
        return black
    } else {
        $c delete $id
        return $color
    }
}

proc svg::Debug {level args} {
    variable Debug

    if {$Debug >= $level} {
        puts "[lindex [info level -1] 0]: [join $args]"
    }
}

# vim:ft=tcl:ts=8:sw=4:sts=4:et
