interfaces/xmaxima/Tkmaxima/Plot3d.tcl

   1 ###### Plot3d.tcl #################################################
   2 #
   3 # Copyright (C) 1998 William F. Schelter
   4 # For distribution under GNU public License. See COPYING.tcl
   5 #
   6 #     Modified by Jaime E. Villate
   7 #     Time-stamp: "2024-03-20 14:40:38 villate
   8 #
   9 ###################################################################
  10
  11 global plot3dOptions
  12 set plot3dOptions {
  13     {xradius 1 "Width in x direction of the x values" }
  14     {yradius 1 "Height in y direction of the y values"}
  15
  16     {width 700 "Width of canvas in pixels"}
  17     {height 500 "Height of canvas in pixels" }
  18     {xcenter 0.0 {(xcenter,ycenter) is the origin of the window}}
  19     {ycenter 0.0 "see xcenter"}
  20     {zcenter 0.0 "see xcenter"}
  21     {bbox "" "xmin ymin xmax ymax zmin zmax overrides the -xcenter etc"}
  22     {zradius auto " Height in z direction of the z values"}
  23     {az 30 "azimuth angle" }
  24     {el 60 "elevation angle" }
  25
  26     {thetax 10.0 "ignored is obsolete: use az and el"}
  27     {thetay 20.0 "ignored is obsolete: use az and el"}
  28     {thetaz 30.0 "ignored is obsolete: use az and el"}
  29
  30     {flatten 1 "Flatten surface when zradius exceeded" }
  31     {zfun "" "a function of z to plot eg: x^2-y^2"}
  32     {parameters "" "List of parameters and values eg k=3,l=7"}
  33     {sliders "" "List of parameters ranges k=3:5,u"}
  34     {data  "" "a data set of type { variable_grid xvec yvec zmatrix}
  35     or {matrix_mesh xmat ymat zmat} or {grid {xmin xmax} {ymin ymax} zmatrix}"}
  36     {nsteps "10 10" "steps in x and y direction"}
  37     {rotationcenter "" "Origin about which rotation will be done"}
  38     {windowname ".plot3d" "window name"}
  39     {psfile "" "A filename where the graph will be saved in PostScript."}
  40     {nobox 0 "if not zero, do not draw the box around the plot."}
  41     {hue 0.25 "Default hue value."}
  42     {saturation 0.7 "Default saturation value."}
  43     {value 0.8 "Default brightness value."}
  44     {colorrange 0.5 "Range of colors used."}
  45     {gradlist {{0 "#00ff00"} {1 "#ff00ff"}} "Color gradient: List of values and colors."}
  46     {ncolors 180 "Number of colors used."}
  47     {colorscheme "hue" "Coloring Scheme (hue, saturation, value, gray, gradient or 0)."}
  48     {mesh_lines "black" "Color for the meshes outline, or 0 for no outline."}
  49 }
  50
  51
  52 ## source Matrix.tcl
  53
  54 proc transformPoints { pts fun } {
  55     set ans ""
  56     foreach { x y z } $pts {
  57         append ans " "
  58         append ans [$fun $x $y $z]
  59     }
  60     return $ans
  61 }
  62
  63 proc calculatePlot3d {win fun  nx ny } {
  64     global plot3dMeshes$win
  65     set meshes  plot3dMeshes$win
  66     makeLocal $win xradius xmin yradius ymin zradius zcenter flatten
  67
  68     set stepx [expr { 2*$xradius / double($nx)}]
  69     set stepy [expr { 2*$yradius / double($ny)} ]
  70     set i 0
  71     set j 0
  72     set zmax -1000000000
  73     set zmin 1000000000
  74     # check if zradius is a number
  75     set dotruncate [expr ![catch {expr {$zradius + 1} }]]
  76     if { $dotruncate } {
  77         if { $flatten } { set dotruncate 0 }
  78         set zzmax [expr {$zcenter + $zradius}]
  79         set zzmin [expr {$zcenter - $zradius}]
  80         #puts "zzmax=$zzmax,$zzmin"
  81     } else {
  82         set flatten 0
  83     }
  84
  85     catch { unset  $meshes }
  86     set k 0
  87     for {set i 0} { $i <= $nx } { incr i} {
  88         set x [expr { $xmin + $i * $stepx }]
  89         for {set j 0} { $j <= $ny } { incr j} {
  90             set y [expr { $ymin + $j *$stepy }]
  91             if { [catch {  set z [$fun $x $y] }] } {
  92                 set z nam
  93             } elseif { $dotruncate  &&  ($z > $zzmax || $z < $zzmin) } {
  94                 set z nam
  95
  96             } else {
  97                 if { $flatten } {
  98                     if { $z > $zzmax } { set z $zzmax } elseif {
  99                                                                 $z < $zzmin } { set z $zzmin }}
 100
 101                 if { $z < $zmin }  { set zmin $z } elseif {
 102                                                            $z > $zmax } { set zmax $z }
 103                 if { $j != $ny && $i != $nx } {
 104                     set [set meshes]($k) \
 105                         "$k [expr { $k+3 }] [expr { $k+3+($ny+1)*3 }] \
 106                       [expr { $k+($ny+1)*3 }]"} else {
 107                           # set plot3dMeshes($k) ""
 108                       }
 109             }
 110             incr k 3
 111             append ans " $x $y $z"
 112         }
 113     }
 114     oset $win zmin $zmin
 115     oset $win zmax $zmax
 116     oset $win points $ans
 117     oset $win nx $nx
 118     oset $win ny $ny
 119     oset $win colorfun plot3dcolorFun
 120     addAxes $win
 121     setupPlot3dColors $win
 122 }
 123
 124 proc calculatePlot3data {win fun  nx ny } {
 125     # calculate the 3d data from function:
 126     makeLocal $win xradius xmin xmax ymax yradius ymin zradius zcenter flatten
 127
 128     set rowx [linspace $xmin $xmax $nx]
 129     set rowy [linspace $ymin $ymax $ny]
 130     foreach  y $rowy {
 131         set row ""
 132         foreach x $rowx {
 133             if { [catch {  set z [$fun $x $y] }] } {
 134                 set z nam
 135             }
 136             lappend row $z
 137         }
 138         lappend matrix $row
 139     }
 140     global silly
 141     set silly [list variable_grid $rowx $rowy $matrix ]
 142     return [list variable_grid $rowx $rowy $matrix ]
 143
 144 }
 145
 146 proc addAxes { win } {
 147     #global plot3dPoints plot3dMeshes xradius yradius xcenter ycenter
 148     global [oarray $win] plot3dMeshes$win
 149     linkLocal $win lmesh
 150     makeLocal $win   xradius yradius xcenter ycenter  points zmax zcenter zmin
 151     set meshes plot3dMeshes$win
 152     set ll [llength $points]
 153
 154     # puts "oset $win  axisstart  $ll"
 155     oset $win  axisstart  $ll
 156     set nx2 5
 157     set ny2 5
 158     set xstep [expr { 1.2 * $xradius/double($nx2) }]
 159     set ystep [expr { 1.2 * $yradius/double($ny2) }]
 160     set nz2 $ny2
 161
 162     set ans " "
 163     set x0 $xcenter
 164     set y0 $ycenter
 165     set z0 $zcenter
 166
 167     set k $ll
 168     for { set i 0 } { $i < $nx2 } { incr i } {
 169         append ans "[expr {$x0 +$i * $xstep}] $y0 $z0 "
 170         lappend lmesh [list $k [incr k 3]]
 171         #set [set meshes]($k) "$k [incr k 3]"
 172     }
 173     append ans "[expr {$x0 +$nx2 * $xstep}] $y0 $z0 "
 174     incr k 3
 175     # set plot3dMeshes($k) ""
 176
 177     for { set i 0 } { $i < $ny2 } { incr i } {
 178         append ans "$x0 [expr {$y0 +$i * $ystep}] $z0 "
 179         lappend lmesh [list $k [incr k 3]]
 180         #set [set meshes]($k) "$k [incr k 3]"
 181     }
 182     append ans "$x0 [expr {$y0 +$ny2 * $ystep}] $z0 "
 183     incr k 3
 184     # set $meshes($k) ""
 185
 186     set zstep [expr {1.2 * $zmax/double($nz2)}]
 187     if { $zstep < $ystep } { set zstep $ystep }
 188
 189     for { set i 0 } { $i < $ny2 } { incr i } {
 190         append ans "$x0 $y0 [expr {$z0 +$i * $zstep}] "
 191         # puts "set [set meshes]($k) \"$k [incr k 3]\""
 192         lappend lmesh [list $k [incr k 3]]
 193         # set [set meshes]($k) "$k [incr k 3]"
 194     }
 195     append ans "$x0 $y0 [expr {$z0 +$nz2 * $zstep}] "
 196     incr k 3
 197     # puts "ans=$ans"
 198     append [oloc $win points] $ans
 199
 200     # set $meshes($k) ""
 201
 202 }
 203
 204 proc addBbox { win } {
 205     global plot3dMeshes$win
 206     makeLocal $win xmin xmax ymin ymax zmin zmax cmap
 207     linkLocal $win points lmesh
 208     set ll [llength $points]
 209     append points " $xmin $ymin $zmin \
 210             $xmax $ymin $zmin \
 211             $xmin $ymax $zmin \
 212             $xmax $ymax $zmin \
 213             $xmin $ymin $zmax \
 214             $xmax $ymin $zmax \
 215             $xmin $ymax $zmax \
 216             $xmax $ymax $zmax "
 217     foreach  { a b } { 0 1 0 2 2 3 3 1
 218         4 5 4 6 6 7 7 5
 219         0 4 1 5 2 6 3 7  }  {
 220         set k [expr {$a*3 + $ll}]
 221         set l [expr {$b*3 + $ll}]
 222         # set plot3dMeshes${win}($k) [list $k $l]
 223         lappend lmesh [list $k $l]
 224     }
 225     lappend lmesh [list $ll]
 226     oset $win $cmap,[list $ll [expr {$ll + 3}]] red
 227     oset $win $cmap,[list $ll [expr {$ll + 6}]] blue
 228     oset $win $cmap,[list $ll [expr {$ll + 12}]] green
 229
 230     oset $win special($ll) "drawOval [oget $win c] 3 -fill red -tags axis"
 231 }
 232
 233 proc drawOval { c radius args } {
 234     set ll [llength $args]
 235     set x [lindex $args [expr {$ll -2}]]
 236     set y [lindex $args [expr {$ll -1}]]
 237     set rest [lrange $args 0 [expr {$ll -3}]]
 238     set com [concat $c create oval [expr {$x - $radius}]  [expr {$y - $radius}] [expr {$x + $radius}]  [expr {$y + $radius}] $rest]
 239     eval $com}
 240
 241 proc plot3dcolorFun {win z } {
 242     makeLocal $win zmin zmax ncolors hue saturation value colorrange colorscheme gradlist
 243     if { $z < $zmin || $z > $zmax } {return "none"}
 244     set h [expr { 360*$hue }]
 245     if { ($value > 1) || ($value < 0) } {
 246         set value [expr { $value - floor($value) }]}
 247     set tem [expr {(double($colorrange)/$ncolors)*round(($z - $zmin)*$ncolors/($zmax - $zmin+.001))}]
 248     switch -exact $colorscheme {
 249         "hue" { return [hsv2rgb [expr { 360*$tem+$h }] $saturation $value] }
 250         "saturation" { return [hsv2rgb $h [expr { $tem+$saturation }] $value] }
 251         "value" { return [hsv2rgb $h $saturation [expr {$tem+$value}]] }
 252         "gray"  { set g [expr { round( ($tem+$value)*255 ) } ]
 253             return  [format "\#%02x%02x%02x" $g $g $g] }
 254         "gradient" {
 255             for {set i 0} {$i < [llength $gradlist]} {incr i} {
 256                 if {$tem < [lindex $gradlist $i 0]} break}
 257             if {$i == 0} {
 258                 return [lindex $gradlist 0 1]
 259             }
 260             set down [lindex $gradlist [expr $i-1] 0]
 261             set up [lindex $gradlist $i 0]
 262             return [interpolatecolor [lindex $gradlist [expr $i-1] 1] [lindex $gradlist $i 1] [expr {($tem-$down)/($up-$down)}]]}
 263         "0" { return "#ffffff" }}}
 264
 265 proc setupPlot3dColors { win first_mesh} {
 266     upvar #0 [oarray $win] wvar
 267     # the default prefix for cmap
 268     set wvar(cmap) c1
 269     makeLocal $win colorfun points lmesh
 270     foreach tem [lrange $lmesh $first_mesh end] {
 271         set k [llength $tem]
 272         if { $k == 4 } {
 273             set z [expr { ([lindex $points [expr { [lindex $tem 0] + 2 } ]] +
 274                            [lindex $points [expr { [lindex $tem 1] + 2 } ]] +
 275                            [lindex $points [expr { [lindex $tem 2] + 2 } ]] +
 276                            [lindex $points [expr { [lindex $tem 3] + 2 } ]])/
 277                           4.0 } ]
 278             catch { set wvar(c1,[lindex $tem 0]) [$colorfun $win $z] }
 279         }
 280     }
 281 }
 282
 283 proc calculateRotated { win } {
 284     set pideg [expr {3.14159/180.0}]
 285     linkLocal $win scalemat
 286     makeLocal $win az el rotationcenter xradius zradius yradius
 287     set rotmatrix [rotationMatrix [expr {$az*$pideg }] [expr {$el*$pideg}] ]
 288
 289     # shrink by .2 on z axis
 290     # set fac [expr  {[vectorlength $xradius $yradius] / (sqrt(2) * $zradius)}]
 291
 292     set rotmatrix [ matMul  $rotmatrix $scalemat]
 293     set tem [matMul $scalemat $rotationcenter]
 294
 295     mkMultLeftFun  $rotmatrix _rot$win
 296     set rot _rot$win
 297     set ans ""
 298     # puts "points=[oget $win points]"
 299     if { $rotationcenter ne "" } {
 300         #puts "rotationcenter = $rotationcenter"
 301         set constant [vectorOp $tem - [eval $rot $rotationcenter]]
 302         mkMultLeftFun  $rotmatrix _rot$win $constant
 303     }
 304     #puts "win $win"
 305     foreach { x y z } [oget $win points] {
 306         if { [catch { append ans " " [$rot $x $y $z] } ] } {
 307             append ans "  nam nam nam " }
 308     }
 309     oset $win rotatefun $rot
 310     oset $win rotated $ans
 311 }
 312
 313 proc getOrderedMeshIndices { win } {
 314     #   global  plot3dMeshes$win
 315     #    set meshes plot3dMeshes$win
 316     linkLocal $win lmesh
 317     # puts "array names $meshes =[array names $meshes ]"
 318     # get the list offset by 2, so the lindex indices grab the Z coordinate.
 319     # without having to add 2.
 320     set pts2 [lrange [oget $win rotated] 2 end]
 321     set i 0
 322     foreach tem $lmesh {
 323         set k [llength $tem]
 324         if { [catch {
 325             if {  $k == 4 } {
 326                 set z [expr { ([lindex $pts2 [lindex $tem 0]] \
 327                                    +[lindex $pts2 [lindex $tem 1]] \
 328                                    + [lindex $pts2 [lindex $tem 2]] \
 329                                    + [lindex $pts2 [lindex $tem 3]])/4.0 }]
 330             } elseif { $k == 2 } {
 331                 set z [expr { ([lindex $pts2 [lindex $tem 0]] \
 332                                    +[lindex $pts2 [lindex $tem 1]])/2.0 }]
 333             } else {
 334                 set z 0
 335                 foreach w $tem {
 336                     set z [expr {$z + [lindex $pts2 $w] }  ]
 337
 338                 }
 339                 set z [expr { $z/double($k)}]
 340             }
 341             lappend ans [list $z $i]
 342             # append pp($z) "$i "
 343             incr i
 344
 345         } ]} {
 346             set lmesh [lreplace $lmesh $i $i]
 347         }
 348     }
 349     set ttem [lsort -real -index 0 $ans]
 350     set ans {}
 351     foreach v $ttem {
 352         lappend ans [lindex $v 1]
 353     }
 354     oset $win meshes $ans
 355     return
 356 }
 357
 358 #
 359 #-----------------------------------------------------------------
 360 #
 361 # set_xy_region_3d --  set up the bounds of the x and y coordinates
 362 # of the projection of the surface on the xy plane and the part of the
 363 # window that will be filled by that projection (fac, a number between
 364 # 0 and 1).
 365 #
 366 #----------------------------------------------------------------
 367 #
 368 proc set_xy_region_3d { win fac } {
 369     linkLocal $win scalemat
 370     makeLocal $win xcenter ycenter xradius yradius xmin xmax ymin ymax zradius
 371     set scalemat [list [list [expr {1.5/($xradius)}] 0 0] \
 372                       [list 0 [expr {1.5/($yradius)}] 0] \
 373                       [list 0 0 [expr {1.5/($zradius)}]]]
 374     oset $win fac $fac
 375     oset $win xmin [expr {1.5*$xmin/($xradius)}]
 376     oset $win xmax [expr {1.5*$xmax/($xradius)}]
 377     oset $win ymin [expr {1.5*$ymin/($yradius)}]
 378     oset $win ymax [expr {1.5*$ymax/($yradius)}]}
 379
 380 proc plot3d { args } {
 381     global  plot3dOptions
 382     set win [assoc -windowname $args]
 383     if { "$win" == "" } {
 384         set win [getOptionDefault windowname $plot3dOptions] }
 385     clearLocal $win
 386     mkPlot3d  $win {*}$args
 387     #    bind $win <Configure> {}
 388     replot3d $win
 389 }
 390
 391 proc replot3d { win } {
 392     global printOption
 393     makeLocal $win nsteps zfun data c
 394     linkLocal $win parameters sliders psfile nobox
 395
 396     oset $win maintitle    "concat \"Plot of z = [oget $win zfun]\""
 397     if { [llength $nsteps] == 1 }    {
 398         oset $win nsteps \
 399             [set nsteps  [list [lindex $nsteps 0] [lindex $nsteps 0]]]
 400     }
 401
 402     set sliders [string trim $sliders]
 403     if { "$sliders" != "" && ![winfo exists $c.sliders] } {
 404         addSliders $win
 405     }
 406
 407     set zfun [string trim $zfun]
 408     if { "$zfun" != "" } {
 409         proc _xf {  x  y } "return \[expr { [sparseWithParams $zfun {x y} $parameters ] } \]"
 410         addOnePlot3d $win [calculatePlot3data $win _xf  [lindex $nsteps 0] [lindex $nsteps 1]]
 411         # calculatePlot3d $win _xf [lindex $nsteps 0] [lindex $nsteps 1]
 412     }
 413
 414     set data [string trim $data]
 415     if { "$data" != "" } {
 416         if { 0 } {
 417             puts "here"
 418             set ranges [ plot3dGetDataRange [list $data]]
 419             linkLocal $win zmin zmax
 420             desetq "zmin zmax" [lindex $ranges 2]
 421             puts "ranges=$ranges"
 422             set some [plot2dRangesToRadius [lindex $ranges 0] [lindex $ranges 1] ""]
 423             puts "and now"
 424             foreach {v k} $some {
 425                 puts "oset $win [string range $v 1 end] $k"
 426                 oset $win [string range $v 1 end] $k
 427             }
 428         }
 429
 430         addOnePlot3d $win $data
 431     }
 432
 433     if { $nobox == 0 } {
 434         addBbox $win
 435     }
 436
 437     set_xy_region_3d $win 0.5
 438     set_xy_transforms $win
 439     # grab the bbox just as itself
 440     global maxima_priv
 441     linkLocal $win lmesh
 442     if { [llength $lmesh] > 100 * $maxima_priv(speed)  } {
 443         # if we judge that rotation would be too slow, we make a secondary list
 444         # of meshes (random) including the bbox, and display those.
 445         linkLocal $win  points lmeshBbox pointsBbox
 446         set n [llength $lmesh]
 447         set lmeshBbox [lrange $lmesh [expr {$n -13}] end]
 448         set i 0 ;
 449         while { [incr i ] < ( 35*$maxima_priv(speed)) } {
 450             set j [expr {round(floor(rand()*($n-13))) }]
 451             if { ![info exists temm($j)] } {
 452                 lappend lmeshBbox [lindex $lmesh $j ]
 453                 set temm(j) 1
 454             }
 455         }
 456         resetPtsForLmesh $win
 457     }
 458     oset $win lastAnglesPlotted ""
 459     setView $win ignore
 460
 461     # Create a PostScript file, if requested
 462     if { $psfile != "" } {
 463         set printOption(psfilename) $psfile
 464         writePostscript $win
 465         $c delete printoptions
 466         eval [$win.menubar.close cget -command]
 467     }
 468
 469 }
 470
 471 proc setView { win ignore } {
 472     global timer
 473     foreach v [after info] {
 474         #puts "$v=<[after info $v]>"
 475         if {[lindex [after info $v] 0] == "setView1" } {
 476             after cancel $v
 477         }
 478     }
 479     after 2 setView1 $win
 480 }
 481
 482 proc setView1 { win  } {
 483     linkLocal $win lastAnglesPlotted points
 484     set new [list [oget  $win az] [oget  $win el] ]
 485     if { "$new" != "$lastAnglesPlotted" } {
 486         makeLocal $win c
 487         calculateRotated $win
 488         getOrderedMeshIndices $win
 489         drawMeshes $win $c
 490         oset $win lastAnglesPlotted $new
 491     }
 492 }
 493
 494 proc setQuick { win on } {
 495     linkLocal $win  lmesh  points savedData cmap        lmeshBbox pointsBbox
 496     if { $on } {
 497         if { ![info exists savedData] && [info exists lmeshBbox] } {
 498             set savedData [list $lmesh $points $cmap]
 499             set lmesh $lmeshBbox
 500             set points $pointsBbox
 501             set cmap c2
 502         }
 503     } else {
 504         if { [info exists savedData] } {
 505             desetq "lmesh points cmap" $savedData
 506             unset savedData
 507             oset $win lastAnglesPlotted ""
 508         }
 509     }
 510 }
 511
 512
 513 # reduce the set of pointsBbox to include only those needed by lmeshBbox
 514 proc resetPtsForLmesh { win } {
 515     upvar 1 lmeshBbox lmeshBbox
 516     upvar 1 pointsBbox pointsBbox
 517     upvar 1 points points
 518     upvar #0 [oarray $win] wvar
 519     set k 0
 520     foreach v $lmeshBbox {
 521         if { [llength $v] == 1 } {
 522             lappend nmesh $v
 523         } else {
 524             set s ""
 525             foreach w $v {
 526                 if { [info exists tem($w)] } {
 527                     lappend s $tem($w)
 528                 } else {
 529                     set tem($w) $k
 530                     lappend s $k
 531                     lappend pointsBbox \
 532                         [lindex $points $w] \
 533                         [lindex $points [expr {$w +1}]] \
 534                         [lindex $points [expr {$w +2}]]
 535                     catch {set wvar(c2,$k) $wvar(c1,$w)}
 536                     incr k 3
 537
 538                 }
 539
 540             }
 541             lappend nmesh $s
 542             if { [info exists wvar(c1,$v)] } {
 543                 set wvar(c2,$s) $wvar(c1,$v)
 544             }
 545         }
 546     }
 547     set lmeshBbox  $nmesh
 548 }
 549
 550 proc drawMeshes {win canv} {
 551     # $canv delete poly
 552     # only delete afterwards, to avoid relinquishing the colors
 553     $canv addtag oldpoly withtag poly
 554     $canv delete axis
 555     makeLocal $win lmesh rotated cmap
 556     upvar #0 [oarray $win] ar
 557     proc _xf { x} [info body rtosx$win]
 558     proc _yf { y} [info body rtosy$win]
 559     foreach { x y z} $rotated { lappend rotatedxy [_xf $x] [_yf $y] 0 }
 560
 561     foreach k [oget $win meshes] {
 562         #puts "drawOneMesh $win $canv $k"
 563         #puts "drawOneMesh $win $canv $k"
 564         set mesh [lindex $lmesh $k]
 565         set col black
 566         catch { set col $ar($cmap,[lindex $mesh 0]) }
 567         drawOneMesh $win $canv $k $mesh $col
 568     }
 569     $canv delete oldpoly
 570 }
 571
 572
 573 #
 574 #-----------------------------------------------------------------
 575 # plot3dMeshes  --  given K an index in plot3dPoints(points)
 576 # if this is the index of a lower grid corner, return the other points.
 577 # k takes values 0,3,6,9,... the values returned all have a 3 factor,
 578 # and so are true lindex indices into the list of points.
 579 # returns {} if this is not a mesh point.
 580 #  Results:
 581 #
 582 #  Side Effects: none... NOTE we should maybe cash this in an array.
 583 #
 584 #----------------------------------------------------------------
 585 #
 586
 587 proc drawOneMesh { win  canv k mesh color } {
 588     #k=i*(ny+1)+j
 589     # k,k+1,k+1+nyp,k+nyp
 590     makeLocal $win mesh_lines
 591     upvar 1 rotatedxy ptsxy
 592     set n [llength $mesh]
 593
 594     foreach kk $mesh {
 595         lappend coords [lindex $ptsxy $kk] [lindex $ptsxy [expr {$kk + 1}]]
 596     }
 597     if { $n <= 2 } {
 598         #puts "drawing $k,n=$n $coords, points $mesh "
 599         #desetq "a b" $mesh
 600         #puts "<[lrange $points $a [expr {$a +2}]]> <[lrange $points $b [expr {$b +2}]]"
 601         if { $n == 2 } {
 602             #       set color black
 603             #       catch { set color [oget $win $cmap,$mesh]}
 604
 605             eval $canv create line $coords -tags [list [list axis mesh.$k]] \
 606                 -fill $color -width 2
 607         } else {
 608             # puts "doing special $mesh, $coords"
 609             catch { set tem [oget $win special([lindex $mesh 0])]
 610                 eval [concat $tem $coords]
 611             }
 612         }
 613     } elseif { [string length $color] < 8 && $color != "none"} {
 614         if { $mesh_lines != 0 } {
 615             set outline "-outline $mesh_lines"
 616         } else {
 617             set outline ""
 618         }
 619         eval $canv create polygon $coords -tags [list [list poly mesh.$k]] \
 620             -fill $color $outline
 621     }
 622 }
 623
 624
 625 proc makeFrame3d { win } {
 626     global plot3dPoints
 627     set w [makeFrame $win 3d]
 628     set top $w
 629     catch { set top [winfo parent $w]}
 630     catch {
 631         wm title $top {Xmaxima: plot3d}
 632         wm iconname $top "plot3d"
 633     }
 634     #pack $w
 635 }
 636
 637 proc mkPlot3d { win  args } {
 638     global plot3dOptions  printOption [oarray $win] axisGray
 639     getOptions $plot3dOptions $args -usearray [oarray $win]
 640     setPrintOptions $args
 641     set printOption(maintitle) ""
 642     set wb $win.menubar
 643     setupCanvas $win
 644     # catch { destroy $win }
 645     makeFrame3d $win
 646     oset $win sliderCommand sliderCommandPlot3d
 647     oset $win noaxisticks 1
 648
 649     makeLocal $win buttonFont c
 650     [winfo parent $c].position config -text {}
 651     bind $c <Motion> ""
 652
 653     setForRotate $win
 654 }
 655
 656 proc doConfig3d { win } {
 657     desetq "wb1 wb2" [doConfig $win]
 658     makeLocal $win buttonFont
 659
 660     mkentry $wb1.zfun [oloc $win zfun]  "z=f(x,y)" $buttonFont
 661     mkentry $wb1.nsteps [oloc $win nsteps]  [mc "Number of mesh grids"]  $buttonFont
 662
 663     pack $wb1.zfun  $wb1.nsteps
 664     pack            $wb1.zfun  $wb1.nsteps
 665     foreach w {xradius yradius xcenter ycenter zcenter zradius parameters } {
 666         mkentry $wb1.$w [oloc $win $w] $w $buttonFont
 667         pack $wb1.$w
 668     }
 669
 670     scale $wb1.rotxscale -label [mc "azimuth"]  \
 671         -orient horizontal -length 150 -from -180 -to 180 -resolution 1 \
 672         -command "setView $win" -variable [oloc $win az] -tickinterval 120 -font $buttonFont
 673
 674     scale $wb1.rotyscale -label [mc "elevation"]  \
 675         -orient horizontal -length 150 -from -180 -to 180 -resolution 1 \
 676         -command "setView $win" -variable [oloc $win el] -tickinterval 120 -font $buttonFont
 677
 678
 679     #    scale $wb1.rotzscale -label "thetaz"  \
 680         #           -orient horizontal -length 150 -from -180 -to 180 \
 681         #           -command "setView $win" -variable [oloc $win thetaz] -tickinterval 120 -font $buttonFont
 682
 683     pack   $wb1.rotxscale   $wb1.rotyscale
 684
 685 }
 686
 687
 688 proc showPosition3d { win x y } {
 689     # global position c
 690     makeLocal $win c
 691     set x [$c canvasx $x]
 692     set y [$c canvasy $y]
 693     set it [ $c find closest $x $y]
 694     set tags [$c gettags $it]
 695     if { [regexp {mesh[.]([0-9]+)} $tags junk k] } {
 696         set i 0
 697         set min 1000000
 698         set at 0
 699         # find closest.
 700         foreach {x1 y1} [$c coords $it] {
 701             set d [expr {($x1 - $x)*($x1 - $x)+($y1 - $y)*($y1 - $y)}]
 702             if { $d < $min} { set at $i ; set min $d }
 703             incr i
 704         }
 705         set mesh [lindex [oget $win lmesh] $k]
 706         set ll [lindex $mesh $at]
 707         set pt [lrange [oget $win points] $ll [expr {$ll + 2}]]
 708         # puts pt=$pt
 709         catch { $win.position config -text [eval [concat "format {(%.2f %.2f %.2f)}" $pt]] }
 710     }
 711     #    oset $win position [format {(%.1f %.1f)} $x $y]
 712     #    oset $win position \
 713         #      "[format {(%.2f,%.2f)}  [storx$win [$c canvasx $x]] [story$win [$c canvasy $y]]]"
 714 }
 715
 716
 717
 718 #
 719 #-----------------------------------------------------------------
 720 #
 721 # rotateRelative --  do a rotation indicated by a movement
 722 # of dx,dy on the screen.
 723 #
 724 #  Results:
 725 #
 726 #  Side Effects:
 727 #
 728 #----------------------------------------------------------------
 729 #
 730
 731 proc rotateRelative { win x1 x2 y1 y2 } {
 732     makeLocal $win c az el rotatefun
 733     set x1 [$c canvasx $x1]
 734     set x2 [$c canvasx $x2]
 735     set y1 [$c canvasy $y1]
 736     set y2 [$c canvasy $y2]
 737     set xx [expr {$x2-$x1}]
 738     set yy [expr {($y2-$y1)}]
 739     set res [$rotatefun 0 0 1]
 740     set res1 [$rotatefun 0 0 0]
 741     set fac [expr {([lindex $res 1] > [lindex $res1 1] ? -1 : 1) }] ;
 742     # puts "fac=$fac,[lindex $res 1],[lindex $res1 1]"
 743     oset $win az [reduceMode360 [expr   {round($az + $fac *  $xx /2.0) }]]
 744     oset $win el [reduceMode360 [expr   {round($el -  $yy /2.0) }]]
 745     setView $win ignore
 746 }
 747
 748 proc reduceMode360 { n } {
 749     return [  expr fmod(($n+180+5*360),360)-180]
 750
 751 }
 752
 753 proc setForRotate { win} {
 754     makeLocal $win c
 755     $c delete printrectangle
 756     bind $c  <Button-1> "setQuick $win 1 ; doRotateScreen $win %x %y "
 757     bind $c  <ButtonRelease-1> "setQuick $win 0 ; setView $win ignore"
 758 }
 759 proc doRotateScreen { win x y } {
 760     makeLocal $win c
 761     oset $win lastx $x
 762     oset $win lasty $y
 763     bind $c <B1-Motion> "doRotateScreenMotion $win %x %y"
 764 }
 765
 766 proc doRotateScreenMotion {win x y } {
 767     makeLocal $win lastx lasty
 768     set dx [expr {$x - $lastx}]
 769     set dy [expr {$y - $lasty}]
 770     if { [vectorlength $dx $dy] < 4 } { return }
 771     rotateRelative $win $lastx $x $lasty $y
 772     oset $win lastx $x
 773     oset $win lasty $y
 774     # show values of azimuth and elevation angles
 775     set az [oget $win az]
 776     set el [oget $win el]
 777     catch { $win.position config -text [eval [concat "format {Azimuth: %.2f, Elevation: %.2f}" $az $el]] }
 778 }
 779
 780
 781 proc sliderCommandPlot3d { win var val } {
 782     linkLocal $win recompute
 783
 784     updateParameters $win $var $val
 785     set com "recomputePlot3d $win"
 786     # allow for fast move of slider...
 787     #mike FIXME: this is a wrong use of after cancel
 788     after cancel $com
 789     after 10 $com
 790 }
 791
 792 proc recomputePlot3d { win } {
 793     linkLocal $win  recompute
 794     if { [info exists recompute]  } {
 795         incr recompute
 796         return
 797     } else {
 798         set recompute 1
 799     }
 800     set redo 0
 801     while { $redo != $recompute } {
 802         set redo $recompute
 803         #       puts "replot3d $win,[oget $win parameters]"
 804         catch {replot3d $win }
 805         update
 806     }
 807     unset recompute
 808 }
 809
 810
 811 ## endsource plot3d.tcl