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 <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
Screenshots Section edit
gold added pix
