elmer-common 6.1.0.svn.5396.dfsg2-2 / usr / share / elmerpost / tcl / material.tcl

#/*****************************************************************************
# *
# *  Elmer, A Finite Element Software for Multiphysical Problems
# *
# *  Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland
# * 
# *  This program is free software; you can redistribute it and/or
# *  modify it under the terms of the GNU General Public License
# *  as published by the Free Software Foundation; either version 2
# *  of the License, or (at your option) any later version.
# * 
# *  This program is distributed in the hope that it will be useful,
# *  but WITHOUT ANY WARRANTY; without even the implied warranty of
# *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# *  GNU General Public License for more details.
# *
# *  You should have received a copy of the GNU General Public License
# *  along with this program (in file fem/GPL-2); if not, write to the 
# *  Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 
# *  Boston, MA 02110-1301, USA.
# *
# *****************************************************************************/

#*******************************************************************************
#*
#* Material editor utility widget.
#*
#*******************************************************************************
#*
#*                     Author:       Juha Ruokolainen
#*
#*                    Address: CSC - IT Center for Science Ltd.
#*                                Keilaranta 14, P.O. BOX 405
#*                                  02101 Espoo, Finland
#*                                  Tel. +358 0 457 2723
#*                                Telefax: +358 0 457 2302
#*                              EMail: Juha.Ruokolainen@csc.fi
#*
#*                       Date: 26 Sep 1995
#*
#*                Modified by:
#*
#*       Date of modification:
#*
#*******************************************************************************
#
# User level command for setting material parametrs
#
proc material { args } {
     global me_color me_A me_S

     set Usage "\
Usage: material -diffuse r,g,b -specular r,g,b -shininess exp -opacity percent\n\n\
-(r,g,b) values are given in percents of the full intensity\n -exp can be range from  0 to 128,\n -opactity is in percents.\n"

     set opt(1,name)  -diffuse;     set opt(1,args)  3
     set opt(2,name)  -specular;    set opt(2,args)  3
     set opt(3,name)  -shininess;   set opt(3,args)  1
     set opt(4,name)  -opacity;     set opt(4,args)  1
     set opt(5,name)  -noupdate;    set opt(5,args)  0
     set opt(6,name)  -vectors;     set opt(6,args)  0
     set opt(7,name)  -contour;     set opt(7,args)  0
     set opt(8,name)  -mesh;        set opt(8,args)  0
     set opt(9,name)  -sphere;      set opt(9,args)  0
     set opt(10,name) -particles;   set opt(10,args) 0
     set opt(11,name) -isosurface;  set opt(11,args) 0
     set opt(12,name) -default;     set opt(12,args) 0

     check_args material $Usage 12 0 opt opt_val 0 0 arg_val $args

     if { ![info exists opt_val] } { return $Usage }

     set me_edit .me_editMaterial
     set update 1

     set cmd "material"

     set sid [array startsearch opt_val]

     set defopt "-default"

     while { [array anymore opt_val $sid] != 0 } {

         set n [array nextelement opt_val $sid]
         set value $opt_val($n)
         set n [string range $n 1 [string length $n]]

         switch $n {
            diffuse {
                 if { [info exists me_color($me_edit,diffuse,R)] } {
                     set R $me_color($me_edit,diffuse,R)
                     set G $me_color($me_edit,diffuse,G)
                     set B $me_color($me_edit,diffuse,B)
                 }

                 scan $value "%f,%f,%f" R G B

                 set me_color($me_edit,diffuse,R) $R
                 set me_color($me_edit,diffuse,G) $G
                 set me_color($me_edit,diffuse,B) $B

                 set cmd "$cmd -diffuse $R,$G,$B"
            }
            specular {
                 if { [info exists me_color($me_edit,specular,R)] } {
                     set R $me_color($me_edit,specular,R)
                     set G $me_color($me_edit,specular,G)
                     set B $me_color($me_edit,specular,B)
                 }
     
                 scan $value "%f,%f,%f" R G B
  
                 set me_color($me_edit,specular,R) $R
                 set me_color($me_edit,specular,G) $G
                 set me_color($me_edit,specular,B) $B

                 set cmd "$cmd -specular $R,$G,$B"
            }
            shininess {
                if { [info exists me_S($me_edit)] }  { set S $me_S($me_edit) }
                scan $value "%d" S
                set me_S($me_edit) $S

                set cmd "$cmd -shininess $S"
            } 
            opacity {
                if { [info exists me_A($me_edit)] }  { set A $me_A($me_edit) }
                scan $value "%d" A
                set me_A($me_edit) $A

                set cmd "$cmd -opacity $A"
            }
            noupdate {
                set update 0
            }
            vectors    { set defopt "-vectors" }
            mesh       { set defopt "-mesh"    }
            contour    { set defopt "-contour" }
            sphere     { set defopt "-sphere"  }
            particles  { set defopt "-particles" }
            isosurface { set defopt "-isosurface" }
         }
     }

     array donesearch opt_val $sid

     if { $cmd == "" } return

     if { $update && [winfo exists $me_edit] } { me_UpdateAll $me_edit }

     UpdateColor $defopt color diffuse $me_color($me_edit,diffuse,R) $me_color($me_edit,diffuse,G) $me_color($me_edit,diffuse,B)     \
                 color specular $me_color($me_edit,specular,R) $me_color($me_edit,specular,G) $me_color($me_edit,specular,B) \
                 opacity $me_A($me_edit) shininess $me_S($me_edit)
     UpdateObject;

     if { !$update } { history add $cmd }
}

