[PD-cvs] pd/src desire.tk,1.1.2.22,1.1.2.23

4 Sep 2005


      Update of /cvsroot/pure-data/pd/src
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18595
Modified Files:
      Tag: devel_0_39
    desire.tk 
Log Message:
adding code for: console, buttonbar, tooltips, classbrowser, completions.
note that most of that code is not functioning and has to be reintegrated with other components.
Index: desire.tk
===================================================================
RCS file: /cvsroot/pure-data/pd/src/Attic/desire.tk,v
retrieving revision 1.1.2.22
retrieving revision 1.1.2.23
diff -C2 -d -r1.1.2.22 -r1.1.2.23
*** desire.tk	4 Sep 2005 06:59:08 -0000	1.1.2.22
--- desire.tk	4 Sep 2005 08:31:17 -0000	1.1.2.23
***************
*** 19,23 ****
proc def {class selector args body} {
! 	proc ${class}_$selector "self $args" "global _; $body"
  }
--- 19,24 ----
proc def {class selector args body} {
! 	proc ${class}_$selector "self $args" \
! 		"global _; [regsub -all @(\w+) $body _($self:\1)]"
  }
***************
*** 143,146 ****
--- 144,161 ----
  # puts stderr [bind all]
+ set cmdline(console) 0
+ 
+ for {set i 0} {$i < $argc} {incr i} {
+   global cmdline
+   set o [lindex $argv $i]
+   switch -- $o {
+     -console {
+       incr i
+       set cmdline(console) [lindex $argv $i]
+     }
+     default {puts "ERROR: command line argument: unknown $o"}
+   }
+ }
+ 
  ################## set up main window #########################
  menu .mbar
***************
*** 1241,1245 ****
    puts "object_xy"
    set canvas_id [canvastosym $canvas]
