Tcl/Tk
frenzy
I'm new to this group. Infact, I'm new to Tcl/Tk. Just thought I'd
share my first Tcl script. If your like me and remember the good old
days of computer graphics, the demoscene, etc. then you will like
this. An oldskool graphics intro with 3d starfield, 3d spinning cube,
scroller and last but by no means least some copper bars.
If you run this be sure to change the top line to point to your
wish.exe.
cheers,
Paul.
frenzy
And like a wally I forgot to attach the Tcl Code :-)
cheers,
Paul.
----snip----
#!S:/Tools_Main_Deployment/dependencies/tcltk/8.4.3/install/hint/bin/wish84
#############################################
##
## TclVision Intro
##
##
##
## - 3d graphics technology
## - space simulation featuring realistic star movements ;-)
##
## author: paul_...@mentor.com
##
#########################
##############################################
# globals
##############################################
set PI 3.14159
# starfield globals
set NUMSTARS 40
set STARSPEED 10
# cube
set xrot 0.0
set yrot 0.0
set xpos 0.0
set zoom 0.0
# cosmos
set COSMOS_PTS 300
##############################################
# vertex management
##############################################
# create a vertex
proc addVertexToList {vertexList x y z} {
upvar $vertexList v
set v([array size v]) "$x $y $z"
}
proc createVertex {vertex x y z} {
upvar $vertex v
set v "$x $y $z"
}
proc addQuadToList {faceList i1 i2 i3 i4} {
upvar $faceList faces
set faces([array size faces]) "$i1 $i2 $i3 $i4"
}
# get a vertex component
proc getVertex {vertex xyzw} {
upvar $vertex v
switch $xyzw {
X {return [lindex $v 0]}
Y {return [lindex $v 1]}
Z {return [lindex $v 2]}
W {return [lindex $v 3]}
}
}
##############################################
# matrix/vector maths
##############################################
proc zeroMatrix {matrix} {
upvar $matrix m
set m(Xx) 0.0; set m(Yx) 0.0; set m(Zx) 0.0
set m(Xy) 0.0; set m(Yy) 0.0; set m(Zy) 0.0
set m(Xz) 0.0; set m(Yz) 0.0; set m(Zz) 0.0
}
proc identityMatrix {matrix} {
upvar $matrix m
set m(Xx) 1.0; set m(Yx) 0.0; set m(Zx) 0.0
set m(Xy) 0.0; set m(Yy) 1.0; set m(Zy) 0.0
set m(Xz) 0.0; set m(Yz) 0.0; set m(Zz) 1.0
}
# m = a*b, warning NOT COMMUTATIVE
# unrolled for eliteness
proc mulMatrix {amat bmat mmat} {
upvar $amat a
upvar $bmat b
upvar $mmat m
set m(Xx) [expr $a(Xx)*$b(Xx) + $a(Xy)*$b(Yx) + $a(Xz)*$b(Zx)]
set m(Yx) [expr $a(Yx)*$b(Xx) + $a(Yy)*$b(Yx) + $a(Yz)*$b(Zx)]
set m(Zx) [expr $a(Zx)*$b(Xx) + $a(Zy)*$b(Yx) + $a(Zz)*$b(Zx)]
set m(Xy) [expr $a(Xx)*$b(Xy) + $a(Xy)*$b(Yy) + $a(Xz)*$b(Zy)]
set m(Yy) [expr $a(Yx)*$b(Xy) + $a(Yy)*$b(Yy) + $a(Yz)*$b(Zy)]
set m(Zy) [expr $a(Zx)*$b(Xy) + $a(Zy)*$b(Yy) + $a(Zz)*$b(Zy)]
set m(Xz) [expr $a(Xx)*$b(Xz) + $a(Xy)*$b(Yz) + $a(Xz)*$b(Zz)]
set m(Yz) [expr $a(Yx)*$b(Xz) + $a(Yy)*$b(Yz) + $a(Yz)*$b(Zz)]
set m(Zz) [expr $a(Zx)*$b(Xz) + $a(Zy)*$b(Yz) + $a(Zz)*$b(Zz)]
}
# build matrix for a rotation around x-axis
proc buildXRotationMatrix {xan mmat} {
global PI
upvar $mmat m
set xa [expr (($xan * $PI) / 180.0)]
set m(Xx) 1.0
set m(Xy) 0.0
set m(Xz) 0.0
set m(Yx) 0.0
set m(Yy) [expr cos($xa)]
set m(Yz) [expr -sin($xa)]
set m(Zx) 0.0
set m(Zy) [expr sin($xa)]
set m(Zz) [expr cos($xa)]
}
proc buildYRotationMatrix {yan mmat} {
global PI
upvar $mmat m
set ya [expr (($yan * $PI) / 180.0)]
set m(Xx) [expr cos($ya)]
set m(Xy) 0.0
set m(Xz) [expr sin($ya)]
set m(Yx) 0.0
set m(Yy) 1.0
set m(Yz) 0.0
set m(Zx) [expr -sin($ya)]
set m(Zy) 0.0
set m(Zz) [expr cos($ya)]
}
proc transformVertexByMatrix {vertIn matrix vertOut X Y Z} {
upvar $vertIn vIn
upvar $matrix m
upvar $vertOut vOut
set x [getVertex vIn X]
set y [getVertex vIn Y]
set z [getVertex vIn Z]
set xt [expr $x*$m(Xx) + $y*$m(Xy) + $z*$m(Xz) + $X]
set yt [expr $x*$m(Yx) + $y*$m(Yy) + $z*$m(Yz) + $Y]
set zt [expr $x*$m(Zx) + $y*$m(Zy) + $z*$m(Zz) + $Z]
set vOut "$xt $yt $zt"
}
proc transformVertexList {vertsIn matrix vertsOut X Y Z} {
upvar $vertsIn vIn
upvar $vertsOut vOut
upvar $matrix m
for {set i 0} {$i < [array size vIn]} {incr i} {
transformVertexByMatrix vIn($i) m vOut($i) $X $Y $Z
}
}
proc projectVertexList {vertsIn vertsOut X Y SX SY} {
upvar $vertsIn vIn
upvar $vertsOut vOut
for {set i 0} {$i < [array size vIn]} {incr i} {
set x [getVertex vIn($i) X]
set y [getVertex vIn($i) Y]
set z [getVertex vIn($i) Z]
if {$z > 0.0} {
set xt [expr (($x*$SX)/$z) + $X]
set yt [expr (($y*$SY)/$z) + $Y]
set vOut($i) "$xt $yt"
} else {
set vOut($i) "0.0 0.0"
}
}
}
##############################################
# Rendering procedures
##############################################
canvas .screen -width 640 -height 480 -background black
pack .screen -fill both -expand true
# render a list of quads
# we use cross product to determine face visability
proc renderQuadList {vertices quadList} {
upvar $vertices verts
upvar $quadList faces
for {set i 0} {$i < [array size faces]} {incr i} {
set i1 [getVertex faces($i) X]
set i2 [getVertex faces($i) Y]
set i3 [getVertex faces($i) Z]
set i4 [getVertex faces($i) W]
set x1 [getVertex verts($i1) X]
set y1 [getVertex verts($i1) Y]
set x2 [getVertex verts($i2) X]
set y2 [getVertex verts($i2) Y]
set x3 [getVertex verts($i3) X]
set y3 [getVertex verts($i3) Y]
set x4 [getVertex verts($i4) X]
set y4 [getVertex verts($i4) Y]
set Ux [expr $x2 - $x1]
set Uy [expr $y2 - $y1]
set Wx [expr $x4 - $x1]
set Wy [expr $y4 - $y1]
set crossProd [expr $Ux*$Wy - $Uy*$Wx]
if {$crossProd <= 0.0} {
set colour [expr $i%6]
switch $colour {
0 {set colour red}
1 {set colour green}
2 {set colour blue}
3 {set colour yellow}
4 {set colour pink}
5 {set colour plum}
}
.screen create polygon $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4 -fill
$colour -tag polysoup
}
}
}
##############################################
# colour stuff
##############################################
proc getColourString {r g b} {
set red [format %2x [expr int($r)]]
set green [format %2x [expr int($g)]]
set blue [format %2x [expr int($b)]]
set colourStr "#$red$green$blue"
return $colourStr
}
##################################################################
#
# EFFECT CODE
#
##################################################################
#################################################################
#
# oldskool bars
#
#################################################################
proc drawShadedBar {y h r g b} {
set halfH [expr $h/2.0]
set colourStepR [expr $r / $halfH]
set colourStepG [expr $g / $halfH]
set colourStepB [expr $b / $halfH]
set r 0
set g 0
set b 0
for {set i 0} {$i < $halfH} {incr i} {
.screen create line 0 $y 640 $y -fill [getColourString $r $g $b]
-tag polysoup
set r [expr $r + $colourStepR]
set g [expr $g + $colourStepG]
set b [expr $b + $colourStepB]
incr y
}
for {set i 0} {$i < $halfH} {incr i} {
.screen create line 0 $y 640 $y -fill [getColourString $r $g $b]
-tag polysoup
set r [expr $r - $colourStepR]
set g [expr $g - $colourStepG]
set b [expr $b - $colourStepB]
incr y
}
}
set barPos 0
proc drawBars {} {
global barPos
set pos $barPos
drawShadedBar [expr int([expr 70.0 * sin($pos) + 230.0])] 20 255.0
0.0 0.0
set pos [expr $pos + 0.25]
drawShadedBar [expr int([expr 70.0 * sin($pos) + 230.0])] 20 255.0
0.0 0.0
set pos [expr $pos + 0.25]
drawShadedBar [expr int([expr 70.0 * sin($pos) + 230.0])] 20 255.0
0.0 0.0
set pos [expr $pos + 0.25]
drawShadedBar [expr int([expr 70.0 * sin($pos) + 230.0])] 20 255.0
0.0 0.0
set pos [expr $pos + 0.25]
drawShadedBar [expr int([expr 70.0 * sin($pos) + 230.0])] 20 255.0
0.0 0.0
set barPos [expr $barPos + 0.05]
}
#################################################################
#
# cube stuff!
#
#################################################################
# define our cube object vertices
addVertexToList vertices -100.0 100.0 -100.0
addVertexToList vertices 100.0 100.0 -100.0
addVertexToList vertices 100.0 -100.0 -100.0
addVertexToList vertices -100.0 -100.0 -100.0
addVertexToList vertices -100.0 100.0 100.0
addVertexToList vertices 100.0 100.0 100.0
addVertexToList vertices 100.0 -100.0 100.0
addVertexToList vertices -100.0 -100.0 100.0
# define our face info for cube
addQuadToList faces 0 1 2 3
addQuadToList faces 4 0 3 7
addQuadToList faces 5 4 7 6
addQuadToList faces 1 5 6 2
addQuadToList faces 4 5 1 0
addQuadToList faces 3 2 6 7
proc renderCube {} {
global xrot
global yrot
global xpos
global zoom
global vertices
global faces
set zpos [expr (150.0*sin($zoom) + 450.0)]
buildXRotationMatrix $xrot xRotMatrix
buildYRotationMatrix $yrot yRotMatrix
mulMatrix xRotMatrix yRotMatrix rotMatrix
transformVertexList vertices rotMatrix tVertices $xpos 0.0 $zpos
projectVertexList tVertices sVertices 320.0 240.0 256.0 256.0
renderQuadList sVertices faces
set xrot [expr $xrot + 4.0]
set yrot [expr $yrot + 6.0]
if {$xpos < 0.0} {
set xpos [expr $xpos + 8.0]
}
set zoom [expr $zoom + 0.2]
}
#################################################################
#
# starfield stuff
#
#################################################################
# generate some random stars
proc setupStars {starList} {
global NUMSTARS
upvar $starList stars
for {set i 0} {$i < $NUMSTARS} {incr i} {
set x [expr rand()]
set y [expr rand()]
set z [expr rand()]
addVertexToList stars [expr (1.0-($x*2.0)) * 320.0] \
[expr (1.0-($y*2.0)) * 240.0] \
[expr ($z * 1000.0) + 1.0]
}
}
# update star positions and kill/respawn any if needed
# and render
proc updateStars {starList} {
global NUMSTARS
global STARSPEED
upvar $starList stars
for {set i 0} {$i < $NUMSTARS} {incr i} {
set x [getVertex stars($i) X]
set y [getVertex stars($i) Y]
set z [getVertex stars($i) Z]
if {$z > 0.0} {
set z [expr $z - $STARSPEED]
} else {
set xr [expr rand()]
set yr [expr rand()]
set zr [expr rand()]
set x [expr (1.0-($xr*2.0)) * 320.0]
set y [expr (1.0-($yr*2.0)) * 240.0]
set z [expr ($zr*1000.0)+1.0]
}
set stars($i) "$x $y $z"
set xt [expr (($x*256.0)/$z) + 320.0]
set yt [expr (($y*256.0)/$z) + 240.0]
set depthColour [expr 255.0 - (($z*0.001)*255.0)]
set colourStr [getColourString $depthColour $depthColour
$depthColour]
.screen create rect [expr $xt-2] [expr $yt-2] [expr $xt+2] [expr
$yt+2] -fill $colourStr -tag polysoup
}
}
#################################################################
#
# scrollText
#
#################################################################
set scrollTextPos 0
proc createScrollText {scrollText} {
.screen create text 2600 400 -font "courier" -fill Red -text
$scrollText -tag scrollTextTag
}
proc scrollText {} {
.screen move scrollTextTag -4 0
}
##########################################################################################
proc refresh {} {
update idletasks
pack .screen -fill both -expand true
}
##############################################
# debug functions
##############################################
proc printVertex {vertex} {
upvar $vertex v
puts "[getVertex v X] [getVertex v Y] [getVertex v Z]"
}
proc printVertices {vertices} {
upvar $vertices verts
for {set i 0} {$i < [array size verts]} {incr i} {
puts $verts($i)
}
}
proc printMatrix {matrix} {
upvar $matrix m
puts "$m(Xx) $m(Yx) $m(Zx)"
puts "$m(Xy) $m(Yy) $m(Zy)"
puts "$m(Xz) $m(Yz) $m(Zz)"
}
####################################################
#
#
# MAIN
#
#
#
#
wm title . "TclVision Proudly Presents....."
setupStars stars
createScrollText "an oldskool intro written purely in Tcl..... oh
yes.. Tcl is your friend.... all i need to do \
now is to get a good looking font, create each character individually
and then move them on a sinewave to make \
really good looking scroll text. hrmmmm i wonder.. maybe i could even
rotate the text characters.. somehow i \
dont think so.. maybe next time we will have texture mapping going on
in the cube......................"
while 1 {
.screen delete polysoup
updateStars stars
drawBars
renderCube
scrollText
refresh
}
Michael Schlenker
> Hi,
>
> I'm new to this group. Infact, I'm new to Tcl/Tk. Just thought I'd
> share my first Tcl script. If your like me and remember the good old
> days of computer graphics, the demoscene, etc. then you will like
> this. An oldskool graphics intro with 3d starfield, 3d spinning cube,
> scroller and last but by no means least some copper bars.
>
> If you run this be sure to change the top line to point to your
> wish.exe.
>
> And like a wally I forgot to attach the Tcl Code :-)
One Hint: Brace your exprs. [expr {$x*$y}] is much faster than [expr $x*$y]
Michael
Bryan Oakley
You'll get better performance if you put braces around your expressions
(eg: [expr {$foo*$bar}] vs. [expr $foo*$bar])
This idiom is a bit too old school:
while 1 {
...
}
Wish is already running in a big loop called the event loop. The general
way to animate while still allowing other events to occur is to do
something like this:
proc animate {timeout} {
<do work to draw a frame of animation>
after $timeout [list animate $timeout]
}
animate 100
The graphics are nice, though.
Donald Arseneau
> share my first Tcl script.
Very nice. First?? Really?
I did have to change to "[format %2.2x" in getColourString.
Donald Arseneau as...@triumf.ca
Andreas Kupries
paul_...@mentor.com (frenzy) writes:
> Hi,
>
> I'm new to this group. Infact, I'm new to Tcl/Tk. Just thought I'd
> share my first Tcl script. If your like me and remember the good old
> days of computer graphics, the demoscene, etc. then you will like
> this. An oldskool graphics intro with 3d starfield, 3d spinning cube,
> scroller and last but by no means least some copper bars.
Paul, given the above I believe that you will be interested in
<URL:http://wiki.tcl.tk/8337>
(Category Whizlet of the Tcler's Wiki)
and
<URL:http://mini.net/tcl/references/496!>
Note: The ! is part of the url.
--
Sincerely,
Andreas Kupries <akup...@shaw.ca>
Developer @ <http://www.activestate.com/>
Private <http://www.purl.org/NET/akupries/>
-------------------------------------------------------------------------------
}
John Seal
Donald Arseneau <as...@triumf.ca> wrote:
> I did have to change to "[format %2.2x" in getColourString.
I can't get it to run with Tcl/Tk 8.4.5 under Mac OS X 10.3.3 on a G4
533 MHz, even after joining split lines and making the above change.
Wish just hangs.
se...@fishpool.com
> Hi,
>
> I'm new to this group. Infact, I'm new to Tcl/Tk. Just thought I'd
> share my first Tcl script. If your like me and remember the good old
> days of computer graphics, the demoscene, etc. then you will like
> this. An oldskool graphics intro with 3d starfield, 3d spinning cube,
> scroller and last but by no means least some copper bars.
Heh, cool. You may want to brace your [expr]s to make things faster (and
safer).
Try this for interest:
http://www.altparty.org/archive/invi.tcl
That's based on a friend's perl intro and should run in a vt102 terminal. I
believe it was the first ever actual intro made in pure Tcl. We're
considering setting up a scriptscene site for people making demos with
script languages :-)
You may also be interested in liboil:
http://people.fishpool.fi/~setok/sleberEid/liboil/
(damnit, should finally release a new version of that!)