#!/bin/sh
# \
exec wish8.0 $0 $*

proc getnode {node} {
  global inode
  foreach x [array names inode] {
    if {$inode($x) == $node} {
      foreach {nr color} [split $x ,] break
      return [list $nr $color]
    }
  }
  return ""
}

proc fileparse {file} {
  global transfer gs

  set fd [open $file r]
  set params [read $fd]
  close $fd
  set parlist [split $params "-"]
  set gs(parlist) {}
  foreach p $parlist {
    if [regexp {^dupBlackTransfer} $p] {
      regexp -- "\{\(\[^\}\]*\)" $p dummy transfer(black)
    } elseif [regexp {^dupCyanTransfer} $p] {
      regexp -- "\{\(\[^\}\]*\)" $p dummy transfer(cyan)
    } elseif [regexp {^dupMagentaTransfer} $p] {
      regexp -- "\{\(\[^\}\]*\)" $p dummy transfer(magenta)
    } elseif [regexp {^dupYellowTransfer} $p] {
      regexp -- "\{\(\[^\}\]*\)" $p dummy transfer(yellow)
    } elseif [string compare [string trim $p] ""] {
      lappend gs(parlist) "-$p"
    }
  }
}
 
proc equalnodes {} {
  global gs transfer

  set c $gs(upcolor)
  set n [expr [llength $transfer($c)]-1]
  set v [lindex $transfer($c) end]
  set transfer($c) 0.0
  set dv [expr $v/$n]
  for {set i 1} {$i <= $n} {incr i} {
    lappend transfer($c) [expr $i*$dv]
  }
  drawtransfer
  drawcttrans
}

proc scalenodes {} {
  global gs transfer

  set scale ""
  scan $gs(scale) %f scale
  if {$scale == ""} return
  set c $gs(upcolor)
  set n [expr [llength $transfer($c)]-1]
  set v [lindex $transfer($c) end]
  set t $transfer($c)
  set transfer($c) {}
  for {set i 0} {$i <= $n} {incr i} {
    lappend transfer($c) [expr $scale*[lindex $t $i]]
  }
  drawtransfer
  drawcttrans
}

proc changenodes {delta} {
  global transfer

  set n [llength $transfer(cyan)]
  foreach x {cyan magenta yellow black} {
    set v($x) [lindex $transfer($x) end]
  }
  set n [expr $n-1+$delta]
  foreach x {cyan magenta yellow black} {
    set transfer($x) 0.0
    set dv [expr $v($x)/$n]
    for {set i 1} {$i <= $n} {incr i} {
      lappend transfer($x) [expr $i*$dv]
    }
  }
  drawtransfer
  drawcttrans
}

proc drawcolortriangle {} {
  set xr 10
  set yr 260
  set xg 265
  set yg 260
  set xb 137.5
  set yb [expr 260-256*sqrt(2.0)]
  for {set r 0} {$r < 256} {incr r} {
    for {set g 0} {$g < 256} {incr g} {
      set b [expr 255-$r-$g]
      if {$b < 0} continue
      set x [expr $b*1+$xr+$g*2]
      set y [expr $yr-$b*1]
      set col [format "#%02x%02x%02x" $r $g $b]
      .ct create rectangle ${x} ${y} [expr $x+1] [expr $y] -outline {} \
        -fill $col
    }
  }
}

