#!/usr/local/bin/wish -f

set bigfont "-adobe-helvetica-bold-r-normal-*-*-240-100-100-*-*-*-*"
set italicfont "-adobe-helvetica-bold-o-normal-*-*-240-100-100-*-*-*-*"
set courierfont "-adobe-courier-bold-r-normal-*-*-240-100-100-*-*-*-*"
set courieritalic "-adobe-courier-bold-o-normal-*-*-240-100-100-*-*-*-*"
set symbolfont "-adobe-symbol-medium-r-normal-*-*-240-100-100-*-*-*-*"

set cursor {@bigarrow.xbm bigarrowmask.xbm black white}

set currentslide 1

proc slide {title block} {
    global slidenum slidename slidepart slideparts

    incr slidenum
    set slidename($slidenum) $title
    proc slide${slidenum}p0 {title} $block
    set slidepart 0
    set slideparts($slidenum) 0
}

proc titledslide {title} {
    slide $title {drawtitle $title}
}

proc part {block} {
    global slidenum slidepart slideparts
    incr slidepart
    proc slide${slidenum}p${slidepart} {part} $block
    set slideparts($slidenum) $slidepart
}

proc drawtitle {t} {
    global bigfont
    global winw winh centerx
    .c create rectangle 30 30 [expr $winw - 10] 110 -fill black
    .c create rectangle 20 20 [expr $winw - 20] 100 -fill RoyalBlue3
    .c create text $centerx 60 -text $t -anchor center -font $bigfont -fill white -width [expr $winw - 60] -justify center
}

proc outlinelist {secs s} {
    global currentsection
    global bigfont winw

    set currentsection $s

    set y 150
    set x 100

    set sn 1

    foreach section $secs {
	.c create text $x $y -text $section -justify left -anchor w \
	    -width [expr $winw - 20 - $x] -font $bigfont -tags "section$sn section"
	incr y 75
	incr sn
    }

    .c create polygon 0 -6 40 -6 30 -20 \
	70 0 \
	30 20 40 6 0 6 -fill black -tags thearrow

    .c move thearrow 20 [expr 75 + 75 * $s]
    .c itemconfigure section$s -fill red
}

proc nextsection {} {
    global currentsection

    .c itemconfigure section$currentsection -fill black

    for { set i 0 } { $i < 25 } {incr i} {
	.c move thearrow 0 3
	update
    }

    incr currentsection

    .c itemconfigure section$currentsection -fill red

}

proc bulletenter {i t} {
    global bigfont

    set x 50
    set y [expr 100 + $i * 50]

    set b [bullet $x $y 50]

    foreach r {55 45 35 25 15 5} {bulletscale $x $y $r $b ; after 30 ; update }

    .c create text [expr $x + 20] $y -text $t \
	-anchor w -font $bigfont -fill black
}

proc bulletitem {i t} {
    global bigfont

    set x 50
    set y [expr 100 + $i * 50]

    set b [bullet $x $y 5]

    .c create text [expr $x + 20] $y -text $t \
	-anchor w -font $bigfont -fill black
}

proc centeritem {i t} {
    global centerx winw bigfont

    .c create text $centerx [expr 100 + $i * 50] -text $t \
	-anchor n -width [expr $winw - 60] -font $bigfont -fill black -justify center
}

proc bullet {x y rad} {
   return [.c create oval [expr $x - $rad] [expr $y - $rad] \
		[expr $x + $rad] [expr $y + $rad] -fill white ]
}

proc bulletscale {x y rad i} {
    .c coords $i [expr $x - $rad] [expr $y - $rad] \
	[expr $x + $rad] [expr $y + $rad]
}

proc starttext {} {
    global winh winw
    .c create window 20 130 -window .t -height [expr $winh - 160] -width [expr $winw - 40] -anchor nw
}

proc addtext {text} {
    global tstring
    set tstring $text
    .t configure -state normal
    addtext1 normal
    .t configure -state disabled
}

