1# *- tcl -*-
2# ### ### ### ######### ######### #########
3
4# Copyright (c) 2010 Wolf-Dieter Busch
5# Origin http://wiki.tcl.tk/26859 [23-08-2010]
6# OLL licensed (http://wiki.tcl.tk/10892).
7
8# ### ### ### ######### ######### #########
9## Requisites
10
11package require Tcl 8.5
12package require Tk  8.5
13
14namespace eval ::canvas {}
15
16# ### ### ### ######### ######### #########
17## Implementation.
18
19proc ::canvas::mvg {canvas} {
20
21    #raise [winfo toplevel $canvas]
22    #update
23
24    # Initialize drawing state... This array is keyed by the MVG
25    # commands for the attribute, not by the canvas options, and not
26    # by something third.
27    array set mode {
28	fill            {}
29	stroke          {}
30	stroke-width    {}
31	stroke-linejoin {}
32	stroke-linecap  {}
33	font            {}
34	font-size       {}
35    }
36
37    # Get the bounding box of all item, and compute the translation
38    # required to put the lower-left corner at the origin.
39    set dx 0
40    set dy 0
41    set box [$canvas bbox {*}[$canvas find all]]
42    lassign $box zx zy ex ey
43    if {$zx < 0} { set dx [expr {- $zx}] ; set ex [expr {$ex + $dx}] }
44    if {$zy < 0} { set dy [expr {- $zy}] ; set ey [expr {$ey + $dy}] }
45    set box [list 0 0 $ex $ey]
46
47    # Standard prelude...
48    mvg::Emit [list viewbox {*}$box]
49    mvg::EmitChanged stroke none
50    mvg::EmitChanged fill   [mvg::Col2Hex $canvas]
51    mvg::Emit [list rectangle {*}$box]
52
53    # Introspect the canvas, i.e. convert each item to MVG
54    foreach item [$canvas find all] {
55	set type [$canvas type $item]
56
57	# Info to help debugging...
58	mvg::Emit "# $type ... [$canvas gettags $item]"
59
60	# Dump the item's attributes, as they are supported by it.
61	# Note how the code is not sliced by item type which then
62	# handles each of its attributes, but by attribute name, which
63	# then checks if the type of the current item supports it.
64
65	# Further note that the current attribute state is stored in
66	# the mode array and actually emitted if and only if it is
67	# different from the previously drawn state. This optimizes
68	# the number of commands needed to set the drawing state for a
69	# particular item.
70
71	# outline width
72	if {$type in {polygon oval arc rectangle line}} then {
73	    mvg::EmitValue $item -width stroke-width
74	}
75
76	# fill, stroke
77	if {$type in {polygon oval arc rectangle}} {
78	    mvg::EmitColor $item -fill    fill
79	    mvg::EmitColor $item -outline stroke
80	}
81
82	# joinstyle
83	if {$type in {polygon}} then {
84	    mvg::EmitValue $item -joinstyle stroke-linejoin
85	}
86
87	# line color, capstyle
88	if {$type in {line}} then {
89	    mvg::EmitChanged fill none
90	    mvg::EmitColor $item -fill     stroke
91	    mvg::EmitCap   $item -capstyle stroke-linecap
92	}
93
94	# text color, font, size
95	if {$type in {text}} then {
96	    # Compute font-family, font-size
97	    set font [$canvas itemcget $item -font]
98	    if {$font in [font names]} {
99		set fontsize   [font configure $font -size]
100		set fontfamily [font configure $font -family]
101	    } else {
102		if {[llength $font] == 1} then {
103		    set fontsize 12
104		} else {
105		    set fontsize [lindex $font 1]
106		}
107		set fontfamily [lindex $font 0]
108	    }
109	    if {$fontsize < 0} {
110		set fontsize [expr {int(-$fontsize / [tk scaling])}]
111	    }
112
113	    mvg::EmitChanged stroke none
114	    mvg::EmitColor $item -fill fill
115	    mvg::EmitChanged font-size $fontsize
116	    mvg::EmitChanged font $fontfamily
117
118	    #
119	    # Attention! In some cases ImageMagick assumes 72dpi where
120	    # 90dpi is necessary. If that happens use the switch
121	    # -density to force the correct dpi setting, like %
122	    # convert -density 90 test.mvg test.png
123	    #
124	    # Attention! Make sure that ImageMagick has access to the
125	    # used fonts. If it has not, an error msg will be shown,
126	    # and then switches silently to the default font.
127	    #
128	}
129
130	# After the attributes we can emit the command actually
131	# drawing the item, in the its place.
132
133	set line {}
134	set coords [mvg::Translate [$canvas coords $item]]
135
136	switch -exact -- $type {
137	    line {
138		# start of path
139		lappend line path 'M
140
141		# smooth can be any boolean value, plus the name of a
142		# line smoothing method. Core supports only 'raw'.
143		# This however is extensible through packages.
144
145		switch -exact -- [mvg::Smooth $item] {
146		    0 {
147			lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end]
148		    }
149		    1 {
150			if {[$canvas itemcget $item -arrow] eq "none"} {
151			    lappend line {*}[mvg::Spline2MVG $coords]
152			} else {
153			    lappend line {*}[mvg::Spline2MVG $coords false]
154			}
155		    }
156		    2 {
157			lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
158		    }
159		}
160
161		append line '
162		mvg::Emit $line
163	    }
164	    polygon {
165		# start of path.
166		lappend line path 'M
167
168		switch -exact -- [mvg::Smooth $item] {
169		    0 {
170			lassign $coords x0 y0
171			lassign [lrange $coords end-1 end] x1 y1
172			set x [expr {($x0+$x1)/2.0}]
173			set y [expr {($y0+$y1)/2.0}]
174			lappend line $x $y L {*}$coords $x $y Z
175		    }
176		    1 {
177			lassign $coords x0 y0
178			lassign [lrange $coords end-1 end] x1 y1
179			if {($x0 != $x1) || ($y0 != $y1)} {
180			    lappend coords {*}[lrange $coords 0 1]
181			}
182			lappend line {*}[mvg::Spline2MVG $coords]
183		    }
184		    2 {
185			lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
186		    }
187		}
188
189		append line '
190		mvg::Emit $line
191	    }
192	    oval {
193		lassign $coords x0 y0 x1 y1
194		set xc [expr {($x0+$x1)/2.0}]
195		set yc [expr {($y0+$y1)/2.0}]
196
197		mvg::Emit [list ellipse $xc $yc [expr {$x1-$xc}] [expr {$y1-$yc}] 0 360]
198	    }
199	    arc {
200		lassign $coords x0 y0 x1 y1
201
202		set rx [expr {($x1-$x0)/2.0}]
203		set ry [expr {($y1-$y0)/2.0}]
204		set x  [expr {($x0+$x1)/2.0}]
205		set y  [expr {($y0+$y1)/2.0}]
206		set f  [expr {acos(0)/90}]
207
208		set start  [$canvas itemcget $item -start]
209		set startx [expr {cos($start*$f)*$rx+$x}]
210		set starty [expr {sin(-$start*$f)*$ry+$y}]
211		set angle  [expr {$start+[$canvas itemcget $item -extent]}]
212		set endx   [expr {cos($angle*$f)*$rx+$x}]
213		set endy   [expr {sin(-$angle*$f)*$ry+$y}]
214
215		# start path
216		lappend line path 'M
217		# start point
218		lappend line $startx $starty
219		lappend line A
220		# radiusx, radiusy
221		lappend line $rx $ry
222		# angle -- always 0
223		lappend line 0
224		# "big" or "small"?
225		lappend line [expr {($angle-$start) > 180}]
226		# right side (always)
227		lappend line 0
228		# end point
229		lappend line $endx $endy
230		# close path
231		lappend line L $x $y Z
232		append line '
233
234		mvg::Emit $line
235	    }
236	    rectangle {
237		mvg::Emit [list rectangle {*}$coords]
238	    }
239	    text {
240		lassign [mvg::Translate [$canvas bbox $item]] x0 y0 x1 y1
241		mvg::Emit "text $x0 $y1 '[$canvas itemcget $item -text]'"
242	    }
243	    image - bitmap {
244		set img  [$canvas itemcget $item -image]
245		set file [$img cget -file]
246		lassign  [mvg::Translate [$canvas bbox $item]] x0 y0
247		mvg::Emit "image over $x0 $y0 0 0 '$file'"
248	    }
249	    default {
250		set    line "# not yet done:"
251		append line " "  [$canvas type $item]
252		append line " "  [mvg::Translate [$canvas coords $item]]
253		append line " (" [$canvas gettags $item] ")"
254		mvg::Emit $line
255	    }
256	}
257    }
258
259    # At last, return the fully assembled snapshot
260    return [join $result \n]
261}
262
263# ### ### ### ######### ######### #########
264## Helper commands. Internal.
265
266namespace eval ::canvas::mvg {}
267
268proc ::canvas::mvg::Translate {coords} {
269    upvar 1 dx dx dy dy
270    set tmp {}
271    foreach {x y} $coords {
272	lappend tmp [expr {$x + $dx}] [expr {$y + $dy}]
273    }
274    return $tmp
275}
276
277
278proc ::canvas::mvg::Smooth {item} {
279    upvar 1 canvas canvas
280
281    # Force smooth to canonical values we can then switch on.
282    set smooth [$canvas itemcget $item -smooth]
283    if {[string is boolean $smooth]} {
284	if {$smooth} {
285	    return 1
286	} else {
287	    return 0
288	}
289    } else {
290	return 2
291    }
292}
293
294proc ::canvas::mvg::EmitValue {item option cmd} {
295    upvar 1 mode mode result result canvas canvas
296
297    EmitChanged $cmd \
298	[$canvas itemcget $item $option]
299    return
300}
301
302proc ::canvas::mvg::EmitColor {item option cmd} {
303    upvar 1 mode mode result result canvas canvas
304
305    EmitChanged $cmd \
306	[Col2Hex [$canvas itemcget $item $option]]
307    return
308}
309
310proc ::canvas::mvg::EmitCap {item option cmd} {
311    upvar 1 mode mode result result canvas canvas
312
313    EmitChanged $cmd \
314	[dict get {
315	    butt       butt
316	    projecting square
317	    round      round
318	} [$canvas itemcget $item $option]]
319    return
320}
321
322proc ::canvas::mvg::EmitChanged {cmd value} {
323    upvar 1 mode mode result result
324
325    if {$mode($cmd) eq $value} return
326    set mode($cmd) $value
327    Emit [list $cmd $value]
328    return
329}
330
331proc ::canvas::mvg::Emit {command} {
332    upvar 1 result result
333    lappend result $command
334    return
335}
336
337proc ::canvas::mvg::Col2Hex {color} {
338    # This command or similar functionality we might have somewhere
339    # in tklib already ...
340
341    # Special handling of canvas widgets, use their background color.
342    if {[winfo exists $color] && [winfo class $color] eq "Canvas"} {
343	set color [$color cget -bg]
344    }
345    if {$color eq ""} {
346	return none
347    }
348    set result #
349    foreach x [winfo rgb . $color] {
350	append result [format %02x [expr {int($x / 256)}]]
351    }
352    return $result
353}
354
355proc ::canvas::mvg::Spline2MVG {coords {canBeClosed yes}} {
356    set closed [expr {$canBeClosed &&
357		      [lindex $coords 0] == [lindex $coords end-1] &&
358		      [lindex $coords 1] == [lindex $coords end]}]
359
360    if {$closed} {
361	lassign [lrange $coords end-3 end] x0 y0 x1 y1
362
363	set x [expr {($x0+$x1)/2.0}]
364	set y [expr {($y0+$y1)/2.0}]
365
366	lset coords end-1 $x
367	lset coords end $y
368
369	set coords [linsert $coords 0 $x $y]
370    }
371
372    if {[llength $coords] != 6} {
373	lappend tmp {*}[lrange $coords 0 1]
374
375	set co1 [lrange $coords 2 end-4]
376	set co2 [lrange $coords 4 end-2]
377
378	foreach {x1 y1} $co1 {x2 y2} $co2 {
379	    lappend tmp $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}]
380	}
381	lappend tmp {*}[lrange $coords end-3 end]
382	set coords $tmp
383    }
384
385    return [lreplace $coords 2 1 Q]
386}
387
388# ### ### ### ######### ######### #########
389## Ready
390
391package provide canvas::mvg 1
392return
393