[Arjen Markus] (21 february 2003) As a kind of dual technique to [Literate programming] this page contains a script that allows a user to create a story with embedded commands. The whole thing is rather simple and actually silly. But try it to get a taste for the possibilities - I myself thought of reviewing chess plays (reusing Richard's page on chess), demonstrating [geometrical constructions] and so on. For starters, type in a few commands: @ puppet A green @ A walks 10 paces @ house 100 blue Then try the story below (save it in a file with extension ".sto") And above all: have fun and be creative! ---- This is a small example of a story: We introduce the characters: @ puppet A green @ puppet B red @ B at 123 and of course the houses in front of which the scene plays: @ house 100 gray75 @ house 140 gray50 @ house 180 lightblue @ house 220 lightblue Our first figure just happily strolls along. Our second figure is just standing @ A walks 40 paces Note: The following commands are available: - house pos colour - puppet name colour - name turns - name stops - name at pos - name walks number paces ----- # 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 "+actUponKey %W %K" #bind $widget "+actUponKey %W %K" $widget tag configure command \ -background gray -foreground red #$widget tag bind command "$widget tag configure command $front" #$widget tag bind command "$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 ---- ---- **Screenshots Section** [http://farm5.static.flickr.com/4096/4866119925_d581cce233_t.jpg] [http://farm5.static.flickr.com/4141/4866732802_99fe8d4662_z.jpg] [http://farm5.static.flickr.com/4096/4866119925_d581cce233.jpg] [gold] added pix ---- [[ [Category Toys] | [Category Animation] ]]