#!/home/fellowsd/bin/wish8.0 set tcl_precision 17; # Full precision please! proc nextrand seed { expr {(16807.0*$seed)-2147483647.0*floor(16807.0*$seed/2147483647.0)} } proc srand seed { global theSeed set theSeed [nextrand $seed] } # Magic! The default range of integers is from 0 to 99 proc rand {{range 100}} { global theSeed set theSeed [nextrand $theSeed] expr {int(($theSeed/2147483647.0)*$range)} } # Initialise from the clock. This is not as good as I would like, but # it will do... srand [clock seconds]; rand; rand; rand # ---------------------------------------------------------------------- # Load the images array set imagedata { ... } foreach dir {n s e w} { image create bitmap frog-$dir \ -data $imagedata(frog,$dir,image) -foreground green4 \ -maskdata $imagedata(frog,$dir,mask) -background black } foreach {i f b} { car black grey25 bus red black lorry yellow black log1 brown black log2 brown black } { image create bitmap $i -data $imagedata($i,image) -foreground $f \ -maskdata $imagedata($i,mask) -background $b } foreach {i f} { reeds green3 sand yellow w1 skyblue w2 skyblue w3 skyblue w4 skyblue bullet black } { image create bitmap $i -data $imagedata($i,image) -foreground $f } foreach {ib c f b} { croc 4 darkolivegreen black } { for {set i 1} {$i<=$c} {incr i} { image create bitmap $ib-$i \ -data $imagedata($ib,$i,image) -foreground $f \ -maskdata $imagedata($ib,$i,mask) -background $b } } foreach d {e w} { image create bitmap heron-$d \ -data $imagedata(heron,$d,image) -foreground grey45 \ -maskdata $imagedata(heron,$d,mask) -background grey15 } # ---------------------------------------------------------------------- # I would like to say something like: # [eval .c find overlapping [.c bbox frog] && withtag obstacle] # or # [.c find closest $x $y 10 && withtag obstacle] proc listfrogtags {} { set t {nothing} foreach id [eval .c find overlapping [.c bbox frog]] { append t " [.c gettags $id]" } return $t } proc listspottags {x y} { set t {nothing} foreach id [.c find overlapping \ [expr $x-10] [expr $y-10] [expr $x+10] [expr $y+10]] { append t " [.c gettags $id]" } return $t } # ---------------------------------------------------------------------- proc movetraffic {y r tag d t} { global after if {$d>0} { .c move $tag 5 0 if {![string match *$tag* [listspottags 0 $y]] && [rand $r]<1} { if {[catch { .c create image -30 $y -image $tag -tags $tag }]} { .c create rectangle -62 [expr $y-22] 2 [expr $y+22] \ -outline red -fill yellow -tags $tag } } eval .c delete [.c find enclosed 251 0 500 450] } else { .c move $tag -5 0 if {![string match *$tag* [listspottags 250 $y]] && [rand $r]<1} { if {[catch { .c create image 280 $y -image $tag -tags $tag }]} { .c create rectangle 312 [expr $y-22] 248 [expr $y+22] \ -outline red -fill yellow -tags $tag } } eval .c delete [.c find enclosed -1 0 -250 450] } if {[string match *$tag* [listfrogtags]]} { die $tag "Splat! Roadkill..." } set after($tag) [after $t movetraffic $y $r $tag $d $t] } proc moveheron {r d t dn} { global after if {[rand $r]<1} { if {[string match *heron* [listspottags 0 225]]} { set d 5 set dn e } elseif {[string match *heron* [listspottags 250 225]]} { set d -5 set dn w } .c move heron $d 0 .c itemconf heron -image heron-$dn } if {[string match *heron* [listfrogtags]]} { die heron "Eaten by the heron! " } set after(heron) [after $t moveheron $r $d $t $dn] } proc movelog {y r tag d t {ani 0} {c 1} {map {xyzzy}}} { global after if {$d>0} { if {[string match *$tag* [listfrogtags]]} {.c move frog 5 0} .c move $tag 5 0 if {![string match *$tag* [listspottags 0 $y]] && [rand $r]<1} { if {[catch { .c lower [.c create image -30 $y -image [lindex $map 0] -tags "$tag $tag-anim"] frog }]} { .c lower [.c create rectangle -62 [expr $y-22] 2 [expr $y+22] \ -outline black -fill brown -tags $tag] frog } } eval .c delete [.c find enclosed 251 0 500 450] } else { if {[string match *$tag* [listfrogtags]]} {.c move frog -5 0} .c move $tag -5 0 if {![string match *$tag* [listspottags 250 $y]] && [rand $r]<1} { if {[catch { .c lower [.c create image 280 $y -image [lindex $map 0] -tags "$tag $tag-anim"] frog }]} { .c lower [.c create rectangle 312 [expr $y-22] \ 248 [expr $y+22] -outline black -fill brown \ -tags $tag] frog } } eval .c delete [.c find enclosed -1 0 -250 450] } .c itemconf $tag-anim -image [lindex $map $ani] foreach {x1 y1 x2 y2} [.c bbox frog] {break} if {$x1<0} { die left "Drowned..." } elseif {$x2>250} { die right "Drowned..." } incr ani if {$ani>=$c} {set ani 0} set after($tag) [after $t [list movelog $y $r $tag $d $t $ani $c $map]] } # ---------------------------------------------------------------------- proc movefrog {dir dx dy} { .c move frog $dx $dy .c itemconf frog -image frog-$dir foreach {x1 y1 x2 y2} [.c bbox frog] {break} if {$x1<0 || $y1<0 || $x2>250 || $y2>450} { .c move frog [expr -$dx] [expr -$dy] } switch -glob [listfrogtags] { *car* { die car "Splat! Roadkill..." } *bus* { die bus "Splat! Roadkill..." } *lorry* { die lorry "Splat! Roadkill..." } *croc* - *log* { #ignore the water when on a log } *water* { die water "Drowned..." } *heron* { die heron "Eaten by the heron! " } *win* { die winner "You win! " } } } # ---------------------------------------------------------------------- proc animatewater {t {stage 1}} { global after .c itemconf aniwater -image w$stage .c move aniwater 5 0 foreach item [.c find enclosed 250 0 300 450] { if {[string match *aniwater* [.c gettags $item]]} { .c move $item -265 0 } } incr stage; if {$stage>4} {set stage 1} set after(aniwater) [after $t animatewater $t $stage] } # ---------------------------------------------------------------------- proc die {tag string} { global after # puts $string focus . foreach {k id} [array get after] {after cancel $id} unset after switch $tag { winner { set id [.c create text 125 225 -font *Adobe*Helvetica*Bold*O*240* \ -text $string -fill red] eval .c create rectangle [.c bbox $id] -outline blue -fill yellow } default { set id [.c create text 125 225 -font *Adobe*Helvetica*Bold*O*240* \ -text $string -fill white] eval .c create rectangle [.c bbox $id] -outline white -fill black } } .c raise $id after 5000 init restart return -code return "exit the caller!" } # ---------------------------------------------------------------------- proc init {action} { switch $action { clear { # clear anything previously there global after .c delete all foreach {k id} [array get after] {after cancel $id} foreach b [bind .c] {bind .c $b {}} } scene { # set up the display foreach {y d c t} { 0 50 green3 win 50 150 blue2 water 200 50 green3 {} 250 150 grey50 {} 400 50 green3 {} } { .c create rectangle 0 $y 250 [expr $y+$d] -outline {} \ -fill $c -tags $t } .c create rectangle 0 297 250 299 -outline {} -fill white .c create rectangle 0 301 250 303 -outline {} -fill white for {set x 5} {$x<250} {incr x 30} { .c create rectangle $x 349 [expr $x+20] 351 \ -outline {} -fill white } .c create rectangle 0 247 250 251 -outline {} -fill grey50 .c create rectangle 0 399 250 403 -outline {} -fill grey50 for {set x 1} {$x<250} {incr x 10} { .c create rectangle $x 247 [expr $x+9] 251 \ -outline {} -fill grey85 .c create rectangle $x 399 [expr $x+9] 403 \ -outline {} -fill grey85 } for {set x 7} {$x<259} {incr x 16} { .c create image $x 48 -image sand -tags sand .c create image $x 193 -image reeds -tags reeds } .c lower sand; .c raise sand water foreach {x y} {35 75 50 175 106 125 161 175 177 75 222 125} { .c create image $x $y -image w1 -tags aniwater } .c lower aniwater; .c raise aniwater water # create the frog .c lower [.c create image 125 425 -image frog-n -tags frog] reeds # start the traffic movetraffic 275 30 car -1 25 movetraffic 325 40 bus 1 50 movetraffic 375 50 lorry 1 75 # start the heron .c create image 35 225 -image heron-e -tags heron moveheron 4 5 100 e # start the logs and 'gators movelog 75 60 log1 1 80 0 1 log1 movelog 125 70 croc -1 100 0 10 { croc-1 croc-1 croc-1 croc-1 croc-1 croc-2 croc-2 croc-3 croc-4 croc-4 } movelog 175 80 log2 1 70 0 1 log2 # start the background animations animatewater 250 } instructions { frame .i;lower .i grid .i -row 0 -column 0 if {[info tclversion] < 8.0} { text .i.t -background white -width 20 -height 6 -wrap word -cursor {} } else { text .i.t -background white -width 30 -height 6 -wrap word -cursor {} } pack .i.t -fill x -expand 1 -side top .i.t tag conf head -font *Adobe*Helvetica*Bold*O*240* \ -justify center -spacing1 2 -spacing3 2 -foreground red3 .i.t tag conf body -font *Adobe*Times*Medium*R*140* \ -justify left -spacing1 2 -spacing2 1 -spacing3 2 \ -lmargin1 22 -lmargin2 3 -rmargin 3 -foreground black .i.t insert end "Frogger!\n" head .i.t insert end "Get your frog across the busy road and river any way you can! Don't forget that:\n" body .i.t insert end " Drivers love to squash frogs, as roadkill forms a major part of their diet,\n" body .i.t insert end " Herons love to eat frogs, especially with ketchup,\n" body .i.t insert end " You can travel on the back of a crocodile as well as on a log, though I don't know why the crocs don't eat the frogs, and\n" body .i.t insert end " Going off the edge of the screen is fatal too...\n" body foreach l {3 4 5 6} { .i.t window create $l.0 -create \ [list label .i.t.$l -image bullet -background white] } for {set h 7} {[.i.t dlineinfo end-1c] == ""} {incr h} { .i.t conf -height $h update idletasks } .i.t conf -state disabled button .i.dismiss -text "OK! Play the game..." \ -command {destroy .i;init motion} pack .i.dismiss -fill x -expand 1 -side top update idletasks raise .i #tkwait window .i } motion { # allow the frog to move... focus .c bind .c {movefrog w -25 0} bind .c {movefrog e 25 0} bind .c {movefrog n 0 -50} bind .c {movefrog s 0 50} } restart { init clear init scene init motion } } } # ---------------------------------------------------------------------- set tk_strictMotif 1 catch {destroy .c} canvas .c -width 250 -height 450 -highlightthick 0 catch {init clear} grid .c catch {wm title . "Frogger!"} catch {wm iconname . "Frogger"} catch {wm resizable . 0 0} catch {wm protocol . WM_DELETE_WINDOW {init clear; exit}} init scene init instructions