newlispfanclub.alh.net

Code: Select all

(tk "load C:/tcl/bin/ivrs.dll VRS")

(tk "if {[winfo exists .dw] == 1} {destroy .dw}")
(tk "toplevel .dw -background lightblue")

;# camera settings
(tk "global mview; set mview [new SceneThing]")
(tk "global mview; $mview append [new Camera {0 3 2} {0 0 0}  60]")

;# main thing
(tk "global mscene mview; set mscene [new SceneThing $mview]")

;# thing with floor
(tk "global menviron mscene; set menviron [new SceneThing $mscene]")

;# lightsources 
(tk "global mscene; $mscene append [new DistantLight { -0.1 0 -1 } {1 1 1 1} 1.0 0.9]")
(tk "global mscene; $mscene append [new PointLight { 1 2 1 } {1 1 1 1} 1.0  0.8]")

;# thing with snowman
(tk "global msnowman mscene; set msnowman [new SceneThing $mscene]")

(tk "global mbody_ msnowman; set mbody_ [new SceneThing $msnowman]")
(tk "global mbody_ ;$mbody_ append [new ColorAttribute 1 1 1 ]")
(tk "global mbody_ ;$mbody_ append [new Scaling {1 0.9 1 }]")
(tk "global mbody_ ;$mbody_ append [new FaceStyle FaceStyle::Filled FaceStyle::Culled]")
(tk "global mbody_ ;$mbody_ append [new Sphere 0.5  {0 0.43 0}]")
(tk "global mbody_ ;$mbody_ append [new Sphere 0.35 {0 1.1 0}]")
(tk "global mbody_ ;$mbody_ append [new Sphere 0.25 {0 1.5 0}]")
(tk "global mbody_ ;$mbody_ append [new ColorAttribute { 0.7 0.7 1.0 1 }]")
(tk "global mbody_ ;$mbody_ append [new Box {-1 -0.08 -1 } { 1 0 1 }]")

(tk "global mface msnowman; set mface [new SceneThing $msnowman]")
(tk "global meyes_ mface; set meyes_ [new SceneThing $mface]")
(tk "global meyes_ ; $meyes_ append [new ColorAttribute 0.1 0.1 1.0]")
(tk "global meyes_ ; $meyes_ append [new Sphere 0.04  {-0.1 1.5 0.12}]")
(tk "global meyes_ ; $meyes_ append [new Sphere 0.04  { 0.1 1.5 0.12}]")

(tk "global mnose_ mface; set mnose_ [new SceneThing $mface]")
(tk "global mnose_ ; $mnose_ append [new ColorAttribute 1 0.5 0]")
(tk "global mnose_ ; $mnose_ append [new Cone {0 1.55 0.2} {0 1.35 0.22} 0.00  0.04]")

(tk "global mmouth_ mface; set mmouth_ [ new SceneThing $mface]")
(tk "global mmouth_ ; $mmouth_ append [new ColorAttribute 0.9 0.9 0]")
(tk "global mmouth_ ; $mmouth_ append [new Cylinder {-0.12 1.33 0.21} {.12 1.33 0.21}  0.05]")

;# store a few shapes so we can identify them later
(tk "global mbody_ ;[$mbody_ object 3]  setObjectName  {lower part}")
(tk "global mbody_ ;[$mbody_ object 4]  setObjectName  {middle part}")
(tk "global mbody_ ;[$mbody_ object 5]  setObjectName  {upper part}")
(tk "global mbody_ ;[$mbody_ object 7]  setObjectName  {box}")
(tk "global meyes_ ;[$meyes_ object 1]  setObjectName  {left eye}")
(tk "global meyes_ ;[$meyes_ object 2]  setObjectName  {right eye}")
(tk "global mnose_ ;[$mnose_ object 1]  setObjectName  {nose}")
(tk "global mmouth_ ;[$mmouth_ object 1]  setObjectName  {mouth}")

 
;# MENUS

(tk "frame .dw.mbar -border 1 -relief raised")
(tk "menubutton .dw.mbar.file -text File -menu .dw.mbar.file.m")

(tk "menu .dw.mbar.file.m")
(tk ".dw.mbar.file.m add command -label {quit} -command {destroy .; VRS cleanup}")
(tk "pack .dw.mbar.file -side left")
(tk "pack .dw.mbar -fill x")

;# build a 3D canvas
(tk "global canvas ;set canvas [ new TclCanvas .dw.toto 256  256 ]")
(tk "pack .dw.toto")

;# connect geometry graphs to the canvas
(tk "global canvas mview; $canvas append $mview")
(tk "global canvas mscene; $canvas append [new TrackBall $mscene]")

;# STATUS AREA
(tk "frame .dw.state -relief sunken -border 2")
(tk "global statustext; label .dw.state.msg -textvariable statustext -justify left -anchor w")
(tk "pack .dw.state -side bottom -fill x")
(tk "pack .dw.state.msg -side left -fill x")