proc drawcolorcirc {} {
  set col(r,0) 255
  set col(g,0) 0
  set col(b,0) 0
  set col(r,1) 255
  set col(g,1) 255
  set col(b,1) 0
  set col(r,2) 0
  set col(g,2) 255
  set col(b,2) 0
  set col(r,3) 0
  set col(g,3) 255
  set col(b,3) 255
  set col(r,4) 0
  set col(g,4) 0
  set col(b,4) 255
  set col(r,5) 255
  set col(g,5) 0
  set col(b,5) 255
  set col(r,6) 255
  set col(g,6) 0
  set col(b,6) 0
  set X0 20
  set Y0 30
  set R  10
  set dphi [expr 60.0/16.0]
  for {set i 0} {$i < 6} {incr i} {
    for {set j 0} {$j < 16} {incr j} {
      set dx [expr cos(($i*60+$j*$dphi)*3.1416/180.0)]
      set dy [expr sin(($i*60+$j*$dphi)*3.1416/180.0)]
      if {$j == 0} {
        set x0 $X0
        set y0 $Y0
      } else {
        set x0 [expr $X0+$R*$dx]
        set y0 [expr $Y0-$R*$dy]
      }
      set x1 [expr $X0+($R+8)*$dx]
      set y1 [expr $Y0-($R+8)*$dy]
      set i1 [expr $i+1]
      set cr [expr ($col(r,$i)*(16-$j)+$col(r,$i1)*$j)/16]
      set cg [expr ($col(g,$i)*(16-$j)+$col(g,$i1)*$j)/16]
      set cb [expr ($col(b,$i)*(16-$j)+$col(b,$i1)*$j)/16]
      set color [format "#%02x%02x%02x" $cr $cg $cb]
      .ct create line ${x0}m ${y0}m ${x1}m ${y1}m -fill $color -width 0.8m
    }
  }
  .ct create rectangle  0m 0m  5m 4m -fill cyan    -outline {}
  .ct create rectangle  5m 0m 10m 4m -fill magenta -outline {}
  .ct create rectangle 10m 0m 15m 4m -fill yellow  -outline {}
  .ct create rectangle 15m 0m 20m 4m -fill black   -outline {}
  .ct create rectangle 20m 0m 25m 4m -fill red     -outline {}
  .ct create rectangle 25m 0m 30m 4m -fill green   -outline {}
  .ct create rectangle 30m 0m 35m 4m -fill blue    -outline {}

  set dx [expr 40.0/256.0]
  for {set i 0} {$i < 256} {incr i 2} {
    set color [format "#%02x%02x%02x" $i $i $i]
    .ct create rectangle [expr $i*$dx]m 5m [expr ($i+2)*$dx]m 9m \
      -fill $color -outline ""
  }
  set X0 40
  set Y0 48
  .ct create line 40m 48m 80m 48m -width 0.2m
  .ct create line 40m 48m 40m 8m -width 0.2m
  for {set i 1} {$i <= 10} {incr i} {
    .ct create line 40m [expr $Y0-$i*4]m 80m [expr $Y0-$i*4]m -width 0.1m
  }
  drawcttrans
}

proc drawcttrans {} {
  global transfer inode

  .ct delete trans
  set X0 40
  set Y0 48
  set n [llength $transfer(cyan)]
  incr n -1
  set dx [expr 40.0/$n]
  foreach c {cyan magenta yellow black} {
    for {set i 0} {$i <= $n} {incr i} {
      set val [lindex $transfer($c) $i]
      set x [expr $i*$dx+$X0]
      set y [expr $Y0-$val*40.0]
      if {$i > 0} {
        .ct create line ${xold}m ${yold}m ${x}m ${y}m -fill $c \
          -width 0.3m -tags trans 
      }
      set xold $x
      set yold $y
    }
  }
}

proc drawtransfer {} {
  global transfer inode

  .cc delete all
  foreach x [array names inode] {
    unset inode($x)
  }
  set X0 50
  set Y0 260
  .cc create line 50 260 50 10
  for {set i 0} {$i <= 10} {incr i} {
    .cc create line 50 [expr $Y0-$i*25] 550 [expr $Y0-$i*25]
    .cc create text 20 [expr $Y0-$i*25] \
      -text [format %3.1f [expr $i*0.1]] -anchor w
  }
  set n [llength $transfer(cyan)]
  incr n -1
  set dx [expr 500.0/$n]
  foreach c {cyan magenta yellow black} {
    for {set i 0} {$i <= $n} {incr i} {
      set val [lindex $transfer($c) $i]
      set x [expr $i*$dx+$X0]
      set y [expr $Y0-$val*250.0]
      if {$i > 0} {
#        .cc create line $xold $yold $x $y -fill $c -tags $c
      }
      set inode($i,$c) [.cc create oval [expr $x-2] [expr $y-2] \
        [expr $x+2] [expr $y+2] \
        -fill $c -tags "node $c"]
      set xold $x
      set yold $y
    }
  }
}

