path: root/demos/transforms.tcl

# $Id$
# This simple demo has been developped by P. Lecoanet <lecoanet@cena.fr>

#
# TODO:
#
# Add the building of missing items
#

if {![info exists zincDemo]} {
    error "This script should be run from the zinc-widget demo."
}

set w .transforms
catch {destroy $w}
toplevel $w
wm title $w "Zinc Transformation Demonstration"
wm iconname $w Transformation

set defaultfont [font create -family Helvetica -size 10 -weight bold]

frame $w.buttons
pack $w.buttons -side bottom -fill x -pady 2m
button $w.buttons.dismiss -text Dismiss -command "destroy $w"
button $w.buttons.code -text "See Code" -command "showCode $w"
pack $w.buttons.dismiss $w.buttons.code -side left -expand 1


###########################################
# Text zone
###########################################
text $w.text -relief sunken -borderwidth 2 -setgrid true -height 12

pack $w.text -expand yes -fill x

$w.text insert 0.0 {Items are always added to the current group.
The available commands are:
   Button 1         on the background, add an item with initial translation
   Button 2         on the background, add a group with initial translation
   Button 1         on item/group axes, select/deselect that item coordinates
   Drag Button 1    on item/group axes, translate that item coordinates
   Home             reset the transformation
   Shift-Home       reset a group direct children transformations
   +/-              scale the selected item up/down
   Ctrl-Left/Right  rotate the selected item right/left
   Shift-Up/Down    swap the selected item Y axis
   Shift-Left/Right swap the selected item X axis
   4 arrows         translate in the 4 directions
   Delete           destroy the selected item}
$w.text configure -state disabled

###########################################
# Zinc
###########################################
set zinc_width 600
set zinc_height 500;
zinc $w.zinc -width $zinc_width -height $zinc_height \
    -font 10x20 -borderwidth 3 -relief sunken -takefocus 1 -render 0
pack $w.zinc -expand y -fill both


set top 1

set inactiveAxisColor blue
set activeAxisColor red
set worldAxisColor \#a5a5a5

set composeRot 1
set composeScale 1
set drag 0
set itemType Rectangle
set currentItem 0

image create photo logo -file [file join $zinc_library demos images zinc.gif]

frame $w.f
pack $w.f -expand 0 -fill x

tk_optionMenu $w.f.types itemType Rectangle Arc Curve Icon Tabular \
    Text Track Triangles WayPoint
grid $w.f.types -row 0 -column 1 -sticky w

button $w.f.add -text {Add item} -command "addItem $w.zinc"
grid $w.f.add -row 0 -column 2 -padx 10 -sticky ew

button $w.f.addg -text {Add group} -command "addGroup $w.zinc"
grid $w.f.addg -row 0 -column 3 -padx 10 -sticky ew

button $w.f.remove -text Remove -command "removeItem $w.zinc"
grid $w.f.remove -row 0 -column 4 -padx 10 -sticky ew

checkbutton $w.f.cscale -text -composescale -command "toggleComposeScale $w.zinc" \
    -variable composeScale
grid $w.f.cscale -row 0 -column 6 -sticky w

checkbutton $w.f.crot -text -composesrotation -command "toggleComposeRot $w.zinc" \
    -variable composeRot
grid $w.f.crot -row 1 -column 6 -sticky w


set world [$w.zinc add group $top]
set currentGroup $world
$w.zinc add curve $top {0 0 80 0} -linewidth 3 \
    -linecolor $worldAxisColor -lastend {6 8 3} -tags axis:$world
$w.zinc add curve $top {0 0 0 80} -linewidth 3 \
    -linecolor $worldAxisColor -lastend {6 8 3} -tags axis:$world
$w.zinc add rectangle $top {-2 -2 2 2} -filled 1 \
    -fillcolor $worldAxisColor -linecolor $worldAxisColor \
    -linewidth 3 -tags axis:$world
$w.zinc add text $top -text "This is the origin\nof the world" \
    -anchor s -color $worldAxisColor -alignment center \
    -tags [list "axis:$world" text]
$w.zinc lower axis:$world

bind $w.zinc <1> {mouseAdd %W Item %x %y}
bind $w.zinc <2> {mouseAdd %W Group %x %y}
bind $w.zinc <Up> {moveUp %W}
bind $w.zinc <Left> {moveLeft %W}
bind $w.zinc <Right> {moveRight %W}
bind $w.zinc <Down> {moveDown %W}
bind $w.zinc <minus> {scaleDown %W}
bind $w.zinc <KP_Subtract> {scaleDown %W}
bind $w.zinc <plus> {scaleUp %W}
bind $w.zinc <KP_Add> {scaleUp %W}
bind $w.zinc <Home> {reset %W}
bind $w.zinc <Shift-Home> {resetChildren %W}
bind $w.zinc <Control-Left> {rotateLeft %W}
bind $w.zinc <Control-Right> {rotateRight %W}
bind $w.zinc <Shift-Up> {swapAxis %W y}
bind $w.zinc <Shift-Down> {swapAxis %W y}
bind $w.zinc <Shift-Left> {swapAxis %W x}
bind $w.zinc <Shift-Right> {swapAxis %W x}
bind $w.zinc <Delete> {removeItem %W}

