foreach package {snack tkdnd tkpath} {package require $package} namespace eval ::ix { proc rc {} {return [format "\#%06x" [expr "int(floor(rand() * 16777216))"]]} proc rgb {} {return [list [expr "int(floor(rand() * 256))"] [expr "int(floor(rand() * 256))"] [expr "int(floor(rand() * 256))"]]} proc lighten {rgb r} {set l {}; foreach c $rgb {lappend l [expr {(256 - $c) * $r + $c}]}; return $l} proc darken {rgb r} {set l {}; foreach c $rgb {lappend l [expr {$c - ($c * $r)}]}; return $l} proc color {rgb} {return [format "\#%02x%02x%02x" [expr int([lindex $rgb 0])] [expr int([lindex $rgb 1])] [expr int([lindex $rgb 2])]]} proc random_txt {n} { set i 0 set text "" while {$i < $n} { set int [expr "int(floor(rand()*62))"] if {$int < 10} {incr int 48} elseif {$int < 36} {incr int 55} else {incr int 61} set text "$text[format %c $int]" incr i } return $text } proc mat_scroll {p t d axis} { variable _ foreach xy $axis { set mv [expr {($_($t:${xy}b) - $_($t:${xy}a)) / 4.0}] foreach ab {a b} {set _($t:${xy}$ab) [expr {$d > 0 ? $_($t:${xy}$ab) + $mv : $_($t:${xy}$ab) - $mv }]}} mat_redraw $p $t all mat_gridlines $p $t} proc mat_sel {p t a x y} { variable _ set _($t:sc) [rc] switch $a { first { foreach xy {x y} {set _($t:c$xy) [set $xy];set _($t:f$xy) [set $xy]} $p.m create path [::tkpath::coords rect $_($t:cx) $_($t:cy) 0 0 -rx 12 -ry 12] \ -tags sel -stroke $_($t:sc) -strokewidth 12 -strokeopacity 0.3} release {$p.m delete sel; set _($t:hover) 0} motion { if {$_($t:hover) != 1} { mat_updatesel $p $t [mat_cleansel $p $t [$p.m find overlapping $_($t:fx) $_($t:fy) $x $y]] } if {$x >= $_($t:cx)} {set xa $_($t:fx);set xb $x} else {set xa $x;set xb $_($t:fx)} if {$y >= $_($t:cy)} {set ya $_($t:fy);set yb $y} else {set ya $y;set yb $_($t:fy)} set w [expr {abs($xb - $xa)}] set h [expr {abs($yb - $ya)}] $p.m coords sel [::tkpath::coords rect $xa $ya $w $h -rx 12 -ry 12] $p.m itemconfigure sel -stroke $_($t:sc)}}} proc mat_item_new {p t d} { variable _ incr _($t:i) set tags [list item i$_($t:i) $_($t:i)] switch [dict get $d type] { note { set color [dict get $_($t:g) $_($t:cg) color] $p.m create path [::tkpath::coords rect 0 0 0 0 -rx 3 -ry 3] -tags [concat $tags r] -stroke [color [lighten $color 0.4]] -strokeopacity 1.0 -fill [color $color] -fillopacity 0.08 $p.m create path [::tkpath::coords rect 0 0 0 0 -rx 3 -ry 3] -tags [concat $tags q] -fill [color $color] -strokewidth 0 -fillopacity 0.8 } sound { snack:::sound s$_($t:i) s$_($t:i) read [dict get $d filename] $p.m create waveform 0 0 -tags $tags -sound s$_($t:i) } } mat_item_ua $p $t $_($t:i) abs $d 1 } proc mat_item_delete {p t} { variable _ foreach item $_($t:sel) {$p.m delete $item} } proc mat_quant {p t y v} { variable _ if {$y eq "xx"} {set y x}; if {$y eq "yy"} {set y y} if {$y eq "x" || $y eq "y"} { set v [expr {int( ($v + $_($t:q$y) / 2.0 ) / ($_($t:q$y) + 0.0))*$_($t:q$y)}] } return $v } proc mat_item_pos {p t item r x y xx yy} { variable _ foreach v {x xx y yy} { if {[set $v] ne "-"} { switch $r { abs {dict set _($t) $item $v [set $v]} rel {dict set _($t) $item $v [expr {[dict get $_($t) $item $v] + [set $v]}]}}}} mat_redraw $p $t $item} proc mat_item_ua {p t item r u redraw} { variable _ foreach a [dict keys $u] { switch $r { abs {dict set _($t) $item $a [dict get $u $a] } rel {dict set _($t) $item $a [expr {[dict get $_($t) $item $a] + [dict get $u $a]}]}}} if {$redraw == 1} {mat_redraw $p $t $item} } proc mat_draw {p t a x y} { variable _ switch $a { motion { if {$x >= $_($t:cx)} {set xa $_($t:fx);set xb $x} else {set xa $x;set xb $_($t:fx)} mat_item_pos $p $t $_($t:i) abs [mat_tr $p $t x i $xa] [mat_tr $p $t y i $y] [mat_tr $p $t x i $xb] [mat_tr $p $t y i $y]} first {mat_item_new $p $t [dict create type note g $_($t:cg) x 0 y 0 xx 0 yy 0 v 1]}}} proc mat_resize_canvas {p t a x y} { variable _ set mx [expr {$x - $_($t:cx)}] set my [expr {$y - $_($t:cy)}] foreach xy {x y} { set pos [set $xy] set mvt [mat_tr $p $t $xy d [expr {$pos - $_($t:c$xy)}]] set _($t:${xy}a) [expr {$_($t:${xy}a) - $mvt}] set _($t:${xy}b) [expr {$_($t:${xy}b) + $mvt}]} mat_redraw $p $t all mat_gridlines $p $t} proc mat_redraw {p t items} { variable _ switch $items { all {set items [dict keys $_($t)]} default {}} foreach id $items { set x [mat_tr $p $t x t [dict get $_($t) $id x]] set y [mat_tr $p $t y t [dict get $_($t) $id y]] set qx [mat_tr $p $t x t [mat_quant $p $t x [dict get $_($t) $id x]]] set qy [mat_tr $p $t y t [mat_quant $p $t y [dict get $_($t) $id y]]] switch [dict get $_($t) $id type] { note { set sx [expr abs([mat_tr $p $t x id [expr {[dict get $_($t) $id xx] - [dict get $_($t) $id x]}]])] set qsx [expr abs([mat_tr $p $t x id [expr {[mat_quant $p $t x [dict get $_($t) $id xx]] - [mat_quant $p $t x [dict get $_($t) $id x]]}]])] set sy [expr abs([mat_tr $p $t y id 1])] set ro [expr {int( $sy / 2.0 )}] set r [$p.m find withtag "i$id && r"] set q [$p.m find withtag "i$id && q"] $p.m coords $r [::tkpath::coords rect $x $y $sx $sy -rx $ro -ry $ro] $p.m coords $q [::tkpath::coords rect $qx $qy $qsx $sy -rx $ro -ry $ro] $p.m itemconfigure $q -fillopacity [dict get $_($t) $id v] } sound { $p.m coords [$p.m find withtag i$id] $x $y } } } } proc mat_item_v {p t a x y} { variable _ foreach item $_($t:sel) { mat_item_ua $p $t $item rel [dict create v [expr {($x - $_($t:cx)) / 100.0}]] 1 } mat_item_info $p $t $_($t:sel) } proc mat_move_canvas {p t a x y} { variable _ set mx [expr {$x - $_($t:cx)}] set my [expr {$y - $_($t:cy)}] foreach xy {x y} { set pos [set $xy] set mvt [mat_tr $p $t $xy d [expr {$pos - $_($t:c$xy)}]] foreach ab {a b} {set _($t:${xy}$ab) [expr {$_($t:${xy}$ab) - $mvt}]}} mat_redraw $p $t all mat_gridlines $p $t} proc mat_move_object {p t a x y} { variable _ set mx [mat_tr $p $t x d [expr {$x - $_($t:cx)}]] set my [mat_tr $p $t y d [expr {$y - $_($t:cy)}]] foreach item $_($t:sel) {mat_item_pos $p $t $item rel $mx $my $mx $my} mat_item_info $p $t $_($t:sel) } proc mat_resize_left {p t a x y} {mat_resize_object $p $t x $x $y} proc mat_resize_right {p t a x y} {mat_resize_object $p $t xx $x $y} proc mat_resize_top {p t a x y} {mat_resize_object $p $t y $x $y} proc mat_resize_bottom {p t a x y} {mat_resize_object $p $t yy $x $y} proc mat_resize_tl {p t a x y} {mat_resize_object $p $t x $x $y; mat_resize_object $p $t y $x $y} proc mat_resize_tr {p t a x y} {mat_resize_object $p $t x $x $y; mat_resize_object $p $t yy $x $y} proc mat_resize_bl {p t a x y} {mat_resize_object $p $t xx $x $y; mat_resize_object $p $t y $x $y} proc mat_resize_br {p t a x y} {mat_resize_object $p $t xx $x $y; mat_resize_object $p $t yy $x $y} proc mat_resize_object {p t e x y} { variable _ array set ax {x x xx x y y yy y} set m [mat_tr $p $t $ax($e) d [expr $$ax($e) - $_($t:c$ax($e))]] foreach item $_($t:sel) {mat_item_ua $p $t $item rel [dict create $e $m] 1} mat_item_info $p $t $_($t:sel) } proc mat_cleansel {p t sel} { set clean {} foreach item $sel {if {[lindex [$p.m itemcget $item -tags] 0] eq "item"} {lappend clean [lindex [$p.m itemcget $item -tags] 2]}} set clean [lsort -integer -unique $clean] return $clean } proc mat_hover {p t x y} { variable _ mat_loc $p $t $x $y if {[$p.m find withtag sel] ne ""} { set _($t:hover) 1 set clicked [mat_cleansel $p $t [$p.m find overlapping $_($t:fx) $_($t:fy) $x $y]] mat_sel $p $t motion $x $y } else { set clicked [mat_cleansel $p $t [$p.m find overlapping $x $y $x $y]] } if {$clicked ne ""} { mat_mode $p $t move_object set id [lindex $clicked 0] set d 3 set dx [expr {abs([mat_tr $p $t x t [dict get $_($t) $id x]] - $x)}] set dxx [expr {abs([mat_tr $p $t x t [dict get $_($t) $id xx]] - $x)}] set dy [expr {abs([mat_tr $p $t y t [dict get $_($t) $id y]] - $y)}] set dyy [expr {abs([mat_tr $p $t y t [dict get $_($t) $id yy]] - $y)}] puts "d: x $dx y $dy xx $dxx yy $dyy" if {$dx < $d && $dy < $d} { mat_mode $p $t resize_tl } elseif {$dxx < $d && $dy < $d} { mat_mode $p $t resize_tr } elseif {$dx < $d && $dyy < $d} { mat_mode $p $t resize_bl } elseif {$dxx < $d && $dyy < $d} { mat_mode $p $t resize_br } elseif {$dx < $d} { mat_mode $p $t resize_left } elseif {$dxx < $d} { mat_mode $p $t resize_right } elseif {$dy < $d} { mat_mode $p $t resize_top } elseif {$dyy < $d} { mat_mode $p $t resize_bottom } if {[$p.m find withtag sel] eq "" && [llength $_($t:sel)] > 1} {return} mat_updatesel $p $t $clicked } else { mat_mode $p $t move_canvas } } proc mat_item_info {p t clicked} { variable _ set n 0;$p.m delete hover foreach item $clicked { set info "" set data [dict get $_($t) $item] foreach d $data {lappend info [string range $d 0 7]} $p.m create text [list [expr [winfo width $p.m] - 8.0] [expr [winfo height $p.m] - 8.0 - 11 * $n.0]] -fill $_($t:sc) -justify right -anchor se -font {{bitstream vera sans mono} 10} -tags hover -text $info incr n }} proc mat_updatesel {p t clicked} { variable _ foreach item $_($t:sel) { if {[lsearch -integer $clicked $item] < 0 && $item >= 0} { $p.m itemconfigure [$p.m find withtag i$item] -fill [color [dict get $_($t:g) [dict get $_($t) $item g] color]]}} foreach item $clicked { $p.m itemconfigure [$p.m find withtag i$item] -fill $_($t:sc) } mat_item_info $p $t $clicked set _($t:sel) $clicked } proc mat_click {m button action p t x y X Y} { variable _ set clicked [mat_cleansel $p $t [$p.m find overlapping $x $y $x $y]] set a [$p.m itemcget mode -text] switch $action { first { foreach xy {x y} {set _($t:f$xy) [set $xy]} switch $button { 1 {if {$m eq "control"} { mat_mode $p $t draw; mat_draw $p $t $action $x $y } elseif {$m eq "double" || $m eq "shift"} { mat_sel $p $t first $x $y mat_mode $p $t sel } elseif {[$p.m find withtag sel] ne ""} { mat_sel $p $t release $x $y } elseif {[llength $_($t:sel)] > 1 && [llength $clicked] > 0 && [lsearch $_($t:sel) $clicked] == -1} { mat_updatesel $p $t $clicked}} 2 {mat_mode $p $t resize_canvas} 3 {if {$clicked ne ""} { mat_mode $p $t item_v } else {mat_rmenu $p $t $X $Y}}}} motion {eval mat_$a $p $t $action $x $y} release { switch $button { 1 {if {$a eq "draw" || ($a eq "sel" && [expr {abs($_($t:fx) - $x)}] >13)} {eval mat_$a $p $t $action $x $y}} 2 {mat_mode $p $t move_canvas} 3 {mat_mode $p $t move_canvas} } } } foreach xy {x y} {set _($t:c$xy) [set $xy]} } proc mat_rmenu {p t x y} { variable _ if {[winfo exists $p.rmenu] != 1} { set m [menu $p.rmenu -tearoff no] $m add command -label "zoom to fit" -command "::ix::mat_zoom $p $t fit" $m add command -label "reset zoom" -command "::ix::mat_zoom $p $t reset" $m add command -label "add group" -command "::ix::mat_group_new $p $t -" $m add cascade -label "sel to group" -menu [menu $p.rmenu.seltogroup -tearoff no] } else { # $p.rmenu entryconfigure 0 -label $x } $p.rmenu.seltogroup delete 0 end foreach group [dict keys $_($t:g)] { $p.rmenu.seltogroup add command -label [dict get $_($t:g) $group name] -command "::ix::mat_group_assign $p $t $group" } tk_popup $p.rmenu $x $y } proc mat_tr {p t d inv v} { variable _ array set dm {x width y height} switch $inv { t {return [expr {($v - $_($t:${d}a)) / ($_($t:${d}b) - $_($t:${d}a) + 0.0) * [winfo $dm($d) $p.m]}]} i {return [expr {($_($t:${d}b) - $_($t:${d}a)) * $v /([winfo $dm($d) $p.m] + 0.0) + $_($t:${d}a)}]} d {return [expr {($_($t:${d}b) - $_($t:${d}a)) * $v /([winfo $dm($d) $p.m] + 0.0)}]} id {return [expr {$v / ($_($t:${d}b) - $_($t:${d}a) + 0.0) * [winfo $dm($d) $p.m]}]}}} proc mat_zoom {p t a} { variable _ switch $a { fit { set i 0 dict for {s xy} $_($t) { dict with xy { if {$i == 0} { set xa $x set xb $x set ya $y set yb $y } if {$x > $xb} {set xb $x} if {$x < $xa} {set xa $x} if {$y > $yb} {set yb $y} if {$y < $ya} {set ya $y} if {$xx > $xb} {set xb $xx} if {$xx < $xa} {set xa $xx} if {$yy > $yb} {set yb $yy} if {$yy < $ya} {set ya $yy} incr i } } set _($t:xa) $xa set _($t:xb) $xb set _($t:ya) $ya set _($t:yb) $yb } reset { set _($t:ya) $_($t:yao);set _($t:yb) $_($t:ybo);set _($t:xa) $_($t:xao);set _($t:xb) $_($t:xbo) } } mat_redraw $p $t all mat_gridlines $p $t } proc mat_mode {p t m} { array set cursor {draw pencil move_canvas fleur move_object dotbox item_v box_spiral resize_canvas bogosity sel cross_reverse resize_left left_side resize_right right_side resize_top top_side resize_bottom bottom_side resize_tl top_left_corner resize_tr top_right_corner resize_bl bottom_left_corner resize_br bottom_right_corner} $p.m itemconfigure mode -text $m $p.m configure -cursor $cursor($m) } proc mat_loc {p t x y} { $p.m itemconfigure loc -text [list [mat_tr $p $t x i $x] [mat_tr $p $t y i $y]] } proc mat_group_assign {p t group} { variable _ foreach item $_($t:sel) { mat_item_ua $p $t $item abs [dict create g $group] 0 } } proc mat_group_new {p t grp} { variable _ set exists 0 dict for {key val} $_($t:g) {if {[dict get $val name] eq $grp} {set exists 1}} if {$exists == 0} { if {$grp eq "-"} {set grp [random_txt [expr "int(floor(rand() * 10 + 2))"]]} set n -1 while true { if {[lsearch -integer [dict keys $_($t:g)] [incr n]] == -1} {break}} dict set _($t:g) $n name $grp dict set _($t:g) $n color [rgb] set _($t:cg) $n mat_groups_view $p $t } } proc mat_groups_view {p t} { variable _ $p.m delete [$p.m find withtag group] foreach i [dict keys $_($t:g)] { set id [$p.m create text [concat 68.0 [expr {38.0 + 11 * $i}]] -fill [color [dict get $_($t:g) $i color]] -justify right -anchor e -font {{bitstream vera sans mono} 10} -tags [concat group $i lb] -text [dict get $_($t:g) $i name]] $p.m bind $id "::ix::mat_group_active $p $t $i" set bx [$p.m bbox $id] $p.m lower [$p.m create path [::tkpath::coords rect [lindex $bx 0] [lindex $bx 1] [expr [lindex $bx 2] - [lindex $bx 0]] [expr [lindex $bx 3] - [lindex $bx 1]] -rx 6 -ry 6] -tags [concat group $i bg] -strokewidth 1 -stroke white -fill white -fillopacity 0.5] } mat_group_active $p $t $_($t:cg) } proc mat_group_active {p t g} { variable _ set _($t:cg) $g foreach n [dict keys $_($t:g)] { if {$g == $n} {set cb black; set cl white; set tl 1} {set cb white; set cl [color [dict get $_($t:g) $n color]]; set tl 0.5} set idb [$p.m find withtag "group && $n && bg"] $p.m itemconfigure $idb -fill $cb -fillopacity $tl -stroke $cl set idl [$p.m find withtag "group && $n && lb"] $p.m itemconfigure $idl -fill $cl; if {$g == $n} {$p.m raise $idb;$p.m raise $idl;} } } proc mat_key {p t k b} { # puts $k switch $b { 1 { switch $k { 37 {mat_mode $p $t draw} 22 {mat_item_delete $p $t} 107 {mat_item_delete $p $t} } } 0 { switch $k { 37 {mat_mode $p $t {move_canvas}} } } } } proc mat_drop {p t dropped x y} { # foreach d $dropped { foreach d [split $dropped "\n"] { set x [mat_tr $p $t x i $x] set y [mat_tr $p $t y i $y] mat_item_new $p $t [dict create type sound g 1 v 1 x $x y $y xx [expr $x + 10] yy [expr $y + 10] filename [regsub -- {^file:[/]+} $d "/"]] } } proc mat_new {p t w h bg ln xa xb ya yb qx qy mx my} { variable _ set sc white foreach xy {x y} {foreach ab {a b} {set ${xy}${ab}o [set ${xy}${ab}]}} foreach a {sc ln xa xb ya yb xao xbo yao ybo qx qy mx my} {set _($t:$a) [set $a]} if {[winfo exists $p.m] != 1} { canvas $p.m -bg $bg -width $w -height $h pack $p.m -side left bind $p.m "::ix::mat_key $p $t %k 1" bind $p.m "::ix::mat_key $p $t %k 0" # dnd bindtarget $p.m text/uri-list "::ix::mat_drop $p $t %D %x %y" dnd bindtarget $p.m text/plain "::ix::mat_drop $p $t %D %x %y" bind $p.m "::ix::mat_hover $p $t %x %y" bind $p.m <4> "::ix::mat_scroll $p $t 1 x" bind $p.m <5> "::ix::mat_scroll $p $t -1 x" bind $p.m "::ix::mat_scroll $p $t -1 y" bind $p.m "::ix::mat_scroll $p $t 1 y" foreach m {"Control-" "" "Shift-" "Double-"} { foreach bn {1 2 3} { set b [list [concat $bn first] [concat B${bn}-Motion motion] [concat ButtonRelease-$bn release]] foreach ba {0 1 2} { bind $p.m <$m[lindex [lindex $b $ba] 0]> "::ix::mat_click [list [string tolower [string trimright $m -1]]] $bn [lindex [lindex $b $ba] 1] $p $t %x %y %X %Y"}}} set bd [expr {[$p cget -bd] * 2}] $p configure -bg gray -width [expr {[winfo width $p.m] + $bd}] -height [expr {[winfo height $p.m] + $bd}] $p.m create text {20 20} -fill blue -justify left -anchor w -font {{bitstream vera sans} 18} -tags mode -text move_canvas $p.m create text [list [expr {$w / 2.}] 5] -fill red -justify center -anchor n -font {{bitstream vera sans} 14} -tags q -text q $p.m create text "10 $h" -fill red -justify left -anchor sw -font {{bitstream vera sans} 12 bold} -fill purple -tags loc -text "" if {[info exists _($t)] != 1} { set _($t) {} set _($t:g) {} set sel -1; set i -1; set hover 0; foreach a {i sel hover} {set _($t:$a) [set $a]} mat_group_new $p $t default mat_group_new $p $t wavs } } mat_gridlines $p $t mat_redraw $p $t all mat_groups_view $p $t } proc mat_gridlines {p t} { variable _ set w $p.m $w delete gridlines set gh [winfo height $w] set gw [winfo width $w] foreach item [$w find withtag gridline] {$w delete $item} foreach xy {x y} { array set ta {x n y w} array set tj {x center y left} array set igx {y width x height} set range [expr {abs($_($t:${xy}b) - $_($t:${xy}a))}] set numshits [expr {$range / $_($t:q$xy)}] if {$numshits > $_($t:m${xy})} {set factor [expr {int($numshits / ($_($t:m${xy}) + 0.0) + 1)}]} else { set factor [expr {1. / (int(1./($numshits / ($_($t:m${xy}) + 0.0) + 0.0)) + 0.0)}] } set increment [expr {$_($t:q${xy}) * $factor}] for {set x [expr {int($_($t:${xy}a) / ($increment + 0.0) + 1)*($increment + 0.0)}]} {[expr {$_($t:${xy}a) > $_($t:${xy}b) ? $x >= $_($t:${xy}b) : $x <= $_($t:${xy}b)}]} {set x [expr {$_($t:${xy}a) > $_($t:${xy}b) ? $x - $increment : $x + $increment}]} { set og [mat_tr $p $t $xy t $x] set invgeo [winfo $igx($xy) $w] switch $xy { y {set coords [concat M [expr {int(rand()*32)}] $og L $invgeo $og]} x {set coords [concat M $og [expr {int(rand()*16)}] L $og $invgeo]}} $w lower [$w create text [lrange $coords 1 2] -font {{Bitstream Vera Sans} 8} -fill [rc] -anchor $ta($xy) -text [string range $x 0 7] -justify $tj($xy) -tags gridline] $w lower [$w create path $coords -stroke $_($t:ln) -strokedasharray [expr {int(rand()*42 + 1)}] -tags gridline -strokewidth 1] }}}} #> mat frame #. -bd 3 #w 384 #h 144 #bg gray86 #ln white #. #Xa 123 #Xb 2000 #Ya 127 #Yb 0 #qx 50 #qy 1 #mx 12 #my 64 #. @list ::ix::mat_add .- .| {.#1} .#2 .#3 .#4 #. @add ::ix::mat_add .- .| {.#1} .#2 .#3 .#4 puts "mat .- .|" ::ix::mat_new .- .| .#w .#h .#bg .#ln .#Xa .#Xb .#Ya .#Yb .#qx .#qy .#mx .#my #bind .- {focus .-} #bind .- {focus .^.c}