! 	
    if {[info exists _($self:cx)]} {
    	return [list $_($self:cx) $_($self:cy)]
--- 1256,1260 ----
    puts "object_xy"
    set canvas_id [canvastosym $canvas]
! 
    if {[info exists _($self:cx)]} {
    	return [list $_($self:cx) $_($self:cy)]
***************
*** 2111,2116 ****
    		foreach {ox1 oy1 ox2 oy2} [$canvas bbox ${id}o${out}] {}
    		wire_draw lnew $canvas 1 $cx $cy $cx $cy
! 			#!@#$ -dash blows up on OSX
! 			switch -- $pd_nt { 2 {} default { $canvas itemconfigure lnew -dash "4 4 4 4" }}
    		set wire_from [list $id $out]
    		return
--- 2126,2130 ----
    		foreach {ox1 oy1 ox2 oy2} [$canvas bbox ${id}o${out}] {}
    		wire_draw lnew $canvas 1 $cx $cy $cx $cy
! 			$canvas itemconfigure lnew -dash {4 4 4 4}
    		set wire_from [list $id $out]
    		return
***************
*** 3686,3702 ****
#####################################################################################
  ############ evaluator
def listener new {name command} {
! 	set _($self:hist) {}
! 	set _($self:histi) 0
! 	set _($self:command) $command
    frame $self
! 	button $self.expander -image icon_plus -command "listener_expand $self"
! 	label $self.label -text "$name: "
! 	entry $self.entry -width 40
! 	pack $self.expander -side left
! 	pack $self.label -side left
! 	pack $self.entry -side left -fill x -expand yes
    pack $self -fill x -expand no
    bind $self.entry <Up>   "listener_up   $self"
--- 3700,3772 ----
#####################################################################################
+ ############ console
+ 
+ proc make_console {} {
+ 	global cmdline pd_nt
+ 	set errMsg ""
+ 	catch {
+ 	if {$cmdline(console) != 0} {
+ 		frame .log
+ 		text .log.1 -width 60 -height 10 -yscrollcommand ".log.2 set"
+ 		scrollbar .log.2 -command ".log.1 yview"
+ 		global tcl_version tk_version pd_myversion tcl_platform pd_nt
+ 		#.log.1 insert end "$pd_myversion"
+ 		.log.1 insert end "DesireData 0.39.A"
+ 		.log.1 insert end "Tcl $tcl_version, Tk $tk_version, pd_nt=$pd_nt\n"
+ 		foreach k [array names tcl_platform] {
+ 			.log.1 insert end "tcl_platform($k) = $tcl_platform($k)\n"
+ 		}
+ 		pack .log.1 -side left -fill both -expand yes
+ 		pack .log.2 -side left -fill    y -expand no
+ 		pack .log -fill both -expand yes
+ 		.log.2 set 0.0 1.0
+ 		switch $pd_nt { 2 {
+ 			bind .log.1 <MouseWheel> {
+ 				.log.1 yview scroll [expr -2-abs(%D)/%D] units
+ 			}
+ 		}}
+ 	}
+ 	} errMsg
+ 	if {[string compare "" $errMsg] != 0} {puts stderr "ERROR: $errMsg"}
+ }
+ 
+ set console_scrollback_count 0
+ proc post_to_gui {x} {
+ 	global cmdline console_scrollback_count
+ 	if {[catch {
+ 		set oldpos [lindex [.log.2 get] 1]
+ 		.log.1 insert end $x
+ 		incr console_scrollback_count
+ 		if {$console_scrollback_count >= $cmdline(console)} {
+ 			.log.1 delete 1.0 2.0
+ 		}	
+ 		if {$oldpos > 0.9999} {.log.1 see end}
+ 	}]} {
+ 		puts -nonewline stderr $x
+ 	}
+ }
+ 
+ proc post {args} {
+ 	global cmdline
+ 	if {$cmdline(console)} {
+ 		post_to_gui [eval [linsert $args 0 format]]
+ 		post_to_gui "\n"
+ 	} else {
+ 		puts stderr [eval [linsert $args 0 format]]
+ 	}
+ }
+ 
+ if {$cmdline(console)} {make_console}
+ 
  ############ evaluator
def listener new {name command} {
! 	set @hist {}
! 	set @histi 0
! 	set @command $command
    frame $self
! 	pack [button $self.expander -image icon_plus -command "listener_expand $self"] -side left
! 	pack [label $self.label -text "$name: "] -side left
! 	pack [entry $self.entry -width 40] -side left -fill x -expand yes
    pack $self -fill x -expand no
    bind $self.entry <Up>   "listener_up   $self"
***************
*** 3709,3716 ****
    destroy $self.entry
    text $self.entry -width 40 -height 8
! 	$self.entry insert 0.0 $text
! 	pack $self.entry -side left -fill x -expand yes
    $self.expander configure -image icon_minus -command "listener_unexpand $self"
! 	#bind $self.entry <Alt-Return> $_($self:command)
  }
--- 3779,3785 ----
    destroy $self.entry
    text $self.entry -width 40 -height 8
! 	pack [$self.entry insert 0.0 $text] -side left -fill x -expand yes
    $self.expander configure -image icon_minus -command "listener_unexpand $self"
! 	#bind $self.entry <Alt-Return> $@command
  }
***************
*** 3725,3748 ****
    bind $self.entry <Up>   "listener_up   $self"
    bind $self.entry <Down> "listener_down $self"
! 	bind $self.entry <Return> $_($self:command)
  }
def listener up {} {
! 	if {$_($self:histi) > 0} {set _($self:histi) [expr -1+$_($self:histi)]}
    $self.entry delete 0 end
! 	$self.entry insert 0 [lindex $_($self:hist) $_($self:histi)]
    $self.entry icursor end
  }
def listener down {} {
! 	if {$_($self:histi) < [llength $_($self:hist)]} {incr _($self:histi)}
    $self.entry delete 0 end
! 	$self.entry insert 0 [lindex $_($self:hist) $_($self:histi)]
    $self.entry icursor end
  }
def listener append {v} {
! 	lappend _($self:hist) $v
! 	set _($self:histi) [llength $_($self:hist)]
  }
--- 3794,3817 ----
    bind $self.entry <Up>   "listener_up   $self"
    bind $self.entry <Down> "listener_down $self"
! 	bind $self.entry <Return> $@command
  }
def listener up {} {
! 	if {$@histi > 0} {set @histi [expr -1+$@histi]}
    $self.entry delete 0 end
! 	$self.entry insert 0 [lindex $@hist $@histi]
    $self.entry icursor end
  }
def listener down {} {
! 	if {$@histi < [llength $@hist]} {incr @histi}
    $self.entry delete 0 end
! 	$self.entry insert 0 [lindex $@hist $@histi]
    $self.entry icursor end
  }
def listener append {v} {
! 	lappend @hist $v
! 	set @histi [llength $@hist]
  }
