Check-in [bf021ad209]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:improve twv examples
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: bf021ad209dcfd7b9e045f51ab46857f4a3706d5
User & Date: chw 2019-07-02 03:58:53
Context
2019-07-02
04:04
add tk upstream changes check-in: 4063ca24da user: chw tags: trunk
03:58
improve twv examples check-in: bf021ad209 user: chw tags: trunk
2019-07-01
15:58
attempt to fix ticket [e3c6fbfa6f], now for menubuttons check-in: 4d5c3bdcce user: chw tags: trunk
Changes

Changes to undroid/tsb/tsb.tcl.

521
522
523
524
525
526
527





528
529
530
531
532
533
534
535
536
537
...
548
549
550
551
552
553
554
555
556
557
558
559
560



561


562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
...
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
...
710
711
712
713
714
715
716



717
718
719
720
721
722
723
724
725
726
727
728
729
730
	}
	return $all
    }

    proc canvascmd {c cmd args} {
	variable C
	set ret ""





	switch -glob -- $cmd {
	    cr* {
		# create
		set args [lassign $args type]
		set id [incr C($c,id)]
		set coords {}
		set count 0
		foreach arg $args {
		    if {[string is double $arg]} {
			lappend coords $arg
................................................................................
			set opt -tags
		    }
		    dict set C($c,$id) $opt $val
		}
		lappend C($c,dlist) $id
		set ret $id
	    }
	    bb* {
		# bbox, assumes measuring text item with "M"
		set ret {0 0 12 16}
	    }
	    cg* {
		# cget



		switch -glob -- [lindex $args 0] {


		    -bd - -bo* {
			set ret 0
		    }
		    -wi* {
			set ret $C($c,width)
		    }
		    -he* {
			set ret $C($c,height)
		    }
		}
	    }
	    ra* {
		# raise
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			lappend all $t
		    }
		}
		set C($c,dlist) $all
	    }
	    lo* {
		# lower
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			set all [linsert $all 0 $t]
		    }
		}
		set C($c,dlist) $all
	    }
	    des* {
		# destroy
		set cmd $C($c,cmd)
		foreach name [array names C $c,*] {
		    unset C($name)
		}
		rename "::$cmd" {}
	    }
	    de* {
		# delete
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			unset C($c,$t)
		    }
		}
		set C($c,dlist) $all
	    }
	    coo* {
		# coords
		set coords [lassign $args id]
		if {![info exists C($c,$id)]} {
		    foreach item $C($c,dlist) {
			set t [dict get $C($c,$item) -tags]
			if {$id in $t} {
			    if {[llength $coords]} {
				dict set C($c,$item) -coords $coords
................................................................................
		    }
		} elseif {[llength $coords]} {
		    dict set C($c,$id) -coords $coords
		} else {
		    set ret [dict get $C($c,$id) -coords]
		}
	    }
	    fi* {
		# find ?withtag?
		set args [lassign $args tags]
		if {$tags eq "withtag"} {
		    lassign $args tags
		}
		set ret [tagfind $c $tags]
	    }
	    sv* {
		# svg
		set vx ""
		set vy ""
		set vw ""
		set vh ""
		lassign $args vx vy vw vh
		package require can2svg
		set xml "<?xml version='1.0'?>\n"
................................................................................
	set C($cid,cmd) $cmd
	set C($cid,dlist) {}
	set C($cid,width) 640
	set C($cid,height) 480
	set C($cid,id) 0
	incr C(cid)
	foreach {key value} $args {



	    switch -glob -- $key {
		-wi* {
		    if {[scan $value %d value]} {
			set C($cid,width) $value
		    }
		}
		-he* {
		    if {[scan $value %d value]} {
			set C($cid,height) $value
		    }
		}
	    }
	}
	return $cmd







>
>
>
>
>

<
|







 







|
|


<
|
>
>
>
|
>
>
|


|


|




<
|











<
|











<
|






<
|











<
|







 







|







<
|







 







>
>
>

|




|







521
522
523
524
525
526
527
528
529
530
531
532
533

534
535
536
537
538
539
540
541
...
552
553
554
555
556
557
558
559
560
561
562

563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580

581
582
583
584
585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603
604

605
606
607
608
609
610
611

612
613
614
615
616
617
618
619
620
621
622
623

624
625
626
627
628
629
630
631
...
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650

651
652
653
654
655
656
657
658
...
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
	}
	return $all
    }

    proc canvascmd {c cmd args} {
	variable C
	set ret ""
	if {![catch {tcl::prefix match {
	    create bbox cget raise lower destroy delete coords find svg
	} ncmd}]} {
	    set cmd $ncmd
	}
	switch -glob -- $cmd {

	    create {
		set args [lassign $args type]
		set id [incr C($c,id)]
		set coords {}
		set count 0
		foreach arg $args {
		    if {[string is double $arg]} {
			lappend coords $arg
................................................................................
			set opt -tags
		    }
		    dict set C($c,$id) $opt $val
		}
		lappend C($c,dlist) $id
		set ret $id
	    }
	    bbox {
		# assumes measuring text item with "M"
		set ret {0 0 12 16}
	    }

	    cget {
		if {[catch {tcl::prefix match {
		    -bd -borderwidth -width -height
		} [lindex $args 0]} opt]} {
		    set opt [lindex $args 0]
		}
		switch -glob -- $opt {
		    -bd - -borderwidth {
			set ret 0
		    }
		    -width {
			set ret $C($c,width)
		    }
		    -height {
			set ret $C($c,height)
		    }
		}
	    }

	    raise {
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			lappend all $t
		    }
		}
		set C($c,dlist) $all
	    }

	    lower {
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			set all [linsert $all 0 $t]
		    }
		}
		set C($c,dlist) $all
	    }

	    destroy {
		set cmd $C($c,cmd)
		foreach name [array names C $c,*] {
		    unset C($name)
		}
		rename "::$cmd" {}
	    }

	    delete {
		lassign $args tags
		set all $C($c,dlist)
		foreach t [tagfind $c $tags] {
		    set n [lsearch -exact $all $t]
		    if {$n >= 0} {
			set all [lreplace $all $n $n]
			unset C($c,$t)
		    }
		}
		set C($c,dlist) $all
	    }

	    coords {
		set coords [lassign $args id]
		if {![info exists C($c,$id)]} {
		    foreach item $C($c,dlist) {
			set t [dict get $C($c,$item) -tags]
			if {$id in $t} {
			    if {[llength $coords]} {
				dict set C($c,$item) -coords $coords
................................................................................
		    }
		} elseif {[llength $coords]} {
		    dict set C($c,$id) -coords $coords
		} else {
		    set ret [dict get $C($c,$id) -coords]
		}
	    }
	    find {
		# find ?withtag?
		set args [lassign $args tags]
		if {$tags eq "withtag"} {
		    lassign $args tags
		}
		set ret [tagfind $c $tags]
	    }

	    svg {
		set vx ""
		set vy ""
		set vw ""
		set vh ""
		lassign $args vx vy vw vh
		package require can2svg
		set xml "<?xml version='1.0'?>\n"
................................................................................
	set C($cid,cmd) $cmd
	set C($cid,dlist) {}
	set C($cid,width) 640
	set C($cid,height) 480
	set C($cid,id) 0
	incr C(cid)
	foreach {key value} $args {
	    if {![catch {tcl::prefix match {-width -height} $key} nkey]} {
		set key $nkey
	    }
	    switch -glob -- $key {
		-width {
		    if {[scan $value %d value]} {
			set C($cid,width) $value
		    }
		}
		-height {
		    if {[scan $value %d value]} {
			set C($cid,height) $value
		    }
		}
	    }
	}
	return $cmd