#!/bin/sh
#\
exec wish4.2 $0 ${1+"$@"}
#
#  Make a Tcl/Tk sliderule
#
# $Id: slide-rule.tcl,v 1.4 1997/06/13 05:24:44 kragen Exp $

### Section 1.  Dragging groups of objects horizontally.
proc groupof {canvas obj} {
	set fqid "$canvas $obj"
	global groupof
	return $groupof($fqid)
}

proc addtogroup {canvas obj group} {
	set fqid "$canvas $obj"
	global groupof
	set groupof($fqid) $group
	# NOTE: This will lose any other tags on $obj.
	$canvas itemconfigure $obj -tags $group
}

proc sl_ru_bind {canvas} {
	bind $canvas <1> {
		global old_x
		set old_x %x
		global dragobj
		set dragobj [groupof %W [%W find closest %x %y]]
	}
	bind $canvas <B1-Motion> {
		global old_x dragobj
		%W move $dragobj [expr (%x - $old_x) / 2] 0
		set old_x %x
	}
}

### Section 2.  Making ticks
#
# Call this function to create a tick on a canvas as part of a draggable group.
# If you want a label, pass one; otherwise, pass an empty string.
# The label will be on the y2 end.
set labelfont "-*-*-medium-o-*-*-8-*-*-*-p-*-*-*"
proc mktick {canvas group x y1 y2 label} {
	global labelfont
	set line [$canvas create line $x $y1 $x $y2]
	addtogroup $canvas $line $group
	if { $label != "" } {
		set textdist 3
		if {$y1 < $y2} {
			set text_y [expr $y2 + $textdist]
			set tanchor n
		} else {
			set text_y [expr $y2 - $textdist]
			set tanchor s
		}
		set text [$canvas create text $x $text_y -text $label \
			-font $labelfont -anchor $tanchor]
		addtogroup $canvas $text $group
	}
}
			

### Section 3. Traditional logarithmic scales -- A, B, C, D, K.

proc newlogscale {xmin xmax nummin nummax} {
	list "logscalepos" $xmin $nummin [
		expr ($xmax - $xmin) / log10(double($nummax)/$nummin)
	]
}

proc logscalepos {xmin nummin rate n} {
	expr round($xmin + $rate * log10($n/$nummin))
}

# Converts a floating-point number into a number suitable for labeling a
# sliderule.  No more than three digits, no trailing zeroes.
proc scalelabel {n} {
	set n [expr round($n * 1000)]
	regsub 0*$ $n {} n
	return $n
}

proc logscale_e_g {canvas name y xmin xmax nummin nummax interval dir} {
	set ls [newlogscale $xmin $xmax $nummin $nummax]
	set tick_len 3
	if {$dir == "n"} {
		set tick_end [expr $y - $tick_len]
	} else {
		set tick_end [expr $y + $tick_len]
	}
	for {set i [expr double($nummin)]} {$i <= $nummax} {
		set i [expr $i+$interval]} {
		mktick $canvas $name [eval $ls $i] $y $tick_end [scalelabel $i]
	}
}

proc sliderule_e_g {} {
	catch {canvas .c -width 500 -height 50}
	catch {pack .c}
	logscale_e_g .c C 25 10 490 1 10 0.5 n
	logscale_e_g .c D 25 10 490 1 10 0.5 s
	sl_ru_bind .c
}
	

### Section 4.  Drawing scales with marks as dense as possible, but no
###             denser.

# This code here is gross and needs to be de-magic-numbered.  All the coords
# are currently magic numbers.
# This code here is gross and needs to be factored.  Some things that should
# be factored:
# - making a canvas with sliderule bindings maybe
# - adding a label to a slide
# - creating a scale at a certain set of coords.
proc nsliderule_eg {width} {
	global labelfont
	catch {destroy .c}
	catch {canvas .c -width $width -height 200 -bg white}
	catch {pack .c}
	sl_ru_bind .c
	set xmin 10
	set xmax [expr $width - 10]
	hairline_slider .c slider [expr $xmin + 20] 15 [expr $xmin + 120] 155
	set ls [newlogscale $xmin $xmax 1 10]
	set obj [.c create text [expr $xmin + 30] 100 -font $labelfont -anchor s -text C]
	addtogroup .c $obj Cd
	markscale .c Cd $ls 1 10 3 120 -1
	set obj [.c create text [expr $xmin + 30] 140 -font $labelfont -anchor n -text D]
	addtogroup .c $obj Dd
	markscale .c Dd $ls 1 10 3 120 1
	set abscale [newlogscale $xmin $xmax 1 100]
	set obj [.c create text [expr $xmin + 30] 30 -font $labelfont -anchor s -text A]
	addtogroup .c $obj Dd
	markscale .c Dd $abscale 1 100 0003 50 -1
	set obj [.c create text [expr $xmin + 30] 70 -font $labelfont -anchor n -text B]
	addtogroup .c $obj Cd
	markscale .c Cd $abscale 1 100 0003 50 1
}
# see bottom