***************
*** 3761,3769 ****
  }
! #####################################################################################
! proc post {args} {
! #	post_to_gui [eval [linsert $args 0 format]]
! #	post_to_gui "\n"
! 	puts stderr [eval [linsert $args 0 format]]
  }
--- 3830,4053 ----
  }
! ############ button bar
! set butt {
! 	{object  {obj 0}}
! 	{message {msg 0}}
! 	{number  {floatatom 0}}
! 	{symbol  {symbolatom 0}}
! 	{comment {text 0}}
! 	{bang    {bng 0}}
! 	{toggle  {toggle 0}}
! 	{number2 {numbox 0}}
! 	{vslider {vslider 0}}
! 	{hslider {hslider 0}}
! 	{vradio  {vradio 0}}
! 	{hradio  {hradio 0}}
! 	{vu      {vumeter 0}}
! 	{dropper      {dropper 0}}
! 	{canvas  {mycnv 0}}
! 	{graph   {graph}}
! 	{array   {menuarray}}
! }
! 
! proc button_bar_add {x y} {
! 	global butt
! 	lappend butt [list $x $y noload]
! 	
! }
! 
! proc load_button_bar {} {
! 	global butt
! 	global cmdline
! 	set icons {mode_edit mode_run}
! 	set dir $cmdline(look)
! 	foreach b $butt {
! 		if {[string compare [lindex $b 2] noload]!=0} {
! 			lappend icons [lindex $b 0]
! 		}
! 	}
! 	foreach im $icons {
! 		set errMsg {}
! 		if {[catch {image create photo icon_$im -file $dir/$im.gif }]} {
! 			# post_to_gui "ERROR: $errorInfo\n"
! 		}
! 	}
! }
! 
! set buttons_loaded 0
! proc make_button_bar {self doc} {
! 	global buttons_loaded
! 	if {!$buttons_loaded} {load_button_bar}
!         global butt
! 	frame $self
! 	button $self.edit -image icon_mode_edit -border 1 \
! 		-command "menu_editmode $doc"
! 	pack $self.edit -side left 
! 	foreach b $butt {
! 		catch {
! 			button "$self.[lindex $b 0]" -image "icon_[lindex $b 0]" -border 1 \
! 				-command [list pd "$doc [lindex $b 1] ;"]
! 			pack $self.[lindex $b 0] -side left
! 		}
! 	}
! 	entry $self.name -font {courier 9} -width 10 -border 0
! 	$self.name insert 0 ".[lindex [split $self .] 1]"
! 	$self.name configure -state disabled
! 	pack $self.name -side right
! }
! 
! ############ tooltips
! 
! set tooltip(mx) -1000
! set tooltip(my) -1000
! set tooltip(canvas) foo
! set tooltip(visible) 0
! set tooltip(text) ""
! 
! # woops, self is for future use
! proc show_canvas_tooltip {self canvas x y text} {
! 	global current_x current_y tooltip
! 	if {$tooltip(visible) && [string compare $text $tooltip(text)==0]} {return}
! 	hide_canvas_tooltip $canvas
! 	set border 4
! 	set x [expr $x+$border+4]
! 	$canvas create text $x $y -text $text -anchor w -tags tooltip_fg
! 	foreach {x1 y1 x2 y2} [$canvas bbox tooltip_fg] {}
! 	set w 0
! 	set h 0
! 	$canvas create rectangle \
! 		[expr $x1-$border] [expr $y1-$border] \
! 		[expr $x2+$border] [expr $y2+$border] \
! 		-fill "#ffffcc" -outline "#000000" -tags tooltip_bg
! 	$canvas lower tooltip_bg tooltip_fg
! 	set tooltip(mx) $current_x
! 	set tooltip(my) $current_y
! 	set tooltip(canvas) $canvas
! 	set tooltip(visible) 1
! 	set tooltip(text) $text
! }
! 
! proc hide_canvas_tooltip {canvas} {
! 	$canvas delete tooltip_bg tooltip_fg
! 	global tooltip
! 	set tooltip(visible) 0
! }
! 
! ############ class list
! 
! proc show_class_list {} {
! 	pd "pd update-path ; pd update-class-list class_list_callback ;"
! }
! 
! proc class_list_fill_box {s} {
! 	global class_list
! 	set n 0
! 	.browser.cl.1 delete 0 end
! 	foreach class [lsort $class_list] {
! 		if {[string length $s]==0 || [string first $s $class]>=0} {
! 			.browser.cl.1 insert end "$class"
! 			incr n
! 		}
! 	}
! 	.browser.title configure -text "$n/[llength $class_list] registered object classes"
! 	.browser.cl.1 selection set 0 0
! }
! 
! proc search_for_externs {} {
! 	global pd_path
! 	global class_list
! 	foreach dir $pd_path {
! 		catch {
! 			set xs [glob "$dir/*.pd*"]
! 			foreach x $xs {lappend class_list "[lindex [file split $x] end] (not loaded)"}
! 		}
! 	}
! }
! 
! proc class_list_callback {} {
! 	global class_list
! 	search_for_externs
! 	toplevel .browser
! 	frame .browser.cl
! 	label .browser.title -text ""
! 	pack .browser.title -side top
! 	listbox .browser.cl.1 -width 30 -height 10 -yscrollcommand ".browser.cl.2 set"
! 	scrollbar .browser.cl.2 -command ".browser.cl.1 yview"
! 	text .browser.cl.3 -width 30 -height 10 -yscrollcommand ".browser.cl.4 set"
! 	scrollbar .browser.cl.4 -command ".browser.cl.3 yview"
! 	pack .browser.cl -side top -fill both -expand yes
! 
! 	frame .browser.cl.5
! 	button .browser.cl.5.help -text "Help" -command {pd "pd help [.browser.cl.1 get [.browser.cl.1 curselection]] ;"}
! 	pack .browser.cl.5.help -side top
! 	pack .browser.cl.5 -side left -fill    y -expand no
! 	pack .browser.cl.1 -side left -fill both -expand yes
! 	pack .browser.cl.2 -side left -fill    y -expand no
! 	pack .browser.cl.3 -side left -fill both -expand yes
! 	pack .browser.cl.4 -side left -fill    y -expand no
! 
! 	frame .browser.butt
! 	label .browser.butt.1 -text "Filter: "
! 	entry .browser.butt.2 -width 15
! 	pack .browser.butt.1 .browser.butt.2 -side left
! 	button .browser.butt.close -text "Close" -command "destroy .browser"
! 	pack .browser.butt.close -side right
! 	pack .browser.butt -side bottom -fill x -expand no
! 	class_list_fill_box ""
! 	bind .browser.cl.1 <Button-1> {
! 		after 1 {
! 			set i [.browser.cl.1 curselection]
! 			set class [.browser.cl.1 get $i]
! 			pd "pd update-class-info $class ;"
! 		}
! 	}
! 	bind .browser.butt.2 <KeyPress> {after 1 {class_list_fill_box [.browser.butt.2 get]}}
! 	after 1 {focus .browser.butt.2}
  }
