mirror of
https://git.dev.opencascade.org/repos/occt.git
synced 2025-04-21 10:13:43 +03:00
427 lines
12 KiB
Tcl
427 lines
12 KiB
Tcl
# Copyright (c) 1999-2014 OPEN CASCADE SAS
|
|
#
|
|
# This file is part of Open CASCADE Technology software library.
|
|
#
|
|
# This library is free software; you can redistribute it and/or modify it under
|
|
# the terms of the GNU Lesser General Public License version 2.1 as published
|
|
# by the Free Software Foundation, with special exception defined in the file
|
|
# OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
|
|
# distribution for complete text of the license and disclaimer of any warranty.
|
|
#
|
|
# Alternatively, this file may be used under the terms of Open CASCADE
|
|
# commercial license or contractual agreement.
|
|
|
|
###########################
|
|
# #
|
|
# Version 1.0 #
|
|
# by FID #
|
|
# #
|
|
###########################
|
|
#
|
|
# Open : double-clic or +
|
|
# Close : double-clic or -
|
|
# Refresh tree : close top level and re-open
|
|
#
|
|
# Attributes:
|
|
# white : interoperable
|
|
# white + c : non interoperable
|
|
# X : X Reference
|
|
# Red : not yet committed in transaction #0
|
|
#
|
|
#
|
|
|
|
proc __update { args } {
|
|
}
|
|
|
|
global TreeBrowser
|
|
|
|
proc treebrowser { TreeBrowser } {
|
|
|
|
global TREE_WINDOWS
|
|
global TREE_LabelStyle
|
|
global TREE_LabelStyle1
|
|
global TREE_AttributeStyle
|
|
global TREE_AttributeStyle1
|
|
global TREE_AttributeStyle2
|
|
|
|
global $TreeBrowser
|
|
|
|
package require Tix
|
|
tixPref:InitFontSet:14Point
|
|
|
|
set TREE_LabelStyle [tixDisplayStyle imagetext \
|
|
-font 9x15bold \
|
|
-background Bisque3 \
|
|
]
|
|
|
|
set TREE_LabelStyle1 [tixDisplayStyle imagetext \
|
|
-font 9x15bold \
|
|
-background Bisque3 \
|
|
-foreground SeaGreen2 \
|
|
]
|
|
|
|
set TREE_AttributeStyle [tixDisplayStyle imagetext \
|
|
-font 9x15 \
|
|
-background Bisque3 \
|
|
]
|
|
|
|
set TREE_AttributeStyle1 [tixDisplayStyle imagetext \
|
|
-font 9x15 \
|
|
-background Bisque3 \
|
|
-foreground Green \
|
|
]
|
|
|
|
set TREE_AttributeStyle2 [tixDisplayStyle imagetext \
|
|
-font 9x15 \
|
|
-background Bisque3 \
|
|
-foreground Red \
|
|
]
|
|
|
|
set w .$TreeBrowser
|
|
toplevel $w
|
|
|
|
set top [frame $w.thu -bd 1 -relief raised -background Bisque3]
|
|
|
|
################
|
|
# Paned Window #
|
|
################
|
|
set p [tixPanedWindow $top.p -orient horizontal -height 400 -width 700]
|
|
pack $p -expand yes -fill both -padx 4 -pady 4
|
|
|
|
TREE:Tree:InitTreePanel $TreeBrowser $w $p
|
|
#TREE:Tree:InitTextPanel $TreeBrowser $w $p
|
|
|
|
tixForm $top -left 2 -top 2 -right %99 -bottom %99
|
|
|
|
return
|
|
}
|
|
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:InitTreePanel { TreeBrowser w p } {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
|
|
########
|
|
# Tree #
|
|
########
|
|
|
|
set p1 [$p add pane1 -expand 1 -size 700] ; $p1 config -relief flat
|
|
set tree [tixTree $p1.tree \
|
|
-opencmd [list TREE:Tree:Open $TreeBrowser $w] \
|
|
-options { \
|
|
hlist.separator "^" \
|
|
hlist.font 9x15bold \
|
|
hlist.background Bisque3 \
|
|
hlist.foreground Black \
|
|
} ]
|
|
pack $p1.tree -expand yes -fill both -padx 4 -pady 4
|
|
|
|
# -browsecmd TREE:Tree:BrowseCmd
|
|
# Cette option peut etre ajoutee a la commande tixTree,
|
|
# mais elle declanche l'appel a la procedure a chaque clic ,
|
|
# double-clic, voire a chaque appui puis relachement de souris!!!
|
|
|
|
# to see different fonts: /usr/openwin/lib/X11/fonts/misc or xlsfonts?
|
|
# 8x13 8x13bold 9x15 9x15bold
|
|
# hlist.font 8x13bold
|
|
# hlist.gap "15"
|
|
# hlist.indent "30"
|
|
|
|
set TREE_WINDOWS($w,NAV,tree) $tree
|
|
set TREE_WINDOWS($w,NAV,hlist) [$tree subwidget hlist]
|
|
$TREE_WINDOWS($w,NAV,hlist) add ^ \
|
|
-text $TreeBrowser \
|
|
-data [list $TreeBrowser Root]
|
|
$TREE_WINDOWS($w,NAV,tree) setmode ^ open
|
|
}
|
|
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:InitTextPanel { TreeBrowser w p } {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
|
|
########
|
|
# Text #
|
|
########
|
|
set p2 [$p add pane2 -expand 4 -size 400] ; $p2 config -relief flat
|
|
tixScrolledText $p2.st
|
|
pack $p2.st -expand yes -fill both -padx 4 -pady 4
|
|
|
|
set TREE_WINDOWS($w,NAV,text) [$p2.st subwidget text]
|
|
|
|
|
|
|
|
$TREE_WINDOWS($w,NAV,text) insert end " Welcome to the QDF browser (Rev #.#)\n"
|
|
$TREE_WINDOWS($w,NAV,text) insert end "--------------------------------------\n\n"
|
|
$TREE_WINDOWS($w,NAV,text) insert end "This browser is an easy to use prototype made with Tix technology. We hope it will be useful for understanding and debugging QDF.\n"
|
|
$TREE_WINDOWS($w,NAV,text) insert end "\t\t\t\tFID & YAN"
|
|
}
|
|
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:BrowseCmd { dir } {
|
|
puts "Hello $dir !"
|
|
}
|
|
###############################################################################
|
|
# Se positionne sur l'entry pere et update les fenetres.
|
|
#
|
|
proc FCTREE:Tree:Up { w } {
|
|
global TREE_WINDOWS
|
|
global TREE_GLOBALS
|
|
#puts "TREE:Tree:Up"
|
|
|
|
if { [set here [$TREE_WINDOWS($w,NAV,hlist) info anchor]] != {} } {
|
|
if { [set up [$TREE_WINDOWS($w,NAV,hlist) info parent $here]] != {} } {
|
|
TREE:Tree:ShowUp $w $up
|
|
set TREE_GLOBALS(CWD) [lindex [$TREE_WINDOWS($w,NAV,hlist) info data $up] 0]
|
|
}
|
|
}
|
|
return
|
|
}
|
|
###############################################################################
|
|
# Se positionne sur l'entry up sans update (History)
|
|
#
|
|
proc TREE:Tree:ShowUp { w dir } {
|
|
global TREE_WINDOWS
|
|
#puts "TREE:Tree:ShowUp"
|
|
|
|
$TREE_WINDOWS($w,NAV,hlist) anchor clear
|
|
$TREE_WINDOWS($w,NAV,hlist) anchor set $dir
|
|
$TREE_WINDOWS($w,NAV,hlist) selection clear
|
|
$TREE_WINDOWS($w,NAV,hlist) selection set $dir
|
|
$TREE_WINDOWS($w,NAV,hlist) see $dir
|
|
return
|
|
}
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:Open { TreeBrowser w dir} {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
#puts "TREE:Tree:Open"
|
|
|
|
if {$dir == "^"} {
|
|
# This is root
|
|
if {[$TREE_WINDOWS($w,NAV,hlist) info children $dir] != {}} {
|
|
# The root branch already exists in hlist.
|
|
# Clear all its children to force the tree to be updated.
|
|
foreach kid [$TREE_WINDOWS($w,NAV,hlist) info children $dir] {
|
|
$TREE_WINDOWS($w,NAV,hlist) delete entry $kid
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[$TREE_WINDOWS($w,NAV,hlist) info children $dir] != {}} {
|
|
# The branch exists in hlist.
|
|
foreach kid [$TREE_WINDOWS($w,NAV,hlist) info children $dir] {
|
|
$TREE_WINDOWS($w,NAV,hlist) show entry $kid
|
|
}
|
|
set data [$TREE_WINDOWS($w,NAV,hlist) info data $dir]
|
|
#set loc [lindex $data 0]
|
|
} else {
|
|
# The branch is unknown.
|
|
tixBusy $w on
|
|
update
|
|
TREE:Tree:Fill $TreeBrowser $w $dir
|
|
tixBusy $w off
|
|
}
|
|
return
|
|
}
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:Fill { TreeBrowser w dir } {
|
|
global TREE_WINDOWS
|
|
global TREE_GLOBALS
|
|
global $TreeBrowser
|
|
#puts "TREE:Tree:Fill"
|
|
|
|
set data [$TREE_WINDOWS($w,NAV,hlist) info data $dir]
|
|
#set loc [lindex $data 0]
|
|
set type [lindex $data 1]
|
|
|
|
#puts "====================="
|
|
#puts "Type $type"
|
|
#puts "Window $w"
|
|
#puts "Loc $loc"
|
|
#puts "Dir $dir"
|
|
#puts "====================="
|
|
|
|
switch -glob $type {
|
|
|
|
Root {
|
|
TREE:Tree:UpdateRoot $TreeBrowser $w $dir
|
|
}
|
|
|
|
Node {
|
|
set lab [lindex $data 0]
|
|
TREE:Tree:UpdateNode $TreeBrowser $w $dir $lab
|
|
}
|
|
|
|
terminal {
|
|
TREE:Tree:terminal $TreeBrowser $w $dir
|
|
}
|
|
|
|
default {
|
|
puts "type non reconnu"
|
|
}
|
|
}
|
|
return
|
|
}
|
|
###############################################################################
|
|
# ici dir = ^
|
|
#
|
|
proc TREE:Tree:UpdateRoot { TreeBrowser w dir } {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
global TREE_AttributeStyle
|
|
global TREE_AttributeStyle1
|
|
#puts "TREE:Tree:UpdateRoot"
|
|
|
|
foreach nodeItem [split [OpenNode $TreeBrowser ""] "\\" ] {
|
|
|
|
TREE:Tree:DecodeNodeItem $TreeBrowser $w $dir $nodeItem
|
|
|
|
}
|
|
|
|
return
|
|
}
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:UpdateNode { TreeBrowser w dir lab} {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
global TREE_AttributeStyle
|
|
global TREE_AttributeStyle1
|
|
#puts "TREE:Tree:UpdateNode"
|
|
|
|
foreach nodeItem [split [OpenNode $TreeBrowser $lab ] "\\" ] {
|
|
|
|
TREE:Tree:DecodeNodeItem $TreeBrowser $w $dir $nodeItem
|
|
|
|
}
|
|
return
|
|
}
|
|
###############################################################################
|
|
# item:
|
|
# "LabelEntry "Name" DynamicType Executable|Forgotten Failed|Success First|Null [ LabelFather]"
|
|
proc TREE:Tree:DecodeNodeItem { TreeBrowser w dir nodeItem} {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
global TREE_AttributeStyle
|
|
global TREE_AttributeStyle1
|
|
global TREE_AttributeStyle2
|
|
#puts "TREE:Tree:DecodeNodeItem"
|
|
|
|
set litm {}
|
|
set standardimage [tix getimage file]
|
|
set forgottenimage [tix getimage maximize]
|
|
set image $standardimage
|
|
|
|
# Information first split
|
|
set tmplist [split $nodeItem " "]
|
|
set labentry [lindex $tmplist 0]
|
|
set name [lindex $tmplist 1]
|
|
set type [lindex $tmplist 2]
|
|
#set exec [lindex $tmplist 3]
|
|
#set state [lindex $tmplist 4]
|
|
set children [lindex $tmplist 3]
|
|
set father [lindex $tmplist 4]
|
|
set first [lindex $tmplist 5]
|
|
set next [lindex $tmplist 6]
|
|
set previous [lindex $tmplist 7]
|
|
|
|
#puts "labentry : $labentry"
|
|
#puts "name : $name"
|
|
#puts "type : $type"
|
|
#puts "state : $state"
|
|
#puts "exec : $exec"
|
|
#puts "children : $children"
|
|
#puts "father : $father"
|
|
#puts "first : $first"
|
|
#puts "next : $next"
|
|
#puts "previous : $previous"
|
|
|
|
# Label entry , name & Dynamic type.
|
|
set ll [expr [string length $name] -2]
|
|
if {$ll > 0} {
|
|
set textname "$labentry [string range $name 1 $ll] $type"
|
|
} else {
|
|
set textname "$labentry $type"
|
|
}
|
|
|
|
set locstyle $TREE_AttributeStyle
|
|
|
|
# Executable/Forgotten?
|
|
#if {$exec == "Forgotten"} {
|
|
#set textname "$textname $exec"
|
|
#set locstyle $TREE_AttributeStyle1
|
|
#set image $forgottenimage
|
|
#}
|
|
|
|
# Failed/Success analysis.
|
|
#if {$state == "Failed"} {
|
|
#set textname "$textname $state"
|
|
#set locstyle $TREE_AttributeStyle2
|
|
#}
|
|
|
|
# Father?
|
|
if {$father != "Null"} {set textname "$textname Father=$father"}
|
|
# First?
|
|
if {$first != "Null"} {set textname "$textname First=$first"}
|
|
# Next?
|
|
if {$next != "Null"} {set textname "$textname Next=$next"}
|
|
# Previous?
|
|
if {$previous != "Null"} {set textname "$textname Previous=$previous"}
|
|
|
|
$TREE_WINDOWS($w,NAV,hlist) add ${dir}^${labentry} \
|
|
-itemtype imagetext \
|
|
-text $textname \
|
|
-image $image \
|
|
-style $locstyle \
|
|
-data [list ${labentry} Node]
|
|
if {$children == "First"} {
|
|
$TREE_WINDOWS($w,NAV,tree) setmode ${dir}^${labentry} open
|
|
}
|
|
lappend litm [list $labentry $image]
|
|
|
|
return
|
|
}
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:terminal { TreeBrowser w dir } {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
return
|
|
}
|
|
###############################################################################
|
|
#
|
|
#
|
|
proc TREE:Tree:DisplayAttribute { TreeBrowser w dir } {
|
|
global TREE_WINDOWS
|
|
global $TreeBrowser
|
|
|
|
return
|
|
}
|
|
###############################################################################
|
|
# imprime tout ce qu'il y a dans hli ( Hlist )
|
|
#
|
|
proc wokDBG { {root {}} } {
|
|
global TREE_GLOBALS
|
|
global TREE_WINDOWS
|
|
set w $TREE_GLOBALS(toplevel)
|
|
set hli $TREE_WINDOWS($w,NAV,hlist)
|
|
foreach c [$hli info children $root] {
|
|
puts "$c : data <[$hli info data $c]>"
|
|
wokDBG $c
|
|
}
|
|
return
|
|
}
|