module Bounce where

import Tcl


-- Bounce: a simple bouncing ball demo
-- by Philip Healy

-- Writing at the tcl level in TclHaskell

bounce :: GUI ()
bounce =
     do top <- window' ".bounce" [] 
	title top "Bounce"
	tcl_ ["wm geometry .bounce 300x400"]
	tcl_ ["wm maxsize  .bounce 500 480"]
	tcl_ ["wm minsize  .bounce 100 100"]
	tcl_ ["canvas .bounce.c -width 500 -height 480 -background black"]
	tcl_ ["pack .bounce.c"]
	tcl_ [ball_proc]
	bimage <- tcl ["image create photo -file [file join images ball.gif]"]
	tcl_ ["set bounce_width  300"]
	tcl_ ["set bounce_height 400"]
	bind top "<Configure>" resize

	m <- menu' ".bounce.m" []
	mbutton m [wgt_label "Bounce speed",
			command bounce_speed,
			underline 0]
	mbutton m [wgt_label "Quit",
			command bounce_tidy,
			underline 0]

	bindXY top "<3>"      (popup m)

	bind top "<Alt-Key-b>" bounce_speed
	bind top "<Alt-Key-q>" bounce_tidy

	tcl_ ["set bounce_speed 2"]
	tcl_ ["ball 20 20 1 1", bimage]

	trapDeleteWindow top bounce_tidy


bounce_tidy :: GUI ()
bounce_tidy = tcl_ ["after cancel $bounce_after; destroy .bounce"]


ball_proc :: String
ball_proc = unlines
	["proc ball {xpos ypos xdis ydis ballimage} {"
	,"    global bounce_width bounce_height bounce_speed bounce_after"
	,"    "
        ,"    .bounce.c delete all"
	,"    .bounce.c create image $xpos $ypos -image $ballimage" 	
        ,"    if {$xpos >= [expr $bounce_width-17]} {"
	,"        set xdis -1"
	,"    }"
	,"    if {$xpos <= 17} {"
	,"        set xdis 1"
	,"    }"
	,"    set xpos [expr $xpos + $xdis]"
	,"    if {$ypos >= [expr $bounce_height-17]} {" 	
        ,"        set ydis -1"
	,"    }"
	,"    if {$ypos <= 17} {"
	,"        set ydis 1"
	,"    }"
	,"    set ypos [expr $ypos + $ydis]"
	,"    set bounce_after [after [expr $bounce_speed+1] \
	 \                       \"ball $xpos $ypos $xdis $ydis $ballimage\"]"
	,"}\n"
	]


resize :: GUI ()
resize =
     do tcl_ ["set bounce_width  [winfo width  .bounce]"]
	tcl_ ["set bounce_height [winfo height .bounce]"]


bounce_speed :: GUI ()
bounce_speed =
     do tcl_ ["destroy .bounce.speed"]
	t <- window' ".bounce.speed" []
	let scl = wpath t ++ ".scale"
	title t "Bounce Speed"
 	hscale' scl [sca_from 0, sca_to 25, sca_length 200,
			tickinterval 5,	"showvalue" %% "1",
			"variable" %% "bounce_speed"]
	tcl_ ["pack", scl]