proc addtext1 {tag} {
    global tstring
    if {$tstring != "" } {
	set firstc [string index $tstring 0]
	switch $firstc {
	    "\\" {
		addwithtag $tag [string index $tstring 1]
		regsub {..} $tstring "" tstring
		addtext1 $tag
	    }
	    "\{" {
		regexp {[^ ]*} $tstring newtag
		regsub {\{} $newtag "" newtag
		regsub {[^ ]* } $tstring "" tstring
		addtext1 $newtag
		addtext1 $tag
	    }
	    "\}" {
		regsub {^\}} $tstring "" tstring
	    }
	    default {
		regexp {^[^\{\}]*} $tstring text
		regsub {^[^\{\}]*} $tstring "" tstring
		addwithtag $tag $text
		addtext1 $tag
	    }
	}
    }
}

proc addwithtag {tag text} {
    set start [.t index end]
    .t insert end $text
    foreach t [.t tag names $start] {
	.t tag remove $t $start end
    }
    .t tag add $tag $start end
    .t yview -pickplace end
}

proc fadeout {} {

    set a [.c create arc -100 -100 800 800 -fill grey]

    for { set e 20 } { $e < 360 } { incr e 20 } {
	.c itemconfigure $a -extent $e
	update
    }

}

proc setslide {s} {
    global slidename
    global slidenum currentslide currentpart
    global winw winh

    # delete all on the canvas

    .c delete withtag all

    # clear the text widget

    .t configure -state normal
    .t delete 1.0 end
    .t configure -state disabled

    # delete the .ex widget (and descendents) if present

    if [winfo exists .ex] {destroy .ex}
    
    eval slide${s}p0 {$slidename($s)}
    set currentslide $s
    set currentpart 0
}
proc prevslide {} { .s set [expr [.s get] - 1] }
proc nextslide {} { .s set [expr [.s get] + 1] }
proc nextpart {} {
    global currentpart currentslide slideparts
    incr currentpart
    if {$currentpart <= $slideparts($currentslide) } {
	eval slide${currentslide}p${currentpart} $currentpart
    } else {
	nextslide
    }
}

proc reload {f} {
    global slidenum currentslide
    set slidenum 0

    source $f

    .s config -to $slidenum

    setslide $currentslide
}

proc resizewin {} {
    global winw winh centerx centery
    global currentslide
    scan [wm geometry .] "%dx%d+%d+%d" winw winh x y

    set centerx [expr $winw / 2]
    set centery [expr $winh / 2]
}


wm minsize . 100 100
wm geometry . 1024x768

canvas .c -relief raised -bd 2 -background #ffe4c4 -cursor $cursor
#canvas .c -relief raised -bd 2 -background orange
frame .bf -cursor $cursor
scale .s -orient horiz -from 1 -showvalue no -command setslide -cursor $cursor
entry .e -state disabled -textvariable currentslide -width 3 -cursor $cursor
button .b -text "Next" -command "nextpart" -padx 3 -cursor $cursor
button .bq -text "Quit" -command "destroy ." -padx 3 -cursor $cursor

pack .c -side top -fill both -expand yes
pack .bf -side bottom -fill x

pack .bq -side left -in .bf
pack .s -side left -fill x -in .bf -expand yes
pack .b -side right -in .bf
pack .e -side right -in .bf -padx 5


text .t -wrap word -cursor $cursor
.t tag configure normal -font $bigfont
.t tag configure i -font $italicfont
.t tag configure tt -font $courierfont
.t tag configure tti -font $courieritalic
.t tag configure ttred -font $courierfont -foreground red
.t tag configure symbol -font $symbolfont

bind . <Control-c> "destroy ."

bind . <Right> {nextslide}
bind . <Key-space> {nextpart}
bind . <Left> {prevslide}

bind . <Control-r> {reload $slidefile ; puts reloaded}
bind . <Key-R> {reload $slidefile ; puts reloaded}

bind .c <Button-1> {focus [focus default]}
bind .t <Button-1> {focus [focus default]}

bind . <Configure> {resizewin ; setslide $currentslide}

focus default .

resizewin

if { $argc == 1 } {
    set slidefile [lindex $argv 0]
} else {
    set slidefile slides
}

reload $slidefile

# Local Variables:
# mode: tcl
# End:
