# story.tcl --
 #    Pilot project for programmed story telling:
 #    You type the story, mix in some commands and the story
 #    becomes animated with moving figures and the lot.
 #

 package require Tk

 # createStoryBoard --
 #    Create the main window with the story board
 #
 # Arguments:
 #    None
 # Result:
 #    None
 # Side effects:
 #    Set up of story board window
 #
 proc createStoryBoard {} {
    global widget

    #
    # Menubar (simple)
    #
    frame .menubar -relief raised -borderwidth 1
    pack  .menubar -side top -fill x

    menubutton .menubar.file        -text File   -menu .menubar.file.menu
    menu       .menubar.file.menu   -tearoff false
    .menubar.file.menu add command -label "New"      -command newStory
    .menubar.file.menu add command -label "Open ..." -command openStory
    .menubar.file.menu add separator
    .menubar.file.menu add command -label "Save" -command {saveStory 0}
    .menubar.file.menu add command -label "Save as ..." -command {saveStory 1}
    .menubar.file.menu add separator
    .menubar.file.menu add command -label Exit -command exit

    menubutton .menubar.help        -text Help     -menu .menubar.help.menu
    menu       .menubar.help.menu   -tearoff false
    .menubar.help.menu add command -label Overview -command showOverview

    pack       .menubar.file .menubar.help -side left

    frame .f
    text  .f.text -font "Courier 10" -width 40 -height 10 \
       -yscrollcommand {.f.y set} \
       -xscrollcommand {.f.x set}
    scrollbar .f.x -command {.f.text xview} -orient horizontal
    scrollbar .f.y -command {.f.text yview}

    grid .f.text .f.y -sticky ns
    grid .f.x    x    -sticky we

    set widget .f.text
    setupBindingsStoryBoard $widget

    frame  .f2
    button .f2.run   -text Run   -command runStory
    button .f2.pause -text Pause -command pauseStory
    grid   .f2.run .f2.pause -sticky we

    pack .f .f2 -side top -anchor nw
 }

 # createSceneWindow --
 #    Create the scene window
 #
 # Arguments:
 #    None
 # Result:
 #    None
 # Side effects:
 #    Set up of scene window
 #
 proc createSceneWindow {} {
    global cnv

    toplevel .scene
    wm title .scene "Scene"
    set cnv  .scene.canvas
    canvas   $cnv  -background white -width 300 -height 200
    pack     $cnv  -fill both

    #$cnv create rectangle 0 0 300 160 -fill blue -outline blue
    $cnv create oval 30 30 50 50 -fill yellow -outline yellow
    $cnv create line 0 160 300 160
 }

 # showOverview --
 #    Show a message window
 #
 # Arguments:
 #    None
 # Result:
 #    None
 # Side effects:
 #    Message window with help text
 #
 proc showOverview {} {
    global cnv

    toplevel .help
    wm title .help "Help"
    message  .help.msg -text "Story telling:\n
 Type your text and use \"@ commands\" to create
 figures and let them move"

    pack     .help.msg
 }

 # runStory --
 #    Run all the commands in a story
 #
 # Arguments:
 #    lineno      Line number to examine (optional)
 # Result:
 #    None
 # Side effects:
 #    Commands are run
 #
 proc runStory { {lineno 1} } {
    global cnv
    global widget

    if { [$widget compare $lineno.0 < end] } {
       set line [$widget get "$lineno.0" "$lineno.0 lineend"]

       #
       # Does it contain a @ (special story command)?
       if { [regexp {^ *@} $line] } {
          runStoryCommand [lrange $line 1 end]
       }

       after 250 [list runStory [incr lineno]]
    }
 }

 # setupBindingsStoryBoard --
 #    Set the special bindings for the story board
 #
 # Arguments:
 #    widget    Text widget to use
 # Result:
 #    None
 # Side effects:
 #    Bindings set up
 #
 proc setupBindingsStoryBoard { widget } {

    set front  "-background gray  -foreground red"
    set normal "-background white -foreground black"

    bind $widget <Key-Return> "+actUponKey %W %K"
   #bind $widget <Key-@>      "+actUponKey %W %K"

    $widget tag configure command \
       -background gray  -foreground red
   #$widget tag bind command <Any-Enter> "$widget tag configure command $front"
   #$widget tag bind command <Any-Leave> "$widget tag configure command $normal"
 }

 # actUponKey --
 #    Take action when a special key is pressed
 #
 # Arguments:
 #    widget    Text widget in question
 #    key       Key pressed (keysym)
 # Result:
 #    None
 # Side effects:
 #    Bindings set up
 #
 proc actUponKey { widget key } {

    #
    # If the key was "Return", then examine the current line
    #
    if { $key == "Return" } {
       set line [$widget get "insert linestart" "insert lineend"]

       #
       # Does it contain a @ (special story command)?
       if { [regexp {^ *@} $line] } {
          set tags [$widget tag names insert]
          if { [lsearch $tags command] == -1 } {
             $widget tag add command "insert linestart" "insert lineend"
          }

          #
          # Run the command
          #
          runStoryCommand [lrange $line 1 end]
       }
    }
 }

 # runStoryCommand --
 #    Run the given story command
 #
 # Arguments:
 #    args       Any number of commands
 # Result:
 #    None
 # Side effects:
 #    The side effects from the commands
 #
 # Note:
 #    We should probably examine the command before executing it!
 #    (use a save interpreter?)
 #
 proc runStoryCommand { args } {
    eval [join $args]
 }

 # house --
 #    Create a house (static object in the background)
 #
 # Arguments:
 #    pos        Position of the house
 #    colour     Its colour (distinguishing feature)
 # Result:
 #    None
 # Side effects:
 #    Object on the canvas drawn
 #
 proc house { pos colour } {
    global object
    global cnv

    set pos1    [expr {$pos-25}]
    set pos2    [expr {$pos+25}]
    set height1 100
    set height2  80

    set id \
       [$cnv create polygon $pos1 160 $pos1 $height1 $pos $height2 $pos2 \
           $height1 $pos2 160 $pos1 160 -outline black -fill $colour]
    $cnv lower $id
 }

 # puppet --
 #    Create a puppet (figure in the story) by name and colour
 #
 #
 # Arguments:
 #    name       Name of the puppet (becomes a command)
 #    colour     Its colour (distinguishing feature)
 # Result:
 #    None
 # Side effects:
 #    Entries in a global array set, commands $name defined
 #
 proc puppet { name colour } {
    global object
    global cnv

    set object($name,name)   $name
    set object($name,colour) $colour
    set object($name,state)  "stand"
    set object($name,dir)    5
    set object($name,pos)    0

   # $cnv create rectangle 0 160 10 130 -fill $colour -outline black -tag $name
    $cnv create line -2 160 5 140 12 160 -fill black -tag $name -width 2
    $cnv create line -6 140 5 125 16 140 -fill black -tag $name -width 2
    $cnv create oval 0 125 10 145 -fill $colour -outline black -tag $name
    $cnv create oval 2 125  7 120 -fill $colour -outline black -tag $name

    interp alias {} $name {} PuppetAct $name
 }

 # PuppetAct --
 #    Specific actions for a puppet
 #
 # Arguments:
 #    name       Name of the puppet
 #    action     Action to take
 #    args       Any arguments
 # Result:
 #    None
 # Side effects:
 #    Any defined by the action
 #
 proc PuppetAct { name action args } {
    global object
    global cnv
    global stop

    switch -- $action {
    "stops" { set stop 1 }
    "at"    {
       set newpos   [lindex $args 0]
       set displace [expr {$newpos-$object($name,pos)}]
       $cnv move $name $displace 0
       set object($name,pos) $newpos
    }
    "turns" { set object($name,dir) [expr {-$object($name,dir)}] }
    "walks" {
       set steps [lindex $args 0]
       if { $steps > 0 && $stop != 1 } {
          $cnv move $name $object($name,dir) 0
          incr object($name,pos) $object($name,dir)
          after 100 [list PuppetAct $name $action [incr steps -1]]
       }
       if { $stop == 1 } {
          set stop 0
       }
    }
    default { }
    }
 }

 # newStory --
 #    Remove all text and objects
 #
 # Arguments:
 #    None
 # Result:
 #    None
 # Side effects:
 #    Clean up the memory
 #
 proc newStory {} {
    global cnv
    global object
    global widget

    $cnv delete all
    #$cnv create rectangle 0 0 300 160 -fill blue -outline blue
    $cnv create oval 30 30 50 50 -fill yellow -outline yellow
    $cnv create line 0 160 300 160

    foreach {dummy name} [array get object "*,name"] {
       interp alias {} $name {}
    }

    $widget delete 1.0 end
 }

 # openStory --
 #    Read in an existing story
 #
 # Arguments:
 #    None
 # Result:
 #    None
 # Side effects:
 #    Filled in text widget
 #
 #
 proc openStory {} {
    global cnv
    global object
    global widget

    set filename [tk_getOpenFile -filetypes { {{Story files} {.sto} } }]

    if { $filename != "" } {
       newStory

       set infile [open $filename "r"]
       while { [gets $infile line] >= 0 } {
          if { [regexp {^ *@} $line] } {
             set tag command
          } else {
             set tag ""
          }
          $widget insert end $line $tag
          $widget insert end "\n"
       }
       close $infile
    }
 }

 # main --
 #    Main code to get it all going
 #
 global stop
 set stop 0

 createStoryBoard
 createSceneWindow