1############################################################################# 2# Author: # 3# ------ # 4# Anton Kokalj Email: Tone.Kokalj@ijs.si # 5# Department of Physical and Organic Chemistry Phone: x 386 1 477 3523 # 6# Jozef Stefan Institute Fax: x 386 1 477 3811 # 7# Jamova 39, SI-1000 Ljubljana # 8# SLOVENIA # 9# # 10# Source: $XCRYSDEN_TOPDIR/Tcl/FS_Main.tcl 11# ------ # 12# Copyright (c) 1996-2003 by Anton Kokalj # 13############################################################################# 14 15# 16# NOTE: XSF file and (band)XSF file must alreadu be read !!! 17# 18proc FS_GoFermi {{spin {}}} { 19 global fs xcMisc system 20 21 if { ! [info exists fs(counter)] } { 22 set fs(counter) 0 23 } else { 24 incr fs(counter) 25 } 26 27 set fs($spin,togl_w) [expr int(750 * $xcMisc(resolution_ratio1))] 28 set fs($spin,togl_h) $fs($spin,togl_w) 29 30 xcDebug -debug "FS_GoFermi> xcMisc(resolution_ratio1) = $xcMisc(resolution_ratio1)" 31 32 # NOTE: 33 #------- 34 # prevent the mass that can be done by going several times trough 35 # the "Render Fermi Surface" process for WIEN 36 set t .fs${spin} 37 if { [winfo exists $t] } { 38 return 39 } 40 toplevel $t 41 if { $spin == "dn" } { 42 wm geometry $t +0-0 43 } else { 44 wm geometry $t -0+0 45 } 46 47 global exit_viewer_win 48 set exit_viewer_win $t 49 bind $t <Destroy> "exit_viewer $t" 50 51 if { ! [info exists xcMisc(titlefile)] } { 52 set xcMisc(titlefile) $fs(titlefile) 53 } 54 if { $spin != {} } { 55 wm title $t "*** XCrySDen - Fermi Surface ($spin spin): [file tail $xcMisc(titlefile)]" 56 } else { 57 wm title $t "*** XCrySDen - Fermi Surface: [file tail $xcMisc(titlefile)]" 58 } 59 wm iconname $t "Fermi Surface" 60 wm iconbitmap . @$system(BMPDIR)/xcrysden.xbm 61 62 set nb [NoteBook $t.nb -width $fs($spin,togl_w) -height $fs($spin,togl_h)] 63 pack $nb -expand 1 -fill both 64 set fs($spin,nb) $nb 65 66 set fs($spin,bandlist) "" 67 set fs($spin,togllist) "" 68 69 set _first_band -1 70 putsFlush stderr "NBANDS = $fs($spin,nbands)" 71 for {set i 1} {$i <= $fs($spin,nbands)} {incr i} { 72 if { $fs($spin,$i,band_selected) } { 73 if { $_first_band == -1 } { 74 set _first_band $i 75 } 76 # initialize variables 77 FS_InitVar $i $spin 78 79 $nb insert $i band$i -text "Band #$i" \ 80 -createcmd [list FS_RenderSurface $i $spin] 81 82 # 83 # page container frame 84 # 85 set f [$nb getframe band$i] 86 set togl $f.togl$i 87 lappend fs($spin,bandlist) $i 88 lappend fs($spin,togllist) $togl 89 90 # 91 # toolbox frame 92 # 93 set ft [frame $f.container -relief raised -bd 1] 94 pack $ft -side top -expand 0 -fill x -padx 0m -pady 0m 95 FS_Toolbox $ft $togl $spin $i 96 set fs($spin,$i,show_toolbox_frame) 1 97 set fs($spin,$i,toolbox_frame) $ft 98 set fs($spin,$i,toolbox_frame_pack) [pack info $ft] 99 set fs($spin,$i,toolbox_frame_packbefore) $togl 100 101 # 102 # Togl 103 # 104 global toglOpt 105 106 set fs($spin,$i,togl) \ 107 [togl $togl \ 108 -ident $togl \ 109 -rgba true \ 110 -rgba $toglOpt(rgba) \ 111 -redsize $toglOpt(redsize) \ 112 -greensize $toglOpt(greensize) \ 113 -bluesize $toglOpt(bluesize) \ 114 -double $toglOpt(double) \ 115 -depth $toglOpt(depth) \ 116 -depthsize $toglOpt(depthsize) \ 117 -accum $toglOpt(accum) \ 118 -accumredsize $toglOpt(accumredsize) \ 119 -accumgreensize $toglOpt(accumgreensize) \ 120 -accumbluesize $toglOpt(accumbluesize) \ 121 -accumalphasize $toglOpt(accumalphasize) \ 122 -alpha $toglOpt(alpha) \ 123 -alphasize $toglOpt(alphasize) \ 124 -stencil $toglOpt(stencil) \ 125 -stencilsize $toglOpt(stencilsize) \ 126 -auxbuffers $toglOpt(auxbuffers) \ 127 -overlay $toglOpt(overlay) \ 128 -stereo $toglOpt(stereo) \ 129 -time $toglOpt(time) \ 130 -create togl_create \ 131 -display togl_display \ 132 -reshape togl_reshape \ 133 -destroy togl_destroy \ 134 -timer togl_timer ] 135 136 pack $togl -fill both -expand 1 137 update 138 139 # take care of togl's background 140 FS_UserBackground $togl 141 142 # 143 bind $fs($spin,$i,togl) <B1-Motion> { xc_B1motion %W %x %y } 144 bind $fs($spin,$i,togl) <B2-Motion> { xc_B2motion %W %x %y } 145 bind $fs($spin,$i,togl) <B1-ButtonRelease> { xc_Brelease %W B1; MouseZoomBrelease %W } 146 bind $fs($spin,$i,togl) <B2-ButtonRelease> { xc_Brelease %W B2 } 147 bind $fs($spin,$i,togl) <Button-3> [list FS_PopupMenu %W %X %Y $i $spin] 148 bind $fs($spin,$i,togl) <Shift-B1-Motion> { MouseZoom %W %X %Y } 149 bind $fs($spin,$i,togl) <Shift-B1-ButtonRelease> { MouseZoomBrelease %W } 150 151 global tcl_platform 152 if { $tcl_platform(platform) == "unix" } { 153 bind $fs($spin,$i,togl) <Button-4> { MouseWheelZoom %W +} 154 bind $fs($spin,$i,togl) <Button-5> { MouseWheelZoom %W -} 155 } else { 156 bind $t <MouseWheel> [list WindowsMouseWheel $fs($spin,$i,togl) %D ] 157 } 158 159 bind $t <Control-q> exit_pr 160 bind $t <Control-p> [list FSbind_printTogl $spin] 161 bind $t <Control-Alt-p> FSbind_printSetup 162 163 bind $t <S> [list FSbind_SetSurfColor $spin] 164 bind $t <C> [list FSbind_SetCellColor $spin] 165 bind $t <L> [list FSbind_glLight $spin] 166 bind $t <D> [list FSbind_ModDepthCuing $spin] 167 bind $t <A> [list FSbind_ModAntiAlias $spin] 168 169 bind $t t [list FS_ToggleMenuCheckbutton transparent $spin FS_Config ] 170 bind $t c [list FS_ToggleMenuCheckbutton displaycell $spin FS_fsConfig ] 171 bind $t p [list FS_ToggleMenuCheckbutton cropbz $spin FS_fsConfig ] 172 bind $t d [list FS_ToggleMenuCheckbutton depthcuing $spin FS_DepthCuing] 173 bind $t a [list FS_ToggleMenuCheckbutton antialias $spin FS_AntiAlias ] 174 175 # 176 # here is some setting optimized for rendering Fermi Surfaces 177 # 178 global mody 179 #xc_setGLparam lightmodel -disable_light 1 180 xc_newvalue $togl $mody(SET_FOG_DENSITY) 2.0 181 xc_newvalue $togl $mody(SET_FOG_ORT_START_F) 0.0 182 xc_newvalue $togl $mody(SET_FOG_ORT_END_F) 0.8 183 xc_newvalue $togl $mody(SET_ANTIALIAS_DEGREE) 2 184 xc_newvalue $togl $mody(SET_ANTIALIAS_OFFSET) 0.9 185 FS_DepthCuing $i $spin 186 187 set fs($spin,$i,ident) [cry_surfreg $fs($spin,$i,togl)] 188 cry_dispfunc $fs($spin,$i,togl) fermisurface 189 190 # 191 # small toolbox frame ontop of Togl 192 # 193 set small_toolbox [frame $togl.f -relief raised -bd 1 -class mea] 194 place $small_toolbox -x 0 -y 0 195 set fs($spin,$i,show_small_toolbox_frame) 1 196 set fs($spin,$i,small_toolbox_frame) $small_toolbox 197 set fs($spin,$i,toolbox_frame_place) [place info $small_toolbox] 198 199 set separator_1 [frame $small_toolbox.s1 -height 2 -relief raised -bd 1] 200 set separator_2 [frame $small_toolbox.s2 -height 2 -relief raised -bd 1] 201 202 set bz_b [radiobutton $small_toolbox.bz -image fs_bz -highlightthickness 1 \ 203 -variable fs($spin,$i,celltype) -value bz -indicatoron 0 \ 204 -selectcolor \#ff4444 -highlightbackground \#000000 \ 205 -command [list FSbutton_SmallToolbox bz $i $spin]] 206 207 set para_b [radiobutton $small_toolbox.para -image fs_cell -highlightthickness 1 \ 208 -variable fs($spin,$i,celltype) -value para -indicatoron 0 \ 209 -selectcolor \#ff4444 -highlightbackground \#000000 \ 210 -command [list FSbutton_SmallToolbox para $i $spin]] 211 212 set nocrop_b [checkbutton $small_toolbox.nocrop -image fs_nocrop -highlightthickness 1 \ 213 -selectcolor \#44ff44 -highlightbackground \#000000 \ 214 -variable fs($spin,$i,nocropbz) -command [list FSbutton_SmallToolbox nocrop $i $spin] -indicatoron 0] 215 216 foreach button {nocell wirecell solidcell solidwirecell} { 217 set ${button}_b [radiobutton $small_toolbox.$button \ 218 -image fs_$button -highlightthickness 1 \ 219 -selectcolor \#4444ff -highlightbackground \#000000 \ 220 -variable fs($spin,$i,radiobutton_celldisplaytype) -value $button -indicatoron 0 \ 221 -command [list FSbutton_SmallToolbox $button $i $spin]] 222 } 223 224 set b_pack_option {-side top -fill x -padx 0 -pady 0 -ipadx 0 -ipady 0} 225 set s_pack_option {-side top -fill x -padx 0 -pady 2 -ipadx 0 -ipady 0} 226 227 eval pack $bz_b $para_b $b_pack_option 228 eval pack $separator_1 $s_pack_option 229 eval pack $nocrop_b $b_pack_option 230 eval pack $separator_2 $s_pack_option 231 eval pack $nocell_b $wirecell_b $solidcell_b $solidwirecell_b $b_pack_option 232 233 global xcFonts 234 foreach {wid text} { 235 bz "display Fermi surface in Brillouin zone" 236 para "display Fermi surface in reciprocal unit cell" 237 nocrop "toggle croping of Fermi surface to Brillouin zone" 238 nocell "do not display cell" 239 wirecell "display wire cell" 240 solidcell "display solid cell" 241 solidwirecell "display solid+wire cell" 242 } { 243 set path $small_toolbox.$wid 244 DynamicHelp::register $path balloon $text 245 } 246 247 # 248 # Status frame 249 # 250 set ff [frame $f.f -relief ridge -bd 4] 251 pack $ff -side top -expand 0 -fill x -padx 0m -pady 0m 252 #set fs($spin,$i,status_f) $ff 253 254 set fs($spin,$i,show_status_frame) 1 255 set fs($spin,$i,status_frame) $ff 256 set fs($spin,$i,status_frame_pack) [pack info $ft] 257 258 259 if { $spin != {} } { 260 set l1 [label $ff.l1 -text "Spin: [string toupper $spin]" \ 261 -anchor w -relief sunken -bd 1] 262 pack $l1 -side left -padx 1m -ipadx 1m -ipady 1m 263 } 264 set l2 [label $ff.l2 -text "FERMI Energy: $fs(Efermi)" \ 265 -anchor w -relief sunken -bd 1] 266 set l3 [label $ff.l3 -text "Min Ene: $fs($spin,$i,minE)" \ 267 -anchor w -relief sunken -bd 1] 268 set l4 [label $ff.l4 -text "Max Ene: $fs($spin,$i,maxE)" \ 269 -anchor w -relief sunken -bd 1] 270 set fff [frame $ff.f -relief sunken -bd 1] 271 pack $l2 $l3 $l4 \ 272 -side left -padx 1m -ipadx 1m -ipady 1m 273 pack $fff \ 274 -side right -fill x -padx 1m -ipadx 1m -ipady 1m 275 276 set l5 [label $fff.l5 -text "Isolevel:"] 277 set e [entry $fff.e \ 278 -width 15 -textvariable fs($spin,$i,isolevel) \ 279 -validate key -validatecommand {string is double %P}] 280 pack $e $l5 -side right -padx 0m -pady 0m 281 bind $e <Return> [list FS_Config $i $spin] 282 } 283 } 284 if { $_first_band != -1 } { 285 $nb raise band$_first_band 286 update 287 set fs($spin,toolbox_frame_height) [winfo height $fs($spin,$_first_band,toolbox_frame)] 288 set fs($spin,status_frame_height) [winfo height $fs($spin,$_first_band,status_frame)] 289 xcDebug -debug "fs($spin,toolbox_frame_height) == [winfo height $fs($spin,$_first_band,toolbox_frame)]" 290 xcDebug -debug "fs($spin,status_frame_height) == [winfo height $fs($spin,$_first_band,status_frame)] " 291 } else { 292 WarningDialog "no band selected !!! Aplication will exit." 293 exit 0 294 } 295 296 update 297 set fs($spin,togl_w) [winfo width $fs($spin,$_first_band,togl)] 298 set fs($spin,togl_h) [winfo height $fs($spin,$_first_band,togl)] 299 set fs($spin,top_w) [winfo width $t] 300 set fs($spin,top_h) [winfo height $t] 301 set fs($spin,top_togl_dw) [expr $fs($spin,top_w) - $fs($spin,togl_w)] 302 set fs($spin,top_togl_dh) [expr $fs($spin,top_h) - $fs($spin,togl_h)] 303 304 xcDebug -debug "fs($spin,togl_w) == [winfo width $fs($spin,$_first_band,togl)]" 305 xcDebug -debug "fs($spin,togl_h) == [winfo height $fs($spin,$_first_band,togl)]" 306 xcDebug -debug "fs($spin,top_w) == [winfo width $t] " 307 xcDebug -debug "fs($spin,top_h) == [winfo height $t] " 308 xcDebug -debug "fs($spin,top_togl_dw) == [expr $fs($spin,top_w) - $fs($spin,togl_w)]" 309 xcDebug -debug "fs($spin,top_togl_dh) == [expr $fs($spin,top_h) - $fs($spin,togl_h)]" 310 311 xcDebug -debug "Notebook's width: [winfo width $nb]" 312 xcDebug -debug "Notebook's height: [winfo height $nb]" 313 314 #if { $fs($spin,top_h) < $fs($spin,togl_h) } { 315 # set fs($spin,top_h) [expr $fs($spin,togl_h) + $fs($spin,toolbox_frame_height) + $fs($spin,status_frame_height) + 30] 316 # set fs($spin,top_w) [expr $fs($spin,togl_w) + 4] 317 #} 318 #set w $fs($spin,top_w) 319 #set h $fs($spin,top_h) 320 #if { $spin == "dn" } { 321 # wm geometry $t ${w}x${h}+0-0 322 #} else { 323 # wm geometry $t ${w}x${h}-0+0 324 #} 325 326 for {set i 1} {$i <= $fs($spin,nbands)} {incr i} { 327 if { $fs($spin,$i,band_selected) } { 328 set fs($spin,$i,togl_w) [winfo width $fs($spin,$_first_band,togl)] 329 set fs($spin,$i,togl_h) [winfo height $fs($spin,$_first_band,togl)] 330 set fs($spin,$i,top_togl_dw) [expr $fs($spin,top_w) - $fs($spin,togl_w)] 331 set fs($spin,$i,top_togl_dh) [expr $fs($spin,top_h) - $fs($spin,togl_h)] 332 } 333 } 334 335 FS_Multi $nb $spin 336 337 bind $t <Configure> [list FS_ResizeWin %W %w %h $t $spin] 338} 339 340proc FS_PopupMenu {W x y i {spin {}} {multiband {}}} { 341 global fs 342 343 set togl $fs($spin,$i,togl) 344 345 if { [winfo exists $W.menu] } { 346 destroy $W.menu 347 } 348 set m [menu $W.menu -tearoff 1] 349 tk_popup $m $x $y 350 351 #$m add command -label "PopUp Menu" -state disabled 352 #$m add separator 353 354 # ------------------------------------------------------------------------ 355 # Pop-Up menu 356 # ------------------------------------------------------------------------ 357 358 if { $multiband == "" } { 359 $m add command -label "Render Surface" \ 360 -command [list FS_RenderSurface $i $spin] 361 362 #$m add separator 363 #$m add command -label "Interpolation" \ 364 # -command [list FS_Interpolation "Interpolation for band \# $i:" $togl $spin $i] 365 #$m add command -label "Zoom" \ 366 # -command [list toglZoom "Zoom for band \# $i:" $togl] 367 # 368 $m add separator 369 } 370 371 # Palette-cascade 372 $m add cascade -image colors -menu $m.colors 373 menu $m.colors -tearoff 1 374 ColorMenu $W $m.colors 375 376 # File-cascade 377 $m add cascade -label "File" -menu $m.file 378 set mfile [menu $m.file -tearoff 1] 379 $mfile add command -label "Save Fermi Surface(s) in BXSF format" \ 380 -command [list FS_SaveBXSF $i $spin multiband] 381 $mfile add separator 382 $mfile add command -label "Print Setup" -command printSetup -accelerator "Ctlr-Alt-p" 383 $mfile add command -label "Print " -command [list printTogl $togl] -accelerator "Ctrl-p" 384 385 if { $multiband == "" } { 386 # View-cascade 387 $m add cascade -label "View" -menu $m.view 388 menu $m.view -tearoff 1 389 390 # Display-cascade 391 $m add cascade -label "Display" -menu $m.dis 392 menu $m.dis -tearoff 1 393 394 # Modify-cascade 395 $m add cascade -label "Modify" -menu $m.mody 396 menu $m.mody -tearoff 1 397 398 FS_ViewMenu $m.view $W $i $spin 399 FS_DisplayMenu $m.dis $W $i $spin 400 FS_ModifyMenu $m.mody $W $i $spin 401 402 #$m add cascade -label "Modify" -menu $m.mod 403 #menu $m.mod -tearoff 1 404 #FS_ModifyMenu $m.dis $W $i $spin 405 #$m add cascade -label "Tools" -menu $m.tools 406 #menu $m.tools -tearoff 0 407 #FS_ToolsMenu $m.dis $W $i $spin 408 } 409 410 $m add separator 411 $m add command -label "Print " -command [list printTogl $togl] -accelerator "Ctrl-p" 412 413 $m add separator 414 415 $m add command -label "Exit" -command exit_pr -accelerator "Ctrl-q" 416} 417 418proc FS_ResizeWin {W w h t {spin {}}} { 419 global fs 420 421 if { $t != $W } { 422 set w [winfo width $t] 423 set h [winfo height $t] 424 } 425 426 #xcDebug -debug "FS_ResizeWin> (w,h) == ($w,$h)" 427 428 # update only if size of "toplevel ." has changed 429 #if { $w != $fs($spin,top_w) || $h != $fs($spin,top_h) } { 430 # set fs($spin,top_w) $w 431 # set fs($spin,top_h) $h 432 # for {set i 1} {$i <= $fs($spin,nbands)} {incr i} { 433 # if { $fs($spin,$i,band_selected) } { 434 # set fs($spin,$i,togl_w) [expr $w - $fs($spin,$i,top_togl_dw)] 435 # set fs($spin,$i,togl_h) [expr $h - $fs($spin,$i,top_togl_dh)] 436 # $fs($spin,$i,togl) config \ 437 # -width $fs($spin,$i,togl_w) \ 438 # -height $fs($spin,$i,togl_h) 439 # } 440 # } 441 #} 442} 443 444proc FS_InitVar {i {spin {}}} { 445 global fs 446 447 # 448 # set monocolor 449 # 450 set rainbow { 451 { 1.0 0.2 0.2 0.5 } 452 { 1.0 1.0 0.2 0.5 } 453 { 0.2 1.0 0.2 0.5 } 454 { 0.2 1.0 1.0 0.5 } 455 { 0.2 0.2 1.0 0.5 } 456 { 1.0 0.2 1.0 0.5 } 457 } 458 foreach rgb $rainbow { 459 set r [expr 1.0 - [lindex $rgb 0]] 460 set g [expr 1.0 - [lindex $rgb 1]] 461 set b [expr 1.0 - [lindex $rgb 2]] 462 set a 0.5 463 lappend backrainbow [list $r $g $b $a] 464 } 465 466 # 467 # hard-coded defaults 468 # 469 set im [expr $i - 6 * int( $i / 6)] 470 set fs($spin,$i,celltype) bz 471 set fs($spin,$i,text_celltype) "first Brillouin zone" 472 set fs($spin,$i,cropbz) 1 473 set fs($spin,$i,nocropbz) 0 474 set fs($spin,$i,displaycell) 1 475 set fs($spin,$i,celldisplaytype) wire 476 set fs($spin,$i,drawstyle) solid 477 set fs($spin,$i,transparent) 0 478 set fs($spin,$i,shademodel) smooth 479 set fs($spin,$i,colormodel) "set front-side color only" 480 set fs($spin,$i,monocolor) [lindex $rainbow $im] 481 set fs($spin,$i,backmonocolor) [lindex $backrainbow $im] 482 set fs($spin,$i,smoothsteps) 0 483 set fs($spin,$i,smoothweight) 0.2 484 set fs($spin,$i,interpolationdegree) {1 1 1} 485 set fs($spin,$i,frontface) CW 486 set fs($spin,$i,revertnormals) 0 487 488 set fs($spin,$i,wirecellcolor) {1.00 1.00 1.00 1.00} 489 set fs($spin,$i,solidcellcolor) {0.00 0.95 0.95 0.40} 490 set fs($spin,$i,antialias) 0 491 set fs($spin,$i,depthcuing) 0 492 493 set fs($spin,$i,radiobutton_celldisplaytype) $fs($spin,$i,celldisplaytype)cell 494 495 # try to use user specified defaults 496 FS_UserDefaults $i $spin 497 498 set fs($spin,$i,old_celltype) $fs($spin,$i,celltype) 499 set fs($spin,$i,old_cropbz) $fs($spin,$i,cropbz) 500 set fs($spin,$i,old_displaycell) $fs($spin,$i,displaycell) 501 set fs($spin,$i,old_celldisplaytype) $fs($spin,$i,celldisplaytype) 502 set fs($spin,$i,old_drawstyle) $fs($spin,$i,drawstyle) 503 set fs($spin,$i,old_transparent) $fs($spin,$i,transparent) 504 set fs($spin,$i,old_shademodel) $fs($spin,$i,shademodel) 505 set fs($spin,$i,old_monocolor) $fs($spin,$i,monocolor) 506 set fs($spin,$i,old_smoothsteps) $fs($spin,$i,smoothsteps) 507 set fs($spin,$i,old_smoothweight) $fs($spin,$i,smoothweight) 508 set fs($spin,$i,old_interpolationdegree) $fs($spin,$i,interpolationdegree) 509 #set fs($spin,$i,old_frontface) $fs($spin,$i,frontface) 510 #set fs($spin,$i,old_revertnormals) $fs($spin,$i,revertnormals) 511} 512 513 514proc FS_UserBackground {togl} { 515 global myParam mody 516 # BEWARE: the myParam(FS_BACKGROUND) needs a special treatment 517 if { [info exists myParam(FS_BACKGROUND)] } { 518 if { ! [rgba $myParam(FS_BACKGROUND)] } { 519 error "wrong value \"$myParam(FS_BACKGROUND)\" for myParam(FS_BACKGROUND), should be one of rgba type; correct custom-definition file" 520 } else { 521 eval xc_newvalue $togl $mody(L_BACKGROUND) $myParam(FS_BACKGROUND) 522 } 523 } 524} 525 526 527proc FS_UserDefaults {i {spin {}}} { 528 global fs myParam 529 530 # BEWARE: the myParam(FS_BACKGROUND) needs a special treatment 531 532 foreach {fs_item allowed} { 533 FS_CELLTYPE {bz para} 534 FS_CROPBZ {0 1} 535 FS_CELLDISPLAYTYPE {none wire solid solidwire} 536 FS_DRAWSTYLE {solid wire dot} 537 FS_TRANSPARENT {0 1} 538 FS_SHADEMODEL {smooth flat} 539 FS_INTERPOLATIONDEGREE {@ positiveInteger} 540 FS_FRONTFACE {CW CCW} 541 FS_REVERTNORMALS {0 1} 542 FS_WIRECELLCOLOR {@ rgba} 543 FS_SOLIDCELLCOLOR {@ rgba} 544 FS_ANTIALIAS {0 1} 545 FS_DEPTHCUING {0 1} 546 } { 547 if { [info exists myParam($fs_item)] } { 548 549 regsub ^FS_ $fs_item {} _item 550 set item [string tolower $_item] 551 552 if { [lindex $allowed 0] == "@" } { 553 554 # not a literal comparison, but a given type is specified 555 556 set typeCmd [lindex $allowed 1] 557 558 if { ! [$typeCmd $myParam($fs_item)] } { 559 error "wrong value \"$myParam($fs_item)\" for myParam($fs_item), should be one of $typeCmd type; correct custom-definition file" 560 } else { 561 # special treatment for FS_INTERPOLATIONDEGREE 562 if { $fs_item eq "FS_INTERPOLATIONDEGREE" } { 563 set fs($spin,$i,$item) [list $myParam($fs_item) $myParam($fs_item) $myParam($fs_item)] 564 } else { 565 set fs($spin,$i,$item) $myParam($fs_item) 566 } 567 } 568 569 } else { 570 571 # literal comparison 572 573 if { ! [allowedValue $myParam($fs_item) $allowed] } { 574 error "wrong value \"$myParam($fs_item)\" for myParam($fs_item), should be one of: $allowed; correct custom-definition file" 575 } else { 576 set fs($spin,$i,$item) $myParam($fs_item) 577 578 # handle specialties 579 580 if { $item eq "cropbz" } { 581 582 set fs($spin,$i,nocropbz) [expr ! $fs($spin,$i,cropbz)] 583 584 } elseif { $item eq "celldisplaytype" } { 585 586 switch -- $myParam($fs_item) { 587 none { 588 set fs($spin,$i,displaycell) 0 589 set fs($spin,$i,celldisplaytype) wire; # just in any case !!! 590 set fs($spin,$i,radiobutton_celldisplaytype) nocell 591 } 592 wire - solid - solidwire { 593 set fs($spin,$i,displaycell) 1 594 set fs($spin,$i,radiobutton_celldisplaytype) $fs($spin,$i,celldisplaytype)cell 595 } 596 } 597 } 598 } 599 } 600 } 601 } 602} 603 604 605proc FS_RenderSurface {i {spin {}}} { 606 global fs 607 608 if { ! [info exist fs($spin,$i,rendered)] } { 609 set fs($spin,$i,rendered) 1 610 611 FS:cry_surf $i $spin 612 # next lines are a hack-around a "display-bug" to force the display 613 set w [lindex [$fs($spin,$i,togl) config -width] end] 614 $fs($spin,$i,togl) config -width $w 615 $fs($spin,$i,togl) render 616 $fs($spin,$i,togl) swapbuffers 617 update 618 } 619} 620 621proc FS:cry_surf {i {spin {}}} { 622 global fs 623 624 # band index-identifiers strats from 0 not from 1 in ReadBandGrid !!! 625 set iband [expr $i - 1] 626 SetWatchCursor 627 update 628 629 if { $fs($spin,$i,colormodel) == "set front-side color only" } { 630 631 # monocolor == -monocolor $fs($spin,$i,monocolor) 632 633 cry_surf $fs($spin,$i,togl) \ 634 -ident $fs($spin,$i,ident) \ 635 -type fermisurface \ 636 -fs [list \ 637 -gridindex $fs($spin,grid_index) \ 638 -gridsubindex $fs($spin,grid_subindex) \ 639 -bandindex $iband \ 640 -celltype $fs($spin,$i,celltype) \ 641 -cropbz $fs($spin,$i,cropbz) \ 642 -displaycell $fs($spin,$i,displaycell) \ 643 -celldisplaytype $fs($spin,$i,celldisplaytype) \ 644 -interpolationdegree $fs($spin,$i,interpolationdegree) \ 645 -wirecellcolor $fs($spin,$i,wirecellcolor) \ 646 -solidcellcolor $fs($spin,$i,solidcellcolor)] \ 647 -level $fs($spin,$i,isolevel) \ 648 -drawstyle $fs($spin,$i,drawstyle) \ 649 -transparent $fs($spin,$i,transparent) \ 650 -shademodel $fs($spin,$i,shademodel) \ 651 -monocolor $fs($spin,$i,monocolor) \ 652 -smoothsteps $fs($spin,$i,smoothsteps) \ 653 -smoothweight $fs($spin,$i,smoothweight) \ 654 -frontface $fs($spin,$i,frontface) \ 655 -revertnormals $fs($spin,$i,revertnormals) 656 } else { 657 658 # monocolor == -frontmonocolor $fs($spin,$i,monocolor) \ 659 # -backmonocolor $fs($spin,$i,backmonocolor)" 660 661 cry_surf $fs($spin,$i,togl) \ 662 -ident $fs($spin,$i,ident) \ 663 -type fermisurface \ 664 -fs [list \ 665 -gridindex $fs($spin,grid_index) \ 666 -gridsubindex $fs($spin,grid_subindex) \ 667 -bandindex $iband \ 668 -celltype $fs($spin,$i,celltype) \ 669 -cropbz $fs($spin,$i,cropbz) \ 670 -displaycell $fs($spin,$i,displaycell) \ 671 -celldisplaytype $fs($spin,$i,celldisplaytype) \ 672 -interpolationdegree $fs($spin,$i,interpolationdegree) \ 673 -wirecellcolor $fs($spin,$i,wirecellcolor) \ 674 -solidcellcolor $fs($spin,$i,solidcellcolor)] \ 675 -level $fs($spin,$i,isolevel) \ 676 -drawstyle $fs($spin,$i,drawstyle) \ 677 -transparent $fs($spin,$i,transparent) \ 678 -shademodel $fs($spin,$i,shademodel) \ 679 -frontmonocolor $fs($spin,$i,monocolor) \ 680 -backmonocolor $fs($spin,$i,backmonocolor) \ 681 -smoothsteps $fs($spin,$i,smoothsteps) \ 682 -smoothweight $fs($spin,$i,smoothweight) \ 683 -frontface $fs($spin,$i,frontface) \ 684 -revertnormals $fs($spin,$i,revertnormals) 685 } 686 687 ResetCursor 688 update 689} 690 691 692proc FS:cry_surfconfig {i {spin {}}} { 693 global fs 694 695 if { ! [info exist fs($spin,$i,rendered)] } { 696 return 697 } 698 699 # band index-identifiers strats from 0 not from 1 in ReadBandGrid !!! 700 set iband [expr $i - 1] 701 702 SetWatchCursor 703 update 704 705 if { $fs($spin,$i,colormodel) == "set front-side color only" } { 706 707 # monocolor == -monocolor $fs($spin,$i,monocolor) 708 cry_surfconfig $fs($spin,$i,togl) \ 709 -ident $fs($spin,$i,ident) \ 710 -fs [list \ 711 -gridindex $fs($spin,grid_index) \ 712 -gridsubindex $fs($spin,grid_subindex) \ 713 -bandindex $iband \ 714 -celltype $fs($spin,$i,celltype) \ 715 -cropbz $fs($spin,$i,cropbz) \ 716 -displaycell $fs($spin,$i,displaycell) \ 717 -celldisplaytype $fs($spin,$i,celldisplaytype) \ 718 -interpolationdegree $fs($spin,$i,interpolationdegree) \ 719 -wirecellcolor $fs($spin,$i,wirecellcolor) \ 720 -solidcellcolor $fs($spin,$i,solidcellcolor)] \ 721 -render 1 \ 722 -level $fs($spin,$i,isolevel) \ 723 -drawstyle $fs($spin,$i,drawstyle) \ 724 -transparent $fs($spin,$i,transparent) \ 725 -shademodel $fs($spin,$i,shademodel) \ 726 -monocolor $fs($spin,$i,monocolor) \ 727 -smoothsteps $fs($spin,$i,smoothsteps) \ 728 -smoothweight $fs($spin,$i,smoothweight) \ 729 -frontface $fs($spin,$i,frontface) \ 730 -revertnormals $fs($spin,$i,revertnormals) 731 } else { 732 # monocolor == -frontmonocolor $fs($spin,$i,monocolor) \ 733 # -backmonocolor $fs($spin,$i,backmonocolor)" 734 735 cry_surfconfig $fs($spin,$i,togl) \ 736 -ident $fs($spin,$i,ident) \ 737 -fs [list \ 738 -gridindex $fs($spin,grid_index) \ 739 -gridsubindex $fs($spin,grid_subindex) \ 740 -bandindex $iband \ 741 -celltype $fs($spin,$i,celltype) \ 742 -cropbz $fs($spin,$i,cropbz) \ 743 -displaycell $fs($spin,$i,displaycell) \ 744 -celldisplaytype $fs($spin,$i,celldisplaytype) \ 745 -interpolationdegree $fs($spin,$i,interpolationdegree) \ 746 -wirecellcolor $fs($spin,$i,wirecellcolor) \ 747 -solidcellcolor $fs($spin,$i,solidcellcolor)] \ 748 -render 1 \ 749 -level $fs($spin,$i,isolevel) \ 750 -drawstyle $fs($spin,$i,drawstyle) \ 751 -transparent $fs($spin,$i,transparent) \ 752 -shademodel $fs($spin,$i,shademodel) \ 753 -frontmonocolor $fs($spin,$i,monocolor) \ 754 -backmonocolor $fs($spin,$i,backmonocolor) \ 755 -smoothsteps $fs($spin,$i,smoothsteps) \ 756 -smoothweight $fs($spin,$i,smoothweight) \ 757 -frontface $fs($spin,$i,frontface) \ 758 -revertnormals $fs($spin,$i,revertnormals) 759 } 760 761 ResetCursor 762 update 763} 764 765proc FS_ModifyMenu {m togl i {spin {}}} { 766 global fs 767 768 $m add command -label "Surface Color" \ 769 -command [list FS_SetSurfColor $i $spin] -accelerator "Shift-s" 770 771 $m add command -label "Cell Color" \ 772 -command [list FS_SetCellColor $i $spin] -accelerator "Shift-c" 773 774 $m add separator 775 $m add command -label "Lighting Parameters" -command [list glLight $togl] \ 776 -accelerator "Shift-l" 777 778 $m add command -label "Depth-Cuing Parameters" \ 779 -command [list FS_ModDepthCuing $i $spin] -accelerator "Shift-d" 780 781 $m add command -label "Anti-aliasing Parameters" \ 782 -command [list FS_ModAntiAlias $i $spin] -accelerator "Shift-a" 783} 784 785proc FS_ViewMenu {m togl i {spin {}}} { 786 global fs 787 788 # 789 # Checkbuttons 790 # 791 $m add checkbutton -label "Show Toolbox" \ 792 -variable fs($spin,$i,show_toolbox_frame) \ 793 -command [list FS_ViewMenu:_show toolbox $i $spin] 794 $m add checkbutton -label "Show Small Toolbox" \ 795 -variable fs($spin,$i,show_small_toolbox_frame) \ 796 -command [list FS_ViewMenu:_show small_toolbox $i $spin] 797 $m add checkbutton -label "Show Status Frame" \ 798 -variable fs($spin,$i,show_status_frame) \ 799 -command [list FS_ViewMenu:_show status $i $spin] 800} 801 802proc FS_ViewMenu:_show {which i spin} { 803 global fs 804 805 set dh 0 806 807 switch -exact -- $which { 808 toolbox { 809 # 810 # TOOLBOX 811 # 812 if { $fs($spin,$i,show_toolbox_frame) } { 813 eval pack $fs($spin,$i,toolbox_frame) $fs($spin,$i,toolbox_frame_pack) \ 814 -before $fs($spin,$i,toolbox_frame_packbefore) 815 set dh [expr -1 * $fs($spin,toolbox_frame_height)] 816 } else { 817 pack forget $fs($spin,$i,toolbox_frame) 818 set dh $fs($spin,toolbox_frame_height) 819 } 820 } 821 822 small_toolbox { 823 # 824 # SMALL-TOOLBOX 825 # 826 if { $fs($spin,$i,show_small_toolbox_frame) } { 827 eval place $fs($spin,$i,small_toolbox_frame) $fs($spin,$i,toolbox_frame_place) 828 } else { 829 place forget $fs($spin,$i,small_toolbox_frame) 830 } 831 } 832 833 status { 834 # 835 # STATUS-FRAME 836 # 837 if { $fs($spin,$i,show_status_frame) } { 838 eval pack $fs($spin,$i,status_frame) $fs($spin,$i,status_frame_pack) 839 set dh [expr -1 * $fs($spin,status_frame_height)] 840 } else { 841 pack forget $fs($spin,$i,status_frame) 842 set dh $fs($spin,status_frame_height) 843 } 844 } 845 } 846 847 set h [winfo height $fs($spin,$i,togl)] 848 set fs($spin,$i,top_togl_dh) [expr $fs($spin,$i,top_togl_dh) - $dh] 849 set fs($spin,$i,togl_h) [expr $h + $dh] 850 851 $fs($spin,$i,togl) config -height $fs($spin,$i,togl_h) 852 FS_ResizeWin . 0 0 [winfo toplevel $fs($spin,$i,togl)] $spin 853} 854 855 856proc FS_DisplayMenu {m togl i {spin {}}} { 857 global fs 858 859 if { $fs($spin,$i,celltype) == "para" } { 860 set cell cell 861 } else { 862 set cell "first Brillouin zone" 863 } 864 865 # 866 # Checkbuttons 867 # 868 $m add checkbutton -label "Transparent Fermi Surface" \ 869 -variable fs($spin,$i,transparent) \ 870 -command [list FS_Config $i $spin] -accelerator "t" 871 872 $m add checkbutton -label "Display $cell" \ 873 -variable fs($spin,$i,displaycell) \ 874 -command [list FS_fsConfig $i $spin] -accelerator "c" 875 876 $m add checkbutton -label "Crop Fermi Surface to first BZ" \ 877 -variable fs($spin,$i,cropbz) \ 878 -command [list FS_fsConfig $i $spin] -accelerator "p" 879 880 if { $fs($spin,$i,celltype) == "para" } { 881 $m entryconfig "Crop Fermi Surface to first BZ" -state disabled 882 } 883 $m add separator 884 $m add checkbutton -label "Depth-Cuing" \ 885 -variable fs($spin,$i,depthcuing) -onvalue 1 -offvalue 0 \ 886 -command [list FS_DepthCuing $i $spin] -accelerator "d" 887 888 $m add checkbutton -label "Anti-Aliasing" \ 889 -variable fs($spin,$i,antialias) -onvalue 1 -offvalue 0 \ 890 -command [list FS_AntiAlias $i $spin] -accelerator "a" 891 892 # 893 # CASCADES 894 # 895 $m add separator 896 $m add cascade -label "Cell type ..." -menu $m.celltype 897 $m add cascade -label "Display $cell as ..." -menu $m.discell 898 $m add cascade -label "Surface Drawstyle ..." -menu $m.draw 899 $m add cascade -label "Surface Shademodel ..." -menu $m.shade 900 901 $m add separator 902 903 #$m add command -label "Surface Smoothing" \ 904 # -command [list FS_SurfSmooth $i $spin] 905 906 907 # CELLTYPE CASCADE 908 menu $m.celltype -tearoff 0 909 $m.celltype add radiobutton -label "first Brillouin zone" \ 910 -variable fs($spin,$i,text_celltype) \ 911 -command [list celltype:FS_fsConfig $i $spin] 912 $m.celltype add radiobutton -label "reciprocal primitive cell" \ 913 -variable fs($spin,$i,text_celltype) \ 914 -command [list celltype:FS_fsConfig $i $spin] 915 916 # DISPLAYCELL CASCADE 917 menu $m.discell -tearoff 0 918 $m.discell add radiobutton -label "solid" \ 919 -variable fs($spin,$i,celldisplaytype) \ 920 -command [list FS_fsConfig $i $spin] 921 $m.discell add radiobutton -label "wire" \ 922 -variable fs($spin,$i,celldisplaytype) \ 923 -command [list FS_fsConfig $i $spin] 924 #$m.discell add radiobutton -label "rod" \ 925 # -variable fs($spin,$i,celldisplaytype) \ 926 # -command [list FS_fsConfig $i $spin] 927 $m.discell add radiobutton -label "solidwire" \ 928 -variable fs($spin,$i,celldisplaytype) \ 929 -command [list FS_fsConfig $i $spin] 930 #$m.discell add radiobutton -label "solidrod" \ 931 # -variable fs($spin,$i,celldisplaytype) \ 932 # -command [list FS_fsConfig $i $spin] 933 934 #$m.discell entryconfig "rod" -state disabled 935 #$m.discell entryconfig "solidrod" -state disabled 936 ######################################################################### 937 #/ 938 939 # DRAWSTYLE CASCADE 940 menu $m.draw -tearoff 0 941 $m.draw add radiobutton -label "solid" \ 942 -variable fs($spin,$i,drawstyle) \ 943 -command [list FS_Config $i $spin] 944 $m.draw add radiobutton -label "wire" \ 945 -variable fs($spin,$i,drawstyle) \ 946 -command [list FS_Config $i $spin] 947 $m.draw add radiobutton -label "dot" \ 948 -variable fs($spin,$i,drawstyle) \ 949 -command [list FS_Config $i $spin] 950 951 # SHADEMODEL CASCADE 952 menu $m.shade -tearoff 0 953 $m.shade add radiobutton -label "smooth" \ 954 -variable fs($spin,$i,shademodel) \ 955 -command [list FS_Config $i $spin] 956 $m.shade add radiobutton -label "flat" \ 957 -variable fs($spin,$i,shademodel) \ 958 -command [list FS_Config $i $spin] 959} 960 961 962proc FS_fsConfig {i {spin {}}} { 963 global fs 964 965 if { $fs($spin,$i,old_celltype) != $fs($spin,$i,celltype) } { 966 FS:cry_surf $i $spin 967 } else { 968 FS:cry_surfconfig $i $spin 969 } 970 set fs($spin,$i,old_celltype) $fs($spin,$i,celltype) 971} 972 973proc FS_Config {i {spin {}}} { 974 global fs 975 976 # -level $fs($spin,$i,isolevel) 977 # -drawstyle $fs($spin,$i,drawstyle) 978 # -transparent $fs($spin,$i,transparent) 979 # -shademodel $fs($spin,$i,shademodel) 980 # -monocolor $fs($spin,$i,monocolor) 981 # -smoothsteps $fs($spin,$i,smoothsteps) 982 # -smoothweight $fs($spin,$i,smoothweight) 983 984 FS:cry_surfconfig $i $spin 985} 986 987 988proc celltype:FS_fsConfig {i {spin {}}} { 989 global fs 990 991 if { $fs($spin,$i,text_celltype) == "reciprocal primitive cell" } { 992 set fs($spin,$i,celltype) para 993 } else { 994 set fs($spin,$i,celltype) bz 995 } 996 997 FS_fsConfig $i $spin 998} 999 1000 1001proc FS_SaveBXSF {i {spin {}} {multiband {}}} { 1002 global fs system 1003 1004 set filetypes { 1005 {{BXSF} {.bxsf} } 1006 {{All Files} * } 1007 } 1008 set sfile [tk_getSaveFile \ 1009 -initialdir $system(PWD) \ 1010 -title "Save BXSF File" \ 1011 -defaultextension ".bxsf" \ 1012 -filetypes $filetypes] 1013 if { $sfile == "" } { 1014 return 1015 } 1016 1017 if { $multiband == "" } { 1018 # band index-identifiers strats from 0 not from 1 in ReadBandGrid !!! 1019 xc_writebandXSF $fs($spin,$i,ident) $fs(Efermi) $i $sfile 1020 } else { 1021 foreach band $fs($spin,bandlist) { 1022 xc_writebandXSF $fs($spin,$band,ident) $fs(Efermi) $band ${sfile}.band-$band 1023 } 1024 } 1025} 1026 1027 1028proc FS_SetSurfColor {i {spin {}}} { 1029 global fs 1030 1031 if { ! [info exists fs($spin,$i,monocolor)] } { 1032 return 1033 } 1034 1035 set fs($spin,$i,monocolor_R) [lindex $fs($spin,$i,monocolor) 0] 1036 set fs($spin,$i,monocolor_G) [lindex $fs($spin,$i,monocolor) 1] 1037 set fs($spin,$i,monocolor_B) [lindex $fs($spin,$i,monocolor) 2] 1038 set fs($spin,$i,monocolor_A) [lindex $fs($spin,$i,monocolor) 3] 1039 1040 set fs($spin,$i,backmonocolor_R) [lindex $fs($spin,$i,backmonocolor) 0] 1041 set fs($spin,$i,backmonocolor_G) [lindex $fs($spin,$i,backmonocolor) 1] 1042 set fs($spin,$i,backmonocolor_B) [lindex $fs($spin,$i,backmonocolor) 2] 1043 set fs($spin,$i,backmonocolor_A) [lindex $fs($spin,$i,backmonocolor) 3] 1044 1045 if { $spin == "" } { 1046 set t [xcToplevel [WidgetName] "Surface Colors for band #$i" "Surface Colors" . 0 0 1] 1047 } else { 1048 set t [xcToplevel [WidgetName] "Surface Colors for band #$i (spin: $spin)" "Surface Colors" . 0 0 1] 1049 } 1050 1051 # 1052 # widgets 1053 # 1054 set f1 [frame $t.f1] 1055 set f2 [frame $t.f2] 1056 set f21 [frame $f2.1 -relief groove -bd 2] 1057 set f22 [frame $f2.2 -relief groove -bd 2] 1058 set f23 [frame $f2.3] 1059 pack $f1 $f2 -side top -padx 5 -pady 5 -fill both -expand 1 1060 pack $f21 $f22 $f23 -side left -padx 3 -pady 3 -fill both 1061 1062 set fs($spin,$i,backcolor_frame) $f22 1063 1064 RadioBut $f1 "Color model:" fs($spin,$i,colormodel) top top 1 0 \ 1065 "set front-side color only" "set front- and back-side colors" 1066 1067 setRGBAwidget $f21 "Front-side color:" \ 1068 fs($spin,$i,monocolor_R) fs($spin,$i,monocolor_G) \ 1069 fs($spin,$i,monocolor_B) fs($spin,$i,monocolor_A) \ 1070 _UNKNOWN_ 1071 1072 setRGBAwidget $f22 "Back-side color:" \ 1073 fs($spin,$i,backmonocolor_R) fs($spin,$i,backmonocolor_G) \ 1074 fs($spin,$i,backmonocolor_B) fs($spin,$i,backmonocolor_A) \ 1075 _UNKNOWN_ 1076 1077 trace variable fs($spin,$i,colormodel) w FS_SetSurfColor:_widget 1078 FS_SetSurfColor:_widget fs $spin,$i,colormodel w 1079 1080 # 1081 # in bottom frame goes the "Close|Update" buttons 1082 # 1083 set update [button $f23.update -text "Update" -command [list FS_SetSurfColor:Update $i $spin]] 1084 set close [button $f23.close -text "Close" -command [list CancelProc $t]] 1085 pack $update $close -side top -padx 5 -pady 5 -ipadx 3 -ipady 3 -fill x 1086} 1087 1088 1089proc FS_SetSurfColor:Update {i spin} { 1090 global fs 1091 1092 set fs($spin,$i,monocolor) [list \ 1093 $fs($spin,$i,monocolor_R) \ 1094 $fs($spin,$i,monocolor_G) \ 1095 $fs($spin,$i,monocolor_B) \ 1096 $fs($spin,$i,monocolor_A)] 1097 1098 set fs($spin,$i,backmonocolor) [list \ 1099 $fs($spin,$i,backmonocolor_R) \ 1100 $fs($spin,$i,backmonocolor_G) \ 1101 $fs($spin,$i,backmonocolor_B) \ 1102 $fs($spin,$i,backmonocolor_A)] 1103 1104 FS_Config $i $spin 1105} 1106 1107 1108proc FS_SetSurfColor:_widget {name1 name2 op} { 1109 global fs 1110 1111 regsub -- {,colormodel$} $name2 {} spin_i 1112 1113 if { $fs($name2) == "set front-side color only" } { 1114 xcDisableAll -disabledfg $fs($spin_i,backcolor_frame) 1115 } else { 1116 xcEnableAll -disabledfg $fs($spin_i,backcolor_frame) 1117 } 1118} 1119 1120 1121proc FS_SetCellColor {i {spin {}}} { 1122 global fs 1123 1124 set t .fs_cellcolor 1125 if { [winfo exists $t] } { 1126 return 1127 } 1128 xcToplevel $t "Cell Color" "Cell Color" 1129 1130 set fs($spin,$i,wirecellcolor_R) [lindex $fs($spin,$i,wirecellcolor) 0] 1131 set fs($spin,$i,wirecellcolor_G) [lindex $fs($spin,$i,wirecellcolor) 1] 1132 set fs($spin,$i,wirecellcolor_B) [lindex $fs($spin,$i,wirecellcolor) 2] 1133 set fs($spin,$i,wirecellcolor_A) [lindex $fs($spin,$i,wirecellcolor) 3] 1134 1135 set fs($spin,$i,solidcellcolor_R) [lindex $fs($spin,$i,solidcellcolor) 0] 1136 set fs($spin,$i,solidcellcolor_G) [lindex $fs($spin,$i,solidcellcolor) 1] 1137 set fs($spin,$i,solidcellcolor_B) [lindex $fs($spin,$i,solidcellcolor) 2] 1138 set fs($spin,$i,solidcellcolor_A) [lindex $fs($spin,$i,solidcellcolor) 3] 1139 1140 set f1 [frame $t.1] 1141 set f2 [frame $t.2] 1142 pack $f1 $f2 -side left -fill both -padx 5 -pady 5 1143 1144 foreach type {wire solid} { 1145 set frame($type) [frame $f1.$type -relief groove -bd 2] 1146 pack $frame($type) -side left -fill both -padx 5 -pady 0 -ipady 3 -expand 1 1147 1148 setRGBAwidget $frame($type) "[string totitle $type]-cell color:" \ 1149 fs($spin,$i,${type}cellcolor_R) fs($spin,$i,${type}cellcolor_G) \ 1150 fs($spin,$i,${type}cellcolor_B) fs($spin,$i,${type}cellcolor_A) \ 1151 _UNKNOWN_ 1152 } 1153 1154 # 1155 # in bottom frame goes the "Close|Update" buttons 1156 # 1157 set update [button $f2.update -text "Update" -command [list FS_SetCellColor:Update $i $spin]] 1158 set close [button $f2.close -text "Close" -command [list CancelProc $t]] 1159 pack $update $close -side top -padx 5 -pady 5 -ipadx 3 -ipady 3 -fill x 1160} 1161proc FS_SetCellColor:Update {i spin} { 1162 global fs 1163 1164 set fs($spin,$i,wirecellcolor) [list \ 1165 $fs($spin,$i,wirecellcolor_R) \ 1166 $fs($spin,$i,wirecellcolor_G) \ 1167 $fs($spin,$i,wirecellcolor_B) \ 1168 $fs($spin,$i,wirecellcolor_A)] 1169 set fs($spin,$i,solidcellcolor) [list \ 1170 $fs($spin,$i,solidcellcolor_R) \ 1171 $fs($spin,$i,solidcellcolor_G) \ 1172 $fs($spin,$i,solidcellcolor_B) \ 1173 $fs($spin,$i,solidcellcolor_A)] 1174 FS_Config $i $spin 1175} 1176 1177proc FS_SurfSmooth {i {spin {}}} { 1178 global fs fs_trial 1179 1180 set fs_trial($spin,$i,smoothsteps) $fs($spin,$i,smoothsteps) 1181 set fs_trial($spin,$i,smoothweight) $fs($spin,$i,smoothweight) 1182 1183 set t [xcToplevel [WidgetName] "Surface Smoothing" "SurfSmooth" . 20 20 1] 1184 1185 message $t.m -aspect 800 \ 1186 -relief groove -bd 2 \ 1187 -text "Reasonable values for weight are between 0.1 and 1. Lighter weight will require more steps for smoothing, but will perturb the surface less !!!" 1188 pack $t.m -side top -padx 3m -pady 3m -ipadx 1m -ipady 1m 1189 1190 set f [frame $t.f] 1191 set e [FillEntries $t {"Smoothing steps:" "Smoothing weight:"} \ 1192 [list fs_trial($spin,$i,smoothsteps) \ 1193 fs_trial($spin,$i,smoothweight)] 17 7] 1194 set e1 [string trimright $e 1] 1195 set foclist "$e $e1" 1196 set varlist [list \ 1197 [list fs_trial($spin,$i,smoothsteps) int] \ 1198 [list fs_trial($spin,$i,smoothweight) real] ] 1199 1200 button $t.b1 -text "Close" -command [list CancelProc $t] 1201 button $t.b2 -text "Update" \ 1202 -command [list FS_SurfSmoothOK $t $foclist $varlist $i $spin] 1203 1204 pack $f -side bottom -expand 1 -fill both -padx 3m -pady 3m 1205 pack $t.b1 $t.b2 -side left -expand 1 -padx 2m -pady 2m 1206} 1207proc FS_SurfSmoothOK {t foclist varlist i {spin {}}} { 1208 global fs fs_trial 1209 1210 if ![check_var $varlist $foclist] { 1211 return 1212 } 1213 set fs($spin,$i,smoothsteps) $fs_trial($spin,$i,smoothsteps) 1214 set fs($spin,$i,smoothweight) $fs_trial($spin,$i,smoothweight) 1215 FS_Config $i $spin 1216 1217 return 1218} 1219 1220 1221proc FS_AntiAlias {i {spin {}}} { 1222 global fs mody 1223 1224 xc_newvalue $fs($spin,$i,togl) $mody(L_ANTIALIAS) $fs($spin,$i,antialias) 1225 1226 # update display 1227 $fs($spin,$i,togl) render 1228} 1229 1230 1231proc FS_DepthCuing {i {spin {}}} { 1232 global fs mody 1233 1234 xc_newvalue $fs($spin,$i,togl) $mody(L_FOG) $fs($spin,$i,depthcuing) 1235 1236 # update display 1237 $fs($spin,$i,togl) render 1238} 1239 1240proc FS_ModAntiAlias {i {spin {}}} { 1241 global fs 1242 set t .fs_antialias 1243 if { [winfo exists $t] } { 1244 return 1245 } 1246 xcToplevel $t "Anti-aliasing Parameters" "Antialias" 1247 glModParam:AntiAlias $t $t $fs($spin,$i,togl) 1248} 1249 1250proc FS_ModDepthCuing {i {spin {}}} { 1251 global fs 1252 set t .fs_depthcuing 1253 if { [winfo exists $t] } { 1254 return 1255 } 1256 xcToplevel $t "Depth-Cuing Parameters" "Depth-Cuing" 1257 glModParam:DepthCuing $t $t $fs($spin,$i,togl) 1258} 1259 1260 1261proc FS_ToggleMenuCheckbutton {what spin cmd} { 1262 global fs 1263 1264 set i [FS_getBandIndexFromNoteBookPage $spin] 1265 1266 if { ! [info exists fs($spin,$i,$what)] } { 1267 return 1268 } 1269 1270 if { $fs($spin,$i,$what) } { 1271 set fs($spin,$i,$what) 0 1272 } else { 1273 set fs($spin,$i,$what) 1 1274 } 1275 eval $cmd $i $spin 1276} 1277 1278 1279proc FS_getBandIndexFromNoteBookPage {spin} { 1280 global fs 1281 set pageName [$fs($spin,nb) raise] 1282 if { $pageName == "multiband" } { 1283 set index [expr [lindex $fs($spin,bandlist) end] + 1] 1284 } else { 1285 set index [string trimleft $pageName band] 1286 } 1287 xcDebug -stderr "FS_getBandIndexFromNoteBookPage:: bandIndex = $index" 1288 return $index 1289} 1290 1291proc FSbind_printTogl {spin} { 1292 global fs 1293 set i [FS_getBandIndexFromNoteBookPage $spin] 1294 printTogl $fs($spin,$i,togl) 1295} 1296proc FSbind_SetSurfColor {spin} { 1297 global fs 1298 if { [$fs($spin,nb) raise] == "multiband" } { 1299 return 1300 } 1301 set i [FS_getBandIndexFromNoteBookPage $spin] 1302 FS_SetSurfColor $i $spin 1303} 1304proc FSbind_SetCellColor {spin} { 1305 global fs 1306 if { [$fs($spin,nb) raise] == "multiband" } { 1307 return 1308 } 1309 set i [FS_getBandIndexFromNoteBookPage $spin] 1310 FS_SetCellColor $i $spin 1311} 1312proc FSbind_glLight {spin} { 1313 global fs 1314 set i [FS_getBandIndexFromNoteBookPage $spin] 1315 glLight $fs($spin,$i,togl) 1316} 1317proc FSbind_ModAntiAlias {spin} { 1318 global fs 1319 set i [FS_getBandIndexFromNoteBookPage $spin] 1320 FS_ModAntiAlias $i $spin 1321} 1322proc FSbind_ModDepthCuing {spin} { 1323 global fs 1324 set i [FS_getBandIndexFromNoteBookPage $spin] 1325 FS_ModDepthCuing $i $spin 1326} 1327 1328 1329proc FSbutton_SmallToolbox {button i spin} { 1330 global fs 1331 1332 switch -exact -- $button { 1333 bz { 1334 set fs($spin,$i,text_celltype) "first Brillouin zone" 1335 celltype:FS_fsConfig $i $spin 1336 } 1337 para { 1338 set fs($spin,$i,text_celltype) "reciprocal primitive cell" 1339 celltype:FS_fsConfig $i $spin 1340 } 1341 nocrop { 1342 if { $fs($spin,$i,nocropbz) } { 1343 set fs($spin,$i,cropbz) 0 1344 } else { 1345 set fs($spin,$i,cropbz) 1 1346 } 1347 FS_fsConfig $i $spin 1348 } 1349 nocell { 1350 set fs($spin,$i,displaycell) 0 1351 FS_fsConfig $i $spin 1352 } 1353 wirecell { 1354 set fs($spin,$i,displaycell) 1 1355 set fs($spin,$i,celldisplaytype) wire 1356 FS_fsConfig $i $spin 1357 } 1358 solidcell { 1359 set fs($spin,$i,displaycell) 1 1360 set fs($spin,$i,celldisplaytype) solid 1361 FS_fsConfig $i $spin 1362 } 1363 solidwirecell { 1364 set fs($spin,$i,displaycell) 1 1365 set fs($spin,$i,celldisplaytype) solidwire 1366 FS_fsConfig $i $spin 1367 } 1368 } 1369} 1370