bind $w.zinc <Configure> {resize %W %w %h}

focus $w.zinc
tk_focusFollowsMouse


proc resize {z width height} {
    global world

    set x [expr $width/2]
    set y [expr $height/2]
    
    $z treset $world
    $z treset axis:$world
    $z translate $world $x $y
    $z translate axis:$world $x $y
}

proc swapAxis {z axis} {
    global currentItem

    set sx 1
    set sy 1
    if { $axis eq "x" } {
	set sx -1
    } elseif { $axis eq "y" } {
	set sy -1
    }
    if {$currentItem != 0} {
	$z scale $currentItem $sx $sy
	$z scale axisgrp:$currentItem $sx $sy
    }
}

proc toggleComposeRot {z} {
    global currentItem composeRot

    if {$currentItem != 0} {
    $z itemconfigure $currentItem -composerotation $composeRot
    $z itemconfigure axisgrp:$currentItem -composerotation $composeRot
  }
}

proc toggleComposeScale {z} {
    global currentItem composeScale
    
    if {$currentItem != 0} {
	$z itemconfigure $currentItem -composescale $composeScale
	$z itemconfigure axisgrp:$currentItem -composescale $composeScale
    }
}

proc removeItem {z} { 
    global currentGroup currentItem world
    
    if {$currentItem != 0} {
	$z remove $currentItem axisgrp:$currentItem
	if {$currentItem == $currentGroup} {
	    set currentGroup $world
	}
	set currentItem 0
	set composeScale 1
	set composeRot 1
    }
}

proc dragItem {z x y} {
    global drag currentItem

    set drag 1
    if {$currentItem == 0} {
	return
    }
    
    set group [$z group $currentItem]
    foreach {x y} [$z transform $group [list $x $y]] break
    
    $z treset $currentItem
    $z treset axisgrp:$currentItem
    $z translate $currentItem $x $y
    $z translate axisgrp:$currentItem $x $y
}

proc select {z} {
    foreach t [$z gettags current] {
	if {[regexp {^axis:(\d+)} $t m item]} {
	    changeItem $z $item
	}
    }
}

proc changeItem {z item} {
    global currentItem currentGroup
    global composeRot composeScale
    global drag activeAxisColor inactiveAxisColor

    if {($currentItem != 0) && !$drag} {
	$z itemconfigure axis:$currentItem&&!text \
	    -linecolor $inactiveAxisColor -fillcolor $inactiveAxisColor
    }
    if {($currentItem == 0) || ($item != $currentItem)} {
	$z itemconfigure axis:$item&&!text \
	    -linecolor $activeAxisColor -fillcolor $activeAxisColor -linewidth 3
	set currentItem $item
	set composeRot [$z itemcget $currentItem -composerotation]
	$z itemconfigure axisgrp:$currentItem -composerotation $composeRot
	set composeScale [$z itemcget $currentItem -composescale]
	$z itemconfigure axisgrp:$currentItem -composescale $composeScale
    } elseif {!$drag} {
	set currentItem 0
	set composeRot 1
	set composeScale 1
    }
}

proc selectGroup {z} {
    foreach t [$z gettags current] {
	if {[regexp {^axis:(\d+)} $t m item]} {
	    changeGroup $z $item
	    return
	}
    }
}

proc changeGroup {z grp} {
    global currentItem currentGroup world
    
    changeItem $z $grp
    if {$currentItem != 0} {
	set currentGroup $currentItem
    } else {
	set currentGroup $world
    }
}

proc reset {z } {
    global currentItem

    if {$currentItem != 0} {
	$z treset $currentItem
	$z treset axisgrp:$currentItem
    }
}

proc resetChildren {z} {
    global currentItem

    if {($currentItem != 0) && ([$z type $currentItem] == "group")} {
	$z addtag rt withtag .$currentItem.
	$z treset rt
	$z dtag rt rt
    }
}

proc moveUp {z} {
  move $z 0 20
}

proc moveDown {z} {
  move $z 0 -20
}

proc moveRight {z} {
  move $z 20 0
}

proc moveLeft {z} {
  move $z -20 0
}

proc move {z dx dy} {
    global currentItem

    if {$currentItem != 0} {
	$z translate $currentItem $dx $dy
	$z translate axisgrp:$currentItem $dx $dy
    }
}

proc scaleUp {z} {
  scale $z 1.1 1.1
}

proc scaleDown {z} {
  scale $z 0.9 0.9
}

proc scale {z dx dy} {
    global currentItem

    if {$currentItem != 0} {
	$z scale $currentItem $dx $dy
	$z scale axisgrp:$currentItem $dx $dy
    }
}

proc rotateLeft {z} {
    rotate $z [expr -3.14159/18]
}

proc rotateRight {z} {
    rotate $z [expr 3.14159/18]
}

