Sex Tcl Script
|
|
|
Sex Tcl Script
# Init entry point.
proc initBehavior {} {
if [ catch { sexBehaviourInit } err ] {
return -code error "sexBehaviourInit > $err"
}
}
# Update entry point
proc updateBehavior {} {
if [ catch { sexBehaviour } err ] {
return -code error "sexBehaviour > $err"
}
}
# Cleanup entry point frees memory and unsets global variables.
proc cleanupBehavior {} {
global modelAttachedName
global nbOfNewBornBabies
catch { sexBehaviourFree }
unset modelAttachedName
unset nbOfNewBornBabies
}
# This init procedure is executed in init entry point.
proc sexBehaviourInit {} {
global modelAttachedName
global nbOfNewBornBabies
global env
package require SWC
# Source file with the procedure that mixes colors of the parents.
source [file join $env(SI_LOCATION) 3D custom SoftWish \
SoftWishDemos behaviorDemo mixedColors.tcl]
# Determine the name of element with attached tcl script.
set modelAttachedName [SWB_getCurrentElementName]
set nbOfNewBornBabies 0
}
# This procedure is executed in update entry point.
proc sexBehaviour {} {
global SAA_Constants
global SAA_unConstants
global modelAttachedName
global sexBehaviour_SAA_obj
global nbOfNewBornBabies
# Retrieve current scene and model with attached this tcl script.
# In our case we assume this is a sphere.
set curSceneID [SWB_getScene]
set modelAttachedID [SWB_getCurrentElement]
# Get wire type of the sphere.
SAA_elementGetWireType $curSceneID $modelAttachedID wireType
# If sphere is invisible then return.
if { $SAA_unConstants(SAA_WireType,$wireType) != "SAA_WIR_FULL" } {
return
}
# Retrieve the number of models in the scene.
SAA_sceneGetNbModels $curSceneID nbModels
# Retrieve names of the scene models and array with their IDs.
set listNames [ SWCSR_elementGetNames $curSceneID Models $nbModels \
sexBehaviour_SAA_obj(modelsID) ]
set count 0
# For each model in the scene:
foreach item $listNames {
# If the name of model is the name of the sphere then continue with the next model.
if { $item == $modelAttachedName } {
incr count
continue
}
# Retrieve wire type of the model
SAA_elementGetWireType $curSceneID \
[access $sexBehaviour_SAA_obj(modelsID) $count] wireType
# If it is invisible then continue with the next model.
if { $SAA_unConstants(SAA_WireType,$wireType) != "SAA_WIR_FULL" } {
incr count
continue
}
# Define the distance between model centers.
set distance [ SW_exprValue "ctr_dist($item.,\
$modelAttachedName.)" $curSceneID ]
# If it is less then some number then we assume that they collide.
if { $distance < 2.32 } {
# Determine if models are of the same type. We assume that models have the same type if
# their names have the same character parts ( for example sphere1 and sphere2 )
regexp {[A-Za-z]*} $modelAttachedName match1
regexp {[A-Za-z]*} $item match2
# If models have the same type then:
if { [ string compare $match1 $match2] == 0 } {
# Create a new sphere and set the name "sphere" to it.
set sexBehaviour_SAA_obj(babyID) [SAA_AllocElem]
SAA_meshCreateSphere $curSceneID 0.8 8 8 $sexBehaviour_SAA_obj(babyID)
set babyName "sphere"
SAA_elementSetName $curSceneID $sexBehaviour_SAA_obj(babyID) babyName
incr nbOfNewBornBabies
# Set expressions to etrnx and etrny of baby sphere. It will spin around its mother (model
# with attached code).
set sexBehaviour_SAA_obj(childExpr) [ SAA_AllocElem ]
set childTrackName etrnx
set speed [ expr $nbOfNewBornBabies*20 ]
set childExprStr "$modelAttachedName.etrnx + 4* cos($speed * Fc)"
SAA_expressionCreate $curSceneID $sexBehaviour_SAA_obj(babyID) childTrackName \
0 NULL NULL childExprStr $sexBehaviour_SAA_obj(childExpr)
set childTrackName etrny
set childExprStr "$modelAttachedName.etrny + 4* sin($speed * Fc)"
SAA_expressionCreate $curSceneID $sexBehaviour_SAA_obj(babyID) \
childTrackName 0 NULL NULL childExprStr $sexBehaviour_SAA_obj(childExpr)
# Set the color to the baby. The color is a mixture of the parent's colors.
mixedColors $curSceneID $modelAttachedID \
[access $sexBehaviour_SAA_obj(modelsID) $count] \
$sexBehaviour_SAA_obj(babyID)
# Free the memory and unset some variables.
SAA_Free $sexBehaviour_SAA_obj(babyID)
SAA_Free $sexBehaviour_SAA_obj(childExpr)
unset sexBehaviour_SAA_obj(babyID)
unset sexBehaviour_SAA_obj(childExpr)
}
}
incr count
}
sexBehaviourFree
}
# This procedure frees memory allocated for SAA objects.
proc sexBehaviourFree {} {
global sexBehaviour_SAA_obj
foreach item [array names sexBehaviour_SAA_obj] {
SAA_Free $sexBehaviour_SAA_obj($item)
}
unset sexBehaviour_SAA_obj
}
|
|
copyright Video-Collage Inc. |