#
# User level command to set background color
#
proc background { args } {
    global me_color

    set Usage \
"Usage: background red green blue\n\nRed,Green, and Blue are in percents of the full intensity.\n"

    set opt(1,name) -noupdate;  set opt(1,args) 0

    check_args background $Usage 1 1 opt opt_val 1 3 arg_val $args

    set me_edit .me_editBackground

    set update 1

    if { [info exists opt_val(-noupdate)] } { set update 0 }

    if { [info exists me_color($me_edit,diffuse,R)] } {
        set R $me_color($me_edit,diffuse,R)
        set G $me_color($me_edit,diffuse,G)
        set B $me_color($me_edit,diffuse,B)
    }

    scan $args "%f %f %f" R G B

    set me_color($me_edit,diffuse,R) $R
    set me_color($me_edit,diffuse,G) $G
    set me_color($me_edit,diffuse,B) $B

    if { $update && [winfo exists $me_edit] } { me_UpdateColor $me_edit }

    UpdateBackColor color diffuse $me_color($me_edit,diffuse,R) $me_color($me_edit,diffuse,G) $me_color($me_edit,diffuse,B)

    UpdateEdgeColor color diffuse [@ 100-$R] [@ 100-$G] [@ 100-$B]

    if { !$update } { history add "background $R $G $B" }
}