proc rotate {z angle} {
    global currentItem
    
    if {$currentItem != 0} {
	$z rotate $currentItem $angle
	$z rotate axisgrp:$currentItem $angle
    }
}

proc newRectangle {z} {
    global currentGroup

    return [$z add rectangle $currentGroup {-15 -15 15 15} \
		-filled 1 -linewidth 0 -fillcolor tan]
}

proc newArc {z} {
    global currentGroup

    return [$z add arc $currentGroup {-25 -15 25 15} \
		-filled 1 -linewidth 0 -fillcolor tan]
}

proc newCurve {z} {
    global currentGroup

    return [$z add curve $currentGroup {-15 -15 -15 15 15 15 15 -15} \
		-filled 1 -linewidth 0 -fillcolor tan]
}

proc newText {z} {
    global currentGroup

    set item [$z add text $currentGroup -anchor s]
    $z itemconfigure $item -text "Item id: $item"
    return $item;
}

proc newIcon {z} {
    global currentGroup

    return [$z add icon $currentGroup -image logo -anchor center]
}

proc newTriangles {z} {
    global currentGroup

    return [$z add triangles $currentGroup \
		{-25 15 -10 -15 5 15 20 -15 35 15 50 -30} \
		-colors {tan wheat tan wheat}]
}

proc newTrack {z} {
    global currentGroup

    set labelformat {x80x50+0+0 a0a0^0^0 a0a0^0>1 a0a0>2>1 x30a0>3>1 a0a0^0>2}
    
    set item [$z add track $currentGroup 6 -labelformat $labelformat \
		  -speedvector {30 -15} -markersize 20]
    $z itemconfigure $item 0 -filled 0 -bordercolor DarkGreen -border contour
    $z itemconfigure $item 1 -filled 1 -backcolor gray60 -text AFR6128
    $z itemconfigure $item 2 -filled 0 -backcolor gray65 -text 390
    $z itemconfigure $item 3 -filled 0 -backcolor gray65 -text /
    $z itemconfigure $item 4 -filled 0 -backcolor gray65 -text 350
    $z itemconfigure $item 5 -filled 0 -backcolor gray65 -text TUR

    return $item;
}

proc newWayPoint {z} {
    global currentGroup

    set labelformat {a0a0+0+0 a0a0>0^1}

    set item [$z add waypoint $currentGroup 2 -labelformat $labelformat]
    $z itemconfigure $item 0 -filled 1 -backcolor DarkGreen -text TUR
    $z itemconfigure $item 1 -text >>>

    return $item;
}

proc newTabular {z} {
    global currentGroup

    set labelformat {f700f600+0+0 f700a0^0^0 f700a0^0>1 \
			 f700a0^0>2 f700a0^0>3 f700a0^0>4 f700a0^0>5}

    set item [$z add tabular $currentGroup 7 -labelformat $labelformat]
    $z itemconfigure $item 0 -filled 1 -border contour \
	-bordercolor black -backcolor gray60
    $z itemconfigure $item 1 -alignment center -text AFR6128
    $z itemconfigure $item 2 -alignment center -text 390
    $z itemconfigure $item 3 -alignment center -text 370
    $z itemconfigure $item 4 -alignment center -text 350
    $z itemconfigure $item 5 -alignment center -text 330
    $z itemconfigure $item 6 -alignment center -text TUR

    return $item;
}

proc addAxes {z item length command inFront} {
    global currentGroup

    set axesGroup [$z add group $currentGroup -tags axisgrp:$item]
    $z add curve $axesGroup [list 0 0 $length 0] -linewidth 3 \
	-lastend {6 8 3} -tags axis:$item
    $z add curve $axesGroup [list 0 0 0 $length] -linewidth 3 \
	-lastend {6 8 3} -tags axis:$item
    $z add rectangle $axesGroup {-3 -3 3 3} -filled 1 \
	-linewidth 0 -composescale 0 -tags axis:$item
    if {$inFront} {
	$z raise $item $axesGroup
    }
    $z bind axis:$item <B1-Motion> {dragItem %W %x %y}
    $z bind axis:$item <ButtonRelease-1> "$command %W; set drag 0"
}

proc addItem {z} {
    global itemType

    set length 25
    set itemOnTop 0

    set item [eval "new$itemType $z"]
    if {($itemType == "Track") || ($itemType == "WayPoint")} {
	set itemOnTop 1
    }

    addAxes $z $item 25 select $itemOnTop
    changeItem $z $item
}

proc addGroup {z} {
    global currentGroup

    set item [$z add group $currentGroup]

    addAxes $z $item 80 selectGroup 1
    changeGroup $z $item
}

proc mouseAdd {z itemOrGroup x y} {
    global currentGroup currentItem

    if {[llength [$z find withtag current]] != 0} {
	return
    }

    foreach {x y} [$z transform $currentGroup [list $x $y]] break

    eval "add$itemOrGroup $z"

    $z translate $currentItem $x $y
    $z translate axisgrp:$currentItem $x $y
}