proc markscale {canvas name scale nmin nmax ndiv y dir} {
	set depth [mark_intv $canvas $name $scale $nmin $nmax \
		$ndiv $y $dir
	]
	set tick_yend [expr $y + [tick_len $depth $dir]]
	mktick $canvas $name [eval $scale $nmin] $y $tick_yend [scalelabel $nmin]
	mktick $canvas $name [eval $scale $nmax] $y $tick_yend [scalelabel $nmax]
}

# This procedure is way too long, has too many parameters, and is likely 
# to be quite buggy.
# Its return value is the depth of recursion beneath it.
# The pseudo-code goes like this:
# To mark an interval into n parts:
# - find the divisions between subintervals.
# - if they're too dense, return 0.
# - For each subinterval:
#   - mark it into n' parts.
#   - remember the depth that operation returned.
# - add 1 to the maximum subinterval depth for our return value.
# - decide whether the subintervals are big enough to label the divisions 
#   between them.
# - Make ticks in between the subintervals according to what will be our return
#   value.
# - return it.

# For 1..100.
set next_level(0003) 003
set next_level(003) 11
set next_level(11) 2

# For 1..10.
set next_level(3)  03
set next_level(03) 2
# set next_level(9) 2

set next_level(5) 2
set next_level(2) 5

proc mark_intv {canvas name scale nmin nmax ndiv y dir} {
	global next_level
	set len [expr $nmax - $nmin]
	set subdsiz [expr double($len) / $ndiv]

	set domdiv {}
	set randiv {}
	# This loop iterates through the places between the divisions; thus
	# it has $ndiv-1 iterations.
	for {set i 1} {$i < $ndiv} {incr i} {
		set n [expr $nmin + $i * $subdsiz]
		lappend domdiv $n
		lappend randiv [eval $scale $n]
	}
	# puts "domdiv: $domdiv"
	# puts "randiv: $randiv"

	set ranmin [eval $scale $nmin]
	set ranmax [eval $scale $nmax]
	set mindiff [eval mindiff $ranmin $randiv $ranmax]
    # Marks should be made no closer than 3
	if {$mindiff < 3} {return 0}

	set maxdepth 0
	set ldom $nmin
	foreach rdom [eval list $domdiv $nmax] {
		set depth [mark_intv $canvas $name $scale $ldom $rdom \
			$next_level($ndiv) $y $dir]
		if {$depth > $maxdepth} {set maxdepth $depth}
		set ldom $rdom
	}

	incr maxdepth

	# Note that tick_len returns a signed number.
	set tick_len [tick_len $maxdepth $dir]
	set tick_yend [expr $y + $tick_len]
	
	# This loop iterates through the spaces between divisions, just like
	# the first loop.  However, it needs to use its loop index as a
	# list index, so it must start at 0.
	set label ""
	for {set i 0} {$i < $ndiv - 1} {incr i} {
		if {$mindiff > 15} {
			set label [scalelabel [lindex $domdiv $i]]
		} 
		mktick $canvas $name [lindex $randiv $i] $y $tick_yend $label
		update idletasks; # for debugging
	}
	# if {$maxdepth > 4} {
	# 	puts "mark_intv: $nmin $nmax $ndiv"
	# 	puts "subdsiz: $subdsiz"
	# }
	return $maxdepth
}

# This returns the smallest difference between any adjacent pair of its args.
# This will not work for CI, etc., as currently written
proc mindiff {a args} {
	set mindiff [expr [lindex $args 0] - $a]
	foreach arg $args {
		set diff [expr $arg - $a]
		if {$diff < $mindiff} {set mindiff $diff}
		set a $arg
	}
	return $mindiff
}

proc tick_len {depth dir} {
	expr $dir * ($depth * 3 + 2)
}

### Section 5.  Drawing the hairline slider.

proc hairline_slider {canvas name x1 y1 x2 y2} {
	# top/bottom linewidth
	set tblw 8
	# left/right linewidth
	set lrlw 2
	# fudge to make line joins right
	set fudge [expr ceil($lrlw/2)]
	set fudgex1 [expr $x1 + $fudge]
	set fudgex2 [expr $x2 - $fudge]

	set objects {}
	lappend objects [$canvas create line $fudgex1 $y1 $fudgex1 $y2 -width $lrlw]
	lappend objects [$canvas create line $x1 $y2 $x2 $y2 -width $tblw]
	lappend objects [$canvas create line $fudgex2 $y2 $fudgex2 $y1 -width $lrlw]
	lappend objects [$canvas create line $x2 $y1 $x1 $y1 -width $tblw]
	set midx [expr round(($x1 + $x2)/2.0)]
	lappend objects [$canvas create line $midx $y1 $midx $y2 -fill red]
	foreach obj $objects {
		addtogroup $canvas $obj $name
	}
}

### Testing:
frame .controls
scale .size -orient horizontal -from 0 -to 3000 -label "Slide length" -length 200 \
	-resolution 1 -tickinterval 200 -variable slidelength
button .redraw -text "Redraw slide rule" -command {nsliderule_eg $slidelength}
pack .size .redraw -in .controls -side left -fill both
pack .size -expand 1
pack .controls -side bottom -fill x

# This is the biggest that fits in a default-sized Netscape window
set slidelength 600
.redraw invoke