#
# Create a material editor toplevel window for a user to use.
# There can be several editors running at any time provided 
# a different name for editor is given at each invokation.
#
# 12 Sep 1995
#
proc me_Edit { name just_colors {UpdateProc material} } {
   global me_color me_A me_S me_edit_var me_rgb_list me_R me_G me_B me_apply_to me_defopt

   set me_edit .me_edit$name

   if { [winfo exists $me_edit] } { destroy $me_edit }

   if { ![info exists me_color($me_edit,diffuse,R)] } {
       set me_color($me_edit,diffuse,R) 100
       set me_color($me_edit,diffuse,G) 100
       set me_color($me_edit,diffuse,B) 100
   }

   if { ![info exists me_color($me_edit,specular,R)] } {
       set me_color($me_edit,specular,R) 0
       set me_color($me_edit,specular,G) 0
       set me_color($me_edit,specular,B) 0
   }

   if { ![info exists me_S($me_edit)] } { set me_S($me_edit)  20 }

   if { ![info exists me_A($me_edit)] } { set me_A($me_edit) 100 }

   if { ![info exists me_edit_var($me_edit)] } { set me_edit_var($me_edit) "diffuse" }

   set me_R($me_edit) $me_color($me_edit,$me_edit_var($me_edit),R)
   set me_G($me_edit) $me_color($me_edit,$me_edit_var($me_edit),G)
   set me_B($me_edit) $me_color($me_edit,$me_edit_var($me_edit),B)

   toplevel $me_edit
   place_window $me_edit
   wm minsize $me_edit 100 100
   wm title $me_edit $name

   label $me_edit.title -height 1;#-text "Elmer Post - Material" -height 3 -font -Adobe-Times-Medium-R-Normal-*-180-*
   pack $me_edit.title -side top -expand 1 -fill both

    frame $me_edit.menubar

    menubutton $me_edit.menubar.file -menu $me_edit.menubar.file.menu -text "Apply-To" -underline 0
    menu $me_edit.menubar.file.menu

    set me_apply_to 0
    set me_defopt   "-default"
    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Default" -value 0 -variable me_apply_to \
               -command { set me_defopt "-default" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Mesh" -value 1 -variable me_apply_to \
               -command { set me_defopt "-mesh" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Vectors" -value 2 -variable me_apply_to \
               -command { set me_defopt "-vectors" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Contour" -value 3 -variable me_apply_to \
               -command { set me_defopt "-contour" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Isosurface" -value 4 -variable me_apply_to \
               -command { set me_defopt "-isosurface" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Spheres" -value 5 -variable me_apply_to \
               -command { set me_defopt "-sphere" }

    $me_edit.menubar.file.menu add radiobutton
    $me_edit.menubar.file.menu entryconfigure last -label "Particles" -value 6 -variable me_apply_to \
               -command { set me_defopt "-particles" }

    pack $me_edit.menubar.file -side left
    pack $me_edit.menubar -side top -expand 1 -fill both

   frame $me_edit.red   -bd 10 -relief ridge -bg lightblue
   frame $me_edit.green -bd 10 -relief ridge -bg lightblue
   frame $me_edit.blue  -bd 10 -relief ridge -bg lightblue

   if { !$just_colors } {
#
# Radiobuttons selecting color (diffuse or specular) to be edited
#
       frame $me_edit.rbox -bd 5 -relief ridge -bg lightblue
       radiobutton $me_edit.rbox.diffuse  -variable me_edit_var($me_edit) -value "diffuse" \
                 -text "Ambient & Diffuse" -command "me_ChangeSpec $me_edit"

       radiobutton $me_edit.rbox.specular -variable me_edit_var($me_edit) -value "specular" \
                     -text "Specular" -command "me_ChangeSpec $me_edit"



       pack $me_edit.rbox.diffuse  -side left -expand 1 -fill x
       pack $me_edit.rbox.specular -side left -expand 1 -fill x
       pack $me_edit.rbox -side top -expand 1 -fill both

#
# slider for Shininess setting
#
       frame $me_edit.sbox -bd 5 -relief ridge -bg lightblue
       slider $me_edit.sbox.scl -orient horizontal -command "me_SetShine $me_edit" -from 0 -to 128 -digit 4 -resol 0.5 -tick 32
       label $me_edit.sbox.lab -text "Shininess" -relief raised -bd 5

       pack $me_edit.sbox.scl -side bottom -expand 1 -fill x
       pack $me_edit.sbox.lab -side bottom -expand 1 -fill x
       pack $me_edit.sbox -expand 1 -fill both

#
# slider for Opacity setting
#
       frame $me_edit.obox -bd 5 -relief ridge -bg lightblue
       slider $me_edit.obox.scl -orient horizontal -command "me_SetOpac $me_edit" -from 0 -to 100 -digit 4 -resol 0.5
       label $me_edit.obox.lab -text "Opacity (%)" -relief raised -bd 5

       pack $me_edit.obox.scl -side bottom -expand 1 -fill x
       pack $me_edit.obox.lab -side bottom -expand 1 -fill x
       pack $me_edit.obox -expand 1 -fill both
   }

#
# button, background showing current color, pressing it same as Apply-button (downwards)
#
   button $me_edit.value -bd 10 -relief raised -command \
           "$UpdateProc \$me_defopt -\$me_edit_var($me_edit) \$me_R($me_edit),\$me_G($me_edit),\$me_B($me_edit) \
                  -opacity \$me_A($me_edit) -shininess \$me_S($me_edit) -noupdate"


#
# rgb sliders
#
   slider $me_edit.red.scl -orient horizontal -command "me_ShowColor $me_edit" -from 0 -to 100 -troughcolor red -digit 4 -resol 0.5
   slider $me_edit.green.scl -orient horizontal -command "me_ShowColor $me_edit" -from 0 -to 100 -troughcolor green -digit 4 -resol 0.5
   slider $me_edit.blue.scl -orient horizontal -command "me_ShowColor $me_edit" -from 0 -to 100 -troughcolor blue -digit 4 -tick 25 -resol 0.5

   pack $me_edit.red.scl -side left -expand 1 -fill x
   pack $me_edit.green.scl -side left -expand 1 -fill x
   pack $me_edit.blue.scl -side left -expand 1 -fill x

   pack $me_edit.red -side top -fill x
   pack $me_edit.green -side top -fill x
   pack $me_edit.blue -side top  -fill x
   pack $me_edit.value -side top -expand 1 -fill both

#
# List box containing color names
#
   frame $me_edit.lbox -relief sunken -bg lightblue
   listbox $me_edit.lbox.list -yscroll "$me_edit.lbox.scroll set"
   scrollbar $me_edit.lbox.scroll -command "$me_edit.lbox.list yview"

   pack $me_edit.lbox.scroll -side left -fill y
   pack $me_edit.lbox.list -side left -expand 1 -fill both
   pack $me_edit.lbox -side top -expand 1 -fill both

   bind $me_edit.lbox.list <Double-1> {me_SetListColor %W}

#
# button box at window bottom (Apply,OK,Cancel)
#
   frame $me_edit.bbox  -bg lightblue

   button $me_edit.bbox.apply -text "Apply" -command \
           "$UpdateProc \$me_defopt -\$me_edit_var($me_edit) \$me_R($me_edit),\$me_G($me_edit),\$me_B($me_edit) \
                  -opacity \$me_A($me_edit) -shininess \$me_S($me_edit) -noupdate"

   button $me_edit.bbox.cancel -text "Cancel" -command "destroy $me_edit"

   button $me_edit.bbox.ok -text "OK" -command \
           "$UpdateProc \$me_defopt -\$me_edit_var($me_edit) \$me_R($me_edit),\$me_G($me_edit),\$me_B($me_edit) \
              -opacity \$me_A($me_edit) -shininess \$me_S($me_edit) -noupdate; destroy $me_edit"

   pack $me_edit.bbox.apply  -side left -expand 1 -fill x
   pack $me_edit.bbox.ok  -side left -expand 1 -fill x
   pack $me_edit.bbox.cancel  -side left -expand 1 -fill x

   pack $me_edit.bbox -side top -expand 1 -fill both

#
#  Get database of color names -> RGB-values, and add them to a listbox
#
   if { ![info exists me_rgb_list] } me_GetColorNames
   me_AddColorNames $me_edit.lbox.list

#
# Update the slider etc. values
#
   if { $name == "Material"   } { me_UpdateAll   $me_edit }
   if { $name == "Background" } { me_UpdateColor $me_edit }
}

#
# Update the color settings given current state
#
proc me_UpdateColor { top } {
   global me_edit_var me_R me_G me_B me_color

   if { $me_edit_var($top) == "diffuse" } {
       set me_R($top) $me_color($top,diffuse,R)
       set me_G($top) $me_color($top,diffuse,G)
       set me_B($top) $me_color($top,diffuse,B)

       $top.red.scl set $me_R($top)
       $top.green.scl set $me_G($top)
       $top.blue.scl set $me_B($top)
   } else {
       set me_R($top) $me_color($top,specular,R)
       set me_G($top) $me_color($top,specular,G)
       set me_B($top) $me_color($top,specular,B)

       $top.red.scl set $me_R($top)
       $top.green.scl set $me_G($top)
       $top.blue.scl set $me_B($top)
   }
}


#
# Update the interaction window, given current state
#
proc me_UpdateAll { top } {
    global me_S me_A

    me_UpdateColor $top

    $top.sbox.scl set $me_S($top)
    $top.obox.scl set $me_A($top)
}

#
# User pressed one of the radiobuttons changing the diffuse/specular setting
#
proc me_ChangeSpec { top } {
    global me_edit_var me_R me_G me_B me_color

    set me_R($top) $me_color($top,$me_edit_var($top),R)
    set me_G($top) $me_color($top,$me_edit_var($top),G)
    set me_B($top) $me_color($top,$me_edit_var($top),B)

    $top.red.scl   set $me_R($top)
    $top.green.scl set $me_G($top)
    $top.blue.scl  set $me_B($top)
}

#
# Get color name from listbox and show the color with a button
#
# 12 Sep 1995
#
proc me_SetListColor {w} {
    global me_edit_var me_rgb_list me_R me_G me_B me_color

    set top [winfo toplevel $w]

    set value [$w get [$w curselection]]

    set me_R($top) $me_rgb_list($value,R)
    set me_G($top) $me_rgb_list($value,G)
    set me_B($top) $me_rgb_list($value,B)

    $top.red.scl   set $me_R($top)
    $top.green.scl set $me_G($top)
    $top.blue.scl  set $me_B($top)

    set R $me_R($top)
    set G $me_G($top)
    set B $me_B($top)

    set me_color($top,$me_edit_var($top),R) $R
    set me_color($top,$me_edit_var($top),G) $G
    set me_color($top,$me_edit_var($top),B) $B

    set R [@ int(2.55*$R+0.5)]
    set G [@ int(2.55*$G+0.5)]
    set B [@ int(2.55*$B+0.5)]

    set value  [format "#%02x%02x%02x" $R $G $B]
    set value1 [format "#%02x%02x%02x" [@ 255-$R] [@ 255-$G] [@ 255-$B]]

    $top.value configure -bg $value -activeback $value -fg $value1
}

proc me_Nil { args } {}

#
# Get rgb-definition from sliders and set button background accordingly
#
# 12 Sep 1995
#
proc me_ShowColor {top args} {
    global me_R me_G me_B me_edit_var me_color

    set me_R($top) [$top.red.scl   get]
    set me_G($top) [$top.green.scl get]
    set me_B($top) [$top.blue.scl  get]

    set R $me_R($top)
    set G $me_G($top)
    set B $me_B($top)

    set me_color($top,$me_edit_var($top),R) $R
    set me_color($top,$me_edit_var($top),G) $G
    set me_color($top,$me_edit_var($top),B) $B

    set R [@ int(2.55*$R+0.5)]
    set G [@ int(2.55*$G+0.5)]
    set B [@ int(2.55*$B+0.5)]

    set value  [format "#%02x%02x%02x" $R $G $B]
    set value1 [format "#%02x%02x%02x" [@ 255-$R] [@ 255-$G] [@ 255-$B]]

    $top.value configure -bg $value -activeback $value -fg $value1
}

#
# Set material state for opacity according to slider value 
#
# 19 Sep 1995
#
proc me_SetOpac {top value} {
    global me_A

    set me_A($top) $value
}

#
# Set material state for shininess according to slider value 
#
# 19 Sep 1995
#
proc me_SetShine {top value} {
    global me_S

    set me_S($top) $value
}

#
# Add color names to a listbox given as argument
#
# 13 Sep 1995
#
proc me_AddColorNames {w} {
    global me_rgb_count me_rgb_names

    do i 0 [@ $me_rgb_count-1] { $w insert end $me_rgb_names($i) }
}

#
# Read color names and their rgb-definitions from a file rgb.txt
#
# 13 Sep 1995
#
proc me_GetColorNames {} {
   global me_rgb_list me_rgb_names me_rgb_count ELMER_POST_HOME

   set me_rgb_file [open "$ELMER_POST_HOME/lib/rgb.txt" RDONLY]

   set me_rgb_count 0
   while {![eof $me_rgb_file]} {
      set me_str [gets $me_rgb_file]
      set me_str [string trim $me_str]
      if { [string index $me_str 0] == "!" } continue

      set R 0
      set G 0
      set B 0

      set me_name1 ""
      scan $me_str "%d %d %d %s %s" R G B me_name me_name1
      set me_name "$me_name $me_name1"
      set me_name [string trim $me_name]

      set R [@ $R/2.55]
      set G [@ $G/2.55]
      set B [@ $B/2.55]

      set me_rgb_list($me_name,R) $R
      set me_rgb_list($me_name,G) $G
      set me_rgb_list($me_name,B) $B
      set me_rgb_names($me_rgb_count) $me_name

      incr me_rgb_count
   }

   close $me_rgb_file
}