proc movenode {x y} {
  global gs transfer

  if {$gs(x0) == ""} {
    set node [.cc find withtag current]
    if {[set l [getnode $node]] == ""} return
    foreach {gs(nr) gs(color)} $l break
    set gs(nodevalue) [lindex $transfer($gs(color)) $gs(nr)]
    set gs(node) [.cc find withtag current]
    set gs(x0) $x
    set gs(y0) $y
    bind .cc <Motion> {
      if {$gs(x0) == ""} return
      foreach {x0 y0 x1 y1} [.cc coords $gs(node) ] break
      .cc coords $gs(node) $x0 [expr %y-2] $x1 [expr %y+2]
      set gs(nodevalue) [format "%%5.3f" [expr (260-%y)*0.004]]
    }
  } else {
    bind .cc <Motion> {}
    set gs(x0) ""
    set transfer($gs(color)) [lreplace $transfer($gs(color)) $gs(nr) \
      $gs(nr) $gs(nodevalue)]
    drawcttrans
  }
}

proc cancelmove {} {
  global gs

  bind .cc <Motion> {}
  set gs(x0) ""
  drawtransfer
}

proc printdlg {} {
  global pr gs

  toplevel .pr
  wm title .pr "Test Print"
  label .pr.l -text "Page Position"
  grid .pr.l -row 0 -column 0 -columnspan 2
  for {set x 1} {$x <= 5} {incr x} {
    for {set y 0} {$y < 2} {incr y} {
      radiobutton .pr.x$x-$y -text "$x,[expr $y+1]" -variable pr(pos) \
        -value "$x $y"
      grid .pr.x$x-$y -row $x -column $y
    }
  }
  label .pr.lsheet -text "Sheet format:"
  entry .pr.esheet -textvariable gs(sheet)
  grid .pr.lsheet -row 6 -column 0
  grid .pr.esheet -row 6 -column 1
  label .pr.lcmd -text "Print command:"
  entry .pr.ecmd -textvariable gs(prcmd)
  grid .pr.lcmd -row 7 -column 0
  grid .pr.ecmd -row 7 -column 1
  button .pr.ok -text OK -default active -command "set pr(ok) 1"
  button .pr.cancel -text Cancel -command "set pr(ok) 0"
  grid .pr.ok -row 8 -column 0
  grid .pr.cancel -row 8 -column 1
  set oldfocus [focus]
  update 
  focus .pr.ok
  grab .pr
  tkwait variable pr(ok)
  grab release .pr
  focus $oldfocus
  destroy .pr
  if $pr(ok) {
    return $pr(pos)
  } else {
    return ""
  }
}

proc writeuppfile {file} {
  global gs transfer

  set fd [open $file w]
  foreach x $gs(parlist) {
    if {$x != ""} {
      puts -nonewline $fd $x
    }
  }
  puts $fd "-dupCyanTransfer=\"\{$transfer(cyan)\}\""
  puts $fd "-dupMagentaTransfer=\"\{$transfer(magenta)\}\""
  puts $fd "-dupYellowTransfer=\"\{$transfer(yellow)\}\""
  puts $fd "-dupBlackTransfer=\"\{$transfer(black)\}\""
  close $fd
}

proc print {} {
  global gs transfer

  set l [printdlg]
  if {$l == ""} return
  foreach {x y} $l break
  set ps [.ct postscript -pagewidth 8c -pageheight 5c \
    -pageanchor sw -pagex [expr 8*$y+1]c -pagey [expr 5*(5-$x)+2]c]
  regsub "%%EndComments\n" $ps \
    "%%DocumentPaperSizes: $gs(sheet)\n&$gs(sheet)\n" ps
  set fd [open test.ps w]
  puts -nonewline $fd $ps
  close $fd
  writeuppfile .test.upp
  eval exec gs @.test.upp -sPAPERSIZE=$gs(sheet) \
    -sOutputFile=- -q test.ps -c quit | $gs(prcmd)
}