+ 
+ proc class_info_callback {class} {
+ 	global class_info
+ 	set i [.browser.cl.1 curselection]
+ 	set class [.browser.cl.1 get $i]
+ 	.browser.cl.3 delete 0.0 end
+ 	.browser.cl.3 insert end "class $class\n"
+ 	foreach {k v} $class_info($class) {
+ 		.browser.cl.3 insert end "$k="$v"\n"
+ 	}
+ }
+ 
+ ############ completions
+ 
+ set completion_closure {}
+ 
+ proc propose_completions {self canvas x y text} {
+ 	global class_list completion_closure
+ 	set completion_closure [list $self $canvas $x $y $text]
+ 	pd "pd update-class-list propose_completions2 ;"
+ 	if {![info exists class_list]} {
+ 		post_to_gui "loading class list..."
+ 		
+ 	} else {
+ 		propose_completions2
+ 	}
+ }
+ 
+ proc propose_completions2 {} {
+ 	global class_list completion_closure
+ 	foreach {self canvas x y text} $completion_closure {}
+ 	set r {}
+ 	set n 0
+ 	foreach class [lsort $class_list] {
+ 		if {[string length $text]==0 || [string first $text $class]>=0} {
+ 			lappend r $class
+ 			incr n
+ 		}
+ 		if {$n > 20} {lappend r ...; break}
+ 	}
+ 	#post_to_gui "$r\n"
+ 	set r [string map {" " "\n"} $r]
+ 	global tooltip
+ 	show_canvas_tooltip $self $canvas $x $y $r
+ }
+

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

[PD-cvs] pd/src desire.tk,1.1.2.22,1.1.2.23