Artifact
d0f68f21fb0e44bbe3f0a2ea60fec938efb8aac6
File
assets/Canvas3d1.2.1/demo/photocube.tcl
— part of check-in
[5735e8d93e]
at
2014-12-13 17:51:20
on branch trunk
— added another 3d canvas demo script
(user:
chw
size: 2322)
0000: 23 21 20 2f 62 69 6e 2f 73 68 0a 23 20 54 68 65 #! /bin/sh.# The
0010: 20 6e 65 78 74 20 6c 69 6e 65 20 72 65 73 74 61 next line resta
0020: 72 74 73 20 75 73 69 6e 67 20 74 63 6c 73 68 20 rts using tclsh
0030: 5c 0a 65 78 65 63 20 74 63 6c 73 68 20 22 24 30 \.exec tclsh "$0
0040: 22 20 24 7b 31 2b 22 24 40 22 7d 0a 0a 70 61 63 " ${1+"$@"}..pac
0050: 6b 61 67 65 20 72 65 71 75 69 72 65 20 54 6b 0a kage require Tk.
0060: 70 61 63 6b 61 67 65 20 72 65 71 75 69 72 65 20 package require
0070: 49 6d 67 0a 70 61 63 6b 61 67 65 20 72 65 71 75 Img.package requ
0080: 69 72 65 20 43 61 6e 76 61 73 33 64 0a 0a 77 6d ire Canvas3d..wm
0090: 20 61 74 74 72 69 62 75 74 65 73 20 2e 20 2d 66 attributes . -f
00a0: 75 6c 6c 73 63 72 65 65 6e 20 31 0a 63 61 6e 76 ullscreen 1.canv
00b0: 61 73 33 64 20 2e 77 31 0a 70 61 63 6b 20 2e 77 as3d .w1.pack .w
00c0: 31 20 2d 65 78 70 61 6e 64 20 79 65 73 20 2d 66 1 -expand yes -f
00d0: 69 6c 6c 20 62 6f 74 68 20 2d 73 69 64 65 20 6c ill both -side l
00e0: 65 66 74 0a 2e 77 31 20 63 6f 6e 66 69 67 75 72 eft..w1 configur
00f0: 65 20 2d 77 69 64 74 68 20 33 30 30 20 2d 68 65 e -width 300 -he
0100: 69 67 68 74 20 33 30 30 20 2d 62 61 63 6b 67 72 ight 300 -backgr
0110: 6f 75 6e 64 20 62 6c 61 63 6b 0a 0a 62 69 6e 64 ound black..bind
0120: 20 61 6c 6c 20 3c 42 72 65 61 6b 3e 20 65 78 69 all <Break> exi
0130: 74 0a 0a 23 20 43 61 6d 65 72 61 20 63 6f 6e 74 t..# Camera cont
0140: 72 6f 6c 0a 70 72 6f 63 20 54 20 7b 77 20 61 72 rol.proc T {w ar
0150: 67 73 7d 20 7b 0a 20 20 20 20 24 77 20 74 72 61 gs} {. $w tra
0160: 6e 73 66 6f 72 6d 20 2d 63 61 6d 65 72 61 20 74 nsform -camera t
0170: 79 70 65 28 6c 69 67 68 74 29 20 24 61 72 67 73 ype(light) $args
0180: 0a 20 20 20 20 24 77 20 64 65 6c 65 74 65 20 43 . $w delete C
0190: 61 6d 65 72 61 53 74 72 69 6e 67 0a 7d 0a 0a 23 ameraString.}..#
01a0: 20 4d 6f 75 73 65 20 63 6f 6e 74 72 6f 6c 0a 62 Mouse control.b
01b0: 69 6e 64 20 2e 77 31 20 3c 42 31 2d 4d 6f 74 69 ind .w1 <B1-Moti
01c0: 6f 6e 3e 20 7b 0a 20 20 20 20 73 65 74 20 72 79 on> {. set ry
01d0: 20 5b 65 78 70 72 20 33 36 30 2e 30 20 2a 20 28 [expr 360.0 * (
01e0: 25 79 20 20 2d 20 24 3a 3a 59 29 20 2f 20 5b 25 %y - $::Y) / [%
01f0: 57 20 63 67 65 74 20 2d 68 65 69 67 68 74 5d 5d W cget -height]]
0200: 0a 20 20 20 20 73 65 74 20 72 78 20 5b 65 78 70 . set rx [exp
0210: 72 20 33 36 30 2e 30 20 2a 20 28 25 78 20 20 2d r 360.0 * (%x -
0220: 20 24 3a 3a 58 29 20 2f 20 5b 25 57 20 63 67 65 $::X) / [%W cge
0230: 74 20 2d 77 69 64 74 68 5d 5d 0a 20 20 20 20 54 t -width]]. T
0240: 20 25 57 20 6f 72 62 69 74 75 70 20 24 72 79 20 %W orbitup $ry
0250: 6f 72 62 69 74 6c 65 66 74 20 24 72 78 0a 20 20 orbitleft $rx.
0260: 20 20 73 65 74 20 3a 3a 58 20 25 78 0a 20 20 20 set ::X %x.
0270: 20 73 65 74 20 3a 3a 59 20 25 79 0a 7d 0a 62 69 set ::Y %y.}.bi
0280: 6e 64 20 2e 77 31 20 3c 31 3e 20 7b 0a 20 20 20 nd .w1 <1> {.
0290: 20 73 65 74 20 3a 3a 58 20 25 78 0a 20 20 20 20 set ::X %x.
02a0: 73 65 74 20 3a 3a 59 20 25 79 0a 7d 0a 0a 62 69 set ::Y %y.}..bi
02b0: 6e 64 20 2e 77 31 20 3c 44 6f 75 62 6c 65 2d 31 nd .w1 <Double-1
02c0: 3e 20 7b 0a 20 20 20 20 2e 77 31 20 64 65 6c 65 > {. .w1 dele
02d0: 74 65 20 74 78 74 0a 20 20 20 20 69 6d 67 66 65 te txt. imgfe
02e0: 74 63 68 20 25 57 20 25 78 20 25 79 0a 7d 0a 0a tch %W %x %y.}..
02f0: 70 72 6f 63 20 69 6d 67 66 65 74 63 68 20 7b 77 proc imgfetch {w
0300: 20 78 20 79 7d 20 7b 0a 20 20 20 20 66 6f 72 65 x y} {. fore
0310: 61 63 68 20 69 64 20 5b 24 77 20 66 69 6e 64 20 ach id [$w find
0320: 2d 73 6f 72 74 62 79 64 65 70 74 68 20 76 69 65 -sortbydepth vie
0330: 77 70 6f 72 74 28 24 78 2c 24 79 29 5d 20 7b 0a wport($x,$y)] {.
0340: 09 73 65 74 20 74 61 67 20 5b 24 77 20 67 65 74 .set tag [$w get
0350: 74 61 67 20 24 69 64 5d 0a 09 69 66 20 7b 5b 73 tag $id]..if {[s
0360: 74 72 69 6e 67 20 6d 61 74 63 68 20 22 78 2a 22 tring match "x*"
0370: 20 24 74 61 67 5d 7d 20 7b 0a 09 20 20 20 20 73 $tag]} {.. s
0380: 65 74 20 3a 3a 54 41 47 20 5b 6c 69 6e 64 65 78 et ::TAG [lindex
0390: 20 24 74 61 67 20 30 5d 0a 09 20 20 20 20 62 6f $tag 0].. bo
03a0: 72 67 20 73 70 69 6e 6e 65 72 20 31 0a 09 20 20 rg spinner 1..
03b0: 20 20 62 6f 72 67 20 61 63 74 69 76 69 74 79 20 borg activity
03c0: 61 6e 64 72 6f 69 64 2e 6d 65 64 69 61 2e 61 63 android.media.ac
03d0: 74 69 6f 6e 2e 49 4d 41 47 45 5f 43 41 50 54 55 tion.IMAGE_CAPTU
03e0: 52 45 20 5c 0a 09 09 7b 7d 20 7b 7d 20 7b 7d 20 RE \...{} {} {}
03f0: 7b 7d 20 7b 7d 20 69 6d 67 63 62 0a 09 20 20 20 {} {} imgcb..
0400: 20 62 72 65 61 6b 0a 09 7d 0a 20 20 20 20 7d 0a break..}. }.
0410: 7d 0a 0a 70 72 6f 63 20 63 75 62 65 20 7b 77 20 }..proc cube {w
0420: 73 69 64 65 6c 65 6e 67 74 68 20 74 61 67 7d 20 sidelength tag}
0430: 7b 0a 20 20 73 65 74 20 70 20 5b 65 78 70 72 20 {. set p [expr
0440: 24 73 69 64 65 6c 65 6e 67 74 68 20 2f 20 32 2e $sidelength / 2.
0450: 30 5d 0a 20 20 73 65 74 20 6d 20 5b 65 78 70 72 0]. set m [expr
0460: 20 24 73 69 64 65 6c 65 6e 67 74 68 20 2f 20 2d $sidelength / -
0470: 32 2e 30 5d 0a 0a 20 20 24 77 20 63 72 65 61 74 2.0].. $w creat
0480: 65 20 70 6f 6c 79 67 6f 6e 20 5b 6c 69 73 74 20 e polygon [list
0490: 24 70 20 24 70 20 24 70 20 20 24 6d 20 24 70 20 $p $p $p $m $p
04a0: 24 70 20 20 24 6d 20 24 6d 20 24 70 20 20 24 70 $p $m $m $p $p
04b0: 20 24 6d 20 24 70 5d 20 2d 74 61 67 73 20 78 31 $m $p] -tags x1
04c0: 0a 20 20 24 77 20 63 72 65 61 74 65 20 70 6f 6c . $w create pol
04d0: 79 67 6f 6e 20 5b 6c 69 73 74 20 24 70 20 24 70 ygon [list $p $p
04e0: 20 24 6d 20 20 24 6d 20 24 70 20 24 6d 20 20 24 $m $m $p $m $
04f0: 6d 20 24 6d 20 24 6d 20 20 24 70 20 24 6d 20 24 m $m $m $p $m $
0500: 6d 5d 20 2d 74 61 67 73 20 78 32 0a 0a 20 20 24 m] -tags x2.. $
0510: 77 20 63 72 65 61 74 65 20 70 6f 6c 79 67 6f 6e w create polygon
0520: 20 5b 6c 69 73 74 20 24 70 20 24 70 20 24 70 20 [list $p $p $p
0530: 20 24 6d 20 24 70 20 24 70 20 20 24 6d 20 24 70 $m $p $p $m $p
0540: 20 24 6d 20 20 24 70 20 24 70 20 24 6d 5d 20 2d $m $p $p $m] -
0550: 74 61 67 73 20 78 33 0a 20 20 24 77 20 63 72 65 tags x3. $w cre
0560: 61 74 65 20 70 6f 6c 79 67 6f 6e 20 5b 6c 69 73 ate polygon [lis
0570: 74 20 24 70 20 24 6d 20 24 70 20 20 24 6d 20 24 t $p $m $p $m $
0580: 6d 20 24 70 20 20 24 6d 20 24 6d 20 24 6d 20 20 m $p $m $m $m
0590: 24 70 20 24 6d 20 24 6d 5d 20 2d 74 61 67 73 20 $p $m $m] -tags
05a0: 78 34 20 0a 0a 20 20 24 77 20 63 72 65 61 74 65 x4 .. $w create
05b0: 20 70 6f 6c 79 67 6f 6e 20 5b 6c 69 73 74 20 24 polygon [list $
05c0: 70 20 24 70 20 24 70 20 20 24 70 20 24 6d 20 24 p $p $p $p $m $
05d0: 70 20 20 24 70 20 24 6d 20 24 6d 20 20 24 70 20 p $p $m $m $p
05e0: 24 70 20 24 6d 5d 20 2d 74 61 67 73 20 78 35 20 $p $m] -tags x5
05f0: 0a 20 20 24 77 20 63 72 65 61 74 65 20 70 6f 6c . $w create pol
0600: 79 67 6f 6e 20 5b 6c 69 73 74 20 24 6d 20 24 70 ygon [list $m $p
0610: 20 24 70 20 20 24 6d 20 24 6d 20 24 70 20 20 24 $p $m $m $p $
0620: 6d 20 24 6d 20 24 6d 20 20 24 6d 20 24 70 20 24 m $m $m $m $p $
0630: 6d 5d 20 2d 74 61 67 73 20 78 36 0a 7d 0a 0a 63 m] -tags x6.}..c
0640: 75 62 65 20 2e 77 31 20 31 2e 30 20 63 75 62 65 ube .w1 1.0 cube
0650: 5f 6f 6e 65 0a 2e 77 31 20 63 72 65 61 74 65 20 _one..w1 create
0660: 6c 69 67 68 74 20 7b 30 2e 30 20 30 2e 30 20 33 light {0.0 0.0 3
0670: 2e 30 7d 0a 2e 77 31 20 74 72 61 6e 73 66 6f 72 .0}..w1 transfor
0680: 6d 20 2d 63 61 6d 65 72 61 20 6c 69 67 68 74 20 m -camera light
0690: 7b 6c 6f 6f 6b 61 74 20 61 6c 6c 7d 0a 0a 23 20 {lookat all}..#
06a0: 64 65 66 65 72 20 32 64 20 74 65 78 74 20 69 74 defer 2d text it
06b0: 65 6d 20 75 6e 74 69 6c 20 3c 43 6f 6e 66 69 67 em until <Config
06c0: 75 72 65 3e 20 6f 74 68 65 72 77 69 73 65 20 62 ure> otherwise b
06d0: 6f 6f 6d 21 20 6f 6e 20 73 6f 6d 65 20 64 65 76 oom! on some dev
06e0: 69 63 65 73 0a 62 69 6e 64 20 2e 77 31 20 3c 43 ices.bind .w1 <C
06f0: 6f 6e 66 69 67 75 72 65 3e 20 7b 0a 20 20 20 20 onfigure> {.
0700: 2e 77 31 20 63 72 65 61 74 65 20 74 65 78 74 20 .w1 create text
0710: 7b 30 20 30 7d 20 5c 0a 09 2d 74 65 78 74 20 22 {0 0} \..-text "
0720: 44 6f 75 62 6c 65 2d 74 61 70 20 6f 6e 20 66 61 Double-tap on fa
0730: 63 65 20 6f 66 20 63 75 62 65 20 74 6f 20 74 61 ce of cube to ta
0740: 6b 65 20 61 20 70 69 63 74 75 72 65 22 20 5c 0a ke a picture" \.
0750: 09 2d 61 6e 63 68 6f 72 20 6e 77 20 2d 66 6f 6e .-anchor nw -fon
0760: 74 20 7b 7b 44 65 6a 61 56 75 20 53 61 6e 73 7d t {{DejaVu Sans}
0770: 20 38 7d 20 2d 74 61 67 73 20 74 78 74 0a 20 20 8} -tags txt.
0780: 20 20 62 69 6e 64 20 2e 77 31 20 3c 43 6f 6e 66 bind .w1 <Conf
0790: 69 67 75 72 65 3e 20 7b 7d 0a 7d 0a 0a 70 72 6f igure> {}.}..pro
07a0: 63 20 69 6d 67 63 62 20 7b 72 65 74 63 6f 64 65 c imgcb {retcode
07b0: 20 61 63 74 69 6f 6e 20 75 72 69 20 6d 69 6d 65 action uri mime
07c0: 74 79 70 65 20 63 61 74 65 67 6f 72 69 65 73 20 type categories
07d0: 64 61 74 61 7d 20 7b 0a 20 20 20 20 69 66 20 7b data} {. if {
07e0: 24 72 65 74 63 6f 64 65 20 3d 3d 20 2d 31 7d 20 $retcode == -1}
07f0: 7b 0a 09 23 20 53 55 43 43 45 53 53 0a 09 61 72 {..# SUCCESS..ar
0800: 72 61 79 20 73 65 74 20 72 65 73 75 6c 74 20 24 ray set result $
0810: 64 61 74 61 0a 09 69 66 20 7b 5b 69 6e 66 6f 20 data..if {[info
0820: 65 78 69 73 74 73 20 72 65 73 75 6c 74 28 64 61 exists result(da
0830: 74 61 29 5d 7d 20 7b 0a 09 20 20 20 20 69 6d 61 ta)]} {.. ima
0840: 67 65 20 63 72 65 61 74 65 20 70 68 6f 74 6f 20 ge create photo
0850: 70 31 20 2d 64 61 74 61 20 24 72 65 73 75 6c 74 p1 -data $result
0860: 28 64 61 74 61 29 0a 09 20 20 20 20 2e 77 31 20 (data).. .w1
0870: 69 74 65 6d 63 6f 6e 66 69 67 75 72 65 20 24 3a itemconfigure $:
0880: 3a 54 41 47 20 2d 74 65 78 69 6d 61 67 65 20 7b :TAG -teximage {
0890: 7d 20 2d 73 6d 6f 6f 74 68 20 31 0a 09 20 20 20 } -smooth 1..
08a0: 20 2e 77 31 20 69 74 65 6d 63 6f 6e 66 69 67 75 .w1 itemconfigu
08b0: 72 65 20 24 3a 3a 54 41 47 20 2d 74 65 78 69 6d re $::TAG -texim
08c0: 61 67 65 20 70 31 20 2d 73 6d 6f 6f 74 68 20 31 age p1 -smooth 1
08d0: 0a 09 20 20 20 20 69 6d 61 67 65 20 64 65 6c 65 .. image dele
08e0: 74 65 20 70 31 0a 09 7d 0a 20 20 20 20 7d 0a 20 te p1..}. }.
08f0: 20 20 20 61 66 74 65 72 20 69 64 6c 65 20 7b 62 after idle {b
0900: 6f 72 67 20 73 70 69 6e 6e 65 72 20 30 7d 0a 7d org spinner 0}.}
0910: 0a 0a ..