proc mainwin {} {
  global gs
  
  wm protocol . WM_DELETE_WINDOW quit
  menu .mainmenu
  . configure -menu .mainmenu
  .mainmenu add cascade -label File -menu .mainmenu.mfile
  menu .mainmenu.mfile -tearoff 0
  .mainmenu.mfile add command -label Save -command save
  .mainmenu.mfile add command -label Quit -command quit

  canvas .cc -width 600 -height 270 -bg white
  frame .f
  entry .f.evalue -textvariable gs(nodevalue) -width 5
  button .f.bequal -text " = " -command "equalnodes"
  button .f.bplus -text " + " -command "changenodes 1"
  button .f.bminus -text " - " -command "changenodes -1"
  button .f.bscale -text Scale -command "scalenodes"
  entry .f.escale -textvariable gs(scale) -width 5
  radiobutton .f.rcyan -text cyan -fg cyan \
    -command ".cc raise cyan" -variable gs(upcolor) -value cyan
  radiobutton .f.rmagenta -text magenta -fg magenta \
    -command ".cc raise magenta" -variable gs(upcolor) -value magenta
  radiobutton .f.ryellow -text yellow -fg yellow \
    -command ".cc raise yellow" -variable gs(upcolor) -value yellow
  radiobutton .f.rblack -text black -fg black \
    -command ".cc raise black" -variable gs(upcolor) -value black
  button .f.bprint -text Print -command print
  grid .f.evalue -row 0 -column 0
  grid .f.bequal -row 1 -column 0
  grid .f.bplus -row 1 -column 1
  grid .f.bminus -row 1 -column 2
  grid .f.escale -row 1 -column 3
  grid .f.bscale -row 1 -column 4

  grid .f.rcyan -row 2 -column 0 -columnspan 3 -sticky w
  grid .f.rmagenta -row 3 -column 0 -columnspan 3 -sticky w
  grid .f.ryellow -row 4 -column 0 -columnspan 3 -sticky w
  grid .f.rblack -row 5 -column 0 -columnspan 3 -sticky w
  grid .f.bprint -row 2 -column 4 -columnspan 3 -sticky w
  canvas .ct -width 80m -height 50m -bg white
  pack .cc -side top
  pack .f -side left
  pack .ct -side right
  set gs(upcolor) black
  set gs(x0) ""
  bind .cc <1> {movenode %x %y}
  bind .cc <3> {cancelmove}
}

proc readfiles {} {
  global gs env argc argv

  set gs(prcmd) "lpr -Praw"
  set gs(sheet) "a4"
  if [file exists $env(HOME)/.gstransfer] {
    set fd [open $env(HOME)/.gstransfer r]
    while {![eof $fd]} {
      gets $fd line
      if {$line == ""} continue
      if [regexp {^ *#} $line] continue
      regexp {^ *([^ ]*) *(.*)} $line dummy par value
      set gs($par) $value
    }
    close $fd
  }
  if {$argc > 0} {
    set file [lindex $argv end]
  } else {
    set types {
      {{GhostScript Option Files} {.upp}}
    }
    set file [tk_getOpenFile -filetypes $types]
  }
  if {![file exists $file]} exit
  fileparse $file
}
 
proc save {} {
  set types {
    {{GhostScript Option Files} {.upp}}
  }
  set file [tk_getSaveFile -filetypes $types]
  if {$file != ""} {
    writeuppfile $file
  }
  return $file
}

proc quit {} {
  global gs env

  save
  set answer [tk_messageBox -message "Really quit?" -type yesno \
    -icon question]
  if {$answer != "yes"} return
  set fd [open $env(HOME)/.gstransfer w]
  foreach par {prcmd sheet} {
    puts $fd "$par $gs($par)"
  }
  close $fd
  exit
}

#main

puts "gstransfer version 0.1"
puts "Copyright 1999 Jens Poenisch, poenisch@wirtschaft.tu-chemnitz.de"
puts "Distribution is restricted by GNU Public License"
# first page position
set gs(scale) 1.0
set pr(pos) "1 0"
readfiles
mainwin
#drawcolortriangle
drawcolorcirc
drawtransfer
